Basic font files--see documentation
For the most part as described in docs/internal/FONTCODECHANGES and docs/internal/MEDLEYFONTFORMAT
This commit is contained in:
236
sources/AFONT
236
sources/AFONT
@@ -1,33 +1,31 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Jul-2025 19:53:00" {WMEDLEY}<sources>AFONT.;13 43176
|
||||
(FILECREATED "22-Jul-2025 23:20:06"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>AFONT.;15 27510
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS ACFONT.GETCHARSET \READACFONTFILE)
|
||||
:CHANGES-TO (VARS AFONTCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 8-Jul-2025 22:09:41" {WMEDLEY}<sources>AFONT.;12)
|
||||
:PREVIOUS-DATE "21-Jul-2025 00:14:04"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>sources>AFONT.;14)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT AFONTCOMS)
|
||||
|
||||
(RPAQQ AFONTCOMS
|
||||
(
|
||||
(* ;; "AC and Interpress font file support. ACFILEP is on FONT")
|
||||
[
|
||||
(* ;; "AC font file support. ACFONT.FILEP is on FONT")
|
||||
|
||||
(XCL:FILE-ENVIRONMENTS "AFONT")
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX)
|
||||
(CONSTANTS noInfoCode))
|
||||
(FNS ACFONT.FILEP ACFONT.GETCHARSET \CREATESTARFONT \READACFONTBOXES \READACFONTFILE
|
||||
\ACCHARIMAGELIST \ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \READFONTWDFILE
|
||||
\FACECODE \FAMILYCODE \FINDFONT)
|
||||
(ADDVARS (DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET)))
|
||||
(INITVARS (INTERPRESSFONTDIRECTORIES))
|
||||
(MACROS \POSITIONFONTFILE)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX))
|
||||
(FNS ACFONT.FILEP ACFONT.GETCHARSET \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST
|
||||
\ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \FACECODE \FAMILYCODE)
|
||||
(ADDVARS (DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET])
|
||||
|
||||
|
||||
|
||||
(* ;; "AC and Interpress font file support. ACFILEP is on FONT")
|
||||
(* ;; "AC font file support. ACFONT.FILEP is on FONT")
|
||||
|
||||
|
||||
(XCL:DEFINE-FILE-ENVIRONMENT "AFONT" :PACKAGE "IL"
|
||||
@@ -58,14 +56,6 @@
|
||||
|
||||
(RECORD FONTBOUNDINGBOX (FBBBDX FBBBDY FBBBOX FBBBOY))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ noInfoCode 32768)
|
||||
|
||||
|
||||
(CONSTANTS noInfoCode)
|
||||
)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -96,35 +86,6 @@
|
||||
|
||||
(\READACFONTFILE STRM])
|
||||
|
||||
(\CREATESTARFONT
|
||||
[LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 22-May-2025 09:59 by rmk")
|
||||
(* ; "Edited 18-May-2025 21:37 by rmk")
|
||||
(* gbn " 1-Oct-85 18:29")
|
||||
|
||||
(* ;; "the Build font descriptor for an Interpress NS font. If we can't find widths info for that font, return NIL")
|
||||
|
||||
(* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS")
|
||||
|
||||
(DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES \ASCIITONS))
|
||||
(RESETLST (* ;
|
||||
"RESETLST to make sure the fontfiles get closed")
|
||||
(LET [(FD (create FONTDESCRIPTOR
|
||||
FONTDEVICE _ DEVICE
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ PSIZE
|
||||
FONTFACE _ FACE
|
||||
\SFFACECODE _ (\FACECODE FACE)
|
||||
ROTATION _ ROTATION
|
||||
OTHERDEVICEFONTPROPS _ \ASCIITONS
|
||||
FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72]
|
||||
(CL:UNLESS (fetch (CHARSETINFO CSSLUGP) of (\INSURECHARSETINFO (OR CHARSET
|
||||
\DEFAULTCHARSET)
|
||||
FD))
|
||||
|
||||
(* ;; "return NIL for slug, let FONTCREATE decide whether or not to cause an error")
|
||||
|
||||
FD)))])
|
||||
|
||||
(\READACFONTBOXES
|
||||
[LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "15-Jun-85 11:48")
|
||||
(* ;
|
||||
@@ -448,93 +409,6 @@
|
||||
|
||||
(ROTATE-BITMAP-LEFT BITMAP])
|
||||
|
||||
(\READFONTWDFILE
|
||||
[LAMBDA (FILE FD WIDTHS SCALE) (* jds " 2-Jan-86 12:34")
|
||||
|
||||
(* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS")
|
||||
|
||||
(DECLARE (GLOBALVARS FONTWIDTHSFILES)) (* (RESETLST (* ;
|
||||
"RESETLST to make sure the fontfiles get closed")
|
||||
(PROG (FIXEDFLAGS FIRSTCHAR LASTCHAR
|
||||
TEM WIDTHSY) (SETFILEPTR FILE
|
||||
(LLSH (\FIXPIN FILE) 1))
|
||||
(* ; "Locate the segment")
|
||||
(replace (FONTDESCRIPTOR FBBOX) of FD
|
||||
with (SIGNED (\WIN FILE) BITSPERWORD))
|
||||
(replace \SFDescent of FD with
|
||||
(IMINUS (SIGNED (\WIN FILE)
|
||||
BITSPERWORD))) (* ; "Descent is -FBBOY")
|
||||
(replace (FONTDESCRIPTOR FBBDX) of FD
|
||||
with (SIGNED (\WIN FILE) BITSPERWORD))
|
||||
(replace \SFHeight of FD with
|
||||
(SIGNED (\WIN FILE) BITSPERWORD))
|
||||
(* ; "Height is FBBDY")
|
||||
(replace \SFWidths of FD with WIDTHS)
|
||||
(SETQ FIRSTCHAR (fetch FIRSTCHAR of FD))
|
||||
(* ;
|
||||
"First and last 'real' characters in the font")
|
||||
(SETQ LASTCHAR (fetch LASTCHAR of FD))
|
||||
(COND (SCALE (* ;
|
||||
"Dimensions are relative, must be scaled")
|
||||
(replace (FONTDESCRIPTOR FBBOX) of FD
|
||||
with (IQUOTIENT (ITIMES
|
||||
(fetch (FONTDESCRIPTOR FBBOX) of FD)
|
||||
SCALE) 1000)) (replace \SFDescent of
|
||||
FD with (IQUOTIENT (ITIMES
|
||||
(fetch \SFDescent of FD) SCALE) 1000))
|
||||
(replace (FONTDESCRIPTOR FBBDX) of FD
|
||||
with (IQUOTIENT (ITIMES
|
||||
(fetch (FONTDESCRIPTOR FBBDX) of FD)
|
||||
SCALE) 1000)) (replace \SFHeight of FD
|
||||
with (IQUOTIENT (ITIMES
|
||||
(fetch \SFHeight of FD) SCALE) 1000))))
|
||||
(replace \SFAscent of FD with
|
||||
(IDIFFERENCE (fetch \SFHeight of FD)
|
||||
(fetch \SFDescent of FD)))
|
||||
(SETQ FIXEDFLAGS (LRSH
|
||||
(\BIN FILE) 6)) (* ;
|
||||
"The fixed flags") (\BIN FILE)
|
||||
(* ; "Skip the spares")
|
||||
(COND ((EQ 2 (LOGAND FIXEDFLAGS 2))
|
||||
(SETQ TEM (\WIN FILE))
|
||||
(* ; "The fixed width for this font")
|
||||
(COND ((AND SCALE (NOT
|
||||
(ZEROP TEM))) (SETQ TEM
|
||||
(IQUOTIENT (ITIMES TEM SCALE) 1000))))
|
||||
(for I from FIRSTCHAR to LASTCHAR do
|
||||
(SETA WIDTHS I TEM)))
|
||||
(T (AIN WIDTHS FIRSTCHAR
|
||||
(ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
|
||||
FILE) (for I from FIRSTCHAR to
|
||||
LASTCHAR when (EQ noInfoCode
|
||||
(ELT WIDTHS I)) do (SETA WIDTHS I 0))
|
||||
(COND (SCALE (for I from FIRSTCHAR to
|
||||
LASTCHAR do (SETA WIDTHS I
|
||||
(IQUOTIENT (ITIMES (ELT WIDTHS I)
|
||||
SCALE) 1000))))))) (COND
|
||||
((EQ 1 (LOGAND FIXEDFLAGS 1))
|
||||
(SETQ WIDTHSY (\WIN FILE))
|
||||
(* ;
|
||||
"The fixed width-Y for this font; the width-Y field is a single integer in the FD")
|
||||
(replace \SFWidthsY of FD with
|
||||
(COND ((AND SCALE (NOT
|
||||
(ZEROP WIDTHSY))) (IQUOTIENT
|
||||
(ITIMES WIDTHSY SCALE) 1000))
|
||||
(T WIDTHSY)))) (T (replace \SFWidthsY
|
||||
of FD with (SETQ WIDTHSY
|
||||
(ARRAY (ADD1 \MAXCHAR)
|
||||
(QUOTE SMALLPOSP) 0 0)))
|
||||
(AIN WIDTHSY FIRSTCHAR
|
||||
(ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))
|
||||
FILE) (for I from FIRSTCHAR to
|
||||
LASTCHAR when (EQ noInfoCode
|
||||
(ELT WIDTHSY I)) do (SETA WIDTHSY I 0))
|
||||
(COND (SCALE (for I from FIRSTCHAR to
|
||||
LASTCHAR do (SETA WIDTHSY I
|
||||
(IQUOTIENT (ITIMES (ELT WIDTHSY I)
|
||||
SCALE) 1000))))))))))
|
||||
(HELP])
|
||||
|
||||
(\FACECODE
|
||||
[LAMBDA (FACE) (* rmk%: "27-FEB-81 12:16")
|
||||
(IPLUS (SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
|
||||
@@ -578,90 +452,12 @@
|
||||
(RETURN CODE))))
|
||||
(0 (RETURN NIL))
|
||||
NIL])
|
||||
|
||||
(\FINDFONT
|
||||
[LAMBDA (FD WSTRM PRESSMICASIZE NSMICASIZE DONTCHECK) (* ; "Edited 2-Apr-87 14:39 by bvm:")
|
||||
|
||||
(* ;; "Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. The FIRSTCHAR and LASTCHAR of the font are filled in, since we have to read past those to check the size. If successful, returns the size found in the widths file, with zero indicating that dimensions in the widths file are relative, leaving the file pointing just after the Rotation word of the font. --- If DONTCHECK, then assumes that this file contains exactly the right face and family, without checking --- Returns NIL if the font is not found")
|
||||
(* (bind TYPE LENGTH SIZE FAMILYCODE
|
||||
(ROTATION _ (fetch ROTATION of FD))
|
||||
(FACECODE _ (\FACECODE
|
||||
(fetch FONTFACE of FD)))
|
||||
(NEXT _ 0) (FUZZ _ (PROG1 0.02
|
||||
(* ;
|
||||
"percentile difference acceptable as the same font size")))
|
||||
first (OR (SETQ FAMILYCODE
|
||||
(\FAMILYCODE (OR DONTCHECK
|
||||
(fetch FONTFAMILY of FD)) WSTRM))
|
||||
(RETURN NIL)) do (SETQ TYPE
|
||||
(\BIN WSTRM)) (SETQ LENGTH
|
||||
(\BIN WSTRM)) (add NEXT
|
||||
(LLSH (IPLUS LENGTH (LLSH
|
||||
(LOGAND TYPE 15) 8)) 1))
|
||||
(SELECTQ (LRSH TYPE 4)
|
||||
(4 (COND ((OR (AND (EQ FAMILYCODE
|
||||
(\BIN WSTRM)) (EQ FACECODE
|
||||
(\BIN WSTRM))) DONTCHECK)
|
||||
(* ;
|
||||
"This is the right family/face (DONTCHECK must come last, so the file reads get done.)")
|
||||
(replace FIRSTCHAR of FD with
|
||||
(\BIN WSTRM)) (replace LASTCHAR of FD
|
||||
with (\BIN WSTRM)) (COND
|
||||
((AND (OR (ZEROP (SETQ SIZE
|
||||
(\WIN WSTRM))) (LESSP
|
||||
(ABS (FQUOTIENT (IDIFFERENCE
|
||||
(OR PRESSMICASIZE NSMICASIZE) SIZE)
|
||||
PRESSMICASIZE)) FUZZ))
|
||||
(EQ ROTATION (\WIN WSTRM)))
|
||||
(replace \SFFACECODE of FD with
|
||||
FACECODE) (RETURN SIZE))))))
|
||||
(0 (RETURN NIL)) NIL)
|
||||
(SETFILEPTR WSTRM NEXT)))
|
||||
(HELP])
|
||||
)
|
||||
|
||||
(ADDTOVAR DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET))
|
||||
|
||||
(RPAQ? INTERPRESSFONTDIRECTORIES )
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \POSITIONFONTFILE MACRO
|
||||
((WSTRM NSMICASIZE FIRSTCHAR LASTCHAR FAMILY FACECODE)
|
||||
(* gbn "25-Jul-85 02:15")
|
||||
(bind TYPE LENGTH SIZE FAMCODE FILEFAM FILEFACE (NEXT _ 0)
|
||||
first (OR (SETQ FAMCODE (\FAMILYCODE (OR FAMILY T)
|
||||
WSTRM))
|
||||
(RETURN NIL))
|
||||
do (SETQ TYPE (\BIN WSTRM))
|
||||
(SETQ LENGTH (\BIN WSTRM))
|
||||
(add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15)
|
||||
8))
|
||||
1))
|
||||
(SELECTQ (LRSH TYPE 4)
|
||||
(4 (SETQ FILEFAM (\BIN WSTRM))
|
||||
(SETQ FILEFACE (\BIN WSTRM))
|
||||
[COND
|
||||
((OR (EQ FAMILY T)
|
||||
(EQ FAMILY NIL)
|
||||
(AND (IEQP FILEFAM FAMCODE)
|
||||
(IEQP FILEFACE FACECODE)))
|
||||
(SETQ FIRSTCHAR (\BIN WSTRM))
|
||||
(SETQ LASTCHAR (\BIN WSTRM))
|
||||
(COND
|
||||
((AND (OR (ZEROP (SETQ SIZE (\WIN WSTRM)))
|
||||
(LESSP (ABS (FQUOTIENT (IDIFFERENCE NSMICASIZE SIZE)
|
||||
NSMICASIZE))
|
||||
0.02))
|
||||
(ZEROP (\WIN WSTRM)))
|
||||
(RETURN SIZE])
|
||||
(0 (RETURN NIL))
|
||||
NIL)
|
||||
(SETFILEPTR WSTRM NEXT))))
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2849 41269 (ACFONT.FILEP 2859 . 3743) (ACFONT.GETCHARSET 3745 . 4137) (\CREATESTARFONT
|
||||
4139 . 5862) (\READACFONTBOXES 5864 . 8091) (\READACFONTFILE 8093 . 20934) (\ACCHARIMAGELIST 20936 .
|
||||
21293) (\ACCHARWIDTHLIST 21295 . 22561) (\GETFBB 22563 . 25843) (\ACCHARPOSLIST 25845 . 26895) (
|
||||
\ACROTATECHAR 26897 . 27461) (\READFONTWDFILE 27463 . 35496) (\FACECODE 35498 . 36092) (\FAMILYCODE
|
||||
36094 . 37398) (\FINDFONT 37400 . 41267)))))
|
||||
(FILEMAP (NIL (2626 27417 (ACFONT.FILEP 2636 . 3520) (ACFONT.GETCHARSET 3522 . 3914) (\READACFONTBOXES
|
||||
3916 . 6143) (\READACFONTFILE 6145 . 18986) (\ACCHARIMAGELIST 18988 . 19345) (\ACCHARWIDTHLIST 19347
|
||||
. 20613) (\GETFBB 20615 . 23895) (\ACCHARPOSLIST 23897 . 24947) (\ACROTATECHAR 24949 . 25513) (
|
||||
\FACECODE 25515 . 26109) (\FAMILYCODE 26111 . 27415)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
3839
sources/FONT
3839
sources/FONT
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -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 " 4-Sep-2025 11:43:26" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;240 58467
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS MEDLEYFONT.READ.ITEM)
|
||||
:CHANGES-TO (FNS MEDLEYFONT.WRITE.CHARSET MEDLEYFONT.READ.CHARSET MEDLEYFONT.FILENAME)
|
||||
|
||||
:PREVIOUS-DATE "24-Jul-2025 22:07:35" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;217)
|
||||
:PREVIOUS-DATE " 3-Sep-2025 11:32:20" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;235)
|
||||
|
||||
|
||||
(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,12 @@
|
||||
(FULLNAME STREAM])
|
||||
|
||||
(MEDLEYFONT.GETCHARSET
|
||||
[LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 17:09 by rmk")
|
||||
[LAMBDA (STREAM CHARSET FONT) (* ; "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 +147,12 @@
|
||||
(ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM))))
|
||||
(LET ((CSVECTORLOC (\FIXPIN STREAM))
|
||||
CSLOC)
|
||||
(MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT) (* ;
|
||||
"Maybe only for the first character set?")
|
||||
(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 +194,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 +203,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 +263,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 +276,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 +292,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ÿ | ||||