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


(FILECREATED "26-Feb-2026 17:01:47" {WMEDLEY}<sources>FONT.;677
 278005 

      :EDIT-BY rmk

      :CHANGES-TO (FNS MOVEFONTCHARS)

      :PREVIOUS-DATE "20-Feb-2026 12:54:44" {WMEDLEY}<sources>FONT.;675)


(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))
        (VARS NSFONTFAMILIES ALTOFONTFAMILIES)
        (INITVARS MCCSFONTFAMILIES)
        (COMS 
              (* ;; "Creation: ")


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


              (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH)
              (EXPORT (OPTIMIZERS FONTPROP))
              (FNS 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.DISPLAY)
              (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)
        (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)
                                   (MACROS \GETCHARSETINFO \SETCHARSETINFO \INSURECHARSETINFO 
                                          \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR CHARSETPROP)
                                   (PROP ARGNAMES CHARSETPROP)
                                   (CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR))
                                          (SLUGCHARSET (ADD1 \MAXCHARSET]
               (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)
        (LOCALVARS . T)
        (PROP FILETYPE FONT)
        
        (* ;; "")


        
        (* ;; "DISPLAY")


        (COMS                                                (* ; 

                                                            "Functions for DISPLAY IMAGESTREAMTYPES ")

              (FNS \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY \FONTEXISTS?.DISPLAY))
        (FNS STRIKEFONT.FILEP STRIKEFONT.GETCHARSET WRITESTRIKEFONTFILE STRIKECSINFO)
        (COMS                                                (* ; "Bitmap faking")

              (FNS MAKEBOLD.CHARSET MAKEBOLD.CHAR MAKEITALIC.CHARSET MAKEITALIC.CHAR \SFMAKEBOLD 
                   \SFMAKEITALIC)
              (FNS \SFMAKEROTATEDFONT \SFROTATECSINFO \SFROTATEFONTCHARACTERS \SFROTATECSINFOOFFSETS)
              (FNS \SFMAKECOLOR))
        (EXPORT (GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYCHARCOERCIONS 
                       DISPLAYFONTCOERCIONS DISPLAYCHARSETFNS))
        (DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DISPLAYFONTDIRECTORIES NIL))
               (ADDVARS (DISPLAYCHARSETFNS (STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET)))
                                                             (* ; "The loadup might have fewer")

               (ADDVARS (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT DISPLAYFONT)))
        (INITVARS [DISPLAYFONTCOERCIONS '(((HELVETICA (<= * 2))
                                           (HELVETICA 4))
                                          ((MODERN (<= 15 * 16))
                                           (* 14))
                                          ((MODERN (<= 17 * 21))
                                           (* 18))
                                          ((MODERN (<= 22 * 28))
                                           (* 24))
                                          ((MODERN (<= 29 * 33))
                                           (* 30))
                                          ((MODERN (<= 34 * 40))
                                           (* 36))
                                          ((MODERN (<= 41 * 65))
                                           (* 48))
                                          ((MODERN (<= 66 *))
                                           (* 72))
                                          ((PALATINO 9)
                                           (PALATINO 12))
                                          ((PALATINO (<= * 8))
                                           (PALATINO 10))
                                          ((TITAN (<= * 9)
                                                  BOLD)
                                           (MODERN 10))
                                          ((TITAN (<= * 9)
                                                  ITALIC)
                                           (MODERN 10))
                                          ((TITAN (<= * 9))
                                           (TITAN 10))
                                          (LPT AMTEX]
               [DISPLAYCHARCOERCIONS '((GACHA TERMINAL)
                                       (MODERN CLASSIC)
                                       (TIMESROMAN CLASSIC)
                                       (HELVETICA MODERN)
                                       (TERMINAL MODERN)
                                       (HIPPO CLASSIC)
                                       (CYRILLIC CLASSIC)
                                       (MATH CLASSIC)
                                       (SIGMA MODERN)
                                       (SYMBOL MODERN)
                                       (TITAN CLASSIC)
                                       (PALATINO CLASSIC)
                                       (OPTIMA MODERN)
                                       (BOLDPS CLASSIC)
                                       (PCTERMINAL CLASSIC)
                                       (TITANLEGAL CLASSIC]
               (\DEFAULTCHARSET 0))
        
        (* ;; "")


        
        (* ;; "Defunct coercions? Mapping for DOS filenames, Adobe equivalences")


        [COMS (INITVARS [ADOBEDISPLAYFONTCOERCIONS '(((HELVETICABLACK 16)
                                                      (HELVETICABLACK 18))
                                                     ((SYMBOL)
                                                      (ADOBESYMBOL))
                                                     ((SYMBOL 11)
                                                      (ADOBESYMBOL 10))
                                                     ((AVANTGARDE-DEMI)
                                                      (AVANTGARDE))
                                                     ((AVANTGARDE-BOOK)
                                                      (AVANTGARDE))
                                                     ((NEWCENTURYSCHLBK)
                                                      (CENTURYSCHOOLBOOK))
                                                     ((BOOKMAN-LIGHT)
                                                      (BOOKMAN))
                                                     ((BOOKMAN-DEMI)
                                                      (BOOKMAN))
                                                     ((HELVETICA-NARROW)
                                                      (HELVETICANARROW))
                                                     ((HELVETICA 24)
                                                      (ADOBEHELVETICA 24]
                     (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR)
                                                (HELVETICA . HV)
                                                (TIMESROMAND . TD)
                                                (HELVETICAD . HD)
                                                (MODERN . MD)
                                                (CLASSIC . CL)
                                                (GACHA . GC)
                                                (TITAN . TI)
                                                (LETTERGOTHIC . LG)
                                                (BOLDPS . BP)
                                                (TERMINAL . TM)
                                                (CLASSICTHIN . CT)
                                                (HIPPO . HP)
                                                (LOGO . LG)
                                                (MATH . MA)
                                                (OLDENGLISH . OE)
                                                (SYMBOL . SY]
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
                                                                             (NLAML)
                                                                             (LAMA FONTCOPY])



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

(RPAQQ NSFONTFAMILIES
 (CLASSIC MODERN TERMINAL OPTIMA TITAN BOLDPS PCTERMINAL))

(RPAQQ ALTOFONTFAMILIES
 (TIMESROMAN TIMESROMAND HELVETICA HELVETICAD CLARITY BRAVOX TONTO CREAM 
                               OLDENGLISH))

(RPAQ? MCCSFONTFAMILIES
 NIL)



(* ;; "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 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
 (AND (FONTEXISTS?
 FONTSPEC)
                                (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 (FAMILY SIZE FACE ROTATION DEVICE CHARSET)
         (* ; "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")


    (* ;; "For the REMEMBER case,  dummy font descriptor completely fillled with a slug charsetinfo")


    (LET* ([FONTDESC (create
 FONTDESCRIPTOR
                            FONTDEVICE ← DEVICE
                            FONTFAMILY ← FAMILY
                            FONTSIZE ← SIZE
                            FONTFACE ← FACE
                            \SFAscent ← SIZE
                            \SFDescent ← 0
                            \SFHeight ← SIZE
                            ROTATION ← ROTATION
                            FONTDEVICESPEC ← (LIST FAMILY SIZE FACE ROTATION DEVICE)
                            FONTCHARENCODING ← 'MCCS
                            FONTAVGCHARWIDTH ← (FIXR (FTIMES SIZE 0.75]
           (SLUGCSINFO (\BUILDSLUGCSINFO
 FONTDESC)))
          (if
 CHARSET
              then
 (\SETCHARSETINFO FONTDESC CHARSET SLUGCSINFO)
            else
 (for
 CS from
 0 to
 (ADD1 \MAXCHARSET) 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)
                            (* ; "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 FAMILY in
 [OR (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")


                                    (SETQ FAMILY (fetch
 (FONTSPEC FSFAMILY) of
 FONTSPEC))
                                    (CHARSETPROP CSINFO 'CSCHARENCODING
                                           (if
 (OR (NEQ CHARSET 0)
                                                   (MEMB FAMILY MCCSFONTFAMILIES))
                                               then
 'MCCS
                                             elseif
 (MEMB FAMILY NSFONTFAMILIES)
                                               then
 'XCCS$
                                             elseif
 (MEMB FAMILY ALTOFONTFAMILIES)
                                               then
 'ALTOTEXT
                                             else
 FAMILY)))

                                (* ;; "Remember the file that this basic charset information came from, before any character coercions, for informational purposes.  Path and version won't be valid if sysout moves, or if PSEUDOFILENAME's aren't aligned.  Don't want files to be new atoms, for loadup.")


                                (CHARSETPROP CSINFO 'FILE (MKSTRING (PSEUDOFILENAME FILE)))
                                (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)))))])
)
(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)
                           (* ; "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
 (SETQ COERCED (if
 (FONTEXISTS?
 COERCED NIL NIL NIL NIL T)
                              then
 (CONS COERCED)
                            elseif
 ALL
                              then
 (COERCEFONTSPEC
 COERCED COERCIONS T)
                            elseif
 (SETQ COERCED (COERCEFONTSPEC
 COERCED COERCIONS))
                              then
 (CONS COERCED))) 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
 COERCED
                                                          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])
)
(DEFINEQ

(COMPLETE.FONT

  [LAMBDA (FONTSPEC EVENIFCOMPLETE)
                          (* ; "Edited  7-Oct-2025 17:01 by rmk")


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


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


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


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


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


                                                             (* ; "Edited 12-Jun-2025 22:06 by rmk")


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


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


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


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


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


    (* ;; "This returns a FONTDESCRIPTOR for FONTSPEC that is complete with respect to all known character sources.  A caller that wants to insure that only files sources are considered should reset \FONTSINCORE and \FONTEXISTS?-CACHE. If reset, we still get the benefit of previous completions/coercions in this run if medleyfont files have been created for them.")


    (LET ((FONT (FONTCREATE
 FONTSPEC)))
         (SETQ FONTSPEC (FONTPROP
 FONT 'SPEC))               (* ; "Normalized version")

         (CL:WHEN (OR EVENIFCOMPLETE (NOT (fetch
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT)))
             (for
 CHARSET CSINFO from
 0 to
 \MAXCHARSET
                do
 (if
 (SETQ CSINFO (\GETCHARSETINFO FONT CHARSET))
                       then
 (CL:WHEN EVENIFCOMPLETE
                                (replace
 (CHARSETINFO CSCOMPLETEP) of
 CSINFO with
 NIL))
                     else
 (SETQ CSINFO (\CREATECHARSET
 CHARSET FONT)))
                   (COMPLETE.CHARSET
 CSINFO FONTSPEC CHARSET FONT))
             (replace
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT with
 T))
         (PRUNESLUGCSINFOS
 FONT)
         FONT])

(COMPLETEFONTP

  [LAMBDA (FONT)
                                             (* ; "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 always
 (\GETCHARSETINFO FONT CS])

(COMPLETE.CHARSET

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


    (* ;; "CSINFO has some characters for this charset in FONT, but others may fill in from the FONTSPEC of 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.")


    (\SETCHARSETINFO FONT CHARSET CSINFO)
    (CL:UNLESS (fetch
 (CHARSETINFO CSCOMPLETEP) of
 CSINFO)
        (for
 CODE SOURCEFONT from
 (FIRSTCHARSETCODE CHARSET) to
 (LASTCHARSETCODE CHARSET)
           when
 [AND (SLUGCHARP.DISPLAY
 CODE FONT)
                     (SETQ SOURCEFONT (CAR (\COERCECHARSET
 FONTSPEC CHARSET CODE]
           collect
 (LIST (LIST CODE SOURCEFONT)
                         CODE) finally
 (CL:WHEN $$VAL        (* ; "The source is now here")

                                           (MOVEFONTCHARS
 $$VAL FONT)
                                           (CHARSETPROP CSINFO 'SOURCE FONTSPEC)))
        (CL:WHEN (FONTDEVICEPROP
 FONT 'CHARCOERCIONS)        (* ; 

                                                             "Maybe coercions are just being delayed")

            (replace
 (CHARSETINFO CSCOMPLETEP) of
 CSINFO with
 T)))
    CSINFO])

(PRUNESLUGCSINFOS

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


    (SETQ FONT (FONTCREATE
 FONT))
    (for
 CS CSINFO from
 0 to
 \MAXCHARSET when
 (AND (SETQ CSINFO (\GETCHARSETINFO FONT CS))
                                                   (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO))
       do
 (\SETCHARSETINFO FONT CS NIL))
    FONT])

(MONOSPACEFONTP

  [LAMBDA (FONT CODES SKIPSLUGS RETURNVARIABLES)
             (* ; "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.DISPLAY
 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 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 (CSVECTOR ← (ffetch
 FONTCHARSETVECTOR of
 FONT)) from
 0 to
 
                                                                                          \MAXCHARSET
                     eachtime
 (SETQ CSINFO (\GETBASEPTR CSVECTOR (UNFOLD CS 2))) when
 CSINFO
                     unless
 (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO) collect
 CS))
        (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)))
                           'IGNOREMACRO))

(* "END EXPORTED DEFINITIONS")

(DEFINEQ

(FONTDEVICEPROP

  [LAMBDA (FONTDEVICE PROP)
                                  (* ; "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)...)")


    [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))
    (LET ((VAR (PACK* FONTDEVICE PROP)))
         (CL:WHEN (BOUNDP VAR)
                (GETATOMVAL VAR])
)



(* ; "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 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 a list of (SOURCE DEST) pairs where each source  is a list of the form (schar/code sfont) or just a character, and each DEST is a destination character/code. If a pair is a character code C, it is treated as (C C).")


    (* ;; "If a pair does not contain its own source font, then information is extracted from the DEFAULTSOURCEFONT.  If the DEFAULTSOURCEFONT is not provided, thenSFONT 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))
        [if
 (HARRAYP PAIRS)
            then
 
                 (* ;; "E.g. *UNICODETOMCCS*")


                 [MAPHASH PAIRS (FUNCTION (LAMBDA (VAL KEY)
                                            (CL:UNLESS (EQ VAL KEY)
                                                (\MOVEFONTCHAR
 (\MOVEFONTCHARS.SOURCEDATA
 KEY 
                                                                      DEFAULTSOURCEFONT)
                                                       VAL DESTFONT))]
          else
 (LET (PAIRINFO)

                    (* ;; "Fix/check arguments, and expand out the information for all the source characters, so there is no toe-stepping if there are overlaps.")


                    (SETQ PAIRINFO (for
 P S DCODE in
 PAIRS collect
 (CL:WHEN (SMALLP P)
                                                                       (SETQ P (LIST P P)))
                                                                 (SETQ DCODE (CADR P))
                                                                 (CL:UNLESS (CHARCODEP DCODE)
                                                                     (SETQ DCODE (CHARCODE.DECODE
                                                                                  DCODE)))
                                                                 (\INSURECHARSETINFO DESTFONT
                                                                        (\CHARSET DCODE))
                                                                 (LIST (\MOVEFONTCHARS.SOURCEDATA

                                                                        (CAR P)
                                                                        DEFAULTSOURCEFONT)
                                                                       DCODE)))

                    (* ;; "Install source character information into the destination font.  ")


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

(\MOVEFONTCHAR

  [LAMBDA (SOURCEDATA DCODE DFONT)
                           (* ; "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)))
                    (replace
 (CHARSETINFO CSSLUGP) of
 DCSINFO with
 NIL)
                    (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)
                         (* ; "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).")


    (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:WHEN (AND SCODE (SLUGCHARP.DISPLAY
 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.DISPLAY

  [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%: 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 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.DISPLAY

                                                                               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 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
                             CSCOMPLETEP ← 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 (FAMILY SIZE FACE ROTATION DEVICE NOCOERCIONS)
     (* ; "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 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))
    (LET ((FONTSPEC (\FONT.CHECKARGS
 FAMILY SIZE FACE ROTATION DEVICE T))
          VAL DEVICE)

         (* ;; "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.  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)))
                (if
 VAL
                    then
 (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL 'SASSOC)
                  elseif
 [AND (NOT NOCOERCIONS)
                              (SETQ VAL (COERCEFONTSPEC
 FONTSPEC (FONTDEVICEPROP
 DEVICE 
                                                                        'FONTCOERCIONS]
                    then
 
                         (* ;; "It's coerceable...even though coercion may not yet be instantiated")


                         (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL 'SASSOC)
                  else
 (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC 'NO 'SASSOC)
                       NIL])

(\SEARCHFONTFILES

  [LAMBDA (FONTSPEC)
                                         (* ; "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 (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 (TYPE FAMILY SIZE FACE ROTATION DEVICE)
            (* ; "Edited 27-Nov-2025 10:02 by rmk")


                                                             (* ; "Edited 22-Nov-2025 15:52 by rmk")


    (* ;; 

    "Removes information for font(s) from the TYPE cache, if TYPE is NIL, all caches are flushed")


    (CL:UNLESS TYPE
        (SETQ TYPE '(:INCORE :EXISTS :AVAILABLE)))
    (if
 (LISTP TYPE)
        then
 (for
 TY in
 TYPE collect
 (FLUSHFONTCACHE
 TY FAMILY SIZE FACE ROTATION DEVICE))
      else
 
           (* ;; "If all NILs, don't want the default font")


           (SPREADFONTSPEC (\FONT.CHECKARGS
 (OR FAMILY '*)
                                  (OR SIZE '*)
                                  (OR FACE '*)
                                  (OR ROTATION '*)
                                  (OR DEVICE '*)
                                  T))
           (LET ((NFLUSHED 0)
                 FONTX)
                (DECLARE
 (SPECVARS NFLUSHED))
                [MAPMULTI (SELECTQ TYPE
                              (:INCORE \FONTSINCORE)
                              (:EXISTS \FONTEXISTS?-CACHE)
                              (:AVAILABLE \FONTSAVAILABLEFILECACHE)
                              (\ILLEGAL.ARG TYPE))
                       (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 TYPE 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 30-Aug-2025 15:12 by rmk")


    (* ;; 

    "Sort FONTSPECS by alphabetically by family, then by smaller sizes, then by medium/regular faces")


    (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 (fetch
 (FONTSPEC FSFACE) of
 FS1))
                                                     (FACE2 (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 21-Jun-2025 11:57 by rmk")


    (* ;; "Does FACE match a PATTERN that may contain stars?")


    (OR (EQ PATTERN '*)
        (EQUAL PATTERN FACE)
        (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])
)

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

                          (NIL SIGNEDWORD)                   (* ; 

                                       "Was FBBOY.  Can be removed if all references are recompiled.")

                          (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 257-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))
                         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)
                 (TYPE?
 LISTP))
)

(/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 POINTER POINTER POINTER WORD WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER FLAG POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 0 (FLAGBITS . 0))
         (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 (SIGNEDBITS . 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)))
)
(DECLARE%: EVAL@COMPILE 

(PUTPROPS \GETCHARSETINFO
 MACRO
 ((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).")


                                     (OR (\GETCHARSETINFO FONTDESC CHARSET)
                                         (\SETCHARSETINFO FONTDESC CHARSET (\CREATECHARSET
 CHARSET 
                                                                                  FONTDESC])

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

(PUTPROPS \CREATEFONTCHARSETVECTOR
 MACRO
 (NIL 

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


                                              (\ALLOCBLOCK (IPLUS 2 \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 CHARSETPROP
 ARGNAMES
 (CSINFO PROP NEWVALUE))
(DECLARE%: EVAL@COMPILE 

(RPAQ SLUGCHARINDEX
 (ADD1 \MAXTHINCHAR))

(RPAQ SLUGCHARSET
 (ADD1 \MAXCHARSET))


(CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR))
       (SLUGCHARSET (ADD1 \MAXCHARSET)))
)

(* "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 SOURCE
                                           [NOT (EQUAL SOURCE (FONTPROP
 FONT 'DEVICESPEC])])
)
)
(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 POINTER POINTER POINTER WORD WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD 
               SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8)
               WORD POINTER POINTER FLAG POINTER)
       '((FONTDESCRIPTOR 0 POINTER)
         (FONTDESCRIPTOR 0 (FLAGBITS . 0))
         (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 (SIGNEDBITS . 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)
                          (FONTFAMILY POINTER)
                          (FONTSIZE POINTER)
                          (FONTFACE POINTER)
                          (\SFAscent WORD)
                          (\SFDescent WORD)
                          (\SFHeight WORD)
                          (ROTATION WORD)
                          (FONTSLUGWIDTH WORD)
                          (NIL SIGNEDWORD)
                          (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 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 18-Aug-2025 00:17 by rmk")


                                                             (* ; "Edited 16-Aug-2025 20:52 by rmk")


                                                             (* ; "Edited 12-Aug-2025 23:36 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 but doesn't call SETFONTDESCRIPTOR to install it and doesn't instantiate a charset.  That's deferred to FONTCREATE1.  ")


    (* ;; "")


    (LET ([FN (CAR (GETMULTI IMAGESTREAMTYPES (fetch
 (FONTSPEC FSDEVICE) of
 FONTSPEC)
                          'FONTCREATE]
          FONT)
         [if
 FN
             then
 (SETQ FONT (if
 (EQ (NARGS FN)
                                     1)
                                 then
 (APPLY* FN FONTSPEC)
                               else
                          (* ; "Old form: spreading FONTSPEC")

                                    (APPLY FN FONTSPEC)))
                  (CL:UNLESS FONT
                      (CL:WHEN (SETQ FONTSPEC (COERCEFONTSPEC
 FONTSPEC))
                          (SETQ FONT (if
 (EQ (NARGS FN)
                                             1)
                                         then
 (APPLY* FN FONTSPEC)
                                       else
 (APPLY FN FONTSPEC)))))
           else
 (SETQ 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]
         FONT])

(\CREATECHARSET

  [LAMBDA (CHARSET FONT)
                                     (* ; "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 27-Aug-2025 12:55 by rmk")


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


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


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


                                                             (* ; "Edited  5-Aug-2025 22:29 by rmk")


                                                             (* ; "Edited  3-Aug-2025 17:41 by rmk")


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


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


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


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


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


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


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


                                                             (* ; "Edited 18-May-2025 21:40 by rmk")


                                                             (* ; "Edited 16-May-2025 21:37 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 fonts FONTCHARSETVECTOR")


    (CL:UNLESS (<= 0 CHARSET \MAXCHARSET)
           (\ILLEGAL.ARG CHARSET))
    (LET [(CSINFO (if
 (fetch
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT)
                      then
 (\GETCHARSETINFO FONT CHARSET)
                    else
 (APPLY* [OR (CAR (GETMULTI IMAGESTREAMTYPES (fetch
 (FONTDESCRIPTOR 
                                                                                   FONTDEVICE)
                                                                        of
 FONT)
                                                 'CREATECHARSET))
                                     (FUNCTION (LAMBDA (FONTSPEC FONT CHARSET)
                                                             (* ; 

                                                             "No function: read or read-coerced-font")

                                                 (OR (\READCHARSET
 FONTSPEC CHARSET FONT)
                                                     (\READCHARSET
 (COERCEFONTSPEC
 FONTSPEC)
                                                            CHARSET FONT]
                                (create
 FONTSPEC using
 (FONTPROP
 FONT 'DEVICESPEC))
                                FONT CHARSET]

         (* ;; "Create a descriptor of info for that charset. If we got one, the subfunction may have ignored NOSLUG?.  But if not, we store it in the vector so that we don't search later.    ")


         (if
 (AND CSINFO (NOT (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)))
             then
 (\INSTALLCHARSETINFO
 FONT CSINFO CHARSET)
           elseif
 (SETQ CSINFO (\GETCHARSETINFO FONT SLUGCHARSET))
           else
 (SETQ CSINFO (\BUILDSLUGCSINFO
 FONT))
                (\SETCHARSETINFO FONT SLUGCHARSET CSINFO)
                (\SETCHARSETINFO FONT CHARSET CSINFO))
         CSINFO])

(\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))))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(LOCALVARS . T)
)

(PUTPROPS FONT
 FILETYPE
 :FAKE-COMPILE-FILE)



(* ;; "")





(* ;; "DISPLAY")





(* ; "Functions for DISPLAY IMAGESTREAMTYPES ")


(DEFINEQ

(\CREATEDISPLAYFONT

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


    (* ;; "FONTEXISTS? has determined that there is at least one source file for this font, so the font exists in at least some character sets, d FONTCREATED1 tells us that the font descriptor is not yet availabe.")


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

(\CREATECHARSET.DISPLAY

  [LAMBDA (FONTSPEC FONT CHARSET)
                            (* ; "Edited  7-Oct-2025 17:05 by rmk")


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


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


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


                                                             (* ; "Edited 26-Aug-2025 23:29 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 20-May-2025 15:00 by rmk")


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


                                                             (* ; "Edited 14-Jan-88 23:42 by FS")


    (* ;; "The first case is simple:  A DISPLAYFONTCOERCIONS substitution for one font for another.  E.g. Use the information derived for HELVETICA 4 to construct the fontdescriptor for Helvetic 3. ")


    (* ;; "After that, it uses requested source files and/or DISPLAYCHARCOERCIONS to produce and complete the CHARSETINFO:")


    (* ;; "This first tries to find a source file that exactly matches the characteristics of the requested charset.  The charset is %"completed%" by filling in any missing characters from further down the coercion chain.  Thus, the missing characters for e.g. TERMINAL 357 will be filled in from MODERN357, and then perhaps CLASSIC357.")


    (* ;; "If an exact match file cannot be found for a requested rotation, the rotation 0 charset is obtained and rotated.")


    (* ;; "If a non-existent Kanji or Chinese charset is requested for a non-MRR face, the MRR charset is used unmodified.  We don't try to boldify or italicize Kanji or Chinese.")


    (* ;; "When all coercions have been exhausted and FACE is bold and/or italic, the search process repeats with bold/italice changed to Regular, and algorithmic transformations are applied to the first result, if any.")


    (* ;; "If all else fails, it looks for the next charset in the coercion list, and fills that in with further coercions for missing characters.")


    (* ;; "")


    (LET ((ROTATION (fetch
 (FONTSPEC FSROTATION) of
 FONTSPEC))
          (FACE (fetch
 (FONTSPEC FSFACE) of
 FONTSPEC))
          CSINFO)

         (* ;; 

         "If no COERCIONS, skip that first \COERCECHARSET call--easier debugging of the other cases.")


         (SETQ CSINFO (if
 (AND (FONTDEVICEPROP
 'DISPLAY 'FONTCOERCIONS)
                               (CADR (\COERCECHARSET
 FONTSPEC CHARSET NIL 'FONTCOERCIONS FONT)))
                        elseif
 [SETQ CSINFO (OR (\READCHARSET
 FONTSPEC CHARSET FONT)
                                                (CADR (\COERCECHARSET
 FONTSPEC CHARSET NIL
                                                             'CHARCOERCIONS]
                          then
 
                               (* ;; "This completes CSINFO with glyphs for all codes from possibly different sources, even if just asking for a single THINCODE. We never return an incomplete CSINFO.")


                               (COMPLETE.CHARSET
 CSINFO FONTSPEC CHARSET FONT)
                        elseif
 (NEQ ROTATION 0)
                          then
 (CL:UNLESS (MEMB ROTATION '(90 270))
                                      (ERROR "Only implemented rotations are 0, 90 and 270." ROTATION
                                             ))
                               (CL:WHEN (SETQ CSINFO (\CREATECHARSET.DISPLAY
 (create
 FONTSPEC
                                                                                using
 FONTSPEC 
                                                                                      FSROTATION ← 0)
                                                            FONT CHARSET))
                                      (\SFROTATECSINFO
 CSINFO ROTATION))
                        elseif
 (OR (KANJICHARSETP CHARSET)
                                   (CHINESECHARSETP CHARSET))
                          then
 (CL:UNLESS (EQUAL FACE '(MEDIUM REGULAR REGULAR))
                                   (\CREATECHARSET.DISPLAY
 (create
 FONTSPEC
                                                              using
 FONTSPEC FSFACE ←
                                                                    '(MEDIUM REGULAR REGULAR))
                                          FONT CHARSET))
                        elseif
 (EQ 'BOLD (fetch
 (FONTFACE WEIGHT) of
 FACE))
                          then
 (MAKEBOLD.CHARSET
 FONTSPEC CHARSET FONT)
                        elseif
 (EQ 'ITALIC (fetch
 (FONTFACE SLOPE) of
 FACE))
                          then
 (MAKEITALIC.CHARSET
 FONTSPEC CHARSET FONT)
                        elseif
 (EQ 'COMPRESSED (fetch
 (FONTFACE EXPANSION) of
 FACE))
                          then
 (\CREATECHARSET.DISPLAY
 (create
 FONTSPEC
                                                          using
 FONTSPEC FSFACE ←
                                                                '(MEDIUM REGULAR REGULAR))
                                      FONT CHARSET)))
         CSINFO])

(\FONTEXISTS?.DISPLAY

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


    (LET ((FACE (fetch
 (FONTSPEC FSFACE) of
 FONTSPEC)))
         (OR [AND (EQ 'BOLD (fetch
 (FONTFACE WEIGHT) of
 FACE))
                  (FONTEXISTS?
 (create
 FONTSPEC using
 FONTSPEC FSFACE ←
                                                      (create
 FONTFACE using
 FACE WEIGHT ←
                                                                             'MEDIUM]
             [AND (EQ 'ITALIC (fetch
 (FONTFACE SLOPE) of
 FACE))
                  (FONTEXISTS?
 (create
 FONTSPEC using
 FONTSPEC FSFACE ←
                                                      (create
 FONTFACE using
 FACE SLOPE ←
                                                                             'REGULAR]
             [AND (EQ 'COMPRESSED (fetch
 (FONTFACE EXPANSION) of
 FACE))
                  (FONTEXISTS?
 (create
 FONTSPEC using
 FONTSPEC FSFACE ←
                                                      (create
 FONTFACE using
 FACE EXPANSION ←
                                                                             'REGULAR]
             (COERCEFONTSPEC
 FONTSPEC (APPEND (FONTDEVICEPROP
 'DISPLAY 'FONTCOERCIONS)
                                             (FONTDEVICEPROP
 'DISPLAY 'CHARCOERCIONS])
)
(DEFINEQ

(STRIKEFONT.FILEP

  [LAMBDA (FILE)
                                             (* ; "Edited 15-May-2025 17:47 by rmk")


    (* ;; "If high bit of type is on, then must be strike.  If 2nd bit is on, must be strike-index, and we punt.  We don't care about the 3rd bit")


    (* ;; "first word has high bits (onebit index fixed).  Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width.  Lisp doesn't care about 'fixed'")


    (RESETLST
        (CL:UNLESS (OPENP FILE 'INPUT)
            [RESETSAVE (SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD))
                   `(PROGN (CLOSEF? OLDVALUE])
        (CL:WHEN [MEMB (\WIN FILE)
                       (CONSTANT (LIST (LLSH 1 15)
                                       (LOGOR (LLSH 1 15)
                                              (LLSH 1 13]
               T))])

(STRIKEFONT.GETCHARSET

  [LAMBDA (STRM)
                                             (* ; "Edited  3-Aug-2025 22:27 by rmk")


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


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


                                                             (* ; "Edited  9-Jun-2025 14:22 by rmk")


                                                             (* ; "Edited 12-Jul-2022 09:19 by rmk")


                                                             (* ; "Edited  4-Dec-92 12:11 by jds")


    (* ;; "STRM has already been determined to be a vanilla strike-format file holding only the desired charset.")

                                                             (* ; "returns a charsetinfo")

    (RESETLST
        (CL:UNLESS (\GETSTREAM STRM 'INPUT T)
            [RESETSAVE (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD))
                   `(PROGN (CLOSEF? OLDVALUE])
        (SETFILEPTR STRM 0)
        (CL:UNLESS (STRIKEFONT.FILEP
 STRM)
               (ERROR "Not a STRIKE font file" STRM))
        (CL:UNLESS (EQ 2 (GETFILEPTR STRM))
               (SETFILEPTR STRM 2))
        (LET (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS)
             (SETQ CSINFO (create
 CHARSETINFO))
             (SETQ FIRSTCHAR (\WIN STRM))                    (* ; "minimum ascii code")

             (SETQ LASTCHAR (\WIN STRM))                     (* ; "maximum ascii code")

             (\WIN STRM)                                     (* ; 

                                                             "MaxWidth which isn't used by anyone.")

             (\WIN STRM)                                     (* ; 

                                                             "number of words in this StrikeBody")

             (replace
 (CHARSETINFO CHARSETASCENT) of
 CSINFO with
 (\WIN STRM))
                                                             (* ; 

                                                             "ascent in scan lines (=FBBdy+FBBoy)")

             (replace
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO with
 (\WIN STRM))
                                                             (* ; "descent in scan-lines (=FBBoy)")

             (\WIN STRM)                                     (* ; 

                                                    "offset in bits (<0 for kerning, else 0, =FBBox)")

             (SETQ RW (\WIN STRM))                           (* ; "raster width of bitmap")

                                                             (* ; "height of bitmap")


             (* ;; "JDS 12/4/92:  Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.")


             (SETQ HEIGHT (IPLUS (SIGNED (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                                        16)
                                 (SIGNED (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO)
                                        16)))
             (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD)
                                 HEIGHT))
             (\BINS STRM (fetch
 BITMAPBASE of
 BITMAP)
                    0
                    (UNFOLD (ITIMES RW HEIGHT)
                           BYTESPERWORD))                    (* ; "read bits into bitmap")

             (replace
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO with
 BITMAP)
             (SETQ NUMBCODES (IDIFFERENCE (ADD1 LASTCHAR)
                                    FIRSTCHAR))
             (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))

             (* ;; 

             "Initialize the offsets to 0, all but FIRSTCHAR to be replaced with the slug offset")


             (for
 I from
 0 to
 (IPLUS \MAXTHINCHAR 2) do
 (\FSETOFFSET OFFSETS I 0))
             (for
 I from
 FIRSTCHAR as
 J from
 1 to
 NUMBCODES do
 
                                                               (* ;; 

                                        "J starts at 1 because we know that the offset of J=0 is 0 ?")


                                                               (\FSETOFFSET OFFSETS I (\WIN STRM)))
             (for
 I (SLUGOFFSET ← (\WIN STRM)) from
 0 to
 \MAXTHINCHAR
                when
 (EQ 0 (\FGETOFFSET OFFSETS I)) unless
 (EQ I FIRSTCHAR)
                do
 (\FSETOFFSET OFFSETS I SLUGOFFSET) finally
 (\FSETOFFSET OFFSETS SLUGCHARINDEX 
                                                                     SLUGOFFSET) 

                                                     (* ;; 

      "There's one more so that \FONTRESETCHARWIDTHS can get the slug width, otherwise not necessary")


                                                            (\FSETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)
                                                                   (\WIN STRM)))

             (* ;; "Initialize the widths to 0")


             (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
             (for
 I from
 0 to
 (IPLUS \MAXTHINCHAR 2) do
 (\FSETWIDTH WIDTHS I 0))
             (\FONTRESETCHARWIDTHS
 CSINFO 0 SLUGCHARINDEX)
             (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO with
 (fetch
 (CHARSETINFO WIDTHS)
                                                                  of
 CSINFO))
             CSINFO))])

(WRITESTRIKEFONTFILE

  [LAMBDA (FONT CHARSET FILE)
                                (* ; "Edited 30-Aug-2025 23:21 by rmk")


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


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


                                                             (* ; "Edited  3-Aug-2025 22:33 by rmk")


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


                                                             (* ; "Edited  1-Feb-2025 12:27 by mth")


                                                             (* ; "Edited 12-Jul-2022 14:36 by rmk")

                                                             (* kbr%: "21-Oct-85 15:08")

                                                             (* ; 

                                                            "Write strike FILE using info in FONT.  ")

    (CL:UNLESS (FONTP
 FONT)
           (LISPERROR "ILLEGAL ARG" FONT))
    (CL:UNLESS CHARSET (SETQ CHARSET 0))
    (CL:UNLESS (AND (IGEQ CHARSET 0)
                    (ILEQ CHARSET \MAXCHARSET))
           (LISPERROR "ILLEGAL ARG" CHARSET))
    (LET (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS MAXWIDTH LENGTH RASTERWIDTH SLUGOFFSET OFFSETS)
         (SETQ CSINFO (\INSURECHARSETINFO FONT CHARSET))
         (CL:UNLESS CSINFO (ERROR "Couldn't find charset " CHARSET))
         (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
         (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
         (SETQ SLUGOFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX))

         (* ;; "Find the first and last non-slug characters")


         [SETQ FIRSTCHAR (for
 I from
 0 to
 \MAXTHINCHAR thereis
 (NEQ SLUGOFFSET (\FGETOFFSET OFFSETS I
                                                                                      ]
         [SETQ LASTCHAR (for
 I from
 \MAXTHINCHAR to
 0 by
 -1 thereis
 (NEQ SLUGOFFSET (\FGETOFFSET
                                                                                     OFFSETS I]
         [SETQ STREAM (OPENSTREAM FILE 'OUTPUT 'NEW '((TYPE BINARY]
         (\WOUT STREAM 32768)                                (* ; "STRIKE HEADER.  ")

         (\WOUT STREAM FIRSTCHAR)
         (\WOUT STREAM LASTCHAR)
         (SETQ MAXWIDTH 0)
         [for
 I from
 0 to
 SLUGCHARINDEX do
 (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I]
         (\WOUT STREAM MAXWIDTH)                             (* ; "STRIKE BODY.  ")

                                                             (* ; "Length.  ")

         (SETQ RASTERWIDTH (fetch
 (BITMAP BITMAPRASTERWIDTH) of
 (fetch
 (CHARSETINFO CHARSETBITMAP)
                                                                   of
 CSINFO)))
         (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR)
                             (ITIMES (fetch
 (FONTDESCRIPTOR \SFHeight) of
 FONT)
                                    RASTERWIDTH)))
         (\WOUT STREAM LENGTH)                               (* ; 

                                       "Ascent, Descent, Xoffset (no longer used) and Rasterwidth.  ")

         (\WOUT STREAM (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO))
         (\WOUT STREAM (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO))
         (\WOUT STREAM 0)
         (\WOUT STREAM RASTERWIDTH)                          (* ; "Bitmap.  ")

         [\BOUTS STREAM (fetch
 (BITMAP BITMAPBASE) of
 (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
                0
                (ITIMES 2 RASTERWIDTH (IPLUS (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                                             (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO]
                                                             (* ; "Offsets.  ")

         [for
 I (OFFSET ← 0) from
 FIRSTCHAR to
 LASTCHAR first
 (\WOUT STREAM OFFSET) 
                                                             (* ; "Offset of the first char")

            do
 (CL:UNLESS (EQ SLUGOFFSET (\FGETOFFSET OFFSETS I))
                                                             (* ; 

                                                           "The slug isn't really here in the bitmap")

                   (ADD
 OFFSET (\FGETWIDTH WIDTHS I)))
               (\WOUT STREAM OFFSET) finally
                 (* ; 

                                                             "Offset for the after-slug, for width")

                                           (\WOUT STREAM (IPLUS OFFSET (\FGETWIDTH WIDTHS 
                                                                              SLUGCHARINDEX]
         (CLOSEF STREAM])

(STRIKECSINFO

  [LAMBDA (CSINFO)
                                           (* ; "Edited 27-Apr-89 13:39 by atm")


    (* ;; "Returns a STRIKE type font descriptor (EQ WIDTHS IMAGEWIDTHS), cause we know how to write those guys out (they read quicker  but display slower).  If (EQ WIDTHS IMAGEWIDTHS), just return original.")


    (PROG (WIDTHS OFFSETS IMWIDTHS OLDBM BMWIDTH BMHEIGHT NEWBM NEWOFFSET NEWWIDTH OLDOFFSET 
                 DUMMYOFFSET NEWOFFSETS)
          (SETQ WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
          (SETQ IMWIDTHS (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO))
          (if
 (EQ WIDTHS IMWIDTHS)
              then
 (RETURN CSINFO))
          (SETQ OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
          (SETQ OLDBM (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
          (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS 256))
          (SETQ BMHEIGHT (BITMAPHEIGHT OLDBM))
          [SETQ BMWIDTH (for
 I from
 0 to
 \MAXTHINCHAR
                           sum
 (if
 (IEQP DUMMYOFFSET (\FGETOFFSET OFFSETS I))
                                   then
 0
                                 else
 (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                            (\FGETWIDTH WIDTHS I]

     (* ;; "")


     (* ;; "Initialize new offsets vector")


     (* ;; "")


          (SETQ NEWOFFSETS (\CREATECSINFOELEMENT))
          (for
 I from
 0 to
 (IPLUS \MAXTHINCHAR 2) do
 (\FSETOFFSET NEWOFFSETS I 0))
          (\FSETOFFSET NEWOFFSETS (ADD1 \MAXTHINCHAR)
                 BMWIDTH)

     (* ;; "")


     (* ;; "Adjust bitmap with so width = imagewidth, fill offsets")


     (* ;; "")


          (SETQ NEWBM (BITMAPCREATE BMWIDTH BMHEIGHT 1))
          (SETQ NEWOFFSET 0)
          [for
 I from
 0 to
 255 do
 (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I))
                                  (if
 (IEQP DUMMYOFFSET OLDOFFSET)
                                      then
 (\FSETOFFSET NEWOFFSETS I BMWIDTH)
                                    else
 (\FSETOFFSET NEWOFFSETS I NEWOFFSET)
                                         (SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I)
                                                              (\FGETWIDTH WIDTHS I)))
                                         (BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH
                                                                                      IMWIDTHS I)
                                                BMHEIGHT
                                                'REPLACE)
                                         (SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH]

     (* ;; "")


     (* ;; "Make new CSInfo record withs IMAGEWIDTHS, WIDTHS the same")


     (* ;; "")


          (SETQ WIDTHS (COPYALL WIDTHS))
          [for
 I from
 0 to
 \MAXTHINCHAR do
 (\FSETWIDTH WIDTHS I (IMAX (\FGETWIDTH WIDTHS I)
                                                                      (\FGETIMAGEWIDTH IMWIDTHS I]
          (RETURN (create
 CHARSETINFO
                         WIDTHS ← WIDTHS
                         OFFSETS ← NEWOFFSETS
                         IMAGEWIDTHS ← WIDTHS
                         CHARSETBITMAP ← NEWBM
                         YWIDTHS ← (fetch
 (CHARSETINFO YWIDTHS) of
 CSINFO)
                         CHARSETASCENT ← (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                         CHARSETDESCENT ← (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO])
)



(* ; "Bitmap faking")


(DEFINEQ

(MAKEBOLD.CHARSET

  [LAMBDA (FONTSPEC CHARSET FONT)
                            (* ; "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")


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


    (* ;; "BOLD is requested in FACE, so we look for an MRR or MIR that we can bold.  If we find one, we presume that it is complete for all characters in its face.  But there may be other fonts in the coercion chain that have true information about the bold face that we are after. We look for those before we try to adjust the characters in the non-bold CSINFO that we found.")


    (LET ([MFONT (FONTCREATE1
 (create
 FONTSPEC using
 FONTSPEC FSFACE ← (create
 FONTFACE
                                                                          using
 (fetch
 (FONTSPEC
                                                                                        FSFACE)
                                                                                   of
 FONTSPEC)
                                                                                WEIGHT ← 'MEDIUM]
          CSINFO)

         (* ;; "MFONT is the corresponding Medium font.")


         (CL:WHEN (AND MFONT (SETQ CSINFO (\GETCHARSETINFO MFONT CHARSET))
                       (NOT (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)))
             (replace
 (FONTDESCRIPTOR FONTCHARENCODING) of
 FONT with
 (fetch
 (FONTDESCRIPTOR 
                                                                                   FONTCHARENCODING)
                                                                        of
 MFONT))
             (replace
 (FONTDESCRIPTOR FONTTOMCCSFN) of
 FONT with
 (fetch
 (FONTDESCRIPTOR FONTTOMCCSFN)
                                                                    of
 MFONT))
             (SETQ CSINFO (COPYALL CSINFO))                  (* ; "CSINFO is now the CS to be bolded")

             (\SETCHARSETINFO FONT CHARSET CSINFO)
             (for
 CODE SOURCEFONT (CHARCOERCIONS ← (FONTDEVICEPROP
 FONT 'CHARCOERCIONS))
                from
 (FIRSTCHARSETCODE CHARSET) to
 (LASTCHARSETCODE CHARSET)
                do
 (if
 (SLUGCHARP.DISPLAY
 CODE FONT)
                       then
 
                            (* ;; "The Medium font doesn't have a glyph for THINCODE. Look for a bold glyph for THINCODE lurking somewhere down the chain, copy it up.  There may be different sources for different codes.  We're starting from FONT and FONTSPEC, still hoping for BOLD.")


                            (CL:WHEN (SETQ SOURCEFONT (CAR (\COERCECHARSET
 FONTSPEC CHARSET CODE)))
                                (\MOVEFONTCHAR
 (\MOVEFONTCHARS.SOURCEDATA
 CODE SOURCEFONT)
                                       CODE FONT))
                     else
 
                          (* ;; "There is Medium glyph, bold it")


                          (MAKEBOLD.CHAR
 CODE FONT)))
             (replace
 (CHARSETINFO CSCOMPLETEP) of
 CSINFO with
 T)
             CSINFO)])

(MAKEBOLD.CHAR

  [LAMBDA (CODE FONT)
                                        (* ; "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.DISPLAY
 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.CHARSET

  [LAMBDA (FONTSPEC CHARSET FONT)
                            (* ; "Edited  7-Sep-2025 12:03 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:10 by rmk")


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


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


    (* ;; "ITALIC is requested, so we look for an MRR or MIR that we can italicize.  If we find one, we presume that it is complete for all characters in its face.  But there may be other fonts in the coercion chain that have true information about the italic face that we are after. We look for those before we try to adjust the characters in  non-italic CSINFO that we found.")


    (LET ([RFONT (FONTCREATE1
 (create
 FONTSPEC using
 FONTSPEC FSFACE ← (create
 FONTFACE
                                                                          using
 (fetch
 (FONTSPEC
                                                                                        FSFACE)
                                                                                   of
 FONTSPEC)
                                                                                SLOPE ← 'REGULAR]
          CSINFO)

         (* ;; "RFONT is the corresponding Regular font.")


         (CL:WHEN (AND RFONT (SETQ CSINFO (\GETCHARSETINFO RFONT CHARSET))
                       (NOT (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO)))
             (replace
 (FONTDESCRIPTOR FONTCHARENCODING) of
 FONT with
 (fetch
 (FONTDESCRIPTOR 
                                                                                   FONTCHARENCODING)
                                                                        of
 RFONT))
             (replace
 (FONTDESCRIPTOR FONTTOMCCSFN) of
 FONT with
 (fetch
 (FONTDESCRIPTOR FONTTOMCCSFN)
                                                                    of
 RFONT))
             (SETQ CSINFO (COPYALL CSINFO))                  (* ; 

                                                             "CSINFO is now the CS to be italicized")

             (\SETCHARSETINFO FONT CHARSET CSINFO)
             (for
 CODE SOURCEFONT (CHARCOERCIONS ← (FONTDEVICEPROP
 FONT 'CHARCOERCIONS))
                from
 (FIRSTCHARSETCODE CHARSET) to
 (LASTCHARSETCODE CHARSET)
                do
 (if
 (SLUGCHARP.DISPLAY
 CODE FONT)
                       then
 
                            (* ;; "The regular font doesn't have a glyph for THINCODE. Look for an italic glyph for THINCODE lurking somewhere down the chain, copy it up. There may be different sources for different codes.")


                            (CL:WHEN (SETQ SOURCEFONT (CAR (\COERCECHARSET
 FONTSPEC CHARSET CODE)))
                                (\MOVEFONTCHAR
 (\MOVEFONTCHARS.SOURCEDATA
 CODE SOURCEFONT)
                                       CODE FONT))
                     else
 
                          (* ;; "There is a Regular glyph, Italicize it.")


                          (MAKEITALIC.CHAR
 CODE FONT)))
             (replace
 (CHARSETINFO CSCOMPLETEP) of
 CSINFO with
 T)
             CSINFO)])

(MAKEITALIC.CHAR

  [LAMBDA (CODE FONT)
                                        (* ; "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.DISPLAY
 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)))])

(\SFMAKEBOLD

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


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


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

                                                             (* gbn "25-Jul-85 04:52")

    (LET ((OLDCHARBITMAP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
          (WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
          (OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
          (HEIGHT (IPLUS (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO)
                         (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO)))
          NEWCHARBITMAP OFFSET SLUGOFFSET SLUGWIDTH)
         (SETQ NEWCHARBITMAP (BITMAPCREATE (fetch
 BITMAPWIDTH of
 OLDCHARBITMAP)
                                    (fetch
 BITMAPHEIGHT of
 OLDCHARBITMAP)))
         (SETQ SLUGOFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX))
         (SETQ SLUGWIDTH (\FGETWIDTH WIDTHS SLUGCHARINDEX))
         (for
 I from
 0 to
 \MAXTHINCHAR unless
 (EQ SLUGOFFSET (SETQ OFFSET (\FGETOFFSET OFFSETS I)))
            do
                                               (* ; 

                                                            "overlap two blts to produce bold effect")

               (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0 (\FGETWIDTH WIDTHS I)
                      HEIGHT
                      'INPUT
                      'REPLACE)
               (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP (ADD1 OFFSET)
                      0
                      (SUB1 (\FGETWIDTH WIDTHS I))
                      HEIGHT
                      'INPUT
                      'PAINT))                               (* ; 

                                                            "fill in the slug for the magic charcode")

         (BITBLT OLDCHARBITMAP SLUGOFFSET 0 NEWCHARBITMAP SLUGOFFSET 0 SLUGWIDTH HEIGHT 'INPUT
                'REPLACE)
         (create
 CHARSETINFO using
 CSINFO CHARSETBITMAP ← NEWCHARBITMAP])

(\SFMAKEITALIC

  [LAMBDA (CSINFO)
                                           (* ; "Edited 16-Jun-2025 23:20 by rmk")

                                                             (* gbn "18-Sep-85 17:57")

    (LET ((WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
          (OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
          (ASCENT (fetch
 (CHARSETINFO CHARSETASCENT) of
 CSINFO))
          (DESCENT (fetch
 (CHARSETINFO CHARSETDESCENT) of
 CSINFO))
          (OLDBITMAP (fetch
 (CHARSETINFO CHARSETBITMAP) of
 CSINFO))
          HEIGHT OFFSET NEWBITMAP WIDTH SLUGOFFSET SLUGWIDTH N M R XN XX YN YX)
         (SETQ HEIGHT (IPLUS ASCENT DESCENT))
         (SETQ NEWBITMAP (BITMAPCREATE (fetch
 BITMAPWIDTH of
 OLDBITMAP)
                                (fetch
 BITMAPHEIGHT of
 OLDBITMAP)))
         (SETQ SLUGOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR)))
         (SETQ SLUGWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR)))
         (SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3)
                                       4)))
         (SETQ M (IQUOTIENT (IPLUS ASCENT 3)
                        4))
         [for
 I from
 0 to
 \MAXTHINCHAR unless
 (EQ SLUGOFFSET (SETQ OFFSET (\FGETOFFSET OFFSETS I)))
            do
 (SETQ WIDTH (\FGETWIDTH WIDTHS I))
               (for
 J from
 N to
 M do
 (SETQ R (IPLUS OFFSET WIDTH))
                                     (SETQ XN (IMIN R (IMAX (IPLUS OFFSET J)
                                                            0)))
                                     (SETQ XX (IMIN R (IMAX (IPLUS R J)
                                                            0)))
                                     [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4]
                                     [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4)
                                                                                 4]
                                     (CL:WHEN (AND (IGREATERP XX XN)
                                                   (IGREATERP YX YN))
                                         (BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE
                                                                                      XX XN)
                                                (IDIFFERENCE YX YN)
                                                'INPUT
                                                'REPLACE))]
         (BITBLT OLDBITMAP SLUGOFFSET 0 NEWBITMAP SLUGOFFSET 0 SLUGWIDTH HEIGHT 'INPUT 'REPLACE)
         (create
 CHARSETINFO using
 CSINFO CHARSETBITMAP ← NEWBITMAP])
)
(DEFINEQ

(\SFMAKEROTATEDFONT

  [LAMBDA (FONTDESC ROTATION)
                                (* ; "Edited 30-Mar-87 20:35 by FS")


    (* ;; "takes a fontdecriptor and rotates it.")


    (* ;; "1/5/86 JDS.  Masterscope claims nobody calls this.  Let's find out....")


    (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields")
                                                             (* (create FONTDESCRIPTOR using 

                                                             FONTDESC (SETQ CHARACTERBITMAP

                                                             (\SFROTATEFONTCHARACTERS

                                                             (fetch (FONTDESCRIPTOR CHARACTERBITMAP)

    of FONTDESC) ROTATION)) (SETQ ROTATION ROTATION) (SETQ \SFOffsets (\SFFIXOFFSETSAFTERROTATION 

                                                             FONTDESC ROTATION)) (SETQ 

                                                             FONTCHARSETVECTOR (\ALLOCBLOCK

                                                             (ADD1 \MAXCHARSET) T))))


    (* ;; "If you uncomment out the code above, remove this comment and the NIL below")


    NIL])

(\SFROTATECSINFO

  [LAMBDA (CSINFO ROTATION)                                  (* gbn "15-Sep-85 14:38")


    (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.")


    (create
 CHARSETINFO using
 CSINFO CHARSETBITMAP ← (\SFROTATEFONTCHARACTERS
 (fetch
 (CHARSETINFO
                                                                                      CHARSETBITMAP)
                                                                                 of
 CSINFO)
                                                            ROTATION)
                              OFFSETS ← (\SFROTATECSINFOOFFSETS
 CSINFO 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])
)
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYCHARCOERCIONS DISPLAYFONTCOERCIONS 
       DISPLAYCHARSETFNS)
)

(* "END EXPORTED DEFINITIONS")

(DECLARE%: DONTEVAL@LOAD DOCOPY 

(RPAQ? DISPLAYFONTDIRECTORIES
 NIL)


(ADDTOVAR DISPLAYCHARSETFNS
 (STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET))


(ADDTOVAR DISPLAYFONTEXTENSIONS
 MEDLEYDISPLAYFONT DISPLAYFONT)
)

(RPAQ? DISPLAYFONTCOERCIONS

       '(((HELVETICA (<= * 2))
          (HELVETICA 4))
         ((MODERN (<= 15 * 16))
          (* 14))
         ((MODERN (<= 17 * 21))
          (* 18))
         ((MODERN (<= 22 * 28))
          (* 24))
         ((MODERN (<= 29 * 33))
          (* 30))
         ((MODERN (<= 34 * 40))
          (* 36))
         ((MODERN (<= 41 * 65))
          (* 48))
         ((MODERN (<= 66 *))
          (* 72))
         ((PALATINO 9)
          (PALATINO 12))
         ((PALATINO (<= * 8))
          (PALATINO 10))
         ((TITAN (<= * 9)
                 BOLD)
          (MODERN 10))
         ((TITAN (<= * 9)
                 ITALIC)
          (MODERN 10))
         ((TITAN (<= * 9))
          (TITAN 10))
         (LPT AMTEX)))

(RPAQ? DISPLAYCHARCOERCIONS

       '((GACHA TERMINAL)
         (MODERN CLASSIC)
         (TIMESROMAN CLASSIC)
         (HELVETICA MODERN)
         (TERMINAL MODERN)
         (HIPPO CLASSIC)
         (CYRILLIC CLASSIC)
         (MATH CLASSIC)
         (SIGMA MODERN)
         (SYMBOL MODERN)
         (TITAN CLASSIC)
         (PALATINO CLASSIC)
         (OPTIMA MODERN)
         (BOLDPS CLASSIC)
         (PCTERMINAL CLASSIC)
         (TITANLEGAL CLASSIC)))

(RPAQ? \DEFAULTCHARSET
 0)



(* ;; "")





(* ;; "Defunct coercions? Mapping for DOS filenames, Adobe equivalences")



(RPAQ? ADOBEDISPLAYFONTCOERCIONS

       '(((HELVETICABLACK 16)
          (HELVETICABLACK 18))
         ((SYMBOL)
          (ADOBESYMBOL))
         ((SYMBOL 11)
          (ADOBESYMBOL 10))
         ((AVANTGARDE-DEMI)
          (AVANTGARDE))
         ((AVANTGARDE-BOOK)
          (AVANTGARDE))
         ((NEWCENTURYSCHLBK)
          (CENTURYSCHOOLBOOK))
         ((BOOKMAN-LIGHT)
          (BOOKMAN))
         ((BOOKMAN-DEMI)
          (BOOKMAN))
         ((HELVETICA-NARROW)
          (HELVETICANARROW))
         ((HELVETICA 24)
          (ADOBEHELVETICA 24))))

(RPAQ? *DISPLAY-FONT-NAME-MAP*

       '((TIMESROMAN . TR)
         (HELVETICA . HV)
         (TIMESROMAND . TD)
         (HELVETICAD . HD)
         (MODERN . MD)
         (CLASSIC . CL)
         (GACHA . GC)
         (TITAN . TI)
         (LETTERGOTHIC . LG)
         (BOLDPS . BP)
         (TERMINAL . TM)
         (CLASSICTHIN . CT)
         (HIPPO . HP)
         (LOGO . LG)
         (MATH . MA)
         (OLDENGLISH . OE)
         (SYMBOL . SY)))
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 )

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 FONTCOPY)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (11429 21096 (CHARWIDTH 11439 . 12228) (CHARWIDTHY 12230 . 13747) (STRINGWIDTH 13749 . 
14786) (\CHARWIDTH.DISPLAY 14788 . 15203) (\STRINGWIDTH.DISPLAY 15205 . 15633) (\STRINGWIDTH.GENERIC 
15635 . 21094)) (21097 27729 (DEFAULTFONT 21107 . 22392) (FONTCLASS 22394 . 24666) (FONTCLASSUNPARSE 
24668 . 25569) (FONTCLASSCOMPONENT 25571 . 26159) (SETFONTCLASSCOMPONENT 26161 . 26603) (
GETFONTCLASSCOMPONENT 26605 . 27727)) (29442 47482 (FONTCREATE 29452 . 32697) (FONTCREATE1 32699 . 
35314) (FONTCREATE.SLUGFD 35316 . 36820) (\FONT.CHECKARGS1 36822 . 41527) (\FONTCREATE1.NOFN 41529 . 
41743) (FONTFILEP 41745 . 42633) (\READCHARSET 42635 . 47480)) (47483 54559 (\FONT.CHECKARGS 47493 . 
54242) (\CHARSET.CHECK 54244 . 54557)) (54560 61171 (COERCEFONTSPEC 54570 . 60482) (
COERCEFONTSPEC.TARGETFACE 60484 . 61169)) (63366 64715 (MAKEFONTSPEC 63376 . 64713)) (64716 72893 (
COMPLETE.FONT 64726 . 67249) (COMPLETEFONTP 67251 . 67874) (COMPLETE.CHARSET 67876 . 70561) (
PRUNESLUGCSINFOS 70563 . 71488) (MONOSPACEFONTP 71490 . 72891)) (72932 81390 (FONTASCENT 72942 . 73326
) (FONTDESCENT 73328 . 73813) (FONTHEIGHT 73815 . 74217) (FONTPROP 74219 . 80667) (\AVGCHARWIDTH 80669
 . 81388)) (82047 82955 (FONTDEVICEPROP 82057 . 82953)) (83001 83855 (EDITCHAR 83011 . 83853)) (83901 
96091 (GETCHARBITMAP 83911 . 85035) (PUTCHARBITMAP 85037 . 87195) (\GETCHARBITMAP.CSINFO 87197 . 89213
) (\PUTCHARBITMAP.CSINFO 89215 . 96089)) (96092 117372 (MOVECHARBITMAP 96102 . 97996) (MOVEFONTCHARS 
97998 . 102744) (\MOVEFONTCHAR 102746 . 107593) (\MOVEFONTCHARS.SOURCEDATA 107595 . 113710) (
\MAKESLUGCHAR 113712 . 116247) (SLUGCHARP.DISPLAY 116249 . 117370)) (118030 129879 (FONTFILES 118040
 . 119873) (\FINDFONTFILE 119875 . 121852) (\FONTFILENAMES 121854 . 122414) (\FONTFILENAME 122416 . 
125327) (FONTSPECFROMFILENAME 125329 . 129877)) (129880 166129 (FONTCOPY 129890 . 134973) (FONTP 
134975 . 135274) (FONTUNPARSE 135276 . 136999) (SETFONTDESCRIPTOR 137001 . 138465) (\STREAMCHARWIDTH 
138467 . 142478) (\COERCECHARSET 142480 . 145847) (\BUILDSLUGCSINFO 145849 . 149480) (\FONTSYMBOL 
149482 . 150136) (\DEVICESYMBOL 150138 . 150922) (\FONTFACE 150924 . 158128) (\FONTFACE.COLOR 158130
 . 164912) (SETFONTCHARENCODING 164914 . 166127)) (166130 185807 (FONTSAVAILABLE 166140 . 171504) (
FONTEXISTS? 171506 . 175047) (\SEARCHFONTFILES 175049 . 178136) (FLUSHFONTCACHE 178138 . 180361) (
FINDFONTFILES 180363 . 183579) (SORTFONTSPECS 183581 . 185805)) (185808 189923 (MATCHFONTFACE 185818
 . 186633) (MAKEFONTFACE 186635 . 187669) (FONTFACETOATOM 187671 . 189921)) (190554 191046 (
\UNITWIDTHSVECTOR 190564 . 191044)) (205689 207756 (FONTDESCRIPTOR.DEFPRINT 205699 . 207278) (
FONTCLASS.DEFPRINT 207280 . 207754)) (211585 214375 (\CREATEKERNELEMENT 211595 . 211953) (
\FSETLEFTKERN 211955 . 212446) (\FGETLEFTKERN 212448 . 214373)) (214376 226042 (\CREATEFONT 214386 . 
217282) (\CREATECHARSET 217284 . 221793) (\INSTALLCHARSETINFO 221795 . 225129) (
\INSTALLCHARSETINFO.CHARENCODING 225131 . 226040)) (226364 227732 (\FONTRESETCHARWIDTHS 226374 . 
227730)) (228362 238439 (\CREATEDISPLAYFONT 228372 . 230239) (\CREATECHARSET.DISPLAY 230241 . 235956) 
(\FONTEXISTS?.DISPLAY 235958 . 238437)) (238440 253445 (STRIKEFONT.FILEP 238450 . 239338) (
STRIKEFONT.GETCHARSET 239340 . 244934) (WRITESTRIKEFONTFILE 244936 . 249849) (STRIKECSINFO 249851 . 
253443)) (253476 269809 (MAKEBOLD.CHARSET 253486 . 257141) (MAKEBOLD.CHAR 257143 . 258895) (
MAKEITALIC.CHARSET 258897 . 262576) (MAKEITALIC.CHAR 262578 . 264924) (\SFMAKEBOLD 264926 . 267152) (
\SFMAKEITALIC 267154 . 269807)) (269810 273834 (\SFMAKEROTATEDFONT 269820 . 271054) (\SFROTATECSINFO 
271056 . 271731) (\SFROTATEFONTCHARACTERS 271733 . 272117) (\SFROTATECSINFOOFFSETS 272119 . 273832)) (
273835 275009 (\SFMAKECOLOR 273845 . 275007)))))
STOP