GitLab

at 2021-09-19T14:03:38-07:00

Expunge all FontList usage, replace with CompoundString tags.

20 or so Widget constructor calls included a :FONT-LIST initarg, which
had the effect of superseding Xt-based configuration mechanisms (e.g.,
X resource files). This turns out to have been unnecessary, since
Motif's XmString type includes tags whose purpose is to direct text
styling.

This commit simply rips out all Font Lists while ensuring that every
place a FontList was used instead uses a CompoundString with an
appropriate tag, one of "header" or "italic".

Given those tags, it becomes possible to achieve all the previous
styling effects just using Xt/Motif machinery, e.g. by putting
something like one or the other of the below examples into the user's
~/.Xdefaults or an app-defaults file named "Lisp".

(A subseqent commit will arrange for these defaults to get set as
fallback resources when the GUI starts up, so that no external
resources file will be needed, and so that users who prefer to
configure things from within Lisp can do so.)

Sample .Xdefaults content; use one or the other, not both.

!! Core X11 Fonts
!!
!! First, setup the defaults for the RenderTable.
!!
Lisp*renderTable.fontName: -adobe-helvetica-medium-r-normal--*-120-75-*
Lisp*renderTable.fontType: FONT_IS_FONT
!!
!! Define a rendition called "header", and specify its font.
!!
Lisp*header.fontName:  -adobe-helvetica-bold-r-normal--*-120-75-*
Lisp*header.fontType: FONT_IS_FONT
!!
!! Define a rendition called "italic", and specify its font.
!!
Lisp*italic.fontName: -adobe-helvetica-medium-o-normal--*-120-75-*
Lisp*italic.fontType: FONT_IS_FONT
!!
!! Add these renditions to the RenderTable
!!
!Lisp*renderTable:  header italic
!! EOF

!! Xft2
!! This is similar to the above, except that each Xft2 font
!! requires two extra resources, fontStyle and fontSize.
!!
!! First, setup the defaults for the RenderTable.
!!
Lisp*renderTable.fontName: Helvetica
Lisp*renderTable.fontStyle: Medium
Lisp*renderTable.fontSize: 12
Lisp*renderTable.fontType: FONT_IS_XFT
!!
!! Define a rendition called "header", and specify its font.
!!
Lisp*header.fontName: Helvetica
Lisp*header.fontStyle: Bold
Lisp*header.fontType: FONT_IS_XFT
Lisp*header.fontSize: 12
!!
!! Define a rendition called "italic", and specify its font.
!!
Lisp*italic.fontName: Helvetica
Lisp*italic.fontSize: 12
Lisp*italic.fontStyle: Italic
Lisp*italic.fontType: FONT_IS_XFT
!!
!! Add these renditions to the RenderTable
!!
Lisp*renderTable:  header italic
!! EOF

@@ -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")))

@@ -21,7 +21,7 @@
  (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+"
  	   "USE-GRAPHICS-INTERFACE" "VERIFY-SYSTEM-SERVER-EXISTS"
  	   "CREATE-INTERFACE-SHELL" "POPUP-INTERFACE-PANE"
  	   "CREATE-INTERFACE-PANE-SHELL" "FIND-INTERFACE-PANE"
@@ -29,4 +29,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"))

@@ -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))

@@ -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,17 @@
    "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")
++
  ;;;; Functions for dealing with interface widgets
@@ -78,19 +80,7 @@
  	(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)
@@ -110,7 +100,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))))
@@ -193,17 +182,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
@@ -633,11 +622,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
@@ -646,11 +636,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
@@ -662,13 +653,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
@@ -694,13 +685,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

@@ -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"

Raymond Toy pushed to branch issue-111-fixes-for-motifd-clm at cmucl / cmucl

Commits:

6 changed files:

Changes:

@@ -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