diff --git a/src/interface/debug.lisp b/src/interface/debug.lisp index 42b52ecdc3c7be3c0bd1eaaee21e784b1122a8b9..fecb5684605599f174df490acbf3c17348c2cc98 100644 --- a/src/interface/debug.lisp +++ b/src/interface/debug.lisp @@ -157,9 +157,10 @@ (di:do-debug-function-variables (v debug-fun) (unless any-p (setf any-p t) - (push (create-label frame-view "localsLabel" - :font-list *header-font* - :label-string "Local variables:") + (push (with-compound-strings ((label-string "Local variables:" + +header-tag+)) + (create-label frame-view "localsLabel" + :label-string label-string)) widgets)) (when (eq (di:debug-variable-validity v location) :valid) (let ((value (di:debug-variable-value v frame)) @@ -176,23 +177,23 @@ (cond ((not any-p) (push - (create-label frame-view "noLocals" - :font-list *italic-font* - :label-string - " No local variables in function.") + (with-compound-strings + ((label-string " No local variables in function." +italic-tag+)) + (create-label frame-view "noLocals" + :label-string label-string)) widgets)) ((not any-valid-p) (push - (create-label frame-view "noValidLocals" - :font-list *italic-font* - :label-string - " All variables have invalid values.") + (with-compound-strings + ((label-string " All variables have invalid values." +italic-tag+)) + (create-label frame-view "noValidLocals" + :label-string label-string)) widgets)))) - (push (create-label frame-view "noVariableInfo" - :font-list *italic-font* - :label-string - " No variable information available.") + (push (with-compound-strings + ((label-string " No variable information available." +italic-tag+)) + (create-label frame-view "noVariableInfo" + :label-string label-string)) widgets)) (apply #'manage-children widgets))) @@ -203,9 +204,9 @@ ;;; (defun debug-display-frame-prompt (frame frame-view) (let* ((form (create-form frame-view "promptForm")) - (label (create-label form "framePrompt" - :label-string "Frame Eval:" - :font-list *header-font*)) + (label (with-compound-strings ((label "Frame Eval:" +header-tag+)) + (create-label form "framePrompt" + :label-string label))) (entry (create-text form "frameEval" :top-attachment :attach-widget :top-widget label @@ -254,9 +255,9 @@ :callback 'frame-view-callback :client-data (di:debug-function-function debug-fun))) - (slabel (create-label frame-view "sourceLabel" - :font-list *header-font* - :label-string "Source form:")) + (slabel (with-compound-strings ((label "Source form:" +header-tag+)) + (create-label frame-view "sourceLabel" + :label-string label))) (swindow (create-scrolled-window frame-view "frameSourceWindow" :scrolling-policy :automatic :scroll-bar-placement :bottom-right)) @@ -378,12 +379,13 @@ '(("Close All Frames" close-all-callback) ("Dump Backtrace" dump-backtrace-callback) ("Quit Debugger" quit-debugger-callback)))) - (errlabel (create-label form "errorLabel" - :top-attachment :attach-widget - :top-widget menu-bar - :left-attachment :attach-form - :font-list *header-font* - :label-string "Error Message:")) + (errlabel (with-compound-strings + ((label "Error Message:" +header-tag+)) + (create-label form "errorLabel" + :top-attachment :attach-widget + :top-widget menu-bar + :left-attachment :attach-form + :label-string label))) (errmsg (create-label form "errorMessage" :top-attachment :attach-widget :top-widget errlabel @@ -392,8 +394,7 @@ (rlabel (create-label form "restartLabel" :top-attachment :attach-widget :top-widget errmsg - :left-attachment :attach-form - :font-list *header-font*)) + :left-attachment :attach-form)) (restarts (create-row-column form "debugRestarts" :adjust-last nil :top-attachment :widget @@ -401,12 +402,12 @@ :left-attachment :attach-form :right-attachment :attach-form :left-offset 10)) - (btlabel (create-label form "backtraceLabel" - :label-string "Stack Backtrace:" - :font-list *header-font* - :top-attachment :attach-widget - :top-widget restarts - :left-attachment :attach-form)) + (btlabel (with-compound-strings ((label "Stack Backtrace:" +header-tag+)) + (create-label form "backtraceLabel" + :label-string label + :top-attachment :attach-widget + :top-widget restarts + :left-attachment :attach-form))) (btwindow (create-scrolled-window form "backtraceWindow" :scrolling-policy :automatic :scroll-bar-placement :bottom-right @@ -431,9 +432,11 @@ (if *debug-restarts* (progn - (set-values rlabel :label-string "Restarts:") + (with-compound-strings ((label "Restarts:" +header-tag+)) + (set-values rlabel :label-string label)) (debug-display-restarts restarts)) - (set-values rlabel :label-string "No restarts available")) + (with-compound-strings ((label "No restarts available" +header-tag+)) + (set-values rlabel :label-string label))) (let ((quick-stack (create-highlight-button backtrace "quickStack" "Display Stack"))) diff --git a/src/interface/initial.lisp b/src/interface/initial.lisp index 44a24921168075a34346c033b5ee3b1ac297c3a5..c62efee6aff103a92ffb6ea6d6449f554f8d1e3a 100644 --- a/src/interface/initial.lisp +++ b/src/interface/initial.lisp @@ -21,7 +21,9 @@ (defpackage "INTERFACE" (:use "TOOLKIT" "LISP" "EXTENSIONS" "KERNEL") (:shadow "CLASS-DIRECT-SUPERCLASSES") - (:export "*HEADER-FONT*" "*ITALIC-FONT*" "*ENTRY-FONT*" "*INTERFACE-STYLE*" + (: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" @@ -29,4 +31,4 @@ "SET-VALUE-BOX" "WITH-WIDGET-CHILDREN" "INTERFACE-ERROR" "PRINT-FOR-WIDGET-DISPLAY" "WITH-BUSY-CURSOR" "CREATE-INTERFACE-MENU" "CREATE-CACHED-MENU" - "GRAB-OUTPUT-AS-STRING" "*ALL-FONTS*" "LISP-CONTROL-PANEL")) + "GRAB-OUTPUT-AS-STRING" "LISP-CONTROL-PANEL")) diff --git a/src/interface/inspect.lisp b/src/interface/inspect.lisp index 46de6bae6571e110997a8766c3ae9cb1b97eaf93..63ecbb7aaa22e4f78a523db7d78b48aaa8e9be02 100644 --- a/src/interface/inspect.lisp +++ b/src/interface/inspect.lisp @@ -77,10 +77,10 @@ (declare (ignore widget call-data)) (multiple-value-bind (form shell) (create-form-dialog pane "evalDialog") - (let* ((s1 (compound-string-create "Eval: " "HeaderFont")) + (let* ((s1 (compound-string-create "Eval: " +header-tag+)) (s2 (compound-string-create (format nil "[~a]" (print-for-widget-display "~S" object)) - "EntryFont")) + "")) (s3 (compound-string-concat s1 s2)) (done (create-push-button-gadget form "evalDone" :label-string "Done" @@ -98,7 +98,6 @@ (prompt (create-label-gadget form "evalPrompt" :bottom-attachment :attach-widget :bottom-widget entry - :font-list *all-fonts* :label-string s3)) (output (create-text form "evalOutput" :edit-mode :multi-line-edit @@ -208,14 +207,16 @@ ,``(("Eval Expression" popup-eval-callback ,pane ,,object) ("Close Pane" destroy-pane-callback ,,object) ("Close All Panes" close-all-callback)))) - (title (create-label-gadget - over-form "inspectTitle" - :label-string (inspector-pane-title ,object) - :font-list *header-font* - :top-attachment :attach-widget - :top-widget menu-bar - :left-attachment :attach-form - :right-attachment :attach-form)) + (title (with-compound-strings ((label-string + (inspector-pane-title ,object) + +header-tag+)) + (create-label-gadget + over-form "inspectTitle" + :label-string label-string + :top-attachment :attach-widget + :top-widget menu-bar + :left-attachment :attach-form + :right-attachment :attach-form))) (form (create-form over-form "inspectForm" :left-attachment :attach-form :right-attachment :attach-form @@ -424,15 +425,17 @@ :left-attachment :attach-form :right-attachment :attach-form :orientation :horizontal)) - (slabel (create-label-gadget controls "sequenceStartLabel" - :font-list *header-font* - :label-string "Start:")) + (slabel (with-compound-strings ((label-string + "Start:" +header-tag+)) + (create-label-gadget controls "sequenceStartLabel" + :label-string label-string))) (start (create-text controls "sequenceStart" :value "0" :columns 4)) - (clabel (create-label-gadget controls "sequenceCountLabel" - :font-list *header-font* - :label-string "Count:")) + (clabel (with-compound-strings ((label-string + "Count:" +header-tag+)) + (create-label-gadget controls "sequenceCountLabel" + :label-string label-string))) (count (create-text controls "sequenceCount" :value "5" :columns 4)) @@ -442,9 +445,10 @@ :left-attachment :attach-form :right-attachment :attach-form :orientation :horizontal)) - (flabel (create-label-gadget filter "sequenceFilterLabel" - :font-list *header-font* - :label-string "Filter:")) + (flabel (with-compound-strings ((label-string + "Filter:" +header-tag+)) + (create-label-gadget filter "sequenceFilterLabel" + :label-string label-string))) (fexp (create-text filter "sequenceFilterExp" :value "T")) (apply (create-push-button-gadget filter "sequenceFilterApply" :label-string "Apply")) @@ -491,9 +495,9 @@ (manage-child rc))))) (defun show-slot-list (object slot-list view allocp label) - (let ((label (create-label-gadget view "slotLabel" - :label-string label - :font-list *header-font*)) + (let ((label (with-compound-strings ((label-string label +header-tag+)) + (create-label-gadget view "slotLabel" + :label-string label-string))) (widgets)) (dolist (slotd slot-list) (with-slots ((slot pcl::name) (allocation pcl::allocation)) diff --git a/src/interface/interface.lisp b/src/interface/interface.lisp index 86d382535cb0e23798829d7be7bba49f864a4d62..bffc5b9b1460a5b30ccc8d247eedbb242f864f2c 100644 --- a/src/interface/interface.lisp +++ b/src/interface/interface.lisp @@ -22,15 +22,6 @@ ;;;; Globally defined variables -(defparameter entry-font-name "-adobe-helvetica-medium-r-normal--*-120-75-*") -(defparameter header-font-name "-adobe-helvetica-bold-r-normal--*-120-75-*") -(defparameter italic-font-name "-adobe-helvetica-medium-o-normal--*-120-75-*") - - -(defvar *header-font*) -(defvar *italic-font*) -(defvar *entry-font*) -(defvar *all-fonts*) (defvar *system-motif-server* nil) @@ -62,6 +53,24 @@ "This specifies the default interface mode for the debugger and inspector. The allowable values are :GRAPHICS and :TTY.") +;; Tags for compound strings' rendering of non-default text. Compound +;; strings' tags are the keys Motif uses to look up style info in +;; RenderTables. Tags are part of the "public" interface to +;; customizing the GUI, so they're constants. We define them as +;; (constant) variables here to avoid the possibility of typographical +;; errors at call sites (typos would not be detectable errors; they'd +;; simply be tags that aren't keys in any RenderTables). They're +;; exported from INTERFACE only because the CLM debugger needs them. +(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 @@ -72,24 +81,16 @@ (let ((con (xt::open-motif-connection *default-server-host* *default-display* "lisp" "Lisp" + (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) (setf (xti:motif-connection-close-hook *motif-connection*) #'close-connection-hook) - (setf *header-font* - (build-simple-font-list "HeaderFont" header-font-name)) - (setf *italic-font* - (build-simple-font-list "ItalicFont" italic-font-name)) - (setf *entry-font* - (build-simple-font-list "EntryFont" entry-font-name)) - (setf *all-fonts* - (build-font-list `(("EntryFont" ,entry-font-name) - ("HeaderFont" ,header-font-name) - ("ItalicFont" ,italic-font-name)))) - - (let ((shell (create-application-shell - :default-font-list *entry-font*))) + (let ((shell (create-application-shell))) (setf *lisp-interface-panes* (make-hash-table)) (setf *lisp-interface-menus* (make-hash-table :test #'equal)) (setf *lisp-interface-connection* con) @@ -109,7 +110,6 @@ (pane (or existing (create-popup-shell "interfacePaneShell" :top-level-shell shell - :default-font-list *entry-font* :keyboard-focus-policy :pointer :title title :icon-name title)))) @@ -192,17 +192,17 @@ :margin-height 0 :margin-width 0 :orientation :horizontal)) - (label (create-label rc "valueLabel" - :font-list *header-font* - :label-string name)) + (label (with-compound-strings ((name name +header-tag+)) + (create-label rc "valueLabel" + :label-string name))) (button (if activep (create-highlight-button rc "valueObject" (print-for-widget-display "~S" value)) - (create-label rc "valueObject" - :font-list *italic-font* - :label-string - (format nil "~A" value))))) + (with-compound-strings + ((value (format nil "~A" value) +italic-tag+)) + (create-label rc "valueObject" + :label-string value))))) (manage-children label button) (when (and callback activep) (add-callback button :activate-callback @@ -632,11 +632,12 @@ :bottom-attachment :attach-form :right-attachment :attach-position :right-position 50)) - (prompt (create-label form "inspectPrompt" - :top-attachment :attach-widget - :top-widget menu-bar - :font-list *header-font* - :label-string "Inspect new object:")) + (prompt (with-compound-strings ((prompt + "Inspect new object:" +header-tag+)) + (create-label form "inspectPrompt" + :top-attachment :attach-widget + :top-widget menu-bar + :label-string prompt))) (entry (create-text form "inspectEval" :top-attachment :attach-widget :top-widget prompt @@ -645,11 +646,12 @@ :left-attachment :attach-form :right-attachment :attach-widget :right-widget vsep)) - (hlabel (create-label form "inspectHistoryLabel" - :top-attachment :attach-widget - :top-widget entry - :font-list *header-font* - :label-string "Inspector History:")) + (hlabel (with-compound-strings ((prompt + "Inspector History:" +header-tag+)) + (create-label form "inspectHistoryLabel" + :top-attachment :attach-widget + :top-widget entry + :label-string prompt))) (hview (create-scrolled-list form "inspectHistory" :visible-item-count 5 :left-offset 4 @@ -661,13 +663,13 @@ :right-attachment :attach-widget :right-widget vsep :bottom-attachment :attach-form)) - (flabel (create-label form "filesLabel" - :left-attachment :attach-widget - :left-widget vsep - :top-attachment :attach-widget - :top-widget menu-bar - :label-string "Files:" - :font-list *header-font*)) + (flabel (with-compound-strings ((prompt "Files:" +header-tag+)) + (create-label form "filesLabel" + :left-attachment :attach-widget + :left-widget vsep + :top-attachment :attach-widget + :top-widget menu-bar + :label-string prompt))) (frc (create-row-column form "filesButtons" :packing :pack-column :num-columns 2 @@ -693,13 +695,13 @@ :left-offset 4 :right-offset 4 :bottom-offset 4)) - (alabel (create-label form "aproposLabel" - :label-string "Apropos:" - :font-list *header-font* - :left-attachment :attach-widget - :left-widget vsep - :bottom-attachment :attach-widget - :bottom-widget apropos)) + (alabel (with-compound-strings ((prompt "Apropos:" +header-tag+)) + (create-label form "aproposLabel" + :label-string prompt + :left-attachment :attach-widget + :left-widget vsep + :bottom-attachment :attach-widget + :bottom-widget apropos))) (hsep (create-separator form "separator" :left-attachment :attach-widget :left-widget vsep diff --git a/src/motif/lisp/fonts.lisp b/src/motif/lisp/fonts.lisp new file mode 100644 index 0000000000000000000000000000000000000000..3802b247bdae10528b42e0f5d43672e582db178a --- /dev/null +++ b/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 ,@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 ,@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 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 ,@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 ,@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"))) diff --git a/src/motif/lisp/initial.lisp b/src/motif/lisp/initial.lisp index 968198fd23c4303830d2793eb6ec413de58f1604..41fe30e4218cf163e2c058a5240b203467358d5e 100644 --- a/src/motif/lisp/initial.lisp +++ b/src/motif/lisp/initial.lisp @@ -139,7 +139,7 @@ "TEXT-CALLBACK-FORMAT" "*DEBUG-MODE*" "*DEFAULT-SERVER-HOST*" "*CLM-BINARY-DIRECTORY*" "*CLM-BINARY-NAME*" "*DEFAULT-DISPLAY*" "QUIT-APPLICATION" "WITH-MOTIF-CONNECTION" - "RUN-MOTIF-APPLICATION" "WITH-CLX-REQUESTS" + "RUN-MOTIF-APPLICATION" "WITH-CLX-REQUESTS" "WITH-COMPOUND-STRINGS" "BUILD-SIMPLE-FONT-LIST" "BUILD-FONT-LIST" "*MOTIF-CONNECTION*" "*X-DISPLAY*" "WIDGET" "XMSTRING" "FONT-LIST" "SET-VALUES" "GET-VALUES" "CREATE-MANAGED-WIDGET" "CREATE-WIDGET" @@ -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")) diff --git a/src/motif/lisp/interface-glue.lisp b/src/motif/lisp/interface-glue.lisp index 9480c568a274d776d8adea834d8284457c9d1547..b2ebf10672d4b004095f3592e2c207e630ae9235 100644 --- a/src/motif/lisp/interface-glue.lisp +++ b/src/motif/lisp/interface-glue.lisp @@ -146,7 +146,7 @@ (sleep 1)) (setf *local-motif-server* process)))) -(defun open-motif-connection (host dpy-name app-name app-class &optional pid) +(defun open-motif-connection (host dpy-name app-name app-class &optional fallback-resources pid) (declare (simple-string app-name app-class)) (unless (or host pid) (verify-local-server-exists)) @@ -170,6 +170,7 @@ (toolkit-write-value greeting display) (toolkit-write-value greeting app-name) (toolkit-write-value greeting app-class) + (toolkit-write-value greeting fallback-resources :string-table) (transmit-message greeting socket) (destroy-message greeting) diff --git a/src/motif/lisp/main.lisp b/src/motif/lisp/main.lisp index 75c46bbceb1eba29131f344b7784fe7995d056c7..57815bb35f6075ad9caa802d90e5a43fa21893c3 100644 --- a/src/motif/lisp/main.lisp +++ b/src/motif/lisp/main.lisp @@ -89,6 +89,16 @@ (popdown target)) (popdown widget))) +;; Another randomly placed useful thing. +(defmacro with-compound-strings ((&rest specs) &body body) + `(let ,(mapcar + (lambda (spec) + `(,(car spec) + (compound-string-create ,(cadr spec) (or ,(caddr spec) "")))) + specs) + (unwind-protect (progn ,@body) + ,@(mapcar (lambda (spec) `(compound-string-free ,(car spec))) specs)))) + ;;;; A convenient (and CLM compatible) way to start Motif applications @@ -100,11 +110,13 @@ (application-name "lisp") (server-host *default-server-host*) (display *default-display*) - (sync-clx *debug-mode*)) + (sync-clx *debug-mode*) + (fallback-resources)) (declare (ignore sync-clx)) (let ((connection (open-motif-connection server-host display application-name - application-class))) + application-class + fallback-resources))) (with-motif-connection (connection) (apply init-function init-args)) connection)) diff --git a/src/motif/server/datatrans.c b/src/motif/server/datatrans.c index e9f960ebae56053e1ba93bdc32fee9d9989ee4ee..471b0121698ddc49fe3e8e303f9810d585110379 100644 --- a/src/motif/server/datatrans.c +++ b/src/motif/server/datatrans.c @@ -491,10 +491,13 @@ void message_read_string_table(message_t m,StringTable *items,int tag,int len) int i; items->length = len; - items->data = (char **)XtMalloc( len*sizeof(char *) ); + /* We make this 1 larger than len in case the caller needs a + NULL-terminated string list, and always NULL-terminate. */ + items->data = (char **)XtMalloc( (1+len)*sizeof(char *) ); register_garbage(items->data,GarbageData); for(i=0;idata[i]),XtRString); + items->data[len] = NULL; } void message_read_xm_string_table(message_t m,StringTable *items, diff --git a/src/motif/server/server.c b/src/motif/server/server.c index fe0b22488ce38a359cd93bef8ccd44ea942102f7..fc4cfae4072ae241786a7d2c60dfc0e8a4f232f2 100644 --- a/src/motif/server/server.c +++ b/src/motif/server/server.c @@ -105,6 +105,7 @@ void greet_client(int socket) { short byte; int result; char *dpy_name,*app_class,*app_name; + StringTable fallback_resources; message_t first; /* Read byte-swap thing */ @@ -129,6 +130,10 @@ void greet_client(int socket) { toolkit_read_value(first,&app_name,XtRString); toolkit_read_value(first,&app_class,XtRString); + toolkit_read_value(first,&fallback_resources,XtRStringTable); + if (fallback_resources.length > 0) + XtAppSetFallbackResources(app_context, fallback_resources.data); + global_app_class = XtNewString(app_class); global_app_name = XtNewString(app_name); diff --git a/src/tools/clmcom.lisp b/src/tools/clmcom.lisp index 0241a264820ee7bd36881a9e87e3449e14a3b8f3..c546348a9745023f64b4e8a8c656017e94706bd5 100644 --- a/src/tools/clmcom.lisp +++ b/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