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


(FILECREATED "11-Apr-2026 10:11:29" {WMEDLEY}<sources>FONT.;780
 256466 

      :EDIT-BY rmk

      :CHANGES-TO (FNS \CREATEDISPLAYFONT)

      :PREVIOUS-DATE " 5-Apr-2026 11:55:11" {WMEDLEY}<sources>FONT.;779)


(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)
              (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS COERCEFONTSPEC.MATCH COERCEFONTSPEC.TARGET))
              (MACROS SPREADFONTSPEC)
              (FNS MAKEFONTSPEC FONTSPEC.TO.FONTDESCRIPTOR)
              (FNS COMPLETE.FONT COMPLETEFONTP COMPLETE.CHARSET PRUNESLUGCSINFOS MONOSPACEFONTP))
        (COMS 
              (* ;; "Property extraction:")


              (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH)
              (EXPORT (OPTIMIZERS FONTPROP))
              (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 \MAKESLUGCHAR
                   SLUGCHARP)
              [DECLARE%: DONTCOPY (EXPORT (CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR]
                                                             (* ; "At the end of each csinfo")

              (MACROS UPDATEINFOELEMENT))
        (FNS FONTFILES \FINDFONTFILE \FONTFILENAMES \FONTFILENAME FONTSPECFROMFILENAME)
        (FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \COERCECHARSET 
             \BUILDSLUGCSINFO \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR SETFONTCHARENCODING
             )
        (FNS FONTSAVAILABLE FONTEXISTS? \SEARCHFONTFILES FLUSHFONTCACHE FINDFONTFILES SORTFONTSPECS)
        (FNS MATCHFONTFACE MAKEFONTFACE FONTFACETOATOM FONTFACE.STARS)
        (INITVARS \FONTSINCORE \FONTEXISTS?-CACHE \FONTSAVAILABLEFILECACHE \DEFAULTDEVICEFONTS)
        
        (* ;; "The INITVARS value of MEDLEY-INIT-VARS in MEDLEY dalso includes these entries.  That's because FONT is in the INIT, so these entries would be lost when MEDLEY-INIT-VARS is reinitialized when the Lisp loadup starts")


        (ADDVARS (MEDLEY-INIT-VARS (\FONTEXISTS?-CACHE NIL RESET)
                        (\FONTSAVAILABLEFILECACHE NIL RESET)))
        [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)
        (DECLARE%: DONTCOPY (MACROS FIRSTCHARSETCODE LASTCHARSETCODE))
        (FNS \FONTRESETCHARWIDTHS)
        (MACROS \FGETCHARIMAGEWIDTH)
        
        (* ;; "")


        
        (* ;; "DISPLAY")


        (COMS                                                (* ; 

                                                            "Functions for DISPLAY IMAGESTREAMTYPES ")

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

              (FNS \SFROTATECSINFO \SFROTATEFONTCHARACTERS \SFROTATECSINFOOFFSETS)
              (FNS \SFMAKECOLOR))
        [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DISPLAYFONTDIRECTORIES NIL))
                                                             (* ; "The loadup might have fewer")

               (ADDVARS (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT))
               (INITVARS (DISPLAYFACECOERCIONS '(((* * (BOLD * *))
                                                  (* * (MEDIUM * *)))
                                                 ((* * (* ITALIC *))
                                                  (* * (* REGULAR *)))
                                                 ((* * (* * COMPRESSED))
                                                  (* * (* * REGULAR]
        (INITVARS (\DEFAULTCHARSET 0))
        (LOCALVARS . T)
        (PROP FILETYPE FONT)
        (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 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.")


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

          (SETQ CHARSET (\CHARSET.CHECK
 CHARSET))
          (SETQ FONTSPEC (if
 (AND (type?
 FONTDESCRIPTOR FAMILY)
                                  (NULL SIZE)
                                  (NULL FACE)
                                  (NULL ROTATION)
                                  (NULL DEVICE))
                             then
 
                                  (* ;; "Pretest for a fontdescriptor with no modification--makes it possible to break/trace/change \FONT.CHECKARGS")


                                  FAMILY
                           else
 (\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 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 ((FONTDESC (if
 SOURCEFONT
                        then
 (create
 FONTDESCRIPTOR using
 SOURCEFONT FONTFAMILY ← (fetch
 (FONTSPEC
                                                                                          FSFAMILY)
                                                                                     of
 FONTSPEC)
                                                          FONTSIZE ← (fetch
 (FONTSPEC FSSIZE)
                                                                        of
 FONTSPEC)
                                                          FONTFACE ← (fetch
 (FONTSPEC FSFACE)
                                                                        of
 FONTSPEC)
                                                          ROTATION ← (fetch
 (FONTSPEC FSROTATION)
                                                                        of
 FONTSPEC)
                                                          FONTDEVICE ← (fetch
 (FONTSPEC FSDEVICE)
                                                                          of
 FONTSPEC)
                                                          FONTDEVICESPEC ← FONTSPEC FONTCHARSETVECTOR
                                                          ← NIL)
                      else
 (FONTSPEC.TO.FONTDESCRIPTOR
 FONTSPEC)))
          SLUGCSINFO)
         (replace
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONTDESC with
 (\CREATEFONTCHARSETVECTOR
                                                                       FONTDESC))
         (SETQ SLUGCSINFO (\BUILDSLUGCSINFO
))
         (for
 CS from
 0 to
 (ADD1 (MAXCHARSET FONTDESC)) do
 (\SETCHARSETINFO FONTDESC CS SLUGCSINFO))
         FONTDESC])

(\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 (FONTSPEC CHARSET FONT CHARSETFNS)
                 (* ; "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. ")


    (CL:WHEN (AND FONTSPEC (EQ 0 (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC)))
        (RESETLST
            (for
 FILE STRM CSINFO in
 (FONTFILES
 FONTSPEC 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
 FONTSPEC '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
 FONTSPEC 'ENCODINGFN)
                                                       (FUNCTION NILL))
                                                  FONTSPEC)))
                                (CL:UNLESS (CHARSETPROP CSINFO 'SOURCE)
                                    (CHARSETPROP CSINFO 'SOURCE (create
 FONTSPEC using
 FONTSPEC)))
                                (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 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)
         (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 (fetch
 (FONTSPEC FSFAMILY) of
 FONTX))
                      (SETQ SIZE (OR SIZE (fetch
 (FONTSPEC FSSIZE) of
 FONTX)))
                      (SETQ FACE (OR FACE (fetch
 (FONTSPEC FSFACE) of
 FONTX)))
                      (SETQ ROTATION (OR ROTATION (fetch
 (FONTSPEC FSROTATION) of
 FONTX)))
                      (SETQ DEVICE (OR DEVICE (fetch
 (FONTSPEC FSDEVICE) of
 FONTX)))
                      (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 (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONTX))
                      (CL:UNLESS SIZE
                          (SETQ SIZE (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONTX)))
                      (CL:UNLESS FACE
                          (SETQ FACE (fetch
 (FONTDESCRIPTOR FONTFACE) of
 FONTX)))
                      (CL:UNLESS ROTATION
                          (SETQ ROTATION (fetch
 (FONTDESCRIPTOR ROTATION) of
 FONTX)))
                      (CL:UNLESS DEVICE
                          (SETQ DEVICE (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 FONTX)))])

         (* ;; "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)
                             (IGREATERP 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
 (AND (FIXP ROTATION)
                       (IGEQ ROTATION 0))
           elseif
 (EQ ROTATION '*)
           else
 (\ILLEGAL.ARG ROTATION))
         (CL:WHEN FONTX

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


             (CL:UNLESS (AND (NOT ALWAYSFONTSPEC)
                             (EQ SIZE (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONTX))
                             (EQUAL FACE (fetch
 (FONTDESCRIPTOR FONTFACE) of
 FONTX))
                             (EQ ROTATION (fetch
 (FONTDESCRIPTOR ROTATION) of
 FONTX))
                             (EQ DEVICE (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 FONTX)))
                    (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  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])
    (for
 C RESULT MATCH TARGET MFAMILY MSIZE MFACE MROTATION TFAMILY TSIZE TFACE TROTATION 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 (CAR MATCH)
                                                      ROTATION)
                                               (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)))

                                                      (* ;; 

                                "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]
                                        (MAKEFONTSPEC
 TFAMILY TSIZE TFACE TROTATION DEVICE]
       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 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  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 (FONTP
 BASE)
        (SETQ BASE (FONTPROP
 BASE 'SPEC)))
    (create
 FONTSPEC
           FSFAMILY ← (OR FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 BASE))
           FSSIZE ← (OR SIZE (fetch
 (FONTSPEC FSSIZE) of
 BASE))
           FSFACE ← (OR 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)
                              (* ; "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 ← (fetch
 (FONTSPEC FSFAMILY) of
 FONTSPEC)
                       FONTSIZE ← (fetch
 (FONTSPEC FSSIZE) of
 FONTSPEC)
                       FONTFACE ← (fetch
 (FONTSPEC FSFACE) of
 FONTSPEC)
                       ROTATION ← (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC)
                       FONTDEVICE ← (fetch
 (FONTSPEC FSDEVICE) of
 FONTSPEC)
                       \SFAscent ← 0
                       \SFDescent ← 0
                       \SFHeight ← 0
                       FONTDEVICESPEC ← (create
 FONTSPEC using
 FONTSPEC)
                       MAXCHARSET ← MAXCHARSET
                       FONTCHARSETVECTOR ← NIL)))
         (replace
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONT with
 (\CREATEFONTCHARSETVECTOR FONT))
         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  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
 CODE FONT)
                                 (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 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
 CODE FONT))
                  (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 14-Jul-2025 22:52 by rmk")


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

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

    (ffetch
 \SFAscent of
 (FONTCREATE
 FONTSPEC])

(FONTDESCENT

  [LAMBDA (FONTSPEC)
                                         (* ; "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
 \SFDescent of
 (FONTCREATE
 FONTSPEC])

(FONTHEIGHT

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


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

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

    (fetch
 (FONTDESCRIPTOR \SFHeight) of
 (FONTCREATE
 FONTSPEC])

(FONTPROP

  [LAMBDA (FONT PROP)
                                        (* ; "Edited 28-Mar-2026 07:51 by rmk")


                                                             (* ; "Edited 18-Mar-2026 23:11 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 12-Aug-2025 21:10 by rmk")


                                                             (* ; "Edited 10-Aug-2025 13:28 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 24-May-2025 07:40 by rmk")


                                                             (* ; "Edited 18-May-2025 10:01 by rmk")


                                                             (* ; "Edited 16-May-2025 14:27 by rmk")


                                                             (* ; "Edited 13-May-2025 09:32 by rmk")


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

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

    (SETQ FONT (FONTCREATE
 FONT))
    (SELECTQ PROP
        (HEIGHT (ffetch
 \SFHeight of
 FONT))
        (ASCENT (ffetch
 \SFAscent of
 FONT))
        (DESCENT (ffetch
 \SFDescent of
 FONT))
        (FAMILY (ffetch
 FONTFAMILY of
 FONT))
        (SIZE (ffetch
 FONTSIZE of
 FONT))
        (FACE (COPY (ffetch
 FONTFACE of
 FONT)))
        (WEIGHT (ffetch
 WEIGHT of
 (ffetch
 FONTFACE of
 FONT)))
        (SLOPE (ffetch
 SLOPE of
 (ffetch
 FONTFACE of
 FONT)))
        (EXPANSION (ffetch
 EXPANSION of
 (ffetch
 FONTFACE of
 FONT)))
        (FORECOLOR (ffetch
 FORECOLOR of
 (ffetch
 FONTFACE of
 FONT)))
        (BACKCOLOR (ffetch
 BACKCOLOR of
 (ffetch
 FONTFACE of
 FONT)))
        (ROTATION (ffetch
 ROTATION of
 FONT))
        (DEVICE (ffetch
 FONTDEVICE of
 FONT))
        (CHARENCODING [OR (ffetch
 FONTCHARENCODING of
 FONT)
                          (freplace
 FONTCHARENCODING of
 FONT
                             with
 (if
 (MEMB (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT)
                                            NSFONTFAMILIES)
                                      then
 'XCCS$
                                    elseif
 (MEMB (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT)
                                                 ALTOFONTFAMILIES)
                                      then
 'ALTOTEXT
                                    elseif
 (MEMB (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT)
                                                 MCCSFONTFAMILIES)
                                      then
 'MCCS
                                    else
 (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT])
        (SPEC (create
 FONTSPEC
                     FSFAMILY ← (ffetch
 FONTFAMILY of
 FONT)
                     FSSIZE ← (ffetch
 FONTSIZE of
 FONT)
                     FSFACE ← (COPY (ffetch
 FONTFACE of
 FONT))
                     FSROTATION ← (ffetch
 ROTATION of
 FONT)
                     FSDEVICE ← (ffetch
 FONTDEVICE of
 FONT)))
        (DEVICESPEC                                          (* ; 

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

                    (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                        (COPY (ffetch
 FONTDEVICESPEC of
 FONT))
                        (FONTPROP
 FONT 'SPEC)))
        (DEVICEFAMILY (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                          (fetch
 (FONTSPEC FSFAMILY) of
 (ffetch
 FONTDEVICESPEC of
 FONT))
                          (ffetch
 FONTFAMILY of
 FONT)))
        (DEVICESIZE (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                        (fetch
 (FONTSPEC FSSIZE) of
 (ffetch
 FONTDEVICESPEC of
 FONT))
                        (ffetch
 FONTSIZE of
 FONT)))
        (DEVICEFACE (COPY (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                              (fetch
 (FONTSPEC FSFACE) of
 (ffetch
 FONTDEVICESPEC of
 FONT))
                              (ffetch
 FONTFACE of
 FONT))))
        (DEVICESLOPE (fetch
 SLOPE of
 (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                                         (fetch
 (FONTSPEC FSFACE) of
 (ffetch
 FONTDEVICESPEC
                                                                        of
 FONT))
                                         (ffetch
 FONTFACE of
 FONT))))
        (DEVICEWEIGHT (fetch
 WEIGHT of
 (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                                           (fetch
 (FONTSPEC FSFACE) of
 (ffetch
 FONTDEVICESPEC
                                                                          of
 FONT))
                                           (ffetch
 FONTFACE of
 FONT))))
        (DEVICEEXPANSION 
             (fetch
 EXPANSION of
 (CL:IF (ffetch
 FONTDEVICESPEC of
 FONT)
                                     (fetch
 (FONTSPEC FSFACE) of
 (ffetch
 FONTDEVICESPEC of
 FONT))
                                     (ffetch
 FONTFACE of
 FONT))))
        (SCALE (ffetch
 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
 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])
)
(* "FOLLOWING DEFINITIONS EXPORTED")
(DEFOPTIMIZER FONTPROP
 (&REST ARGS)
                       (SELECTQ (AND (EQ (CAADR ARGS)
                                         'QUOTE)
                                     (CADADR ARGS))
                           (ASCENT `(FONTASCENT
 ,(CAR ARGS)))
                           (DESCENT `(FONTDESCENT
 ,(CAR ARGS)))
                           (HEIGHT `(FONTHEIGHT
 ,(CAR ARGS)))
                           (FONTTOMCCSFN `(fetch
 (FONTDESCRIPTOR FONTTOMCCSFN)
                                             of
 ,(CAR ARGS)))
                           (MAXCHARSET `(MAXCHARSET ,(CAR ARGS)))
                           'IGNOREMACRO))

(* "END EXPORTED DEFINITIONS")

(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 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)))
    (\GETCHARBITMAP.CSINFO
 (\CHAR8CODE CHARCODE)
           (\INSURECHARSETINFO (FONTCREATE
 FONT)
                  (\CHARSET CHARCODE])

(PUTCHARBITMAP

  [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT)
       (* ; "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 \SFAscent) of
 FONT)))
                       (DESCENT (IMAX (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO)
                                      (fetch
 (FONTDESCRIPTOR \SFDescent) of
 FONT]
                      (replace
 (FONTDESCRIPTOR \SFAscent) of
 FONT with
 ASCENT)
                      (replace
 (FONTDESCRIPTOR \SFDescent) of
 FONT with
 DESCENT)
                      (replace
 (FONTDESCRIPTOR \SFHeight) of
 FONT with
 (IPLUS ASCENT DESCENT)))))
         NIL NEWCHARBITMAP])

(\GETCHARBITMAP.CSINFO

  [LAMBDA (CODE CSINFO)
                                      (* ; "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")

                                                             (* ; 

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


    (* ;; "CODE is a thincode")


    (LET (CSBITMAP CBM CWDTH CHGHT)
         (CL:WHEN (SETQ CSBITMAP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
             (SETQ CHGHT (BITMAPHEIGHT CSBITMAP))
             (SETQ CBM (BITMAPCREATE (SETQ CWDTH (if
 (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                                                     then
 (\FGETIMAGEWIDTH (fetch
 (CHARSETINFO 
                                                                                         IMAGEWIDTHS)
                                                                              of
 CSINFO)
                                                                 CODE)
                                                   else
 (\FGETWIDTH (fetch
 (CHARSETINFO WIDTHS)
                                                                       of
 CSINFO)
                                                               CODE)))
                              CHGHT
                              (fetch
 (BITMAP BITMAPBITSPERPIXEL) of
 CSBITMAP)))
             (BITBLT CSBITMAP (\FGETOFFSET (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO)
                                     CODE)
                    0 CBM 0 0 CWDTH CHGHT))
         CBM])

(\PUTCHARBITMAP.CSINFO

  [LAMBDA (THINCODE CSINFO NEWCHARBITMAP NEWCHARDESCENT)
     (* ; "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
 (EQ CHAROFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX))
              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
 SLUGCHARINDEX 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  9-Mar-2026 23:00 by rmk")


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


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


                                                             (* ; "Edited  1-Mar-2026 09:40 by rmk")


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


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


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


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


                                                             (* ; "Edited 25-Aug-2025 09:12 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 23-May-2025 15:02 by rmk")


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


                                                             (* ; "Edited 13-May-2025 08:56 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 SD 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 SD (\MOVEFONTCHARS.SOURCEDATA
 (CADR P)
                                                                DEFAULTSOURCEFONT DCODE DESTFONT))
                                                (CL:WHEN SD
                                                    (push
 PAIRINFO (LIST SD 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  4-Mar-2026 11:03 by rmk")


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


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


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


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


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


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


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


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


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


                                                             (* ; "Edited 17-Jun-2025 19:53 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.")


    (LET ((DCSINFO (\INSURECHARSETINFO DFONT (\CHARSET DCODE)))
          (DTHINCODE (\CHAR8CODE DCODE))
          DESCENT ASCENT TEMP)
         (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))))
         [if
 (GETMULTI SOURCEDATA 'SLUG)
             then
 (\MAKESLUGCHAR
 DTHINCODE DCSINFO)
           else
 (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))
                    (\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 \SFDescent) of
 DFONT)))
             (SETQ ASCENT (IMAX ASCENT (fetch
 (FONTDESCRIPTOR \SFAscent) of
 DFONT)))
             (replace
 (FONTDESCRIPTOR \SFAscent) of
 DFONT with
 ASCENT)
             (replace
 (FONTDESCRIPTOR \SFDescent) of
 DFONT with
 DESCENT)
             (replace
 (FONTDESCRIPTOR \SFHeight) of
 DFONT with
 (IPLUS DESCENT ASCENT)))
         DCSINFO])

(\MOVEFONTCHARS.SOURCEDATA

  [LAMBDA (SOURCE DEFAULTSOURCEFONT DCODE DESTFONT)
          (* ; "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
 (SETQ SFONT (MKLIST SFONT))            (* ; 

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

                      [SETQ SFONT (FONTCREATE
 (create
 FONTSPEC
                                                     FSFAMILY ← (OR (fetch
 (FONTSPEC FSFAMILY)
                                                                       of
 SFONT)
                                                                    (FONTPROP
 DEFAULTSOURCEFONT
                                                                           'FAMILY))
                                                     FSSIZE ← (OR (fetch
 (FONTSPEC FSSIZE)
                                                                     of
 SFONT)
                                                                  (FONTPROP
 DEFAULTSOURCEFONT
                                                                         'SIZE))
                                                     FSFACE ← (OR (fetch
 (FONTSPEC FSFACE)
                                                                     of
 SFONT)
                                                                  (FONTPROP
 DEFAULTSOURCEFONT
                                                                         'FACE))
                                                     FSROTATION ← (OR (fetch
 (FONTSPEC FSROTATION)
                                                                         of
 SFONT)
                                                                      (FONTPROP
 DEFAULTSOURCEFONT
                                                                             'ROTATION))
                                                     FSDEVICE ← (OR (fetch
 (FONTSPEC FSDEVICE)
                                                                       of
 SFONT)
                                                                    (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")

             (CL:WHEN (AND SCODE (SLUGCHARP
 SCODE SFONT))
                    (SETQ SCODE NIL))
             (if
 SCODE
                 then
 (SETQ CSINFO (\INSURECHARSETINFO SFONT (\CHARSET SCODE)))
                      (SETQ CHAR8CODE (\CHAR8CODE SCODE))
               else
 
                    (* ;; "NIL SCODE means replace with slug. We calculate the source-slug information, but that should be ignored later in favor of the slug information from the destination's character set. ")


                    (SETQ CSINFO (\INSURECHARSETINFO SFONT 0))
                    (SETQ CHAR8CODE SLUGCHARINDEX))

             (* ;; "Use (plural) vector field names for UPDATEINFOELEMENT.  Don't know if the CHAR8CODE is useful, but...")


             `((CHAR8CODE \, CHAR8CODE)
               (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)))
               (SLUG \, (NOT SCODE))))])

(\MAKESLUGCHAR

  [LAMBDA (CODE FONT/CSINFO)
                                 (* ; "Edited 30-Aug-2025 23:20 by rmk")


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


    (* ;; "Makes CODE be a slug character in FONT/CSINFO.  If give a FONT, CODE is a true character code, otherwise it is a thincode in the given character set.")


    (LET (CSINFO THINCODE OFFSETS WIDTHS)
         (if
 (type?
 FONTDESCRIPTOR FONT/CSINFO)
             then
 (SETQ CSINFO (\INSURECHARSETINFO FONT/CSINFO (\CHARSET CODE)))
                  (SETQ THINCODE (\CHAR8CODE CODE))
           else
 (SETQ CSINFO FONT/CSINFO)
                (SETQ THINCODE CODE))
         (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
         (CL:UNLESS (AND OFFSETS (EQ (\FGETOFFSET OFFSETS THINCODE)
                                     (\FGETOFFSET OFFSETS SLUGCHARINDEX)))
             (if
 OFFSETS
                 then
 
                      (* ;; "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 (\FGETOFFSET OFFSETS SLUGCHARINDEX))
               else
 (HELP "NONDISPLAY SLUG ?"))
             (\FSETWIDTH (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)
                    THINCODE
                    (\FGETWIDTH (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)
                           SLUGCHARINDEX))
             (\FSETIMAGEWIDTH (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                    THINCODE
                    (\FGETIMAGEWIDTH (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                           SLUGCHARINDEX))
             (CL:WHEN (fetch
 (CHARSETINFO YWIDTHS) of
 CSINFO)
                 (\FSETWIDTH (fetch
 (CHARSETINFO YWIDTHS) of
 CSINFO)
                        THINCODE
                        (\FGETWIDTH (fetch
 (CHARSETINFO YWIDTHS) of
 CSINFO)
                               SLUGCHARINDEX)))
             (CL:WHEN (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                 (SETA (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                       THINCODE
                       (ELT (fetch
 (CHARSETINFO LEFTKERN) of
 CSINFO)
                            SLUGCHARINDEX))))
         CSINFO])

(SLUGCHARP

  [LAMBDA (CODE FONT/CHARSETINFO)
                            (* ; "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")


    (* ;; "True if CODE is currently a slug in FONT or the particular CHARSETINFO.  If we are given a CSINFO, CODE is alread charset-relative.")


    (LET [(CSINFO (CL:IF (type?
 CHARSETINFO FONT/CHARSETINFO)
                      FONT/CHARSETINFO
                      (\GETCHARSETINFO FONT/CHARSETINFO (\CHARSET CODE)))]
         (OR (NULL CSINFO)
             (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)
             (EQ (\FGETOFFSET (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO)
                        (\CHAR8CODE CODE))
                 (\FGETOFFSET (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO)
                        (ADD1 \MAXTHINCHAR])
)
(DECLARE%: DONTCOPY 
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 

(RPAQ SLUGCHARINDEX
 (ADD1 \MAXTHINCHAR))


(CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR)))
)

(* "END EXPORTED DEFINITIONS")

)



(* ; "At the end of each csinfo")


(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

(FONTFILES

  [LAMBDA (FONTSPEC CHARSET DIRLST EXTLST)
                   (* ; "Edited 28-Aug-2025 14:42 by rmk")


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


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


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


                                                             (* ; "Edited  6-Jul-2025 10:40 by rmk")


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


                                                             (* ; "Edited 13-Jun-2025 22:48 by rmk")


                                                             (* ; "Edited  9-Jun-2025 09:57 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, returns a list of the names of files that actually exist somewhere in DIRLST.  Does not validate their contents.")


    (LET (FAMILY SIZE FACE ROTATION DEVICE)
         (SPREADFONTSPEC FONTSPEC)
         [SETQ DIRLST (MKLIST (OR DIRLST (FONTDEVICEPROP
 DEVICE 'FONTDIRECTORIES]
         [SETQ EXTLST (MKLIST (OR EXTLST (FONTDEVICEPROP
 DEVICE 'FONTEXTENSIONS]
         (CL:UNLESS CHARSET (SETQ CHARSET \DEFAULTCHARSET))
         (APPEND (MKLIST (\FINDFONTFILE
 FAMILY SIZE FACE ROTATION DEVICE 'NOCHARSET DIRLST EXTLST))
                (MKLIST (\FINDFONTFILE
 FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST])

(\FINDFONTFILE

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST)

                                                             (* ; "Edited  6-Feb-2026 23:44 by rmk")


                                                             (* ; "Edited 22-Jan-2026 08:54 by rmk")


                                                             (* ; "Edited  3-Dec-2025 23:38 by rmk")


                                                             (* ; "Edited  9-Jun-2025 09:40 by rmk")


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


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


                                                             (* ; "Edited  6-Oct-89 11:18 by bvm")


    (* ;; "This doesn't call FINDFILE because the hyphens separating the family from the face would get confused with the hyphen in TEDIT-STREAM file names.")


    (CL:UNLESS DIRLST
        (SETQ DIRLST (CONS NIL)))

    (* ;; "Find any font file on any directory with any naming convention with any extension.  Note that ROTATION and DEVICE are just place holders.   DEVICE is irrelevant because DIRLST already incorporates the device information.  ")


    (for
 EXT FONTFILE inside
 EXTLST join
 (SETQ FONTFILE (\FONTFILENAME
 FAMILY SIZE FACE EXT CHARSET))
                                         (for
 DIR FOUND inside
 DIRLST
                                            when
 (SETQ FOUND (INFILEP (PACKFILENAME.STRING
                                                                       'DIRECTORY DIR 'BODY FONTFILE)
                                                                    )) collect
 FOUND)
       finally
 

             (* ;; "Backward compatibility for devices that expect a single file")


             (CL:UNLESS (CDR $$VAL)
                 (RETURN (CAR $$VAL)))])

(\FONTFILENAMES

  [LAMBDA (FAMILY SIZE FACE DEVICE EXTENSIONS)
               (* ; "Edited 22-Jan-2026 09:01 by rmk")


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


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

    (APPEND (for
 EXT inside
 EXTENSIONS collect
 (\FONTFILENAME
 FAMILY SIZE FACE EXT 'NOCHARSET))
           (for
 EXT inside
 EXTENSIONS collect
 (\FONTFILENAME
 FAMILY SIZE FACE EXT 0])

(\FONTFILENAME

  [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET)
               (* ; "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:")


    (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.  New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD")


    (* ;; "FAMILY can be a FONTSPEC")


    (DECLARE
 (SPECVARS FAMILY SIZE FACE))
    (SETQ FACE (\FONTFACE
 FACE))                             (* ; "Validate face")

    (LET (ROTATION DEVICE SIZEPATT CSETNAME FACESPEC STARPOS FILENAME)
         (DECLARE
 (SPECVARS ROTATION DEVICE))
         (CL:WHEN (type?
 FONTSPEC FAMILY)
                (SPREADFONTSPEC FAMILY))
         (SETQ SIZEPATT (CL:IF (OR (EQ SIZE '*)
                                   (>= SIZE 10))
                            SIZE
                            (CONCAT "0" SIZE)))
         (SETQ CSETNAME (if
 (FIXP CHARSET)
                            then
 (OCTALSTRING CHARSET)
                          elseif
 (MEMB CHARSET '(NIL NOCHARSET))
                            then
                             (* ; "Don't want the charset indicated")

                                 NIL
                          else
                               (* ; "Somebody made the string already?")

                               CHARSET))

         (* ;; "Fortunately, PACKFILENAME ignores packages")


         (SETQ FILENAME (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF CSETNAME
                                                               (CONCAT "c" CSETNAME ">")
                                                               "")
                                                          FAMILY SIZEPATT "-" (FONTFACETOATOM
 FACE)
                                                          (CL:IF CSETNAME
                                                              (CONCAT "-C" CSETNAME)
                                                              ""))
                               'EXTENSION EXTENSION))

         (* ;; 

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


         (CL:IF (STRPOS "**" 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))
             FILENAME)])

(FONTSPECFROMFILENAME

  [LAMBDA (FONTFILE DEVICE)
                                  (* ; "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 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])
)
(DEFINEQ

(FONTCOPY

  [LAMBDA FONTSPECS
                                          (* ; "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 ERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT)

     (* ;; "Set NOERROR if we find it as a prop, but set ERROR if we find a PROP which is illegal.  Then just return NIL if NOERROR and ERROR, otherwise, call FONTCREATE.")


          [SETQ OLDFONT (FONTCREATE
 (ARG FONTSPECS 1)
                               NIL NIL NIL
                               (CL:WHEN (type?
 FONTCLASS (ARG FONTSPECS 1))
                                   [COND
                                      ((AND (EQ FONTSPECS 2)
                                            (LISTP (ARG FONTSPECS 2)))
                                       (LISTGET (ARG FONTSPECS 2)
                                              'DEVICE))
                                      (T (for
 I from
 2 by
 2 to
 FONTSPECS
                                            do
 (COND
                                                  ((AND (NEQ I FONTSPECS)
                                                        (EQ (ARG FONTSPECS I)
                                                            'DEVICE))
                                                   (RETURN (ARG FONTSPECS (ADD1 I])]
          (SETQ FAMILY (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 OLDFONT))
          (SETQ SIZE (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 OLDFONT))
          (SETQ FACE (fetch
 (FONTDESCRIPTOR FONTFACE) of
 OLDFONT))
          (SETQ ROTATION (fetch
 (FONTDESCRIPTOR ROTATION) of
 OLDFONT))
          (SETQ DEVICE (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 OLDFONT))
          [for
 I VAL from
 2 by
 2 to
 FONTSPECS
             do
 [SETQ VAL (COND
                             ((NOT (EQ I FONTSPECS))
                              (ARG FONTSPECS (ADD1 I]
                (SELECTQ (ARG FONTSPECS I)
                    (FAMILY (SETQ FAMILY VAL))
                    (SIZE (SETQ SIZE VAL))
                    (FACE (SETQ FACE (\FONTFACE
 VAL)))
                    (WEIGHT (SETQ FACE (create
 FONTFACE using
 FACE WEIGHT ← VAL)))
                    (SLOPE (SETQ FACE (create
 FONTFACE using
 FACE SLOPE ← VAL)))
                    (EXPANSION (SETQ FACE (create
 FONTFACE using
 FACE EXPANSION ← VAL)))
                    (BACKCOLOR (SETQ FACE (create
 FONTFACE using
 FACE BACKCOLOR ← VAL)))
                    (FORECOLOR (SETQ FACE (create
 FONTFACE using
 FACE FORECOLOR ← VAL)))
                    (ROTATION (SETQ ROTATION VAL))
                    (DEVICE (SETQ DEVICE VAL))
                    (NOERROR (SETQ NOERROR VAL))
                    (COND
                       [(AND (EQ I 2)
                             (EQ FONTSPECS 2)
                             (LISTP (ARG FONTSPECS 2)))
                        (for
 J on
 (ARG FONTSPECS 2) by
 (CDDR J)
                           do
 (SETQ VAL (CADR J))
                              (SELECTQ (CAR J)
                                  (FAMILY (SETQ FAMILY VAL))
                                  (SIZE (SETQ SIZE VAL))
                                  (FACE (SETQ FACE (\FONTFACE
 VAL)))
                                  (WEIGHT (SETQ FACE (create
 FONTFACE using
 FACE WEIGHT ← VAL)))
                                  (SLOPE (SETQ FACE (create
 FONTFACE using
 FACE SLOPE ← VAL)))
                                  (EXPANSION (SETQ FACE (create
 FONTFACE using
 FACE EXPANSION ← VAL)))
                                  (BACKCOLOR (SETQ FACE (create
 FONTFACE using
 FACE BACKCOLOR ← VAL)))
                                  (FORECOLOR (SETQ FACE (create
 FONTFACE using
 FACE FORECOLOR ← VAL)))
                                  (ROTATION (SETQ ROTATION VAL))
                                  (DEVICE (SETQ DEVICE VAL))
                                  (NOERROR (SETQ NOERROR VAL))
                                  (COND
                                     (NOERROR 

                                            (* ;; 

    "Fell through the SELECTQ, so an illegal PROP.  But, if NOERROR, just note the error, otherwise ")


                                            (SETQ ERROR T))
                                     (T (\ILLEGAL.ARG (CAR J]
                       (T (if
 NOERROR
                              then
 (SETQ ERROR T)
                            else
 (\ILLEGAL.ARG (ARG FONTSPECS I]
          (RETURN (if
 (AND NOERROR ERROR)
                      then
 NIL
                    else
 (FONTCREATE
 FAMILY SIZE FACE ROTATION DEVICE 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 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
 CODE CFONT))
       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])

(\BUILDSLUGCSINFO

  [LAMBDA (FONT SLUGWIDTH)
                                   (* ; "Edited 15-Mar-2026 23:39 by rmk")


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


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


                                                             (* ; "Edited  6-Aug-2025 22:42 by rmk")


                                                             (* ; "Edited  3-Aug-2025 16:11 by rmk")


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


                                                             (* ; "Edited 13-Jun-2025 22:55 by rmk")


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


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


                                                             (* ; "Edited 18-May-2025 21:52 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 \SFHeight) of
 FONT))
          (DESCENT (fetch
 (FONTDESCRIPTOR \SFDescent) 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 from
 0 to
 \MAXTHINCHAR do
 (\FSETWIDTH WIDTHS I SLUGWIDTH))
         (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])

(\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  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 0 really exists--but is that true only for the display?  Cache just the first file")

                (SETQ DEVICE (fetch
 (FONTSPEC FSDEVICE) of
 FONTSPEC))
                [SETQ VAL (OR (CAR (FONTFILES
 (CL:IF (MEMB (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC)
                                                           '(90 270))
                                                  (create
 FONTSPEC using
 FONTSPEC FSROTATION ← 0)
                                                  FONTSPEC)))
                              (APPLY* (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE 'FONTEXISTS?))
                                          (CAR (GETMULTI IMAGESTREAMTYPES DEVICE 'FONTSAVAILABLE))
                                          (FUNCTION NILL))
                                     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 (FONTSPEC)
                                         (* ; "Edited  4-Mar-2026 00:14 by rmk")


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


                                                             (* ; "Edited 25-Aug-2025 10:23 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 and 270.  The caller must do any desired coercions.")


    (LET (FAMILY SIZE FACE ROTATION DEVICE)
         (SPREADFONTSPEC FONTSPEC)
         (for
 FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH ← 1)
            in
 [\FONTFILENAMES
 FAMILY SIZE FACE DEVICE (MKLIST (FONTDEVICEPROP
 DEVICE 
                                                                      'FONTEXTENSIONS]
            do
 (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY))
               (SETQ FILEDIR (CL:IF FILEDIR
                                 (CONCAT ">" FILEDIR ">")
                                 ""))
               (for
 DIR inside
 (FONTDEVICEPROP
 DEVICE 'FONTDIRECTORIES)
                  eachtime
 

                        (* ;; "The file pattern might have an extending subdirectory (C41>) that might not exist, but DIRECTORYNAMEP makes sure that it does.")


                        (SETQ DIR (CONCAT DIR ">" (OR FILEDIR ""))) when
 (DIRECTORYNAMEP DIR)
                  do
 (for
 FONTFILE THISFONT in
 (DIRECTORY DIR) eachtime
 (SETQ THISFONT
                                                                         (FONTSPECFROMFILENAME
 
                                                                                FONTFILE DEVICE)) 

                                                                     (* ;; 

                                                 "make sure the face, size, and family really match.")

 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  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
 (SPEVARS NFLUSHED)
       first
 (CL:WHEN (type?
 FONTSPEC 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)
                                  (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])

(FINDFONTFILES

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


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


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


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


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


                                                             (* ; "Edited 29-Jun-2025 09:08 by rmk")


    (* ;; "GENERIC FUNCTION")


    (* ;; "returns a list of the fontfiles that can be read in for a device.  Rotation is ignored because it is assumed that all devices support 0 90 and 270.")


    (* ;; "The same algorithm as \SEARCHFONTFILES except returns the file names.  This may return several files for the same specification")


    (SPREADFONTSPEC (\FONT.CHECKARGS
 FAMILY SIZE FACE ROTATION DEVICE))
    (CL:UNLESS DIRLST
        [SETQ DIRLST (MKLIST (FONTDEVICEPROP
 DEVICE 'FONTDIRECTORIES])
    (CL:UNLESS EXTLST
        [SETQ EXTLST (MKLIST (FONTDEVICEPROP
 DEVICE 'FONTEXTENSIONS])
    (for
 FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH ← 1)
       IN
 (\FONTFILENAMES
 FAMILY SIZE FACE DEVICE EXTLST)
       do
 (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY))
          (SETQ FILEDIR (CL:IF FILEDIR
                            (CONCAT ">" FILEDIR ">")
                            ""))
          (for
 DIR inside
 DIRLST eachtime
 

                                   (* ;; "The file pattern might have an extending subdirectory (C41>) that might not exist, but DIRECTORYNAMEP makes sure that it does.")


                                       (SETQ DIR (CONCAT DIR ">" (OR FILEDIR "")))
             when
 (DIRECTORYNAMEP DIR)
             do
 (for
 FONTFILE FONTSPEC THISFACE in
 (DIRECTORY DIR) eachtime
 (SETQ FONTSPEC
                                                                             (FONTSPECFROMFILENAME

                                                                              FONTFILE DEVICE))
                                                                         (SETQ THISFACE (CADDR 
                                                                                             FONTSPEC
                                                                                               )) 

                                                                         (* ;; 

                                                 "make sure the face, size, and family really match.")

 when
 (AND (NOT (MEMBER FONTFILE FONTSFOUND))
           (OR (EQ FAMILY '*)
               (EQ FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 FONTSPEC)))
           (OR (EQ SIZE '*)
               (EQ SIZE (fetch
 (FONTSPEC FSSIZE) of
 FONTSPEC)))
           (MATCHFONTFACE
 FACE (fetch
 (FONTSPEC FSFACE) of
 FONTSPEC))) do
 (push
 FONTSFOUND FONTFILE))
               ) finally
 (RETURN (DREVERSE FONTSFOUND])

(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)
                (* ; "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)))
    (CL:UNLESS COLOR
        (SETQ COLOR (COPY (fetch
 (FONTFACE COLOR) of
 BASE))))
    (create
 FONTFACE
           WEIGHT ← WEIGHT
           SLOPE ← SLOPE
           EXPANSION ← EXPANSION
           COLOR ← COLOR])

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



(* ;; 
"The INITVARS value of MEDLEY-INIT-VARS in MEDLEY dalso includes these entries.  That's because FONT is in the INIT, so these entries would be lost when MEDLEY-INIT-VARS is reinitialized when the Lisp loadup starts"
)



(ADDTOVAR MEDLEY-INIT-VARS
 (\FONTEXISTS?-CACHE NIL RESET)
                           (\FONTSAVAILABLEFILECACHE NIL RESET))
(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)
                          (\SFAscent WORD)
                          (\SFDescent WORD)
                          (\SFHeight WORD)
                          (ROTATION 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.")

                          (NIL SIGNEDWORD)                   (* ; "Was FBBDX")

                          (NIL SIGNEDWORD)                   (* ; "Was FBBDY")

                          (FONTTOMCCSFN POINTER)             (* ; "Was \SFLKerns. Function that translates codes in the font's pre-MCCS encoding into MCCS (e.g. Hippo A to Greek,Alpha) ")

                          (NIL POINTER)                      (* ; "Was \SFRWidths")

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

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

                      WIDTHS ← (\CREATECSINFOELEMENT)
                      OFFSETS ← (\CREATECSINFOELEMENT)
                      CHARSETNO ← MAX.SMALLP)

(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)
                                                           1))
                                                (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 SIGNEDWORD 
               SIGNEDWORD 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 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (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)
       '((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)))
       '18)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FONTASCENT
 MACRO
 ((FONTSPEC)
                            (ffetch
 \SFAscent of
 (FONTCREATE
 FONTSPEC))))

(PUTPROPS FONTDESCENT
 MACRO
 ((FONTSPEC)
                             (ffetch
 \SFDescent of
 (FONTCREATE
 FONTSPEC))))

(PUTPROPS FONTHEIGHT
 MACRO
 ((FONTSPEC)
                            (ffetch
 \SFHeight 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).")


                                     (CL:IF (IGREATERP CHARSET (MAXCHARSET FONTDESC))
                                         (SLUGCSINFO FONTDESC)
                                         (OR (\GETCHARSETINFO FONTDESC CHARSET)
                                             (\SETCHARSETINFO FONTDESC CHARSET (\CREATECHARSET
 
                                                                                      CHARSET 
                                                                                      FONTDESC))))])

(PUTPROPS \CREATECSINFOELEMENT
 MACRO
 (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3)
                                                              WORDSPERCELL))))

(PUTPROPS \CREATEFONTCHARSETVECTOR
 MACRO
 (OPENLAMBDA (FONT)

                                           (* ;; "Allocates a block for the character set records, including one extra slot to hold the common slug charsetinfo")


                                           (\ALLOCBLOCK (IPLUS 2 (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 (\GETCHARSETINFO FONT (ADD1 (MAXCHARSET FONT)))
                                (\SETCHARSETINFO FONT (ADD1 (MAXCHARSET FONT))
                                       (\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 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))
                      "/"
                      (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 SIGNEDWORD 
               SIGNEDWORD 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 (SIGNEDBITS . 15))
         (FONTDESCRIPTOR 15 (SIGNEDBITS . 15))
         (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)
       '((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)))
       '18)
(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)
                          (\SFAscent WORD)
                          (\SFDescent WORD)
                          (\SFHeight WORD)
                          (ROTATION WORD)
                          (FONTSLUGWIDTH WORD)
                          (MAXCHARSET WORD)
                          (NIL SIGNEDWORD)
                          (NIL SIGNEDWORD)
                          (FONTTOMCCSFN POINTER)
                          (NIL 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)))
)
(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  8-Jul-2025 22:50 by rmk")


                                                             (* ; "Edited 17-May-2025 09:18 by rmk")

    (CL:UNLESS (ARRAYP (ffetch
 (CHARSETINFO LEFTKERN) of
 CSINFO))
        (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  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)
         (if
 (FONTEXISTS?
 FONTSPEC T)
             then
 [SETQ FN (CAR (GETMULTI IMAGESTREAMTYPES (fetch
 (FONTSPEC FSDEVICE) of
 FONTSPEC)
                                       'FONTCREATE]
                  (if
 FN
                      then
 (APPLY* FN FONTSPEC)
                    elseif
 (MEDLEYFONT.READ.FONT FONTSPEC NIL T)
                    else
 (FONTSPEC.TO.FONTDESCRIPTOR
 FONTSPEC))
           elseif
 [SETQ COERCIONSPEC (CAR (COERCEFONTSPEC
 FONTSPEC 'FONTCOERCIONS]
             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.")


                  (SETQ FONT (\CREATEFONT
 COERCIONSPEC))
                  (replace
 (FONTDESCRIPTOR FONTCOERCEDP) of
 FONT with
 T)
                  (replace
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT with
 (fetch
 (FONTSPEC FSFAMILY)
                                                                       of
 FONTSPEC))
                  (replace
 (FONTDESCRIPTOR FONTSIZE) of
 FONT with
 (fetch
 (FONTSPEC FSSIZE)
                                                                     of
 FONTSPEC))
                  (replace
 (FONTDESCRIPTOR FONTFACE) of
 FONT with
 (fetch
 (FONTSPEC FSFACE)
                                                                     of
 FONTSPEC))
                  (replace
 (FONTDESCRIPTOR ROTATION) of
 FONT with
 (fetch
 (FONTSPEC FSROTATION)
                                                                     of
 FONTSPEC))
                  (replace
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT with
 COERCIONSPEC)
                  FONT
           elseif
 [SETQ COERCIONSPEC (CAR (COERCEFONTSPEC
 FONTSPEC 'FACECOERCIONS]
             then
 (FONTSPEC.TO.FONTDESCRIPTOR
 FONTSPEC (MAXCHARSET (\CREATEFONT
 COERCIONSPEC])

(\CREATECHARSET

  [LAMBDA (CHARSET FONT GETCHARSETFN)
                        (* ; "Edited  4-Apr-2026 14:39 by rmk")


                                                             (* ; "Edited 31-Mar-2026 17:44 by rmk")


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


                                                             (* ; "Edited 27-Mar-2026 07:52 by rmk")


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


                                                             (* ; "Edited 16-Mar-2026 12:35 by rmk")


                                                             (* ; "Edited 13-Mar-2026 10:06 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 31-Aug-2025 14:36 by rmk")


                                                             (* ; "Edited 28-Aug-2025 14:31 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")


    (OR (\GETCHARSETINFO FONT CHARSET)
        (LET ((FONTSPEC (FONTPROP
 FONT 'DEVICESPEC))
              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 FONTSPEC FONT CHARSET)
                            else
 (\READCHARSET
 FONTSPEC CHARSET FONT)))
             (CL:WHEN CSINFO                                 (* ; 

                     "CSINFO could be a slug, an instantiated charset, or NIL meaning uninstantiated")

                 (\INSTALLCHARSETINFO
 FONT CSINFO CHARSET))])

(\INSTALLCHARSETINFO

  [LAMBDA (FONT CSINFO CHARSET)
                              (* ; "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
 \SFAscent of
 FONT with
 (IMAX (fetch
 \SFAscent of
 FONT)
                                          (SIGNED (fetch
 CHARSETASCENT of
 CSINFO)
                                                 16)))
    (replace
 (FONTDESCRIPTOR \SFDescent) of
 FONT with
 (IMAX (fetch
 (FONTDESCRIPTOR \SFDescent)
                                                               of
 FONT)
                                                            (SIGNED (fetch
 (CHARSETINFO 
                                                                                  CHARSETDESCENT)
                                                                       of
 CSINFO)
                                                                   16)))
                                                             (* ; 

                                "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)")

    (replace
 (FONTDESCRIPTOR \SFHeight) of
 FONT with
 (IPLUS (fetch
 (FONTDESCRIPTOR \SFAscent)
                                                               of
 FONT)
                                                            (ffetch
 (FONTDESCRIPTOR \SFDescent)
                                                               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")

        (replace
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT with
 (\FGETWIDTH (fetch
 (CHARSETINFO WIDTHS)
                                                                            of
 CSINFO)
                                                                    SLUGCHARINDEX)))
    (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 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)))
        (replace
 (FONTDESCRIPTOR FONTCHARENCODING) of
 FONT with
 (CHARSETPROP CSINFO 'CSCHARENCODING)))
    ])
)
(DECLARE%: DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(PUTPROPS FIRSTCHARSETCODE
 MACRO
 ((CHARSET)
                                  (LLSH CHARSET 8)))

(PUTPROPS LASTCHARSETCODE
 MACRO
 ((CHARSET)
                                 (LOGOR (LLSH CHARSET 8)
                                        \MAXTHINCHAR)))
)
)
(DEFINEQ

(\FONTRESETCHARWIDTHS

  [LAMBDA (CSINFO FIRSTCHAR LASTCHAR)
                        (* ; "Edited  3-Aug-2025 20:59 by rmk")


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

                                                             (* AJB " 6-Dec-85 14:42")

    (for
 CHARCODE LEFT RIGHT SLUGCHAROFFSET SLUGCHARWIDTH (OFFSETS ← (fetch
 (CHARSETINFO OFFSETS)
                                                                        of
 CSINFO))
         (WIDTHS ← (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)) from
 0 to
 SLUGCHARINDEX
       first
 (SETQ SLUGCHAROFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX))
             (SETQ SLUGCHARWIDTH (IDIFFERENCE (\FGETOFFSET OFFSETS (ADD1 SLUGCHARINDEX))
                                        SLUGCHAROFFSET))
       do
 (SETQ LEFT (\FGETWIDTH OFFSETS CHARCODE))
          (if
 (EQ SLUGCHAROFFSET LEFT)
              then
 (\FSETWIDTH WIDTHS CHARCODE SLUGCHARWIDTH)
            else
 (SETQ RIGHT (\FGETWIDTH OFFSETS (ADD1 CHARCODE)))
                 (if
 (EQ LEFT RIGHT)
                     then
 (\FSETOFFSET OFFSETS CHARCODE SLUGCHAROFFSET)
                          (\FSETWIDTH WIDTHS CHARCODE SLUGCHARWIDTH)
                   else
 (\FSETWIDTH WIDTHS CHARCODE (IDIFFERENCE RIGHT LEFT])
)
(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

(\CREATEDISPLAYFONT

  [LAMBDA (FONTSPEC)
                                         (* ; "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 in at least some character sets.")


    (MEDLEYFONT.READ.FONT FONTSPEC NIL T])

(\CREATECHARSET.DISPLAY

  [LAMBDA (FONTSPEC FONT CHARSET)
                            (* ; "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
 FONTSPEC CHARSET FONT)
      else
 
           (* ;; "Successful transformations must set the CSINFO so that it can be returned.")


           (CL:UNLESS (EQ 0 (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC))
                  (\SFROTATECSINFO
 FONTSPEC FONT 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  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.")


    (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)))))])
)
(DEFINEQ

(FAKEFACE.CHARSET

  [LAMBDA (FONT CHARSET FAKEFN SOURCEFONT)
                   (* ; "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)
                     (CHINESECHARSETP 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 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
 CODE FONT) unless
 (SLUGCHARP
 CODE SOURCEFONT)
                       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 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
 CODE FONT)
        (LET* [(THINCODE (\CHAR8CODE CODE))
               (CSINFO (\GETCHARSETINFO FONT (\CHARSET CODE)))
               (OLDCHARBITMAP (\GETCHARBITMAP.CSINFO
 THINCODE CSINFO))
               (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 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
 CODE FONT)
        (LET* ((THINCODE (\CHAR8CODE CODE))
               (CSINFO (\GETCHARSETINFO FONT (\CHARSET CODE)))
               (OLDBITMAP (\GETCHARBITMAP.CSINFO
 THINCODE CSINFO))
               (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 FONT CHARSET)
                            (* ; "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))
    (if
 (MEMB ROTATION '(90 270))
        then
 
             (* ;; "WHAT ABOUT 180 ?")


             (* ;; "CAN THE RECURSIVE CALL BE REPLACED BY \READCHARSET ??")


             (CL:WHEN (SETQ CSINFO (\CREATECHARSET.DISPLAY
 (create
 FONTSPEC
                                                              using
 FONTSPEC FSROTATION ← 0)
                                          FONT CHARSET))
                 (\SETCHARSETINFO FONT CHARSET (create
 CHARSETINFO using
 CSINFO CHARSETBITMAP ←
                                                                         (\SFROTATEFONTCHARACTERS

                                                                          (fetch
 (CHARSETINFO 
                                                                                        CHARSETBITMAP
                                                                                        )
                                                                             of
 CSINFO)
                                                                          ROTATION)
                                                                         OFFSETS ← (

                                                                               \SFROTATECSINFOOFFSETS

                                                                                    CSINFO ROTATION))
                        ))
      else
 (ERROR "Only rotations of 0, 90 and 270 are allowed" ROTATION])

(\SFROTATEFONTCHARACTERS

  [LAMBDA (CHARBITMAP ROTATION)
                              (* ; "Edited 22-Sep-87 10:38 by Snow")


(* ;;; "rotate a bitmap either 90 or 270 for fonts.")


    (CASE ROTATION
        (0 CHARBITMAP)
        (90 (ROTATE-BITMAP-LEFT CHARBITMAP))
        (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP)))
        (270 (ROTATE-BITMAP CHARBITMAP)))])

(\SFROTATECSINFOOFFSETS

  [LAMBDA (CSINFO ROTATION)
                                  (* ; "Edited 28-Aug-2025 15:10 by rmk")


                                                             (* ; "Edited 24-Aug-2025 11:42 by rmk")

                                                             (* gbn "15-Sep-85 14:36")

                                                             (* ; 

                                       "adjusts offsets in case where rotation turned things around.")

    (COND
       ((EQ ROTATION 270)
        (PROG ((OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
               (WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
               (BITMAPHEIGHT (BITMAPWIDTH (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO)))
               NEWOFFSETS)
              (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
              [for
 CHARCODE from
 0 to
 \MAXTHINCHAR do
 (\FSETOFFSET NEWOFFSETS CHARCODE
                                                             (IDIFFERENCE BITMAPHEIGHT
                                                                    (IPLUS (\FGETOFFSET OFFSETS 
                                                                                  CHARCODE)
                                                                           (\FGETWIDTH WIDTHS 
                                                                                  CHARCODE]
                                                             (* ; 

                                           "may be some problem with dummy character representation.")

              (RETURN NEWOFFSETS)))
       (T (fetch
 (CHARSETINFO OFFSETS) 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
 NIL)


(ADDTOVAR DISPLAYFONTEXTENSIONS
 MEDLEYDISPLAYFONT)


(RPAQ? DISPLAYFACECOERCIONS

       '[((* * (BOLD * *))
          (* * (MEDIUM * *)))
         ((* * (* ITALIC *))
          (* * (* REGULAR *)))
         ((* * (* * COMPRESSED))
          (* * (* * REGULAR])
)

(RPAQ? \DEFAULTCHARSET
 0)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(PUTPROPS FONT
 FILETYPE
 :FAKE-COMPILE-FILE)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 FONTCOPY FONTDEVICEPROP)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (6426 16093 (CHARWIDTH 6436 . 7225) (CHARWIDTHY 7227 . 8744) (STRINGWIDTH 8746 . 9783) (
\CHARWIDTH.DISPLAY 9785 . 10200) (\STRINGWIDTH.DISPLAY 10202 . 10630) (\STRINGWIDTH.GENERIC 10632 . 
16091)) (16094 22726 (DEFAULTFONT 16104 . 17389) (FONTCLASS 17391 . 19663) (FONTCLASSUNPARSE 19665 . 
20566) (FONTCLASSCOMPONENT 20568 . 21156) (SETFONTCLASSCOMPONENT 21158 . 21600) (GETFONTCLASSCOMPONENT
 21602 . 22724)) (24174 43430 (FONTCREATE 24184 . 27429) (FONTCREATE1 27431 . 30090) (
FONTCREATE.SLUGFD 30092 . 32656) (\FONT.CHECKARGS1 32658 . 37363) (\FONTCREATE1.NOFN 37365 . 37579) (
FONTFILEP 37581 . 38469) (\READCHARSET 38471 . 43010) (FONTCHARSETS 43012 . 43428)) (43431 50507 (
\FONT.CHECKARGS 43441 . 50190) (\CHARSET.CHECK 50192 . 50505)) (50508 56868 (COERCEFONTSPEC 50518 . 
56179) (COERCEFONTSPEC.TARGETFACE 56181 . 56866)) (59063 62042 (MAKEFONTSPEC 59073 . 60410) (
FONTSPEC.TO.FONTDESCRIPTOR 60412 . 62040)) (62043 71705 (COMPLETE.FONT 62053 . 64078) (COMPLETEFONTP 
64080 . 64818) (COMPLETE.CHARSET 64820 . 68886) (PRUNESLUGCSINFOS 68888 . 70199) (MONOSPACEFONTP 70201
 . 71703)) (71744 81312 (FONTASCENT 71754 . 72138) (FONTDESCENT 72140 . 72625) (FONTHEIGHT 72627 . 
73029) (FONTPROP 73031 . 80589) (\AVGCHARWIDTH 80591 . 81310)) (82035 83905 (FONTDEVICEPROP 82045 . 
83903)) (84022 84876 (EDITCHAR 84032 . 84874)) (84922 97112 (GETCHARBITMAP 84932 . 86056) (
PUTCHARBITMAP 86058 . 88216) (\GETCHARBITMAP.CSINFO 88218 . 90234) (\PUTCHARBITMAP.CSINFO 90236 . 
97110)) (97113 119454 (MOVECHARBITMAP 97123 . 99017) (MOVEFONTCHARS 99019 . 104169) (\MOVEFONTCHAR 
104171 . 109043) (\MOVEFONTCHARS.SOURCEDATA 109045 . 115800) (\MAKESLUGCHAR 115802 . 118337) (
SLUGCHARP 118339 . 119452)) (120369 132218 (FONTFILES 120379 . 122212) (\FINDFONTFILE 122214 . 124191)
 (\FONTFILENAMES 124193 . 124753) (\FONTFILENAME 124755 . 127666) (FONTSPECFROMFILENAME 127668 . 
132216)) (132219 168552 (FONTCOPY 132229 . 137312) (FONTP 137314 . 137613) (FONTUNPARSE 137615 . 
139338) (SETFONTDESCRIPTOR 139340 . 140804) (\STREAMCHARWIDTH 140806 . 144817) (\COERCECHARSET 144819
 . 148208) (\BUILDSLUGCSINFO 148210 . 151903) (\FONTSYMBOL 151905 . 152559) (\DEVICESYMBOL 152561 . 
153345) (\FONTFACE 153347 . 160551) (\FONTFACE.COLOR 160553 . 167335) (SETFONTCHARENCODING 167337 . 
168550)) (168553 189124 (FONTSAVAILABLE 168563 . 173927) (FONTEXISTS? 173929 . 177737) (
\SEARCHFONTFILES 177739 . 180953) (FLUSHFONTCACHE 180955 . 183199) (FINDFONTFILES 183201 . 186417) (
SORTFONTSPECS 186419 . 189122)) (189125 194663 (MATCHFONTFACE 189135 . 190210) (MAKEFONTFACE 190212 . 
191246) (FONTFACETOATOM 191248 . 193498) (FONTFACE.STARS 193500 . 194661)) (195294 195786 (
\UNITWIDTHSVECTOR 195304 . 195784)) (212590 214657 (FONTDESCRIPTOR.DEFPRINT 212600 . 214179) (
FONTCLASS.DEFPRINT 214181 . 214655)) (218570 221360 (\CREATEKERNELEMENT 218580 . 218938) (
\FSETLEFTKERN 218940 . 219431) (\FGETLEFTKERN 219433 . 221358)) (221361 232242 (\CREATEFONT 221371 . 
224814) (\CREATECHARSET 224816 . 227993) (\INSTALLCHARSETINFO 227995 . 231329) (
\INSTALLCHARSETINFO.CHARENCODING 231331 . 232240)) (232564 233932 (\FONTRESETCHARWIDTHS 232574 . 
233930)) (234455 242071 (\CREATEDISPLAYFONT 234465 . 236230) (\CREATECHARSET.DISPLAY 236232 . 239656) 
(\FONTEXISTS?.DISPLAY 239658 . 242069)) (242072 250342 (FAKEFACE.CHARSET 242082 . 246036) (
MAKEBOLD.CHAR 246038 . 247891) (MAKEITALIC.CHAR 247893 . 250340)) (250373 254628 (\SFROTATECSINFO 
250383 . 252525) (\SFROTATEFONTCHARACTERS 252527 . 252911) (\SFROTATECSINFOOFFSETS 252913 . 254626)) (
254629 255803 (\SFMAKECOLOR 254639 . 255801)))))
STOP