MEDLEYFONTFORMAT: Version 1. MAXCHARSET, distinguish empty for uninstantiated, simpler arguments
This commit is contained in:
rmkaplan
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED "14-Feb-2026 00:39:34" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;250 60733
|
||||
(FILECREATED " 4-Apr-2026 15:29:42" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;301 63158
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS MEDLEYFONT.GETCHARSET MEDLEYFONT.READ.CHARSET)
|
||||
:CHANGES-TO (FNS MEDLEYFONT.READ.FONT MEDLEYFONT.FILEVERSION)
|
||||
|
||||
:PREVIOUS-DATE "23-Jan-2026 15:10:16" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;249)
|
||||
:PREVIOUS-DATE " 1-Apr-2026 10:05:10" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;299)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
|
||||
@@ -18,8 +18,8 @@
|
||||
|
||||
(* ;; "Main public entries")
|
||||
|
||||
(FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP
|
||||
MEDLEYFONT.FILEP)
|
||||
(FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.GETCHARSET.INTERNAL
|
||||
MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP MEDLEYFONT.FILEP MEDLEYFONT.FILEVERSION)
|
||||
|
||||
(* ;; "Reading")
|
||||
|
||||
@@ -59,191 +59,211 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.WRITE.FONT
|
||||
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 20-Jan-2026 22:36 by rmk")
|
||||
[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 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")
|
||||
|
||||
(* ;; "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))
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FILE 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)
|
||||
(CL:WITH-OPEN-FILE
|
||||
(STREAM (MEDLEYFONT.FILENAME FILE)
|
||||
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
|
||||
(MEDLEYFONT.WRITE.HEADER STREAM OTHERFONTPROPS FONT)
|
||||
|
||||
(* ;; "Figure out the actual non empty/sluggish charsets that will be wrtitten.")
|
||||
(* ;; "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.")
|
||||
|
||||
(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))
|
||||
(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")
|
||||
|
||||
(* ;; "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.")
|
||||
(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")
|
||||
|
||||
(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
|
||||
(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")
|
||||
|
||||
(* ;;
|
||||
"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])
|
||||
(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 14-Feb-2026 00:36 by rmk")
|
||||
[LAMBDA (STREAM CHARSET FONT BASE) (* ; "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 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.")
|
||||
(* ;; "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.")
|
||||
|
||||
(CL:UNLESS (<= 0 CHARSET \MAXCHARSET)
|
||||
(\ILLEGAL.ARG CHARSET))
|
||||
(SETQ CHARSET (CHARSET.DECODE CHARSET))
|
||||
(RESETLST
|
||||
(CL:UNLESS (\GETSTREAM STREAM 'INPUT T)
|
||||
(CL:WHEN (type? FONTSPEC STREAM)
|
||||
(SETQ STREAM (MEDLEYFONT.FILENAME STREAM BASE)))
|
||||
[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")
|
||||
`(PROGN (CLOSEF? OLDVALUE])
|
||||
(MEDLEYFONT.FILEVERSION STREAM 1)
|
||||
(CL:IF (IGREATERP CHARSET (MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET))
|
||||
(SLUGCSINFO FONT)
|
||||
(MEDLEYFONT.GETCHARSET.INTERNAL STREAM CHARSET FONT (\FIXPIN STREAM))))])
|
||||
|
||||
(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.GETCHARSET.INTERNAL
|
||||
[LAMBDA (STREAM CHARSET FONT CSLOC) (* ; "Edited 29-Mar-2026 22:42 by rmk")
|
||||
|
||||
(MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT))
|
||||
(replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with NIL)
|
||||
(* ;; "Caller guarantees STREAM and CSLOC as the location of the charset info. CHARSET is less than (MAXCHARSTE FONT).")
|
||||
|
||||
(* ;;
|
||||
"One charset doesn't %"complete%" a complete font--maybe that's only an incore property? ")
|
||||
(LET (CSINFO FILECHARSET ALLOTHERS)
|
||||
(if (ILESSP CSLOC 0)
|
||||
then
|
||||
(* ;;
|
||||
"File contains at most one instantiated charset, others are either all empty or all uninstantiated")
|
||||
|
||||
(* ;; "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.")
|
||||
(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?")
|
||||
|
||||
(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 FONT))))])
|
||||
(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 15-Jul-2025 15:21 by rmk")
|
||||
[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")
|
||||
|
||||
(* ;; "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])
|
||||
(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 27-Aug-2025 17:12 by rmk")
|
||||
[LAMBDA (FILE PROP) (* ; "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")
|
||||
(* ; "Edited 14-May-2025 17:46 by rmk")
|
||||
(CL:UNLESS (OR (LITATOM FILE)
|
||||
(STRINGP FILE))
|
||||
[SETQ FILE (CAR (FONTFILES (FONTPROP (FONTCREATE FILE)
|
||||
'SPEC])
|
||||
[if (\GETSTREAM FILE 'INPUT T)
|
||||
then (* ; "Shouldn't need to reopen")
|
||||
(SETQ FILE (FULLNAME FILE))
|
||||
elseif (OR (LITATOM FILE)
|
||||
(STRINGP FILE))
|
||||
else (SETQ FILE (CAR (FONTFILES (FONTPROP (FONTCREATE FILE)
|
||||
'SPEC]
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
|
||||
(LET (HEADERPROPS CSVECTORLOC)
|
||||
(LET (HEADERPROPS CSLOC SINGLECS)
|
||||
(CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP STREAM))
|
||||
(ERROR "Not a MEDLEYFONT file" (FULLNAME STREAM)))
|
||||
(SETQ CSVECTORLOC (\FIXPIN STREAM))
|
||||
(MEDLEYFONT.READ.ITEM STREAM 'MAXCHARSET)
|
||||
(SETQ CSLOC (\FIXPIN STREAM))
|
||||
(SELECTQ PROP
|
||||
(OTHERPROPS (CDDR HEADERPROPS))
|
||||
(DATE (CADR HEADERPROPS))
|
||||
(FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM))
|
||||
(CHARSETS (if (ILESSP CSVECTORLOC 0)
|
||||
(CHARSETS (if (ILESSP CSLOC 0)
|
||||
then
|
||||
(* ;; "File contains only one charset ")
|
||||
(* ;; "File contains only one instantiated 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)))
|
||||
(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 (CADR (ASSOC 'INDIRECTS (MEDLEYFONT.READ.FONTPROPS STREAM))))
|
||||
(ERROR "Unknown MEDLEYFONT property"])
|
||||
|
||||
(MEDLEYFONT.FILEP
|
||||
[LAMBDA (FILE) (* ; "Edited 6-Jul-2025 11:44 by rmk")
|
||||
[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")
|
||||
@@ -258,7 +278,7 @@
|
||||
(* ;; "If FILE is an open stream, it is left open. Otherwise it is opened and closed.")
|
||||
|
||||
(RESETLST
|
||||
[LET (STREAM VERSION DATE)
|
||||
[LET (STREAM)
|
||||
[if (\GETSTREAM FILE 'INPUT T)
|
||||
then (SETQ STREAM FILE)
|
||||
else (RESETSAVE (SETQ STREAM (OPENSTREAM FILE 'INPUT))
|
||||
@@ -266,11 +286,23 @@
|
||||
(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])])])
|
||||
|
||||
(* ;; "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 4-Apr-2026 00:10 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 12:08 by rmk")
|
||||
(* ; "Edited 29-Mar-2026 11:21 by rmk")
|
||||
(LET [(FILEVERSION (CADR (ASSOC 'VERSION (MEDLEYFONT.FILEP FILE]
|
||||
(CL:WHEN (AND REQUIRED (NEQ REQUIRED FILEVERSION))
|
||||
(ERROR (CONCAT "Medley font version is " FILEVERSION ", " REQUIRED " is required")
|
||||
FILE))
|
||||
FILEVERSION])
|
||||
)
|
||||
|
||||
|
||||
@@ -280,97 +312,69 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.READ.FONT
|
||||
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 20-Jan-2026 22:31 by rmk")
|
||||
[LAMBDA (FILE CHARSETNOS NOERROR) (* ; "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")
|
||||
(SETQ FONT (CL:IF FONT
|
||||
(FONTCREATE FONT)
|
||||
(create FONTDESCRIPTOR)))
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FILE FONT))
|
||||
(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.")
|
||||
(* ;; "Returns a font descriptor containing the requested charsets from FILE. If FILE is not given, the filename is determined from the FONTSPEC and the FONTDEVICEPROP's for its FSDEVICE.")
|
||||
|
||||
(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])
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FILE))
|
||||
(if (NOT (INFILEP FILE))
|
||||
then (CL:UNLESS NOERROR (ERROR "FILE NOT FOUND" FILE))
|
||||
elseif [OR (MEMB CHARSETNOS '(NIL ALL))
|
||||
(SETQ CHARSETNOS (SORT (CHARSET.DECODE (MKLIST CHARSETNOS)
|
||||
NOERROR]
|
||||
then (RESETLST
|
||||
(LET (STREAM FONT CSLOC MAXCHARSET) (* ;
|
||||
"CL:OPEN-FILE doesn't exist in the init")
|
||||
[RESETSAVE (SETQ STREAM (OPENSTREAM FILE '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 CHARSETNOS
|
||||
when (if (EQ CHARSETNOS 'ALL)
|
||||
elseif (EQ CSNO (CAR CHARSETNOS))
|
||||
then (pop CHARSETNOS))
|
||||
do (\SETCHARSETINFO FONT CSNO (MEDLEYFONT.GETCHARSET.INTERNAL STREAM CSNO
|
||||
FONT CSLOC)))
|
||||
FONT))])
|
||||
|
||||
(MEDLEYFONT.READ.CHARSET
|
||||
[LAMBDA (STREAM CHARSET FONT) (* ; "Edited 14-Feb-2026 00:36 by rmk")
|
||||
[LAMBDA (STREAM CHARSET FONT) (* ; "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 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")
|
||||
|
||||
(* ;; "FONT is only needed for the \READCHARSET call below that interprets an INDIRECT and leads to a recursiving invocation of MEDLEYFONT.GETCHARSET and this function. It is the font descriptor provided at the top-level call. ")
|
||||
|
||||
(MEDLEYFONT.READ.ITEM STREAM 'CHARSETSTRING) (* ;
|
||||
"Throwaway for looking with text editor")
|
||||
(LET (CSNO INDIRECT)
|
||||
(LET (CSNO)
|
||||
(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). ")
|
||||
(* ;; "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.")
|
||||
|
||||
(SETQ INDIRECT (MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET))
|
||||
(\READCHARSET INDIRECT CHARSET FONT)
|
||||
(MEDLEYFONT.GETCHARSET (MEDLEYFONT.FILENAME (MEDLEYFONT.READ.ITEM STREAM
|
||||
'INDIRECTCHARSET)
|
||||
STREAM)
|
||||
CHARSET FONT)
|
||||
else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO
|
||||
WIDTHS _ NIL
|
||||
OFFSETS _ NIL)) eachtime (SETQ PAIR
|
||||
@@ -516,20 +520,29 @@
|
||||
(bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR])
|
||||
|
||||
(MEDLEYFONT.READ.VERIFIEDFONT
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 20-Jan-2026 22:31 by rmk")
|
||||
[LAMBDA (STREAM FONT) (* ; "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)))
|
||||
(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
|
||||
@@ -544,6 +557,8 @@
|
||||
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)
|
||||
@@ -556,24 +571,22 @@
|
||||
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))
|
||||
(INDIRECTS (* ; "Only a file prop"))
|
||||
(\SFFACECODE (* ; "to be deprecated"))
|
||||
(HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P")))
|
||||
(replace (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT with (\CREATEFONTCHARSETVECTOR FONT))
|
||||
FONT])
|
||||
)
|
||||
|
||||
@@ -584,7 +597,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.WRITE.CHARSET
|
||||
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 4-Sep-2025 11:41 by rmk")
|
||||
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "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")
|
||||
@@ -593,7 +607,7 @@
|
||||
(* ; "Edited 16-May-2025 20:18 by rmk")
|
||||
(* ; "Edited 13-May-2025 23:26 by rmk")
|
||||
(LET ((CSINFO (\INSURECHARSETINFO FONT CHARSET))
|
||||
CSCHARENCODING)
|
||||
CSCHARENCODING INDIRECT)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSETSTRING (MKSTRING CHARSET))
|
||||
(* ; "For human file-scan")
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSET CHARSET)
|
||||
@@ -604,14 +618,13 @@
|
||||
|
||||
(* ;; "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))
|
||||
(if (CL:UNLESS NOINDIRECTS
|
||||
(SETQ INDIRECT (INDIRECTCHARSETP CSINFO FONT)))
|
||||
then
|
||||
(* ;;
|
||||
"This charset is is taken entirely from on another file, no need to copy it to this file.")
|
||||
"This charset is is taken entirely from another file, no need to copy it to this file.")
|
||||
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (CHARSETPROP CSINFO 'SOURCE)
|
||||
NIL
|
||||
'PRINT)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET INDIRECT NIL 'PRINT)
|
||||
else (MEDLEYFONT.WRITE.ITEM STREAM 'CSINFOPROPS (fetch (CHARSETINFO CSINFOPROPS)
|
||||
of CSINFO)
|
||||
NIL
|
||||
@@ -774,7 +787,11 @@
|
||||
(TERPRI STREAM))])
|
||||
|
||||
(MEDLEYFONT.WRITE.FONTPROPS
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 12-Aug-2025 17:55 by rmk")
|
||||
[LAMBDA (STREAM FONT) (* ; "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")
|
||||
@@ -785,7 +802,7 @@
|
||||
|
||||
(* ;; "HPRINT would be obvious, but it would get charsetvector etc.")
|
||||
|
||||
(* ;; "Exclude FONTCHARSETVECTOR and \SFFACECODE")
|
||||
(* ;; "Exclude FONTCHARSETVECTOR ")
|
||||
|
||||
(* ;; "Write even NIL values for default overerides")
|
||||
|
||||
@@ -793,6 +810,8 @@
|
||||
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)
|
||||
@@ -807,6 +826,8 @@
|
||||
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)
|
||||
@@ -827,53 +848,59 @@
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTHASLEFTKERNS (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS)
|
||||
of FONT)
|
||||
T)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'FONTEXTRAFIELD2 (fetch (FONTDESCRIPTOR FONTEXTRAFIELD2)
|
||||
of FONT)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTS (for CS CSINFO INDIRECT (FSPEC _ (FONTPROP FONT
|
||||
'SPEC))
|
||||
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) (* ; "Edited 25-May-2025 20:51 by rmk")
|
||||
[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 0)
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'VERSION "1")
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'DATE (DATE))
|
||||
(MEDLEYFONT.WRITE.ITEM STREAM 'OTHERFONTPROPS OTHERFONTPROPS T])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.FILENAME
|
||||
[LAMBDA (FILE FONT CHARSET EXTENSION DIRECTORY) (* ; "Edited 23-Jan-2026 15:10 by rmk")
|
||||
(* ; "Edited 20-Jan-2026 17:39 by rmk")
|
||||
[LAMBDA (FILE DIRECTORY CHARSET) (* ; "Edited 1-Apr-2026 09:46 by rmk")
|
||||
(* ; "Edited 30-Mar-2026 09:19 by rmk")
|
||||
(* ; "Edited 17-Mar-2026 10:15 by rmk")
|
||||
(* ; "Edited 2-Mar-2026 22:45 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")
|
||||
(* ; "Edited 25-May-2025 21:25 by rmk")
|
||||
(* ; "Edited 19-May-2025 17:42 by rmk")
|
||||
(* ; "Edited 16-May-2025 14:09 by rmk")
|
||||
(LET [(FONTSPEC (AND FONT (\FONT.CHECKARGS FONT NIL NIL NIL NIL T]
|
||||
(CL:UNLESS EXTENSION (* ;
|
||||
"EXTENSION may be needed for DIRECTORY below")
|
||||
(SETQ EXTENSION (OR (FILENAMEFIELD FILE 'EXTENSION)
|
||||
(CONCAT "MEDLEY" (OR (AND FONTSPEC (fetch (FONTSPEC FSDEVICE)
|
||||
of FONTSPEC))
|
||||
(ERROR "Font device not known"))
|
||||
"FONT"))))
|
||||
(PACKFILENAME.STRING `(BODY ,FILE ,@(UNPACKFILENAME.STRING (AND FONTSPEC
|
||||
(\FONTFILENAME FONTSPEC NIL
|
||||
NIL NIL CHARSET)))
|
||||
DIRECTORY
|
||||
,(OR DIRECTORY (FILENAMEFIELD FILE 'DIRECTORY)
|
||||
(PSEUDOFILENAME (CONCAT (MEDLEYDIR)
|
||||
"fonts/"
|
||||
(L-CASE EXTENSION)
|
||||
"s")))
|
||||
EXTENSION
|
||||
,EXTENSION])
|
||||
(* ; "Edited 19-May-2025 17:42 by rmk")
|
||||
|
||||
(* ;; "Defaults to components of BASEFILE, e.g. host/directory and extension, otherwise")
|
||||
|
||||
(LET (FONTSPEC HOST DIR EXT)
|
||||
(if (type? FONTSPEC FILE)
|
||||
then (SETQ FONTSPEC FILE)
|
||||
(SETQ FILE (\FONTFILENAME (\FONT.CHECKARGS FILE NIL NIL NIL NIL T)
|
||||
NIL NIL NIL CHARSET))
|
||||
else (SETQ FONTSPEC (FONTSPECFROMFILENAME FILE)))
|
||||
[if DIRECTORY
|
||||
then (SETQ HOST (FILENAMEFIELD DIRECTORY 'HOST))
|
||||
(SETQ DIR (FILENAMEFIELD DIRECTORY 'DIRECTORY))
|
||||
else [SETQ DIR (CAR (MKLIST (FONTDEVICEPROP FONTSPEC 'FONTDIRECTORIES]
|
||||
(SETQ HOST (FILENAMEFIELD DIR 'HOST]
|
||||
(PACKFILENAME 'BODY FILE 'HOST HOST 'DIRECTORY DIR 'EXTENSION
|
||||
(CAR (MKLIST (FONTDEVICEPROP FONTSPEC 'FONTEXTENSIONS])
|
||||
)
|
||||
|
||||
(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
|
||||
@@ -924,11 +951,12 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2152 16901 (MEDLEYFONT.WRITE.FONT 2162 . 7217) (MEDLEYFONT.GETCHARSET 7219 . 11360) (
|
||||
MEDLEYFONT.CHARSET? 11362 . 12831) (MEDLEYFONT.GETFILEPROP 12833 . 14933) (MEDLEYFONT.FILEP 14935 .
|
||||
16899)) (16927 39618 (MEDLEYFONT.READ.FONT 16937 . 21473) (MEDLEYFONT.READ.CHARSET 21475 . 27190) (
|
||||
MEDLEYFONT.READ.ITEM 27192 . 33341) (MEDLEYFONT.PEEK.ITEM 33343 . 34205) (MEDLEYFONT.READ.FONTPROPS
|
||||
34207 . 34672) (MEDLEYFONT.READ.VERIFIEDFONT 34674 . 39616)) (39644 57481 (MEDLEYFONT.WRITE.CHARSET
|
||||
39654 . 44216) (MEDLEYFONT.WRITE.ITEM 44218 . 53271) (MEDLEYFONT.WRITE.FONTPROPS 53273 . 56826) (
|
||||
MEDLEYFONT.WRITE.HEADER 56828 . 57479)) (57482 59848 (MEDLEYFONT.FILENAME 57492 . 59846)))))
|
||||
(FILEMAP (NIL (2204 19305 (MEDLEYFONT.WRITE.FONT 2214 . 8617) (MEDLEYFONT.GETCHARSET 8619 . 10553) (
|
||||
MEDLEYFONT.GETCHARSET.INTERNAL 10555 . 12292) (MEDLEYFONT.CHARSET? 12294 . 13172) (
|
||||
MEDLEYFONT.GETFILEPROP 13174 . 16238) (MEDLEYFONT.FILEP 16240 . 18668) (MEDLEYFONT.FILEVERSION 18670
|
||||
. 19303)) (19331 41011 (MEDLEYFONT.READ.FONT 19341 . 22654) (MEDLEYFONT.READ.CHARSET 22656 . 27703) (
|
||||
MEDLEYFONT.READ.ITEM 27705 . 33854) (MEDLEYFONT.PEEK.ITEM 33856 . 34718) (MEDLEYFONT.READ.FONTPROPS
|
||||
34720 . 35185) (MEDLEYFONT.READ.VERIFIEDFONT 35187 . 41009)) (41037 60387 (MEDLEYFONT.WRITE.CHARSET
|
||||
41047 . 45686) (MEDLEYFONT.WRITE.ITEM 45688 . 54741) (MEDLEYFONT.WRITE.FONTPROPS 54743 . 59512) (
|
||||
MEDLEYFONT.WRITE.HEADER 59514 . 60385)) (60388 62273 (MEDLEYFONT.FILENAME 60398 . 62271)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user