- cmucl-cvs - mailman3.common-lisp.net

[Git][cmucl/cmucl][issue-119-ci-osx-install-fails] Use /opt/local/bin/git
by Raymond Toy (＠rtoy) 17 Oct '21

17 Oct '21

Raymond Toy pushed to branch issue-119-ci-osx-install-fails at cmucl / cmucl Commits: 6215f6a9 by Raymond Toy at 2021-10-17T16:43:32-07:00 Use /opt/local/bin/git The osx:ansi-test fails with this message: ``` $ git clone https://gitlab.common-lisp.net/cmucl/ansi-test.git Cloning into 'ansi-test'... fatal: unable to access 'https://gitlab.common-lisp.net/cmucl/ansi-test.git/': SSL certificate problem: certificate has expired ``` But I don't know why. I can run this manually using /usr/bin/git and /opt/local/bin/git without running into the problem. Trying /opt/local/bin/git to see if it helps. - - - - - 1 changed file: - .gitlab-ci.yml Changes: ===================================== .gitlab-ci.yml ===================================== @@ -161,8 +161,8 @@ osx:ansi-test: - job: osx:build artifacts: true before_script: - - git clone https://gitlab.common-lisp.net/cmucl/ansi-test.git - - (cd ansi-test; git checkout rtoy-cmucl-expected-failures) + - /opt/local/bin/git clone https://gitlab.common-lisp.net/cmucl/ansi-test.git + - (cd ansi-test; /opt/local/bin/git checkout rtoy-cmucl-expected-failures) script: - cd ansi-test - make LISP="../dist/bin/lisp -batch -noinit -nositeinit" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6215f6a957ee25b97ed5297… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/6215f6a957ee25b97ed5297… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-119-ci-osx-install-fails
by Raymond Toy (＠rtoy) 17 Oct '21

17 Oct '21

Raymond Toy pushed new branch issue-119-ci-osx-install-fails at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-119-ci-osx-install-… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] Update release notes from changes up to 2021/09/22
by Raymond Toy (＠rtoy) 22 Sep '21

22 Sep '21

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 2e3b90ff by Raymond Toy at 2021-09-22T15:09:27-07:00 Update release notes from changes up to 2021/09/22 - - - - - 1 changed file: - src/general-info/release-21e.md Changes: ===================================== src/general-info/release-21e.md ===================================== @@ -43,8 +43,11 @@ public domain. * ~~#98~~ fstpd is not an Intel instruction; disassemble as `fstp dword ptr [addr]` * ~~#100~~ ldb prints out unicode base-chars correctly instead of just the low 8 bits. * ~~#103~~ RANDOM-MT19937-UPDATE assembly routine still exists + * ~~#104~~ Single-stepping broken (fixed via #97). * ~~#107~~ Replace u_int8_t with uint8_t * ~~#108~~ Update ASDF + * ~~#112~~ CLX can't connect to X server via inet sockets + * ~~#113~~ REQUIRE on contribs can pull in the wrong things vai ASDF. * Other changes: * Improvements to the PCL implementation of CLOS: * Changes to building procedure: View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2e3b90ff9cc84de876fd993… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/2e3b90ff9cc84de876fd993… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #112: Update CLX sources of 2021-09-19 and support inet sockets
by Raymond Toy (＠rtoy) 20 Sep '21

20 Sep '21

Raymond Toy pushed to branch master at cmucl / cmucl Commits: d2c70ec2 by Raymond Toy at 2021-09-20T23:11:06+00:00 Fix #112: Update CLX sources of 2021-09-19 and support inet sockets - - - - - 263e9398 by Raymond Toy at 2021-09-20T23:11:07+00:00 Merge branch 'clx-update-2021-09-19' into 'master' Fix #112: Update CLX sources of 2021-09-19 and support inet sockets Closes #112 See merge request cmucl/cmucl!80 - - - - - 14 changed files: - src/clx/README.md - src/clx/attributes.lisp - src/clx/buffer.lisp - src/clx/clx.asd - src/clx/clx.lisp - src/clx/demo/clclock.lisp - src/clx/demo/clx-demos.lisp - src/clx/demo/mandel.lisp - src/clx/demo/menu.lisp - src/clx/dep-allegro.lisp - src/clx/dep-lispworks.lisp - src/clx/depdefs.lisp - src/clx/dependent.lisp - src/clx/display.lisp The diff was not included because it is too large. View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a47dbed7928a613539647b… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a47dbed7928a613539647b… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch clx-update-2021-09-19
by Raymond Toy (＠rtoy) 20 Sep '21

20 Sep '21

Raymond Toy pushed new branch clx-update-2021-09-19 at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/clx-update-2021-09-19 You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][master] 2 commits: Fix #113: Search cmucl modules and libraries first
by Raymond Toy (＠rtoy) 20 Sep '21

20 Sep '21

Raymond Toy pushed to branch master at cmucl / cmucl Commits: 3824d74a by Raymond Toy at 2021-09-20T21:54:32+00:00 Fix #113: Search cmucl modules and libraries first - - - - - a47dbed7 by Raymond Toy at 2021-09-20T21:54:33+00:00 Merge branch 'issue-113-prefer-cmucl-modules' into 'master' Fix #113: Search cmucl modules and libraries first Closes #113 See merge request cmucl/cmucl!78 - - - - - 2 changed files: - src/code/module.lisp - src/i18n/locale/cmucl.pot Changes: ===================================== src/code/module.lisp ===================================== @@ -37,8 +37,13 @@ (defvar *require-verbose* t "*load-verbose* is bound to this before loading files.") +(defvar *cmucl-provider-functions* + '(module-provide-cmucl-defmodule module-provide-cmucl-library) + "Provider functions for cmucl modules and libraries. These are + searched first before trying *module-provider-functions*") + (defvar *module-provider-functions* - '(module-provide-cmucl-defmodule module-provide-cmucl-library) + nil "See function documentation for REQUIRE") ;;;; Defmodule. @@ -102,11 +107,6 @@ \"contrib-games-feebs\", \"contrib-hist\", \"contrib-psgraph\", \"contrib-ops\", \"contrib-embedded-c\", \"contrib-sprof\", and \"contrib-packed-sse2\". " - ;; First, load asdf if it's not already loaded. This is needed to - ;; load easily the contribs that use asdf. There are no contribs - ;; that use defsystem, so we won't autoload defsystem. - (unless (featurep :asdf) - (load "modules:asdf/asdf")) (let ((saved-modules (copy-list *modules*)) (module-name (module-name-string module-name))) (unless (member module-name *modules* :test #'string=) @@ -114,9 +114,20 @@ (if pathname (dolist (file (if (consp pathname) pathname (list pathname)) t) (load file)) - (unless (some (lambda (p) (funcall p module-name)) - *module-provider-functions*) - (error (intl:gettext "Don't know how to load ~A") module-name))))) + ;; Search *cmucl-provider-functions* first so that we'll + ;; load our version of clx (and friends) before loading + ;; any asdf version, if asdf is loaded. + (or (some (lambda (p) (funcall p module-name)) + *cmucl-provider-functions*) + (progn + ;; Load asdf if it's not already loaded. This is needed to + ;; load easily the contribs that use asdf. There are no contribs + ;; that use defsystem, so we won't autoload defsystem. + (unless (featurep :asdf) + (load "modules:asdf/asdf")) + (some (lambda (p) (funcall p module-name)) + *module-provider-functions*)) + (error (intl:gettext "Don't know how to load ~A") module-name))))) (set-difference *modules* saved-modules))) ;;;; Default module providers ===================================== src/i18n/locale/cmucl.pot ===================================== @@ -10397,6 +10397,12 @@ msgstr "" msgid "*load-verbose* is bound to this before loading files." msgstr "" +#: src/code/module.lisp +msgid "" +"Provider functions for cmucl modules and libraries. These are\n" +" searched first before trying *module-provider-functions*" +msgstr "" + #: src/code/module.lisp msgid "See function documentation for REQUIRE" msgstr "" View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a2dfe20ddefc60bb9e55a4… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/a2dfe20ddefc60bb9e55a4… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-113-prefer-cmucl-modules] Only load ASDF if the Cmucl providers failed
by Raymond Toy (＠rtoy) 20 Sep '21

20 Sep '21

Raymond Toy pushed to branch issue-113-prefer-cmucl-modules at cmucl / cmucl Commits: af8841b4 by Raymond Toy at 2021-09-20T11:49:07-07:00 Only load ASDF if the Cmucl providers failed If the cmucl providers succeed, don't load asdf so we don't unnecessarily pollute the image if asdf isn't needed. If the cmucl providers fail, then load asdf so we can use asdf to load the other contribs or other asdf packages that might be available. - - - - - 1 changed file: - src/code/module.lisp Changes: ===================================== src/code/module.lisp ===================================== @@ -107,11 +107,6 @@ \"contrib-games-feebs\", \"contrib-hist\", \"contrib-psgraph\", \"contrib-ops\", \"contrib-embedded-c\", \"contrib-sprof\", and \"contrib-packed-sse2\". " - ;; First, load asdf if it's not already loaded. This is needed to - ;; load easily the contribs that use asdf. There are no contribs - ;; that use defsystem, so we won't autoload defsystem. - (unless (featurep :asdf) - (load "modules:asdf/asdf")) (let ((saved-modules (copy-list *modules*)) (module-name (module-name-string module-name))) (unless (member module-name *modules* :test #'string=) @@ -124,8 +119,14 @@ ;; any asdf version, if asdf is loaded. (or (some (lambda (p) (funcall p module-name)) *cmucl-provider-functions*) - (some (lambda (p) (funcall p module-name)) - *module-provider-functions*) + (progn + ;; Load asdf if it's not already loaded. This is needed to + ;; load easily the contribs that use asdf. There are no contribs + ;; that use defsystem, so we won't autoload defsystem. + (unless (featurep :asdf) + (load "modules:asdf/asdf")) + (some (lambda (p) (funcall p module-name)) + *module-provider-functions*)) (error (intl:gettext "Don't know how to load ~A") module-name))))) (set-difference *modules* saved-modules))) View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/af8841b424a38d43fe5debc… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/af8841b424a38d43fe5debc… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-111-fixes-for-motifd-clm] Unify naming of Core X11 and Xft2 fonts in CLM, use in INTERFACE.
by Raymond Toy (＠rtoy) 19 Sep '21

19 Sep '21

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 ,@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 <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 ,@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: ~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/81d8160b79e78ebd9821ed5… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/81d8160b79e78ebd9821ed5… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl][issue-111-fixes-for-motifd-clm] Expunge all FontList usage, replace with CompoundString tags.
by Raymond Toy (＠rtoy) 19 Sep '21

19 Sep '21

Raymond Toy pushed to branch issue-111-fixes-for-motifd-clm at cmucl / cmucl Commits: 254aa315 by Raymond Toy 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 - - - - - 6 changed files: - src/interface/debug.lisp - src/interface/initial.lisp - src/interface/inspect.lisp - src/interface/interface.lisp - src/motif/lisp/initial.lisp - src/motif/lisp/main.lisp Changes: ===================================== 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"))) ===================================== src/interface/initial.lisp ===================================== @@ -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")) ===================================== 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)) ===================================== 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,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 ===================================== 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" ===================================== 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 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/254aa3154efd42dda7fdc1f… -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/254aa3154efd42dda7fdc1f… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0

[Git][cmucl/cmucl] Pushed new branch issue-111-fixes-for-motifd-clm
by Raymond Toy (＠rtoy) 19 Sep '21

19 Sep '21

Raymond Toy pushed new branch issue-111-fixes-for-motifd-clm at cmucl / cmucl -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/tree/issue-111-fixes-for-motif… You're receiving this email because of your account on gitlab.common-lisp.net.

1 0