[Git][cmucl/cmucl][issue-111-fixes-for-motifd-clm] Unify naming of Core X11 and Xft2 fonts in CLM, use in INTERFACE.
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Sun Sep 19 21:05:32 UTC 2021
Raymond Toy pushed to branch issue-111-fixes-for-motifd-clm at cmucl / cmucl
Commits:
81d8160b by Raymond Toy at 2021-09-19T14:05:13-07:00
Unify naming of Core X11 and Xft2 fonts in CLM, use in INTERFACE.
The substance of this commit is the new file,
src/motif/lisp/fonts.lisp. This file contains a couple of trivial
models of Core X11 and fontconfig names, heuristics for telling them
apart, a convention for deciding the ambiguous cases, and a utility
that uses that convention to generate corresponding resource strings
for OpenMotif. For the moment the only exported interfaces are
GENERATE-HEURISTICATED-FONT-RESOURCES and a
user-customizable *AMBIGUOUS-FONT-DISPOSITION*, exported in
src/motif/lisp/initial.lisp. src/tools/clmcom.lisp is adjusted to
include fonts.lisp.
src/interface/interface.lisp take advantage of the new font naming
functionality, by calling GENERATE-HEURISTICATED-FONT-RESOURCES with
some tag names and new user-customizable font name variables to create
fallback resources. src/interface/initial.lisp exports those font name
variables.
- - - - -
5 changed files:
- src/interface/initial.lisp
- src/interface/interface.lisp
- + src/motif/lisp/fonts.lisp
- src/motif/lisp/initial.lisp
- src/tools/clmcom.lisp
Changes:
=====================================
src/interface/initial.lisp
=====================================
@@ -22,6 +22,8 @@
(:use "TOOLKIT" "LISP" "EXTENSIONS" "KERNEL")
(:shadow "CLASS-DIRECT-SUPERCLASSES")
(:export "*INTERFACE-STYLE*" "+HEADER-TAG+" "+ITALIC-TAG+"
+ "*DEFAULT-FONT-NAME*" "*HEADER-FONT-NAME*" "*ITALIC-FONT-NAME*"
+ "*AMBIGUOUS-FONT-DISPOSITION*"
"USE-GRAPHICS-INTERFACE" "VERIFY-SYSTEM-SERVER-EXISTS"
"CREATE-INTERFACE-SHELL" "POPUP-INTERFACE-PANE"
"CREATE-INTERFACE-PANE-SHELL" "FIND-INTERFACE-PANE"
=====================================
src/interface/interface.lisp
=====================================
@@ -64,6 +64,13 @@
(defconstant +header-tag+ "header")
(defconstant +italic-tag+ "italic")
+;; Default fonts. Users are allowed to customize these. Note that
+;; changing them only takes effect the next time these interface
+;; programs start a fresh motifd process.
+(defvar *default-font-name* "Helvetica-12:Regular")
+(defvar *header-font-name* "Helvetica-12:Bold")
+(defvar *italic-font-name* "Helvetica-12:Italic")
+
;;;; Functions for dealing with interface widgets
@@ -74,7 +81,10 @@
(let ((con (xt::open-motif-connection
*default-server-host* *default-display*
"lisp" "Lisp"
- nil ;; fallback resources go here.
+ (generate-heuristicated-font-resources
+ (list "" +header-tag+ +italic-tag+)
+ (list *default-font-name* *header-font-name*
+ *italic-font-name*))
(and *system-motif-server*
(ext:process-pid *system-motif-server*)))))
(with-motif-connection (con)
=====================================
src/motif/lisp/fonts.lisp
=====================================
@@ -0,0 +1,646 @@
+;;;; -*- Mode: Lisp ; Package: Toolkit -*-
+
+(ext:file-comment "$Header: src/motif/lisp/fonts.lisp $")
+
+;;; fonts.lisp -- some machinery for unifying the naming of
+;;; traditional Core X11 Fonts with Xft2 fonts. Conceptually almost
+;;; all of this this file is not specific to CLM (it's mostly parsing
+;;; and some invented heuristics/conventions that could be useful in
+;;; X11 context), but it currently only models the minimum properties
+;;; of font names necessary to generate the resource specifications
+;;; OpenMotif uses to configure fonts. However, the interfaces in this
+;;; file were designed to permit retrofitting in a richer model
+;;; non-disruptively.
+
+(in-package "TOOLKIT")
+
+;; For reasons that'll be explained as we go, we need to parse (or at
+;; least validate) font name strings. Here's the base class for
+;; parsing errors.
+(define-condition font-name-parse-error (parse-error)
+ ((kind :initarg :kind :reader font-name-parse-error-kind)
+ (string :initarg :string :reader font-name-parse-error-string)
+ (index :initarg :index :reader font-name-parse-error-index)
+ (description :initarg :description
+ :reader font-name-parse-error-description))
+ (:default-initargs :kind nil :description nil)
+ (:documentation "Class of error signaled when a string can't be parsed as a font name.")
+ (:report
+ (lambda (error stream)
+ (format stream
+ "Parsing ~S as a font-name~@[ according to ~A syntax~] ended at ~D~@[ ~A~]."
+ (font-name-parse-error-string error)
+ (font-name-parse-error-kind error)
+ (font-name-parse-error-index error)
+ (font-name-parse-error-description error)))))
+
+;; As mentioned, this file currently only offers a trivial model of
+;; font specifications. The representation of parsed font names is
+;; *not* part of the interface, and subject to change. To insulate
+;; prospective clients from that detail, here are some types.
+(deftype core-font-name ()
+ "Instances of this type are for use with the Core X11 Font system."
+ '(satisfies core-font-name-p))
+(deftype xlfd-name ()
+ "Subtype of CORE-FONT-NAME for XLFD names."
+ '(satisfies xlfd-name-p))
+(deftype fontconfig-name ()
+ "Instances of this type are for use with the Xft2 font system."
+ '(satisfies fontconfig-name-p))
+
+;; Core X11 Font names are just strings, ultimately transmitted to the
+;; X server for resolution. In general core fonts' names are strings
+;; that are opaque to clients. We'll wrap them in an object for
+;; discrimination, and let DEFSTRUCT define the predicate we use for
+;; the DEFTYPE above.
+(defstruct (core-font-name (:type vector) :named (:copier nil))
+ (string "" :type string :read-only t))
+
+;; Core X11 Font names can be in XLFD format, but they might
+;; not be (e.g., aliases are unlikely to be in XLFD format). Here's
+;; the XLFD spec:
+
+;; https://www.x.org/releases/X11R7.6/doc/xorg-docs/specs/XLFD/xlfd.html
+
+;; For now, we don't really need a detailed parse of an XLFD, but
+;; we'll pretend as if we've got one. In fact our parser will merely
+;; validate the string and then cons up an object for which we've got
+;; a predicate.
+(defstruct (xlfd-name (:type vector) :named (:copier nil)
+ (:include core-font-name)))
+
+(define-condition xlfd-name-parse-error
+ (font-name-parse-error)
+ ()
+ (:default-initargs :kind "XLFD"))
+
+;; A proper XLFD has 14 hyphens, so 15 fields (inclusive of the
+;; registry, which must be the empty string).
+(defconstant +xlfd-field-count+ 15)
+
+;; Even though we don't really need a structured XLFD parse, our
+;; heuristics require code for validating well-formedness of an XLFD
+;; (14 hyphens, optionally excluding wildcards). JUNK-ALLOWED follows
+;; the ANSI CL convention. WILDCARD-ALLOWED is just a convenience. It
+;; seems that Xorg and Xquartz treat subsets of well-formed XLFDs as
+;; usable font names, so this also supports a keyword to make it okay
+;; to have fewer than 15 fields).
+(defun parse-xlfd-name (string &key (start 0) end
+ junk-allowed subsequence-allowed
+ wildcard-allowed)
+ "Parse STRING bounded by START and END as an X Logical Font
+Description. If parsing succeeds, return an object for which
+XLFD-NAME-P returns true and the index at which parsing
+ended. Exceptional conditions: if STRING has a registry but doesn't
+have enough fields (13), then signal an error if SUBSEQUENCE-ALLOWED
+is false (the default); if string contains a delimiter after the 13th
+field, signal an error if JUNK-ALLOWED is false (the default). If
+SUBSEQUENCE-ALLOWED is true or JUNK-ALLOWED is true, then return NIL
+and the index at which parsing stopped. If WILDCARD-ALLOWED is
+false (the default), wildcard characters will cause parsing to end at
+the first wildcard character (and so the consequences will depend on
+JUNK-ALLOWED); otherwise, wildcard characters will be treated as field
+contents."
+ (setq end (or end (length string)))
+ (let ((index start) (field-count 0))
+ (labels
+ (;; This is the only way out of PARSE-XLFD-NAME. It
+ ;; implements all the SUBSEQUENCE-ALLOWED and JUNK-ALLOWED
+ ;; logic. Callers can supply arguments to enrich the error
+ ;; report, though it's not the caller's job to decide whether
+ ;; we've succeeded or not.
+ (finish-parsing (&rest error-description)
+ (if (and (or (= field-count +xlfd-field-count+)
+ (and (plusp field-count) subsequence-allowed))
+ (or (= index end) junk-allowed))
+ (return-from parse-xlfd-name
+ (values
+ (make-xlfd-name
+ :string (subseq string start index))
+ index))
+ (error 'xlfd-name-parse-error
+ :string (subseq string start end)
+ :index (- index start)
+ :description
+ (apply #'format nil
+ (if error-description
+ error-description
+ (if (< field-count
+ +xlfd-field-count+)
+ (list "with too few fields (~D)"
+ field-count)
+ '("with trailing junk")))))))
+ (next-token ()
+ (loop
+ (when (= index end)
+ (return))
+ (when (> (- index start) 255)
+ (finish-parsing "due to length limits"))
+ (let ((char (char string index)))
+ (cond
+ ;; Fields must be ISO-8859-1 strings.
+ ((> (char-code char) 255)
+ (finish-parsing "due to non-ISO-8859-1 character, ~@C" char))
+ ;; Explicitly disallowed in field values.
+ ((char= #\" char)
+ (finish-parsing "due to a double-quote"))
+ ;; Conditionally allowed.
+ ((and (find (char string index) '(#\? #\*))
+ (not wildcard-allowed))
+ (finish-parsing "due to wildcard character, ~@C" char))
+ ;; Field delimiter character, unescapable.
+ ((char= #\- char)
+ (return))
+ (t (incf index)))))
+ (progn (incf field-count)
+ (values index
+ ;; Leave INDEX at END when we're at end of string
+ (when (< index end)
+ (prog1 (char string index)
+ (incf index)))))))
+ (unless (< index end)
+ (finish-parsing "because the bounded string was empty"))
+ (let ((registry-end (next-token)))
+ (when (> registry-end start)
+ (finish-parsing "due to unsupported font name registry ~S"
+ (subseq string start registry-end))))
+ (loop
+ (let ((delimiter (nth-value 1 (next-token))))
+ (when (= field-count +xlfd-field-count+)
+ (when delimiter
+ (decf index))
+ (finish-parsing))
+ (when (null delimiter)
+ (finish-parsing)))))))
+
+;; Several test cases for PARSE-XLFD-NAME.
+#+(or)
+(macrolet
+ ((test-okay (results string &rest args)
+ `(assert (equalp (ignore-errors
+ (multiple-value-list
+ (parse-xlfd-name ,string , at args)))
+ ',(if results
+ results
+ (list (vector 'core-font-name string 'xlfd-name)
+ (length string))))))
+ (test-fail (msg string &rest args &aux (result (gensym)) (error (gensym)))
+ `(multiple-value-bind (,result ,error)
+ (ignore-errors
+ (multiple-value-list
+ (parse-xlfd-name ,string , at args)))
+ (assert (null ,result))
+ (assert (typep ,error 'xlfd-name-parse-error))
+ ,(when msg
+ `(assert (search ',msg (princ-to-string ,error)))))))
+ (test-okay nil "--------------")
+ ;; By default, an XLFD with fewer than 14 hyphens is an error.
+ (test-fail nil "--------")
+ ;; But :SUBSEQUENCE-ALLOWED T will make it allowed.
+ (test-okay nil "--------" :subsequence-allowed t)
+ ;; By default, a string that has more than 14 fields is an error
+ (test-fail nil "--------------nope-")
+ ;; But :JUNK-ALLOWED T will make it allowed.
+ (test-okay (#(core-font-name "--------------nope" xlfd-name)
+ 18)
+ "--------------nope" :junk-allowed t)
+ ;; By default, wildcards are disallowed.
+ (test-fail nil "-*-------------")
+ (test-okay nil "-*-------------" :wildcard-allowed t)
+ (test-fail nil "--------------*")
+ (test-okay nil "--------------*" :wildcard-allowed t))
+
+;; Xft2 doesn't strictly have its own font names; it uses fontconfig
+;; for naming. Fontconfig has a syntax for specifying fonts; here's
+;; the spec for that:
+
+;; https://www.freedesktop.org/software/fontconfig/fontconfig-user.html
+
+;; For Motif-y reasons explained below, we must parse a few properties
+;; out of fontconfig names. We'll ignore properties we don't care
+;; about. We'll use the same basic idea as above: a lightweight
+;; representation of the stuff we need, a PARSE-ERROR subclass, and a
+;; parsing function.
+(defstruct (fontconfig-name (:type vector) :named (:copier nil))
+ (foundry nil :type (or null string) :read-only t)
+ (family "" :type string :read-only t)
+ ;; TODO: SIZE is really a number, but the fontconfig spec doesn't
+ ;; document the number format, so for the moment it's a string.
+ ;; Probably this ought to get fixed before contemplating exporting
+ ;; the accessor name.
+ (size nil :type (or null string) :read-only t)
+ (weight nil :type (or null string) :read-only t)
+ (slant nil :type (or null string) :read-only t)
+ ;; This isn't a proper part of a model of a fontconfig name, just an
+ ;; internal trick for the heuristics that follow.
+ (has-properties-p nil :type boolean :read-only t))
+
+(define-condition fontconfig-name-parse-error
+ (font-name-parse-error)
+ ()
+ (:default-initargs :kind "fontconfig"))
+
+;; This routine attempts to implement a fairly strict idea of
+;; well-formedness for fontconfig specs. Any functional disagreement
+;; with fontconfig over the domain of well-formed fontconfig names is
+;; a bug. (fontconfig's matching of strings that aren't well-formed
+;; fontconfig names is none of our business.)
+(defun parse-fontconfig-name (string &key (start 0) end junk-allowed)
+ (setq end (or end (length string)))
+ (let (foundry family size weight slant has-properties-p
+ (index start) part-end)
+ (labels
+ (;; This is the only way out of
+ ;; PARSE-FONTCONFIG-NAME.
+ (finish-parsing (&rest error-description)
+ (if (or (= part-end end) junk-allowed)
+ (return-from parse-fontconfig-name
+ (values
+ (when family
+ (make-fontconfig-name
+ :family family :foundry foundry :size size
+ :weight weight :slant slant
+ :has-properties-p
+ (or has-properties-p slant weight foundry)))
+ ;; Parsing always ends at the index of the end of
+ ;; the part of the name that parsed, even if there's
+ ;; junk after.
+ part-end))
+ (error 'fontconfig-name-parse-error
+ :string (subseq string start end)
+ :index (- index start)
+ :description (when error-description
+ (apply #'format nil error-description)))))
+ ;; Parse the next token starting at INDEX, delimited by any
+ ;; character in DELIMITERS. Note that the family and any
+ ;; property value use backslash to escape the delimiter, but
+ ;; the size and property name are not documented as allowing
+ ;; an escape character. Returns a non-empty token, the
+ ;; delimiter that ended the token, and the delimiter's index.
+ (next-token (delimiters &optional (escapep t))
+ (do ((chars)
+ (char (and (< index end) (char string index))
+ (and (< index end) (char string index))))
+ ((or (null char) (find char delimiters))
+ (multiple-value-prog1
+ (values (when chars
+ (coerce (nreverse chars) 'string))
+ char
+ index)
+ (incf index)))
+ (when (and escapep (char= #\\ char))
+ (when (= index end)
+ (finish-parsing "after the escape character"))
+ (incf index)
+ (setq char (char string index)))
+ (push char chars)
+ (incf index)))
+ ;; The fontconfig spec doesn't say whether names & their
+ ;; components are matched case-sensitively or
+ ;; case-insensitively. It seems as if it's insensitive, but
+ ;; let's factor it here just in case.
+ (string-equiv (s1 s2)
+ (string-equal s1 s2)))
+ (let (delimiter token-end)
+ (multiple-value-setq (family delimiter token-end)
+ (next-token '(#\- #\:)))
+ (when (null family)
+ (finish-parsing "without any family"))
+ ;; fontconfig names allow for a comma-separated list of
+ ;; families. TODO: check if Motif can handle such lists.
+ ;; Pending that, make it an error to find a comma in the name.
+ ;; This is a defect in this parser.
+ (when (find #\, family)
+ (finish-parsing "with an unsupported syntax (list of families))"))
+ ;; If we're here, the family is acceptable, so we've reached
+ ;; the end of this part. Save it for FINISH-PARSING.
+ (setq part-end token-end)
+ (when (eql #\- delimiter)
+ (multiple-value-setq (size delimiter token-end)
+ (next-token '(#\:) nil))
+ ;; TODO, maybe: validate that SIZE parses as a number. (But
+ ;; first figure out what the number syntax is; the
+ ;; fontconfig spec doesn't say.)
+ (unless size
+ (finish-parsing "with a hyphen")))
+ ;; TODO: check if Motif supports lists of sizes.
+ ;; This is a defect in this parser.
+ (when (find #\, size)
+ (finish-parsing "with an unsupported syntax (list of sizes))"))
+ (setq part-end token-end)
+ (when (eql #\: delimiter) ;There are properties to parse.
+ (let (name value tmp-end)
+ (loop
+ (setq part-end token-end)
+ ;; We must not set TOKEN-END until we know we've parsed
+ ;; a whole property. So we'll use TMP-END.
+ (multiple-value-setq (name delimiter tmp-end)
+ (next-token '(#\= #\:) nil))
+ (if (null name)
+ (ecase delimiter
+ (#\=
+ (finish-parsing "with an empty property name"))
+ (#\:
+ (finish-parsing "with an empty property"))
+ ((nil)
+ (finish-parsing "with a colon")))
+ (ecase delimiter
+ (#\=
+ (multiple-value-setq (value delimiter tmp-end)
+ (next-token '(#\:)))
+ (when (null value)
+ (finish-parsing "with an empty property value"))
+ (setq token-end tmp-end
+ has-properties-p t)
+ ;; These are the only properties we care about.
+ (cond ((string-equiv name "weight")
+ (setq weight value))
+ ((string-equiv name "slant")
+ (setq slant value))
+ ((string-equiv name "foundry")
+ (setq foundry value))))
+ ((#\: nil)
+ ;; In this case, the property might be a
+ ;; "symbolic constant" The fontconfig spec says
+ ;; "there are symbolic constants that
+ ;; simultaneously indicate both a name and a
+ ;; value", but it's not clear what those
+ ;; constants are. We'll assume that any
+ ;; construct is both syntactically valid here.
+ (setq token-end tmp-end
+ has-properties-p t)
+ ;; We need to recognize whatever symbolic
+ ;; constants are defined for the weight and
+ ;; slant properties. These are taken from the
+ ;; description of the <const> element of the
+ ;; configuration file format, in case that's
+ ;; what's intended in the fontconfig spec.
+ (cond ((member name
+ '("thin"
+ "extralight"
+ "ultralight"
+ "light"
+ "demilight"
+ "semilight"
+ "book"
+ "regular"
+ "normal"
+ "medium"
+ "demibold"
+ "semibold"
+ "bold"
+ "extrabold"
+ "black"
+ "heavy")
+ :test #'string-equiv)
+ (setq weight name))
+ ((member name
+ '("roman"
+ "italic"
+ "oblique"
+ "ultracondensed"
+ "extracondensed"
+ "condensed"
+ "semicondensed"
+ "normal"
+ "semiexpanded"
+ "expanded"
+ "extraexpanded"
+ "ultraexpanded")
+ :test #'string-equiv)
+ (setq slant name))))))))))
+ (finish-parsing))))
+
+;; Some test cases for PARSE-FONTCONFIG-NAME.
+#+(or)
+(macrolet
+ ((test-okay (results string &rest args)
+ `(assert (equalp (ignore-errors
+ (multiple-value-list
+ (parse-fontconfig-name ,string , at args)))
+ ',(if (listp results)
+ results
+ (list results (length string))))))
+ (test-fail (msg string &rest args &aux (result (gensym)) (error (gensym)))
+ `(multiple-value-bind (,result ,error)
+ (ignore-errors
+ (multiple-value-list
+ (parse-fontconfig-name ,string , at args)))
+ (assert (null ,result))
+ (assert (typep ,error 'fontconfig-name-parse-error))
+ ,(when msg
+ `(assert (search ',msg (princ-to-string ,error)))))))
+ ;; Just a name
+ (test-okay #(fontconfig-name nil "Foo" nil nil nil nil) "Foo")
+ ;; Name and size
+ (test-okay #(fontconfig-name nil "Foo" "12" nil nil nil) "Foo-12")
+ ;; This fully specifies everything we care about.
+ (test-okay #(fontconfig-name "Bar" "Foo" "12" "bold" "italic" t)
+ "Foo-12:foundry=Bar:slant=italic:weight=bold")
+ ;; Same as previous, but with extra junk (which should be ignored).
+ (test-okay #(fontconfig-name "Bar" "Foo" "12" "bold" "italic" t)
+ "Foo-12:abc=def:foundry=Bar:xyz=123:slant=italic:weight=bold")
+ ;; Test recognition of symbolic constants for weight and slant.
+ (test-okay #(fontconfig-name nil "Foo" "12" "bold" "italic" t)
+ "Foo-12:italic:bold")
+ ;; Test recognition that a font has properties (even if we don't
+ ;; know what they are).
+ (test-okay #(fontconfig-name nil "Foo" "12" nil nil t)
+ "Foo-12:bar=baz")
+ ;; Test various invalid (I think) things.
+ (test-fail "with a hyphen" "Foo-")
+ (test-fail "with a colon" "Foo:")
+ (test-fail "with a colon" "Foo-12:")
+ (test-fail "empty property" "Foo::")
+ (test-fail "empty property" "Foo-12::")
+ (test-fail "empty property name" "Foo:=bar")
+ (test-fail "empty property value" "Foo:bar="))
+
+;; Now that we have font name parsers, let's build a convention for
+;; figuring out when to apply them. Every octet string up to length
+;; 255 is a syntactically valid Core X11 Font name; and fontconfig
+;; appears not to care whether its input strings are well-formed
+;; fontconfig names. So in principle all strings (modulo length and
+;; encoding) might be "usable" as a font names in either system.
+;;
+;; However, in practice, most Core X11 Fonts have XLFD names, and
+;; fontconfig's behavior is more predictable when its inputs are
+;; well-formed and detailed fontconfig names. Therefore, it seems
+;; reasonable to build up some heuristics:
+;;
+;; 1. a string that starts with a hyphen is an XLFD (fontconfig name
+;; can't start with hyphens).
+;;
+;; 2. a string that's a well-formed fontconfig name containing a colon
+;; is a fontconfig name (colons don't seem much used in Core X11 Font
+;; names).
+;;
+;; Here are two helper routines that implement those heuristics. Note
+;; that these two don't partition all strings, e.g., "Times" or
+;; "Helvetica-12" won't satisfy either predicate. We'll address those
+;; "ambiguous" cases below.
+(defun xlfdp (thing)
+ "Returns true if THING represents an X Logical Font Description, either
+as an XLFD string or the parse of one."
+ (etypecase thing
+ (xlfd-name
+ ;; Note that objects that satisfy this predicate might have been
+ ;; created by PARSE-XLFD-NAME calls with non-default
+ ;; flags, and so may not be well-formed XLFDs on their own. If
+ ;; the user had the context to do that, then we're not going to
+ ;; overrule the decision.
+ thing)
+ (string (nth-value
+ 0
+ (ignore-errors
+ (parse-xlfd-name
+ thing
+ ;; These initargs are arbitrary, but appear to agree
+ ;; with what my X server seems to consider acceptable
+ ;; arguments to XOpenFont.
+ :junk-allowed nil :subsequence-allowed t
+ :wildcard-allowed t))))))
+
+(defun fontconfigp (thing)
+ "Returns true in case THING is probably a fontconfig name:
+either a parsed fontconfig name, or a string that parses to a
+fontconfig name having explicit properties."
+ (etypecase thing
+ (fontconfig-name
+ thing)
+ (string
+ (let ((thing (ignore-errors
+ (parse-fontconfig-name thing))))
+ (when (and thing (fontconfig-name-has-properties-p thing))
+ thing)))))
+
+;; So now we've got heuristic detection of XLFD and fontconfig
+;; names. Disambiguating other strings in isolation is inherently
+;; arbitrary. However, when we've got an opportunity to look at a set
+;; of strings, we can disambiguate using context: let's assume that if
+;; any string is an XLFD, then all ambiguous strings are meant as Core
+;; X11 Font names; that if any string is a well-formed fontconfig name
+;; with properties, then all ambiguous strings are also for Xft2; that
+;; if all strings are ambiguous, we'll fallthru to consulting a
+;; variable.
+(defvar *ambiguous-font-disposition* :xft2)
+(declaim (type (member :xft2 :core) *ambiguous-font-disposition*))
+
+;; Finally, it seems that using Core X11 Fonts with Xft2 fonts within
+;; a single RenderTable that doesn't work in OpenMotif circa 2021. (I
+;; couldn't figure it out, anyhow.) And maybe nobody would want to do
+;; so anyway. So for now we'll rule out mix-and-match scenarios.
+(defun heuristicate-font-name-types (names)
+ (assert (every #'stringp names))
+ (flet ((parse-as-core-fonts ()
+ (mapcar #'(lambda (spec)
+ (or (xlfdp spec) (make-core-font-name :string spec)))
+ names))
+ (parse-as-xft2-fonts ()
+ (mapcar #'parse-fontconfig-name names)))
+ (cond ((some #'xlfdp names)
+ (when (some #'fontconfigp names)
+ (error "Can't mix fontconfig and Core X11 font names."))
+ (parse-as-core-fonts))
+ ((some #'fontconfigp names)
+ (when (some #'xlfdp names)
+ (error "Can't mix fontconfig and Core X11 font names."))
+ (parse-as-xft2-fonts))
+ (t (ecase *ambiguous-font-disposition*
+ (:core (parse-as-core-fonts))
+ (:xft2 (parse-as-xft2-fonts)))))))
+
+;; Here's the OpenMotif-specific bit. Now that we can heuristically
+;; classify a list of fonts, we can pair up tags with heuristicated
+;; font names in order to generate OpenMotif resource strings suitable
+;; for either fallback resources or writing into X resource files.
+(defun generate-heuristicated-font-resources
+ (tags fonts &key application-name application-class)
+ "Generate a list of OpenMotif RenderTable & Rendition resources
+associating FONTS with TAGS. If APPLICATION-NAME or APPLICATION-CLASS
+is supplied, the resource keys will be prefixed by that string;
+otherwise, the resource key will start with the loose binding
+operator, asterisk."
+ (declare (type list tags fonts)
+ (type (or null string) application-name application-class))
+ (let ((ntags (length tags))
+ (nfonts (length fonts)))
+ (assert (= ntags nfonts) (tags fonts)
+ "Too ~:[many~;few~] tags (~A) for fonts (~A)."
+ (> ntags nfonts) tags fonts))
+ (let ((name/class (or application-name application-class)))
+ (nconc
+ (mapcan
+ (lambda (tag spec)
+ (let* ((rendition (if (or (string= "" tag) (null tag))
+ ;; Accept NIL or "" as a the default
+ ;; tag. Default tags' resources are
+ ;; resources of the RenderTable itself.
+ "renderTable"
+ ;; Non-default tags get used as resource
+ ;; names.
+ tag)))
+ ((lambda (resources)
+ (loop for (resname resval) on resources by #'cddr
+ collect (format nil "~@[~A~]*~A.~A: ~A"
+ name/class rendition resname resval)))
+ ;; Core fonts are specified by 2 resource name/value pairs.
+ ;; Xft2 fonts are specified by 4 such pairs.
+ (if (core-font-name-p spec)
+ (list "fontName" (core-font-name-string spec)
+ "fontType" "FONT_IS_FONT")
+ (list* "fontName" (fontconfig-name-family spec)
+ "fontType" "FONT_IS_XFT"
+ (nconc
+ (when (fontconfig-name-foundry spec)
+ (list "foundryName" (fontconfig-name-foundry spec)))
+ (when (fontconfig-name-size spec)
+ (list "fontSize" (fontconfig-name-size spec)))
+ (when (or (fontconfig-name-weight spec)
+ (fontconfig-name-slant spec))
+ (list "fontStyle"
+ (format nil "~:[~@[~A~]~;~:*~A~@[ ~A~]~]"
+ (fontconfig-name-weight spec)
+ (fontconfig-name-slant spec))))))))))
+ tags (heuristicate-font-name-types fonts))
+ (list (format nil "~@[~A~]*renderTable: ~{~A~^ ~}"
+ name/class
+ (remove "" tags))))))
+
+;; Test cases for GENERATE-HEURISTICATED-FONT-RESOURCES.
+#+(or)
+(assert
+ (equal
+ ;; These are the Core X11 Fonts that the CLM Debugger/Inspector have
+ ;; used.
+ (let ((fonts '("-adobe-helvetica-medium-r-normal--*-120-75-*"
+ "-adobe-helvetica-bold-r-normal--*-120-75-*"
+ "-adobe-helvetica-medium-o-normal--*-120-75-*"))
+ (tags '("" "header" "italic")))
+ (generate-heuristicated-font-resources tags fonts))
+ '("*renderTable.fontName: -adobe-helvetica-medium-r-normal--*-120-75-*"
+ "*renderTable.fontType: FONT_IS_FONT"
+ "*header.fontName: -adobe-helvetica-bold-r-normal--*-120-75-*"
+ "*header.fontType: FONT_IS_FONT"
+ "*italic.fontName: -adobe-helvetica-medium-o-normal--*-120-75-*"
+ "*italic.fontType: FONT_IS_FONT" "*renderTable: header italic")))
+
+#+(or)
+(assert
+ (equal
+ ;; Here are some fontconfig names.
+ (let ((fonts '("Sans-12:regular"
+ "Sans-12:bold"
+ "Sans-12:italic"
+ "Sans-12:bold:italic"))
+ (tags '("" "header" "italic" "foo")))
+ (generate-heuristicated-font-resources tags fonts))
+ '("*renderTable.fontName: Sans" "*renderTable.fontType: FONT_IS_XFT"
+ "*renderTable.fontSize: 12" "*renderTable.fontStyle: regular"
+ "*header.fontName: Sans" "*header.fontType: FONT_IS_XFT"
+ "*header.fontSize: 12" "*header.fontStyle: bold"
+ "*italic.fontName: Sans" "*italic.fontType: FONT_IS_XFT"
+ "*italic.fontSize: 12" "*italic.fontStyle: italic"
+ "*foo.fontName: Sans" "*foo.fontType: FONT_IS_XFT"
+ "*foo.fontSize: 12" "*foo.fontStyle: bold italic"
+ "*renderTable: header italic foo")))
=====================================
src/motif/lisp/initial.lisp
=====================================
@@ -220,7 +220,8 @@
"IS-APPLICATION-SHELL" "IS-COMPOSITE" "IS-CONSTRAINT" "IS-OBJECT"
"IS-OVERRIDE-SHELL" "IS-RECT-OBJ" "IS-SHELL" "IS-TOP-LEVEL-SHELL"
"IS-TRANSIENT-SHELL" "IS-VENDOR-SHELL" "IS-W-M-SHELL"
- "XT-WIDGET-PARENT"))
+ "XT-WIDGET-PARENT" "*AMBIGUOUS-FONT-DISPOSITION*"
+ "GENERATE-HEURISTICATED-FONT-RESOURCES"))
=====================================
src/tools/clmcom.lisp
=====================================
@@ -48,6 +48,7 @@
"target:motif/lisp/callbacks"
"target:motif/lisp/widgets"
; "target:motif/lisp/timer-support"
+ "target:motif/lisp/fonts"
"target:motif/lisp/main"))
(defparameter interface-files
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/81d8160b79e78ebd9821ed555324628627d2277c
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/81d8160b79e78ebd9821ed555324628627d2277c
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20210919/101dc1f5/attachment-0001.html>
More information about the cmucl-cvs
mailing list