[COMMIT] Improve style, #'fc-name-parse-harder.

Steve, I saw the ;; #### May need generalization to other separators? comment and took that as a prompt to work on the function. A break from merging the bytecomp code. It’s frustrating that FcNameParse is still failing when handed a charset attribute that has just been returned by FcNameUnparse. I’m sure you reported the bug back in the day. I’ve just skimmed the fontconfig source and it doesn’t look particularly unfixable. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1407316765 -3600 # Wed Aug 06 10:19:25 2014 +0100 # Node ID 2dee57a2c2d6579c30cc5cc74181cd42a3873bf5 # Parent 8139bdf8db044f7bbd89b4c7e7bde26da6fb6b99 Improve style, #'fc-name-parse-harder. lisp/ChangeLog addition: 2014-08-06 Aidan Kehoe <kehoea(a)parhasard.net&gt; * fontconfig.el (fc-name-parse-harder): Improve style here, don't re-implement #'split-string-by-char with its ESCAPE-CHAR argument, look for a string prefix in a list of candidates in a more CL-idiomatic way, use the language's features for boolean or. diff -r 8139bdf8db04 -r 2dee57a2c2d6 lisp/ChangeLog --- a/lisp/ChangeLog Sun Aug 03 20:25:03 2014 +0100 +++ b/lisp/ChangeLog Wed Aug 06 10:19:25 2014 +0100 ＠＠ -1,3 +1,11 ＠＠ +2014-08-06 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * fontconfig.el (fc-name-parse-harder): + Improve style here, don't re-implement #'split-string-by-char with + its ESCAPE-CHAR argument, look for a string prefix in a list of + candidates in a more CL-idiomatic way, use the language's features + for boolean or. + 2014-07-14 Aidan Kehoe <kehoea(a)parhasard.net&gt; * simple.el (raw-append-message): diff -r 8139bdf8db04 -r 2dee57a2c2d6 lisp/fontconfig.el --- a/lisp/fontconfig.el Sun Aug 03 20:25:03 2014 +0100 +++ b/lisp/fontconfig.el Wed Aug 06 10:19:25 2014 +0100 ＠＠ -538,55 +538,46 ＠＠ Unlike `fc-parse-name', unparseable objects are skipped and reported in the *Warnings* buffer. \(The *Warnings* buffer is popped up unless all of the unparsed objects are listed in `fc-name-parse-known-problem-attributes'.)" - (labels ((repair-embedded-colons (l) - ;; #### May need generalization to other separators? - (let ((ll l)) - (while (cdr l) - (when (string-match ".*\\\\$" (cadr l)) - (setcdr l (cons (concat (cadr l) ":" (caddr l)) (cdddr l)))) - (setq l (cdr l))) - ll)) - (prepare-omits (object) - (declare (special display)) - (let* ((reports fc-name-parse-known-problem-attributes) - (report (car reports)) - (display-this t)) - (while reports - (if (string= report (subseq object 0 (length report))) - (setq object (concat "(KNOWN) " object) - display-this nil - reports nil) - (setq report (pop reports)))) - (push display-this display) - (concat object "\n"))) - (any (bools) - (let (ret) - (while bools - (setq ret (or (pop bools) ret)))))) - (let* ((objects (repair-embedded-colons (split-string fontname ":"))) - (name (pop objects)) - (omits nil) - (outcomes (list 'dummy))) - (while objects - (let ((object (pop objects))) - (condition-case nil - (let ((try (concat name ":" object))) - (fc-name-parse try) - (setq name try)) - (invalid-argument - (push object omits))))) + (let* ((objects (split-string-by-char fontname ?: ?\\)) + name omits display) + (labels ((prefixp (haystack needle) + "Return non-nil if HAYSTACK starts with NEEDLE." + (not (mismatch haystack needle :end1 (length needle)))) + (prepare-omit (object) + (setq display + (or (if (find object + fc-name-parse-known-problem-attributes +:test #'prefixp) + (progn + (setq object (concat "(KNOWN) " object)) + ;; This attribute is known, don't display the + ;; error based on it alone. + nil) + ;; Attribute is not known. + t) + ;; Otherwise, if we're already decided we need to + ;; show them, respect that. + display)) + object) + (fontconfig-quote (string) + (mapconcat #'identity (split-string-by-char string ?:) #r"\:"))) + (when (find ?: objects :test #'position) + (setq objects (mapcar #'fontconfig-quote objects))) + (setq name (pop objects)) + (dolist (object objects) + (condition-case nil + (let ((try (concat name ":" object))) + (fc-name-parse try) + (setq name try)) + (invalid-argument (push object omits)))) (when omits - (setq display nil) - (setq omits (mapconcat #'prepare-omits omits "")) - (lwarn 'fontconfig (if (apply #'any display) 'warning 'info) - "Some objects in fontname weren't parsed (details in *Warnings*). + (setq omits (mapconcat #'prepare-omit omits "\n")) + (lwarn 'fontconfig (if display 'warning 'info) + "Some objects in fontname weren't parsed (details in *Warnings*). This shouldn't affect your XEmacs except that the font may be inaccurate. Please report any unparseable objects below not marked as KNOWN with -M-x report-xemacs-bug. Objects:\n%sFontname:\n%s" - omits - fontname)) - (fc-name-parse name) - ))) +M-x report-xemacs-bug. Objects:\n%sFontname:\n%s" omits fontname)) + (fc-name-parse name)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -- ‘Liston operated so fast that he once accidentally amputated an assistant’s fingers along with a patient’s leg, […] The patient and the assistant both died of sepsis, and a spectator reportedly died of shock, resulting in the only known procedure with a 300% mortality.’ (Atul Gawande, NEJM, 2012) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches