(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED " 9-Oct-2025 15:20:59" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;242
 59604  

      :EDIT-BY rmk

      :CHANGES-TO (FNS MEDLEYFONT.GETCHARSET)

      :PREVIOUS-DATE " 7-Oct-2025 12:43:33" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;241)


(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)

(RPAQQ MEDLEYFONTFORMATCOMS

       [
        (* ;; "Eventually, MEDLEYFONT should be a package")


        
        (* ;; "Main public entries")


        (FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP 
             MEDLEYFONT.FILEP)
        
        (* ;; "Reading")


        (FNS MEDLEYFONT.READ.FONT MEDLEYFONT.READ.CHARSET MEDLEYFONT.READ.ITEM MEDLEYFONT.PEEK.ITEM 
             MEDLEYFONT.READ.FONTPROPS MEDLEYFONT.READ.VERIFIEDFONT)
        
        (* ;; "Writing")


        (FNS MEDLEYFONT.WRITE.CHARSET MEDLEYFONT.WRITE.ITEM MEDLEYFONT.WRITE.FONTPROPS 
             MEDLEYFONT.WRITE.HEADER)
        (FNS MEDLEYFONT.FILENAME)
        (ADDVARS (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
               (DISPLAYCHARSETFNS (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET))
               (INTERPRESSFONTEXTENSIONS MEDLEYINTERPRESSFONT))
        (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (PRINTDATA 0)
                                                (SMALLPDATA 1)
                                                (BITMAPDATA 2)
                                                (WORDBLOCKDATA 3)
                                                (CLARRAYDATA 4)
                                                (FIXPDATA 5)
                                                (ILPOINTERARRAY 6)
                                                (ILNUMBERARRAY 11)
                                                (HPRINTDATA 7)
                                                (ALISTDATA 8)
                                                (PLISTDATA 9)
                                                (LISTDATA 10])



(* ;; "Eventually, MEDLEYFONT should be a package")





(* ;; "Main public entries")


(DEFINEQ

(MEDLEYFONT.WRITE.FONT

  [LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS)
  (* ; "Edited  2-Sep-2025 23:01 by rmk")


                                                             (* ; "Edited 15-Jul-2025 16:43 by rmk")


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


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


                                                             (* ; "Edited  9-Jun-2025 12:17 by rmk")


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


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


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


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


                                                             (* ; "Edited 14-May-2025 17:45 by rmk")

    (SETQ FONT (FONTCREATE FONT))
    (CL:UNLESS FILE
        (SETQ FILE (MEDLEYFONT.FILENAME
 FONT CHARSETNOS)))
    (SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
    (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
           (MEDLEYFONT.WRITE.HEADER
 STREAM OTHERFONTPROPS)
           (LET ((CHARSETLOCS (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT 0))
                 (FONTCHARENCODING (FONTPROP FONT 'CHARENCODING))
                 (*READTABLE* (FIND-READTABLE "INTERLISP"))
                 CSVECTORPTRLOC CSVECTORLOC FILECHARSETS)

                (* ;; "Figure out the actual non empty/sluggish charsets that will be wrtitten.")


                (SETQ FILECHARSETS (for
 CSNO CSINFO from
 0 to
 \MAXCHARSET
                                      when
 (OR (NULL CHARSETNOS)
                                               (MEMB CSNO CHARSETNOS))
                                      when
 (SETQ CSINFO (\GETCHARSETINFO FONT CSNO))
                                      unless
 (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO) collect
 CSNO))
                (CL:UNLESS FILECHARSETS (ERROR "No character sets to write" FONT))

                (* ;; "Right after the header, leave 4 bytes for the pointer to the charset dispatch vector. If writing a single charset, we store the negative of the byte location so we can still easily skip the font properties without writing the whole vector. The byte in front of the single charset holds its number.")


                (* ;; "")


                (SETQ CSVECTORPTRLOC (GETFILEPTR STREAM))    (* ; 

                                                      "Ptr is before fontproperties, vector is after")

                (\FIXPOUT STREAM 0)
                (MEDLEYFONT.WRITE.FONTPROPS
 STREAM FONT)
                (if
 (CDR FILECHARSETS)
                    then
 (PRINTOUT STREAM "CHARSET LOCATIONS" T) 
                                                             (* ; 

                                                             "Allocate the vector space if multiple")

                         (SETQ CSVECTORLOC (GETFILEPTR STREAM))
                         (for
 I from
 0 to
 \MAXCHARSET do
 (\FIXPOUT STREAM 0))
                         (TERPRI STREAM)
                         (for
 CSNO in
 FILECHARSETS do
 

                                                    (* ;; 

    "LOC remains zero for missing charsets, slug properties are determined by font-level properties.")


                                                      (CL:SETF (CL:SVREF CHARSETLOCS CSNO)
                                                             (GETFILEPTR STREAM))
                                                      (MEDLEYFONT.WRITE.CHARSET
 FONT CSNO STREAM 
                                                             NOINDIRECTS))
                         (SETFILEPTR STREAM CSVECTORLOC)
                         (for
 CSNO from
 0 to
 \MAXCHARSET do
 (\FIXPOUT STREAM (CL:SVREF CHARSETLOCS 
                                                                                    CSNO)))
                  else
 
                       (* ;; "Only one.  The %"vector%" is the charset byte immediately before the charset, the sign bit tells the tale.")


                       (SETQ CSVECTORLOC (IMINUS (GETFILEPTR STREAM)))
                       (BOUT STREAM (CAR FILECHARSETS))
                       (MEDLEYFONT.WRITE.CHARSET
 FONT (CAR FILECHARSETS)
                              STREAM NOINDIRECTS))
                (SETFILEPTR STREAM CSVECTORPTRLOC)
                (\FIXPOUT STREAM CSVECTORLOC)                (* ; 

             "Pointer to the charset dispatch vector--or negative of actual location for a singleton")

                (FULLNAME STREAM])

(MEDLEYFONT.GETCHARSET

  [LAMBDA (STREAM CHARSET FONT)
                              (* ; "Edited  9-Oct-2025 15:18 by rmk")


                                                             (* ; "Edited  3-Sep-2025 11:32 by rmk")


                                                             (* ; "Edited 15-Jul-2025 17:09 by rmk")


                                                             (* ; "Edited  9-Jul-2025 15:45 by rmk")


                                                             (* ; "Edited 14-May-2025 17:46 by rmk")


    (* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information.  FONT is provided so that properties of the fontdescriptor can be read through this interface--ottherwise the fontcreate function of each device might have to also have a list of functions to try.")


    (CL:UNLESS (<= 0 CHARSET \MAXCHARSET)
           (\ILLEGAL.ARG CHARSET))
    (RESETLST
        (CL:UNLESS (\GETSTREAM STREAM 'INPUT T)
            [RESETSAVE (SETQ STREAM (OPENSTREAM STREAM 'INPUT))
                   `(PROGN (CLOSEF? OLDVALUE]
            (CL:UNLESS (MEDLEYFONT.FILEP
 STREAM)             (* ; 

                                                             "Checks and positions, if reopening.")

                (ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM))))
        (LET ((CSVECTORLOC (\FIXPIN STREAM))
              CSLOC)
             (if
 (thereis
 CS from
 0 to
 \MAXTHINCHAR suchthat
 (\GETCHARSETINFO FONT CS))
                 then
 
                      (* ;; "Font fields have been initialized, just update for this charset")


                      (for
 P VAL in
 (MEDLEYFONT.READ.FONTPROPS
 STREAM)
                         do
 (SETQ VAL (CADR P))
                            (SELECTQ (CAR VAL)
                                (\SFAscent (change
 (fetch
 (FONTDESCRIPTOR \SFAscent) of
 FONT)
                                                  (IMAX VAL DATUM)))
                                (\SFDescent (change
 (fetch
 (FONTDESCRIPTOR \SFDescent) of
 FONT)
                                                   (IMAX VAL DATUM)))
                                (\SFHeight (fetch
 (FONTDESCRIPTOR \SFHeight) of
 FONT))
                                NIL))
               else
 
                    (* ;; "First charset, probably 0: establish the overall font properties. ")


                    (MEDLEYFONT.READ.VERIFIEDFONT
 STREAM FONT))
             (replace
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT with
 NIL)

             (* ;; 

         "One charset doesn't %"complete%" a complete font--maybe that's only an incore property?   ")


             (* ;; "We know now that this file has information about the requested charset, including NIL entries for empty/slugglish ones in the middle of populated ones.  A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")


             (CL:WHEN (if
 (ILESSP CSVECTORLOC 0)
                          then
 
                               (* ;; "File contains only one charset. Is it the one we want? If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.")


                               (SETFILEPTR STREAM (IMINUS CSVECTORLOC))
                               (EQ CHARSET (BIN STREAM))
                        else
 
                             (* ;; "The vector-entry points to the one we want.  Is it there?")


                             (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL)))
                             (CL:UNLESS (EQ 0 (SETQ CSLOC (\FIXPIN STREAM)))
                                    (SETFILEPTR STREAM CSLOC)))
                    (MEDLEYFONT.READ.CHARSET
 STREAM CHARSET))))])

(MEDLEYFONT.CHARSET?

  [LAMBDA (FILE CHARSET)
                                     (* ; "Edited 15-Jul-2025 15:21 by rmk")


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


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


                                                             (* ; "Edited 17-May-2025 11:29 by rmk")


                                                             (* ; "Edited 14-May-2025 17:46 by rmk")


    (* ;; "If CHARSET, returns CHARSET if FILE contains a non-slug entry for CHARSET.  If not CHARSET, returns the list of non-slug charsets in FILE.")


    (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
           (CL:UNLESS (MEDLEYFONT.FILEP
 STREAM)
                  (ERROR "Not a MEDLEYFONT file" FILE))
           (LET ((CSVECTORLOC (\FIXPIN STREAM)))
                (CL:WHEN (if
 (ILESSP CSVECTORLOC 0)
                             then
 
                                  (* ;; "File contains only one charse, is it the one we want? ")


                                  (SETFILEPTR STREAM (IMINUS CSVECTORLOC))
                                  (EQ CHARSET (BIN STREAM))
                           else
 (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL)))
                                (NEQ 0 (\FIXPIN STREAM)))
                       CHARSET])

(MEDLEYFONT.GETFILEPROP

  [LAMBDA (FILE PROP)
                                        (* ; "Edited 27-Aug-2025 17:12 by rmk")


                                                             (* ; "Edited 15-Jul-2025 20:21 by rmk")


                                                             (* ; "Edited 10-Jul-2025 17:50 by rmk")


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


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


                                                             (* ; "Edited 17-May-2025 19:07 by rmk")


                                                             (* ; "Edited 14-May-2025 17:46 by rmk")

    (CL:UNLESS (OR (LITATOM FILE)
                   (STRINGP FILE))
        [SETQ FILE (CAR (FONTFILES (FONTPROP (FONTCREATE FILE)
                                          'SPEC])
    (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
           (LET (HEADERPROPS CSVECTORLOC)
                (CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP
 STREAM))
                    (ERROR "Not a MEDLEYFONT file" (FULLNAME STREAM)))
                (SETQ CSVECTORLOC (\FIXPIN STREAM))
                (SELECTQ PROP
                    (OTHERPROPS (CDDR HEADERPROPS))
                    (DATE (CADR HEADERPROPS))
                    (FONTPROPS (MEDLEYFONT.READ.FONTPROPS
 STREAM))
                    (CHARSETS (if
 (ILESSP CSVECTORLOC 0)
                                  then
 
                                       (* ;; "File contains only one charset ")


                                       (SETFILEPTR STREAM (IMINUS CSVECTORLOC))
                                       (CONS (BIN STREAM))
                                else
 (SETFILEPTR STREAM CSVECTORLOC)
                                     (for
 CS from
 0 to
 \MAXCHARSET unless
 (EQ 0 (\FIXPIN STREAM))
                                        collect
 CS)))
                    (ERROR "Unknown MEDLEYFONT property"])

(MEDLEYFONT.FILEP

  [LAMBDA (FILE)
                                             (* ; "Edited  6-Jul-2025 11:44 by rmk")


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


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


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


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


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


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


    (* ;; "Me in first 2 bytes distinguishes MEDLEYFONT format from others.  This may be called after the first 2 bytes have been read to verify the %"Me%", if not we skip over it here.")


    (* ;; "For a valid file, returns (fullname date)")


    (* ;; "If FILE is an open stream, it is left open.  Otherwise it is opened and closed.")


    (RESETLST
        [LET (STREAM VERSION DATE)
             [if
 (\GETSTREAM FILE 'INPUT T)
                 then
 (SETQ STREAM FILE)
               else
 (RESETSAVE (SETQ STREAM (OPENSTREAM FILE 'INPUT))
                           `(PROGN (CLOSEF? OLDVALUE]
             (CL:UNLESS (ZEROP (GETFILEPTR STREAM))
                    (SETFILEPTR STREAM 0))
             (CL:WHEN (for
 C in
 (CONSTANT (CHCON "Medley font")) always
 (EQ C (READCCODE STREAM)))
                 [CAR (NLSETQ [CL:WHEN (EQ 0 (SETQ VERSION (MEDLEYFONT.READ.ITEM
 STREAM 'VERSION]
                             `(,(FULLNAME STREAM)
                               ,(MEDLEYFONT.READ.ITEM
 STREAM 'DATE)
                               ,VERSION
                               ,@(MEDLEYFONT.READ.ITEM
 STREAM 'OTHERFONTPROPS])])])
)



(* ;; "Reading")


(DEFINEQ

(MEDLEYFONT.READ.FONT

  [LAMBDA (FILE CHARSETNOS FONT)
                             (* ; "Edited 31-Aug-2025 14:42 by rmk")


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


                                                             (* ; "Edited  9-Jul-2025 00:06 by rmk")


                                                             (* ; "Edited  6-Jul-2025 11:45 by rmk")

    (CL:UNLESS FILE (SETQ FILE FONT))
    (CL:WHEN (OR (type?
 FONTDESCRIPTOR FILE)
                 (LISTP FILE))
        (SETQ FILE (MEDLEYFONT.FILENAME
 FILE)))
    (SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
    (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
           (CL:UNLESS (MEDLEYFONT.FILEP
 STREAM)
               (ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM)))
           (LET ((*READTABLE* (FIND-READTABLE "INTERLISP"))
                 CSVECTORLOC NOTFOUND SINGLECSNO)
                (SETQ CSVECTORLOC (\FIXPIN STREAM))          (* ; 

                                                       "Byte location of the charset dispatch vector")


                (* ;; "We know now that this file has information about all requested charsets, including NIL entries for empty/slugglish ones in the middle of populated ones.  A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.")


                (SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT
 STREAM FONT))
                (CL:UNLESS (EQ CSVECTORLOC 0)                (* ; "Not empty")

                    [if
 (ILESSP CSVECTORLOC 0)
                        then
 
                             (* ;; 

  "File contains only one charset and it's the one we want. Its CHARSET number is in the first byte.")


                             (* ;; "If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.")


                             (SETFILEPTR STREAM (IMINUS CSVECTORLOC))
                             (SETQ SINGLECSNO (BIN STREAM))
                             (CL:WHEN CHARSETNOS
                                 (CL:UNLESS (AND (EQ SINGLECSNO (CAR CHARSETNOS))
                                                 (NULL (CDR CHARSETNOS)))
                                     (ERROR (CONCAT FILE 
                                                   " does not contain information for charsets "
                                                   (REMOVE SINGLECSNO CHARSETNOS)))))
                             (\SETCHARSETINFO FONT SINGLECSNO (MEDLEYFONT.READ.CHARSET
 STREAM 
                                                                     SINGLECSNO))
                      else
 
                           (* ;; 

                           "Gather all of the CSLOCS before reading, so that we always move forward")


                           (for
 CSNO CSLOC
                              in
 (OR CHARSETNOS (for
 I from
 0 to
 \MAXCHARSET collect
 I))
                              eachtime
 (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CSNO 
                                                                                    BYTESPERCELL)))
                                    (SETQ CSLOC (\FIXPIN STREAM))
                                    (CL:WHEN (ZEROP CSLOC)
                                           (push
 NOTFOUND CSNO)) unless
 (ZEROP CSLOC)
                              collect
 (CONS CSNO CSLOC)
                              finally
 (CL:WHEN (AND CHARSETNOS NOTFOUND)
                                          (ERROR FILE (CONCAT 
                                                        " does not contain information for charsets "
                                                             (DREVERSE NOTFOUND))))
                                    (for
 X CS in
 $$VAL do
 (SETQ CSNO (CAR X))
                                                          (SETFILEPTR STREAM (CDR X))
                                                          (\SETCHARSETINFO FONT CSNO (

                                                                              MEDLEYFONT.READ.CHARSET

                                                                                      STREAM CSNO])
                FONT])

(MEDLEYFONT.READ.CHARSET

  [LAMBDA (STREAM CHARSET)
                                   (* ; "Edited  4-Sep-2025 10:39 by rmk")


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


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


                                                             (* ; "Edited 17-Aug-2025 13:01 by rmk")


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


                                                             (* ; "Edited  9-Jul-2025 19:33 by rmk")


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


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


                                                             (* ; "Edited 23-May-2025 11:01 by rmk")


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


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


                                                             (* ; "Edited 14-May-2025 10:43 by rmk")


                                                             (* ; "Edited 12-May-2025 07:55 by rmk")

    (MEDLEYFONT.READ.ITEM
 STREAM 'CHARSETSTRING)             (* ; 

                                                             "Throwaway for looking with text editor")

    (LET (CSNO INDIRECT)
         (CL:UNLESS [EQ CHARSET (SETQ CSNO (MEDLEYFONT.READ.ITEM
 STREAM 'CHARSET]
             (ERROR "Charset mismatch" (LIST CHARSET CSNO)))
         (if
 (EQ 'INDIRECTCHARSET (CAR (MEDLEYFONT.PEEK.ITEM
 STREAM)))
             then
 
                  (* ;; "Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). ")


                  (SETQ INDIRECT (MEDLEYFONT.READ.ITEM
 STREAM 'INDIRECTCHARSET))
                  (\READCHARSET INDIRECT CHARSET)
           else
 (bind
 PAIR LABEL ITEM (CSINFO _ (create
 CHARSETINFO
                                                       WIDTHS _ NIL
                                                       OFFSETS _ NIL)) eachtime
 (SETQ PAIR
                                                                                 (

                                                                                 MEDLEYFONT.READ.ITEM

                                                                                  STREAM))
                                                                             (SETQ LABEL (CAR PAIR))
                                                                             (SETQ ITEM (CADR PAIR))
                   until
 (EQ LABEL 'STOP) do
 (SELECTQ LABEL
                                                 (WIDTHS (replace
 (CHARSETINFO WIDTHS) of
 CSINFO
                                                            with
 ITEM))
                                                 (OFFSETS (replace
 (CHARSETINFO OFFSETS) of
 CSINFO
                                                             with
 ITEM))
                                                 (IMAGEWIDTHS (replace
 (CHARSETINFO IMAGEWIDTHS)
                                                                 of
 CSINFO with
 ITEM))
                                                 (YWIDTHS (replace
 (CHARSETINFO YWIDTHS) of
 CSINFO
                                                             with
 ITEM))
                                                 (ASCENT (replace
 (CHARSETINFO CHARSETASCENT)
                                                            of
 CSINFO with
 ITEM))
                                                 (DESCENT (replace
 (CHARSETINFO CHARSETDESCENT)
                                                             of
 CSINFO with
 ITEM))
                                                 (LEFTKERN (replace
 (CHARSETINFO LEFTKERN)
                                                              of
 CSINFO with
 ITEM))
                                                 (BITMAP (replace
 (CHARSETINFO CHARSETBITMAP)
                                                            of
 CSINFO with
 ITEM))
                                                 (CSINFOPROPS (replace
 (CHARSETINFO CSINFOPROPS)
                                                                 of
 CSINFO with
 ITEM))
                                                 (CSCOMPLETEP (replace
 (CHARSETINFO CSCOMPLETEP)
                                                                 of
 CSINFO with
 ITEM))
                                                 (HELP "Unrecognized charsetinfo label" LABEL))
                   finally
 (CL:UNLESS (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                               (replace
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO
                                  with
 (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO)))
                         (replace
 (CHARSETINFO CHARSETNO) of
 CSINFO with
 CHARSET)
                         (RETURN CSINFO])

(MEDLEYFONT.READ.ITEM

  [LAMBDA (STREAM LABEL?)
                                    (* ; "Edited 27-Jul-2025 22:22 by rmk")


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


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


    (* ;; "Reads and returns the (label data) that starts at the current position in STREAM according to its storage type.  If LABEL? is provided, error if the data read does not have that label. ")


    (LET
     [(ITEM (GETSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM]
     (if
 ITEM
         then
 (PUTSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM NIL)
       else
 (LET ((*READTABLE* (FIND-READTABLE 'INTERLISP))
                  (*PACKAGE* (CL:FIND-PACKAGE 'INTERLISP))
                  LABEL NELTS)
                 (SETQ LABEL (RATOM STREAM))
                 (READCCODE STREAM)
                 [SETQ ITEM
                  (LIST LABEL (SELECTC (BIN STREAM)
                                  (SMALLPDATA (\WIN STREAM))
                                  (FIXPDATA (\FIXPIN STREAM))
                                  (PRINTDATA (READ STREAM))
                                  (ALISTDATA (bind
 X until
 [EQ 'STOP (CAR (SETQ X (

                                                                                 MEDLEYFONT.READ.ITEM

                                                                                   STREAM]
                                                collect
 (CONS (CAR X)
                                                              (CADR X))))
                                  (PLISTDATA (bind
 X until
 [EQ 'STOP (CAR (SETQ X (

                                                                                 MEDLEYFONT.READ.ITEM

                                                                                   STREAM]
                                                join
 X))
                                  (LISTDATA (bind
 ELT until
 [EQ 'STOP (CAR (SETQ ELT (

                                                                                 MEDLEYFONT.READ.ITEM

                                                                                      STREAM]
                                               collect
 (CADR ELT)
                                               finally
 (CL:WHEN (CADR ELT)
                                                              (NCONC $$VAL ELT))))
                                  (BITMAPDATA (\READBINARYBITMAP STREAM))
                                  (CLARRAYDATA (LET [[ARRAY (CL:MAKE-ARRAY (READ STREAM)
                                                                   :ELEMENT-TYPE
                                                                   (MEDLEYFONT.READ.ITEM
 STREAM
                                                                          'ELEMENT-TYPE]
                                                     (ALLFIXED (EQ 1 (BIN STREAM]
                                                    (for
 I from
 0 to
 (\FIXPIN STREAM)
                                                       do
 [CL:SETF (XCL:ROW-MAJOR-AREF ARRAY I)
                                                                 (CL:IF ALLFIXED
                                                                     (\FIXPIN STREAM)
                                                                     (CADR (MEDLEYFONT.READ.ITEM

                                                                            STREAM)))]
                                                       finally
 (RETURN ARRAY))))
                                  (ILPOINTERARRAY 
                                       (LET [(NELTS (\FIXPIN STREAM))
                                             (ORIG (BIN STREAM))
                                             (ALLFIXED (EQ 1 (BIN STREAM]
                                            (for
 I (ARRAY _ (ARRAY NELTS NIL NIL ORIG)) from
 ORIG
                                               to
 (CL:IF (EQ ORIG 1)
                                                      NELTS
                                                      (SUB1 NELTS))
                                               do
 (SETA ARRAY I (CL:IF ALLFIXED
                                                                    (\FIXPIN STREAM)
                                                                    (MEDLEYFONT.READ.ITEM
 STREAM I)))
                                               finally
 (RETURN ARRAY))))
                                  (ILNUMBERARRAY (LET ((NELTS (\FIXPIN STREAM))
                                                       (ORIG (BIN STREAM)))
                                                      (AIN (ARRAY NELTS (MEDLEYFONT.READ.ITEM

                                                                         STREAM
                                                                         'ARRAYTYP)
                                                                  NIL ORIG)
                                                           ORIG NELTS STREAM)))
                                  (WORDBLOCKDATA (LET* [(NWORDS (\FIXPIN STREAM))
                                                        (BLOCK (\ALLOCBLOCK (FOLDHI NWORDS 
                                                                                   WORDSPERCELL]
                                                       (\BINS STREAM BLOCK 0 (UNFOLD NWORDS 
                                                                                    BYTESPERWORD))
                                                       BLOCK))
                                  (HPRINTDATA (HREAD STREAM))
                                  (SHOULDNT "UNKNOWN MEDLEYFONT DATA TYPE"]
                                                             (* ; "Skip the EOL")

                 (READCCODE STREAM)))
     (CL:WHEN (AND LABEL? (NEQ LABEL? (CAR ITEM)))
         (ERROR (CONCAT LABEL? " item not found")
                ITEM))
     (CL:IF LABEL?
         (CADR ITEM)
         ITEM)])

(MEDLEYFONT.PEEK.ITEM

  [LAMBDA (STREAM LABEL?)
                                    (* ; "Edited  6-Jul-2025 14:10 by rmk")


    (* ;; "If previously peeked and not read, returns that item.  Otherwise calls the reader to get the new item. We always record the (LABEL DATA pair)")


    (LET [(PEEKEDITEM (GETSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM]
         (CL:UNLESS PEEKEDITEM
             (PUTSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM (SETQ PEEKEDITEM (MEDLEYFONT.READ.ITEM

                                                                            STREAM))))
         (CL:WHEN (AND LABEL? (NEQ LABEL? (CAR PEEKEDITEM)))
             (ERROR (CONCAT "Peeked " (CAR PEEKEDITEM)
                           " instead of " LABEL?)
                    PEEKEDITEM))
         (CL:IF LABEL?
             (CADR PEEKEDITEM)
             PEEKEDITEM)])

(MEDLEYFONT.READ.FONTPROPS

  [LAMBDA (STREAM)
                                           (* ; "Edited 25-May-2025 20:55 by rmk")


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


                                                             (* ; "Edited 14-May-2025 09:11 by rmk")

    (bind
 PAIR until
 [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM
 STREAM] collect
 PAIR])

(MEDLEYFONT.READ.VERIFIEDFONT

  [LAMBDA (STREAM FONT)
                                      (* ; "Edited  2-Sep-2025 23:52 by rmk")


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


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


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


                                                             (* ; "Edited 19-May-2025 17:42 by rmk")


                                                             (* ; "Edited 16-May-2025 10:28 by rmk")

    (CL:UNLESS FONT
        (SETQ FONT (create
 FONTDESCRIPTOR)))
    (LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS
 STREAM)))
         (for
 P VAL in
 FONTPROPS do
 (SETQ VAL (CADR P))
                                    (SELECTQ (CAR P)
                                        (FONTDEVICE (replace
 (FONTDESCRIPTOR FONTDEVICE) of
 FONT
                                                       with
 VAL))
                                        (FONTCOMPLETEP (replace
 (FONTDESCRIPTOR FONTCOMPLETEP)
                                                          of
 FONT with
 VAL))
                                        (FONTFAMILY (replace
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT
                                                       with
 VAL))
                                        (FONTSIZE (replace
 (FONTDESCRIPTOR FONTSIZE) of
 FONT
                                                     with
 VAL))
                                        (FONTFACE (replace
 (FONTDESCRIPTOR FONTFACE) of
 FONT
                                                     with
 VAL))
                                        (\SFAscent (replace
 (FONTDESCRIPTOR \SFAscent) of
 FONT
                                                      with
 VAL))
                                        (\SFDescent (replace
 (FONTDESCRIPTOR \SFDescent) of
 FONT
                                                       with
 VAL))
                                        (\SFHeight (replace
 (FONTDESCRIPTOR \SFHeight) of
 FONT
                                                      with
 VAL))
                                        (ROTATION (replace
 (FONTDESCRIPTOR ROTATION) of
 FONT
                                                     with
 VAL))
                                        (FONTSLUGWIDTH (replace
 (FONTDESCRIPTOR FONTSLUGWIDTH)
                                                          of
 FONT with
 VAL))
                                        (FONTTOMCCSFN (replace
 (FONTDESCRIPTOR FONTTOMCCSFN)
                                                         of
 FONT with
 VAL))
                                        (FONTDEVICESPEC 
                                             (replace
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT
                                                with
 VAL))
                                        (OTHERDEVICEFONTPROPS 
                                             (replace
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS)
                                                of
 FONT with
 VAL))
                                        (FONTSCALE (replace
 (FONTDESCRIPTOR FONTSCALE) of
 FONT
                                                      with
 VAL))
                                        (\SFFACECODE (replace
 (FONTDESCRIPTOR \SFFACECODE)
                                                        of
 FONT with
 VAL))
                                        (FONTAVGCHARWIDTH 
                                             (replace
 (FONTDESCRIPTOR FONTAVGCHARWIDTH) of
 FONT
                                                with
 VAL))
                                        (FONTCHARENCODING 
                                             (replace
 (FONTDESCRIPTOR FONTCHARENCODING) of
 FONT
                                                with
 VAL))
                                        (FONTCHARSETVECTOR 
                                             (replace
 (FONTDESCRIPTOR FONTCHARSETVECTOR) of
 FONT
                                                with
 VAL))
                                        (FONTHASLEFTKERNS 
                                             (replace
 (FONTDESCRIPTOR FONTHASLEFTKERNS) of
 FONT
                                                with
 VAL))
                                        (FONTEXTRAFIELD2 
                                             (replace
 (FONTDESCRIPTOR FONTEXTRAFIELD2) of
 FONT
                                                with
 VAL))
                                        (HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P")))
         FONT])
)



(* ;; "Writing")


(DEFINEQ

(MEDLEYFONT.WRITE.CHARSET

  [LAMBDA (FONT CHARSET STREAM NOINDIRECTS)
                  (* ; "Edited  4-Sep-2025 11:41 by rmk")


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


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


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


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


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


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


                                                             (* ; "Edited 13-May-2025 23:26 by rmk")

    (LET ((CSINFO (\INSURECHARSETINFO FONT CHARSET))
          CSCHARENCODING)
         (MEDLEYFONT.WRITE.ITEM
 STREAM 'CHARSETSTRING (MKSTRING CHARSET))
                                                             (* ; "For human file-scan")

         (MEDLEYFONT.WRITE.ITEM
 STREAM 'CHARSET CHARSET)
         (CL:UNLESS (OR (NULL CSINFO)
                        (fetch
 (CHARSETINFO CSSLUGP) of
 CSINFO))
                                                             (* ; 

                                                         "Slug info is determined by FONT properties")


             (* ;; "Copy the fonts charencoding down to each charset info so that it is available when the charsetinfo is read.  The fontdescriptor isn't available at that point and coercion could lead to fonts of different encodings.  At least this would make it possible to fix things up.")


             (if
 (CL:UNLESS NOINDIRECTS (INDIRECTCHARSETP CSINFO FONT))
                 then
 
                      (* ;; 

           "This charset is is taken entirely from on another file, no need to copy it to this file.")


                      (MEDLEYFONT.WRITE.ITEM
 STREAM 'INDIRECTCHARSET (CHARSETPROP CSINFO 'SOURCE)
                             NIL
                             'PRINT)
               else
 (MEDLEYFONT.WRITE.ITEM
 STREAM 'CSINFOPROPS (fetch
 (CHARSETINFO CSINFOPROPS)
                                                                  of
 CSINFO)
                           NIL
                           'ALIST)
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'WIDTHS (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
                    (CL:UNLESS [OR (EQ (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO)
                                       (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
                                   (for
 I (W _ (fetch
 (CHARSETINFO WIDTHS) of
 CSINFO))
                                        (IM _ (fetch
 (CHARSETINFO IMAGEWIDTHS) of
 CSINFO))
                                      from
 0 to
 (SUB1 (IPLUS \MAXTHINCHAR 3))
                                      always
 (EQ (\GETBASE W I)
                                                 (\GETBASE IM I]
                        (MEDLEYFONT.WRITE.ITEM
 STREAM 'IMAGEWIDTHS (fetch
 (CHARSETINFO IMAGEWIDTHS)
                                                                      of
 CSINFO)))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'OFFSETS (fetch
 (CHARSETINFO OFFSETS) of
 CSINFO))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'YWIDTHS (fetch
 (CHARSETINFO YWIDTHS) of
 CSINFO))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'ASCENT (fetch
 (CHARSETINFO CHARSETASCENT)
                                                             of
 CSINFO))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'DESCENT (fetch
 (CHARSETINFO CHARSETDESCENT)
                                                              of
 CSINFO))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'LEFTKERN (fetch
 (CHARSETINFO LEFTKERN)
                                                               of
 CSINFO))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'BITMAP (fetch
 (CHARSETINFO CHARSETBITMAP)
                                                             of
 CSINFO))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'CSCOMPLETEP (fetch
 (CHARSETINFO CSCOMPLETEP)
                                                                  of
 CSINFO))
                    (MEDLEYFONT.WRITE.ITEM
 STREAM 'STOP T)))])

(MEDLEYFONT.WRITE.ITEM

  [LAMBDA (STREAM LABEL ITEM EVENIFNIL TYPE BLOCKNELTS)
      (* ; "Edited 24-Jul-2025 22:07 by rmk")


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


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


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


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


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


                                                             (* ; "Edited 23-May-2025 10:58 by rmk")


                                                             (* ; "Edited 22-May-2025 10:31 by rmk")


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


                                                             (* ; "Edited 14-May-2025 00:07 by rmk")


    (* ;; "Writes ITEM preceded by LABEL.    BLOCKNELTS overrides the default for array blocks, because of the uncertainty/complexity in determining arrayblock length.")


    (LET [(*READTABLE* (FIND-READTABLE 'INTERLISP))
          (*PACKAGE* (CL:FIND-PACKAGE 'INTERLISP]
         (CL:WHEN (OR ITEM EVENIFNIL)
             (PRIN2 LABEL STREAM)
             (PRIN1 " " STREAM)
             (SELECTQ (OR TYPE (TYPENAME ITEM))
                 (SMALLP (BOUT STREAM SMALLPDATA)
                         (\WOUT STREAM ITEM))
                 (FIXP                                       (* ; "Must come after SMALLP")

                       (BOUT STREAM FIXPDATA)
                       (\FIXPOUT STREAM ITEM))
                 ((LITATOM STRINGP PRINT) 
                      (BOUT STREAM PRINTDATA)                (* ; 

                                                   "A printable Lisp object, even some lists (below)")

                      (PRIN2 ITEM STREAM))
                 (LISTP [if
 (for
 TAIL on
 ITEM always
 (ATOM (CAR TAIL))
                               finally
 

                                     (* ;; "Check the final CDR.")


                                     (CL:UNLESS (ATOM TAIL)
                                            (RETURN NIL)))
                            then
 (BOUT STREAM PRINTDATA)     (* ; "More compact for simple lists.")

                                 (PRIN2 ITEM STREAM)
                          else
 (BOUT STREAM LISTDATA)
                               (for
 TAIL on
 ITEM as
 I from
 1 do
 (MEDLEYFONT.WRITE.ITEM
 STREAM I
                                                                       (CAR TAIL)
                                                                       T)
                                                                (CL:UNLESS (LISTP (CDR TAIL))
                                                                    (MEDLEYFONT.WRITE.ITEM

                                                                     STREAM
                                                                     'STOP
                                                                     (CDR TAIL)
                                                                     T)
                                                                    (RETURN))])
                 (ALIST 
                        (* ;; 

                    " This could be done as LISTDATA, but this way it uses the alist keys as labels.")


                        (BOUT STREAM ALISTDATA)
                        (for
 X KEY in
 ITEM do
 (SETQ KEY (CAR X))
                                              (CL:UNLESS (OR (LITATOM KEY)
                                                             (SMALLP KEY))
                                                     (ERROR "NOT AN ALIST" ITEM))
                                              (MEDLEYFONT.WRITE.ITEM
 STREAM KEY (CDR X)
                                                     EVENIFNIL))
                        (MEDLEYFONT.WRITE.ITEM
 STREAM 'STOP T))
                 (PLIST (BOUT STREAM PLISTDATA)
                        (for
 DTAIL KEY on
 ITEM by
 (CDDR DTAIL)
                           do
 (SETQ KEY (CAR DTAIL))
                              (CL:UNLESS (OR (LITATOM KEY)
                                             (SMALLP KEY))
                                     (ERROR "NOT A PLIST" ITEM))
                              (MEDLEYFONT.WRITE.ITEM
 STREAM KEY (CADR DTAIL)
                                     EVENIFNIL))
                        (MEDLEYFONT.WRITE.ITEM
 STREAM 'STOP T))
                 (BITMAP (BOUT STREAM BITMAPDATA)
                         (\PRINTBINARYBITMAP ITEM STREAM))
                 ((ONED-ARRAY TWOD-ARRAY GENERAL-ARRAY)      (* ; 

                                                             "Note: can't be used in MAKEINIT fonts")

                      (BOUT STREAM CLARRAYDATA)
                      (PRIN2 (CL:ARRAY-DIMENSIONS ITEM)
                             STREAM)                         (* ; "A list, READ's OK")

                      (MEDLEYFONT.WRITE.ITEM
 STREAM 'ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ITEM))
                      (for
 I ALLFIXED ELT from
 0 to
 (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM))
                         first
 [SETQ ALLFIXED (for
 I from
 0 to
 (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM))
                                                 always
 (FIXP (XCL:ROW-MAJOR-AREF ITEM I]
                               (BOUT STREAM (CL:IF ALLFIXED
                                                1
                                                0))
                               (\FIXPOUT STREAM (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM)))
                         do
 (SETQ ELT (XCL:ROW-MAJOR-AREF ITEM I))
                            (CL:IF ALLFIXED
                                (\FIXPOUT STREAM ELT)
                                (MEDLEYFONT.WRITE.ITEM
 STREAM I ELT T))))
                 (ARRAYP (if
 (EQ 'POINTER (ARRAYTYP ITEM))
                             then
 (BOUT STREAM ILPOINTERARRAY)
                                  (\FIXPOUT STREAM (ARRAYSIZE ITEM))
                                  (BOUT STREAM (ARRAYORIG ITEM))
                                  (for
 I ALLFIXED from
 (ARRAYORIG ITEM)
                                     to
 (IPLUS (ARRAYORIG ITEM)
                                               (SUB1 (ARRAYSIZE ITEM)))
                                     first
 [SETQ ALLFIXED (for
 I from
 (ARRAYORIG ITEM)
                                                             to
 (IPLUS (ARRAYORIG ITEM)
                                                                       (SUB1 (ARRAYSIZE ITEM)))
                                                             always
 (FIXP (ELT ITEM I]
                                           (BOUT STREAM (CL:IF ALLFIXED
                                                            1
                                                            0))
                                     do
 
                                        (* ;; "Don't need to do the item recursion if all integers")


                                        (CL:IF ALLFIXED
                                            (\FIXPOUT STREAM (ELT ITEM I))
                                            (MEDLEYFONT.WRITE.ITEM
 STREAM I (ELT ITEM I)
                                                   T)))
                           else
 (BOUT STREAM ILNUMBERARRAY)
                                (\FIXPOUT STREAM (ARRAYSIZE ITEM))
                                (BOUT STREAM (ARRAYORIG ITEM))
                                (MEDLEYFONT.WRITE.ITEM
 STREAM 'ARRAYTYP (ARRAYTYP ITEM))
                                (AOUT ITEM (ARRAYORIG ITEM)
                                      (ARRAYSIZE ITEM)
                                      STREAM)))
                 (if
 (\BLOCKDATAP ITEM)
                     then
 
                          (* ;; "This assumes word-element blocks. We can distinguish pointer blocks (from the DTD, see BLOCKEQUALP), caller would have to tell us (a different TYPE?) whether we are looking at full integer or word blocks--how to interpret NELTS")


                          (BOUT STREAM WORDBLOCKDATA)
                          (CL:UNLESS BLOCKNELTS              (* ; "Why 3 ?")

                              (SETQ BLOCKNELTS (IPLUS \MAXTHINCHAR 3)))
                          (\FIXPOUT STREAM BLOCKNELTS)
                          (\BOUTS STREAM ITEM 0 (UNFOLD BLOCKNELTS BYTESPERWORD))
                   else
 (BOUT STREAM HPRINTDATA)             (* ; "A datatype?")

                        (HPRINT ITEM STREAM T T)))

             (* ;; "Terpri to make sure ratom is OK, also looks better")


             (TERPRI STREAM))])

(MEDLEYFONT.WRITE.FONTPROPS

  [LAMBDA (STREAM FONT)
                                      (* ; "Edited 12-Aug-2025 17:55 by rmk")


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


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


                                                             (* ; "Edited 22-May-2025 10:31 by rmk")


                                                             (* ; "Edited 19-May-2025 10:42 by rmk")


                                                             (* ; "Edited 14-May-2025 17:26 by rmk")


    (* ;; "RECORDFIELDACCESS would be more succinct but would depend on runtime availability of the record.  If the record changes, this and the reader have to be updated.")


    (* ;; "HPRINT would be obvious, but it would get charsetvector etc.")


    (* ;; "Exclude FONTCHARSETVECTOR and \SFFACECODE")


    (* ;; "Write even NIL values for default overerides")


    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTDEVICE (fetch
 (FONTDESCRIPTOR FONTDEVICE) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTCOMPLETEP (fetch
 (FONTDESCRIPTOR FONTCOMPLETEP) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTFAMILY (fetch
 (FONTDESCRIPTOR FONTFAMILY) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTSIZE (fetch
 (FONTDESCRIPTOR FONTSIZE) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTFACE (fetch
 (FONTDESCRIPTOR FONTFACE) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM '\SFAscent (fetch
 (FONTDESCRIPTOR \SFAscent) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM '\SFDescent (fetch
 (FONTDESCRIPTOR \SFDescent) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM '\SFHeight (fetch
 (FONTDESCRIPTOR \SFHeight) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'ROTATION (fetch
 (FONTDESCRIPTOR ROTATION) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTSLUGWIDTH (fetch
 (FONTDESCRIPTOR FONTSLUGWIDTH) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTTOMCCSFN (fetch
 (FONTDESCRIPTOR FONTTOMCCSFN) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTDEVICESPEC (fetch
 (FONTDESCRIPTOR FONTDEVICESPEC) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'OTHERDEVICEFONTPROPS (fetch
 (FONTDESCRIPTOR OTHERDEVICEFONTPROPS)
                                                           of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTSCALE (fetch
 (FONTDESCRIPTOR FONTSCALE) of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTAVGCHARWIDTH (fetch
 (FONTDESCRIPTOR FONTAVGCHARWIDTH)
                                                       of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTCHARENCODING (fetch
 (FONTDESCRIPTOR FONTCHARENCODING)
                                                       of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTHASLEFTKERNS (fetch
 (FONTDESCRIPTOR FONTHASLEFTKERNS)
                                                       of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'FONTEXTRAFIELD2 (fetch
 (FONTDESCRIPTOR FONTEXTRAFIELD2)
                                                      of
 FONT)
           T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'STOP T])

(MEDLEYFONT.WRITE.HEADER

  [LAMBDA (STREAM OTHERFONTPROPS)
                            (* ; "Edited 25-May-2025 20:51 by rmk")


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


                                                             (* ; "Edited 14-May-2025 17:01 by rmk")


    (* ;; "Me in first 2 bytes distinguishes MEDLEYFONT format from others")


    (PRINTOUT STREAM "Medley font" T)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'VERSION 0)
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'DATE (DATE))
    (MEDLEYFONT.WRITE.ITEM
 STREAM 'OTHERFONTPROPS OTHERFONTPROPS T])
)
(DEFINEQ

(MEDLEYFONT.FILENAME

  [LAMBDA (FONT CHARSET EXTENSION DIRECTORY)
                 (* ; "Edited  7-Oct-2025 11:50 by rmk")


                                                             (* ; "Edited  4-Sep-2025 08:48 by rmk")


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


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


                                                             (* ; "Edited 19-May-2025 17:42 by rmk")


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


    (* ;; "If EXTENSION and FILE are NIL, puts the file in the MEDLEYDIR fonts/medley[device]fonts/ directory with extension MEDLEY[device]FONT.  If CHARSET, goes in the CHARSET subdirectory.")


    (LET (FAMILY SIZE FACE DEVICE ROTATION FILENAME)
         (SPREADFONTSPEC (CL:IF (type?
 FONTDESCRIPTOR FONT)
                             (FONTPROP FONT 'SPEC)
                             (\FONT.CHECKARGS FONT)))
         (CL:UNLESS EXTENSION
             (SETQ EXTENSION (CONCAT "MEDLEY" (U-CASE DEVICE)
                                    "FONT")))
         (CL:UNLESS DIRECTORY
             [SETQ DIRECTORY (PSEUDOFILENAME (CONCAT (MEDLEYDIR)
                                                    (CONCAT "fonts/" (L-CASE EXTENSION)
                                                           "s"])
         (SETQ FILENAME (PACK* FAMILY (CL:IF (ILEQ SIZE 9)
                                          "0"
                                          "")
                               SIZE "-" (FONTFACETOATOM FACE)
                               (CL:IF (SMALLP CHARSET)
                                   (CONCAT "-C" (OCTALSTRING CHARSET))
                                   "")
                               "." EXTENSION))
         (CONCAT DIRECTORY ">" FILENAME])
)

(ADDTOVAR DISPLAYFONTEXTENSIONS
 MEDLEYDISPLAYFONT)

(ADDTOVAR DISPLAYCHARSETFNS
 (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET))

(ADDTOVAR INTERPRESSFONTEXTENSIONS
 MEDLEYINTERPRESSFONT)
(DECLARE%: EVAL@COMPILE DONTCOPY 
(DECLARE%: EVAL@COMPILE 

(RPAQQ PRINTDATA
 0)

(RPAQQ SMALLPDATA
 1)

(RPAQQ BITMAPDATA
 2)

(RPAQQ WORDBLOCKDATA
 3)

(RPAQQ CLARRAYDATA
 4)

(RPAQQ FIXPDATA
 5)

(RPAQQ ILPOINTERARRAY
 6)

(RPAQQ ILNUMBERARRAY
 11)

(RPAQQ HPRINTDATA
 7)

(RPAQQ ALISTDATA
 8)

(RPAQQ PLISTDATA
 9)

(RPAQQ LISTDATA
 10)


(CONSTANTS (PRINTDATA 0)
       (SMALLPDATA 1)
       (BITMAPDATA 2)
       (WORDBLOCKDATA 3)
       (CLARRAYDATA 4)
       (FIXPDATA 5)
       (ILPOINTERARRAY 6)
       (ILNUMBERARRAY 11)
       (HPRINTDATA 7)
       (ALISTDATA 8)
       (PLISTDATA 9)
       (LISTDATA 10))
)
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (2128 16674 (MEDLEYFONT.WRITE.FONT 2138 . 7104) (MEDLEYFONT.GETCHARSET 7106 . 11133) (
MEDLEYFONT.CHARSET? 11135 . 12604) (MEDLEYFONT.GETFILEPROP 12606 . 14706) (MEDLEYFONT.FILEP 14708 . 
16672)) (16700 38890 (MEDLEYFONT.READ.FONT 16710 . 21142) (MEDLEYFONT.READ.CHARSET 21144 . 26502) (
MEDLEYFONT.READ.ITEM 26504 . 32653) (MEDLEYFONT.PEEK.ITEM 32655 . 33517) (MEDLEYFONT.READ.FONTPROPS 
33519 . 33984) (MEDLEYFONT.READ.VERIFIEDFONT 33986 . 38888)) (38916 56753 (MEDLEYFONT.WRITE.CHARSET 
38926 . 43488) (MEDLEYFONT.WRITE.ITEM 43490 . 52543) (MEDLEYFONT.WRITE.FONTPROPS 52545 . 56098) (
MEDLEYFONT.WRITE.HEADER 56100 . 56751)) (56754 58719 (MEDLEYFONT.FILENAME 56764 . 58717)))))
STOP