(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) (FILECREATED " 5-May-2026 11:06:05" {MEDLEY}MEDLEYFONTFORMAT.;317 67145 :EDIT-BY rmk :CHANGES-TO (FNS MEDLEYFONT.READ.FONT MEDLEYFONT.FILENAME) :PREVIOUS-DATE " 4-May-2026 14:58:55" {MEDLEY}MEDLEYFONTFORMAT.;316) (PRETTYCOMPRINT MEDLEYFONTFORMATCOMS) (RPAQQ MEDLEYFONTFORMATCOMS [ (* ;; "Eventually, MEDLEYFONT should be a package") (* ;; "Main public entries") (FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.GETCHARSET.INTERNAL MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP MEDLEYFONT.FILEP MEDLEYFONT.FILEVERSION) (* ;; "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 OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 30-Mar-2026 12:55 by rmk") (* ; "Edited 25-Mar-2026 10:48 by rmk") (* ; "Edited 22-Mar-2026 18:19 by rmk") (* ; "Edited 21-Mar-2026 15:32 by rmk") (* ; "Edited 18-Mar-2026 23:16 by rmk") (* ; "Edited 20-Jan-2026 22:36 by rmk") (* ; "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 14-May-2025 17:45 by rmk") (* ;; "This writes all of the information in the fontdescriptor FONT, this doesn't allow for selecting a subset of character sets to write. The information allows all of the current CHARSETINFOs to be reconstructed when the font is read. An uninstantiated charset (CSINFO is NIL) will be read as NIL, and the CSINFO for an empty charset (CSINFO is CSSLUGP) will be installed as the font's slug. The reader can select a subset of the charsets for MEDLEYFONT.GETCHARSET to read. ") (SETQ FONT (FONTCREATE FONT)) (CL:WITH-OPEN-FILE (STREAM (MEDLEYFONT.FILENAME FILE) :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (MEDLEYFONT.WRITE.HEADER STREAM OTHERFONTPROPS FONT) (* ;; "Right after the header, leave bytes for the maxcharset and a pointer to either the charset dispatch vector or a single-charset. Ptr is before fontproperties, vector is after, so MEDLEYFONT.GETCHARSET can skip the font stuff.") (MEDLEYFONT.WRITE.ITEM STREAM 'MAXCHARSET (MAXCHARSET FONT)) (LET ((CHARSETLOCS (CL:MAKE-ARRAY (ADD1 (MAXCHARSET FONT)) :INITIAL-ELEMENT 0)) (FONTCHARENCODING (FONTPROP FONT 'CHARENCODING)) (*READTABLE* (FIND-READTABLE "INTERLISP")) CSVECTORPTRLOC CSLOC SINGLECS) [SETQ SINGLECS (AND (ILEQ (FONTPROP FONT 'NINSTANTIATEDCHARSETS) 1) (OR (EQ 0 (FONTPROP FONT 'NEMPTYCHARSETS)) (EQ 0 (FONTPROP FONT 'NUNINSTANTIATEDCHARSETS] (SETQ CSVECTORPTRLOC (GETFILEPTR STREAM)) (\FIXPOUT STREAM 0) (* ;  "Space for the pointer to the charset info") (MEDLEYFONT.WRITE.FONTPROPS STREAM FONT) (PRINTOUT STREAM "CHARSET LOCATIONS" T) (* ; "Signpost for debugging") (SETQ CSLOC (GETFILEPTR STREAM)) (SETFILEPTR STREAM CSVECTORPTRLOC) (* ;  "Store the address of the charset info") (\FIXPOUT STREAM (CL:IF SINGLECS (IMINUS CSLOC) CSLOC)) (* ; "Negative for single") (SETFILEPTR STREAM CSLOC) [if SINGLECS then (* ;; "At most one instantiated, others are either all uninstantiated or all empty, no need for the vector") (if [SETQ SINGLECS (find CSNO CSINFO from 0 to (MAXCHARSET FONT) suchthat (AND (SETQ CSINFO (\GETCHARSETINFO FONT CSNO)) (NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO] then (\FIXPOUT STREAM SINGLECS) (* ;  "Charsetno prefix as cell, not byte") (\BOUT STREAM (CL:IF (EQ 0 (FONTPROP FONT 'NUNINSTANTIATEDCHARSETS)) 1 2)) (* ; "All others") (MEDLEYFONT.WRITE.CHARSET FONT SINGLECS STREAM NOINDIRECTS) else (* ;;  "Fake charset meaning all the same: -1 if all empty, -2 if all uninstantiated.") (\FIXPOUT STREAM (CL:IF (EQ 0 (FONTPROP FONT 'NUNINSTANTIATEDCHARSETS)) -1 -2))) else (* ;; "Allocate the vector space") (for CSNO from 0 to (MAXCHARSET FONT) do (\FIXPOUT STREAM 0)) (for CSNO CSINFO from 0 to (MAXCHARSET FONT) when (SETQ CSINFO (\GETCHARSETINFO FONT CSNO)) do (* ;; "LOC remains zero if the charset is NIL=uninstantiated. Could have initialized array to -1, flipped to zero here if uninstantiated") (if (fetch (CHARSETINFO CSSLUGP) of CSINFO) then (CL:SETF (CL:SVREF CHARSETLOCS CSNO) -1) else (CL:SETF (CL:SVREF CHARSETLOCS CSNO) (GETFILEPTR STREAM)) (MEDLEYFONT.WRITE.CHARSET FONT CSNO STREAM NOINDIRECTS))) (SETFILEPTR STREAM CSLOC) (* ; "Fill in the vector") (for CSNO from 0 to (MAXCHARSET FONT) do (\FIXPOUT STREAM (CL:SVREF CHARSETLOCS CSNO ] (FULLNAME STREAM]) (MEDLEYFONT.GETCHARSET [LAMBDA (STREAM CHARSET FONT) (* ; "Edited 15-Apr-2026 13:29 by rmk") (* ; "Edited 12-Apr-2026 22:14 by rmk") (* ; "Edited 6-Apr-2026 09:45 by rmk") (* ; "Edited 30-Mar-2026 08:42 by rmk") (* ; "Edited 24-Mar-2026 00:04 by rmk") (* ; "Edited 21-Mar-2026 15:28 by rmk") (* ; "Edited 17-Mar-2026 11:42 by rmk") (* ; "Edited 14-Feb-2026 00:36 by rmk") (* ; "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 %"Medley...%" has been checked, FONT is consistent with information in the file, and we are positioned after the header information, at the location of CSLOC.") (SETQ CHARSET (CHARSET.DECODE CHARSET)) (RESETLST (CL:UNLESS (\GETSTREAM STREAM 'INPUT T) [RESETSAVE (SETQ STREAM (OPENSTREAM STREAM 'INPUT)) `(PROGN (CLOSEF? OLDVALUE]) (MEDLEYFONT.FILEVERSION STREAM 1) (MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET) (MEDLEYFONT.GETCHARSET.INTERNAL STREAM CHARSET FONT (\FIXPIN STREAM)))]) (MEDLEYFONT.GETCHARSET.INTERNAL [LAMBDA (STREAM CHARSET FONT CSLOC) (* ; "Edited 15-Apr-2026 11:09 by rmk") (* ; "Edited 12-Apr-2026 14:04 by rmk") (* ; "Edited 29-Mar-2026 22:42 by rmk") (* ;; "Caller guarantees STREAM and CSLOC as the location of the charset info. CHARSET is less than (MAXCHARSTE FONT).") (if (IGREATERP CHARSET (fetch (FONTDESCRIPTOR MAXCHARSET) of FONT)) then (SLUGCSINFO FONT) else (LET (CSINFO FILECHARSET ALLOTHERS) (if (ILESSP CSLOC 0) then (* ;;  "File contains at most one instantiated charset, others are either all empty or all uninstantiated") (SETFILEPTR STREAM (IMINUS CSLOC)) (SETQ FILECHARSET (\FIXPIN STREAM)) (SETQ ALLOTHERS (BIN STREAM)) (* ; "If not the one we wanted") [SELECTQ FILECHARSET (-1 (* ; "All empty") (SLUGCSINFO FONT)) (-2 (* ; "All uninstantiated") NIL) (PROGN (if (IEQP CHARSET FILECHARSET) then (MEDLEYFONT.READ.CHARSET STREAM CHARSET) elseif (EQ 1 ALLOTHERS) then (SLUGCSINFO FONT] else (* ;;  "CSLOC points to the vector, what does it say about the requested CHARSET?") (SETFILEPTR STREAM (IPLUS CSLOC (UNFOLD CHARSET BYTESPERCELL))) (SELECTQ (SETQ CSLOC (\FIXPIN STREAM)) (0 NIL) (-1 (SLUGCSINFO FONT)) (PROGN (SETFILEPTR STREAM CSLOC) (MEDLEYFONT.READ.CHARSET STREAM CHARSET FONT]) (MEDLEYFONT.CHARSET? [LAMBDA (FILE CHARSET) (* ; "Edited 16-Mar-2026 00:31 by rmk") (* ; "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") (SETQ CHARSET (CHARSET.DECODE CHARSET)) (LET [(CHARSETS (MEDLEYFONT.GETFILEPROP FILE 'CHARSETS] (CL:IF CHARSET (CAR (MEMB CHARSET CHARSETS)) CHARSETS)]) (MEDLEYFONT.GETFILEPROP [LAMBDA (FILE PROP) (* ; "Edited 4-May-2026 09:57 by rmk") (* ; "Edited 16-Apr-2026 22:30 by rmk") (* ; "Edited 15-Apr-2026 00:19 by rmk") (* ; "Edited 12-Apr-2026 19:31 by rmk") (* ; "Edited 31-Mar-2026 14:43 by rmk") (* ; "Edited 28-Mar-2026 22:59 by rmk") (* ; "Edited 24-Mar-2026 10:56 by rmk") (* ; "Edited 20-Mar-2026 13:23 by rmk") (* ; "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") (SETQ FILE (OR (MEDLEYFONT.FILENAME FILE) (ERROR "FILE NOT FOUND" FILE))) (CL:WITH-OPEN-FILE (STREAM (OR (MEDLEYFONT.FILENAME FILE) FILE) :DIRECTION :INPUT) (LET (HEADERPROPS CSLOC SINGLECS MAXCHARSET) (CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP STREAM)) (ERROR "Not a MEDLEYFONT file" (FULLNAME STREAM))) (SETQ MAXCHARSET (MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET)) (SETQ CSLOC (\FIXPIN STREAM)) (SELECTQ PROP (OTHERPROPS (CDDR HEADERPROPS)) (DATE (CADR HEADERPROPS)) (MAXCHARSET MAXCHARSET) (FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)) (CHARSETS (* ; "Skips slugs and indirects") (if (ILESSP CSLOC 0) then (* ;; "File contains only one instantiated charset ") (SETFILEPTR STREAM (IMINUS CSLOC)) (SETQ SINGLECS (\FIXPIN STREAM)) (CL:WHEN (IGEQ SINGLECS 0) (CONS SINGLECS)) else (SETFILEPTR STREAM CSLOC) (for CS from 0 to MAXCHARSET when (IGREATERP (\FIXPIN STREAM) 0) collect CS))) (INDIRECTS (* ;;  "These are fully spelled out FONTSPECS, no need to fill in defaults") (CADR (ASSOC 'ICS (MEDLEYFONT.READ.FONTPROPS STREAM)))) (ERROR "Unknown MEDLEYFONT property"]) (MEDLEYFONT.FILEP [LAMBDA (FILE) (* ; "Edited 30-Mar-2026 11:58 by rmk") (* ; "Edited 29-Mar-2026 10:50 by rmk") (* ; "Edited 24-Mar-2026 00:55 by rmk") (* ; "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) [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))) (* ;; "This sticks the file's MAXCHARSET on the stream, so MEDLEYFONT.GETCHARSET can do a bounds check even without decoding all the other font information. ") [CAR (NLSETQ `([VERSION ,(MKATOM (MEDLEYFONT.READ.ITEM STREAM 'VERSION] (FILE ,(FULLNAME STREAM)) [DATE ,(MEDLEYFONT.READ.ITEM STREAM 'DATE] ,@(MEDLEYFONT.READ.ITEM STREAM 'OTHERFONTPROPS])])]) (MEDLEYFONT.FILEVERSION [LAMBDA (FILE REQUIRED) (* ; "Edited 17-Apr-2026 09:32 by rmk") (* ; "Edited 4-Apr-2026 00:10 by rmk") (* ; "Edited 30-Mar-2026 12:08 by rmk") (* ; "Edited 29-Mar-2026 11:21 by rmk") (LET* [(PROPS (OR (MEDLEYFONT.FILEP FILE) (ERROR "Not a Medley font" FILE))) (FILEVERSION (CADR (ASSOC 'VERSION PROPS] (CL:WHEN (AND REQUIRED (NEQ REQUIRED FILEVERSION)) (ERROR (CONCAT "Medley font version is " FILEVERSION ", " REQUIRED " is required") FILE)) FILEVERSION]) ) (* ;; "Reading") (DEFINEQ (MEDLEYFONT.READ.FONT [LAMBDA (FILE CHARSETS NOERROR DIRECTORY) (* ; "Edited 5-May-2026 11:05 by rmk") (* ; "Edited 15-Apr-2026 00:50 by rmk") (* ; "Edited 12-Apr-2026 00:30 by rmk") (* ; "Edited 6-Apr-2026 09:07 by rmk") (* ; "Edited 4-Apr-2026 15:29 by rmk") (* ; "Edited 31-Mar-2026 22:53 by rmk") (* ; "Edited 30-Mar-2026 12:08 by rmk") (* ; "Edited 26-Mar-2026 23:23 by rmk") (* ; "Edited 25-Mar-2026 00:07 by rmk") (* ; "Edited 21-Mar-2026 00:31 by rmk") (* ; "Edited 18-Mar-2026 23:51 by rmk") (* ; "Edited 17-Mar-2026 10:16 by rmk") (* ; "Edited 2-Mar-2026 20:40 by rmk") (* ; "Edited 20-Jan-2026 22:31 by rmk") (* ; "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") (* ;; "Returns a font descriptor containing the requested charsets from FILE. If FILE is a FONTSPEC, it is coerced to a standard font name on DIRECTORY.") (CL:WHEN [OR (MEMB CHARSETS '(NIL ALL)) (SETQ CHARSETS (SORT (CHARSET.DECODE (MKLIST CHARSETS) NOERROR] (RESETLST (LET ((FILENAME (MEDLEYFONT.FILENAME FILE DIRECTORY)) STREAM FONT CSLOC MAXCHARSET) (* ;  "CL:OPEN-FILE doesn't exist in the init") (if FILENAME then [RESETSAVE (SETQ STREAM (OPENSTREAM FILENAME 'INPUT)) '(PROGN (CLOSEF? OLDVALUE] (MEDLEYFONT.FILEVERSION STREAM 1) (SETQ MAXCHARSET (MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET)) (SETQ CSLOC (\FIXPIN STREAM)) (* ;  "CSLOC here so MEDLEYFONT.GETCHARSET can skip over the font stuff.") (SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT STREAM)) (for CSNO from 0 to MAXCHARSET while CHARSETS when (if (EQ CHARSETS 'ALL) elseif (EQ CSNO (CAR CHARSETS)) then (pop CHARSETS)) do (\SETCHARSETINFO FONT CSNO (MEDLEYFONT.GETCHARSET.INTERNAL STREAM CSNO FONT CSLOC))) FONT elseif NOERROR then NIL else (ERROR "FONT FILE NOT FOUND" FILE)))))]) (MEDLEYFONT.READ.CHARSET [LAMBDA (STREAM CHARSET FONT) (* ; "Edited 4-May-2026 12:38 by rmk") (* ; "Edited 30-Apr-2026 08:56 by rmk") (* ; "Edited 14-Apr-2026 22:32 by rmk") (* ; "Edited 12-Apr-2026 13:59 by rmk") (* ; "Edited 30-Mar-2026 08:36 by rmk") (* ; "Edited 22-Mar-2026 00:21 by rmk") (* ; "Edited 17-Mar-2026 10:00 by rmk") (* ; "Edited 14-Feb-2026 00:36 by rmk") (* ; "Edited 4-Sep-2025 10:39 by rmk") (* ; "Edited 17-Aug-2025 13:01 by rmk") (* ; "Edited 15-Jul-2025 11:27 by rmk") (* ; "Edited 12-May-2025 07:55 by rmk") (* ;  "Throwaway for looking with text editor") (LET (CSNO) (CL:UNLESS [EQ CHARSET (SETQ CSNO (MKATOM (MEDLEYFONT.READ.ITEM STREAM 'CS] (ERROR "Charset mismatch" (LIST CHARSET CSNO))) (if (EQ 'ICS (CAR (MEDLEYFONT.PEEK.ITEM STREAM))) then (* ;; "Indirect: Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). The indirect source is in the same directory and has the same extension as the starting file.") (MEDLEYFONT.GETCHARSET (MEDLEYFONT.FILENAME (MAKEFONTSPEC (MEDLEYFONT.READ.ITEM STREAM 'ICS) NIL NIL NIL NIL (FONTPROP FONT 'DEVICESPEC)) (FULLNAME STREAM)) CHARSET FONT) 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 15-Apr-2026 23:16 by rmk") (* ; "Edited 12-Apr-2026 12:51 by rmk") (* ; "Edited 28-Mar-2026 17:03 by rmk") (* ; "Edited 23-Mar-2026 11:37 by rmk") (* ; "Edited 19-Mar-2026 11:48 by rmk") (* ; "Edited 18-Mar-2026 08:18 by rmk") (* ; "Edited 2-Mar-2026 20:40 by rmk") (* ; "Edited 20-Jan-2026 22:31 by rmk") (* ; "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") (LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)) (FONT (create FONTDESCRIPTOR FONTCHARSETVECTOR _ NIL))) (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)) (FONTCOERCEDP (replace (FONTDESCRIPTOR FONTCOERCEDP) 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)) (MAXCHARSET (replace (FONTDESCRIPTOR MAXCHARSET) 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)) (FONTAVGCHARWIDTH (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with VAL)) (FONTCHARENCODING (replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT with VAL)) (FONTHASLEFTKERNS (replace (FONTDESCRIPTOR FONTHASLEFTKERNS) of FONT with VAL)) (FONTEXTRAFIELD2 (replace (FONTDESCRIPTOR FONTEXTRAFIELD2) of FONT with VAL)) (INDIRECTS (* ; "Only a file prop")) (\SFFACECODE (* ; "to be deprecated")) (HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P"))) (replace (FONTDESCRIPTOR FONTFILENAME) of FONT with (PSEUDOFILENAME (FULLNAME STREAM))) (* ;  "PSEUDOFILENAME so that a deployed fontfile is redirected in a new sysout/makesys environment ") (replace (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT with (\CREATEFONTCHARSETVECTOR FONT)) FONT]) ) (* ;; "Writing") (DEFINEQ (MEDLEYFONT.WRITE.CHARSET [LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 4-May-2026 11:53 by rmk") (* ; "Edited 1-Apr-2026 09:20 by rmk") (* ; "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 INDIRECT) (MEDLEYFONT.WRITE.ITEM STREAM 'CS (MKSTRING CHARSET)) (* ; "String for human file-scan") (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 (SETQ INDIRECT (INDIRECTCHARSETP CSINFO FONT))) then (* ;; "This charset is is taken entirely from another file, no need to copy it to this file. Leave off the redundant FONTSPEC stuff") (MEDLEYFONT.WRITE.ITEM STREAM 'ICS (LIST* (fetch (FONTSPEC FSFAMILY) of INDIRECT) (fetch (FONTSPEC FSSIZE) of INDIRECT) (fetch (FONTSPEC FSFACE) of INDIRECT) (CL:UNLESS (EQ (FONTPROP FONT 'ROTATION) (fetch (FONTSPEC FSROTATION) of INDIRECT)) (fetch (FONTSPEC FSROTATION) of INDIRECT))) 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 4-May-2026 09:57 by rmk") (* ; "Edited 31-Mar-2026 14:53 by rmk") (* ; "Edited 23-Mar-2026 11:52 by rmk") (* ; "Edited 19-Mar-2026 11:48 by rmk") (* ; "Edited 18-Mar-2026 08:17 by rmk") (* ; "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 ") (* ;; "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 'FONTCOERCEDP (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 'MAXCHARSET (fetch (FONTDESCRIPTOR MAXCHARSET) 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 'INDIRECTS (for CS CSINFO INDIRECT (FSPEC _ (FONTPROP FONT 'DEVICESPEC)) from 0 to (MAXCHARSET FONT) when (SETQ CSINFO (\GETCHARSETINFO FONT CS)) when (SETQ INDIRECT (CHARSETPROP CSINFO 'SOURCE)) unless (EQUAL FSPEC INDIRECT) unless (MEMBER INDIRECT $$VAL) do (push $$VAL INDIRECT)) T) (MEDLEYFONT.WRITE.ITEM STREAM 'STOP T]) (MEDLEYFONT.WRITE.HEADER [LAMBDA (STREAM OTHERFONTPROPS FONT) (* ; "Edited 29-Mar-2026 10:45 by rmk") (* ; "Edited 24-Mar-2026 00:55 by rmk") (* ; "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 "1") (MEDLEYFONT.WRITE.ITEM STREAM 'DATE (DATE)) (MEDLEYFONT.WRITE.ITEM STREAM 'OTHERFONTPROPS OTHERFONTPROPS T]) ) (DEFINEQ (MEDLEYFONT.FILENAME [LAMBDA (FILE DIRECTORY) (* ; "Edited 5-May-2026 11:02 by rmk") (* ; "Edited 4-May-2026 09:01 by rmk") (* ; "Edited 30-Apr-2026 08:54 by rmk") (* ; "Edited 15-Apr-2026 00:41 by rmk") (* ; "Edited 23-Jan-2026 15:10 by rmk") (* ; "Edited 7-Oct-2025 11:50 by rmk") (* ; "Edited 4-Sep-2025 08:48 by rmk") (* ; "Edited 10-Jun-2025 11:02 by rmk") (CL:WHEN (\GETSTREAM FILE 'INPUT T) (SETQ FILE (FULLNAME FILE))) (CL:WHEN DIRECTORY (* ; "Keep the host/directory.") (SETQ DIRECTORY (PACKFILENAME 'NAME NIL 'EXTENSION NIL 'VERSION NIL 'BODY DIRECTORY))) (if (type? FONTSPEC FILE) then (SETQ FILE (\FONT.CHECKARGS FILE NIL NIL NIL NIL T)) (CL:UNLESS DIRECTORY [SETQ DIRECTORY (CAR (MKLIST (FONTDEVICEPROP FILE 'FONTDIRECTORIES]) (PACKFILENAME 'DIRECTORY DIRECTORY 'BODY (\FONTFILENAME FILE)) elseif FILE then (* ; "File name") (PACKFILENAME 'BODY FILE 'DIRECTORY DIRECTORY]) ) (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 (2199 20663 (MEDLEYFONT.WRITE.FONT 2209 . 8612) (MEDLEYFONT.GETCHARSET 8614 . 10695) ( MEDLEYFONT.GETCHARSET.INTERNAL 10697 . 12950) (MEDLEYFONT.CHARSET? 12952 . 13830) ( MEDLEYFONT.GETFILEPROP 13832 . 17396) (MEDLEYFONT.FILEP 17398 . 19826) (MEDLEYFONT.FILEVERSION 19828 . 20661)) (20689 44110 (MEDLEYFONT.READ.FONT 20699 . 24534) (MEDLEYFONT.READ.CHARSET 24536 . 30297) ( MEDLEYFONT.READ.ITEM 30299 . 36448) (MEDLEYFONT.PEEK.ITEM 36450 . 37312) (MEDLEYFONT.READ.FONTPROPS 37314 . 37779) (MEDLEYFONT.READ.VERIFIEDFONT 37781 . 44108)) (44136 64607 (MEDLEYFONT.WRITE.CHARSET 44146 . 49791) (MEDLEYFONT.WRITE.ITEM 49793 . 58846) (MEDLEYFONT.WRITE.FONTPROPS 58848 . 63732) ( MEDLEYFONT.WRITE.HEADER 63734 . 64605)) (64608 66260 (MEDLEYFONT.FILENAME 64618 . 66258))))) STOP