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

READ-BDF initial changes for XCCS to MCCS (#2360)

Browse Source 
* Verbose mode (READ-BDF) was implemented incorrectly - fixed
* Cleanup DEFPACKAGE in source file using :IMPORT-FROM, and fewer imports.
* Various renaming for consistency with XCCS -> MCCS changes.
* Use IL:FONTSPEC record instead of using FIRST, SECOND, etc.
* Fix the parsing of IL:FONTSPEC to use COMPRESSED instead of incorrect CONDENSED.
* Zero-width "image" with zero-width "escapement" GLYPHS now get put into NOMAPPINGCHARSET.
* Add (FILES (SYSLOAD) SYSEDIT) under existing (DECLARE: EVAL@COMPILE DONTCOPY ...)
This commit is contained in:
Matt Heffron
2025-11-17 10:44:23 -08:00
committed by GitHub
parent 428aac56ea
commit defd68a892
3 changed files with 111 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files

197
lispusers/READ-BDF
View File

@@ -1,17 +1,19 @@
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" (USE "XCL" "LISP") (EXPORT "READ-BDF" (DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" (USE "XCL" "LISP") (EXPORT "READ-BDF"
"WRITE-BDF-TO-DISPLAYFONT-FILES") (IMPORT \AVGCHARWIDTH \FGETWIDTH \FONTFACE \FONTFILENAME "WRITE-BDF-TO-DISPLAYFONT-FILES") (IMPORT-FROM "IL" "BITBLT" "BITMAPCREATE" "BITMAPHEIGHT"
\FSETOFFSET \FSETWIDTH \FONTSYMBOL \GETSTREAM \INSTALLCHARSETINFO \PUTBASE BITBLT BITMAPCREATE "BITMAPWIDTH" "BLACKSHADE" "BLTSHADE" "BOLD" "COMPRESSED" "CHARSETINFO" "DISPLAY" "FONTDESCRIPTOR"
BITMAPHEIGHT BITMAPWIDTH BLACKSHADE BLTSHADE BOLD CONDENSED CHARSETINFO DISPLAY FONTDESCRIPTOR FONTP "FONTP" "FONTPROP" "INPUT" "ITALIC" "LIGHT" "LRSH" "MEDIUM" "REGULAR" "TCONC" "UTOMCODE" "UTOMCODE?"
FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITESTRIKEFONTFILE)) "WRITESTRIKEFONTFILE")) READTABLE "XCL" BASE 10)
READTABLE "XCL" BASE 10)
(IL:FILECREATED "30-Apr-2025 13:20:10" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;61| 47500 (IL:FILECREATED " 6-Nov-2025 23:10:51" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;13| 49101
:EDIT-BY "mth" :EDIT-BY "mth"
:CHANGES-TO (IL:FUNCTIONS GET-FAMILY-FACE-SIZE-FROM-NAME) :CHANGES-TO (IL:FUNCTIONS BDF-TO-FONTDESCRIPTOR BDF-TO-CHARSETINFO READ-GLYPH
WRITE-BDF-TO-DISPLAYFONT-FILES)
(FILE-ENVIRONMENTS "READ-BDF")
(IL:VARS IL:READ-BDFCOMS)
:PREVIOUS-DATE "25-Apr-2025 10:10:08" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;60| :PREVIOUS-DATE " 6-Nov-2025 22:43:21" IL:|{DSK}<home>matt>Interlisp>medley>lispusers>READ-BDF.;9|
) )
@@ -23,8 +25,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR GET-FAMILY-FACE-SIZE-FROM-NAME (IL:FUNCTIONS BDF-TO-CHARSETINFO BDF-TO-FONTDESCRIPTOR GET-FAMILY-FACE-SIZE-FROM-NAME
GLYPHS-BY-CHARSET PACKFILENAME.STRING READ-BDF READ-DELIMITED-LIST-FROM-STRING GLYPHS-BY-CHARSET PACKFILENAME.STRING READ-BDF READ-DELIMITED-LIST-FROM-STRING
READ-GLYPH SPLIT-FONT-NAME WRITE-BDF-TO-DISPLAYFONT-FILES) READ-GLYPH SPLIT-FONT-NAME WRITE-BDF-TO-DISPLAYFONT-FILES)
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:LOADCOMP) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:SYSLOAD)
IL:FONT)) IL:SYSEDIT)
(IL:FILES (IL:LOADCOMP)
IL:FONT))
(FILE-ENVIRONMENTS "READ-BDF") (FILE-ENVIRONMENTS "READ-BDF")
(IL:PROP (IL:DATABASE) (IL:PROP (IL:DATABASE)
IL:READ-BDF))) IL:READ-BDF)))
@@ -40,10 +44,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(SLUG NIL :TYPE GLYPH)) (SLUG NIL :TYPE GLYPH))
(DEFSTRUCT GLYPH (DEFSTRUCT GLYPH
"This is an individual BDF glyph. Includes some values calculted for creating CHARSETINFO" "This is an individual BDF glyph. Includes some values calculated for creating CHARSETINFO"
(NAME NIL :TYPE STRING) (NAME NIL :TYPE STRING)
ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP
(XCODE 0 :TYPE INTEGER) (MCODE 0 :TYPE INTEGER)
(WIDTH 0 :TYPE INTEGER) (WIDTH 0 :TYPE INTEGER)
(ASCENT 0 :TYPE INTEGER) (ASCENT 0 :TYPE INTEGER)
(DESCENT 0 :TYPE INTEGER)) (DESCENT 0 :TYPE INTEGER))
@@ -55,6 +59,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET)) (DEFCONSTANT NOMAPPINGCHARSET (1+ MAXCHARSET))
(DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUG-OR-WIDTH &OPTIONAL MAP-UNKNOWN-TO-PRIVATE) (DEFUN BDF-TO-CHARSETINFO (FONT CSET SLUG-OR-WIDTH &OPTIONAL MAP-UNKNOWN-TO-PRIVATE)
(IL:* IL:\; "Edited 6-Nov-2025 17:30 by mth")
(IL:* IL:\; "Edited 23-Apr-2025 17:53 by mth") (IL:* IL:\; "Edited 23-Apr-2025 17:53 by mth")
(IL:* IL:\; "Edited 21-Apr-2025 16:23 by mth") (IL:* IL:\; "Edited 21-Apr-2025 16:23 by mth")
(IL:* IL:\; "Edited 30-Jan-2025 16:40 by mth") (IL:* IL:\; "Edited 30-Jan-2025 16:40 by mth")
@@ -98,7 +103,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
((INTEGERP SLUG-OR-WIDTH) ((INTEGERP SLUG-OR-WIDTH)
(SETQ SLUGWIDTH SLUG-OR-WIDTH)) (SETQ SLUGWIDTH SLUG-OR-WIDTH))
(T (ERROR "Invalid SLUG-OR-WIDTH: ~S" SLUG-OR-WIDTH))) (T (ERROR "Invalid SLUG-OR-WIDTH: ~S" SLUG-OR-WIDTH)))
(SETQ CSGLYPHS (LOOP :FOR XGL :IN CSGLYPHS :COLLECT (LET* ((XCODE (CAR XGL)) (SETQ CSGLYPHS (LOOP :FOR XGL :IN CSGLYPHS :COLLECT (LET* ((MCODE (CAR XGL))
(GL (CDR XGL)) (GL (CDR XGL))
(GWIDTH (GLYPH-WIDTH (GWIDTH (GLYPH-WIDTH
GL)) GL))
@@ -112,13 +117,13 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
   
 "Is the above statement actually true?")  "Is the above statement actually true?")
(SETF (GLYPH-XCODE GL) (SETF (GLYPH-MCODE GL)
XCODE) MCODE)
(SETQ FIRSTCHAR (SETQ FIRSTCHAR
(MIN FIRSTCHAR XCODE (MIN FIRSTCHAR MCODE
)) ))
(SETQ LASTCHAR (SETQ LASTCHAR
(MAX LASTCHAR XCODE) (MAX LASTCHAR MCODE)
) )
(INCF TOTAL-WIDTH GWIDTH) (INCF TOTAL-WIDTH GWIDTH)
(SETQ ASCENT (SETQ ASCENT
@@ -133,13 +138,13 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(IL:* IL:|;;| (IL:* IL:|;;|
 "Initialize the offsets to the TOTAL-WIDTH (without the SLUG. It will be added later)")  "Initialize the offsets to the TOTAL-WIDTH (without the SLUG. It will be added later)")
(IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (\\FSETOFFSET OFFSETS I (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (IL:\\FSETOFFSET OFFSETS I
TOTAL-WIDTH)) TOTAL-WIDTH))
(SETQ WIDTHS (IL:|fetch| (CHARSETINFO IL:WIDTHS) IL:|of| CSINFO)) (SETQ WIDTHS (IL:|fetch| (CHARSETINFO IL:WIDTHS) IL:|of| CSINFO))
(IL:* IL:|;;| "Initialize the widths to SLUGWIDTH") (IL:* IL:|;;| "Initialize the widths to SLUGWIDTH")
(IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (\\FSETWIDTH WIDTHS I (IL:|for| I IL:|from| 0 IL:|to| (+ MAXTHINCHAR 2) IL:|do| (IL:\\FSETWIDTH WIDTHS I
SLUGWIDTH)) SLUGWIDTH))
(IL:|replace| (CHARSETINFO IL:IMAGEWIDTHS) IL:|of| CSINFO IL:|with| WIDTHS) (IL:|replace| (CHARSETINFO IL:IMAGEWIDTHS) IL:|of| CSINFO IL:|with| WIDTHS)
@@ -151,19 +156,19 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(SETQ BMAP (BITMAPCREATE (+ TOTAL-WIDTH SLUGWIDTH) (SETQ BMAP (BITMAPCREATE (+ TOTAL-WIDTH SLUGWIDTH)
HEIGHT 1)) HEIGHT 1))
(IL:|replace| (CHARSETINFO IL:CHARSETBITMAP) IL:|of| CSINFO IL:|with| BMAP) (IL:|replace| (CHARSETINFO IL:CHARSETBITMAP) IL:|of| CSINFO IL:|with| BMAP)
(LOOP :FOR GL :IN CSGLYPHS :WITH GLBM :WITH GLW :WITH XCODE :DO (SETQ GLBM (LOOP :FOR GL :IN CSGLYPHS :WITH GLBM :WITH GLW :WITH MCODE :DO (SETQ GLBM
(GLYPH-BITMAP (GLYPH-BITMAP
GL)) GL))
(SETQ GLW (GLYPH-WIDTH GL)) (SETQ GLW (GLYPH-WIDTH GL))
(SETQ XCODE (GLYPH-XCODE GL)) (SETQ MCODE (GLYPH-MCODE GL))
(BITBLT GLBM 0 0 BMAP (+ DLEFT (MAX 0 (GLYPH-BBXOFF0 GL))) (BITBLT GLBM 0 0 BMAP (+ DLEFT (MAX 0 (GLYPH-BBXOFF0 GL)))
(+ DESCENT (GLYPH-BBYOFF0 GL)) (+ DESCENT (GLYPH-BBYOFF0 GL))
(BITMAPWIDTH GLBM) (BITMAPWIDTH GLBM)
(BITMAPHEIGHT GLBM) (BITMAPHEIGHT GLBM)
'INPUT 'INPUT
'IL:REPLACE) 'IL:REPLACE)
(\\FSETOFFSET OFFSETS XCODE DLEFT) (IL:\\FSETOFFSET OFFSETS MCODE DLEFT)
(\\FSETOFFSET WIDTHS XCODE GLW) (IL:\\FSETOFFSET WIDTHS MCODE GLW)
(INCF DLEFT GLW)) (INCF DLEFT GLW))
(IL:* IL:|;;| "Now insert the SLUG glyph into the BMAP, or make a slug (block)") (IL:* IL:|;;| "Now insert the SLUG glyph into the BMAP, or make a slug (block)")
@@ -185,6 +190,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE &OPTIONAL (DEFUN BDF-TO-FONTDESCRIPTOR (BDFONT FAMILY SIZE FACE ROTATION DEVICE &OPTIONAL
MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)
(IL:* IL:\; "Edited 5-Nov-2025 16:09 by mth")
(IL:* IL:\; "Edited 21-Apr-2025 16:03 by mth") (IL:* IL:\; "Edited 21-Apr-2025 16:03 by mth")
(IL:* IL:\; "Edited 30-Jan-2025 21:27 by mth") (IL:* IL:\; "Edited 30-Jan-2025 21:27 by mth")
(WHEN (AND (BDF-FONT-P BDFONT) (WHEN (AND (BDF-FONT-P BDFONT)
@@ -200,18 +206,22 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(OR DEVICE (FONTPROP FAMILY 'IL:DEVICE)) (OR DEVICE (FONTPROP FAMILY 'IL:DEVICE))
MAP-UNKNOWN-TO-PRIVATE))) MAP-UNKNOWN-TO-PRIVATE)))
(WHEN (LISTP FAMILY) (WHEN (LISTP FAMILY)
(RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (FIRST FAMILY)
(OR (SECOND FAMILY) (IL:* IL:|;;| "Assume this is a FONTSPEC")
(RETURN (BDF-TO-FONTDESCRIPTOR BDFONT (IL:|fetch| (IL:FONTSPEC IL:FSFAMILY)
IL:|of| FAMILY)
(OR (IL:|fetch| (IL:FONTSPEC IL:FSSIZE) IL:|of| FAMILY)
SIZE) SIZE)
(OR (THIRD FAMILY) (OR (IL:|fetch| (IL:FONTSPEC IL:FSFACE) IL:|of| FAMILY)
FACE "MRR") FACE "MRR")
(OR (FOURTH FAMILY) (OR (IL:|fetch| (IL:FONTSPEC IL:FSROTATION) IL:|of| FAMILY)
ROTATION 0) ROTATION 0)
(OR (FIFTH FAMILY) (OR (IL:|fetch| (IL:FONTSPEC IL:FSDEVICE) IL:|of| FAMILY)
DEVICE DEVICE
'DISPLAY) 'DISPLAY)
MAP-UNKNOWN-TO-PRIVATE))) MAP-UNKNOWN-TO-PRIVATE)))
(SETQ FAMILY (\\FONTSYMBOL FAMILY)) (SETQ FAMILY (IL:\\FONTSYMBOL FAMILY))
(UNLESS (AND (INTEGERP SIZE) (UNLESS (AND (INTEGERP SIZE)
(PLUSP SIZE)) (PLUSP SIZE))
(ERROR "Invalid SIZE: ~S~%" SIZE)) (ERROR "Invalid SIZE: ~S~%" SIZE))
@@ -236,7 +246,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(INTERN (STRING-UPCASE DEVICE) (INTERN (STRING-UPCASE DEVICE)
"IL")) "IL"))
(T (IL:\\ILLEGAL.ARG DEVICE)))) (T (IL:\\ILLEGAL.ARG DEVICE))))
(SETQ FACE (\\FONTFACE FACE NIL DEV)) (SETQ FACE (IL:\\FONTFACE FACE NIL DEV))
(SETQ GBCSL (GLYPHS-BY-CHARSET BDFONT MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)) (SETQ GBCSL (GLYPHS-BY-CHARSET BDFONT MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING))
(UNLESS SLUGWIDTH (UNLESS SLUGWIDTH
@@ -268,15 +278,16 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
GBCS CSET (OR SLUG (1+ GBCS CSET (OR SLUG (1+
SLUGWIDTH SLUGWIDTH
)))) ))))
(\\INSTALLCHARSETINFO FONTDESC CSINFO CSET) (IL:\\INSTALLCHARSETINFO FONTDESC CSINFO CSET
)
(LIST CSET))))) (LIST CSET)))))
(LIST FONTDESC CHARSETS)))) (LIST FONTDESC CHARSETS))))
(RETURN (VALUES-LIST (NCONC (GBCS-TO-FONTDESC (FIRST GBCSL) (RETURN (VALUES-LIST (NCONC (GBCS-TO-FONTDESC (FIRST GBCSL)
FAMILY) FAMILY)
(GBCS-TO-FONTDESC (SECOND GBCSL) (GBCS-TO-FONTDESC (SECOND GBCSL)
(\\FONTSYMBOL (CONCATENATE 'STRING (IL:\\FONTSYMBOL (CONCATENATE 'STRING
(SYMBOL-NAME FAMILY) (SYMBOL-NAME FAMILY)
"-UNMAPPED"))) "-UNMAPPED")))
(LIST (ASSOC NOMAPPINGCHARSET (FIRST GBCSL) (LIST (ASSOC NOMAPPINGCHARSET (FIRST GBCSL)
:TEST :TEST
#'EQL))))))))) #'EQL)))))))))
@@ -311,8 +322,8 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
'((#\R . REGULAR) '((#\R . REGULAR)
(#\N . REGULAR) (#\N . REGULAR)
(#\B . BOLD) (#\B . BOLD)
(#\S . CONDENSED) (#\S . COMPRESSED)
(#\C . CONDENSED))))) (#\C . COMPRESSED)))))
'REGULAR)) (IL:* IL:\; 'REGULAR)) (IL:* IL:\;
 "S is for \"SemiCondensed\", Assuming \"Condensed\"")  "S is for \"SemiCondensed\", Assuming \"Condensed\"")
@@ -336,17 +347,19 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(FIRST (BF-SIZE BDFONT)))))) (FIRST (BF-SIZE BDFONT))))))
(DEFUN GLYPHS-BY-CHARSET (FONT &OPTIONAL MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) (DEFUN GLYPHS-BY-CHARSET (FONT &OPTIONAL MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)
(IL:* IL:\; "Edited 6-Nov-2025 18:11 by mth")
(IL:* IL:\; "Edited 5-Nov-2025 16:18 by mth")
(IL:* IL:\; "Edited 21-Apr-2025 15:48 by mth") (IL:* IL:\; "Edited 21-Apr-2025 15:48 by mth")
(IL:* IL:\; "Edited 9-Jan-2025 11:23 by mth") (IL:* IL:\; "Edited 9-Jan-2025 11:23 by mth")
(LET* ((NCSETS (+ MAXCHARSET 2)) (LET* ((NCSETS (+ MAXCHARSET 2))
(CSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT (CONS NIL)))) (CSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT (CONS NIL))))
(UTOXFN (COND (UTOMFN (COND
(RAW-UNICODE-MAPPING #'IDENTITY) (RAW-UNICODE-MAPPING #'IDENTITY)
(MAP-UNKNOWN-TO-PRIVATE #'UTOXCODE) (MAP-UNKNOWN-TO-PRIVATE #'UTOMCODE)
(T #'UTOXCODE?))) (T #'UTOMCODE?)))
(SLUG (BF-SLUG FONT)) (SLUG (BF-SLUG FONT))
(SLUGWIDTH (AND SLUG (GLYPH-WIDTH SLUG))) (SLUGWIDTH (AND SLUG (GLYPH-WIDTH SLUG)))
NOMAPPINGCSETS ENC XCODE XCS) NOMAPPINGCSETS ENC MCODE MCS)
(UNLESS (OR MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING) (UNLESS (OR MAP-UNKNOWN-TO-PRIVATE RAW-UNICODE-MAPPING)
(SETQ NOMAPPINGCSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT (SETQ NOMAPPINGCSETS (MAKE-ARRAY NCSETS :INITIAL-CONTENTS (LOOP :REPEAT NCSETS :COLLECT
(CONS NIL))))) (CONS NIL)))))
@@ -358,7 +371,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
:UNLESS :UNLESS
(EQ GL SLUG) (EQ GL SLUG)
:DO :DO
(SETQ XCS NIL) (SETQ MCS NIL)
(SETQ ENC (GLYPH-ENCODING GL)) (SETQ ENC (GLYPH-ENCODING GL))
(WHEN (LISTP ENC) (WHEN (LISTP ENC)
@@ -372,9 +385,9 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
 "The -1 case of the (OR ...) shouldn't happen. The (EQ GL SLUG) test above should have caught it")  "The -1 case of the (OR ...) shouldn't happen. The (EQ GL SLUG) test above should have caught it")
) )
(SETQ XCODE (AND (INTEGERP ENC) (SETQ MCODE (AND (INTEGERP ENC)
(PLUSP ENC) (PLUSP ENC)
(FUNCALL UTOXFN ENC))) (FUNCALL UTOMFN ENC)))
(IF RAW-UNICODE-MAPPING (IF RAW-UNICODE-MAPPING
(COND (COND
((> ENC 65535) ((> ENC 65535)
@@ -394,7 +407,15 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(CONS ENC GL))) (CONS ENC GL)))
(T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL CSETS))) (T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL CSETS)))
(COND (COND
((NULL XCODE) ((AND (ZEROP (GLYPH-BBW GL))
(ZEROP (FIRST (GLYPH-DWIDTH GL))))
(IL:* IL:|;;|
 "This has zero-width \"image\" with zero-width \"escapement\", put it in the NOMAPPINGCHARSET")
(TCONC (AREF CSETS NOMAPPINGCHARSET)
(CONS ENC GL)))
((NULL MCODE)
(IL:* IL:|;;| "These assoc with the Unicode encoding") (IL:* IL:|;;| "These assoc with the Unicode encoding")
@@ -408,37 +429,37 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(TCONC (AREF CSETS NOMAPPINGCHARSET) (TCONC (AREF CSETS NOMAPPINGCHARSET)
(CONS ENC GL))) (CONS ENC GL)))
(T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL NOMAPPINGCSETS)))) (T (PUT-GLYPH-IN-CHARSET-ARRAY ENC GL NOMAPPINGCSETS))))
((AND (INTEGERP XCODE) ((AND (INTEGERP MCODE)
(<= 0 XCODE 65535)) (<= 0 MCODE 65535))
(IL:* IL:|;;| (IL:* IL:|;;|
 "These assoc with the 8 bit character code within the charset")  "These assoc with the 8 bit character code within the charset")
(PUT-GLYPH-IN-CHARSET-ARRAY XCODE GL CSETS) (PUT-GLYPH-IN-CHARSET-ARRAY MCODE GL CSETS)
(IL:* IL:|;;| "Default SLUG width is width of A.") (IL:* IL:|;;| "Default SLUG width is width of A.")
(WHEN (AND (NOT SLUGWIDTH) (WHEN (AND (NOT SLUGWIDTH)
(= ENC (CHAR-CODE #\A))) (= ENC (CHAR-CODE #\A)))
(IL:* IL:|;;| "A is the same code in XCCS and UNICODE ") (IL:* IL:|;;| "A is the same code in MCCS and UNICODE ")
(IL:* IL:|;;| (IL:* IL:|;;|
 "Comparing with ENC, not XCODE, to look only in charset 0")  "Comparing with ENC, not MCODE, to look only in charset 0")
(SETQ SLUGWIDTH (GLYPH-WIDTH GL)))) (SETQ SLUGWIDTH (GLYPH-WIDTH GL))))
((LISTP XCODE) ((LISTP MCODE)
(IL:* IL:|;;| (IL:* IL:|;;|
 "These assoc with the 8 bit character code within the charset (like above)")  "These assoc with the 8 bit character code within the charset (like above)")
(LOOP :FOR XC :IN XCODE :WITH CS :UNLESS (MEMBER (SETQ CS (LOOP :FOR MC :IN MCODE :WITH CS :UNLESS (MEMBER (SETQ CS
(LRSH XC 8)) (LRSH MC 8))
XCS) MCS)
:DO :DO
(PUSH CS XCS) (PUSH CS MCS)
(PUT-GLYPH-IN-CHARSET-ARRAY XC GL CSETS))) (PUT-GLYPH-IN-CHARSET-ARRAY MC GL CSETS)))
(T (ERROR "Invalid XCODE: ~A~%")))))) (T (ERROR "Invalid MCODE: ~A~%"))))))
(IL:* IL:|;;| "Extract the lists from the TCONC pointers") (IL:* IL:|;;| "Extract the lists from the TCONC pointers")
@@ -488,7 +509,8 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
X)) X))
Y)))) Y))))
(DEFUN READ-BDF (PATH &OPTIONAL VERBOSE) (IL:* IL:\; "Edited 24-Apr-2025 00:44 by mth") (DEFUN READ-BDF (PATH &OPTIONAL VERBOSE) (IL:* IL:\; "Edited 30-Apr-2025 13:37 by mth")
(IL:* IL:\; "Edited 24-Apr-2025 00:44 by mth")
(IL:* IL:\; "Edited 17-Apr-2025 15:10 by mth") (IL:* IL:\; "Edited 17-Apr-2025 15:10 by mth")
(IL:* IL:\; "Edited 12-Jul-2024 23:02 by mth") (IL:* IL:\; "Edited 12-Jul-2024 23:02 by mth")
(LET (LET
@@ -603,15 +625,15 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(SETF (BF-SLUG FONT) (SETF (BF-SLUG FONT)
GL)))))) GL))))))
(ENDFONT (SETQ FONT-COMPLETE T)))))))) (ENDFONT (SETQ FONT-COMPLETE T))))))))
(WHEN VERBOSE (DESTRUCTURING-BIND (FAMILY (WEIGHT SLANT EXPANSION)
(DESTRUCTURING-BIND (FAMILY (WEIGHT SLANT EXPANSION) SIZE)
SIZE) (GET-FAMILY-FACE-SIZE-FROM-NAME FONT)
(GET-FAMILY-FACE-SIZE-FROM-NAME FONT) (WHEN VERBOSE
(FORMAT *STANDARD-OUTPUT* (FORMAT *STANDARD-OUTPUT*
"Name: ~A~%Family: ~A~%Size: ~A~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%" "Name: ~A~%Family: ~A~%Size: ~A~%Weight: ~A~%Slant: ~A~%Expansion: ~A~%"
(BF-NAME FONT) (BF-NAME FONT)
FAMILY SIZE WEIGHT SLANT EXPANSION))) FAMILY SIZE WEIGHT SLANT EXPANSION))
FONT))) (VALUES FONT FAMILY WEIGHT SLANT EXPANSION SIZE)))))
(DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\])) (DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\]))
(IL:* IL:\; "Edited 20-Aug-2024 16:46 by mth") (IL:* IL:\; "Edited 20-Aug-2024 16:46 by mth")
@@ -699,7 +721,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(SETQ WORDINDEX (* BITROW BM.RASTERWIDTH)) (SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
(SETQ BYTEPOS (* 16 (1- NWORDS))) (SETQ BYTEPOS (* 16 (1- NWORDS)))
(LOOP :REPEAT NWORDS :DO (LOOP :REPEAT NWORDS :DO
(\\PUTBASE BM.BASE WORDINDEX (IL:\\PUTBASE BM.BASE WORDINDEX
(LDB (BYTE 16 BYTEPOS) (LDB (BYTE 16 BYTEPOS)
BITS)) BITS))
(INCF WORDINDEX) (INCF WORDINDEX)
@@ -744,12 +766,13 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(CHAR-SETS T) (CHAR-SETS T)
MAP-UNKNOWN-TO-PRIVATE WRITE-UNMAPPED MAP-UNKNOWN-TO-PRIVATE WRITE-UNMAPPED
RAW-UNICODE-MAPPING) RAW-UNICODE-MAPPING)
(IL:* IL:\; "Edited 5-Nov-2025 23:06 by mth")
(IL:* IL:\; "Edited 25-Apr-2025 10:08 by mth") (IL:* IL:\; "Edited 25-Apr-2025 10:08 by mth")
(IL:* IL:\; "Edited 24-Apr-2025 00:09 by mth") (IL:* IL:\; "Edited 24-Apr-2025 00:09 by mth")
(IL:* IL:\; "Edited 21-Apr-2025 16:03 by mth") (IL:* IL:\; "Edited 21-Apr-2025 16:03 by mth")
(IL:* IL:\; "Edited 3-Feb-2025 23:18 by mth") (IL:* IL:\; "Edited 3-Feb-2025 23:18 by mth")
(UNLESS (TYPEP BDFONT 'BDF-FONT) (UNLESS (TYPEP BDFONT 'BDF-FONT)
(ERROR "Not a BDF-FONT: ~S~%" BDFONT)) (ERROR "Not a BDF-FONT: ~S ~%" BDFONT))
(COND (COND
((EQ CHAR-SETS T) (IL:* IL:\; "This means ALL charsets") ((EQ CHAR-SETS T) (IL:* IL:\; "This means ALL charsets")
) )
@@ -769,7 +792,7 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(GET-FAMILY-FACE-SIZE-FROM-NAME BDFONT) (GET-FAMILY-FACE-SIZE-FROM-NAME BDFONT)
(SETQ FAMILY (OR FAMILY FN-FAMILY)) (SETQ FAMILY (OR FAMILY FN-FAMILY))
(WHEN RAW-UNICODE-MAPPING (WHEN RAW-UNICODE-MAPPING
(SETQ FAMILY (\\FONTSYMBOL (CONCATENATE 'STRING "RAW-" (STRING FAMILY))))) (SETQ FAMILY (IL:\\FONTSYMBOL (CONCATENATE 'STRING "RAW-" (STRING FAMILY)))))
(SETQ FACE (OR FACE FN-FACE)) (SETQ FACE (OR FACE FN-FACE))
(SETQ SIZE (OR SIZE FN-SIZE)) (SETQ SIZE (OR SIZE FN-SIZE))
(MULTIPLE-VALUE-BIND (FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS) (MULTIPLE-VALUE-BIND (FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS)
@@ -780,16 +803,16 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(SETQ UNICODE-CSETS (INTERSECTION CHAR-SETS UNICODE-CSETS))) (SETQ UNICODE-CSETS (INTERSECTION CHAR-SETS UNICODE-CSETS)))
(LOOP :FOR CS :IN CSETS :DO (WRITESTRIKEFONTFILE FONTDESC CS (LOOP :FOR CS :IN CSETS :DO (WRITESTRIKEFONTFILE FONTDESC CS
(PACKFILENAME.STRING :BODY DEST-DIR :NAME (PACKFILENAME.STRING :BODY DEST-DIR :NAME
(\\FONTFILENAME FAMILY SIZE FACE (IL:\\FONTFILENAME FAMILY SIZE FACE
"DISPLAYFONT" CS)))) "DISPLAYFONT" CS))))
(IF WRITE-UNMAPPED (IF WRITE-UNMAPPED
(LOOP :FOR CS :IN UNICODE-CSETS :DO (WRITESTRIKEFONTFILE (LOOP :FOR CS :IN UNICODE-CSETS :DO (WRITESTRIKEFONTFILE
UNMAPPED-FONTDESC CS UNMAPPED-FONTDESC CS
(PACKFILENAME.STRING (PACKFILENAME.STRING
:BODY DEST-DIR :NAME :BODY DEST-DIR :NAME
(\\FONTFILENAME (FONTPROP (IL:\\FONTFILENAME (FONTPROP
UNMAPPED-FONTDESC UNMAPPED-FONTDESC
'IL:FAMILY) 'IL:FAMILY)
SIZE FACE "DISPLAYFONT" CS)))) SIZE FACE "DISPLAYFONT" CS))))
(SETQ UNICODE-CSETS NIL)) (SETQ UNICODE-CSETS NIL))
@@ -801,6 +824,10 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(VALUES FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS)))) (VALUES FONTDESC CSETS UNMAPPED-FONTDESC UNICODE-CSETS UNMAPPEDGLYPHS))))
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY
(IL:FILESLOAD (IL:SYSLOAD)
IL:SYSEDIT)
(IL:FILESLOAD (IL:LOADCOMP) (IL:FILESLOAD (IL:LOADCOMP)
IL:FONT) IL:FONT)
) )
@@ -808,25 +835,23 @@ FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM REGULAR TCONC UTOXCODE UTOXCODE? WRITEST
(DEFINE-FILE-ENVIRONMENT "READ-BDF" :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP") (DEFINE-FILE-ENVIRONMENT "READ-BDF" :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP")
(:EXPORT "READ-BDF" (:EXPORT "READ-BDF"
"WRITE-BDF-TO-DISPLAYFONT-FILES") "WRITE-BDF-TO-DISPLAYFONT-FILES")
(:IMPORT \\AVGCHARWIDTH \\FGETWIDTH \\FONTFACE (:IMPORT-FROM "IL" "BITBLT" "BITMAPCREATE"
\\FONTFILENAME \\FSETOFFSET \\FSETWIDTH "BITMAPHEIGHT" "BITMAPWIDTH" "BLACKSHADE"
\\FONTSYMBOL \\GETSTREAM "BLTSHADE" "BOLD" "COMPRESSED"
\\INSTALLCHARSETINFO \\PUTBASE BITBLT "CHARSETINFO" "DISPLAY" "FONTDESCRIPTOR"
BITMAPCREATE BITMAPHEIGHT BITMAPWIDTH "FONTP" "FONTPROP" "INPUT" "ITALIC"
BLACKSHADE BLTSHADE BOLD CONDENSED "LIGHT" "LRSH" "MEDIUM" "REGULAR" "TCONC"
CHARSETINFO DISPLAY FONTDESCRIPTOR FONTP "UTOMCODE" "UTOMCODE?"
FONTPROP INPUT ITALIC LIGHT LRSH MEDIUM "WRITESTRIKEFONTFILE"))
REGULAR TCONC UTOXCODE UTOXCODE?
WRITESTRIKEFONTFILE))
:READTABLE "XCL" :READTABLE "XCL"
:COMPILER :COMPILE-FILE) :COMPILER :COMPILE-FILE)
(IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO) (IL:PUTPROPS IL:READ-BDF IL:DATABASE IL:NO)
(IL:DECLARE\: IL:DONTCOPY (IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL (2316 10275 (BDF-TO-CHARSETINFO 2316 . 10275)) (10277 16147 (BDF-TO-FONTDESCRIPTOR (IL:FILEMAP (NIL (2497 10576 (BDF-TO-CHARSETINFO 2497 . 10576)) (10578 16996 (BDF-TO-FONTDESCRIPTOR
10277 . 16147)) (16149 19687 (GET-FAMILY-FACE-SIZE-FROM-NAME 16149 . 19687)) (19689 26500 ( 10578 . 16996)) (16998 20538 (GET-FAMILY-FACE-SIZE-FROM-NAME 16998 . 20538)) (20540 27970 (
GLYPHS-BY-CHARSET 19689 . 26500)) (26502 27927 (PACKFILENAME.STRING 26502 . 27927)) (27929 34733 ( GLYPHS-BY-CHARSET 20540 . 27970)) (27972 29397 (PACKFILENAME.STRING 27972 . 29397)) (29399 36358 (
READ-BDF 27929 . 34733)) (34735 35058 (READ-DELIMITED-LIST-FROM-STRING 34735 . 35058)) (35060 41548 ( READ-BDF 29399 . 36358)) (36360 36683 (READ-DELIMITED-LIST-FROM-STRING 36360 . 36683)) (36685 43176 (
READ-GLYPH 35060 . 41548)) (41550 42291 (SPLIT-FONT-NAME 41550 . 42291)) (42293 46075 ( READ-GLYPH 36685 . 43176)) (43178 43919 (SPLIT-FONT-NAME 43178 . 43919)) (43921 47827 (
WRITE-BDF-TO-DISPLAYFONT-FILES 42293 . 46075))))) WRITE-BDF-TO-DISPLAYFONT-FILES 43921 . 47827)))))
IL:STOP IL:STOP

BIN
lispusers/READ-BDF.DFASL
View File

Binary file not shown.

BIN
lispusers/READ-BDF.TEDIT
View File

Binary file not shown.