github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-28 12:58:19 +00:00
Code Issues Projects Releases Wiki Activity

rmk122--Next round on fonts and MCCS (#2280)

Browse Source 
* A revision to the font, Unicode, Tedit, and other modules to implement the MCCS character coding as the standard for internal text strings.  MCCS is a variant of XCCS with arrows switched with circumflex/underscore and $ switched with currency, and allows for additional code assignments over time. :MCCS replaces :XCCS as the default external format, especially for source files.  The file XCCS is removed in favor of the file MCCS, which includes the XCCS external format for backward compatibility.

* This includes a single Medley-font formatted font file for each of the family/size/face display fonts.  The glyph assignments correspond to the MCCS character encoding (except for fonts with idiosyncratic encodings--Hippo, Symbol).  All charsets from legacy font files are included in each file, and the character sets and glyphs in each file have also been extended by offline coercion from related families (e.g. Glyphs not in legacy Terminal are taken from legacy Modern). There should be fewer black boxes, and character-display shouldn't change when you switch fonts.

* The Unicode mapping tables have been redefined to set up correspondences between Unicode and MCCS, not XCCS.  Separate XCCS to/from MCCS mapping functions are provided in the file MCCS; they are no longer included in INTERPRESS.

* TEDIT converts characters in legacy fonts to their new MCCS codes as it reads formatted files, marks the file as MCCS compatible and preserves the new codes on writing.

* Default keyboard assignments produce the MCCS uparrow and leftarrow for shift-6 and shift-hyphen, use Function-6 for circumflex and Function-10 for underscore.

See documentation in FONTCODECHANGES.TEDIT MCCS.TEDIT MEDLEYFONTFORMAT.TEDIT in docs/internal, and library/UNICODE.TEDIT.
This commit is contained in:
rmkaplan
2025-10-20 17:17:34 -07:00
committed by GitHub
parent 54353a4bef
commit 82fc95ce18
401 changed files with 8871 additions and 6601 deletions
Download Patch File Download Diff File Expand all files Collapse all files

287
sources/MEDLEYFONTFORMAT
View File

@@ -1,12 +1,12 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "27-Jul-2025 22:22:23" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;218 57699
(FILECREATED " 9-Oct-2025 15:20:59" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;242 59604
:EDIT-BY rmk
:CHANGES-TO (FNS MEDLEYFONT.READ.ITEM)
:CHANGES-TO (FNS MEDLEYFONT.GETCHARSET)
:PREVIOUS-DATE "24-Jul-2025 22:07:35" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;217)
:PREVIOUS-DATE " 7-Oct-2025 12:43:33" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;241)
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
@@ -59,7 +59,8 @@
(DEFINEQ
(MEDLEYFONT.WRITE.FONT
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 15-Jul-2025 16:43 by rmk")
[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")
@@ -84,7 +85,7 @@
(SETQ FILECHARSETS (for CSNO CSINFO from 0 to \MAXCHARSET
when (OR (NULL CHARSETNOS)
(MEMB CSNO CHARSETNOS))
when (SETQ CSINFO (\XGETCHARSETINFO FONT CSNO))
when (SETQ CSINFO (\GETCHARSETINFO FONT CSNO))
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CSNO))
(CL:UNLESS FILECHARSETS (ERROR "No character sets to write" FONT))
@@ -128,11 +129,13 @@
(FULLNAME STREAM])
(MEDLEYFONT.GETCHARSET
[LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 17:09 by rmk")
[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")
(* ;; "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))
@@ -145,6 +148,27 @@
(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.")
@@ -186,7 +210,8 @@
CHARSET])
(MEDLEYFONT.GETFILEPROP
[LAMBDA (FILE PROP) (* ; "Edited 15-Jul-2025 20:21 by rmk")
[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")
@@ -194,9 +219,8 @@
(* ; "Edited 14-May-2025 17:46 by rmk")
(CL:UNLESS (OR (LITATOM FILE)
(STRINGP FILE))
[SETQ FILE (CAR (APPLY (FUNCTION FONTFILES)
(FONTPROP (FONTCREATE FILE)
'SPEC])
[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))
@@ -255,7 +279,8 @@
(DEFINEQ
(MEDLEYFONT.READ.FONT
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 15-Jul-2025 20:20 by rmk")
[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))
@@ -267,14 +292,13 @@
(CL:UNLESS (MEDLEYFONT.FILEP STREAM)
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM)))
(LET ((*READTABLE* (FIND-READTABLE "INTERLISP"))
FONTCHARSETVECTOR CSVECTORLOC NOTFOUND SINGLECS)
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))
(SETQ FONTCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT))
(CL:UNLESS (EQ CSVECTORLOC 0) (* ; "Not empty")
[if (ILESSP CSVECTORLOC 0)
then
@@ -284,15 +308,15 @@
(* ;; "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 SINGLECS (BIN STREAM))
(SETQ SINGLECSNO (BIN STREAM))
(CL:WHEN CHARSETNOS
(CL:UNLESS (AND (EQ SINGLECS (CAR CHARSETNOS))
(CL:UNLESS (AND (EQ SINGLECSNO (CAR CHARSETNOS))
(NULL (CDR CHARSETNOS)))
(ERROR (CONCAT FILE
" does not contain information for charsets ÿ4ÿ"
(REMOVE SINGLECS CHARSETNOS)))))
(\SETCHARSETINFO FONTCHARSETVECTOR SINGLECS (MEDLEYFONT.READ.CHARSET
STREAM SINGLECS))
" 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")
@@ -311,13 +335,17 @@
(DREVERSE NOTFOUND))))
(for X CS in $$VAL do (SETQ CSNO (CAR X))
(SETFILEPTR STREAM (CDR X))
(\SETCHARSETINFO FONTCHARSETVECTOR CSNO
(MEDLEYFONT.READ.CHARSET STREAM CSNO
])
(\SETCHARSETINFO FONT CSNO (
 MEDLEYFONT.READ.CHARSET
STREAM CSNO])
FONT])
(MEDLEYFONT.READ.CHARSET
[LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 11:27 by rmk")
[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")
@@ -331,12 +359,12 @@
(LET (CSNO INDIRECT)
(CL:UNLESS [EQ CHARSET (SETQ CSNO (MEDLEYFONT.READ.ITEM STREAM 'CHARSET]
(ERROR "Charset mismatch" (LIST CHARSET CSNO)))
(if [EQ 'INDIRECTCHARSET (CAR (SETQ INDIRECT (MEDLEYFONT.PEEK.ITEM STREAM]
then (* ;
 "Read a complete charset from another file (e.g. shared Kanji)")
(MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET)
(APPLY (FUNCTION \READCHARSET)
(CADR INDIRECT))
(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
@@ -366,10 +394,11 @@
of CSINFO with ITEM))
(CSCOMPLETEP (replace (CHARSETINFO CSCOMPLETEP)
of CSINFO with ITEM))
(HELP "Unrecognized charsetinfo label'" LABEL))
(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
@@ -481,64 +510,65 @@
(bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR])
(MEDLEYFONT.READ.VERIFIEDFONT
[LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:57 by rmk")
[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)))
[if FONT
then (* ; "compare/verify")
(for P in FONTPROPS unless (EQUAL (CADR P)
(RECORDACCESS (CAR P)
FONT NIL 'FETCH))
do (ERROR "Mismatching font property" P))
else (SETQ FONT (create FONTDESCRIPTOR)) (* ; "Construct")
(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))
(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"]
(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])
)
@@ -549,15 +579,15 @@
(DEFINEQ
(MEDLEYFONT.WRITE.CHARSET
[LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 9-Jul-2025 19:14 by rmk")
[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")
(* ;; "This outputs the characterset info for CHARSET in FONT.")
(LET ((CSINFO (\INSURECHARSETINFO CHARSET FONT))
(LET ((CSINFO (\INSURECHARSETINFO FONT CHARSET))
CSCHARENCODING)
(MEDLEYFONT.WRITE.ITEM STREAM 'CHARSETSTRING (MKSTRING CHARSET))
(* ; "For human file-scan")
@@ -569,15 +599,12 @@
(* ;; "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 CHARSET))
(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 (GETMULTI (fetch (CHARSETINFO
CSINFOPROPS)
of CSINFO)
'SOURCE)
(MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (CHARSETPROP CSINFO 'SOURCE)
NIL
'PRINT)
else (MEDLEYFONT.WRITE.ITEM STREAM 'CSINFOPROPS (fetch (CHARSETINFO CSINFOPROPS)
@@ -742,7 +769,8 @@
(TERPRI STREAM))])
(MEDLEYFONT.WRITE.FONTPROPS
[LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:50 by rmk")
[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")
@@ -774,6 +802,10 @@
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)
@@ -810,50 +842,35 @@
(DEFINEQ
(MEDLEYFONT.FILENAME
[LAMBDA (FONT CHARSET EXTENSION FILE) (* ; "Edited 10-Jun-2025 11:02 by rmk")
[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.")
(CL:WHEN (AND (LISTP CHARSET)
(NULL (CDR CHARSET)))
(SETQ CHARSET (CAR CHARSET))) (* ; "Edited 14-May-2025 12:02 by rmk")
(LET (FAMILY SIZE FACE DEVICE FILENAME)
[if (LISTP FONT)
then (SETQ FAMILY (CAR FONT))
(SETQ SIZE (CADR FONT))
(SETQ FACE (OR (CADDR FONT)
'MRR))
(SETQ DEVICE (OR (CADDDR FONT)
'DISPLAY))
elseif (type? FONTDESCRIPTOR FONT)
then (SETQ FAMILY (FONTPROP FONT 'FAMILY))
(SETQ SIZE (FONTPROP FONT 'SIZE))
(SETQ FACE (FONTPROP FONT 'FACE))
(SETQ DEVICE (FONTPROP FONT 'DEVICE]
(CL:WHEN (LISTP FACE)
(SETQ FACE (CONCAT (NTHCHAR (CAR FACE)
1)
(NTHCHAR (CADR FACE)
1)
(NTHCHAR (CADDR FACE)
1))))
(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 FILE
[SETQ FILE (PSEUDOFILENAME (MEDLEYDIR (CONCAT "fonts/" (L-CASE EXTENSION)
"s"]))
"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 "-" FACE (CL:IF (SMALLP CHARSET)
(CONCAT "-C" (OCTALSTRING CHARSET))
"")
SIZE "-" (FONTFACETOATOM FACE)
(CL:IF (SMALLP CHARSET)
(CONCAT "-C" (OCTALSTRING CHARSET))
"")
"." EXTENSION))
(PACKFILENAME 'BODY FILE 'BODY FILENAME])
(CONCAT DIRECTORY ">" FILENAME])
)
(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
@@ -904,11 +921,11 @@
)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2127 14772 (MEDLEYFONT.WRITE.FONT 2137 . 6995) (MEDLEYFONT.GETCHARSET 6997 . 9296) (
MEDLEYFONT.CHARSET? 9298 . 10767) (MEDLEYFONT.GETFILEPROP 10769 . 12804) (MEDLEYFONT.FILEP 12806 .
14770)) (14798 36689 (MEDLEYFONT.READ.FONT 14808 . 19241) (MEDLEYFONT.READ.CHARSET 19243 . 24137) (
MEDLEYFONT.READ.ITEM 24139 . 30288) (MEDLEYFONT.PEEK.ITEM 30290 . 31152) (MEDLEYFONT.READ.FONTPROPS
31154 . 31619) (MEDLEYFONT.READ.VERIFIEDFONT 31621 . 36687)) (36715 54244 (MEDLEYFONT.WRITE.CHARSET
36725 . 41330) (MEDLEYFONT.WRITE.ITEM 41332 . 50385) (MEDLEYFONT.WRITE.FONTPROPS 50387 . 53589) (
MEDLEYFONT.WRITE.HEADER 53591 . 54242)) (54245 56814 (MEDLEYFONT.FILENAME 54255 . 56812)))))
(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