(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)


(FILECREATED " 7-Oct-2026 12:02:29" {MEDLEY}<sources>FONT.;934
 279153 

      :EDIT-BY rmk

      :CHANGES-TO (VARS FONTCOMS)

      :PREVIOUS-DATE " 5-Oct-2026 22:28:37" {MEDLEY}<sources>FONT.;933)


(PRETTYCOMPRINT FONTCOMS)

(RPAQQ FONTCOMS

       [
        (* ;; "Font functions ")


        (FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY 
             \STRINGWIDTH.GENERIC)
        (COMS (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT 
                   GETFONTCLASSCOMPONENT)
              (MACROS \GETFONTCLASSCOMPONENT \SETFONTCLASSCOMPONENT))
        (COMS 
              (* ;; "Creation: ")


              (FNS FONTCREATE FONTCREATE1 FONTCREATE.SLUGFD \FONT.CHECKARGS1 \FONTCREATE1.NOFN 
                   FONTFILEP \READCHARSET FONTCHARSETS)
              (FNS \FONT.CHECKARGS \CHARSET.CHECK)
              (FNS COERCEFONTSPEC COERCEFONTSPEC.TARGETFACE)
              (MACROS FONTCREATE)
              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS COERCEFONTSPEC.MATCH COERCEFONTSPEC.TARGET))
              (MACROS SPREADFONTSPEC)
              (FNS MAKEFONTSPEC FONTSPEC.TO.FONTDESCRIPTOR FONT.CHANGESPEC)
              (FNS COMPLETE.FONT COMPLETEFONTP COMPLETE.CHARSET PRUNESLUGCSINFOS MONOSPACEFONTP))
        (COMS 
              (* ;; "Property extraction:")


              (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH)
              (DECLARE%: DONTCOPY                            (* ; "FONTDESCRIPTOR is not in loadup")

                     (EXPORT (MACROS FONTPROP)))
              (MACROS FSPROP)
              (FNS FONTDEVICEPROP)
              (PROP ARGNAMES FONTDEVICEPROP))
        (COMS                                                (* ; "Moving character information")

              (FNS EDITCHAR)
                                                             (* ; "Should this be on EDITFONT ?")

              (FNS GETCHARBITMAP PUTCHARBITMAP \GETCHARBITMAP.CSINFO \PUTCHARBITMAP.CSINFO)
              (FNS MOVECHARBITMAP MOVEFONTCHARS \MOVEFONTCHAR \MOVEFONTCHARS.SOURCEDATA)
              (MACROS UPDATEINFOELEMENT))
        [COMS (FNS SLUGCHARP \SLUGSETUP \BUILDSLUGCSINFO \MAKESLUGCHAR)
              (DECLARE%: DONTCOPY (EXPORT (MACROS GETSLUGFLAG SETSLUGFLAG]
        (FNS FONTFILES FONTSPECFROMFILENAME FILENAMEFROMFONTSPEC)
        (FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \COERCECHARSET \FONTSYMBOL
             \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR SETFONTCHARENCODING)
        (FNS FONTSAVAILABLE FONTEXISTS? \SEARCHFONTFILES FLUSHFONTCACHE SORTFONTSPECS)
        (FNS MATCHFONTFACE MAKEFONTFACE FONTFACETOATOM FONTFACE.STARS)
        (INITVARS \FONTSINCORE \FONTEXISTS?-CACHE \FONTSAVAILABLEFILECACHE \DEFAULTDEVICEFONTS)
        (ADDVARS (\SYSTEMCACHEVARS \FONTEXISTS?-CACHE \FONTSAVAILABLEFILECACHE))
        [COMS (GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
              (INITVARS \UNITWIDTHSVECTOR)
              (FNS \UNITWIDTHSVECTOR)
              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR]
        (DECLARE%: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO FONTSPEC)
                                   (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET
                                          \FGETWIDTH \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH 
                                          \FGETIMAGEWIDTH \FSETIMAGEWIDTH MAXCHARSET)
                                   (MACROS \GETCHARSETINFO \SETCHARSETINFO \INSURECHARSETINFO 
                                          \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR CHARSETPROP 
                                          SLUGCSINFO)
                                   (PROP ARGNAMES CHARSETPROP))
               (MACROS INDIRECTCHARSETP))
        (FNS FONTDESCRIPTOR.DEFPRINT FONTCLASS.DEFPRINT)
        (INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO)
        (FNS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN)
        (FNS \CREATEFONT \CREATECHARSET \INSTALLCHARSETINFO \INSTALLCHARSETINFO.CHARENCODING 
             \COPYCHARSETINFO)
        (DECLARE%: DONTCOPY (EXPORT (MACROS FIRSTCHARSETCODE LASTCHARSETCODE)))
        (MACROS \FGETCHARIMAGEWIDTH)
        
        (* ;; "")


        
        (* ;; "DISPLAY")


        (COMS                                                (* ; 

                                                            "Functions for DISPLAY IMAGESTREAMTYPES ")

              (FNS \CREATEFONT.DISPLAY \CREATECHARSET.DISPLAY \FONTEXISTS?.DISPLAY 
                   FONTSAVAILABLE.DISPLAY)
              (FNS FAKEFACE.CHARSET MAKEBOLD.CHAR MAKEITALIC.CHAR))
        (COMS                                                (* ; "Bitmap faking")

              (FNS \SFROTATECSINFO \SFROTATECSINFOBITMAP \SFROTATECSINFOOFFSETS 
                   \SFROTATECSINFOIMAGEWIDTHS)
              (FNS \SFMAKECOLOR))
        [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DISPLAYFONTDIRECTORIES (LIST 
                                                                  "{MEDLEY}/fonts/medleydisplayfonts"
                                                                                )))
                                                             (* ; "The loadup might have fewer")

               (ADDVARS)
               [ADDVARS (DISPLAYCHARSETFNS (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET))
                      (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
                      (DISPLAYFILETEMPLATES (MEDLEYFONT (FAMILY SIZE - FACE]
               (INITVARS (DISPLAYFACECOERCIONS '(((* * (BOLD * *))
                                                  (* * (MEDIUM * *)))
                                                 ((* * (* ITALIC *))
                                                  (* * (* REGULAR *)))
                                                 ((* * (* * COMPRESSED))
                                                  (* * (* * REGULAR]
        (INITVARS (\DEFAULTCHARSET 0))
        (LOCALVARS . T)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA FONTCOPY 
                                                                                   FONTDEVICEPROP])



(* ;; "Font functions ")


(DEFINEQ

(CHARWIDTH

  [LAMBDA (CHARCODE FONT)                                    (* rmk%: "12-Apr-85 09:46")

                                                             (* ; 

                                                "gets the width of a character code in a font/stream")

    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP)
         (COND
            ((type?
 FONTDESCRIPTOR FONT)
             (\FGETCHARWIDTH FONT CHARCODE))
            ((SETQ TEMP (\OUTSTREAMARG FONT T))              (* ; 

                                                       "NIL font goes thru here--primary output file")

             (IMAGEOP 'IMCHARWIDTH TEMP TEMP CHARCODE))
            (T (\FGETCHARWIDTH (FONTCREATE
 FONT)
                      CHARCODE])

(CHARWIDTHY

  [LAMBDA (CHARCODE FONT)
                                    (* ; "Edited  2-Sep-2025 13:25 by rmk")


                                                             (* ; "Edited 22-May-2025 09:47 by rmk")

                                                             (* edited%: "18-Mar-86 19:30")

                                                             (* ; 

                                   "Gets the Y-component of the width of a character code in a font.")

    (OR (\CHARCODEP CHARCODE)
        (\ILLEGAL.ARG CHARCODE))
    (LET (TEMP WY)
         (COND
            ((type?
 FONTDESCRIPTOR FONT)
             [SETQ WY (ffetch
 (CHARSETINFO YWIDTHS) of
 (\INSURECHARSETINFO FONT (\CHARSET CHARCODE]
             (COND
                ((FIXP WY))
                (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                (T 0)))
            ((type?
 STREAM (SETQ TEMP (\OUTSTREAMARG FONT T)))
                                                             (* ; 

                                                       "NIL font goes thru here--primary output file")

             (IMAGEOP 'IMCHARWIDTHY TEMP TEMP CHARCODE))
            (T [SETQ WY (ffetch
 (CHARSETINFO YWIDTHS) of
 (\INSURECHARSETINFO (FONTCREATE
 FONT)
                                                                (\CHARSET CHARCODE]
               (COND
                  ((FIXP WY))
                  (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE)))
                  (T 0])

(STRINGWIDTH

  [LAMBDA (STR FONT FLG RDTBL)
                               (* ; "Edited  8-Jan-88 14:41 by Snow")


    (* ;; "Returns the width of STR according to FONT")


    (LET (TEMP)

         (* ;; "Used in \MAPCHARS")


         (COND
            [(type?
 FONTDESCRIPTOR FONT)
             (\STRINGWIDTH.GENERIC
 STR FONT (AND FLG (\GTREADTABLE RDTBL))
                    (\FGETCHARWIDTH FONT (CHARCODE SPACE]
            [(AND FONT (SETQ TEMP (\OUTSTREAMARG FONT T)))   (* ; 

    "if you gave something for FONT, coerce it to a stream, and call the stringwidth function of it.")

             (IMAGEOP 'IMSTRINGWIDTH TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL]
            (T (SETQ TEMP (FONTCREATE
 (OR FONT DEFAULTFONT)))(* ; "NIL font will pass thru here.  ie, defaultfont is used to do the stringwidth instead of the font of *standard-output*")

               (\STRINGWIDTH.GENERIC
 STR TEMP (AND FLG (\GTREADTABLE RDTBL))
                      (\FGETCHARWIDTH TEMP (CHARCODE SPACE])

(\CHARWIDTH.DISPLAY

  [LAMBDA (STREAM CHARCODE)                                  (* rmk%: "12-Apr-85 09:42")

                                                             (* ; 

           "gets the width of a character code in a display stream.  Need to fix up for spacefactor.")

    (\FGETCHARWIDTH (ffetch
 (\DISPLAYDATA DDFONT) of
 (ffetch
 IMAGEDATA of
 STREAM))
           CHARCODE])

(\STRINGWIDTH.DISPLAY

  [LAMBDA (STREAM STR RDTBL)
                                 (* ; "Edited  3-Apr-87 12:07 by jop")


    (* ;; "Returns the width of for the current font/spacefactor in STREAM.")


    (LET ((DD (ffetch
 IMAGEDATA of
 STREAM)))
         (\STRINGWIDTH.GENERIC
 STR (ffetch
 (\DISPLAYDATA DDFONT) of
 DD)
                RDTBL
                (ffetch
 DDSPACEWIDTH of
 DD])

(\STRINGWIDTH.GENERIC

  [LAMBDA (STR FONT RDTBL SPACEWIDTH)
                        (* ; "Edited 10-Sep-2025 23:25 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:19 by rmk")


                                                             (* ; "Edited 22-May-2025 09:51 by rmk")


                                                             (* ; "Edited  3-Apr-87 13:47 by jop")


    (* ;; "Returns the width of STR with SPACEWIDTH for the width of spaces.  RDTBL has already been coerced, so no FLG is needed ")


    (* ;; "This is cloned in \STRINGWIDTH.HCPYDISPLAYAUX by straight substitution -- (PUTDEF (QUOTE \STRINGWIDTH.HCPYDISPLAYAUX) (QUOTE FNS) (SUBLIS (QUOTE ((WIDTHS  . IMAGEWIDTHS) (\FGETWIDTH  . \FGETIMAGEWIDTH) (\FGETCHARWIDTH  . \FGETCHARIMAGEWIDTH))) (GETDEF (QUOTE \STRINGWIDTH.GENERIC))))")


    (* ;; "\MAPPNAME uses WIDTHSBASE CSET TOTALWIDTH FONT SPACEWIDTH free, so these become special in bytecompiler")


    (PROG NIL
          [COND
             [(LITATOM STR)
              (if
 RDTBL
                  then
 (GO SLOW)
                else
 (RETURN (for
 C WIDTHSBASE CSET inatom
 STR
                                sum
 (CL:UNLESS (EQ CSET (\CHARSET C))
                                        (SETQ CSET (\CHARSET C))
                                        (SETQ WIDTHSBASE (ffetch
 (CHARSETINFO WIDTHS)
                                                            of
 (\INSURECHARSETINFO FONT CSET))))
                                    (CL:IF (EQ C (CHARCODE SPACE))
                                        SPACEWIDTH
                                        (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C)))]
             ((STRINGP STR)
              (RETURN (LET ((TOTAL 0)
                            ESC ESCWIDTH WIDTHSBASE CSET)
                           (CL:WHEN RDTBL                    (* ; 

                                                       "Count delimiting quotes and internal escapes")

                               (SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %"))
                                                  2))
                               (SETQ ESC (fetch
 (READTABLEP ESCAPECHAR) of
 RDTBL))
                               (SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC)))
                           [for
 C instring
 STR
                              do
 (CL:UNLESS (EQ (\CHARSET C)
                                                CSET)        (* ; 

                                                       "Get the widths vector for this character set")

                                     (SETQ CSET (\CHARSET C))
                                     (SETQ WIDTHSBASE (ffetch
 (CHARSETINFO WIDTHS)
                                                         of
 (\INSURECHARSETINFO FONT CSET))))
                                 (add
 TOTAL (CL:IF (EQ C (CHARCODE SPACE))
                                                SPACEWIDTH
                                                (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C))
                                                       (COND
                                                          ((AND RDTBL (OR (EQ C (CHARCODE %"))
                                                                          (EQ C ESC)))
                                                             (* ; "String char must be escaped")

                                                           ESCWIDTH)
                                                          (T 0))))]
                           TOTAL]
      SLOW
                                                             (* ; "Do the general case here")

          (RETURN (LET ((TOTALWIDTH 0)
                        WIDTHSBASE CSET (FONT FONT)
                        (SPACEWIDTH SPACEWIDTH))
                       (DECLARE
 (SPECVARS TOTALWIDTH WIDTHSBASE CSET FONT SPACEWIDTH))
                       (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC)
                                              (add
 TOTALWIDTH (COND
                                                                 ((EQ CC (CHARCODE SPACE))
                                                                  SPACEWIDTH)
                                                                 ((EQ CSET (\CHARSET CC))
                                                                  (\FGETWIDTH WIDTHSBASE (\CHAR8CODE
                                                                                          CC)))
                                                                 (T (SETQ CSET (\CHARSET CC))
                                                                    (SETQ WIDTHSBASE
                                                                     (ffetch
 (CHARSETINFO WIDTHS)
                                                                        of
 (\INSURECHARSETINFO FONT 
                                                                                  CSET)))
                                                                    (\FGETWIDTH WIDTHSBASE
                                                                           (\CHAR8CODE CC]
                              STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*)
                       TOTALWIDTH])
)
(DEFINEQ

(DEFAULTFONT

  [LAMBDA (DEVICE FONT NOERRORFLG)
                           (* ; "Edited 14-Jul-2025 22:43 by rmk")


                                                             (* ; "Edited  5-Jul-2025 13:30 by rmk")


                                                             (* ; "Edited 28-Jul-88 13:15 by rmk:")


                                                             (* ; "Edited 24-Mar-87 14:41 by FS")

    (DECLARE
 (GLOBALVARS DEFAULTFONT))

    (* ;; "It is a natural mistake for the user to set DEFAULTFONT to an actual font instead of a class.   In that case we up it into a class, ignoring FONT if the given DEFAULTFONT designates a font descriptor.")


    (CL:UNLESS DEVICE
        (SETQ DEVICE 'DISPLAY))
    (CL:UNLESS (type?
 FONTCLASS DEFAULTFONT)

        (* ;; "If total garbage, we want to fall through to the coerce, to protect the system. NLSETQ to suppress even invalid-argument errors.")


        (CL:WHEN DEFAULTFONT
            [SETQ FONT (CAR (NLSETQ (FONTCREATE
 DEFAULTFONT NIL NIL NIL DEVICE T])
        (SETQ DEFAULTFONT (FONTCLASS
 'DEFAULTFONT)))
    (CL:IF FONT
        (SETFONTCLASSCOMPONENT
 DEFAULTFONT DEVICE FONT)
        (FONTCREATE
 DEFAULTFONT NIL NIL NIL DEVICE NOERRORFLG))])

(FONTCLASS

  [LAMBDA (NAME FONTLIST CREATEFORDEVICES)                   (* jds " 9-Sep-86 18:49")


    (* ;; "This builds D style font classes, which are datatypes containing entries for the various known devices.")


    (* ;; "Don't actually set up the for devices not inside CREATEFORDEVICES on the theory that any given user presumably doesn't want all the fonts for all the devices.  We wait until he actually asks for the font or the fontmaparray, at which point we note that the fields don't contain FD's, so we then apply FONTCREATE.  The actual coercion and caching is done inside \COERCEFONTDESC.  However, so as to prevent display crashes, if a display component is specified, we always do the fontcreate before we stick it in.")


    (PROG (F FC FL)
          (SETQ FL FONTLIST)
          [SETQ FC (create
 FONTCLASS
                          FONTCLASSNAME ← NAME
                          PRETTYFONT# ← (OR (FIXP (pop
 FL))
                                            1)
                          DISPLAYFD ← (AND (SETQ F (pop
 FL))
                                           (FONTCREATE
 F NIL NIL NIL 'DISPLAY))
                          PRESSFD ← (pop
 FL)
                          INTERPRESSFD ← (pop
 FL)
                          OTHERFDS ← (for
 FSPEC in
 FL collect
 (OR (AND (LISTP FSPEC)
                                                                       (ATOM (CAR FSPEC))
                                                                       (CAR FSPEC))
                                                                  (ERROR 
                                                                   "illegal font class specification"
                                                                         (LIST NAME FONTLIST))) 
                                                             (* ; 

                                       "Copy the alist entry so it can be smashed in \COERCEFONTDESC")

                                                            (CONS (CAR FSPEC)
                                                                  (CAR (LISTP (CDR FSPEC]
          (for
 D inside
 CREATEFORDEVICES do
 (FONTCREATE
 FC NIL NIL NIL D))
          (RETURN FC])

(FONTCLASSUNPARSE

  [LAMBDA (FONTCLASS
 DEVICE FONT NOERRORFLG)                 (* jds "24-Jan-86 11:58")

                                                             (* ; 

                                  "Given a font class, unparse it to a form that might be reparsable")

    (APPEND (LIST (fetch
 (FONTCLASS
 FONTCLASSNAME) of
 FONTCLASS)
                  (fetch
 (FONTCLASS
 PRETTYFONT#) of
 FONTCLASS)
                  (FONTUNPARSE
 (ffetch
 (FONTCLASS
 DISPLAYFD) of
 FONTCLASS))
                  (FONTUNPARSE
 (ffetch
 (FONTCLASS
 PRESSFD) of
 FONTCLASS))
                  (FONTUNPARSE
 (ffetch
 (FONTCLASS
 INTERPRESSFD) of
 FONTCLASS)))
           (for
 X in
 (fetch
 (FONTCLASS
 OTHERFDS) of
 FONTCLASS)
              collect
 (LIST (CAR X)
                            (FONTUNPARSE
 (CDR X])

(FONTCLASSCOMPONENT

  [LAMBDA (FONTCLASS
 DEVICE FONT NOERRORFLG)
                 (* ; "Edited  4-Jul-2025 10:32 by rmk")

                                                             (* rmk%: "14-Sep-84 19:34")


    (* ;; "Returns the old DEVICE-specific font of the class. Only if FONT designates a font descriptor is that descriptor installed.")


    (PROG1 (FONTCREATE
 FONTCLASS NIL NIL NIL DEVICE NOERRORFLG)
        (AND FONT (SETQ FONT (FONTCREATE
 FONT NIL NIL NIL DEVICE NOERRORFLG))
             (SETFONTCLASSCOMPONENT
 FONTCLASS DEVICE FONT)))])

(SETFONTCLASSCOMPONENT

  [LAMBDA (FONTCLASS
 DEVICE FONT)
                            (* ; "Edited  5-Jul-2025 09:53 by rmk")


                                                             (* ; "Edited 15-Jun-2025 00:02 by rmk")


                                                             (* ; "Edited 29-Aug-91 12:20 by jds")

    (\SETFONTCLASSCOMPONENT FONTCLASS DEVICE (FONTCREATE
 FONT NIL NIL NIL DEVICE])

(GETFONTCLASSCOMPONENT

  [LAMBDA (FONTCLASS
 DEVICE NOERRORFLG)
                      (* ; "Edited  5-Jul-2025 09:54 by rmk")


                                                             (* ; "Edited 14-Jun-2025 20:32 by rmk")


    (* ;; "This is a user entry")


    (LET (FONT)
         (if
 (type?
 FONTCLASS FONTCLASS)
             then
 (SETQ FONT (\GETFONTCLASSCOMPONENT FONTCLASS DEVICE)) 

                  (* ;; "Component may no be a properly instantiated font description.  Let FONTCREATE have a try, possibly error.")


                  (CL:UNLESS (type?
 FONTDESCRIPTOR FONT)
                      (if
 (SETQ FONT (FONTCREATE
 FONT NIL NIL NIL 'DEVICE T))
                          then
 (\SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT)
                        elseif
 NOERRORFLG
                        else
 (ERROR (CONCAT "Invalid " DEVICE " fontclass component")
                                    FONTCLASS)))
                  FONT
           elseif
 NOERRORFLG
             then
 NIL
           else
 (ERROR "NOT A FONTCLASS" FONTCLASS])
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \GETFONTCLASSCOMPONENT
 MACRO
 (OPENLAMBDA (FCLASS DEVICE)
                                         (SELECTQ DEVICE
                                             (DISPLAY (fetch
 (FONTCLASS
 DISPLAYFD) of
 FCLASS))
                                             (INTERPRESS (fetch
 (FONTCLASS
 INTERPRESSFD) of
 FCLASS))
                                             (GETMULTI (fetch
 (FONTCLASS
 OTHERFDS) of
 FCLASS)
                                                    DEVICE))))

(PUTPROPS \SETFONTCLASSCOMPONENT
 MACRO
 (OPENLAMBDA (FCLASS DEVICE NEWFONT)
                                         (SELECTQ DEVICE
                                             (DISPLAY (replace
 (FONTCLASS
 DISPLAYFD) of
 FCLASS
                                                         with
 NEWFONT))
                                             (INTERPRESS (replace
 (FONTCLASS
 INTERPRESSFD)
                                                            of
 FCLASS with
 NEWFONT))
                                             (PRESS (replace
 (FONTCLASS
 PRESSFD) of
 FCLASS
                                                       with
 NEWFONT))
                                             (PUTMULTI (fetch
 (FONTCLASS
 OTHERFDS) of
 FCLASS)
                                                    DEVICE NEWFONT))))
)



(* ;; "Creation: ")


(DEFINEQ

(FONTCREATE

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET)

                                                             (* ; "Edited 22-Sep-2026 00:25 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:39 by rmk")


                                                             (* ; "Edited 15-Aug-2025 23:48 by rmk")


                                                             (* ; "Edited 12-Aug-2025 21:02 by rmk")


                                                             (* ; "Edited 21-Jul-2025 09:11 by rmk")


                                                             (* ; "Edited 11-Jul-2025 10:23 by rmk")


                                                             (* ; "Edited  4-Jul-2025 12:10 by rmk")


                                                             (* ; "Edited 27-Jun-2025 10:29 by rmk")


                                                             (* ; "Edited 21-Jun-2025 14:53 by rmk")


                                                             (* ; "Edited 20-May-2025 20:41 by rmk")


                                                             (* ; "Edited 10-Oct-88 09:53 by rmk:")


                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")


                                                             (* ; "Edited 10-Nov-87 18:08 by FS")


    (* ;; "Returns the requested font descriptor.  If NOERRORFLG, return NIL if the requested  font doesn't exist;  otherwise cause an error.  And always cause an error if any argument is bogus.")


    (* ;; "A font exists if it has at least one charset, even if the optionally desired CHARSET doesn't exist.  There is no difference between all the characters in a missing charset and particular missing characters in an existing charset:  they will show up as slugs. ")


    (* ;; "Original code picked off and returned a fontclass for (CLASS ...).  That's now handled in \FONT.CHECKARGS, and it coerces to a fontdescriptor for DEVICE, not a class.")


    (if
 (AND (type?
 FONTDESCRIPTOR FAMILY)
             (NOT (OR SIZE FACE ROTATION DEVICE))
             (\GETCHARSETINFO FAMILY (\CHARSET.CHECK
 CHARSET)))
        then
 
             (* ;; "Pretest for a fontdescriptor with no modification, the common case of just calling FONTCREATE to check validity.  Avoid cost of \FONT.CHECKARGS, also makes it possible to break/trace/change \FONT.CHECKARGS. Presumably already in \FONTSINCORE.")


             FAMILY
      else
 (PROG (FONTSPEC)
             RETRY
                                                             (* ; "Back to here if ERROR returns")

                 (SETQ FONTSPEC (\FONT.CHECKARGS
 FAMILY SIZE FACE ROTATION DEVICE))

            (* ;; "If FONTSPEC is a fontdescriptor, it's what we want")


                 (RETURN (if
 (type?
 FONTDESCRIPTOR FONTSPEC)
                             then
 FONTSPEC
                           elseif
 (FONTCREATE1
 FONTSPEC CHARSET)
                           elseif
 NOERRORFLG
                             then
 NIL
                           else
 (ERROR "FONT NOT FOUND" FONTSPEC)
                                (GO RETRY])

(FONTCREATE1

  [LAMBDA (FONTSPEC CHARSET)
                                 (* ; "Edited 17-Mar-2026 23:41 by rmk")


                                                             (* ; "Edited 25-Sep-2025 18:41 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:13 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:32 by rmk")


                                                             (* ; "Edited 26-Aug-2025 23:45 by rmk")


                                                             (* ; "Edited 16-Aug-2025 18:55 by rmk")


                                                             (* ; "Edited  8-Aug-2025 10:05 by rmk")


                                                             (* ; "Edited 24-Jul-2025 19:52 by rmk")


                                                             (* ; "Edited 23-Jul-2025 10:01 by rmk")


                                                             (* ; "Edited 17-Jul-2025 23:48 by rmk")


                                                             (* ; "Edited 10-Jul-2025 12:38 by rmk")


                                                             (* ; "Edited  4-Jul-2025 17:05 by rmk")


                                                             (* ; "Edited 21-Jun-2025 09:28 by rmk")


                                                             (* ; "Edited 18-Jun-2025 14:50 by rmk")


                                                             (* ; "Edited 16-Jun-2025 12:07 by rmk")


                                                             (* ; "Edited 14-Jun-2025 20:53 by rmk")


                                                             (* ; "Edited 10-Jun-2025 23:54 by rmk")


    (* ;; "Returns NIL if font not found. Error happens at FONTCREATE.  ")


    (DECLARE
 (GLOBALVARS \FONTSINCORE))
    (CL:UNLESS CHARSET (SETQ CHARSET \DEFAULTCHARSET))
    (LET (FONT)
         (CL:WHEN (if
 (SETQ FONT (FETCHMULTI \FONTSINCORE FONTSPEC T))
                    elseif
 (SETQ FONT (\CREATEFONT
 FONTSPEC))
                      then
 
                           (* ;; "Storing stops internal charset recursions")


                           (STOREMULTI \FONTSINCORE FONTSPEC FONT T))

             (* ;; "Even the cached font may not have had the requested charset.")


             (\INSURECHARSETINFO FONT CHARSET)
             (replace
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT with
 (\AVGCHARWIDTH
 FONT))
             FONT)])

(FONTCREATE.SLUGFD

  [LAMBDA (FONTSPEC SOURCEFONT)
                              (* ; "Edited 30-Sep-2026 16:47 by rmk")


                                                             (* ; "Edited 12-Sep-2026 16:18 by rmk")


                                                             (* ; "Edited 21-Mar-2026 09:20 by rmk")


                                                             (* ; "Edited 19-Mar-2026 20:47 by rmk")


                                                             (* ; "Edited 31-Aug-2025 14:36 by rmk")


                                                             (* ; "Edited 14-Jun-2025 23:25 by rmk")


                                                             (* ; "Edited 13-Jun-2025 09:44 by rmk")


                                                             (* ; "Edited 11-Jun-2025 10:59 by rmk")


    (* ;; 

    "Makes an empty fontdescriptor for FONTSPEC, with parameters taken from SOURCEFONT if given")


    (LET ((FONT (if
 SOURCEFONT
                    then
 (create
 FONTDESCRIPTOR using
 SOURCEFONT FONTFAMILY ← (FSPROP FONTSPEC 
                                                                                     FSFAMILY)
                                                      FONTSIZE ← (FSPROP FONTSPEC FSSIZE)
                                                      FONTFACE ← (FSPROP FONTSPEC FSFACE)
                                                      FONTROTATION ← (FSPROP FONTSPEC FSROTATION)
                                                      FONTDEVICE ← (FSPROP FONTSPEC FSDEVICE)
                                                      FONTDEVICESPEC ← FONTSPEC FONTCHARSETVECTOR ← 
                                                      NIL)
                  else
 (FONTSPEC.TO.FONTDESCRIPTOR
 FONTSPEC)))
          SLUGCSINFO)
         (replace
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONT with
 (\CREATEFONTCHARSETVECTOR FONT))
         (SETQ SLUGCSINFO (\BUILDSLUGCSINFO
 FONT))
         (replace
 (FONTDESCRIPTOR SLUGCSINFO) of
 FONT with
 SLUGCSINFO)
         (for
 CS from
 0 to
 (MAXCHARSET FONT) do
 (\SETCHARSETINFO FONT CS SLUGCSINFO))
         FONT])

(\FONT.CHECKARGS1

  [LAMBDA (SPEC STREAM NOERRORFLG)
                           (* ; "Edited 19-Feb-2026 00:03 by rmk")


                                                             (* ; "Edited 22-Jul-2025 18:47 by rmk")


                                                             (* ; "Edited 14-Jul-2025 19:40 by rmk")


                                                             (* ; "Edited  5-Jul-2025 14:16 by rmk")


                                                             (* ; "Edited 29-Aug-91 12:19 by jds")


    (* ;; "Coerces SPEC to a fontdescriptor appropriate for STREAM (defaulting to DISPLAY).")


    (* ;; "SPEC can be a font descriptor, a font class, any of the symbolic ways of describing those, or NIL (= DEFAULTFONT).  If SPEC is a class whose component for a non-display device is uninstantiated, the display component is used as a template for the requested device font. ")


    (* ;; "STREAM denotes a device:  NIL means DISPLAY, another atom is a device name itself, an IMAGESTREAM means its IMAGESTREAMTYPE.  Anything else here maps to DISPLAY, but maybe that should be an illegal arg error, even of NOERRORFLG.")


    (DECLARE
 (GLOBALVARS DEFAULTFONT \GUARANTEEDDISPLAYFONT))
    (CL:WHEN (IMAGESTREAMP SPEC)
        (SETQ SPEC (DSPFONT NIL SPEC)))
    (LET (FONT DEVICE TEMP)
         (CL:UNLESS SPEC
             (if
 DEFAULTFONT
                 then
 (SETQ SPEC DEFAULTFONT)
               else
 (ERROR "No DEFAULTFONT")))
         (SETQ DEVICE (if
 (NULL STREAM)
                          then
                               (* ; "Default is display")

                               'DISPLAY
                        elseif
 (OR (LITATOM STREAM)
                                   (STRINGP STREAM))
                          then
 (\DEVICESYMBOL
 STREAM)
                        elseif
 (IMAGESTREAMP STREAM)
                          then
 (IMAGESTREAMTYPE STREAM)
                        elseif
 STREAM
                        else
 
                             (* ;; "Original jds comment:  should this be allowed?")


                             'DISPLAY))
         (if
 (type?
 FONTCLASS SPEC)
             then
 (SETQ FONT (\GETFONTCLASSCOMPONENT SPEC DEVICE))
                  (if
 (type?
 FONTDESCRIPTOR FONT)
                      then
 
                           (* ;; "It must be a font for DEVICE")


                           FONT
                    elseif
 (AND FONT (SETQ TEMP (FONTCREATE
 FONT NIL NIL NIL DEVICE T)))
                      then
 (\SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE TEMP)
                    elseif
 (MEMB DEVICE \DISPLAYSTREAMTYPES)
                      then
 (if
 (EQ SPEC DEFAULTFONT)
                               then
                          (* ; "Guarantee system integrity")

                                    (\SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE \GUARANTEEDDISPLAYFONT
                                           )
                             elseif
 NOERRORFLG
                               then
 NIL
                             else
 (ERROR (CONCAT "DISPLAY component for " SPEC " is invalid")))
                    elseif
 (SETQ FONT (FONTCREATE
 (\GETFONTCLASSCOMPONENT SPEC 'DISPLAY)
                                             NIL NIL NIL DEVICE NOERRORFLG))
                      then
 
                           (* ;; "If the DEVICE component was garbage, we use the display component as a template for an appropriate FD.")


                           (\SETFONTCLASSCOMPONENT SPEC DEVICE FONT)
                    elseif
 NOERRORFLG
                      then
 NIL
                    else
 (ERROR (CONCAT DEVICE " component for " SPEC " is invalid")))
           elseif
 (SETQ FONT (if
 (type?
 FONTDESCRIPTOR SPEC)
                                 then
 SPEC
                               elseif
 (OR (IMAGESTREAMP SPEC)
                                          (type?
 WINDOW SPEC))
                                 then
 (DSPFONT NIL SPEC)))
             then
 (if
 (NULL STREAM)
                      then
 
                           (* ;; 

                          "NIL device doesn't default to display if a fully-specified font was found")


                           FONT
                    elseif
 (EQ DEVICE (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 FONT))
                      then
 FONT
                    else
 
                         (* ;; "Switch device")


                         (FONTCREATE
 FONT NIL NIL NIL DEVICE NOERRORFLG])

(\FONTCREATE1.NOFN

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET)
         (* ; "Edited 16-Jun-2025 12:08 by rmk")

    (ERROR (CONCAT "FONTCREATE function is not specified for image-type " DEVICE])

(FONTFILEP

  [LAMBDA (FILE DEVICE)
                                      (* ; "Edited 25-Aug-2025 10:22 by rmk")


                                                             (* ; "Edited 13-Jul-2025 13:41 by rmk")


                                                             (* ; "Edited 27-Jun-2025 22:54 by rmk")

    (CL:UNLESS DEVICE
        (SETQ DEVICE 'DISPLAY))
    (RESETLST
        (if
 (EQ DEVICE 'DISPLAY)
            then
 (for
 FNS STRM in
 (FONTDEVICEPROP
 DEVICE 'CHARSETFNS)
                    first
 [RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT))
                                 `(PROGN (CLOSEF? OLDVALUE]
                    do
 (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS)
                                                    STRM)))
                           (RETURN (CAR FNS)))
                       (CLOSEF? STRM))))])

(\READCHARSET

  [LAMBDA (FONT CHARSET CHARSETFNS)
                          (* ; "Edited 29-Aug-2026 09:28 by rmk")


                                                             (* ; "Edited 18-Aug-2026 17:25 by rmk")


                                                             (* ; "Edited 18-Apr-2026 20:44 by rmk")


                                                             (* ; "Edited 16-Apr-2026 22:38 by rmk")


                                                             (* ; "Edited 12-Apr-2026 12:59 by rmk")


                                                             (* ; "Edited  2-Apr-2026 15:52 by rmk")


                                                             (* ; "Edited 28-Mar-2026 07:51 by rmk")


                                                             (* ; "Edited 17-Mar-2026 08:57 by rmk")


                                                             (* ; "Edited 12-Mar-2026 13:39 by rmk")


                                                             (* ; "Edited  8-Mar-2026 21:41 by rmk")


                                                             (* ; "Edited 14-Feb-2026 09:47 by rmk")


                                                             (* ; "Edited  6-Feb-2026 00:03 by rmk")


                                                             (* ; "Edited 11-Nov-2025 14:30 by rmk")


                                                             (* ; "Edited  2-Sep-2025 23:57 by rmk")


                                                             (* ; "Edited 28-Aug-2025 23:17 by rmk")


                                                             (* ; "Edited 25-Aug-2025 12:03 by rmk")


                                                             (* ; "Edited 16-Aug-2025 18:00 by rmk")


                                                             (* ; "Edited 21-Jul-2025 18:35 by rmk")


                                                             (* ; "Edited 14-Jul-2025 19:51 by rmk")


                                                             (* ; "Edited 12-Jul-2025 13:20 by rmk")


                                                             (* ; "Edited 10-Jul-2025 12:38 by rmk")


                                                             (* ; "Edited  6-Jul-2025 13:09 by rmk")


    (* ;; "This finds the first file in the directories/extensions order that contains information about charset, determines its format, and reads it in.  The assumption is that the first such existing file is the one we want. ")


    (RESETLST
        (for
 FILE STRM CSINFO in
 (FONTFILES
 FONT T CHARSET)
           do
 
              (* ;; "We know that FILE exists and is the best source of information about charset--maybe none. We assume FILE is one of the valid formats, we open it separately for each format-type, and ensure it is closed on exit.  We can't used CL:WITHOPEN-FILE because that doesn't exist in the loadup when the first font is created.")


              (for
 FNS in
 [OR CHARSETFNS (FONTDEVICEPROP
 FONT 'CHARSETFNS)
                              '((MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET]
                 do
 [RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT))
                           `(PROGN (CLOSEF? OLDVALUE]
                    (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS)
                                                 STRM)))

                        (* ;; "Assume that predicate leaves stream (open or closed) in proper state for its retrieval function.  The FILE may be of the right type, but it may not contain this CHARSET (e.g. a complete MEDLEYFONTFILE but CHARSET doesn't exist anywhere).")


                        (SETQ CSINFO (APPLY* (CADDR FNS)
                                            STRM CHARSET FONT))
                        (CL:WHEN (type?
 CHARSETINFO CSINFO)
                            (CL:UNLESS (CHARSETPROP CSINFO 'CSCHARENCODING)

                                (* ;; "The file didn't know its own encoding")


                                (CHARSETPROP CSINFO 'CSCHARENCODING
                                       (APPLY* (OR (FONTDEVICEPROP
 FONT 'ENCODINGFN)
                                                   (FUNCTION NILL))
                                              FONTSPEC)))
                            (CL:UNLESS (CHARSETPROP CSINFO 'SOURCE)
                                [CHARSETPROP CSINFO 'SOURCE (create
 FONTSPEC
                                                               using
 (CL:IF (type?
 FONTSPEC FONT)
                                                                         FONT
                                                                         (FONTPROP
 FONT 'DEVICESPEC))
                                                                   ])
                            (replace
 (CHARSETINFO CHARSETNO) of
 CSINFO with
 CHARSET)
                            (RETURN))) 

                    (* ;; "Prepare for next format-type")


                    (CLOSEF? STRM))
              (CL:WHEN CSINFO (RETURN CSINFO))))])

(FONTCHARSETS

  [LAMBDA (FONT)
                                             (* ; "Edited 26-Mar-2026 12:46 by rmk")


    (* ;; "Returns a list of the charset numbers for nonempty instantiated charsets.")


    (for
 CSNO CSINFO from
 0 to
 (MAXCHARSET FONT) when
 (SETQ CSINFO (\GETCHARSETINFO FONT CSNO))
       unless
 (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO) collect
 CSNO])
)
(DEFINEQ

(\FONT.CHECKARGS

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE ALWAYSFONTSPEC)
  (* ; "Edited 30-Sep-2026 18:17 by rmk")


                                                             (* ; "Edited 19-Sep-2026 23:11 by rmk")


                                                             (* ; "Edited  1-Sep-2026 14:56 by rmk")


                                                             (* ; "Edited 26-Aug-2026 21:05 by rmk")


                                                             (* ; "Edited 20-Aug-2026 23:59 by rmk")


                                                             (* ; "Edited 22-Nov-2025 11:31 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:46 by rmk")


                                                             (* ; "Edited 23-Aug-2025 11:54 by rmk")


                                                             (* ; "Edited 17-Aug-2025 19:15 by rmk")


                                                             (* ; "Edited 12-Aug-2025 22:36 by rmk")


                                                             (* ; "Edited 10-Aug-2025 12:06 by rmk")


                                                             (* ; "Edited  8-Aug-2025 09:57 by rmk")


                                                             (* ; "Edited 27-Jul-2025 13:30 by rmk")


                                                             (* ; "Edited 22-Jul-2025 23:07 by rmk")


                                                             (* ; "Edited 21-Jul-2025 09:22 by rmk")


                                                             (* ; "Edited 14-Jul-2025 20:09 by rmk")


                                                             (* ; "Edited 11-Jul-2025 10:15 by rmk")


                                                             (* ; "Edited  5-Jul-2025 13:37 by rmk")


                                                             (* ; "Edited  2-Jul-2025 16:50 by rmk")


                                                             (* ; "Edited 27-Jun-2025 10:42 by rmk")


                                                             (* ; "Edited 15-Jun-2025 00:25 by rmk")


    (* ;; "DON'T BREAK, TRACE, OR UNSAVE THIS UNLESS ALL SYSTEM FONTS HAVE ALREADY BEEN INSTANTIATED")


    (* ;; "Decodes and checks the various ways of specifying the arguments to font lookup functions.")


    (* ;; "If FAMILY can be coerced to a font descriptor and none of its properties are overwritten by the other aguments, then that font descriptor is returned.  Otherwise the value is the coerced fontspec (family size face rotation device).")


    (LET (FONTX)
         (if
 [AND (NOT (OR SIZE FACE ROTATION DEVICE))
                  (OR (type?
 FONTDESCRIPTOR FAMILY)
                      (AND (IMAGESTREAMP FAMILY)
                           (type?
 FONTDESCRIPTOR (SETQ FONTX (DSPFONT NIL FAMILY)))
                           (SETQ FAMILY FONTX]
             then
 (CL:IF ALWAYSFONTSPEC
                      (create
 FONTSPEC
                             FSFAMILY ← (FONTPROP
 FAMILY 'FAMILY)
                             FSSIZE ← (FONTPROP
 FAMILY 'SIZE)
                             FSFACE ← (COPY (FONTPROP
 FAMILY 'FACE))
                             FSROTATION ← (FONTPROP
 FAMILY 'ROTATION)
                             FSDEVICE ← (FONTPROP
 FAMILY 'DEVICE))
                      FAMILY)
           else
 (CL:WHEN (AND (EQ 'CLASS (CAR (LISTP FAMILY)))
                              (LITATOM (CADR FAMILY)))

                    (* ;; "This used to be at the entry to FONTCREATE, and it returned the FONTCLASS.  That seemed wrong--FONTCREATE should always return a fontdescriptor.  So here we build a throwaway fontclass, coerce it to its device font, and fall through.")


                    (SETQ FAMILY (\FONT.CHECKARGS1
 (FONTCLASS
 (CADR FAMILY)
                                                          (CDDR FAMILY))
                                        DEVICE)))
                (CL:UNLESS (AND FAMILY (LITATOM FAMILY)
                                (NEQ FAMILY T))

                    (* ;; "FAMILY T or NIL produces an error below")


                    [if
 (LISTP FAMILY)
                        then
 
                             (* ;; "Presumably a FONTSPEC.  The variables here override the FONTX properties, as with the fontdescriptor below ")


                             (SETQ FONTX (CL:IF (EQ 'FONT (CAR FAMILY))
                                             (CDR FAMILY)
                                             FAMILY))
                             (SETQ FAMILY (FSPROP FONTX FSFAMILY))
                             (SETQ SIZE (OR SIZE (FSPROP FONTX FSSIZE)))
                             (SETQ FACE (OR FACE (FSPROP FONTX FSFACE)))
                             (SETQ ROTATION (OR ROTATION (FSPROP FONTX FSROTATION)))
                             (SETQ DEVICE (OR DEVICE (FSPROP FONTX FSDEVICE)))
                             (SETQ FONTX NIL)
                      elseif
 (SETQ FONTX (CL:IF (type?
 FONTDESCRIPTOR FAMILY)
                                             FAMILY
                                             (\FONT.CHECKARGS1
 FAMILY DEVICE T)))
                        then
 
                             (* ;; 

                    "FAMILY was a spec for a font descriptor. Are any of its properties overwritten?")


                             (SETQ FAMILY (FONTPROP
 FONTX 'FAMILY))
                             (CL:UNLESS SIZE
                                 (SETQ SIZE (FONTPROP
 FONTX 'SIZE)))
                             (CL:UNLESS FACE
                                 (SETQ FACE (FONTPROP
 FONTX 'FACE)))
                             (CL:UNLESS ROTATION
                                 (SETQ ROTATION (FONTPROP
 FONTX 'ROTATION)))
                             (CL:UNLESS DEVICE
                                 (SETQ DEVICE (FONTPROP
 FONTX 'DEVICE)))]) 

                (* ;; "We have decoded the arguments, fill in defaults and validate")


                (SETQ DEVICE (if
 (NULL DEVICE)
                                 then
 'DISPLAY
                               elseif
 (OR (AND (LITATOM DEVICE)
                                               (NEQ DEVICE T))
                                          (STRINGP DEVICE))
                                 then
 (\DEVICESYMBOL
 DEVICE)
                               elseif
 [AND (SETQ DEVICE (\GETSTREAM DEVICE 'OUTPUT T))
                                           (CAR (MKLIST (IMAGESTREAMTYPE DEVICE]
                               else
 (\ILLEGAL.ARG DEVICE)))
                (CL:UNLESS (AND FAMILY (LITATOM FAMILY)
                                (NEQ FAMILY T))
                       (ERROR "Illegal font family" FAMILY))
                (SETQ FAMILY (U-CASE FAMILY))
                (CL:UNLESS (OR (AND (FIXP SIZE)
                                    (IGEQ SIZE 0))
                               (EQ SIZE '*))
                       (ERROR "Illegal font size" SIZE))
                (CL:UNLESS (EQ FACE '*)
                    (SETQ FACE (\FONTFACE
 FACE NIL DEVICE)))
                (if
 (NULL ROTATION)
                    then
 (SETQ ROTATION 0)
                  elseif
 (EQ ROTATION '*)
                  elseif
 (NUMBERP ROTATION)
                  else
 (\ILLEGAL.ARG ROTATION))
                (CL:WHEN FONTX

                    (* ;; "Return FONTX only if no fields were overwritten")


                    (CL:UNLESS [AND (NOT ALWAYSFONTSPEC)
                                    (EQ FAMILY (FONTPROP
 FONTX 'FAMILY))
                                    (EQ SIZE (FONTPROP
 FONTX 'SIZE))
                                    (EQUAL FACE (FONTPROP
 FONTX 'FACE))
                                    (EQ ROTATION (FONTPROP
 FONTX 'ROTATION))
                                    (EQ DEVICE (FONTPROP
 FONTX 'DEVICE]
                           (SETQ FONTX NIL)))
                (OR FONTX (MAKEFONTSPEC
 FAMILY SIZE FACE ROTATION DEVICE])

(\CHARSET.CHECK

  [LAMBDA (CHARSET)
                                          (* ; "Edited 28-Aug-2025 14:35 by rmk")

    (if
 CHARSET
        then
 (CHARSET.DECODE (CL:IF (LISTP CHARSET)
                                 (CAR CHARSET)
                                 CHARSET))
      else
 0])
)
(DEFINEQ

(COERCEFONTSPEC

  [LAMBDA (FONTSPEC COERCIONS ALL MISSINGOK)
                 (* ; "Edited 13-Sep-2026 11:49 by rmk")


                                                             (* ; "Edited  3-Sep-2026 19:53 by rmk")


                                                             (* ; "Edited  2-Apr-2026 00:08 by rmk")


                                                             (* ; "Edited 11-Mar-2026 10:18 by rmk")


                                                             (* ; "Edited 22-Dec-2025 22:56 by rmk")


                                                             (* ; "Edited 18-Dec-2025 16:06 by rmk")


                                                             (* ; "Edited  2-Dec-2025 17:24 by rmk")


                                                             (* ; "Edited 25-Nov-2025 20:37 by rmk")


                                                             (* ; "Edited  9-Nov-2025 17:54 by rmk")


                                                             (* ; "Edited  5-Oct-2025 09:41 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:41 by rmk")


                                                             (* ; "Edited 25-Aug-2025 10:22 by rmk")


                                                             (* ; "Edited 17-Aug-2025 19:15 by rmk")


                                                             (* ; "Edited 16-Aug-2025 17:47 by rmk")


                                                             (* ; "Edited 12-Aug-2025 12:30 by rmk")


                                                             (* ; "Edited 10-Aug-2025 12:03 by rmk")


                                                             (* ; "Edited  5-Aug-2025 17:27 by rmk")


                                                             (* ; "Edited 23-Jul-2025 15:39 by rmk")


    (* ;; "If ALL, produces a list of coerced fontspecs, one for each coercion to an existing font whose right side matches the given FONTSPEC parameters.  Otherwise, returns the first matching coercion.")


    (* ;; "The recursion allows for coercions on multiple dimensions (e.g. family, and then size).")


    (* ;; "Doesn't make sense to coerce the device, DEVICE is just carried along.")


    (DECLARE
 (SPECVARS FONTSPEC))
    (CL:WHEN (LITATOM COERCIONS)
        [SETQ COERCIONS (FONTDEVICEPROP
 FONTSPEC (OR COERCIONS 'FONTCOERCIONS])
    (if
 (EQ '* (FSPROP FONTSPEC FSFAMILY))
        then
 [for
 C F RESULT in
 COERCIONS eachtime
 (SETQ F (CAR C))
                                                (CL:IF (LISTP F)
                                                    (SETQ F (CAR F)))
                unless
 (EQ F '*) join
 (COERCEFONTSPEC
 (create
 FONTSPEC
                                                         using
 FONTSPEC FSFAMILY ← F FSFACE ←
                                                               (\FONTFACE
 (FSPROP FONTSPEC FSFACE)))
                                             COERCIONS ALL MISSINGOK)
                finally
 (RETURN (CL:REMOVE-DUPLICATES $$VAL :TEST (FUNCTION EQUAL
]
      else
 (for
 C RESULT MATCH TARGET MFAMILY MSIZE MFACE MROTATION TFAMILY TSIZE TFACE TROTATION 
                TDEVICE COERCED FAMILY SIZE FACE ROTATION DEVICE in
 COERCIONS
              declare
 (SPECVARS FAMILY SIZE FACE ROTATION DEVICE) first
 (SPREADFONTSPEC FONTSPEC)
              when
 [SETQ COERCED (if
 (AND C (LITATOM C))
                                     then
 (APPLY* C FONTSPEC FAMILY SIZE FACE ROTATION DEVICE)
                                   else
 (SETQ MATCH (MKLIST (CAR C)))
                                        (CL:WHEN [AND (COERCEFONTSPEC.MATCH (pop
 MATCH)
                                                             FAMILY)
                                                      (COERCEFONTSPEC.MATCH (pop
 MATCH)
                                                             SIZE)
                                                      (MATCHFONTFACE
 (\FONTFACE
 (OR (pop
 MATCH)
                                                                                    '*))
                                                             FACE)
                                                      (COERCEFONTSPEC.MATCH (pop
 MATCH)
                                                             ROTATION)
                                                      (COERCEFONTSPEC.MATCH (pop
 MATCH)
                                                             DEVICE)
                                                      (PROGN (SETQ TARGET (MKLIST (CADR C)))
                                                             (SETQ TFAMILY (COERCEFONTSPEC.TARGET
                                                                            (pop
 TARGET)
                                                                            FAMILY))
                                                             (SETQ TSIZE (COERCEFONTSPEC.TARGET
                                                                          (pop
 TARGET)
                                                                          SIZE))
                                                             (SETQ TFACE (COERCEFONTSPEC.TARGETFACE

                                                                          (pop
 TARGET)
                                                                          FACE))
                                                             (SETQ TROTATION (COERCEFONTSPEC.TARGET
                                                                              ROTATION
                                                                              (pop
 TARGET)))
                                                             (SETQ TDEVICE (COERCEFONTSPEC.TARGET
                                                                            (pop
 TARGET)
                                                                            DEVICE))

                                                             (* ;; 

                                "Don't include the input in the output, if the coercions have a loop")


                                                             (NOT (AND (EQ FAMILY TFAMILY)
                                                                       (EQ SIZE TSIZE)
                                                                       (EQUAL FACE TFACE)
                                                                       (EQ ROTATION TROTATION)
                                                                       (EQ DEVICE TDEVICE]
                                               (MAKEFONTSPEC
 TFAMILY TSIZE TFACE TROTATION TDEVICE]
              unless
 (MEMBER COERCED RESULT) when
 (OR MISSINGOK (FONTEXISTS?
 COERCED T))
              do
 
                 (* ;; "If COERCED exists, it's a singleton whether or not ALL.  We always inflate it to a list, to simplify code")


                 (for
 C in
 (CONS COERCED (CL:IF ALL (COERCEFONTSPEC
 COERCED COERCIONS ALL MISSINGOK))
                                 ) unless
 (MEMBER C RESULT) do
 (push
 RESULT C))
              finally
 (RETURN (DREVERSE RESULT])

(COERCEFONTSPEC.TARGETFACE

  [LAMBDA (TFACE FFACE)
                                      (* ; "Edited 22-Dec-2025 22:54 by rmk")

    (if
 (MEMB TFACE '(NIL *
))
        then
 FFACE
      else
 (MAKEFONTFACE
 (COERCEFONTSPEC.TARGET (fetch
 (FONTFACE WEIGHT) of
 TFACE)
                                (fetch
 (FONTFACE WEIGHT) of
 FFACE))
                  (COERCEFONTSPEC.TARGET (fetch
 (FONTFACE SLOPE) of
 TFACE)
                         (fetch
 (FONTFACE SLOPE) of
 FFACE))
                  (COERCEFONTSPEC.TARGET (fetch
 (FONTFACE EXPANSION) of
 TFACE)
                         (fetch
 (FONTFACE EXPANSION) of
 FFACE])
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FONTCREATE
 MACRO
 [ARGS (CL:IF (CDR ARGS)
                                     'IGNOREMACRO
                                     `(\DTEST ,(CAR ARGS)
                                             'FONTDESCRIPTOR))])
)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS COERCEFONTSPEC.MATCH
 MACRO
 [(M F)                  (* ; "* can't be car--comment")

                                      (LET ((MM M)
                                            *
)
                                           (DECLARE
 (LOCALVARS MM)
                                                  (SPECVARS *
))
                                           (SETQ *
 F)
                                           (OR (EQ *
 MM)
                                               (MEMB MM '(NIL *
))
                                               (AND (LISTP MM)
                                                    (EVAL MM])

(PUTPROPS COERCEFONTSPEC.TARGET
 MACRO

          (OPENLAMBDA (TG F)
            (if
 (MEMB TG '(NIL *
))
                then
 F
              elseif
 (AND (LISTP TG)
                          (LET (VAL *
)
                               (DECLARE
 (LOCALVARS VAL)
                                      (SPECVARS *
))          (* ; "* Can't be car--comment")

                               (SETQ *
 F)
                               (SETQ VAL (EVAL TG))
                               (CL:IF (MEMB VAL '(NIL *
))
                                   F
                                   VAL)))
              else
 TG)))
)
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS SPREADFONTSPEC
 MACRO
 [(FSPEC)
                                (LET ((FS FSPEC))

                                     (* ;; "Unwrap a FONTSPEC ")


                                     (CL:WHEN (type?
 FONTDESCRIPTOR FS)
                                         (SETQ FS (FONTPROP
 FS 'SPEC)))
                                     (SETQ FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 FS))
                                     (SETQ SIZE (fetch
 (FONTSPEC FSSIZE) of
 FS))
                                     (SETQ FACE (fetch
 (FONTSPEC FSFACE) of
 FS))
                                     (SETQ ROTATION (fetch
 (FONTSPEC FSROTATION) of
 FS))
                                     (SETQ DEVICE (fetch
 (FONTSPEC FSDEVICE) of
 FS])
)
(DEFINEQ

(MAKEFONTSPEC

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE BASE)
            (* ; "Edited 30-Sep-2026 16:45 by rmk")


                                                             (* ; "Edited 22-Sep-2026 00:06 by rmk")


                                                             (* ; "Edited  3-Sep-2026 23:24 by rmk")


                                                             (* ; "Edited  4-May-2026 12:38 by rmk")


                                                             (* ; "Edited 15-Apr-2026 00:25 by rmk")


                                                             (* ; "Edited  7-Nov-2025 07:52 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:32 by rmk")


                                                             (* ; "Edited 17-Aug-2025 20:44 by rmk")


    (* ;; "This is a function, not a macro, so that it can be used in the loadup sequence to create the FONTSPEC for the \GUARANTEEDDISPLAYFONT.  That font is created by \CREATEFONT and therefore is not dependent on \FONT.CHECKARGS or on the multi-alist multi-key indexing functions.  The strategy might change if MULTI-ALIST is moved earlier in the loadup sequence.")


    (* ;; "BASE (fontspec or font) provides defaults for NIL arguments, essentialy models a (create using BASE...)")


    (CL:WHEN (type?
 FONTSPEC FAMILY)
           (SPREADFONTSPEC FAMILY))
    (CL:WHEN (type?
 FONTDESCRIPTOR BASE)
        (SETQ BASE (create
 FONTSPEC
                          FSFAMILY ← (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 BASE)
                          FSSIZE ← (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 BASE)
                          FSFACE ← (fetch
 (FONTDESCRIPTOR FONTFACE) of
 BASE)
                          FSROTATION ← (fetch
 (FONTDESCRIPTOR FONTROTATION) of
 BASE)
                          FSDEVICE ← (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 BASE))))
    (CL:WHEN FACE
        (SETQ FACE (\FONTFACE
 FACE)))
    (create
 FONTSPEC
           FSFAMILY ← (OR FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 BASE))
           FSSIZE ← (OR SIZE (fetch
 (FONTSPEC FSSIZE) of
 BASE))
           FSFACE ← (OR (AND FACE (\FONTFACE
 FACE))
                        (fetch
 (FONTSPEC FSFACE) of
 BASE))
           FSROTATION ← (OR ROTATION (fetch
 (FONTSPEC FSROTATION) of
 BASE))
           FSDEVICE ← (OR DEVICE (fetch
 (FONTSPEC FSDEVICE) of
 BASE])

(FONTSPEC.TO.FONTDESCRIPTOR

  [LAMBDA (FONTSPEC MAXCHARSET CHARENCODING SCALE)
           (* ; "Edited 30-Sep-2026 16:47 by rmk")


                                                             (* ; "Edited  5-Sep-2026 22:27 by rmk")


                                                             (* ; "Edited  3-Sep-2026 13:58 by rmk")


                                                             (* ; "Edited  1-Sep-2026 11:19 by rmk")


                                                             (* ; "Edited  5-May-2026 09:55 by rmk")


                                                             (* ; "Edited 29-Mar-2026 10:29 by rmk")


                                                             (* ; "Edited 28-Mar-2026 09:29 by rmk")


                                                             (* ; "Edited 20-Mar-2026 23:57 by rmk")


                                                             (* ; "Edited 19-Mar-2026 10:24 by rmk")


                                                             (* ; "Edited 12-Mar-2026 13:29 by rmk")

    (if
 (NULL MAXCHARSET)
        then
 (SETQ MAXCHARSET 255)
      elseif
 (<= 0 MAXCHARSET \MAXCHARSET)
      else
 (\ILLEGAL.ARG MAXCHARSET))
    (LET ((FONT (create
 FONTDESCRIPTOR
                       FONTFAMILY ← (FSPROP FONTSPEC FSFAMILY)
                       FONTSIZE ← (FSPROP FONTSPEC FSSIZE)
                       FONTFACE ← (COPY (FSPROP FONTSPEC FSFACE))
                       FONTROTATION ← (FSPROP FONTSPEC FSROTATION)
                       FONTDEVICE ← (FSPROP FONTSPEC FSDEVICE)
                       FONTDEVICESPEC ← (COPY (create
 FONTSPEC using
 FONTSPEC))
                       FONTSCALE ← (OR SCALE 1)
                       FONTCHARENCODING ← CHARENCODING
                       FONTTOMCCSFN ← (MCCSMAPFN (OR CHARENCODING FONTSPEC))
                       MAXCHARSET ← MAXCHARSET
                       FONTCHARSETVECTOR ← NIL)))            (* ; 

                                               "Defer the vector so it takes MAXCHARSET into account")

         (replace
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONT with
 (\CREATEFONTCHARSETVECTOR FONT))
         FONT])

(FONT.CHANGESPEC

  [LAMBDA (FONT FONTSPEC DEVICESPEC)
                         (* ; "Edited 30-Sep-2026 16:47 by rmk")


                                                             (* ; "Edited  3-Sep-2026 20:03 by rmk")

    (CL:WHEN FONT
        (replace
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT with
 (FSPROP FONTSPEC FSFAMILY))
        (replace
 (FONTDESCRIPTOR FONTSIZE) of
 FONT with
 (FSPROP FONTSPEC FSSIZE))
        (replace
 (FONTDESCRIPTOR FONTFACE) of
 FONT with
 (FSPROP FONTSPEC FSFACE))
        (replace
 (FONTDESCRIPTOR FONTROTATION) of
 FONT with
 (FSPROP FONTSPEC FSROTATION))
        (replace
 (FONTDESCRIPTOR FONTDEVICE) of
 FONT with
 (FSPROP FONTSPEC FSDEVICE))
        (CL:UNLESS (EQ DEVICESPEC T)
            (replace
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT with
 DEVICESPEC))
        FONT)])
)
(DEFINEQ

(COMPLETE.FONT

  [LAMBDA (FONT EVENIFCOMPLETE)
                              (* ; "Edited  5-Apr-2026 01:01 by rmk")


                                                             (* ; "Edited 24-Mar-2026 22:35 by rmk")


                                                             (* ; "Edited 22-Mar-2026 22:32 by rmk")


                                                             (* ; "Edited 21-Mar-2026 09:20 by rmk")


                                                             (* ; "Edited 19-Mar-2026 09:30 by rmk")


                                                             (* ; "Edited 16-Mar-2026 09:30 by rmk")


                                                             (* ; "Edited  7-Oct-2025 17:01 by rmk")


                                                             (* ; "Edited 21-Jun-2025 11:37 by rmk")


                                                             (* ; "Edited 23-May-2025 22:57 by rmk")


                                                             (* ; "Edited 16-May-2025 21:26 by rmk")


    (* ;; "This completes FONT with respect to all currently known character sources.  A caller that wants to insure that only file sources are considered should reset \FONTSINCORE and \FONTEXISTS?-CACHE. ")


    (* ;; "This assumes that all of the fonts in the coercion chain are already complete.  ")


    (LET (CHANGED)
         (CL:WHEN (AND (OR EVENIFCOMPLETE (NOT (fetch
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT)))
                       (COERCEFONTSPEC
 (FONTPROP
 FONT 'SPEC)
                              'CHARCOERCIONS NIL T))
             (for
 CHARSET from
 0 to
 (MAXCHARSET FONT) when
 (COMPLETE.CHARSET
 FONT CHARSET)
                do
 (SETQ CHANGED T)))
         (CL:UNLESS (fetch
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT)
             (replace
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT with
 T)
             (SETQ CHANGED T))
         CHANGED])

(COMPLETEFONTP

  [LAMBDA (FONT)
                                             (* ; "Edited 18-Mar-2026 23:10 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 24-May-2025 20:55 by rmk")


                                                             (* ; "Edited 20-May-2025 14:37 by rmk")


    (* ;; "A font is incomplete if there is a NIL in any charset slot.  Completing will install a charset everywhere, even if it is a slug charset.")


    (SETQ FONT (FONTCREATE
 FONT))
    (for
 CS from
 0 to
 (MAXCHARSET FONT) always
 (\GETCHARSETINFO FONT CS])

(COMPLETE.CHARSET

  [LAMBDA (FONT CHARSET)
                                     (* ; "Edited 14-Sep-2026 00:24 by rmk")


                                                             (* ; "Edited 12-Sep-2026 00:07 by rmk")


                                                             (* ; "Edited  5-Apr-2026 11:33 by rmk")


                                                             (* ; "Edited 15-Mar-2026 17:20 by rmk")


                                                             (* ; "Edited  6-Mar-2026 21:42 by rmk")


                                                             (* ; "Edited  7-Sep-2025 11:23 by rmk")


                                                             (* ; "Edited 31-Aug-2025 14:36 by rmk")


                                                             (* ; "Edited 28-Aug-2025 20:46 by rmk")


                                                             (* ; "Edited 27-Aug-2025 12:37 by rmk")


                                                             (* ; "Edited 17-Aug-2025 11:47 by rmk")


                                                             (* ; "Edited 12-Jul-2025 13:15 by rmk")


                                                             (* ; "Edited 10-Jul-2025 12:38 by rmk")


                                                             (* ; "Edited  9-Jul-2025 09:12 by rmk")


                                                             (* ; "Edited 21-Jun-2025 08:49 by rmk")


                                                             (* ; "Edited 18-Jun-2025 23:18 by rmk")


                                                             (* ; "Edited  8-Jun-2025 20:20 by rmk")


                                                             (* ; "Edited  7-Jun-2025 13:52 by rmk")


    (* ;; "Return T if anything changed.")


    (LET ((FONTSPEC (FONTPROP
 FONT 'DEVICESPEC))
          (CSINFO (\GETCHARSETINFO FONT CHARSET))
          CHANGED)
         (CL:UNLESS CSINFO
             (SETQ CSINFO (SLUGCSINFO FONT))
             (SETQ CHANGED T))
         (CL:UNLESS (fetch
 (CHARSETINFO CSCOMPLETEP) of
 CSINFO)
             [if
 (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)
                 then
 
                      (* ;; "If CSINFO is a slug and there is a non-slug down the coercion chain, copy that in.  Presumably that gets filed as an indirect.")


                      [SETQ CSINFO (CADR (\COERCECHARSET
 FONTSPEC CHARSET NIL 'CHARCOERCIONS]
                      (CL:WHEN (AND CSINFO (NOT (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)))
                          (\INSTALLCHARSETINFO
 FONT (COPYALL CSINFO)
                                 CHARSET)
                          (SETQ CHANGED T))
               else
 
                    (* ;; "CSINFO  in FONT has some characters for this charset, but others may fill in from later fonts in the coercion chain. We assume that CSINFO is or will be the charsetinfo for the charset/font described by FONTSPEC.  For each missing code we look through all the possible coercions to find the first font with real information about that character. We copy that character up to CSINFO.")


                    (for
 CODE SOURCEFONT from
 (FIRSTCHARSETCODE CHARSET) to
 (LASTCHARSETCODE CHARSET)
                       when
 [AND (SLUGCHARP
 FONT CODE)
                                 (SETQ SOURCEFONT (CAR (\COERCECHARSET
 FONTSPEC CHARSET CODE]
                       collect
 (LIST CODE (LIST CODE SOURCEFONT))
                       finally
 (CL:WHEN $$VAL
                                   (MOVEFONTCHARS
 $$VAL FONT)(* ; "The source is now here")

                                   (CHARSETPROP CSINFO 'SOURCE FONTSPEC))
                             (CL:UNLESS (FONTDEVICEPROP
 FONT 'CHARCOERCIONS)
                                                             (* ; 

                                                             "Maybe coercions are just being delayed")

                                 (replace
 (CHARSETINFO CSCOMPLETEP) of
 CSINFO with
 T))
                             (CL:WHEN $$VAL (SETQ CHANGED T])
         CHANGED])

(PRUNESLUGCSINFOS

  [LAMBDA (FONT)
                                             (* ; "Edited 22-Mar-2026 18:21 by rmk")


                                                             (* ; "Edited 19-Mar-2026 09:29 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 31-Aug-2025 14:36 by rmk")


                                                             (* ; "Edited 17-Aug-2025 19:44 by rmk")


                                                             (* ; "Edited  9-Jun-2025 15:02 by rmk")


                                                             (* ; "Edited 24-May-2025 21:11 by rmk")


    (* ;; "Replaces slug csinfos in FONT with NIL, returns the number of non-slug charsets")


    (SETQ FONT (FONTCREATE
 FONT))
    (for
 CS CSINFO CHANGED (NREAL ← 0) from
 0 to
 (MAXCHARSET FONT) when
 (SETQ CSINFO (\GETCHARSETINFO
                                                                                      FONT CS))
       do
 (CL:IF (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)
              (\SETCHARSETINFO FONT CS NIL)
              (add
 NREAL 1)) finally
 (RETURN NREAL])

(MONOSPACEFONTP

  [LAMBDA (FONT CODES SKIPSLUGS RETURNVARIABLES)
             (* ; "Edited 14-Sep-2026 00:24 by rmk")


                                                             (* ; "Edited 15-Mar-2026 14:24 by rmk")


                                                             (* ; "Edited 12-Oct-2025 21:13 by rmk")


    (* ;; "Returns T if all the CODES are the same width.  Skips slugs if SKIPSLUGHTS, returns the list of variable width characters if RETURNVARIABLES (instead of NIL).")


    (* ;; "If CODES is a charset, checks all the codes in that charset.  Otherwise, can be a (firstcode lastcode) list (e.g. (0 127) to check 7-bit ascii.FIX")


    (SETQ FONT (FONTCREATE
 FONT))
    [SETQ CODES (if
 (LISTP CODES)
                    then
 [LIST (OR (CHARCODEP (CAR CODES))
                                   (CHARCODE.DECODE (CAR CODES)))
                               (OR (CHARCODEP (CADR CODES))
                                   (CHARCODE.DECODE (CADR CODES]
                  else
 (SETQ CODES (\CHARSET.CHECK
 CODES))
                       (LIST (FIRSTCHARSETCODE CODES)
                             (LASTCHARSETCODE CODES]
    (for
 CODE WIDTH from
 (CAR CODES) to
 (CADR CODES)
       unless
 (OR (AND SKIPSLUGS (SLUGCHARP
 FONT CODE))
                  (EQ (OR WIDTH (SETQ WIDTH (CHARWIDTH
 CODE FONT)))
                      (CHARWIDTH
 CODE FONT))) collect
 CODE
       finally
 (RETURN (if
 (NULL $$VAL)
                         elseif
 RETURNVARIABLES
                           then
 (SORT $$VAL])
)



(* ;; "Property extraction:")


(DEFINEQ

(FONTASCENT

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited  1-Sep-2026 11:19 by rmk")


                                                             (* ; "Edited 14-Jul-2025 22:52 by rmk")


                                                             (* ; "Edited  5-Jul-2025 18:47 by rmk")

                                                             (* lmm "19-NOV-82 00:23")

    (ffetch
 (FONTDESCRIPTOR FONTASCENT) of
 (FONTCREATE
 FONTSPEC])

(FONTDESCENT

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited  2-Sep-2026 22:41 by rmk")


                                                             (* ; "Edited  1-Sep-2026 11:22 by rmk")


                                                             (* ; "Edited 14-Jul-2025 22:53 by rmk")


                                                             (* ; "Edited  5-Jul-2025 18:47 by rmk")

                                                             (* lmm "19-NOV-82 00:24")

                                                             (* ; "See comment in FONTASCENT")

    (ffetch
 (FONTDESCRIPTOR FONTDESCENT) of
 (FONTCREATE
 FONTSPEC])

(FONTHEIGHT

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited  1-Sep-2026 11:23 by rmk")


                                                             (* ; "Edited 14-Jul-2025 22:52 by rmk")


                                                             (* ; "Edited  5-Jul-2025 18:47 by rmk")

                                                             (* kbr%: " 9-Jan-86 18:29")

    (fetch
 (FONTDESCRIPTOR FONTHEIGHT) of
 (FONTCREATE
 FONTSPEC])

(FONTPROP

  [LAMBDA (FONT PROP)
                                        (* ; "Edited  2-Oct-2026 21:54 by rmk")


                                                             (* ; "Edited 30-Sep-2026 16:44 by rmk")


                                                             (* ; "Edited  4-Sep-2026 11:10 by rmk")


                                                             (* ; "Edited  2-Sep-2026 22:41 by rmk")


                                                             (* ; "Edited  1-Sep-2026 11:19 by rmk")


                                                             (* ; "Edited 12-Apr-2026 12:52 by rmk")


                                                             (* ; "Edited 25-Jan-2026 20:08 by rmk")


                                                             (* ; "Edited  2-Dec-2025 16:01 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:21 by rmk")


                                                             (* ; "Edited 23-Jul-2025 17:01 by rmk")


                                                             (* ; "Edited 13-Jul-2025 22:44 by rmk")


                                                             (* ; "Edited  8-Jun-2025 20:42 by rmk")


                                                             (* ; "Edited  2-May-2025 19:59 by rmk")

                                                             (* kbr%: "13-May-85 22:36")

    (SETQ FONT (FONTCREATE
 FONT))
    (SELECTQ PROP
        (HEIGHT (ffetch
 (FONTDESCRIPTOR FONTHEIGHT) of
 FONT))
        (ASCENT (ffetch
 (FONTDESCRIPTOR FONTASCENT) of
 FONT))
        (DESCENT (ffetch
 (FONTDESCRIPTOR FONTDESCENT) of
 FONT))
        (FAMILY (ffetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT))
        (SIZE (ffetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONT))
        (FACE (COPY (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)))
        (WEIGHT (fetch
 (FONTFACE WEIGHT) of
 (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)))
        (SLOPE (ffetch
 (FONTFACE SLOPE) of
 (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)))
        (EXPANSION (ffetch
 (FONTFACE EXPANSION) of
 (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)))
        (FORECOLOR (ffetch
 (FONTFACE FORECOLOR) of
 (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)))
        (BACKCOLOR (ffetch
 (FONTFACE BACKCOLOR) of
 (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)))
        (ROTATION (ffetch
 (FONTDESCRIPTOR FONTROTATION) of
 FONT))
        (DEVICE (ffetch
 (FONTDESCRIPTOR FONTDEVICE) of
 FONT))
        (FILENAME (CL:WHEN (ffetch
 (FONTDESCRIPTOR FONTFILENAME) of
 FONT)
                      (INFILEP (ffetch
 (FONTDESCRIPTOR FONTFILENAME) of
 FONT))))
        (CHARENCODING (ffetch
 (FONTDESCRIPTOR FONTCHARENCODING) of
 FONT))
        (OTHERDEVICEFONTPROPS 
             (ffetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of
 FONT))
        (SPEC (create
 FONTSPEC
                     FSFAMILY ← (ffetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT)
                     FSSIZE ← (ffetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONT)
                     FSFACE ← (COPY (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT))
                     FSROTATION ← (ffetch
 (FONTDESCRIPTOR FONTROTATION) of
 FONT)
                     FSDEVICE ← (ffetch
 (FONTDESCRIPTOR FONTDEVICE) of
 FONT)))
        (DEVICESPEC                                          (* ; 

                    "DEVICE fields are for communicating coercions to the particular printing device")

                    (CL:IF (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT)
                        (COPY (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT))
                        (FONTPROP
 FONT 'SPEC)))
        (DEVICEFAMILY (CL:IF (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT)
                          (fetch
 (FONTSPEC FSFAMILY) of
 (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC)
                                                           of
 FONT))
                          (ffetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT)))
        (DEVICESIZE (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                        (fetch
 (FONTSPEC FSSIZE) of
 (ffetch
 FONTDEVICESPEC of
 FONT))
                        (ffetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONT)))
        (DEVICEFACE (COPY (CL:IF (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT)
                              (fetch
 (FONTSPEC FSFACE) of
 (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC)
                                                             of
 FONT))
                              (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT))))
        (DEVICESLOPE (fetch
 SLOPE of
 (CL:IF (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT)
                                         (fetch
 (FONTSPEC FSFACE) of
 (ffetch
 (FONTDESCRIPTOR 
                                                                                    FONTDEVICESPEC)
                                                                        of
 FONT))
                                         (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT))))
        (DEVICEWEIGHT (fetch
 (FONTFACE WEIGHT) of
 (CL:IF (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC)
                                                            of
 FONT)
                                                      (fetch
 (FONTSPEC FSFACE)
                                                         of
 (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC)
                                                               of
 FONT))
                                                      (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT))))
        (DEVICEEXPANSION 
             (fetch
 (FONTFACE EXPANSION) of
 (CL:IF (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC)
                                                      of
 FONT)
                                                (fetch
 (FONTSPEC FSFACE) of
 (ffetch
 (FONTDESCRIPTOR
                                                                                     FONTDEVICESPEC)
                                                                               of
 FONT))
                                                (ffetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT))))
        (SCALE (ffetch
 (FONTDESCRIPTOR FONTSCALE) of
 FONT))
        (CHARSETS (for
 CS CSINFO from
 0 to
 (MAXCHARSET FONT) eachtime
 (SETQ CSINFO (\GETCHARSETINFO
                                                                                    FONT CS))
                     when
 CSINFO unless
 (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO) collect
 CS))
        (MAXCHARSET (MAXCHARSET FONT))
        (NEMPTYCHARSETS 
             (for
 CS CSINFO from
 0 to
 (MAXCHARSET FONT) eachtime
 (SETQ CSINFO (\GETCHARSETINFO FONT 
                                                                                     CS))
                when
 CSINFO count
 (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)))
        (NINSTANTIATEDCHARSETS 
             (for
 CS CSINFO from
 0 to
 (MAXCHARSET FONT) eachtime
 (SETQ CSINFO (\GETCHARSETINFO FONT 
                                                                                     CS))
                when
 CSINFO count
 (NOT (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO))))
        (NUNINSTANTIATEDCHARSETS 
             (for
 CS CSINFO from
 0 to
 (MAXCHARSET FONT) eachtime
 (SETQ CSINFO (\GETCHARSETINFO FONT 
                                                                                     CS))
                count
 (NULL CSINFO)))
        (AVGCHARWIDTH (ffetch
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT))
        (FONTTOMCCSFN (ffetch
 (FONTDESCRIPTOR FONTTOMCCSFN) of
 FONT))
        (\ILLEGAL.ARG PROP])

(\AVGCHARWIDTH

  [LAMBDA (FONT)
                                             (* ; "Edited 10-Jul-2025 23:24 by rmk")


                                                             (* ; "Edited 20-May-2025 21:03 by rmk")

                                                             (* rmk%: "27-Nov-84 18:40")


    (* ;; "Returns the average width of a character, to be used in units-to-characters approximations, as in fixing the linelength")


    (LET ((W (CHARWIDTH
 (CHARCODE A)
                    FONT)))
         (if
 (NEQ 0 W)
             then
 W
           elseif
 [NEQ 0 (SETQ W (FIXR (FTIMES 0.6 (FONTPROP
 FONT 'HEIGHT]
             then
 W
           else
 1])
)
(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS FONTPROP
 MACRO

          [ARGS (LET ((FONT (CAR ARGS))
                      (PROP (CADR ARGS))
                      FORM)
                     (if
 (EQ (CAR PROP)
                             'QUOTE)
                         then
 (SETQ PROP (CADR PROP))        (* ; 

                                                 "fetch forces type check, don't replace with ffetch")

                              [SETQ FORM (CADR (ASSOC PROP '((HEIGHT FONTHEIGHT)
                                                             (ASCENT FONTASCENT)
                                                             (DESCENT FONTDESCENT)
                                                             (FAMILY FONTFAMILY)
                                                             (SIZE FONTSIZE)
                                                             (FACE (COPY (fetch
 (FONTDESCRIPTOR
                                                                                 FONTFACE)
                                                                            of
 FD)))
                                                             (WEIGHT (fetch
 (FONTFACE WEIGHT)
                                                                        of
 (fetch
 (FONTDESCRIPTOR
                                                                                   FONTFACE)
                                                                              of
 FD)))
                                                             (SLOPE (fetch
 (FONTFACE SLOPE)
                                                                       of
 (fetch
 (FONTDESCRIPTOR
                                                                                  FONTFACE)
                                                                             of
 FD)))
                                                             (EXPANSION (fetch
 (FONTFACE EXPANSION)
                                                                           of
 (fetch
 (FONTDESCRIPTOR
                                                                                      FONTFACE)
                                                                                 of
 FD)))
                                                             (ROTATION FONTROTATION)
                                                             (DEVICE FONTDEVICE)
                                                             (SCALE FONTSCALE)
                                                             (CHARENCODING FONTCHARENCODING)
                                                             (OTHERDEVICEFONTPROPS 
                                                                    OTHERDEVICEFONTPROPS)
                                                             (AVGCHARWIDTH FONTAVGCHARWIDTH]
                              (if
 FORM
                                  then
 (CL:IF (LITATOM FORM)
                                           (SETQ FORM `(fetch
 (FONTDESCRIPTOR ,FORM) of
 FD))) 

                                       (* ;; 

                     "No need for FONTCREATE, it would just duplicate the type test from the fetches")


                                       (SUBST (CL:IF (EQ (CAR FONT)
                                                         'FONTCREATE)
                                                  (CADR FONT)
                                                  FONT)
                                              'FD FORM)
                                else
 'IGNOREMACRO)
                       else
 'IGNOREMACRO])
)

(* "END EXPORTED DEFINITIONS")

)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FSPROP
 MACRO
 ((FS FIELD)
                        (fetch
 (FONTSPEC FIELD) of
 FS)))
)
(DEFINEQ

(FONTDEVICEPROP

  [LAMBDA NARGS
                                              (* ; "Edited  8-Mar-2026 21:48 by rmk")


                                                             (* ; "Edited  2-Mar-2026 13:14 by rmk")


                                                             (* ; "Edited  1-Mar-2026 12:22 by rmk")


                                                             (* ; "Edited 25-Aug-2025 21:23 by rmk")


    (* ;; "Returns  the value of the PROP property of the FONTDEVICE.  E.g. if FONTDEVICE is DISPLAY and PROP is %"FONTCOERCIONS%", returns the value of DISPLAYFONTCOERCIONS ((HELVETICA 1)(HELVETICA 4)...)")


    (CL:WHEN (ILESSP NARGS 2)
           (ERROR "DEVICE/PROP not specified"))
    (LET ((FONTDEVICE (ARG NARGS 1))
          (PROP (ARG NARGS 2))
          VAR)
         [if
 (LITATOM FONTDEVICE)
             then
 (SETQ FONTDEVICE (\FONTSYMBOL
 FONTDEVICE))
           else
 (SETQ FONTDEVICE (\FONT.CHECKARGS
 FONTDEVICE))
                (SETQ FONTDEVICE (CL:IF (type?
 FONTDESCRIPTOR FONTDEVICE)
                                     (FONTPROP
 FONTDEVICE 'DEVICE)
                                     (fetch
 (FONTSPEC FSDEVICE) of
 FONTDEVICE))]
         (CL:UNLESS FONTDEVICE
             (SETQ FONTDEVICE 'DISPLAY))
         (SETQ VAR (PACK* FONTDEVICE PROP))
         (if
 (EQ PROP 'ENCODINGFN)
             then
 
                  (* ;; "The name of a function")


                  (PROG1 (CL:IF (GETD VAR)
                                VAR)
                      (CL:WHEN (IGEQ NARGS 3)
                          (PUTD VAR (ARG NARGS 3))))
           else
 (PROG1 (CL:WHEN (BOUNDP VAR)
                              (GETATOMVAL VAR))
                    (CL:WHEN (IGEQ NARGS 3)
                        (SETATOMVAL VAR (ARG NARGS 3))))])
)

(PUTPROPS FONTDEVICEPROP
 ARGNAMES
 (FONTDEVICE PROP NEWVALUE))



(* ; "Moving character information")


(DEFINEQ

(EDITCHAR

  [LAMBDA (CHARCODE FONT)
                                    (* ; "Edited 28-Aug-2025 23:50 by rmk")


                                                             (* ; "Edited 14-Jul-2025 22:54 by rmk")


                                                             (* ; "Edited  5-Jul-2025 18:47 by rmk")

                                                             (* rrb "24-MAR-82 12:22")

                                                             (* ; 

                                                   "calls the bitmap editor on a character of a font")

    (SETQ CHARCODE (OR (CHARCODEP CHARCODE)
                       (CHARCODE.DECODE CHARCODE)))
    (LET ((FONTDESC (FONTCREATE
 FONT)))
         (PUTCHARBITMAP
 CHARCODE FONTDESC (EDITBM (GETCHARBITMAP
 CHARCODE FONTDESC])
)



(* ; "Should this be on EDITFONT ?")


(DEFINEQ

(GETCHARBITMAP

  [LAMBDA (CHARCODE FONT)
                                    (* ; "Edited 22-Aug-2026 09:30 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:19 by rmk")


                                                             (* ; "Edited  3-Aug-2025 13:28 by rmk")


                                                             (* ; "Edited  7-Jun-2025 09:55 by rmk")


                                                             (* ; "Edited 22-May-2025 09:52 by rmk")


                                                             (* ; "Edited 25-Apr-2025 11:21 by rmk")


                                                             (* ; "Edited 26-Apr-89 21:49 by atm")

                                                             (* ; 

                      "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.")

    (SETQ CHARCODE (CL:IF (CHARCODEP CHARCODE)
                       CHARCODE
                       (CHARCODE.DECODE CHARCODE)))
    (SETQ FONT (FONTCREATE
 FONT))
    (\GETCHARBITMAP.CSINFO
 (\CHAR8CODE CHARCODE)
           (\INSURECHARSETINFO FONT (\CHARSET CHARCODE))
           FONT])

(PUTCHARBITMAP

  [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT)
       (* ; "Edited  1-Sep-2026 11:22 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:20 by rmk")


                                                             (* ; "Edited  7-Jun-2025 10:16 by rmk")


                                                             (* ; "Edited 25-May-2025 15:10 by rmk")


                                                             (* ; "Edited 22-May-2025 09:56 by rmk")


                                                             (* ; "Edited  1-May-2025 13:21 by rmk")


                                                             (* ; "Edited 25-Apr-2025 11:21 by rmk")


                                                             (* ; "Edited 27-Apr-89 11:19 by atm")


    (* ;; "Stores the bitmap NEWCHARBITMAP as the character CHARCODE in FONT.  If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.")


    (CL:UNLESS (type?
 BITMAP NEWCHARBITMAP)
           (\ILLEGAL.ARG NEWCHARBITMAP))
    (SETQ CHARCODE (CHARCODE.DECODE CHARCODE))
    (SETQ FONT (FONTCREATE
 FONT))
    (LET [(CSINFO (\INSURECHARSETINFO FONT (\CHARSET CHARCODE]
         (UNINTERRUPTABLY
             (CL:WHEN (\PUTCHARBITMAP.CSINFO
 (\CHAR8CODE CHARCODE)
                             CSINFO NEWCHARBITMAP NEWCHARDESCENT)

                 (* ;; "update the ascent/descent properties for the font as a whole.")


                 (LET [(ASCENT (IMAX (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                                     (fetch
 (FONTDESCRIPTOR FONTASCENT) of
 FONT)))
                       (DESCENT (IMAX (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO)
                                      (fetch
 (FONTDESCRIPTOR FONTDESCENT) of
 FONT]
                      (replace
 (FONTDESCRIPTOR FONTASCENT) of
 FONT with
 ASCENT)
                      (replace
 (FONTDESCRIPTOR FONTDESCENT) of
 FONT with
 DESCENT)
                      (replace
 (FONTDESCRIPTOR FONTHEIGHT) of
 FONT with
 (IPLUS ASCENT DESCENT)))))
         NIL NEWCHARBITMAP])

(\GETCHARBITMAP.CSINFO

  [LAMBDA (THINCODE CSINFO FONT)
                             (* ; "Edited 30-Sep-2026 16:45 by rmk")


                                                             (* ; "Edited 25-Aug-2026 20:14 by rmk")


                                                             (* ; "Edited 22-Aug-2026 13:03 by rmk")


                                                             (* ; "Edited  3-Aug-2025 20:59 by rmk")


                                                             (* ; "Edited  7-Jun-2025 09:56 by rmk")


                                                             (* ; "Edited 22-May-2025 09:52 by rmk")


                                                             (* ; "Edited 25-Apr-2025 11:21 by rmk")


                                                             (* ; "Edited 26-Apr-89 21:49 by atm")


    (* ;; "CODE is a thincode")


    (LET (CSBITMAP CBM IMAGEWIDTH IMAGEHEIGHT OFFSET)
         (CL:WHEN (SETQ CSBITMAP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
             (SETQ IMAGEWIDTH (if
 (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                                  then
 (\FGETIMAGEWIDTH (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                                              THINCODE)
                                else
 (\FGETWIDTH (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)
                                            THINCODE)))
             [SETQ IMAGEHEIGHT (if
 (fetch
 (CHARSETINFO YIMAGEWIDTHS) of
 CSINFO)
                                   then
 (\FGETIMAGEWIDTH (fetch
 (CHARSETINFO YIMAGEWIDTHS)
                                                            of
 CSINFO)
                                               THINCODE)
                                 else
 (IPLUS (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                                             (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO]
             (SETQ OFFSET (\FGETOFFSET (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO)
                                 THINCODE))
             (SETQ CBM (BITMAPCREATE IMAGEWIDTH IMAGEHEIGHT (fetch
 (BITMAP BITMAPBITSPERPIXEL)
                                                               of
 CSBITMAP)))
             (SELECTQ (fetch
 (FONTDESCRIPTOR FONTROTATION) of
 FONT)
                 ((0 180) 
                      (BITBLT CSBITMAP OFFSET 0 CBM 0 0 IMAGEWIDTH IMAGEHEIGHT))
                 ((90 270)                                   (* ; "offset is source bottom, not left")

                      (BITBLT CSBITMAP 0 OFFSET CBM 0 0 IMAGEWIDTH IMAGEHEIGHT))
                 (ERROR "Unimplemented font rotation")))
         CBM])

(\PUTCHARBITMAP.CSINFO

  [LAMBDA (THINCODE CSINFO NEWCHARBITMAP NEWCHARDESCENT)
     (* ; "Edited 10-Sep-2026 23:20 by rmk")


                                                             (* ; "Edited 24-Aug-2025 09:56 by rmk")


                                                             (* ; "Edited  7-Jun-2025 10:15 by rmk")


                                                             (* ; "Edited 25-May-2025 15:10 by rmk")


                                                             (* ; "Edited 22-May-2025 09:56 by rmk")


                                                             (* ; "Edited  1-May-2025 13:21 by rmk")


                                                             (* ; "Edited 25-Apr-2025 11:21 by rmk")


                                                             (* ; "Edited 27-Apr-89 11:19 by atm")


    (* ;; "Stores the bitmap NEWCHARBITMAP as the thin character CODE in CSINFO.  If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.")


    (LET* ((CDESCENT (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO))
           (CASCENT (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO))
           (CHEIGHT (IPLUS CDESCENT CASCENT))
           (OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
           (WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
           (IMWIDTHS (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO))
           (CIMWIDTH (AND IMWIDTHS (\FGETIMAGEWIDTH IMWIDTHS THINCODE)))
           (CWIDTH (OR CIMWIDTH (\FGETWIDTH WIDTHS THINCODE)))
           (FONTBITMAP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
           (OFWIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 FONTBITMAP))
           TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET
           (BITSPERPIXEL (fetch
 (BITMAP BITMAPBITSPERPIXEL) of
 FONTBITMAP)))

          (* ;; "fetch the ascents and descents of the bitmap and the new maximums.")


          (SETQ BWIDTH (fetch
 (BITMAP BITMAPWIDTH) of
 NEWCHARBITMAP))
          (SETQ BHEIGHT (fetch
 (BITMAP BITMAPHEIGHT) of
 NEWCHARBITMAP))
          (SETQ BDESCENT (OR NEWCHARDESCENT CDESCENT))
          (SETQ BASCENT (IDIFFERENCE BHEIGHT BDESCENT))
          (SETQ NDESCENT (IMAX BDESCENT CDESCENT))
          (SETQ NASCENT (IMAX BASCENT CASCENT))
          (SETQ NHEIGHT (IPLUS NDESCENT NASCENT))
          (SETQ CHAROFFSET (\FGETOFFSET OFFSETS THINCODE))

          (* ;; "set up a new target bitmap if any of the parameters have changed.")


          (if
 (GETSLUGFLAG CSINFO THINCODE)
              then
 
                   (* ;; "changing the bitmap for a character which formerly pointed at the slug character.  Allocate a new bitmap character bitmap for this.")


                   (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH BWIDTH)
                                           NHEIGHT BITSPERPIXEL))
                   (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                          OFWIDTH CHEIGHT)                   (* ; "copy the old characters over.")

                   (SETQ CHAROFFSET OFWIDTH)
            elseif
 (NEQ CWIDTH BWIDTH)
              then
 
                   (* ;; "The bitmaps differ in width;  create a new bitmap with things at the right places, then update widths and offsets.")


                   (SETQ DW (IDIFFERENCE BWIDTH CWIDTH))     (* ; "Difference in character widths")

                   (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW)
                                           NHEIGHT BITSPERPIXEL)) 
                                                             (* ; 

                                "this may also be a taller bitmap if NHEIGHT is larger than CHEIGHT.")

                   (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                          CHAROFFSET CHEIGHT)                (* ; 

                                                    "Copy that portion to the left of the character.")

                   (BITBLT FONTBITMAP (IPLUS CHAROFFSET CWIDTH)
                          0 TEMPBITMAP (IPLUS CHAROFFSET BWIDTH)
                          (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                          (ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWIDTH)))
                          CHEIGHT)                           (* ; 

                                               "Copy that portion to the right of the new character.")

            elseif
 (OR (IGREATERP BASCENT CASCENT)
                       (IGREATERP BDESCENT CDESCENT))
              then
 
                   (* ;; 

                   "The new character is TALLER than the existing bitmap.  Make a larger bitmap.")


                   (SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL)) 

                   (* ;; "Copy the existing bitmap into it, adjusting for a larger descent in the new character (if there is one)")


                   (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT))
                          OFWIDTH CHEIGHT))

          (* ;; "copy the new bitmap in and update parameters.")


          (BITBLT NEWCHARBITMAP 0 0 (OR TEMPBITMAP FONTBITMAP)
                 CHAROFFSET
                 (IMAX 0 (IDIFFERENCE NDESCENT BDESCENT))
                 BWIDTH BHEIGHT)
          (CL:WHEN TEMPBITMAP
              (UNINTERRUPTABLY
                                                             (* ; 

                                                      "update the parameters for this character set.")

                  (\FSETWIDTH WIDTHS THINCODE BWIDTH)        (* ; "The new character's correct width")

                                                             (* ; 

                                                          "Make sure that we update imagewidths also")

                  (CL:WHEN IMWIDTHS (\FSETIMAGEWIDTH IMWIDTHS THINCODE BWIDTH))
                  (\FSETOFFSET OFFSETS THINCODE CHAROFFSET)
                  (CL:WHEN DW
                      (for
 I from
 0 to
 \MAXTHINCHAR when
 (IGREATERP (\FGETOFFSET OFFSETS I)
                                                                CHAROFFSET)
                         do
 
                            (* ;; 

         "If the imagewidth has changed, offsets after the modified character have to be adjusted.  ")


                            (add
 (\FGETOFFSET OFFSETS I)
                                 DW)))
                  (replace
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO with
 TEMPBITMAP)
                  (replace
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO with
 NDESCENT)
                  (replace
 (CHARSETINFO CHARSETASCENT) of
 CSINFO with
 NASCENT))
              NEWCHARBITMAP)])
)
(DEFINEQ

(MOVECHARBITMAP

  [LAMBDA (SRCECODE SRCEFONT DESTCODE DESTFONT CLIP)
         (* ; "Edited 14-Jul-2025 22:53 by rmk")


                                                             (* ; "Edited  5-Jul-2025 18:47 by rmk")


                                                             (* ; "Edited 14-Dec-86 18:04 by Shih")


(* ;;; "moves a character from one font to another, clipping if necessary.")


    (PROG ((SRCEDESC (FONTCREATE
 SRCEFONT))
           (DESTDESC (FONTCREATE
 DESTFONT))
           SRCEASCENT SRCEDESCENT DESTASCENT DESTDESCENT CHARBITMAP TEMPBITMAP NEWASCENT NEWDESCENT)
          (SETQ CHARBITMAP (GETCHARBITMAP
 SRCECODE SRCEFONT))
          (SETQ SRCEASCENT (FONTPROP
 SRCEDESC 'ASCENT))
          (SETQ DESTASCENT (FONTPROP
 DESTDESC 'ASCENT))
          (SETQ SRCEDESCENT (FONTPROP
 SRCEDESC 'DESCENT))
          (SETQ DESTDESCENT (FONTPROP
 DESTDESC 'DESCENT))
          [SETQ NEWASCENT (COND
                             (CLIP DESTASCENT)
                             (T (IMAX SRCEASCENT DESTASCENT]
          [SETQ NEWDESCENT (COND
                              (CLIP DESTDESCENT)
                              (T (IMAX SRCEDESCENT DESTDESCENT]
          [COND
             ((OR (NEQ SRCEASCENT NEWASCENT)
                  (NEQ SRCEDESCENT NEWDESCENT))
              (SETQ TEMPBITMAP (BITMAPCREATE (BITMAPWIDTH CHARBITMAP)
                                      (IPLUS NEWASCENT NEWDESCENT)))
              (BITBLT CHARBITMAP 0 (IMAX 0 (IDIFFERENCE SRCEDESCENT NEWDESCENT))
                     TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NEWDESCENT SRCEDESCENT))
                     (BITMAPWIDTH CHARBITMAP)
                     (IMIN (IPLUS SRCEASCENT SRCEDESCENT)
                           (IPLUS NEWASCENT NEWDESCENT]
          (PUTCHARBITMAP
 DESTCODE DESTFONT (OR TEMPBITMAP CHARBITMAP)
                 NEWDESCENT])

(MOVEFONTCHARS

  [LAMBDA (PAIRS DESTFONT DEFAULTSOURCEFONT)
                 (* ; "Edited 12-Sep-2026 14:06 by rmk")


                                                             (* ; "Edited 10-Sep-2026 22:56 by rmk")


                                                             (* ; "Edited  9-Mar-2026 23:00 by rmk")


                                                             (* ; "Edited 26-Feb-2026 16:59 by rmk")


                                                             (* ; "Edited  4-Sep-2025 11:07 by rmk")


                                                             (* ; "Edited 24-Jul-2025 21:05 by rmk")


                                                             (* ; "Edited  9-Jul-2025 09:13 by rmk")


                                                             (* ; "Edited 17-Jun-2025 19:53 by rmk")


                                                             (* ; "Edited  7-Jun-2025 00:06 by rmk")


                                                             (* ; "Edited  1-May-2025 13:20 by rmk")


    (* ;; "The character information for schar in sfont replaces the information for the destination character in the destination font.")


    (* ;; "Pairs is either")


    (* ;; "   a hasharray that maps destination codes to source codes")


    (* ;; "   a list of (DEST SOURCE) pairs where each source  is a list of the form (schar/scode sfont) or just a schar/scode, and each DEST is a destination character/code.  An schar/scode of NIL designates a slug source.")


    (* ;; "If a pair does not contain its own source font, then information is extracted from the DEFAULTSOURCEFONT.  If the DEFAULTSOURCEFONT is not provided, then it is assumed that the source is the DESTFONT (which must always be provided).")


    (* ;; "This collects the source information for all the pairs before it starts, to make sure that it doesn't step on itself when source and destination are the same font.")


    (CL:WHEN PAIRS
        (SETQ DESTFONT (FONTCREATE
 DESTFONT))
        (SETQ DEFAULTSOURCEFONT (CL:IF DEFAULTSOURCEFONT
                                    (FONTCREATE
 DEFAULTSOURCEFONT NIL NIL NIL (FONTPROP
 DESTFONT
                                                                                     'DEVICE))
                                    DESTFONT))
        (LET (PAIRINFO)

             (* ;; "Collect and execute at the end, so that we have validated all of the source information before making any changes.  ")


             [if
 (HARRAYP PAIRS)
                 then
 
                      (* ;; "E.g. *UNICODETOMCCS*")


                      [MAPHASH PAIRS (FUNCTION (LAMBDA (SCODE DCODE)
                                                 (\INSURECHARSETINFO DESTFONT (\CHARSET DCODE))
                                                 (LET ((SD (\MOVEFONTCHARS.SOURCEDATA
 SCODE 
                                                                  DEFAULTSOURCEFONT DESTFONT DCODE 
                                                                  DESTFONT)))
                                                      (CL:WHEN (push
 PAIRINFO (LIST SD DCODE]
               else
 (for
 P DCODE SOURCEDATA in
 PAIRS do
 (CL:WHEN (SMALLP P)
                                                            (SETQ P (LIST P P)))
                                                        (SETQ DCODE (CAR P))
                                                        (CL:UNLESS (CHARCODEP DCODE)
                                                            (SETQ DCODE (CHARCODE.DECODE DCODE)))
                                                        (\INSURECHARSETINFO DESTFONT (\CHARSET DCODE)
                                                               )
                                                        (SETQ SOURCEDATA (\MOVEFONTCHARS.SOURCEDATA

                                                                          (CADR P)
                                                                          DEFAULTSOURCEFONT DCODE 
                                                                          DESTFONT))
                                                        (CL:WHEN SOURCEDATA
                                                            (push
 PAIRINFO (LIST SOURCEDATA DCODE)))]

             (* ;; 

             "Arguments checked out.  install source character information into destfont slots.  ")


             (for
 P in
 PAIRINFO do
 (\MOVEFONTCHAR
 (CAR P)
                                          (CADR P)
                                          DESTFONT))))
    DESTFONT])

(\MOVEFONTCHAR

  [LAMBDA (SOURCEDATA DCODE DFONT)
                           (* ; "Edited 12-Sep-2026 14:08 by rmk")


                                                             (* ; "Edited 10-Sep-2026 23:33 by rmk")


                                                             (* ; "Edited  1-Sep-2026 11:21 by rmk")


                                                             (* ; "Edited  4-Mar-2026 11:03 by rmk")


                                                             (* ; "Edited 25-Sep-2025 21:25 by rmk")


                                                             (* ; "Edited  4-Sep-2025 12:37 by rmk")


                                                             (* ; "Edited 24-Jul-2025 10:47 by rmk")


                                                             (* ; "Edited  8-Jul-2025 22:23 by rmk")


                                                             (* ; "Edited  7-Jun-2025 14:43 by rmk")


    (* ;; "Internal CSINFO-level function to move the information for STHINCODE in the source CSINFO to DTHINCODE) in the destination CSINFO.")


    (* ;; "The caller (MOVEFONTCHARS) may have provided the source character information as an alist structure to avoid stepping on toes.  If SOURCEDATA is a CSINFO, the alist is extracted here.")


    (* ;; "If DFONT is provided, its ascent and descent may be adjusted to reflect SOURCEDATA.")


    (PROG ((DCSINFO (\INSURECHARSETINFO DFONT (\CHARSET DCODE)))
           (DTHINCODE (\CHAR8CODE DCODE))
           DESCENT ASCENT TEMP)
          (CL:WHEN (GETMULTI SOURCEDATA 'SLUG)
              (\MAKESLUGCHAR
 DCODE DFONT)
              (RETURN DCSINFO))
          (CL:WHEN [AND (GETMULTI SOURCEDATA 'IMAGEWIDTHS)
                        (NEQ (GETMULTI SOURCEDATA 'WIDTHS)
                             (GETMULTI SOURCEDATA 'IMAGEWIDTHS))
                        (OR (EQ (ffetch
 (CHARSETINFO WIDTHS) of
 DCSINFO)
                                (ffetch
 (CHARSETINFO IMAGEWIDTHS) of
 DCSINFO))
                            (NULL (ffetch
 (CHARSETINFO IMAGEWIDTHS) of
 DCSINFO]

              (* ;; "We have to split the width and imagewidth vectors in preparation, if the character values are different but the dest vectors are EQ. ")


              (replace
 (CHARSETINFO IMAGEWIDTHS) of
 DCSINFO with
 (\COPYARRAYBLOCK (ffetch

                                                                                   (CHARSETINFO
                                                                                    WIDTHS)
                                                                                     of
 DCSINFO))))
          (CL:WHEN (fetch
 (CHARSETINFO CSSLUGP) of
 DCSINFO)  (* ; "No longer a slug csinfo")

              (SETQ DCSINFO (create
 CHARSETINFO copying
 DCSINFO CSSLUGP ← NIL CSCOMPLETEP ← NIL))
              (\SETCHARSETINFO DFONT (\CHARSET DCODE)
                     DCSINFO))
          (CL:WHEN (SETQ TEMP (GETMULTI SOURCEDATA 'BITMAP)) (* ; "Display")

              (\PUTCHARBITMAP.CSINFO
 DTHINCODE DCSINFO TEMP (GETMULTI SOURCEDATA 'DESCENT))
              (UPDATEINFOELEMENT WIDTHS)
              (UPDATEINFOELEMENT IMAGEWIDTHS)
              (UPDATEINFOELEMENT YWIDTHS)
              (CL:WHEN (GETMULTI SOURCEDATA 'LEFTKERN)
                  (\FSETLEFTKERN
 DCSINFO DTHINCODE (GETMULTI SOURCEDATA 'LEFTKERN)))
              (CHARSETPROP DCSINFO 'SOURCE (FONTPROP
 DFONT 'SPEC)))
          (SETQ DESCENT (IMAX (GETMULTI SOURCEDATA 'DESCENT)
                              (fetch
 (CHARSETINFO CHARSETDESCENT) of
 DCSINFO)))
          (SETQ ASCENT (IMAX (GETMULTI SOURCEDATA 'ASCENT)
                             (fetch
 (CHARSETINFO CHARSETASCENT) of
 DCSINFO)))
          (replace
 (CHARSETINFO CHARSETDESCENT) of
 DCSINFO with
 DESCENT)
          (replace
 (CHARSETINFO CHARSETASCENT) of
 DCSINFO with
 ASCENT)
          (CL:WHEN DFONT
              (SETQ DESCENT (IMAX DESCENT (fetch
 (FONTDESCRIPTOR FONTDESCENT) of
 DFONT)))
              (SETQ ASCENT (IMAX ASCENT (fetch
 (FONTDESCRIPTOR FONTASCENT) of
 DFONT)))
              (replace
 (FONTDESCRIPTOR FONTASCENT) of
 DFONT with
 ASCENT)
              (replace
 (FONTDESCRIPTOR FONTDESCENT) of
 DFONT with
 DESCENT)
              (replace
 (FONTDESCRIPTOR FONTHEIGHT) of
 DFONT with
 (IPLUS DESCENT ASCENT)))
          (RETURN DCSINFO])

(\MOVEFONTCHARS.SOURCEDATA

  [LAMBDA (SOURCE DEFAULTSOURCEFONT DCODE DESTFONT)
          (* ; "Edited 14-Sep-2026 00:24 by rmk")


                                                             (* ; "Edited 12-Sep-2026 13:58 by rmk")


                                                             (* ; "Edited 22-Aug-2026 09:31 by rmk")


                                                             (* ; "Edited 15-Mar-2026 14:24 by rmk")


                                                             (* ; "Edited  9-Mar-2026 23:00 by rmk")


                                                             (* ; "Edited  7-Mar-2026 11:41 by rmk")


                                                             (* ; "Edited  6-Sep-2025 12:59 by rmk")


                                                             (* ; "Edited  4-Sep-2025 11:01 by rmk")


                                                             (* ; "Edited  2-Sep-2025 13:28 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:20 by rmk")


                                                             (* ; "Edited 26-Aug-2025 20:23 by rmk")


                                                             (* ; "Edited 25-Aug-2025 09:12 by rmk")


                                                             (* ; "Edited 23-Aug-2025 23:45 by rmk")


                                                             (* ; "Edited 23-Jul-2025 15:59 by rmk")


                                                             (* ; "Edited 22-Jul-2025 12:48 by rmk")


                                                             (* ; "Edited  8-Jul-2025 22:50 by rmk")


                                                             (* ; "Edited  7-Jun-2025 14:35 by rmk")


    (* ;; "This decodes the source size of a MOVEFONTCHARS pair.  SOURCE can be")


    (* ;; "     a character name or character code:  The source font is the DEFAULTSOURCEFONT")


    (* ;; "     a list of the form (sourcechar sourcefont) where sourcechar is a name or code and sourcefont is a full or partial font specification with defaults taken from the DEFAULTSOURCE FONT.  E.g. if the defaultsource font is GACHA 10 then the pair (94 TERMINAL) is interpreted as (TERMINAL 10).")


    (* ;; "DCODE and DESTFONT provided so that we can avoid vacuous translations")


    (LET (SCODE CHAR8CODE SFONT CSINFO TEMP)
         (if
 (LISTP SOURCE)
             then
 (SETQ SFONT (CADR SOURCE))
                  (SETQ SCODE (CAR SOURCE))
           else
 (SETQ SFONT DEFAULTSOURCEFONT)
                (SETQ SCODE SOURCE))
         (CL:UNLESS (type?
 FONTDESCRIPTOR SFONT)
             (if
 SFONT
                 then
 (CL:UNLESS (type?
 FONTSPEC SFONT)      (* ; 

                                                "Make it look like a fontspec, then fill in defaults")

                          (SETQ SFONT (create
 FONTSPEC
                                             FSFAMILY ← SFONT)))
                      [SETQ SFONT (FONTCREATE
 (OR (FSPROP SFONT FSFAMILY)
                                                  (FONTPROP
 DEFAULTSOURCEFONT 'FAMILY))
                                         (OR (FSPROP SFONT FSSIZE)
                                             (FONTPROP
 DEFAULTSOURCEFONT 'SIZE))
                                         (OR (FSPROP SFONT FSFACE)
                                             (FONTPROP
 DEFAULTSOURCEFONT 'FACE))
                                         (OR (FSPROP SFONT FSROTATION)
                                             (FONTPROP
 DEFAULTSOURCEFONT 'ROTATION))
                                         (OR (FSPROP SFONT FSDEVICE)
                                             (FONTPROP
 DEFAULTSOURCEFONT 'DEVICE]
               else
 (SETQ SFONT DEFAULTSOURCEFONT)))
         (CL:UNLESS (CHARCODEP SCODE)
             (SETQ SCODE (CHARCODE.DECODE SCODE)))
         (CL:UNLESS (AND (EQ DCODE SCODE)
                         (EQ SFONT DESTFONT))                (* ; "Nothing to do")

             [if
 (OR (NULL SCODE)
                     (SLUGCHARP
 SFONT SCODE))
                 then
 '((SLUG . T))
               else
 (SETQ CSINFO (\INSURECHARSETINFO SFONT (\CHARSET SCODE)))
                    (SETQ CHAR8CODE (\CHAR8CODE SCODE)) 

                    (* ;; "Use (plural) vector field names for UPDATEINFOELEMENT.")


                    `((ASCENT \, (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO))
                      (DESCENT \, (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO))
                      (WIDTHS \, (CL:WHEN (SETQ TEMP (ffetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
                                        (\FGETWIDTH TEMP CHAR8CODE)))
                      (YWIDTHS \, (CL:WHEN (SETQ TEMP (ffetch
 (CHARSETINFO YWIDTHS) of
 CSINFO))
                                         (\FGETWIDTH TEMP CHAR8CODE)))
                      (IMAGEWIDTHS \, (CL:WHEN (SETQ TEMP (ffetch
 (CHARSETINFO IMAGEWIDTHS)
                                                             of
 CSINFO))
                                             (\FGETWIDTH TEMP CHAR8CODE)))
                      (LEFTKERN \, (CL:WHEN (ARRAYP (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO))
                                       (ELT (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                                            CHAR8CODE)))
                      (BITMAP \, (CL:WHEN (SETQ TEMP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
                                        (\GETCHARBITMAP.CSINFO
 CHAR8CODE CSINFO SFONT])])
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS UPDATEINFOELEMENT
 MACRO
 [(FIELD)
                                   (LET [(DBLOCK (ffetch
 (CHARSETINFO FIELD) of
 DCSINFO))
                                         (NEWVAL (GETMULTI SOURCEDATA 'FIELD]
                                        (CL:WHEN NEWVAL
                                            (CL:UNLESS DBLOCK
                                                (SETQ DBLOCK (\CREATECSINFOELEMENT))
                                                (freplace
 (CHARSETINFO FIELD) of
 DCSINFO with
 DBLOCK))
                                            (\FSETWIDTH DBLOCK DTHINCODE NEWVAL))])
)
(DEFINEQ

(SLUGCHARP

  [LAMBDA (FONT CODE)
                                        (* ; "Edited 14-Sep-2026 01:08 by rmk")


                                                             (* ; "Edited 10-Sep-2026 23:30 by rmk")


                                                             (* ; "Edited  9-Sep-2026 17:03 by rmk")


                                                             (* ; "Edited 20-Aug-2026 00:37 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 28-Aug-2025 22:56 by rmk")


                                                             (* ; "Edited  6-Jun-2025 10:24 by rmk")


                                                             (* ; "Edited 31-May-2025 23:44 by rmk")

    (GETSLUGFLAG [\INSURECHARSETINFO FONT (PROG1 (\CHARSET CODE)
                                              (SETQ CODE (\CHAR8CODE CODE)))]
           CODE])

(\SLUGSETUP

  [LAMBDA (FONT SLUGPFN)
                                     (* ; "Edited 13-Sep-2026 23:14 by rmk")


    (* ;; "For use in font importation and construction.  This assumes the fontdescriptor FONT is complete with respect to all known charsets and characters.  A slug csinfo is created for all empty charsets, the width of every missing character is set to the slug charwidth, and its slugflag is set to T.")


    (* ;; "A missing/slug character is identified by a true value of the SLUGPFN, if provided.  It is applied to the charset info and thincode of every character.   If no SLUGPFN, then a a slug character is any character with a zero width.")


    (* ;; "If the font's slugwidth is not defined, it is set to .6 of the font's average charwidth (nominally the with of A)")


    (* ;; " ")


    (for
 CSET CSINFO (SLUGCSINFO ← (fetch
 (FONTDESCRIPTOR SLUGCSINFO) of
 FONT))
         (SLUGWIDTH ← (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT)) from
 0
       to
 (MAXCHARSET FONT) first
 (CL:WHEN (MEMB SLUGWIDTH '(NIL 0))
                                      [SETQ SLUGWIDTH (FIXR (FTIMES 0.8 (fetch
 (FONTDESCRIPTOR 
                                                                                     FONTAVGCHARWIDTH
                                                                                      ) of
 FONT]
                                      (replace
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT with
 SLUGWIDTH))
                                  (CL:UNLESS SLUGCSINFO
                                      (SETQ SLUGCSINFO (\BUILDSLUGCSINFO
 FONT))
                                      (replace
 (FONTDESCRIPTOR SLUGCSINFO) of
 FONT with
 SLUGCSINFO))
       do
 (if
 (SETQ CSINFO (\GETCHARSETINFO FONT CSET))
              then
 (CL:UNLESS (EQ CSINFO SLUGCSINFO)
                       (for
 C (WIDTHS ← (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)) from
 0 to
 
                                                                                         \MAXTHINCHAR
                          when
 (CL:IF SLUGPFN
                                   (APPLY* SLUGPFN CSINFO C)
                                   (EQ 0 (\FGETWIDTH WIDTHS C))) do
 (SETSLUGFLAG CSINFO C T)
                                                                    (\FSETWIDTH WIDTHS C SLUGWIDTH)))
            else
 (\SETCHARSETINFO FONT CSET SLUGCSINFO)))
    FONT])

(\BUILDSLUGCSINFO

  [LAMBDA (FONT SLUGWIDTH)
                                   (* ; "Edited 12-Sep-2026 00:25 by rmk")


                                                             (* ; "Edited  9-Sep-2026 15:34 by rmk")


                                                             (* ; "Edited  1-Sep-2026 11:22 by rmk")


                                                             (* ; "Edited 15-Mar-2026 23:39 by rmk")


                                                             (* ; "Edited 17-Aug-2025 12:46 by rmk")


                                                             (* ; "Edited 15-Jun-2025 12:42 by rmk")


                                                             (* ; "Edited 12-May-2025 21:09 by rmk")


                                                             (* ; "Edited  9-May-93 23:12 by rmk:")


    (* ;; "\SF... values are scaled")


    (LET ((SLUGHEIGHT (fetch
 (FONTDESCRIPTOR FONTHEIGHT) of
 FONT))
          (DESCENT (fetch
 (FONTDESCRIPTOR FONTDESCENT) of
 FONT))
          (DEVICE (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 FONT))
          CSINFO WIDTHS OFFSETS BITMAP)
         (CL:WHEN (EQ SLUGHEIGHT 0)

             (* ;; "First character set hasn't been read, so height isn't known.  But usually it is a bit bigger than the request fontsize.")


             (* ;; "This could also be adjusted later.")


             [SETQ SLUGHEIGHT (FIXR (FTIMES 1.2 (OR (fetch
 (FONTDESCRIPTOR FONTSCALE) of
 FONT)
                                                    1)
                                           (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONT])
         (CL:UNLESS SLUGWIDTH
             (SETQ SLUGWIDTH (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT)))
         (CL:WHEN (ZEROP SLUGWIDTH)
             (SETQ SLUGWIDTH (CL:IF (EQ 0 (fetch
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT))
                                 (FIXR (FTIMES SLUGHEIGHT 0.6))
                                 (fetch
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT)))
             (replace
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT with
 SLUGWIDTH))
         (SETQ CSINFO (create
 CHARSETINFO
                             CHARSETASCENT ← (IDIFFERENCE SLUGHEIGHT DESCENT)
                             CHARSETDESCENT ← DESCENT
                             CSSLUGP ← T))
         (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
         (for
 I (SLUGBITS ← (fetch
 (CHARSETINFO SLUGCHARBITS) of
 CSINFO)) from
 0 to
 \MAXTHINCHAR
            do
 (\FSETWIDTH WIDTHS I SLUGWIDTH)
               (SETSLUGFLAG CSINFO I T))
         (replace
 IMAGEWIDTHS OF
 CSINFO with
 WIDTHS)
         (CL:WHEN (MEMB DEVICE \DISPLAYSTREAMTYPES)
             (SETQ OFFSETS (\CREATECSINFOELEMENT))
             (replace
 (CHARSETINFO OFFSETS) of
 CSINFO with
 OFFSETS)
             (for
 I from
 0 to
 \MAXTHINCHAR do
 (\FSETOFFSET OFFSETS I 0))
                                                             (* ; "Slug is at offset 0 in the bitmap")

             (SETQ BITMAP (BITMAPCREATE SLUGWIDTH SLUGHEIGHT 1))
             (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 SLUGWIDTH))
             (replace
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO with
 BITMAP))
         CSINFO])

(\MAKESLUGCHAR

  [LAMBDA (CODE FONT)
                                        (* ; "Edited 10-Sep-2026 23:20 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:20 by rmk")


                                                             (* ; "Edited 24-Aug-2025 09:55 by rmk")


    (* ;; "Makes CODE be a slug character in FONT.  ")


    (LET ((CSINFO (\INSURECHARSETINFO FONT (\CHARSET CODE)))
          (THINCODE (\CHAR8CODE CODE))
          OFFSETS WIDTHS)
         (CL:UNLESS (GETSLUGFLAG CSINFO THINCODE)
             (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
             (CL:WHEN OFFSETS

                 (* ;; "Must be a display. W e remove the character's current bitmap, then change the vectors to point to the existing slug. Otherwise we might end up with multiple slug bitmaps interspersed.")


                 (\PUTCHARBITMAP.CSINFO
 THINCODE CSINFO (BITMAPCREATE 0 0))
                 (\FSETOFFSET OFFSETS THINCODE (for
 C from
 0 to
 \MAXTHINCHAR
                                                  when
 (GETSLUGFLAG CSINFO C)
                                                  do
 (RETURN (\FGETOFFSET OFFSETS C))
                                                  finally
 

                                                        (* ;; 

                                                     "We need to make a slug bitmap and stick it in.")


                                                        (HELP "No slug bitmap"))))
             (\FSETWIDTH (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)
                    THINCODE
                    (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT))
             (\FSETIMAGEWIDTH (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                    THINCODE
                    (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT))
             (CL:WHEN (fetch
 (CHARSETINFO YWIDTHS) of
 CSINFO)
                 (\FSETWIDTH (fetch
 (CHARSETINFO YWIDTHS) of
 CSINFO)
                        THINCODE 0))
             (CL:WHEN (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                 (SETA (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                       THINCODE 0))
             (SETSLUGFLAG CSINFO THINCODE T))
         CSINFO])
)
(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS GETSLUGFLAG
 MACRO
 ((CSINFO THINCODE)
                             (EQ 1 (\GETBASEBIT (fetch
 (CHARSETINFO SLUGCHARBITS) of
 CSINFO)
                                          THINCODE))))

(PUTPROPS SETSLUGFLAG
 MACRO
 ((CSINFO THINCODE NEWVALUE)
                             (\PUTBASEBIT (fetch
 (CHARSETINFO SLUGCHARBITS) of
 CSINFO)
                                    THINCODE
                                    (CL:IF NEWVALUE
                                        1
                                        0))))
)

(* "END EXPORTED DEFINITIONS")

)
(DEFINEQ

(FONTFILES

  [LAMBDA (FONTSPEC EXISTS CHARSET DIRLST EXTLST FORMATS)
    (* ; "Edited  5-Sep-2026 09:03 by rmk")


                                                             (* ; "Edited 31-Aug-2026 09:46 by rmk")


                                                             (* ; "Edited 29-Aug-2026 09:28 by rmk")


                                                             (* ; "Edited 18-Aug-2026 16:45 by rmk")


                                                             (* ; "Edited 19-Apr-2026 09:54 by rmk")


                                                             (* ; "Edited 16-Aug-2025 21:03 by rmk")


                                                             (* ; "Edited 11-Jul-2025 09:42 by rmk")


                                                             (* ; "Edited 17-May-2025 00:06 by rmk")


                                                             (* ; "Edited 15-May-2025 16:29 by rmk")


    (* ;; "Considers all posible names for font files that respect the given characteristics.  If EXISTS, returns only the names of existing files, otherwise all names.  The latter case is for FONTSAVAILABLE, which does its own interpretation of *s.")


    (* ;; "If FONTSPEC is a FONT with a FILENAME that exists, that is the only one returned. Does not validate their contents.")


    (if
 (type?
 FONTDESCRIPTOR FONTSPEC)
        then
 
             (* ;; "Prefer the same version, but maybe a different version if coming up in a new environment. E.g. a font that was created in a loadup sysout that was then distributed into an environment with different font versions.")


             (OR [MKLIST (INFILEP (FONTPROP
 FONTSPEC 'FILENAME]
                 [AND (FONTPROP
 FONTSPEC 'FILENAME)
                      (MKLIST (INFILEP (PACKFILENAME 'VERSION NIL 'BODY (FONTPROP
 FONTSPEC
                                                                               'FILENAME]
                 (FONTFILES
 (FONTPROP
 FONTSPEC 'DEVICESPEC)
                        EXISTS CHARSET DIRLST EXTLST))
      else
 (SETQ FONTSPEC (\FONT.CHECKARGS
 FONTSPEC NIL NIL NIL NIL T))
           (CL:UNLESS DIRLST
               (SETQ DIRLST (FONTDEVICEPROP
 FONTSPEC 'FONTDIRECTORIES)))
           (CL:UNLESS EXTLST
               (SETQ EXTLST (FONTDEVICEPROP
 FONTSPEC 'FONTEXTENSIONS)))
           (for
 D FOUND inside
 DIRLST when
 (DIRECTORYNAMEP D)
              do
 (CL:UNLESS D (SETQ D LOGINHOST/DIR))
                 (for
 E inside
 EXTLST do
 (for
 F inside
 (FILENAMEFROMFONTSPEC
 FONTSPEC CHARSET T 
                                                              FORMATS)
                                            eachtime
 (SETQ F (PACKFILENAME.STRING 'DIRECTORY D
                                                                    'NAME F 'EXTENSION E))
                                            when
 (OR (NULL EXISTS)
                                                     (SETQ F (INFILEP F)))
                                            unless
 (MEMBER F FOUND) do
 (push
 FOUND F)))
              finally
 (RETURN (DREVERSE FOUND])

(FONTSPECFROMFILENAME

  [LAMBDA (FONTFILE DEVICE)
                                  (* ; "Edited 27-Aug-2026 18:39 by rmk")


                                                             (* ; "Edited 23-Nov-2025 21:42 by rmk")


                                                             (* ; "Edited 30-Aug-2025 10:05 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:28 by rmk")


                                                             (* ; "Edited 25-Aug-2025 10:16 by rmk")


                                                             (* ; "Edited 23-Aug-2025 10:42 by rmk")


                                                             (* ; "Edited 17-Aug-2025 00:05 by rmk")


                                                             (* ; "Edited 10-Jul-2025 09:42 by rmk")


                                                             (* ; "Edited 26-Jun-2025 23:03 by rmk")


                                                             (* ; "Edited 14-Sep-96 10:23 by rmk:")


                                                             (* ; "Edited  5-Oct-89 18:28 by bvm")


    (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.  Rotation is 0 always.  Parses both new & old format files.")


    (LET ((FILENAMELIST (UNPACKFILENAME.STRING FONTFILE))
          CH SIZEBEG SIZEEND NAME FAMILY SIZE FACE CHARSET)
         (SETQ NAME (LISTGET FILENAMELIST 'NAME))            (* ; 

           "find where the name and size are.  MUST check for ch nil below or possible infinite loop")

         (SETQ SIZEBEG (for
 CH# from
 1 when
 (OR (NUMBERP (SETQ CH (NTHCHAR NAME CH#)))
                                                (NULL CH)) do
 (RETURN CH#)))

         (* ;; "Get Family")


         [SETQ FAMILY (MKATOM (U-CASE (SUBSTRING NAME 1 (SUB1 SIZEBEG]

         (* ;; "Get Size")


         [SETQ SIZEEND (find
 CH# from
 SIZEBEG suchthat
 (NOT (NUMBERP (NTHCHAR NAME CH#]
         [SETQ SIZE (SMALLP (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEEND]
         (if
 (EQ (NTHCHAR NAME SIZEEND)
                 '-)
             then
 (SETQ SIZEEND (ADD1 SIZEEND)))

         (* ;; "Get Face")


         (SETQ NAME (U-CASE NAME))
         (SETQ FACE (SUBSTRING NAME SIZEEND))                (* ; 

                                                     "don't need name, but checks for lowercase face")

         (SETQ FACE (LIST (SELCHARQ (NTHCHARCODE FACE 1)
                               (B 'BOLD)
                               (L 'LIGHT)
                               (M 'MEDIUM)
                               NIL)
                          (SELCHARQ (NTHCHARCODE FACE 2)
                               (I 'ITALIC)
                               (R 'REGULAR)
                               NIL)
                          (SELCHARQ (NTHCHARCODE FACE 3)
                               (C 'COMPRESSED)
                               (E 'EXPANDED)
                               (R 'REGULAR)
                               NIL)))
         (CL:WHEN (MEMB NIL FACE)                            (* ; 

                                                             "Named didn't have a recognizable face")

             (SETQ FACE (CL:IF (EQUAL FACE '(NIL NIL NIL))
                            (\FONTFACE
 NIL)
                            NIL)))
         (CL:WHEN (SETQ CHARSET (STRPOS "-c" NAME NIL NIL NIL T UPPERCASEARRAY))
             [SETQ CHARSET (FIXP (MKATOM (CONCAT (SUBSTRING NAME CHARSET)
                                                "Q"])
         (SETQ DEVICE (COND
                         ((STREAMP DEVICE)
                          (IMAGESTREAMTYPE DEVICE))
                         [(NULL DEVICE)
                          (CAR (find
 I DEXTS (EXT ← (LISTGET FILENAMELIST 'EXTENSION)) in
 
                                                                                     IMAGESTREAMTYPES
                                  suchthat
 (thereis
 E inside
 (FONTDEVICEPROP
 (CAR I)
                                                                    'FONTEXTENSIONS)
                                              suchthat
 (STRING.EQUAL EXT E]
                         ((LITATOM DEVICE)
                          (\FONTSYMBOL
 DEVICE))
                         (T DEVICE)))
         (CL:WHEN (AND FAMILY SIZE FACE DEVICE)
                (create
 FONTSPEC
                       FSFAMILY ← FAMILY
                       FSSIZE ← SIZE
                       FSFACE ← FACE
                       FSROTATION ← 0
                       FSDEVICE ← DEVICE])

(FILENAMEFROMFONTSPEC

  [LAMBDA (FONTSPEC CHARSET ALL FORMATS)
                     (* ; "Edited  4-Sep-2026 23:01 by rmk")


                                                             (* ; "Edited 28-Aug-2026 09:46 by rmk")


                                                             (* ; "Edited 15-Apr-2026 00:44 by rmk")


                                                             (* ; "Edited 22-Jan-2026 14:25 by rmk")


                                                             (* ; "Edited 11-Jul-2025 09:39 by rmk")


                                                             (* ; "Edited 15-May-2025 15:51 by rmk")


                                                             (* ; "Edited  5-Mar-93 16:10 by rmk:")

    (SETQ FONTSPEC (\FONT.CHECKARGS
 FONTSPEC NIL NIL NIL NIL T))
    (LET (FAMILY SIZE FACE ROTATION DEVICE)
         (SPREADFONTSPEC FONTSPEC)
         (SETQ SIZE (CL:IF (OR (EQ SIZE '*)
                               (>= SIZE 10))
                        SIZE
                        (CONCAT "0" SIZE)))
         (if
 (NULL CHARSET)
             then
 (SETQ CHARSET 0)
           elseif
 (FIXP CHARSET)
             then
 (SETQ CHARSET (OCTALSTRING CHARSET)))
         (SETQ FACE (FONTFACETOATOM
 FACE))
         (for
 F in
 [APPEND (FONTDEVICEPROP
 DEVICE 'FILETEMPLATES)
                          '((MEDLEYFONT (FAMILY SIZE -
 FACE] when
 (OR (NULL FORMATS)
                                                                      (EQMEMB (CAR F)
                                                                             FORMATS))
            join
 (for
 TEMPLATE STARPOS FILENAME SUB in
 (CDR F)
                    eachtime
 (SETQ SUB (SUBPAIR '(FAMILY SIZE FACE CHARSET)
                                              (LIST FAMILY SIZE FACE CHARSET)
                                              TEMPLATE T)) unless
 (MEMB NIL SUB)
                    collect
 (SETQ FILENAME (CONCATLIST SUB)) 

                          (* ;; 

         " Avoid adjacent wildcards because some devices (notably old DSK) get exponentially slower.")


                          (CL:IF (STRPOS "**" FILENAME)
                              (SETQ FILENAME (CONCATCODES
                                              (for
 I C from
 1 while
 (SETQ C (NTHCHARCODE FILENAME I))
                                                 unless
 [AND (EQ (CHARCODE *
)
                                                                 C)
                                                             (EQ (CHARCODE *
)
                                                                 (NTHCHARCODE FILENAME (ADD1 I]
                                                 collect
 C))))
                          (CL:WHEN (EQ 0 (NCHARS FILENAME))
                                 (GO $$ITERATE))
                          FILENAME) finally
 (SETQ $$VAL (CL:REMOVE-DUPLICATES $$VAL :FROM-END T :TEST
                                                               (FUNCTION STREQUAL)))
                                          (RETURN (CL:IF ALL
                                                      $$VAL
                                                      (CAR $$VAL))])
)
(DEFINEQ

(FONTCOPY

  [LAMBDA NARGS
                                              (* ; "Edited 30-Sep-2026 16:45 by rmk")


                                                             (* ; "Edited 22-Sep-2026 09:43 by rmk")


                                                             (* ; "Edited 14-Jul-2025 23:04 by rmk")


                                                             (* ; "Edited  5-Jul-2025 18:54 by rmk")


                                                             (* ; "Edited 10-Nov-87 17:12 by FS")

                                                             (* ; 

                                              "makes a copy of a font changing the specified fields.")

    (PROG (NOERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT WEIGHT SLOPE EXPANSION FORECOLOR 
                 BACKCOLOR)

     (* ;; "Set NOERROR if we find it as a prop")


     (* ;; "Originally, don't cause an illegal prop error if NOERROR, just return NIL.  But an error in the property is really a big mistake, always an illegal arg.  Now (rmk) NOERROR just applies to the FONTCREATEs. ")


          [if
 (AND (EQ NARGS 2)
                   (LISTP (ARG NARGS 2)))
              then
 [for
 J VAL on
 (ARG NARGS 2) by
 (CDDR J)
                      do
 (SETQ VAL (CADR J))                 (* ; "Later values override")

                         (SELECTQ (CAR J)
                             (FAMILY (SETQ FAMILY VAL))
                             (SIZE (SETQ SIZE VAL))
                             (FACE (SETQ FACE (\FONTFACE
 VAL))
                                   (SETQ WEIGHT (fetch
 (FONTFACE WEIGHT) of
 FACE))
                                   (SETQ SLOPE (fetch
 (FONTFACE SLOPE) of
 FACE))
                                   (SETQ EXPANSION (fetch
 (FONTFACE EXPANSION) of
 FACE))
                                   (SETQ FORECOLOR (fetch
 (FONTFACE FORECOLOR) of
 FACE))
                                   (SETQ BACKCOLOR (fetch
 (FONTFACE BACKCOLOR) of
 FACE)))
                             (ROTATION (SETQ ROTATION VAL))
                             (DEVICE (SETQ DEVICE VAL))
                             (WEIGHT (SETQ WEIGHT VAL))
                             (SLOPE (SETQ SLOPE VAL))
                             (EXPANSION (SETQ EXPANSION VAL))
                             (FORECOLOR (SETQ FORECOLOR VAL))
                             (BACKCOLOR (SETQ BACKCOLOR VAL))
                             (COLOR                          (* ; "Is there a declaration?")

                                    (SETQ FORECOLOR (CAR VAL))
                                    (SETQ BACKCOLOR (CADR VAL)))
                             (NOERROR (SETQ NOERROR VAL))
                             (\ILLEGAL.ARG (CAR J]
            else
 (for
 I VAL from
 2 by
 2 to
 NARGS do
 [SETQ VAL (CL:IF (NEQ I NARGS)
                                                                  (ARG NARGS (ADD1 I)))] 
                                                             (* ; 

                                                  "SELECTQ is same as above, except for error at end")

                                                    (SELECTQ (ARG NARGS I)
                                                        (FAMILY (SETQ FAMILY VAL))
                                                        (SIZE (SETQ SIZE VAL))
                                                        (FACE (SETQ FACE (\FONTFACE
 VAL))
                                                              (SETQ WEIGHT (fetch
 (FONTFACE WEIGHT)
                                                                              of
 FACE))
                                                              (SETQ SLOPE (fetch
 (FONTFACE SLOPE)
                                                                             of
 FACE))
                                                              (SETQ EXPANSION (fetch
 (FONTFACE 
                                                                                            EXPANSION
                                                                                            )
                                                                                 of
 FACE))
                                                              (SETQ FORECOLOR (fetch
 (FONTFACE 
                                                                                            FORECOLOR
                                                                                            )
                                                                                 of
 FACE))
                                                              (SETQ BACKCOLOR (fetch
 (FONTFACE 
                                                                                            BACKCOLOR
                                                                                            )
                                                                                 of
 FACE)))
                                                        (ROTATION (SETQ ROTATION VAL))
                                                        (DEVICE (SETQ DEVICE VAL))
                                                        (WEIGHT (SETQ WEIGHT VAL))
                                                        (SLOPE (SETQ SLOPE VAL))
                                                        (EXPANSION (SETQ EXPANSION VAL))
                                                        (FORECOLOR (SETQ FORECOLOR VAL))
                                                        (BACKCOLOR (SETQ BACKCOLOR VAL))
                                                        (COLOR (SETQ FORECOLOR (CAR VAL))
                                                               (SETQ BACKCOLOR (CADR VAL)))
                                                        (NOERROR (SETQ NOERROR VAL))
                                                        (\ILLEGAL.ARG (ARG NARGS I]

     (* ;; "DEVICE to get the the right font from the FONTCLASS, otherwise no need for an intermediate device font")


          (CL:WHEN (SETQ OLDFONT (FONTCREATE
 (ARG NARGS 1)
                                        NIL NIL NIL (CL:IF (type?
 FONTCLASS (ARG NARGS 1))
                                                           DEVICE)
                                        NOERROR))
              (RETURN (FONTCREATE
 (OR FAMILY (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 OLDFONT))
                             (OR SIZE (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 OLDFONT))
                             (MAKEFONTFACE
 WEIGHT SLOPE EXPANSION (fetch
 (FONTDESCRIPTOR FONTFACE)
                                                                     of
 OLDFONT)
                                    NIL FORECOLOR BACKCOLOR)
                             (OR ROTATION (fetch
 (FONTDESCRIPTOR FONTROTATION) of
 OLDFONT))
                             (OR DEVICE (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 OLDFONT))
                             NOERROR)))])

(FONTP

  [LAMBDA (X)                                                (* rmk%: "13-Sep-84 09:04")

                                                             (* ; "is X a FONTDESCRIPTOR?")

    (COND
       ((OR (type?
 FONTDESCRIPTOR X)
            (type?
 FONTCLASS X))
        X])

(FONTUNPARSE

  [LAMBDA (FONT)
                                             (* ; "Edited  7-Sep-2025 09:19 by rmk")


                                                             (* ; "Edited 21-Aug-2025 18:15 by rmk")


                                                             (* ; "Edited 18-Aug-2025 00:52 by rmk")

                                                             (* kbr%: "25-Feb-86 19:40")


    (* ;; "Produces a minimal specification of the font or fontclass specification, for dumping by Tedit, imageobjects.")


    (if
 (type?
 FONTCLASS FONT)
        then
 (CONS 'CLASS (FONTCLASSUNPARSE
 FONT))
      elseif
 (type?
 FONTDESCRIPTOR FONT)
        then
 (LET ((SPEC (FONTPROP
 FONT 'SPEC))
                   FACE)
                  (SETQ FACE (FONTFACETOATOM
 (fetch
 (FONTSPEC FSFACE) of
 SPEC)
                                    T))

                  (* ;; "Original: Don't return device, or any trailing defaults. ")


                  (* ;; "We still honor that even though it is more attractive to return the whole fontspec, perhaps with device NIL.")


                  (* ;; "Seems harmless to include a 0 rotation--any caller would have expected that something might appear there.")

                                                             (* (create FONTSPEC using SPEC FSFACE 

                                                             ← FACE FSDEVICE ← NIL))

                  (LIST (fetch
 (FONTSPEC FSFAMILY) of
 SPEC)
                        (fetch
 (FONTSPEC FSSIZE) of
 SPEC)
                        FACE
                        (fetch
 (FONTSPEC FSROTATION) of
 SPEC])

(SETFONTDESCRIPTOR

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT)
            (* ; "Edited 28-Aug-2025 14:43 by rmk")


                                                             (* ; "Edited 12-Aug-2025 21:07 by rmk")


                                                             (* ; "Edited 21-Jul-2025 08:55 by rmk")


                                                             (* ; "Edited 14-Jul-2025 22:37 by rmk")


                                                             (* ; "Edited 10-Jul-2025 12:38 by rmk")


                                                             (* ; "Edited 19-Jun-2025 21:21 by rmk")


                                                             (* ; "Edited 14-Jun-2025 23:47 by rmk")


                                                             (* ; "Edited  1-Aug-88 16:16 by rmk:")


                                                             (* ; "Edited  5-Mar-87 19:28 by FS")


    (* ;; "Saves a font descriptor under a family/size/face/rotation/device key so that it will be retreived by FONTCREATE.  This is a user entry.")


    (DECLARE
 (GLOBALVARS \FONTSINCORE))
    (SPREADFONTSPEC (\FONT.CHECKARGS
 FAMILY SIZE FACE ROTATION DEVICE))
    (PUTMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE (AND FONT (FONTCREATE
 FONT NIL NIL NIL 
                                                                             DEVICE])

(\STREAMCHARWIDTH

  [LAMBDA (CHARCODE STREAM TTBL)                             (* JonL " 8-NOV-83 03:31")


    (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences.  Used by \ECHOCHAR")


    (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK))
    ((LAMBDA (WIDTHSVECTOR)

       (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded;  e.g., it may want #↑A")


       (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM)
                                   (SETQ WIDTHSVECTOR (ffetch
 IMAGEDATA of
 STREAM))
                                   (ffetch
 DDWIDTHSCACHE of
 WIDTHSVECTOR))
                              \UNITWIDTHSVECTOR))
       (SELECTC (fetch
 CCECHO of
 (\SYNCODE (fetch
 (TERMTABLEP TERMSA) of
 (OR (TERMTABLEP TTBL)
                                                                             \PRIMTERMTABLE))
                                        CHARCODE))
           (INDICATE.CCE ([LAMBDA (CC)
                            (IPLUS (if
 (IGEQ CHARCODE (CHARCODE %#↑@))
                                       then
                  (* ; 

                                            "A META charcode -- implies that the 8th bit is non-zero")

                                            (SETQ CC (LOADBYTE CHARCODE 0 7))
                                            (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#))
                                     else
 0)
                                   (if
 (ILESSP CC (CHARCODE SPACE))
                                       then
                  (* ; "A CONTROL charcode")

                                            (add
 CC (CONSTANT (LLSH 1 6)))
                                            (\FGETWIDTH WIDTHSVECTOR (CHARCODE ↑))
                                     else
 0)
                                   (\FGETWIDTH WIDTHSVECTOR CC]
                          CHARCODE))
           (SIMULATE.CCE (SELCHARQ CHARCODE
                              ((EOL CR LF BELL) 
                                   NIL)
                              (ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $)))
                              (TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR (CHARCODE SPACE)))
                                          (NEWXPOSITON (DSPXPOSITION NIL STREAM))
                                          TABWIDTH)
                                         (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
                                         [add
 NEWXPOSITON (SETQ TABWIDTH
                                                           (IDIFFERENCE TABWIDTH
                                                                  (IMOD (IDIFFERENCE NEWXPOSITON
                                                                               (DSPLEFTMARGIN NIL 
                                                                                      STREAM))
                                                                        TABWIDTH]
                                         (RETURN (if
 (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN NIL 
                                                                                   STREAM))
                                                     then
    (* ; 

                                                             "tab was past rightmargin, force cr.")

                                                          NIL
                                                   else
 TABWIDTH))))
                              (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (REAL.CCE (SELECTC CHARCODE
                         ((CHARCODE (EOL CR LF)) 
                              NIL)
                         (ERASECHARCODE NIL)
                         (\FGETWIDTH WIDTHSVECTOR CHARCODE)))
           (IGNORE.CCE 0)
           (SHOULDNT])

(\COERCECHARSET

  [LAMBDA (FONTSPEC CHARSET CODE COERCIONS FONT)
             (* ; "Edited 14-Sep-2026 00:24 by rmk")


                                                             (* ; "Edited 11-Sep-2026 23:42 by rmk")


                                                             (* ; "Edited 15-Mar-2026 14:23 by rmk")


                                                             (* ; "Edited 17-Dec-2025 21:51 by rmk")


                                                             (* ; "Edited  7-Oct-2025 17:25 by rmk")


                                                             (* ; "Edited 31-Aug-2025 00:00 by rmk")


                                                             (* ; "Edited 28-Aug-2025 23:07 by rmk")


                                                             (* ; "Edited 27-Aug-2025 17:08 by rmk")


                                                             (* ; "Edited 16-Aug-2025 17:48 by rmk")


                                                             (* ; "Edited  5-Aug-2025 17:55 by rmk")


                                                             (* ; "Edited 24-Jul-2025 00:19 by rmk")


                                                             (* ; "Edited  8-Jul-2025 08:14 by rmk")


                                                             (* ; "Edited 11-Jun-2025 09:13 by rmk")


                                                             (* ; "Edited  7-Jun-2025 13:39 by rmk")


                                                             (* ; "Edited 21-May-2025 10:50 by rmk")


    (* ;; "Returns the CHARSET's CSINFO from the first font that the requested font coerces to and that has a non-slug entry for CODE (if given). ")


    (if
 (NULL COERCIONS)
        then
 [SETQ COERCIONS (FONTDEVICEPROP
 FONTSPEC (CL:IF CODE
                                                          'CHARCOERCIONS
                                                          'FONTCOERCIONS)]
      elseif
 (LITATOM COERCIONS)
        then
 (SETQ COERCIONS (FONTDEVICEPROP
 FONTSPEC COERCIONS)))

    (* ;; "This creates a list of fontspecs for the coercions of FONTSPEC that exist, then looks for the first one with the required character. If we stopped at the first coercion and it failed, we wouldn't know how to continue the iteration")


    (for
 CFS CFONT CSINFO in
 (COERCEFONTSPEC
 FONTSPEC COERCIONS T) eachtime
 

                                                                         (* ;; 

                                                            "Font CFS exists, FONTCREATE1 can't fail")


                                                                         (SETQ CFONT (FONTCREATE1

                                                                                      CFS CHARSET))
       when
 (SETQ CSINFO (\INSURECHARSETINFO CFONT CHARSET)) unless
 (AND CODE (SLUGCHARP
 CFONT CODE))
       do
 (CL:WHEN FONT
              (replace
 (FONTDESCRIPTOR FONTCHARENCODING) of
 FONT with
 (fetch
 (FONTDESCRIPTOR 
                                                                                    FONTCHARENCODING)
                                                                         of
 CFONT))
              (replace
 (FONTDESCRIPTOR FONTTOMCCSFN) of
 FONT with
 (fetch
 (FONTDESCRIPTOR FONTTOMCCSFN
                                                                                ) of
 CFONT)))
          (RETURN (LIST CFONT CSINFO])

(\FONTSYMBOL

  [LAMBDA (X ElseReturnXFlg)
                                 (* ; "Edited 28-Jul-88 11:59 by rmk:")


                                                             (* ; "Edited 24-Mar-87 14:32 by FS")


    (* ;; "Return a symbol in IL package and is in uppercase.  Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook.  ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.")


    (COND
       ((LITATOM X)
        (U-CASE X))
       ((STRINGP X)
        (MKATOM (U-CASE X)))
       (ElseReturnXFlg X)
       (T (ERROR "Want an IL symbol"])

(\DEVICESYMBOL

  [LAMBDA (X ElseReturnXFlg)
                                 (* ; "Edited  7-Oct-88 20:07 by rmk:")


                                                             (* ; "Edited 28-Jul-88 14:43 by rmk:")


                                                             (* ; "Edited 24-Mar-87 14:33 by FS")


    (* ;; "Return a canonicalized atom good for comparing with DEVICE symbols")


    (LET ((STRM (\GETSTREAM X 'OUTPUT T)))
         (COND
            (STRM (fetch
 (IMAGEOPS IMFONTCREATE) of
 (fetch
 (STREAM IMAGEOPS) of
 STRM)))
            ((NULL X)
             'DISPLAY)
            (T                                               (* ; "because its used in ASSOC.")

               (\FONTSYMBOL
 X ElseReturnXFlg])

(\FONTFACE

  [LAMBDA (FACE NOERRORFLG DEV)
                              (* ; "Edited 21-Jun-2025 23:16 by rmk")


                                                             (* ; "Edited  1-Aug-88 09:44 by rmk:")


                                                             (* ; "Edited 28-Jul-88 15:50 by rmk:")


                                                             (* ; "Edited 28-Jul-88 15:49 by rmk:")


                                                             (* ; "Edited 28-Jul-88 15:41 by rmk:")


                                                             (* ; "Edited 28-Jul-88 15:38 by rmk:")


                                                             (* ; "Edited 28-Jul-88 14:44 by rmk:")


                                                             (* ; "Edited 25-Feb-87 22:58 by FS")


    (* ;; "Coerces FACE into standard FONTFACE record, usually returns a CONSTANT (so you'd better not RPLACD or REPLACE fields!!)")


    (PROG ((UNKNOWN (CL:IF (EQ NOERRORFLG 'REGULAR)
                        'REGULAR
                        'ERROR))
           (WEIGHT 'MEDIUM)
           (SLOPE 'REGULAR)
           (EXPANSION 'REGULAR)
           (OLDFACE FACE))

     (* ;; "On error, can signal, or return NIL, or return REGULAR face.")


          [COND
             ((type?
 FONTFACE FACE)

              (* ;; "List Case.  Unpack because want to validate fields")


              (SETQ WEIGHT (U-CASE (fetch
 (FONTFACE WEIGHT) of
 FACE)))
              (SETQ SLOPE (U-CASE (fetch
 (FONTFACE SLOPE) of
 FACE)))
              (SETQ EXPANSION (U-CASE (fetch
 (FONTFACE EXPANSION) of
 FACE)))

              (* ;; "Handle unknown faces")


              (CL:UNLESS (MEMB WEIGHT '(BOLD MEDIUM LIGHT *
))(* ; 

                                                       "STRING.EQUAL is case and package insensitive")

                  (SETQ WEIGHT (COND
                                  ((STRING.EQUAL WEIGHT 'REGULAR)

                                   (* ;; "Clean up WEIGHT REGULAR vs. MEDIUM")


                                   (SETQ WEIGHT 'MEDIUM))
                                  (T UNKNOWN))))
              (CL:UNLESS (MEMB SLOPE '(REGULAR ITALIC *
))
                     (SETQ SLOPE UNKNOWN))
              (CL:UNLESS (MEMB EXPANSION '(COMPRESSED REGULAR EXPANDED *
))
                     (SETQ EXPANSION UNKNOWN)))
             ((OR (LITATOM FACE)
                  (STRINGP FACE))
              (COND
                 ((NULL FACE)                                (* ; "Fast vanilla default")

                  )
                 ((EQ (NCHARS FACE)
                      3)                                     (* ; "3 char notation case")

                  (SETQ WEIGHT (SELCHARQ (CHCON1 FACE)
                                    ((B b) 
                                         'BOLD)
                                    ((M m R r) 
                                         'MEDIUM)
                                    ((L l) 
                                         'LIGHT)
                                    UNKNOWN))
                  (SETQ SLOPE (SELCHARQ (NTHCHARCODE FACE 2)
                                   ((R r) 
                                        'REGULAR)
                                   ((I i) 
                                        'ITALIC)
                                   UNKNOWN))
                  (SETQ EXPANSION (SELCHARQ (NTHCHARCODE FACE 3)
                                       ((R r) 
                                            'REGULAR)
                                       ((C c) 
                                            'COMPRESSED)
                                       ((E e) 
                                            'EXPANDED)
                                       UNKNOWN)))
                 ((SELECTQ FACE
                      (BOLD (SETQ WEIGHT 'BOLD))
                      (ITALIC (SETQ SLOPE 'ITALIC))
                      (BOLDITALIC (SETQ WEIGHT 'BOLD)
                                  (SETQ SLOPE 'ITALIC))
                      ((STANDARD REGULAR) 
                           T)
                      NIL))
                 ((STRING.EQUAL FACE 'BOLD)
                  (SETQ WEIGHT 'BOLD))
                 ((STRING.EQUAL FACE 'ITALIC)
                  (SETQ SLOPE 'ITALIC))
                 ((STRING.EQUAL FACE 'BOLDITALIC)
                  (SETQ WEIGHT 'BOLD)
                  (SETQ SLOPE 'ITALIC))
                 ((MEMB FACE '(STANDARD REGULAR NIL NNN))    (* ; "Vanilla case")

                  )
                 ((STRPOS "-" FACE)                          (* ; "Color fontface spec!")

                  (SETQ FACE (\FONTFACE.COLOR
 FACE NOERRORFLG DEV))
                  (RETURN FACE))
                 ((MEMB FACE '                               (* ***)
)
                                                             (* ; "Wildcard case")

                  (SETQ WEIGHT '*)
                  (SETQ SLOPE '*)
                  (SETQ EXPANSION '*))
                 (T                                          (* ; "Other litatom error case")

                    (SETQ WEIGHT UNKNOWN)
                    (SETQ SLOPE UNKNOWN)
                    (SETQ EXPANSION UNKNOWN]
          (if
 (OR (EQ WEIGHT 'ERROR)
                  (EQ SLOPE 'ERROR)
                  (EQ EXPANSION 'ERROR))
              then
 (if
 NOERRORFLG
                       then
 (RETURN NIL)
                     else
 (\ILLEGAL.ARG OLDFACE)))

     (* ;; "Avoid consing by returning constant faces (historical:  really, would have been better to return MRR, but users have know about this for too long (rmk))")


          (RETURN (COND
                     ((AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "MRR")

                      (CONSTANT (create
 FONTFACE)))
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'REGULAR)
                           (EQ EXPANSION 'REGULAR))          (* ; "BRR")

                      (CONSTANT (create
 FONTFACE
                                       WEIGHT ← 'BOLD]
                     [(AND (EQ WEIGHT 'MEDIUM)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "MIR")

                      (CONSTANT (create
 FONTFACE
                                       SLOPE ← 'ITALIC]
                     [(AND (EQ WEIGHT 'BOLD)
                           (EQ SLOPE 'ITALIC)
                           (EQ EXPANSION 'REGULAR))          (* ; "BIR")

                      (CONSTANT (create
 FONTFACE
                                       WEIGHT ← 'BOLD
                                       SLOPE ← 'ITALIC]
                     (T                                      (* ; "Otherwise, cons up")

                        (create
 FONTFACE
                               WEIGHT ← WEIGHT
                               SLOPE ← SLOPE
                               EXPANSION ← EXPANSION])

(\FONTFACE.COLOR

  [LAMBDA (FACE NOERRORFLG DEV)
                              (* ; "Edited 28-Jul-88 14:51 by rmk:")


                                                             (* ; "Edited 28-Jul-88 13:09 by rmk:")


                                                             (* ; "Edited 24-Mar-87 17:03 by FS")


    (* ;; "This used to be \FONTFACE.  Renamed \FONTFACE.COLOR, and \FONTFACE rewritten.  The section below should also be redone")


    (* ;; "Takes a variety of user specifications and converts them to a standard FONTFACE record.")


    (* ;; "b/w fontfaces are extended by an optional '-backcolor-forecolor'")


    (* ;; "the atom NNN is interpreted the same as NIL or MRR to cover up a bug described in AR 3025, the FONTNNN bug")


    (DECLARE
 (GLOBALVARS \COLORDISPLAYSTREAMTYPES))
    (SETQ DEV (\DEVICESYMBOL
 DEV))
    (PROG (BWFACE POS OLDPOS BITSPERPIXEL BACKCOLOR FORECOLOR ANSWER)

     (* ;; "First get a FONTFACE ANSWER.")


          [SETQ ANSWER (COND
                          ((type?
 FONTFACE FACE)
                           FACE)
                          ((LITATOM FACE)
                           (OR (U-CASEP FACE)
                               (SETQ FACE (U-CASE FACE)))
                           (SETQ POS (STRPOS "-" FACE))
                           (COND
                              [POS (SETQ BWFACE (SUBATOM FACE 1 (SUB1 POS]
                              (T (SETQ BWFACE FACE)))
                           [SETQ ANSWER (SELECTQ BWFACE
                                            ((* ***) 
                                                 (CONSTANT (create
 FONTFACE
                                                                  WEIGHT ← '*
                                                                  SLOPE ← '*
                                                                  EXPANSION ← '*)))
                                            ((NIL MRR STANDARD NNN) 
                                                 (CONSTANT (create
 FONTFACE)))
                                            ((ITALIC MIR) 
                                                 (CONSTANT (create
 FONTFACE
                                                                  SLOPE ← 'ITALIC)))
                                            ((BOLD BRR) 
                                                 (CONSTANT (create
 FONTFACE
                                                                  WEIGHT ← 'BOLD)))
                                            ((BOLDITALIC BIR) 
                                                 (CONSTANT (create
 FONTFACE
                                                                  WEIGHT ← 'BOLD
                                                                  SLOPE ← 'ITALIC)))
                                            (create
 FONTFACE
                                                   WEIGHT ← (SELCHARQ (NTHCHARCODE FACE 1)
                                                                 (M 'MEDIUM)
                                                                 (B 'BOLD)
                                                                 (L 'LIGHT)
                                                                 (GO ERROR))
                                                   SLOPE ← (SELCHARQ (NTHCHARCODE FACE 2)
                                                                (R 'REGULAR)
                                                                (I 'ITALIC)
                                                                (GO ERROR))
                                                   EXPANSION ← (SELCHARQ (NTHCHARCODE FACE 3)
                                                                    (R 'REGULAR)
                                                                    (C 'COMPRESSED)
                                                                    (E 'EXPANDED)
                                                                    (GO ERROR]
                           (COND
                              (POS                           (* ; "Color FONTFACE.  *")

                                   (SETQ OLDPOS POS)
                                   (SETQ POS (STRPOS "-" FACE (ADD1 OLDPOS)))
                                   (COND
                                      ((NULL POS)
                                       (GO ERROR)))
                                   (SETQ BITSPERPIXEL (\DISPLAYSTREAMTYPEBPP DEV))
                                   (SETQ BACKCOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        (SUB1 POS))
                                                          BITSPERPIXEL))
                                   (SETQ OLDPOS POS)
                                   (SETQ FORECOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS)
                                                                        -1)
                                                          BITSPERPIXEL))
                                                             (* ; 

                                                           "COPY ANSWER to avoid smashing constants.")

                                   (SETQ ANSWER (COPY ANSWER))
                                   (replace
 (FONTFACE BACKCOLOR) of
 ANSWER with
 BACKCOLOR)
                                   (replace
 (FONTFACE FORECOLOR) of
 ANSWER with
 FORECOLOR)))
                           ANSWER)
                          (T (GO ERROR]

     (* ;; "Coerce on or off COLOR.")


          (SETQ ANSWER (COND
                          ((AND (NOT (FMEMB DEV \COLORDISPLAYSTREAMTYPES))
                                (fetch
 (FONTFACE COLOR) of
 ANSWER))
                           (SETQ ANSWER (COPY ANSWER))
                           (replace
 (FONTFACE COLOR) of
 ANSWER with
 NIL)
                           ANSWER)
                          ((AND (FMEMB DEV \COLORDISPLAYSTREAMTYPES)
                                (NULL (fetch
 (FONTFACE COLOR) of
 ANSWER)))
                           (SETQ FACE (COPY FACE))
                           (replace
 (FONTFACE BACKCOLOR) of
 ANSWER with
 0)
                           (replace
 (FONTFACE FORECOLOR) of
 ANSWER with
 (MAXIMUMCOLOR (
                                                                                \DISPLAYSTREAMTYPEBPP
                                                                                       DEV)))
                           ANSWER)
                          (T ANSWER)))
          (RETURN ANSWER)
      ERROR
          (COND
             (NOERRORFLG (RETURN NIL))
             (T (\ILLEGAL.ARG FACE])

(SETFONTCHARENCODING

  [LAMBDA (FONT CHARENCODING)
                                (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 19-Jul-2025 23:28 by rmk")


                                                             (* ; "Edited 12-Jul-2025 13:15 by rmk")


                                                             (* ; "Edited 10-Jul-2025 12:38 by rmk")


                                                             (* ; "Edited  6-Jul-2025 21:41 by rmk")


                                                             (* ; "Edited 23-May-2025 14:54 by rmk")


                                                             (* ; "Edited 21-May-2025 22:27 by rmk")


                                                             (* ; "Edited  2-May-2025 16:03 by rmk")


    (* ;; "The FONT charencoding is the same as its charset 0 encoding (e.g. ALTOTEXT).  But all higher charsets are MCCS")


    (replace
 (FONTDESCRIPTOR FONTCHARENCODING) of
 (FONTCREATE
 FONT) with
 CHARENCODING)
    (CHARSETPROP (\GETCHARSETINFO FONT 0)
           'CSCHARENCODING CHARENCODING])
)
(DEFINEQ

(FONTSAVAILABLE

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?)
  (* ; "Edited 22-Nov-2025 11:32 by rmk")


                                                             (* ; "Edited  6-Nov-2025 13:50 by rmk")


                                                             (* ; "Edited 25-Sep-2025 18:39 by rmk")


                                                             (* ; "Edited 30-Aug-2025 13:55 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:43 by rmk")


                                                             (* ; "Edited 23-Aug-2025 10:51 by rmk")


                                                             (* ; "Edited 15-Aug-2025 12:18 by rmk")


                                                             (* ; "Edited 12-Aug-2025 12:27 by rmk")


                                                             (* ; "Edited 30-Jul-2025 14:30 by rmk")


                                                             (* ; "Edited 21-Jul-2025 08:55 by rmk")


                                                             (* ; "Edited 21-Jun-2025 15:41 by rmk")


                                                             (* ; "Edited 14-Jun-2025 11:06 by rmk")


                                                             (* ; "Edited 12-Jun-2025 10:48 by rmk")

                                                             (* rrb " 7-Nov-84 15:41")


(* ;;; "returns a list of the fonts fitting a description that are available.  FAMILY SIZE FACE or ROTATION can be * which means get them all.  if CHECKFILESTOO? is NIL, only fonts in core will be considered. If ONLY, fonts in memory will be ignored. ")


    (DECLARE
 (GLOBALVARS \FONTSINCORE \FONTSAVAILABLEFILECACHE))
    (LET
     ((FONTSPEC (\FONT.CHECKARGS
 FAMILY SIZE FACE ROTATION DEVICE T))
      FILEFONTS)
     (if
 (EQ '* (fetch
 (FONTSPEC FSDEVICE) of
 FONTSPEC))
         then
 
              (* ;; 

 "The results for each device will be grouped together, because the sort happens in the clause below")


              (for
 I in
 IMAGESTREAMTYPES join
 (FONTSAVAILABLE
 FONTSPEC NIL NIL NIL (CAR I)
                                                     CHECKFILESTOO?))
       else

       (SPREADFONTSPEC FONTSPEC)                             (* ; "For easier matching code")

       (SORTFONTSPECS

        (UNION (CL:UNLESS (EQ 'ONLY CHECKFILESTOO?)
                   [COLLECTMULTI \FONTSINCORE
                          (FUNCTION (LAMBDA (FM S FC R D FONT)
                                      (DECLARE
 (USEDFREE $$COLLECT))
                                      (CL:WHEN [AND (OR (EQ FAMILY FM)
                                                        (EQ FAMILY '*))
                                                    (OR (EQ SIZE S)
                                                        (EQ SIZE '*))
                                                    (MATCHFONTFACE
 FACE FC)
                                                    (OR (EQ ROTATION R)
                                                        (EQ ROTATION '*))
                                                    (OR (EQ DEVICE D)
                                                        (EQ DEVICE '*]
                                          (push
 $$COLLECT
                                                (create
 FONTSPEC
                                                       FSFAMILY ← FM
                                                       FSSIZE ← S
                                                       FSFACE ← FC
                                                       FSROTATION ← R
                                                       FSDEVICE ← D)))])
               (CL:WHEN CHECKFILESTOO?                       (* ; 

                                                             "apply the device font lookup function.")

                   (SETQ FILEFONTS (SGETMULTI \FONTSAVAILABLEFILECACHE FAMILY SIZE FACE ROTATION 
                                          DEVICE))

                   (* ;; "APPEND the cache value because of the SORT")


                   (APPEND (if
 (NULL FILEFONTS)
                               then
 (LET [(FN (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE 
                                                              'FONTSAVAILABLE))
                                                  (FUNCTION \SEARCHFONTFILES]

                                         (* ;; "Until all the device functions take a FONTSPEC")


                                         (SETQ FILEFONTS (CL:IF (EQ 1 (NARGS FN))
                                                             (APPLY* FN FONTSPEC)
                                                             (APPLY* FN FAMILY SIZE FACE ROTATION 
                                                                    DEVICE)))
                                         (SPUTMULTI \FONTSAVAILABLEFILECACHE FAMILY SIZE FACE 
                                                ROTATION DEVICE (OR FILEFONTS 'NONE))
                                         FILEFONTS)
                             elseif
 (NEQ FILEFONTS 'NONE)
                               then
 FILEFONTS)))])

(FONTEXISTS?

  [LAMBDA (FONTSPEC NOCOERCIONS)
                             (* ; "Edited  3-Sep-2026 18:54 by rmk")


                                                             (* ; "Edited  1-Sep-2026 23:25 by rmk")


                                                             (* ; "Edited 29-Aug-2026 09:28 by rmk")


                                                             (* ; "Edited 26-Aug-2026 23:40 by rmk")


                                                             (* ; "Edited 18-Aug-2026 17:24 by rmk")


                                                             (* ; "Edited  4-Apr-2026 12:27 by rmk")


                                                             (* ; "Edited  2-Apr-2026 23:52 by rmk")


                                                             (* ; "Edited 17-Mar-2026 23:04 by rmk")


                                                             (* ; "Edited 22-Jan-2026 09:07 by rmk")


                                                             (* ; "Edited 18-Dec-2025 13:10 by rmk")


                                                             (* ; "Edited 25-Nov-2025 20:18 by rmk")


                                                             (* ; "Edited 26-Sep-2025 10:10 by rmk")


                                                             (* ; "Edited 28-Aug-2025 22:16 by rmk")


                                                             (* ; "Edited 23-Aug-2025 12:45 by rmk")


                                                             (* ; "Edited 16-Aug-2025 17:49 by rmk")


                                                             (* ; "Edited 12-Aug-2025 21:04 by rmk")


                                                             (* ; "Edited  9-Aug-2025 00:08 by rmk")


                                                             (* ; "Edited  5-Aug-2025 17:54 by rmk")


    (* ;; "Do we have any way of finding or creating the font, even by coercion from other fonts?   The IMAGESTREAM DEVICE can have a FONTEXISTS? function for the case where we can't find a file--presumably returns the file for a coercion to a different font specification.")


    (* ;; 

 "Tries device-specific coercions if the original request can't be satisfied and NOCOERCIONS is NIL.")


    (DECLARE
 (GLOBALVARS \FONTSINCORE \FONTEXISTS?-CACHE IMAGESTREAMTYPES))
    (SETQ FONTSPEC (\FONT.CHECKARGS
 FONTSPEC NIL NIL NIL NIL T))
    (LET (VAL DEVICE COERCED)

         (* ;; "SASSOC everywhere because of face")


         (if
 (FETCHMULTI \FONTSINCORE FONTSPEC 'SASSOC)
           elseif
 (SETQ VAL (FETCHMULTI \FONTEXISTS?-CACHE FONTSPEC 'SASSOC))
             then
 (CL:UNLESS (EQ VAL 'NO)
                         VAL)
           else
 
                (* ;; 

  "Only rotation  0 really exists--but is that true only for the display?  Cache just the first file")


                (SETQ DEVICE (fetch
 (FONTSPEC FSDEVICE) of
 FONTSPEC)) 

                (* ;; "\SEARCHFONTFILES does no coercion, just looks for the fontspec files.  So, not the same as e.g. POSTSCRIPT.FONTSAVAILABLE.  Thus, TERMINAL 10 POSTSCRIPT doesn't exist if NOCOERCIONS.")


                [SETQ VAL (OR (CAR (FONTFILES
 FONTSPEC T))
                              (APPLY* (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE 'FONTEXISTS?))
                                          (FUNCTION \SEARCHFONTFILES))
                                     FONTSPEC NOCOERCIONS)
                              (AND (NOT NOCOERCIONS)
                                   (SETQ COERCED (CAR (OR (COERCEFONTSPEC
 FONTSPEC 'FONTCOERCIONS)
                                                          (COERCEFONTSPEC
 FONTSPEC 'FACECOERCIONS] 

                (* ;; "Don't cache NO if the font isn't found and coercion is suppressed.  A later coercive call might produce a different result.")


                (CL:WHEN (OR VAL COERCED)
                    (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC (OR VAL 'NO)
                           'SASSOC))
                VAL])

(\SEARCHFONTFILES

  [LAMBDA (FONTSPECS)
                                        (* ; "Edited 31-Aug-2026 16:29 by rmk")


                                                             (* ; "Edited 31-Aug-2026 16:16 by rmk")


                                                             (* ; "Edited 31-Aug-2026 16:02 by rmk")


                                                             (* ; "Edited 27-Aug-2026 18:48 by rmk")


                                                             (* ; "Edited 20-Jun-2026 13:40 by rmk")


                                                             (* ; "Edited  3-Jun-2026 19:52 by rmk")


                                                             (* ; "Edited  4-Mar-2026 00:14 by rmk")


                                                             (* ; "Edited 23-Aug-2025 12:36 by rmk")


                                                             (* ; "Edited 21-Jul-2025 08:57 by rmk")


                                                             (* ; "Edited 21-Jun-2025 12:00 by rmk")


                                                             (* ; "Edited 17-May-2025 14:09 by rmk")


                                                             (* ; "Edited 14-Sep-96 10:54 by rmk:")


                                                             (* ; "Edited  6-Oct-89 12:34 by bvm")


    (* ;; "GENERIC FUNCTION")


    (* ;; "Returns a list of the fonts that can be read in for a device.  Rotation is ignored because it is assumed that all devices support 0 90 180 and 270.  The caller must do any desired coercions.")


    (for
 FS FONTSFOUND FAMILY SIZE FACE ROTATION DEVICE (FILING.ENUMERATION.DEPTH ← 1)
       in
 (CL:IF (type?
 FONTSPEC FONTSPECS)
              (CONS FONTSPECS)
              FONTSPECS) declare
 (SPECVARS FILING.ENUMERATION.DEPTH)
       do
 (SPREADFONTSPEC FS) 

          (* ;; "Test DIRECTORYNAMEP because subdirectories may not exist")


          (for
 FILEPATTERN in
 (FONTFILES
 FS) when
 [DIRECTORYNAMEP (PACKFILENAME 'HOST
                                                                         (FILENAMEFIELD FILEPATTERN
                                                                                'HOST)
                                                                         'DIRECTORY
                                                                         (FILENAMEFIELD FILEPATTERN
                                                                                'DIRECTORY]
             do
 (for
 FONTFILE THISFONT in
 (DIRECTORY FILEPATTERN) eachtime
 

                                                                        (* ;; 

                                                 "make sure the face, size, and family really match.")


                                                                        (SETQ THISFONT
                                                                         (FONTSPECFROMFILENAME
 
                                                                                FONTFILE DEVICE))
                   when
 (AND THISFONT (OR (EQ FAMILY '*)
                                          (EQ FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 THISFONT)))
                             (OR (EQ SIZE '*)
                                 (EQ SIZE (fetch
 (FONTSPEC FSSIZE) of
 THISFONT)))
                             (MATCHFONTFACE
 FACE (fetch
 (FONTSPEC FSFACE) of
 THISFONT)))
                   unless
 (MEMBER THISFONT FONTSFOUND) do
 (push
 FONTSFOUND THISFONT)))
       finally
 (RETURN (DREVERSE FONTSFOUND])

(FLUSHFONTCACHE

  [LAMBDA (CACHES FAMILY SIZE FACE ROTATION DEVICE)
          (* ; "Edited 22-Aug-2026 12:49 by rmk")


                                                             (* ; "Edited 15-Apr-2026 22:11 by rmk")


                                                             (* ; "Edited 12-Apr-2026 11:54 by rmk")


                                                             (* ; "Edited  4-Apr-2026 23:04 by rmk")


                                                             (* ; "Edited 27-Nov-2025 10:02 by rmk")


                                                             (* ; "Edited 22-Nov-2025 15:52 by rmk")


    (* ;; "Removes information for font(s) from the caches in CACHES, if CACHES is NIL, all caches are flushed")


    (for
 CACHE NFLUSHED inside
 (OR CACHES '(:INCORE :EXISTS :AVAILABLE)) declare
 (SPECVARS NFLUSHED)
       first
 (CL:WHEN (OR (type?
 FONTSPEC FAMILY)
                          (type?
 FONTDESCRIPTOR FAMILY))
                 (SPREADFONTSPEC (\FONT.CHECKARGS
 FAMILY SIZE FACE ROTATION DEVICE T)))
             (CL:UNLESS FAMILY
                 (SETQ FAMILY '*))
             (CL:UNLESS SIZE
                 (SETQ SIZE '*))
             (CL:UNLESS FACE
                 (SETQ FACE '*))
             (CL:UNLESS ROTATION
                 (SETQ ROTATION '*))
             (CL:UNLESS DEVICE
                 (SETQ DEVICE '*)) eachtime
 (SETQ NFLUSHED 0)
       collect
 [MAPMULTI (SELECTQ CACHE
                             (:INCORE \FONTSINCORE)
                             (:EXISTS \FONTEXISTS?-CACHE)
                             (:AVAILABLE \FONTSAVAILABLEFILECACHE)
                             (\ILLEGAL.ARG CACHE))
                      (FUNCTION (LAMBDA (FM S FC R DPAIR)
                                  (DECLARE
 (USEDFREE NFLUSHED))
                                  (CL:WHEN (AND (OR (EQ FAMILY FM)
                                                    (EQ FAMILY '*))
                                                (OR (EQ SIZE S)
                                                    (EQ SIZE '*))
                                                (MATCHFONTFACE
 FACE FC)
                                                (OR (EQ ROTATION R)
                                                    (EQ ROTATION '*))
                                                (OR (EQ DEVICE (CAR DPAIR))
                                                    (EQ DEVICE '*))
                                                (CDR DPAIR))
                                      (ADD
 NFLUSHED 1)
                                      (RPLACD DPAIR))]
             (LIST CACHE NFLUSHED])

(SORTFONTSPECS

  [LAMBDA (FONTSPECS)
                                        (* ; "Edited 22-Mar-2026 12:44 by rmk")


                                                             (* ; "Edited 13-Mar-2026 11:33 by rmk")


                                                             (* ; "Edited 30-Aug-2025 15:12 by rmk")


    (* ;; "Sort FONTSPECS by alphabetically by family, then by smaller sizes, then by faces.  For faces the order is MRR MIR BRR BIR and any others, so that coercions from earlier fonts are possible.")


    (SORT
     FONTSPECS
     (FUNCTION (LAMBDA (FS1 FS2)
                 (SELECTQ (ALPHORDER (fetch
 (FONTSPEC FSDEVICE) of
 FS1)
                                 (fetch
 (FONTSPEC FSDEVICE) of
 FS2))
                     (EQUAL (SELECTQ (ALPHORDER (fetch
 (FONTSPEC FSFAMILY) of
 FS1)
                                            (fetch
 (FONTSPEC FSFAMILY) of
 FS2))
                                (EQUAL [OR (ILESSP (fetch
 (FONTSPEC FSSIZE) of
 FS1)
                                                  (fetch
 (FONTSPEC FSSIZE) of
 FS2))
                                           (CL:WHEN (EQ (fetch
 (FONTSPEC FSSIZE) of
 FS1)
                                                        (fetch
 (FONTSPEC FSSIZE) of
 FS2))
                                               [LET [(FACE1 (\FONTFACE
 (fetch
 (FONTSPEC FSFACE)
                                                                          of
 FS1)))
                                                     (FACE2 (\FONTFACE
 (fetch
 (FONTSPEC FSFACE)
                                                                          of
 FS2]
                                                    (OR (EQUAL FACE1 FACE2)
                                                        (AND (EQ 'MEDIUM (fetch
 (FONTFACE WEIGHT)
                                                                            of
 FACE1))
                                                             (NEQ 'MEDIUM (fetch
 (FONTFACE WEIGHT)
                                                                             of
 FACE2)))
                                                        (AND (EQ 'REGULAR (fetch
 (FONTFACE SLOPE)
                                                                             of
 FACE1))
                                                             (NEQ 'REGULAR (fetch
 (FONTFACE SLOPE)
                                                                              of
 FACE2])])
                                (LESSP T)
                                NIL))
                     (LESSP T)
                     NIL])
)
(DEFINEQ

(MATCHFONTFACE

  [LAMBDA (PATTERN FACE)
                                     (* ; "Edited 18-Mar-2026 13:39 by rmk")


                                                             (* ; "Edited 21-Jun-2025 11:57 by rmk")


    (* ;; "Does FACE match a PATTERN that may contain stars?")


    (if
 (EQ PATTERN '*)
      elseif
 (EQUAL PATTERN FACE)
      else
 (CL:WHEN (AND PATTERN (LITATOM PATTERN))
               (SETQ PATTERN (\FONTFACE
 PATTERN)))
           (LET ((PWEIGHT (fetch
 (FONTFACE WEIGHT) of
 PATTERN))
                 (PSLOPE (fetch
 (FONTFACE SLOPE) of
 PATTERN))
                 (PEXPANSION (fetch
 (FONTFACE EXPANSION) of
 PATTERN)))
                (AND (OR (EQ PWEIGHT (fetch
 (FONTFACE WEIGHT) of
 FACE))
                         (EQ PWEIGHT '*))
                     (OR (EQ PSLOPE (fetch
 (FONTFACE SLOPE) of
 FACE))
                         (EQ PSLOPE '*))
                     (OR (EQ PEXPANSION (fetch
 (FONTFACE EXPANSION) of
 FACE))
                         (EQ PEXPANSION '*])

(MAKEFONTFACE

  [LAMBDA (WEIGHT SLOPE EXPANSION BASE COLOR FORECOLOR BACKCOLOR)

                                                             (* ; "Edited 22-Sep-2026 09:41 by rmk")


                                                             (* ; "Edited  7-Nov-2025 08:50 by rmk")


                                                             (* ; "Edited 30-Aug-2025 10:22 by rmk")

    (CL:WHEN (FONTP
 BASE)
        (SETQ BASE (FONTPROP
 BASE 'FACE)))
    (CL:UNLESS WEIGHT
        (SETQ WEIGHT (CL:IF BASE
                         (fetch
 (FONTFACE WEIGHT) of
 BASE)
                         'MEDIUM)))
    (CL:UNLESS SLOPE
        (SETQ SLOPE (CL:IF BASE
                        (fetch
 (FONTFACE SLOPE) of
 BASE)
                        'REGULAR)))
    (CL:UNLESS EXPANSION
        (SETQ EXPANSION (CL:IF BASE
                            (fetch
 (FONTFACE EXPANSION) of
 BASE)
                            'REGULAR)))

    (* ;; "COLOR isn't a separate object, so can't create it separately and can't pull it apart")


    (if
 COLOR
        then
 (CL:WHEN (OR FORECOLOR BACKCOLOR)
                    (ERROR "Can't specify COLOR and also FORECOLOR or BACKCOLOR"))
             (create
 FONTFACE
                    WEIGHT ← WEIGHT
                    SLOPE ← SLOPE
                    EXPANSION ← EXPANSION
                    COLOR ← COLOR)
      else
 (create
 FONTFACE
                  WEIGHT ← WEIGHT
                  SLOPE ← SLOPE
                  EXPANSION ← EXPANSION
                  FORECOLOR ← (OR FORECOLOR (fetch
 (FONTFACE FORECOLOR) of
 BASE))
                  BACKCOLOR ← (OR BACKCOLOR (fetch
 (FONTFACE BACKCOLOR) of
 BASE])

(FONTFACETOATOM

  [LAMBDA (FACE NOERROR)
                                     (* ; "Edited 22-Jan-2026 08:13 by rmk")


                                                             (* ; "Edited  7-Sep-2025 09:19 by rmk")

    (LET (ATOM)
         (SETQ ATOM (if
 (type?
 FONTFACE FACE)
                        then
 [PACK (LIST* (SELECTQ (fetch
 (FONTFACE WEIGHT) of
 FACE)
                                              (MEDIUM 'M)
                                              (BOLD 'B)
                                              (LIGHT 'L)
                                              (fetch
 (FONTFACE WEIGHT) of
 FACE))
                                          (SELECTQ (fetch
 (FONTFACE SLOPE) of
 FACE)
                                              (ITALIC 'I)
                                              (REGULAR 'R)
                                              (fetch
 (FONTFACE SLOPE) of
 FACE))
                                          (SELECTQ (fetch
 (FONTFACE EXPANSION) of
 FACE)
                                              (REGULAR 'R)
                                              (COMPRESSED 'C)
                                              (EXPANDED 'E)
                                              (fetch
 (FONTFACE EXPANSION) of
 FACE))
                                          (CL:WHEN (fetch
 (FONTFACE COLOR) of
 FACE)
                                              (LIST "-" (fetch
 (FONTFACE BACKCOLOR) of
 FACE)
                                                    "-"
                                                    (fetch
 (FONTFACE FORECOLOR) of
 FACE)))]
                      elseif
 (AND FACE (LITATOM FACE)
                                  (MEMB (NTHCHARCODE FACE 1)
                                        (CHARCODE M B L *
))
                                  (MEMB (NTHCHARCODE FACE 2)
                                        (CHARCODE I R *
))
                                  (MEMB (NTHCHARCODE FACE 3)
                                        (CHARCODE R C E *
)))
                        then
 FACE
                      elseif
 (NOT NOERROR)
                        then
 (\ILLEGAL.ARG FACE])

(FONTFACE.STARS

  [LAMBDA (FACE)
                                             (* ; "Edited 19-Mar-2026 23:31 by rmk")


    (* ;; "Produces a list of font faces formed by expanding eacy of the starred components of FACE")


    (CL:WHEN (EQ FACE '*)
        (SETQ FACE (create
 FONTFACE
                          WEIGHT ← '*
                          SLOPE ← '*
                          EXPANSION ← '*)))
    (for
 W VAL inside
 (CL:IF (EQ '* (fetch
 (FONTFACE WEIGHT) of
 FACE))
                          '(BOLD MEDIUM)
                          (fetch
 (FONTFACE WEIGHT) of
 FACE))
       do
 [for
 S inside
 (CL:IF (EQ '* (fetch
 (FONTFACE SLOPE) of
 FACE))
                            '(ITALIC REGULAR)
                            (fetch
 (FONTFACE SLOPE) of
 FACE))
             do
 (for
 E inside
 (CL:IF (EQ '* (fetch
 (FONTFACE EXPANSION) of
 FACE))
                                  '(COMPRESSED REGULAR)
                                  (fetch
 (FONTFACE EXPANSION) of
 FACE))
                   do
 (push
 VAL (MAKEFONTFACE
 W S E] finally
 (RETURN VAL])
)

(RPAQ? \FONTSINCORE
 NIL)

(RPAQ? \FONTEXISTS?-CACHE
 NIL)

(RPAQ? \FONTSAVAILABLEFILECACHE
 NIL)

(RPAQ? \DEFAULTDEVICEFONTS
 NIL)

(ADDTOVAR \SYSTEMCACHEVARS
 \FONTEXISTS?-CACHE \FONTSAVAILABLEFILECACHE)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR)
)

(RPAQ? \UNITWIDTHSVECTOR
 NIL)
(DEFINEQ

(\UNITWIDTHSVECTOR

  [LAMBDA NIL
                                                (* ; "Edited 24-Aug-2025 12:39 by rmk")

                                                             (* JonL " 7-NOV-83 19:23")

    (SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXTHINCHAR 3)
                                                WORDSPERCELL)))
    (for
 I from
 0 to
 (IPLUS \MAXTHINCHAR 2) do
 (\PUTBASE \UNITWIDTHSVECTOR I 1))
    \UNITWIDTHSVECTOR])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(\UNITWIDTHSVECTOR
)
)
(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE

(DATATYPE FONTCLASS
 ((PRETTYFONT# BYTE)
                     DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME)
                    (INIT (DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT))))

(DATATYPE FONTDESCRIPTOR
 ((FONTDEVICE POINTER)
                          (FONTCOMPLETEP FLAG)
                          (FONTCOERCEDP FLAG)                (* ; 

                                                        "Indirects to another font via FONTCOERCIONS")

                          (FONTFAMILY POINTER)
                          (FONTSIZE POINTER)
                          (FONTFACE POINTER)
                          (FONTASCENT WORD)
                          (FONTDESCENT WORD)
                          (FONTHEIGHT WORD)
                          (FONTROTATION WORD)
                          (FONTSLUGWIDTH WORD)               (* ; "Was FBBOX.  The width of the slug character in the font, used by the generic \BUILDSLUGCSINFO to create the slug charsetinfo")

                          (MAXCHARSET WORD)                  (* ; 

                  "Maximum number of charsets, usually \MAXCHARSET but maybe more for Unicode fonts.")

                          (SLUGCSINFO POINTER)               (* ; "Was FBBDX and FBBDY words")

                          (FONTTOMCCSFN POINTER)             (* ; "Was \SFLKerns. Function that translates codes in the font's pre-MCCS encoding into MCCS (e.g. Hippo A to Greek,Alpha) ")

                          (FONTFILENAME POINTER)             (* ; "For a font read from a Medleyfont file, the name of that file.  For access to future properties and to instantiate future charsets.")

                          (FONTDEVICESPEC POINTER)           (* ; 

        "Holds the spec by which the font is known to the printing device, if coercion has been done")

                          (OTHERDEVICEFONTPROPS POINTER)     (* ; 

                                                 "For individual devices to hang special information")

                          (FONTSCALE POINTER)
                          (\SFFACECODE BITS 8)
                          (FONTAVGCHARWIDTH WORD)            (* ; 

                            "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called")

                          (FONTCHARENCODING POINTER)         (* ; "Was FONTIMAGEWIDTHS: This is the image width, as opposed to the advanced width;  initial hack for accents, kerning.  Fields is referenced by FONTCREATE.")

                          (FONTCHARSETVECTOR POINTER)        (* ; "A MAXCHARSET+1-pointer block, with one pointer per 'character set' --each group of 256 character codes.  Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset. The last cell if not NIL is the %"slug%" charsetinfo that can be shared as the dummy entry for otherwise NIL charsets")

                          (FONTHASLEFTKERNS FLAG)            (* ; 

                                        "T if at least one character set has an entry for left kerns")

                          (FONTEXTRAFIELD2 POINTER))
                         MAXCHARSET ← \MAXCHARSET FONTCHARSETVECTOR ← (\CREATEFONTCHARSETVECTOR)
                         (INIT (DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)))
                         [ACCESSFNS ((\SFAscent (fetch
 (FONTDESCRIPTOR FONTASCENT) of
 DATUM)
                                            (replace
 (FONTDESCRIPTOR FONTASCENT) of
 DATUM
                                               with
 NEWVALUE))
                                     (\SFDescent (fetch
 (FONTDESCRIPTOR FONTDESCENT) of
 DATUM)
                                            (replace
 (FONTDESCRIPTOR FONTDESCENT) of
 DATUM
                                               with
 NEWVALUE))
                                     (\SFHeight (fetch
 (FONTDESCRIPTOR FONTHEIGHT) of
 DATUM)
                                            (replace
 (FONTDESCRIPTOR FONTHEIGHT) of
 DATUM
                                               with
 NEWVALUE))
                                     (ROTATION (fetch
 (FONTDESCRIPTOR FONTROTATION) of
 DATUM)
                                            (replace
 (FONTDESCRIPTOR FONTROTATION) of
 DATUM
                                               with
 NEWVALUE])

(RECORD FONTFACE
 (WEIGHT SLOPE EXPANSION)
                 [ACCESSFNS ((COLOR (CDDDR DATUM)
                                    (RPLACD (CDDR DATUM)
                                           NEWVALUE))
                             (BACKCOLOR [COND
                                           ((CDDDR DATUM)
                                            (CAR (CDDDR DATUM]
                                    (PROGN [COND
                                              ((NULL (CDDDR DATUM))
                                               (RPLACD (CDDR DATUM)
                                                      (LIST NIL NIL]
                                           (RPLACA (CDDDR DATUM)
                                                  NEWVALUE)))
                             (FORECOLOR [COND
                                           ((CDDDR DATUM)
                                            (CADR (CDDDR DATUM]
                                    (PROGN [COND
                                              ((NULL (CDDDR DATUM))
                                               (RPLACD (CDDR DATUM)
                                                      (LIST NIL NIL]
                                           (RPLACA (CDR (CDDDR DATUM))
                                                  NEWVALUE]
                 WEIGHT ← 'MEDIUM SLOPE ← 'REGULAR EXPANSION ← 'REGULAR (TYPE?
 LISTP))

(DATATYPE CHARSETINFO
 (WIDTHS                                (* ; "The advance-width of each character, an array indexed by charcode.  Usually the same as the imagewidth, but can differ for accents, kerns kerns.  This is what should be used for stringwidth calculations.")

                             (CSSLUGP FLAG)                  (* ; "True if this is a slug charset")

                             (CSCOMPLETEP FLAG)              (* ; 

    "True if there is no further data to fill in any remaining slug-characters in a non-slug charset")

                             OFFSETS                         (* ; 

                              "Offset of each character into the image bitmap;  X value of left edge")

                             IMAGEWIDTHS                     (* ; "imagewidths is not automagically allocated since it is not always needed.  But at least some times the IMAGEWIDTHS and WIDTHS vectors are EQ in this case.")

                             CHARSETBITMAP                   (* ; 

                                         "Bitmap containing the character images, indexed by OFFSETS")

                             YWIDTHS
                             (CHARSETASCENT WORD)            (* ; 

                                                      "Max ascent for all characters in this CHARSET")

                             (CHARSETDESCENT WORD)           (* ; 

                                                     "Max descent for all characters in this CHARSET")

                             LEFTKERN CSINFOPROPS            (* ; "Alist of extra properties")

                             (CHARSETNO WORD)                (* ; 

                               "The number of this CSINFO in its font--MAX.SMALLP if not initialized")

                             SLUGCHARBITS)
                      WIDTHS ← (\CREATECSINFOELEMENT)
                      CHARSETNO ← MAX.SMALLP SLUGCHARBITS ← (\ALLOCBLOCK (FOLDLO 256 BITSPERCELL))
                      (ACCESSFNS (YIMAGEWIDTHS (CHARSETPROP DATUM 'YIMAGEWIDTHS)
                                        (CHARSETPROP DATUM 'YIMAGEWIDTHS NEWVALUE))))

(RECORD FONTSPEC
 (FSFAMILY FSSIZE FSFACE FSROTATION FSDEVICE)
                 (RECORD FSFACE (FSWEIGHT FSSLOPE FSEXPANSION))
                 FSROTATION ← 0 [TYPE?
 (AND (LISTP DATUM)
                                            (AND (fetch
 (FONTSPEC FSFAMILY) of
 DATUM)
                                                 (LITATOM (fetch
 (FONTSPEC FSFAMILY) of
 DATUM)))
                                            (OR (AND (SMALLP (fetch
 (FONTSPEC FSSIZE) of
 DATUM))
                                                     (IGEQ (fetch
 (FONTSPEC FSSIZE) of
 DATUM)
                                                           0))
                                                (EQ '* (fetch
 (FONTSPEC FSSIZE) of
 DATUM])
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS
 0 (BITS . 7))
         (FONTCLASS
 2 POINTER)
         (FONTCLASS
 4 POINTER)
         (FONTCLASS
 6 POINTER)
         (FONTCLASS
 8 POINTER)
         (FONTCLASS
 10 POINTER))
       '12)

(DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT))

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER FLAG FLAG POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD POINTER POINTER 
               POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER FLAG POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 0 (FLAGBITS . 0))
         (FONTDESCRIPTOR 0 (FLAGBITS . 16))
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (BITS . 15))
         (FONTDESCRIPTOR 13 (BITS . 15))
         (FONTDESCRIPTOR 14 POINTER)
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 30 (FLAGBITS . 0))
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT))

(/DECLAREDATATYPE 'CHARSETINFO
       '(POINTER FLAG FLAG POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 0 (FLAGBITS . 0))
         (CHARSETINFO 0 (FLAGBITS . 16))
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER)
         (CHARSETINFO 14 POINTER)
         (CHARSETINFO 16 (BITS . 15))
         (CHARSETINFO 18 POINTER))
       '20)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FONTASCENT
 MACRO
 ((FONTSPEC)
                            (ffetch
 (FONTDESCRIPTOR FONTASCENT) of
 (FONTCREATE
 FONTSPEC))))

(PUTPROPS FONTDESCENT
 MACRO
 ((FONTSPEC)
                             (ffetch
 (FONTDESCRIPTOR FONTDESCENT) of
 (FONTCREATE
 FONTSPEC))))

(PUTPROPS FONTHEIGHT
 MACRO
 ((FONTSPEC)
                            (ffetch
 (FONTDESCRIPTOR FONTHEIGHT) of
 (FONTCREATE
 FONTSPEC))))

(PUTPROPS \FGETOFFSET
 DMACRO
 ((OFFSETSBLOCK CHAR8CODE)
                              (\GETBASE OFFSETSBLOCK CHAR8CODE)))

(PUTPROPS \FSETOFFSET
 DMACRO
 ((OFFSETSBLOCK CHAR8CODE OFFSET)
                              (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET)))

(PUTPROPS \FGETWIDTH
 DMACRO
 ((WIDTHSBLOCK CHAR8CODE)
                             (\GETBASE WIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETWIDTH
 DMACRO
 ((WIDTHSBLOCK CHAR8CODE VAL)
                             (\PUTBASE WIDTHSBLOCK CHAR8CODE VAL)))

(PUTPROPS \FGETCHARWIDTH
 MACRO
 (OPENLAMBDA (FONTDESC CHARCODE)
                                 (\FGETWIDTH (ffetch
 (CHARSETINFO WIDTHS) of
 (\INSURECHARSETINFO
                                                                              FONTDESC
                                                                              (\CHARSET CHARCODE)))
                                        (\CHAR8CODE CHARCODE))))

(PUTPROPS \FSETCHARWIDTH
 MACRO
 (OPENLAMBDA (FONTDESC CHARCODE WIDTH)
                                 (\FSETWIDTH (ffetch
 (CHARSETINFO WIDTHS) of
 (\INSURECHARSETINFO
                                                                              FONTDESC
                                                                              (\CHARSET CHARCODE)))
                                        (\CHAR8CODE CHARCODE)
                                        WIDTH)))

(PUTPROPS \FGETIMAGEWIDTH
 MACRO
 ((IMAGEWIDTHSBLOCK CHAR8CODE)
                                 (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE)))

(PUTPROPS \FSETIMAGEWIDTH
 DMACRO
 ((WIDTHSBLOCK INDEX WIDTH)
                                  (\PUTBASE WIDTHSBLOCK INDEX WIDTH)))

(PUTPROPS MAXCHARSET
 MACRO
 ((FONT)

                            (* ;; "0 test until all old files are gone")


                            (LET ((MAX (fetch
 (FONTDESCRIPTOR MAXCHARSET) of
 FONT)))
                                 (CL:IF (EQ MAX 0)
                                     \MAXCHARSET
                                     MAX))))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \GETCHARSETINFO
 MACRO
 (OPENLAMBDA (FONTDESC CHARSET)

                                  (* ;; 

                 "Temporary until other callers of \GETCHARSETINFO are changes to \INSURECHARSETINFO")


                                  (* ;; 

                          "Fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC.  ")


                                  (* ;; 

       "NOTE Current \GETCHARSETINFO takes the vector, not the font, as does current \SETCHARSETINFO")


                                  (\GETBASEPTR (ffetch
 FONTCHARSETVECTOR of
 FONTDESC)
                                         (UNFOLD CHARSET 2))))

(PUTPROPS \SETCHARSETINFO
 MACRO
 ((FONTDESC CHARSET CSINFO)
                                 (\RPLPTR (fetch
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONTDESC)
                                        (UNFOLD CHARSET 2)
                                        CSINFO)))

(PUTPROPS \INSURECHARSETINFO
 MACRO
 [OPENLAMBDA (FONTDESC CHARSET)

                                 (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC.  If NIL, then creates and installs the required charset, maybe a slug (with CSSLUGP T). Greater than \MAXCHARSET = out of bounds")


                                     (CL:IF (IGREATERP CHARSET (MAXCHARSET FONTDESC))
                                         (SLUGCSINFO FONTDESC)
                                         (OR (\GETCHARSETINFO FONTDESC CHARSET)
                                             (\SETCHARSETINFO FONTDESC CHARSET (\CREATECHARSET
 
                                                                                      CHARSET 
                                                                                      FONTDESC))))])

(PUTPROPS \CREATECSINFOELEMENT
 MACRO
 (NIL (\ALLOCBLOCK (FOLDHI (ADD1 \MAXTHINCHAR)
                                                              WORDSPERCELL))))

(PUTPROPS \CREATEFONTCHARSETVECTOR
 MACRO
 (OPENLAMBDA (FONT)

                                           (* ;; "Allocates a block for the character set records, ADD1 to get the number of cells given the 0-based max.")


                                           (\ALLOCBLOCK (ADD1 (OR (AND FONT (MAXCHARSET FONT))
                                                                  \MAXCHARSET))
                                                  T)))

(PUTPROPS CHARSETPROP
 MACRO
 [ARGS (if
 (CDDR ARGS)
                                      then
 `(PUTMULTI (fetch
 (CHARSETINFO CSINFOPROPS)
                                                         of
 ,(CAR ARGS))
                                                   ,(CADR ARGS)
                                                   ,(CADDR ARGS))
                                    else
 `(GETMULTI (fetch
 (CHARSETINFO CSINFOPROPS)
                                                       of
 ,(CAR ARGS))
                                                 ,(CADR ARGS])

(PUTPROPS SLUGCSINFO
 MACRO
 [(FONT)
                            (OR (fetch
 (FONTDESCRIPTOR SLUGCSINFO) of
 FONT)
                                (replace
 (FONTDESCRIPTOR SLUGCSINFO) of
 FONT with
 (\BUILDSLUGCSINFO

                                                                                   FONT])
)

(PUTPROPS CHARSETPROP
 ARGNAMES
 (CSINFO PROP NEWVALUE))

(* "END EXPORTED DEFINITIONS")


(DECLARE%: EVAL@COMPILE 

(PUTPROPS INDIRECTCHARSETP
 MACRO
 [(CSINFO FONT)

                                  (* ;; "An indirect points somewhere else")


                                  (LET [(SOURCE (CL:UNLESS (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)
                                                    (CHARSETPROP CSINFO 'SOURCE))]
                                       (CL:WHEN [AND SOURCE (NOT (EQUAL SOURCE (FONTPROP
 FONT
                                                                                      'DEVICESPEC]
                                           (create
 FONTSPEC using
 SOURCE FSFACE ←
                                                                  (FONTFACETOATOM
 (fetch
 (FONTSPEC
                                                                                          FSFACE)
                                                                                     of
 SOURCE))))])
)
)
(DEFINEQ

(FONTDESCRIPTOR.DEFPRINT

  [LAMBDA (FONT STREAM)
                                      (* ; "Edited 30-Sep-2026 16:45 by rmk")


                                                             (* ; "Edited 21-Aug-2026 00:33 by rmk")


                                                             (* ; "Edited 10-Jul-2025 09:32 by rmk")


                                                             (* ; "Edited 14-Dec-2024 09:13 by rmk")

    (LET ((LOC (LOC FONT))
          (FACE (fetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)))

         (* ;; "Could lowercase the family, but maybe too dangerous if a BREAK on L-CASE.")


         (* ;; "Somehow flag the device too?")


         (CONS (CONCAT "{" (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT)
                      (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONT)
                      "-"
                      (SELECTQ (fetch
 (FONTFACE WEIGHT) of
 FACE)
                          (MEDIUM 'M)
                          (BOLD 'B)
                          (LIGHT 'L)
                          (fetch
 (FONTFACE WEIGHT) of
 FACE))
                      (SELECTQ (fetch
 (FONTFACE SLOPE) of
 FACE)
                          (ITALIC 'I)
                          (REGULAR 'R)
                          (fetch
 (FONTFACE SLOPE) of
 FACE))
                      (SELECTQ (fetch
 (FONTFACE EXPANSION) of
 FACE)
                          (REGULAR 'R)
                          (COMPRESSED 'C)
                          (EXPANDED 'E)
                          (fetch
 (FONTFACE EXPANSION) of
 FACE))
                      (if
 (EQ 0 (fetch
 (FONTDESCRIPTOR FONTROTATION) of
 FONT))
                          then
 ""
                        else
 (CONCAT "-" (fetch
 (FONTDESCRIPTOR FONTROTATION) of
 FONT)))
                      "/"
                      (OCTALSTRING (CAR LOC))
                      ","
                      (OCTALSTRING (CDR LOC))
                      "}"])

(FONTCLASS.DEFPRINT

  [LAMBDA (FONTCLASS
 STREAM)
                                 (* ; "Edited 14-Dec-2024 16:51 by rmk")

    (LET ((LOC (LOC FONTCLASS)))
         (CONS (CONCAT "{" (OR (fetch
 (FONTCLASS
 FONTCLASSNAME) of
 FONTCLASS)
                               'FONTCLASS)
                      "/"
                      (OCTALSTRING (CAR LOC))
                      ","
                      (OCTALSTRING (CDR LOC))
                      "}"])
)

(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
       '((FONTCLASS
 0 (BITS . 7))
         (FONTCLASS
 2 POINTER)
         (FONTCLASS
 4 POINTER)
         (FONTCLASS
 6 POINTER)
         (FONTCLASS
 8 POINTER)
         (FONTCLASS
 10 POINTER))
       '12)

(DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT))

(/DECLAREDATATYPE 'FONTDESCRIPTOR
       '(POINTER FLAG FLAG POINTER POINTER POINTER WORD WORD WORD WORD WORD WORD POINTER POINTER 
               POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER FLAG POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 0 (FLAGBITS . 0))
         (FONTDESCRIPTOR 0 (FLAGBITS . 16))
         (FONTDESCRIPTOR 2 POINTER)
         (FONTDESCRIPTOR 4 POINTER)
         (FONTDESCRIPTOR 6 POINTER)
         (FONTDESCRIPTOR 8 (BITS . 15))
         (FONTDESCRIPTOR 9 (BITS . 15))
         (FONTDESCRIPTOR 10 (BITS . 15))
         (FONTDESCRIPTOR 11 (BITS . 15))
         (FONTDESCRIPTOR 12 (BITS . 15))
         (FONTDESCRIPTOR 13 (BITS . 15))
         (FONTDESCRIPTOR 14 POINTER)
         (FONTDESCRIPTOR 16 POINTER)
         (FONTDESCRIPTOR 18 POINTER)
         (FONTDESCRIPTOR 20 POINTER)
         (FONTDESCRIPTOR 22 POINTER)
         (FONTDESCRIPTOR 24 POINTER)
         (FONTDESCRIPTOR 26 (BITS . 7))
         (FONTDESCRIPTOR 27 (BITS . 15))
         (FONTDESCRIPTOR 28 POINTER)
         (FONTDESCRIPTOR 30 POINTER)
         (FONTDESCRIPTOR 30 (FLAGBITS . 0))
         (FONTDESCRIPTOR 32 POINTER))
       '34)

(DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT))

(/DECLAREDATATYPE 'CHARSETINFO
       '(POINTER FLAG FLAG POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER WORD POINTER)
       '((CHARSETINFO 0 POINTER)
         (CHARSETINFO 0 (FLAGBITS . 0))
         (CHARSETINFO 0 (FLAGBITS . 16))
         (CHARSETINFO 2 POINTER)
         (CHARSETINFO 4 POINTER)
         (CHARSETINFO 6 POINTER)
         (CHARSETINFO 8 POINTER)
         (CHARSETINFO 10 (BITS . 15))
         (CHARSETINFO 11 (BITS . 15))
         (CHARSETINFO 12 POINTER)
         (CHARSETINFO 14 POINTER)
         (CHARSETINFO 16 (BITS . 15))
         (CHARSETINFO 18 POINTER))
       '20)
(ADDTOVAR SYSTEMRECLST

(DATATYPE FONTCLASS
 ((PRETTYFONT# BYTE)
                     DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))

(DATATYPE FONTDESCRIPTOR
 ((FONTDEVICE POINTER)
                          (FONTCOMPLETEP FLAG)
                          (FONTCOERCEDP FLAG)
                          (FONTFAMILY POINTER)
                          (FONTSIZE POINTER)
                          (FONTFACE POINTER)
                          (FONTASCENT WORD)
                          (FONTDESCENT WORD)
                          (FONTHEIGHT WORD)
                          (FONTROTATION WORD)
                          (FONTSLUGWIDTH WORD)
                          (MAXCHARSET WORD)
                          (SLUGCSINFO POINTER)
                          (FONTTOMCCSFN POINTER)
                          (FONTFILENAME POINTER)
                          (FONTDEVICESPEC POINTER)
                          (OTHERDEVICEFONTPROPS POINTER)
                          (FONTSCALE POINTER)
                          (\SFFACECODE BITS 8)
                          (FONTAVGCHARWIDTH WORD)
                          (FONTCHARENCODING POINTER)
                          (FONTCHARSETVECTOR POINTER)
                          (FONTHASLEFTKERNS FLAG)
                          (FONTEXTRAFIELD2 POINTER)))

(DATATYPE CHARSETINFO
 (WIDTHS (CSSLUGP FLAG)
                             (CSCOMPLETEP FLAG)
                             OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD)
                             (CHARSETDESCENT WORD)
                             LEFTKERN CSINFOPROPS (CHARSETNO WORD)
                             SLUGCHARBITS))
)
(DEFINEQ

(\CREATEKERNELEMENT

  [LAMBDA NIL
                                                (* ; "Edited  8-Jul-2025 22:33 by rmk")


                                                             (* ; "Edited 17-May-2025 09:36 by rmk")


    (* ;; "ARRAY not CL:MAKE-ARRAY for MAKEINIT.")


    (ARRAY (IPLUS \MAXTHINCHAR 3)
           'POINTER 0 0])

(\FSETLEFTKERN

  [LAMBDA (CSINFO INDEX KERNVALUE)
                           (* ; "Edited 12-Sep-2026 09:31 by rmk")


                                                             (* ; "Edited  8-Jul-2025 22:50 by rmk")


                                                             (* ; "Edited 17-May-2025 09:18 by rmk")


    (* ;; "Don't create an array until we see a non-zero value")


    (if
 (ARRAYP (ffetch
 (CHARSETINFO LEFTKERN) of
 CSINFO))
        then
 (SETA (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                   INDEX KERNVALUE)
      elseif
 (EQ KERNVALUE 0)
      else
 (replace
 (CHARSETINFO LEFTKERN) of
 CSINFO with
 (\CREATEKERNELEMENT
))
           (SETA (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                 INDEX KERNVALUE])

(\FGETLEFTKERN

  [LAMBDA (FONT PREVCHARCODE CHARCODE)
                       (* ; "Edited 25-Sep-2025 21:25 by rmk")


                                                             (* ; "Edited 30-Aug-2025 23:29 by rmk")


                                                             (* ; "Edited  8-Jul-2025 22:15 by rmk")


                                                             (* ; "Edited 22-May-2025 09:53 by rmk")


                                                             (* ; "Edited 18-May-2025 21:30 by rmk")


                                                             (* ; "Edited  1-May-2025 11:08 by rmk")


                                                             (* ; "Edited 19-Dec-2024 15:25 by rmk")


    (* ;; "Returns the kern information for CHARCODE in FONT, given that it is an immediate successor of PREVCHARCODE.  Returns 0 if no PREVCHARCODE/CHARCODE kerning is specified.  For now, assume that the kerning information is sparse for characters within a character set, stored as a 2-level alist.  ")


    (* ;; "If the kerning information for a character is already a FIXP, then it is an offset no matter what the preceding character might be.  This appears to be the way at least AC font files are set up.")


    (* ;; "ACFONTFILES STORE A SINGLE NUMBER.  LOGIC OF CODES IS UNCLEAR")


    (LET [(KERN (AND (fetch
 (FONTDESCRIPTOR FONTHASLEFTKERNS) of
 FONT)
                     (ELT (fetch
 (CHARSETINFO LEFTKERN) of
 (\INSURECHARSETINFO FONT (\CHARSET 
                                                                                         PREVCHARCODE
                                                                                           )))
                          (\CHAR8CODE PREVCHARCODE]
         (OR (FIXP KERN)
             (GETMULTI (LISTP KERN)
                    CHARCODE)
             0])
)
(DEFINEQ

(\CREATEFONT

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited  3-Sep-2026 19:08 by rmk")


                                                             (* ; "Edited 18-Aug-2026 22:27 by rmk")


                                                             (* ; "Edited 15-Apr-2026 00:13 by rmk")


                                                             (* ; "Edited  4-Apr-2026 23:29 by rmk")


                                                             (* ; "Edited  2-Apr-2026 23:01 by rmk")


                                                             (* ; "Edited 31-Mar-2026 22:55 by rmk")


                                                             (* ; "Edited 18-Mar-2026 22:44 by rmk")


                                                             (* ; "Edited 26-Jan-2026 15:24 by rmk")


                                                             (* ; "Edited 25-Dec-2025 10:58 by rmk")


                                                             (* ; "Edited 25-Sep-2025 21:24 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:30 by rmk")


                                                             (* ; "Edited 24-Jul-2025 19:51 by rmk")


                                                             (* ; "Edited 20-May-2025 21:10 by rmk")


    (* ;; "Generic font creation.  Uses fontcreate method from device to build the font fontdescriptor with font-level properties but doesn't call SETFONTDESCRIPTOR to install it and doesn't instantiate a charset.  That's deferred to \CREATECHARSET.  ")


    (* ;; "")


    (LET (FN COERCIONSPEC FONT FILE)                         (* ; "FONTEXISTS? tells us whether an uncoerced font exists.  If not, we deal with the coercions at this level.")

         (if
 (FONTEXISTS?
 FONTSPEC T)
             then
 [SETQ FN (CAR (GETMULTI IMAGESTREAMTYPES (FSPROP FONTSPEC FSDEVICE)
                                       'FONTCREATE]
                  (if
 FN
                      then
 (APPLY* FN FONTSPEC)
                    elseif
 (AND (SETQ FILE (CAR (FONTFILES
 FONTSPEC)))
                                (MEDLEYFONT.READ.FONT FILE NIL T))
                    else
 (FONTSPEC.TO.FONTDESCRIPTOR
 FONTSPEC))
           elseif
 [SETQ COERCIONSPEC (find
 C in
 (COERCEFONTSPEC
 FONTSPEC 'FONTCOERCIONS T T)
                                        suchthat
 (SETQ FONT (\CREATEFONT
 C]
             then
 
                  (* ;; "(Re)load the target font, change its spec labeling.  Maybe the DEVICESPEC should also change, in case this is dumped?  But \CREATECHARSET  needs to know the device name so it doesn't keep coercing.  COERCIONSPEC is known to exist")


                  (SETQ FONT (FONT.CHANGESPEC
 FONT FONTSPEC COERCIONSPEC))
                  (replace
 (FONTDESCRIPTOR FONTCOERCEDP) of
 FONT with
 T) 

                  (* ;; "The function applies to the unchanged font")


                  (CL:WHEN [SETQ FN (CAR (GETMULTI IMAGESTREAMTYPES (FSPROP FONTSPEC FSDEVICE)
                                                'FONTCREATE]
                      (SETQ FONT (APPLY* FN FONT)))
                  FONT
           elseif
 [SETQ COERCIONSPEC (CAR (COERCEFONTSPEC
 FONTSPEC 'FACECOERCIONS]
             then
 (FONTSPEC.TO.FONTDESCRIPTOR
 FONTSPEC (MAXCHARSET (\CREATEFONT
 COERCIONSPEC])

(\CREATECHARSET

  [LAMBDA (CHARSET FONT GETCHARSETFN)
                        (* ; "Edited 22-Sep-2026 00:07 by rmk")


                                                             (* ; "Edited 13-Sep-2026 22:29 by rmk")


                                                             (* ; "Edited  2-Sep-2026 14:16 by rmk")


                                                             (* ; "Edited 31-Aug-2026 10:55 by rmk")


                                                             (* ; "Edited 12-Apr-2026 18:47 by rmk")


                                                             (* ; "Edited  4-Apr-2026 14:39 by rmk")


                                                             (* ; "Edited 14-Feb-2026 13:12 by rmk")


                                                             (* ; "Edited 25-Sep-2025 21:24 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited  9-Jul-2025 11:12 by rmk")


                                                             (* ; "Edited 18-May-2025 21:40 by rmk")


                                                             (* ; "Edited 12-Jul-2022 14:37 by rmk")


                                                             (* ; "Edited  8-May-93 23:42 by rmk:")


                                                             (* ; "Edited  4-Dec-92 11:43 by jds")


    (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in FONT's FONTCHARSETVECTOR.")


    (* ;; 

    "\READCHARSET is the default (function is NIL), T produces the empty charsetinfo (or the slug?)")


    (OR (\GETCHARSETINFO FONT CHARSET)
        (LET (CSINFO)                                        (* ; 

                                                             "Use DEVICESPEC in case it was coerced")

             (SETQ CSINFO (if
 [OR GETCHARSETFN (SETQ GETCHARSETFN (CAR (GETMULTI IMAGESTREAMTYPES
                                                                              (fetch
 (FONTDESCRIPTOR
                                                                                      FONTDEVICE)
                                                                                 of
 FONT)
                                                                              'CREATECHARSET]
                              then
 (APPLY* GETCHARSETFN (OR (ffetch
 (FONTDESCRIPTOR FONTDEVICESPEC)
                                                               of
 FONT)
                                                            (MAKEFONTSPEC
 NIL NIL NIL NIL NIL FONT))
                                          FONT CHARSET)
                            else
 (\READCHARSET
 FONT CHARSET)))

             (* ;; "If we couldn't obtain a CSINFO, it must be  a slug")


             (\INSTALLCHARSETINFO
 FONT (OR CSINFO (SLUGCSINFO FONT))
                    CHARSET])

(\INSTALLCHARSETINFO

  [LAMBDA (FONT CSINFO CHARSET)
                              (* ; "Edited 10-Sep-2026 23:24 by rmk")


                                                             (* ; "Edited  1-Sep-2026 12:09 by rmk")


                                                             (* ; "Edited 31-Aug-2025 14:36 by rmk")


                                                             (* ; "Edited 25-Aug-2025 14:32 by rmk")


                                                             (* ; "Edited 24-Aug-2025 11:29 by rmk")


                                                             (* ; "Edited 25-May-2025 07:48 by rmk")


                                                             (* ; "Edited 23-May-2025 14:44 by rmk")


                                                             (* ; "Edited 12-Jul-2022 15:08 by rmk")

    (replace
 FONTASCENT of
 FONT with
 (IMAX (fetch
 FONTASCENT of
 FONT)
                                           (SIGNED (fetch
 CHARSETASCENT of
 CSINFO)
                                                  16)))
    (replace
 (FONTDESCRIPTOR FONTDESCENT) of
 FONT with
 (IMAX (fetch
 (FONTDESCRIPTOR FONTDESCENT)
                                                                of
 FONT)
                                                             (SIGNED (fetch
 (CHARSETINFO 
                                                                                   CHARSETDESCENT)
                                                                        of
 CSINFO)
                                                                    16)))
                                                             (* ; 

                                "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")

    (replace
 (FONTDESCRIPTOR FONTHEIGHT) of
 FONT with
 (IPLUS (ffetch
 (FONTDESCRIPTOR FONTASCENT)
                                                                of
 FONT)
                                                             (ffetch
 (FONTDESCRIPTOR FONTDESCENT)
                                                                of
 FONT)))
    (replace
 (CHARSETINFO CHARSETNO) of
 CSINFO with
 CHARSET) (* ; "In case the device didn't do it")

    (\INSTALLCHARSETINFO.CHARENCODING
 FONT CSINFO CHARSET)
    (\SETCHARSETINFO FONT CHARSET CSINFO)

    (* ;; "\AVGCHARWIDTH has to be confused after the CSINFO is stuck in.")


    (CL:WHEN (EQ 0 (fetch
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT))
        (replace
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT with
 (\AVGCHARWIDTH
 FONT)))
    (CL:WHEN (EQ 0 (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT))
                                                             (* ; "CSINFO is presumably charset 0")

        (for
 C from
 0 to
 \MAXTHINCHAR when
 (GETSLUGFLAG CSINFO C)
           do
 (replace
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT with
 (\FGETWIDTH (fetch
 (CHARSETINFO
                                                                                       WIDTHS)
                                                                                  of
 CSINFO)
                                                                          C))
              (RETURN)))
    (CL:WHEN (EQ 0 (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT))
                                                             (* ; "Still 0: try for the average")

        (replace
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT with
 (fetch
 (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                                of
 FONT)))
    CSINFO])

(\INSTALLCHARSETINFO.CHARENCODING

  [LAMBDA (FONT CSINFO CHARSET)
                              (* ; "Edited  4-Sep-2026 16:32 by rmk")


                                                             (* ; "Edited 12-Jul-2025 10:57 by rmk")


                                                             (* ; "Edited  9-Jul-2025 09:38 by rmk")


                                                             (* ; "Edited  6-Jul-2025 21:46 by rmk")


                                                             (* ; "Edited 25-May-2025 23:05 by rmk")


                                                             (* ; "Edited 24-May-2025 21:42 by rmk")


    (* ;; "The font charencoding is its charset 0 encoding.  All higher charsets are MCCS.")


    (CL:WHEN (AND (EQ CHARSET 0)
                  (NOT (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO))
                  (CHARSETPROP CSINFO 'CSCHARENCODING))
        (replace
 (FONTDESCRIPTOR FONTCHARENCODING) of
 FONT with
 (CHARSETPROP CSINFO 'CSCHARENCODING)))
    ])

(\COPYCHARSETINFO

  [LAMBDA (CSINFO)
                                           (* ; "Edited  4-Sep-2026 17:07 by rmk")


    (* ;; "Produce a copy of CSINFO, including copies of all the blocks underneath, for smashing.")


    (* ;; "Simplest solution, if WIDTHS=IMAGEWIDTHS is to copy them separately, then swap back.")


    (LET ((NEW (COPYALL CSINFO)))
         (CL:WHEN (EQ (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                      (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
             (replace
 (CHARSETINFO IMAGEWIDTHS) of
 NEW with
 (fetch
 (CHARSETINFO WIDTHS) of
 NEW)))
         NEW])
)
(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(PUTPROPS FIRSTCHARSETCODE
 MACRO
 ((CHARSET)
                                  (LLSH CHARSET 8)))

(PUTPROPS LASTCHARSETCODE
 MACRO
 ((CHARSET)
                                 (LOGOR (LLSH CHARSET 8)
                                        \MAXTHINCHAR)))
)

(* "END EXPORTED DEFINITIONS")

)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \FGETCHARIMAGEWIDTH
 MACRO
 (OPENLAMBDA (FONT CHARCODE)
                                      (\FGETWIDTH (ffetch
 (CHARSETINFO IMAGEWIDTHS)
                                                     of
 (\INSURECHARSETINFO FONT (\CHARSET CHARCODE))
                                                         )
                                             (\CHAR8CODE CHARCODE))))
)



(* ;; "")





(* ;; "DISPLAY")





(* ; "Functions for DISPLAY IMAGESTREAMTYPES ")


(DEFINEQ

(\CREATEFONT.DISPLAY

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited  5-Sep-2026 09:14 by rmk")


                                                             (* ; "Edited  2-Sep-2026 21:55 by rmk")


                                                             (* ; "Edited 29-Aug-2026 00:34 by rmk")


                                                             (* ; "Edited 26-Aug-2026 21:02 by rmk")


                                                             (* ; "Edited  5-May-2026 09:54 by rmk")


                                                             (* ; "Edited 15-Apr-2026 00:20 by rmk")


                                                             (* ; "Edited 11-Apr-2026 10:10 by rmk")


                                                             (* ; "Edited 29-Mar-2026 10:23 by rmk")


                                                             (* ; "Edited 16-Mar-2026 12:39 by rmk")


                                                             (* ; "Edited 28-Aug-2025 16:00 by rmk")


                                                             (* ; "Edited 18-Aug-2025 11:32 by rmk")


                                                             (* ; "Edited 16-Aug-2025 18:46 by rmk")


                                                             (* ; "Edited 10-Aug-2025 13:24 by rmk")


                                                             (* ; "Edited 13-Jun-2025 22:58 by rmk")


                                                             (* ; "Edited  9-Jun-2025 17:42 by rmk")


                                                             (* ; "Edited  7-Jun-2025 15:11 by rmk")


                                                             (* ; "Edited 23-May-2025 14:59 by rmk")


                                                             (* ; "Edited 22-May-2025 09:52 by rmk")

                                                             (* ; "gbn: 25-Jan-86 18:02")


    (* ;; "Eventually, this should be removed from IMAGESTREAMTYPES, since it is the default.  Left here in case something else turns up.")


    (* ;; "FONTEXISTS? has determined that there is at least one source file for this font, so the font exists or can be faked in at least some character sets.")


    (if
 (type?
 FONTSPEC FONTSPEC)
        then
                                                 (* ; 

                                                           "Called with an FD if already fontcoerced")

             (SETQ FONTSPEC (MAKEFONTSPEC
 NIL NIL NIL (IMOD (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC)
                                                            360)
                                   NIL FONTSPEC))
             (CL:WHEN (MEMB (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC)
                            '(0 90 180 270))
                 (LET [(FILE (CAR (FONTFILES
 FONTSPEC T]
                      (if
 FILE
                          then
 (MEDLEYFONT.READ.FONT FILE NIL T)
                        else
 
                             (* ;; "Set up for faking")


                             (FONTSPEC.TO.FONTDESCRIPTOR
 FONTSPEC))))
      else
 FONTSPEC])

(\CREATECHARSET.DISPLAY

  [LAMBDA (FONTSPEC FONT CHARSET)
                            (* ; "Edited 26-Aug-2026 11:40 by rmk")


                                                             (* ; "Edited 12-Apr-2026 18:52 by rmk")


                                                             (* ; "Edited  5-Apr-2026 10:02 by rmk")


                                                             (* ; "Edited  1-Apr-2026 10:32 by rmk")


                                                             (* ; "Edited 29-Mar-2026 10:30 by rmk")


                                                             (* ; "Edited 17-Mar-2026 16:11 by rmk")


                                                             (* ; "Edited 14-Mar-2026 12:26 by rmk")


                                                             (* ; "Edited  7-Oct-2025 17:05 by rmk")


                                                             (* ; "Edited 18-Aug-2025 09:12 by rmk")


                                                             (* ; "Edited 31-Jul-2025 10:14 by rmk")


                                                             (* ; "Edited 13-Jul-2025 11:44 by rmk")


                                                             (* ; "Edited 18-May-2025 23:31 by rmk")


                                                             (* ; "Edited 14-Jan-88 23:42 by FS")


    (* ;; "If the CHARSETINFO can be read from a file, then any appropriate charset or character coercions (complete, rotated, faked) are assumed to have already taken place.")


    (* ;; "But if it doesn't exist on a file, it may be that face-faking or rotation can be applied to a character set that can be retrieved from an existing complete file.")


    (* ;; "")


    (if
 (\READCHARSET
 FONT CHARSET)
      else
 
           (* ;; "Successful transformations must set the CSINFO so that it can be returned.")


           (CL:UNLESS (EQ 0 (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC))
               (\SETCHARSETINFO FONT CHARSET (\SFROTATECSINFO
 FONTSPEC CHARSET)))
           (COMPLETE.CHARSET
 FONT CHARSET)
           (CL:WHEN (FONTDEVICEPROP
 FONTSPEC 'FACECOERCIONS) (* ; 

                                                   "Suppresses face-faking in offline COMPLETE phase")

               (CL:WHEN (EQ 'BOLD (fetch
 (FONTSPEC FSWEIGHT) of
 FONTSPEC))

                   (* ;; "Heuristically, an actual glyph from a completed/inherited font with the same face ought to be better than the fake from a more regular version of FONT--the algorithms aren't so good.  So here the complete happens first.  The problem is that the inherited font may have glyphs from its own faking, in the offline importfont sequence.  There is no way to know on the fly whether any individual inherited character was faked or not")


                   (FAKEFACE.CHARSET
 FONT CHARSET (FUNCTION MAKEBOLD.CHAR)
                          (create
 FONTSPEC using
 FONTSPEC FSWEIGHT ← 'MEDIUM)))
               (CL:WHEN (EQ 'ITALIC (fetch
 (FONTSPEC FSSLOPE) of
 FONTSPEC))
                   (FAKEFACE.CHARSET
 FONT CHARSET (FUNCTION MAKEITALIC.CHAR)
                          (create
 FONTSPEC using
 FONTSPEC FSSLOPE ← 'REGULAR)))
               (CL:WHEN (EQ 'COMPRESSED (fetch
 (FONTSPEC FSEXPANSION) of
 FONTSPEC))
                   (FAKEFACE.CHARSET
 FONT CHARSET (FUNCTION MOVEFONTCHARS)
                          (create
 FONTSPEC using
 FONTSPEC FSEXPANSION ← 'REGULAR))))
           (\GETCHARSETINFO FONT CHARSET])

(\FONTEXISTS?.DISPLAY

  [LAMBDA (FONTSPEC NOCOERCIONS)
                             (* ; "Edited 26-Aug-2026 23:44 by rmk")


                                                             (* ; "Edited  4-Apr-2026 09:03 by rmk")


                                                             (* ; "Edited 18-Mar-2026 11:45 by rmk")


                                                             (* ; "Edited 17-Dec-2025 20:56 by rmk")


                                                             (* ; "Edited 28-Aug-2025 22:12 by rmk")


                                                             (* ; "Edited 25-Aug-2025 15:04 by rmk")


                                                             (* ; "Edited 17-Aug-2025 09:56 by rmk")


                                                             (* ; "Edited  8-Aug-2025 10:03 by rmk")


                                                             (* ; "Edited  5-Aug-2025 17:55 by rmk")


                                                             (* ; "Edited 29-Jul-2025 22:56 by rmk")


                                                             (* ; "Edited 25-Jul-2025 21:38 by rmk")


                                                             (* ; "Edited 13-Jul-2025 11:45 by rmk")


                                                             (* ; "Edited 22-Jun-2025 08:53 by rmk")


    (* ;; "Order doesn't matter here, only need one to work. The CHAR coercions are done generically, if this fails.  This considers the face faking to be a form of coercion, suppressed by NOCOERCION.")


    (* ;; "BIR is possible if either MIR or BRR is available, doesn't always go to MRR.")


    (if
 (EQ 0 (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC))
        then
 (CL:UNLESS NOCOERCIONS
                 (CL:WHEN (FONTDEVICEPROP
 FONTSPEC 'FACECOERCIONS)
                     (OR (AND (EQ 'BOLD (fetch
 (FONTSPEC FSWEIGHT) of
 FONTSPEC))
                              (FONTEXISTS?
 (create
 FONTSPEC using
 FONTSPEC FSWEIGHT ← 'MEDIUM)
                                     NOCOERCIONS))
                         (AND (EQ 'ITALIC (fetch
 (FONTSPEC FSSLOPE) of
 FONTSPEC))
                              (FONTEXISTS?
 (create
 FONTSPEC using
 FONTSPEC FSSLOPE ← 'REGULAR)
                                     NOCOERCIONS))
                         (AND (EQ 'COMPRESSED (fetch
 (FONTSPEC FSEXPANSION) of
 FONTSPEC))
                              (FONTEXISTS?
 (create
 FONTSPEC using
 FONTSPEC FSEXPANSION ← 'REGULAR)
                                     NOCOERCIONS)))))
      elseif
 (AND (MEMB (IMOD (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC)
                              360)
                        '(90 180 270))
                  (FONTEXISTS?
 (MAKEFONTSPEC
 NIL NIL NIL 0 NIL FONTSPEC)
                         NOCOERCIONS))
        then
 FONTSPEC])

(FONTSAVAILABLE.DISPLAY

  [LAMBDA (FONTSPEC)
                                         (* ; "Edited 27-Aug-2026 21:22 by rmk")

    (LET ((ROTATION (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC)))
         (CL:IF (EQ ROTATION '*)
                (SETQ ROTATION 0))
         (CL:WHEN (NUMBERP ROTATION)
             (SETQ ROTATION (IMOD ROTATION 360))
             (if
 (EQ ROTATION 0)
                 then
 (\SEARCHFONTFILES
 FONTSPEC)
               elseif
 (MEMB ROTATION '(90 180 270))
                 then
 (for
 FS in
 (\SEARCHFONTFILES
 (MAKEFONTSPEC
 NIL NIL NIL 0 NIL FONTSPEC))
                         collect
 (MAKEFONTSPEC
 NIL NIL NIL ROTATION NIL FS))))])
)
(DEFINEQ

(FAKEFACE.CHARSET

  [LAMBDA (FONT CHARSET FAKEFN SOURCEFONT)
                   (* ; "Edited 14-Sep-2026 00:24 by rmk")


                                                             (* ; "Edited 29-Aug-2026 09:27 by rmk")


                                                             (* ; "Edited 17-Apr-2026 08:42 by rmk")


                                                             (* ; "Edited  5-Apr-2026 00:25 by rmk")


                                                             (* ; "Edited  1-Apr-2026 09:10 by rmk")


                                                             (* ; "Edited 31-Mar-2026 00:39 by rmk")


                                                             (* ; "Edited 24-Mar-2026 10:26 by rmk")


                                                             (* ; "Edited 21-Mar-2026 22:31 by rmk")


                                                             (* ; "Edited 15-Mar-2026 14:26 by rmk")


                                                             (* ; "Edited  7-Sep-2025 12:02 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 31-Aug-2025 14:36 by rmk")


                                                             (* ; "Edited 26-Aug-2025 22:35 by rmk")


                                                             (* ; "Edited 18-Aug-2025 09:08 by rmk")


                                                             (* ; "Edited 16-Aug-2025 12:53 by rmk")


    (* ;; "Caller has determined that slug characters in FONT should be replaced by applying FAKEFN to the corresponding SOURCEFACE characters.")


    (* ;; "This assumes that SOURCEFONT has already been faked up.")


    (LET [CHANGED FCSINFO SCSINFO INDIRECT (FONTSPEC (FONTPROP
 FONT 'DEVICESPEC]
         (CL:WHEN (type?
 FONTSPEC SOURCEFONT)
             (SETQ SOURCEFONT (FONTCREATE1
 SOURCEFONT CHARSET)))
         (CL:WHEN (AND (SETQ SCSINFO (\GETCHARSETINFO SOURCEFONT CHARSET))
                       (NOT (fetch
 (CHARSETINFO CSSLUGP) of
 SCSINFO)))
             (if
 (OR (KANJICHARSETP CHARSET)
                     (UNIHANCHARSETP CHARSET))
                 then
 (SETQ FCSINFO (COPYALL SCSINFO))       (* ; "Copy and set up an indirect")

                      (CHARSETPROP FCSINFO 'SOURCE (FONTPROP
 SOURCEFONT 'DEVICESPEC))
                      (\INSTALLCHARSETINFO
 FONT FCSINFO CHARSET)
                      (SETQ CHANGED T)
               elseif
 (AND [NOT (EQUAL FONTSPEC (SETQ INDIRECT (CHARSETPROP SCSINFO 'SOURCE]
                           (EQUAL (fetch
 (FONTSPEC FSFACE) of
 FONTSPEC)
                                  (fetch
 (FONTSPEC FSFACE) of
 INDIRECT))
                           (FONTFILES
 INDIRECT NIL CHARSET))
                 then
 
                      (* ;; "Indirect: font charset adds nothing new, it can inherit the faking of its charset-source:  MODERN MIR for HELVETICA MIR rather than faking from HELVETICA MRR.  Smaller file size?")


                      (SETQ FCSINFO (COPYALL (MEDLEYFONT.GETCHARSET INDIRECT CHARSET)))
                      (\INSTALLCHARSETINFO
 FONT FCSINFO CHARSET)
                      (SETQ CHANGED FCSINFO)
               else
 (SETQ FCSINFO (OR (\GETCHARSETINFO FONT CHARSET)
                                      (\INSTALLCHARSETINFO
 FONT (SLUGCSINFO FONT)
                                             CHARSET)))
                    (for
 CODE from
 (FIRSTCHARSETCODE CHARSET) to
 (LASTCHARSETCODE CHARSET)
                       when
 (SLUGCHARP
 FONT CODE) unless
 (SLUGCHARP
 SOURCEFONT CODE)
                       do
 (\MOVEFONTCHAR
 (\MOVEFONTCHARS.SOURCEDATA
 CODE SOURCEFONT)
                                 CODE FONT)
                          (APPLY* FAKEFN CODE FONT SOURCEFONT)
                          (SETQ CHANGED FCSINFO))
                    (CL:WHEN CHANGED
                        (CHARSETPROP FCSINFO 'SOURCE FONTSPEC)))
             (replace
 (CHARSETINFO CSCOMPLETEP) of
 FCSINFO with
 T)
             CHANGED)])

(MAKEBOLD.CHAR

  [LAMBDA (CODE FONT)
                                        (* ; "Edited 14-Sep-2026 00:25 by rmk")


                                                             (* ; "Edited 22-Aug-2026 09:32 by rmk")


                                                             (* ; "Edited 15-Mar-2026 14:32 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 27-Aug-2025 23:55 by rmk")


                                                             (* ; "Edited 26-Aug-2025 22:36 by rmk")


                                                             (* ; "Edited 17-Jun-2025 08:22 by rmk")


    (* ;; "Replaces the bitmap for CODE in FONT with a bolder one:  overlaps 2 bits to produce the bold effect.  Could be iterated for bigger fonts, but eventually the open spaces would be closed up.")


    (CL:UNLESS (SLUGCHARP
 FONT CODE)
        (LET* [(THINCODE (\CHAR8CODE CODE))
               (CSINFO (\GETCHARSETINFO FONT (\CHARSET CODE)))
               (OLDCHARBITMAP (\GETCHARBITMAP.CSINFO
 THINCODE CSINFO FONT))
               (NEWCHARBITMAP (BITMAPCREATE (ADD1 (fetch
 BITMAPWIDTH of
 OLDCHARBITMAP))
                                     (fetch
 BITMAPHEIGHT of
 OLDCHARBITMAP)))
               (CWIDTH (\FGETWIDTH (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)
                              THINCODE))
               (HEIGHT (IPLUS (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                              (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO]

              (* ;; 

             "Paint in a shifted copy 1 bit over. The new bitmap is 1 bit wider, to keep the margin.")


              (BITBLT OLDCHARBITMAP 0 0 NEWCHARBITMAP 0 0 CWIDTH HEIGHT 'INPUT 'REPLACE)
              (BITBLT OLDCHARBITMAP 0 0 NEWCHARBITMAP 1 0 CWIDTH HEIGHT 'INPUT 'PAINT)
              (\PUTCHARBITMAP.CSINFO
 THINCODE CSINFO NEWCHARBITMAP)))])

(MAKEITALIC.CHAR

  [LAMBDA (CODE FONT)
                                        (* ; "Edited 14-Sep-2026 00:25 by rmk")


                                                             (* ; "Edited 22-Aug-2026 09:32 by rmk")


                                                             (* ; "Edited 15-Mar-2026 14:32 by rmk")


                                                             (* ; "Edited  2-Sep-2025 22:59 by rmk")


                                                             (* ; "Edited 26-Aug-2025 22:36 by rmk")


                                                             (* ; "Edited 18-Jun-2025 14:12 by rmk")


                                                             (* ; "Edited 17-Jun-2025 09:54 by rmk")


    (* ;; "Replaces the bitmap for CODE in FONT with a slanted one:  It shifts rows to the right as a function of their vertical position. ")


    (CL:UNLESS (SLUGCHARP
 FONT CODE)
        (LET* ((THINCODE (\CHAR8CODE CODE))
               (CSINFO (\GETCHARSETINFO FONT (\CHARSET CODE)))
               (OLDBITMAP (\GETCHARBITMAP.CSINFO
 THINCODE CSINFO FONT))
               (NEWBITMAP (BITMAPCREATE (fetch
 BITMAPWIDTH of
 OLDBITMAP)
                                 (fetch
 BITMAPHEIGHT of
 OLDBITMAP)))
               (WIDTH (\FGETWIDTH (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)
                             THINCODE))
               (ASCENT (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO))
               (DESCENT (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO))
               (HEIGHT (IPLUS ASCENT DESCENT)))
              [for
 ROW XX XN YN YX from
 (IMINUS (IQUOTIENT (IPLUS DESCENT 3)
                                                       4)) to
 (IQUOTIENT (IPLUS ASCENT 3)
                                                                     4)
                 do
 (SETQ XN (IMIN WIDTH (IMAX ROW 0)))
                    (SETQ XX (IMIN WIDTH (IMAX (IPLUS WIDTH ROW)
                                               0)))
                    [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES ROW 4]
                    [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (ITIMES (ADD1 ROW)
                                                                4]
                    (CL:WHEN (AND (IGREATERP XX XN)
                                  (IGREATERP YX YN))
                        (BITBLT OLDBITMAP 0 YN NEWBITMAP XN YN (IDIFFERENCE XX XN)
                               (IDIFFERENCE YX YN)
                               'INPUT
                               'REPLACE))]
              (\PUTCHARBITMAP.CSINFO
 THINCODE CSINFO NEWBITMAP)))])
)



(* ; "Bitmap faking")


(DEFINEQ

(\SFROTATECSINFO

  [LAMBDA (FONTSPEC CHARSET)
                                 (* ; "Edited  1-Sep-2026 11:26 by rmk")


                                                             (* ; "Edited 26-Aug-2026 11:31 by rmk")


                                                             (* ; "Edited 22-Aug-2026 17:49 by rmk")


                                                             (* ; "Edited 21-Aug-2026 00:27 by rmk")


                                                             (* ; "Edited 18-Aug-2026 19:41 by rmk")


                                                             (* ; "Edited 29-Jul-2026 15:35 by rmk")


                                                             (* ; "Edited  5-Apr-2026 01:31 by rmk")

                                                             (* gbn "15-Sep-85 14:38")


    (* ;; 

    "Replaces the CSINFO of CHARSET in FONT with one in which all the characters have been rotated.")


    (* ;; "Only non-zero rotations are coerced here, since it isn't worth creating and storing rotated versions of all fonts.  So in that case, it rotates the charset from the otherwise complete font.")


    (LET ((ROTATION (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC))
          (CSINFO (\INSURECHARSETINFO (FONTCREATE
 (create
 FONTSPEC using
 FONTSPEC FSROTATION ← 0))
                         CHARSET))
          NEWCSINFO)
         (SELECTQ ROTATION
             ((90 270) 
                  (SETQ NEWCSINFO (create
 CHARSETINFO using
 CSINFO CHARSETBITMAP ← (

                                                                                \SFROTATECSINFOBITMAP

                                                                                    CSINFO ROTATION)
                                                            YWIDTHS ← (fetch
 (CHARSETINFO WIDTHS)
                                                                         of
 CSINFO)
                                                            OFFSETS ← (\SFROTATECSINFOOFFSETS
 CSINFO
                                                                             ROTATION)
                                                            IMAGEWIDTHS ← (\SFROTATECSINFOIMAGEWIDTHS

                                                                           CSINFO ROTATION)
                                                            WIDTHS ← (\CREATECSINFOELEMENT)
                                                            YIMAGEWIDTHS ← (fetch
 (CHARSETINFO 
                                                                                         IMAGEWIDTHS)
                                                                              of
 CSINFO))))
             (180 (SETQ NEWCSINFO (create
 CHARSETINFO using
 CSINFO CHARSETBITMAP ← (

                                                                                \SFROTATECSINFOBITMAP

                                                                                    CSINFO ROTATION)
                                                            OFFSETS ← (\SFROTATECSINFOOFFSETS
 CSINFO
                                                                             ROTATION)))

                  (* ;; "Do the offsets a second time")


                  (freplace
 (CHARSETINFO OFFSETS) of
 NEWCSINFO with
 (\SFROTATECSINFOOFFSETS
 NEWCSINFO
                                                                           270))
                  (swap
 (ffetch
 (CHARSETINFO CHARSETASCENT) of
 NEWCSINFO)
                        (ffetch
 (CHARSETINFO CHARSETDESCENT) of
 NEWCSINFO)))
             NIL)
         NEWCSINFO])

(\SFROTATECSINFOBITMAP

  [LAMBDA (CSINFO ROTATION)
                                  (* ; "Edited 25-Aug-2026 15:32 by rmk")


                                                             (* ; "Edited 20-Aug-2026 00:46 by rmk")


                                                             (* ; "Edited 22-Sep-87 10:38 by Snow")


(* ;;; "rotate a bitmap either 90 or 270 for fonts.")


    (LET ((CHARBITMAP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO)))
         (CASE ROTATION
             (0 CHARBITMAP)
             (90 (ROTATE-BITMAP-LEFT CHARBITMAP))
             (180 (ROTATE-BITMAP-LEFT (ROTATE-BITMAP-LEFT CHARBITMAP)))
             (270 (ROTATE-BITMAP CHARBITMAP)))])

(\SFROTATECSINFOOFFSETS

  [LAMBDA (CSINFO ROTATION)
                                  (* ; "Edited 10-Sep-2026 23:25 by rmk")


                                                             (* ; "Edited 22-Aug-2026 12:25 by rmk")


                                                             (* ; "Edited 28-Aug-2025 15:10 by rmk")


                                                             (* ; "Edited 24-Aug-2025 11:42 by rmk")

                                                             (* gbn "15-Sep-85 14:36")


    (* ;; "This is the CSINFO before the bitmap has been rotated, which happens in parallel. This is run before the imagewidths are transformed.")


    (if
 (EQ ROTATION 270)
        then
 (for
 CHARCODE (OFFSETS ← (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
                  (WIDTHS ← (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
                  (IMAGEWIDTHS ← (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO))
                  (BITMAPHEIGHT ← (BITMAPWIDTH (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO)))
                  (NEWOFFSETS ← (\CREATECSINFOELEMENT)) from
 0 to
 \MAXTHINCHAR
                do
 [\FSETOFFSET NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT (IPLUS (\FGETOFFSET
                                                                                      OFFSETS 
                                                                                      CHARCODE)
                                                                                     (\FGETWIDTH
                                                                                      IMAGEWIDTHS 
                                                                                      CHARCODE]
                finally
 (RETURN NEWOFFSETS))
      else
 (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO])

(\SFROTATECSINFOIMAGEWIDTHS

  [LAMBDA (CSINFO ROTATION)
                                  (* ; "Edited 10-Sep-2026 23:25 by rmk")


                                                             (* ; "Edited 22-Aug-2026 12:04 by rmk")


    (* ;; "This is the CSINFO before the bitmap has been rotated, which happens in parallel")


    (if
 (MEMB ROTATION '(90 270))
        then
 
             (* ;; "All the characters have the same image width, the original height")


             (for
 CHARCODE (NEWIMAGEWIDTHS ← (\CREATECSINFOELEMENT))
                  (IMAGEWIDTH ← (IPLUS (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                                       (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO))) from
 0
                to
 \MAXTHINCHAR do
 (\FSETOFFSET NEWIMAGEWIDTHS CHARCODE IMAGEWIDTH)
                finally
 (RETURN NEWIMAGEWIDTHS))
      else
 (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO])
)
(DEFINEQ

(\SFMAKECOLOR

  [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL)        (* kbr%: " 6-Feb-86 18:17")


    (* ;; "makes a csinfo that has a character bitmap that is colorized.")


    (PROG (CHARACTERBITMAP COLORCSINFO)
          [COND
             ((IMAGESTREAMP BITSPERPIXEL)
              (OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL)))
              (OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL)))
              (SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL]
          [SETQ BITSPERPIXEL (COND
                                ((NUMBERP BITSPERPIXEL)
                                 BITSPERPIXEL)
                                (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL]
          (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL))
          (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL))
          (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 BWCSINFO)
                                       BACKCOLOR FORECOLOR BITSPERPIXEL))
          (SETQ COLORCSINFO (create
 CHARSETINFO using
 BWCSINFO CHARSETBITMAP ← CHARACTERBITMAP))
          (RETURN COLORCSINFO])
)
(DECLARE%: DONTEVAL@LOAD DOCOPY 

(RPAQ? DISPLAYFONTDIRECTORIES
 (LIST "{MEDLEY}/fonts/medleydisplayfonts"))



(ADDTOVAR DISPLAYCHARSETFNS
 (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET))

(ADDTOVAR DISPLAYFONTEXTENSIONS
 MEDLEYDISPLAYFONT)

(ADDTOVAR DISPLAYFILETEMPLATES
 (MEDLEYFONT (FAMILY SIZE - FACE)))


(RPAQ? DISPLAYFACECOERCIONS

       '[((* * (BOLD * *))
          (* * (MEDIUM * *)))
         ((* * (* ITALIC *))
          (* * (* REGULAR *)))
         ((* * (* * COMPRESSED))
          (* * (* * REGULAR])
)

(RPAQ? \DEFAULTCHARSET
 0)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 FONTCOPY FONTDEVICEPROP)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (6607 16274 (CHARWIDTH 6617 . 7406) (CHARWIDTHY 7408 . 8925) (STRINGWIDTH 8927 . 9964) (
\CHARWIDTH.DISPLAY 9966 . 10381) (\STRINGWIDTH.DISPLAY 10383 . 10811) (\STRINGWIDTH.GENERIC 10813 . 
16272)) (16275 22907 (DEFAULTFONT 16285 . 17570) (FONTCLASS 17572 . 19844) (FONTCLASSUNPARSE 19846 . 
20747) (FONTCLASSCOMPONENT 20749 . 21337) (SETFONTCLASSCOMPONENT 21339 . 21781) (GETFONTCLASSCOMPONENT
 21783 . 22905)) (24355 44086 (FONTCREATE 24365 . 27713) (FONTCREATE1 27715 . 30374) (
FONTCREATE.SLUGFD 30376 . 32633) (\FONT.CHECKARGS1 32635 . 37340) (\FONTCREATE1.NOFN 37342 . 37556) (
FONTFILEP 37558 . 38446) (\READCHARSET 38448 . 43666) (FONTCHARSETS 43668 . 44084)) (44087 52689 (
\FONT.CHECKARGS 44097 . 52372) (\CHARSET.CHECK 52374 . 52687)) (52690 60825 (COERCEFONTSPEC 52700 . 
60136) (COERCEFONTSPEC.TARGETFACE 60138 . 60823)) (63280 68996 (MAKEFONTSPEC 63290 . 65822) (
FONTSPEC.TO.FONTDESCRIPTOR 65824 . 68106) (FONT.CHANGESPEC 68108 . 68994)) (68997 78986 (COMPLETE.FONT
 69007 . 71032) (COMPLETEFONTP 71034 . 71772) (COMPLETE.CHARSET 71774 . 76058) (PRUNESLUGCSINFOS 76060
 . 77371) (MONOSPACEFONTP 77373 . 78984)) (79025 89608 (FONTASCENT 79035 . 79546) (FONTDESCENT 79548
 . 80269) (FONTHEIGHT 80271 . 80783) (FONTPROP 80785 . 88885) (\AVGCHARWIDTH 88887 . 89606)) (93516 
95386 (FONTDEVICEPROP 93526 . 95384)) (95503 96357 (EDITCHAR 95513 . 96355)) (96403 109678 (
GETCHARBITMAP 96413 . 97667) (PUTCHARBITMAP 97669 . 99941) (\GETCHARBITMAP.CSINFO 99943 . 102715) (
\PUTCHARBITMAP.CSINFO 102717 . 109676)) (109679 126586 (MOVECHARBITMAP 109689 . 111583) (MOVEFONTCHARS
 111585 . 116291) (\MOVEFONTCHAR 116293 . 120814) (\MOVEFONTCHARS.SOURCEDATA 120816 . 126584)) (127244
 136534 (SLUGCHARP 127254 . 128301) (\SLUGSETUP 128303 . 130791) (\BUILDSLUGCSINFO 130793 . 134172) (
\MAKESLUGCHAR 134174 . 136532)) (137211 148528 (FONTFILES 137221 . 140450) (FONTSPECFROMFILENAME 
140452 . 145221) (FILENAMEFROMFONTSPEC 145223 . 148526)) (148529 183432 (FONTCOPY 148539 . 155669) (
FONTP 155671 . 155970) (FONTUNPARSE 155972 . 157695) (SETFONTDESCRIPTOR 157697 . 159161) (
\STREAMCHARWIDTH 159163 . 163174) (\COERCECHARSET 163176 . 166783) (\FONTSYMBOL 166785 . 167439) (
\DEVICESYMBOL 167441 . 168225) (\FONTFACE 168227 . 175431) (\FONTFACE.COLOR 175433 . 182215) (
SETFONTCHARENCODING 182217 . 183430)) (183433 202120 (FONTSAVAILABLE 183443 . 188807) (FONTEXISTS? 
188809 . 192974) (\SEARCHFONTFILES 192976 . 196706) (FLUSHFONTCACHE 196708 . 199413) (SORTFONTSPECS 
199415 . 202118)) (202121 208375 (MATCHFONTFACE 202131 . 203206) (MAKEFONTFACE 203208 . 204958) (
FONTFACETOATOM 204960 . 207210) (FONTFACE.STARS 207212 . 208373)) (208722 209214 (\UNITWIDTHSVECTOR 
208732 . 209212)) (227434 229949 (FONTDESCRIPTOR.DEFPRINT 227444 . 229471) (FONTCLASS.DEFPRINT 229473
 . 229947)) (233820 236949 (\CREATEKERNELEMENT 233830 . 234188) (\FSETLEFTKERN 234190 . 235020) (
\FGETLEFTKERN 235022 . 236947)) (236950 249099 (\CREATEFONT 236960 . 240486) (\CREATECHARSET 240488 . 
243595) (\INSTALLCHARSETINFO 243597 . 247370) (\INSTALLCHARSETINFO.CHARENCODING 247372 . 248445) (
\COPYCHARSETINFO 248447 . 249097)) (250012 260727 (\CREATEFONT.DISPLAY 250022 . 253351) (
\CREATECHARSET.DISPLAY 253353 . 257009) (\FONTEXISTS?.DISPLAY 257011 . 260007) (FONTSAVAILABLE.DISPLAY
 260009 . 260725)) (260728 269774 (FAKEFACE.CHARSET 260738 . 265022) (MAKEBOLD.CHAR 265024 . 267100) (
MAKEITALIC.CHAR 267102 . 269772)) (269805 277171 (\SFROTATECSINFO 269815 . 273570) (
\SFROTATECSINFOBITMAP 273572 . 274285) (\SFROTATECSINFOOFFSETS 274287 . 276179) (
\SFROTATECSINFOIMAGEWIDTHS 276181 . 277169)) (277172 278346 (\SFMAKECOLOR 277182 . 278344)))))
STOP