Rmk151 Remove old fontfile conventions from \FONTFILENAME (#2462)
* Remove code for archaic \FONTFILENAME conventions, MEDLEYFONTFORMAT now calls the generic function. * Add OCTALSTRING to APRINT so FONT can use it. Eventually remove it from PUP
This commit is contained in:
rmkaplan
GitHub
164
sources/APRINT
164
sources/APRINT
@@ -1,21 +1,18 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 9-Jun-2021 22:50:15"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>APRINT.;11 79264
|
||||
|
||||
changes to%: (VARS APRINTCOMS)
|
||||
(FILECREATED "22-Jan-2026 16:13:45" {WMEDLEY}<sources>APRINT.;5 78925
|
||||
|
||||
previous date%: "10-May-2021 15:46:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>APRINT.;10)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS APRINTCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 9-Jun-2021 22:50:15" {WMEDLEY}<sources>APRINT.;1)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT APRINTCOMS)
|
||||
|
||||
(RPAQQ APRINTCOMS
|
||||
[(COMS (* ; "User-level print functions")
|
||||
[(COMS (* ; "User-level print functions")
|
||||
(FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE \PRINTCCODE PRINTLEVEL RADIX SPACES
|
||||
TERPRI FRESHLINE DEFPRINT LINELENGTH))
|
||||
(INITVARS (PLVLFILEFLG NIL)
|
||||
@@ -38,8 +35,9 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(*KEYWORD-PACKAGE* NIL)
|
||||
(*INTERLISP-PRIN1-CASE* ':UPCASE)
|
||||
(\DEFPRINTFNS NIL))
|
||||
(COMS (* ; "PRINT internals")
|
||||
(COMS (* ; "PRINT internals")
|
||||
(FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
|
||||
(FNS OCTALSTRING)
|
||||
(FNS \PRINDATUM \PRINT-USING-DEFPRINT \PRINT-USING-ADDRESS \ELIDE.PRINT.ELEMENT
|
||||
\ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT
|
||||
\CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP
|
||||
@@ -49,23 +47,24 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(EXPORT (MACROS .SPACECHECK. \CHECKRADIX)))
|
||||
(FNS \INVALID.RADIX)
|
||||
(SPECVARS \THISFILELINELENGTH))
|
||||
(COMS (* ; "Internal printing")
|
||||
(COMS (* ; "Internal printing")
|
||||
(FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP)
|
||||
(DECLARE%: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
|
||||
(MACROS PNAMESTREAMP))
|
||||
(INITRESOURCES \MAPPNAMESTREAM)
|
||||
[INITVARS (\PNAMEDEVICE (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME 'NULL T]
|
||||
(GLOBALVARS \PNAMEDEVICE))
|
||||
(COMS (* ; "Obsolete")
|
||||
(COMS (* ; "Obsolete")
|
||||
(FNS \MAPCHARS))
|
||||
(DECLARE%: EVAL@COMPILE DOCOPY
|
||||
(ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE*
|
||||
*PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH*
|
||||
*PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*)))
|
||||
(COMS (* ; "PRINTNUM and friends")
|
||||
(COMS (* ; "PRINTNUM and friends")
|
||||
(FNS PRINTNUM FLTFMT \CHECKFLTFMT PRINTNUM-TO-STRING)
|
||||
(MACROS NUMFORMATCODE)
|
||||
(INITVARS (NILNUMPRINTFLG)))
|
||||
(PROPS (APRINT FILETYPE))
|
||||
(LOCALVARS . T)
|
||||
(GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
@@ -401,6 +400,13 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(OCTALSTRING
|
||||
[LAMBDA (N) (* bvm%: "21-JUL-81 12:16")
|
||||
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
|
||||
(CONCAT (\CONVERTNUMBER N 8 NIL NIL \NUMSTR \NUMSTR1])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\PRINDATUM
|
||||
[LAMBDA (OBJECT STREAM CPL) (* ; "Edited 11-Feb-91 14:34 by jds")
|
||||
(DECLARE (USEDFREE *READTABLE* *PRINT-RADIX* *PRINT-BASE* *PRINT-ESCAPE*))
|
||||
@@ -1117,75 +1123,72 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS .FILELINELENGTH. MACRO ((STRM)
|
||||
(LET ((L (fetch (STREAM LINELENGTH) of STRM)))
|
||||
(SELECTC L
|
||||
(0 (* Some default)
|
||||
\LINELENGTH)
|
||||
(MAX.SMALLP
|
||||
(* Infinite)
|
||||
NIL)
|
||||
L))))
|
||||
(LET ((L (fetch (STREAM LINELENGTH) of STRM)))
|
||||
(SELECTC L
|
||||
(0 (* Some default)
|
||||
\LINELENGTH)
|
||||
(MAX.SMALLP (* Infinite)
|
||||
NIL)
|
||||
L))))
|
||||
)
|
||||
|
||||
|
||||
(DEFMACRO \PRINDATUM-LISTP ()
|
||||
|
||||
(* ;; "This is a hokey macro call to save the function call. Read it as though it were inline code in \prindatum")
|
||||
(* ;; "This is a hokey macro call to save the function call. Read it as though it were inline code in \prindatum")
|
||||
|
||||
`[LET (LABEL FIRSTTIME)
|
||||
(OR CPL (SETQ CPL 0))
|
||||
(if *PRINT-CIRCLE-HASHTABLE*
|
||||
then
|
||||
(* ;; "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")
|
||||
|
||||
(* ;; "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")
|
||||
|
||||
(CL:MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
|
||||
(PRINT-CIRCLE-LOOKUP OBJECT)))
|
||||
(CL:MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
|
||||
(PRINT-CIRCLE-LOOKUP OBJECT)))
|
||||
[if LABEL
|
||||
then (\CKPOSSOUT STREAM LABEL)
|
||||
(CL:WHEN FIRSTTIME
|
||||
(\CKPOSBOUT STREAM (CHARCODE SPACE)))]
|
||||
(CL:WHEN FIRSTTIME
|
||||
(\CKPOSBOUT STREAM (CHARCODE SPACE)))]
|
||||
(COND
|
||||
((AND LABEL (NOT FIRSTTIME)) (* ;
|
||||
"Second reference --- just print label")
|
||||
((AND LABEL (NOT FIRSTTIME)) (* ;
|
||||
"Second reference --- just print label")
|
||||
NIL)
|
||||
((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* CPL))
|
||||
(\ELIDE.PRINT.ELEMENT STREAM))
|
||||
(T (PROG (CDRCNT)
|
||||
[COND
|
||||
(*PRINT-LENGTH* (SETQ CDRCNT (COND
|
||||
((fetch (READTABLEP COMMONLISP)
|
||||
of *READTABLE*)
|
||||
((fetch (READTABLEP COMMONLISP) of
|
||||
*READTABLE*
|
||||
)
|
||||
0)
|
||||
(T (* ;
|
||||
"Interlisp print depth is triangular, Common Lisp isn't")
|
||||
(T (* ;
|
||||
"Interlisp print depth is triangular, Common Lisp isn't")
|
||||
[COND
|
||||
((IGEQ CPL *PRINT-LENGTH*)
|
||||
(* ;
|
||||
"We would just print '(--)' so it's nicer to print '&'")
|
||||
(RETURN (\ELIDE.PRINT.ELEMENT
|
||||
STREAM]
|
||||
(* ;
|
||||
"We would just print '(--)' so it's nicer to print '&'")
|
||||
(RETURN (\ELIDE.PRINT.ELEMENT STREAM]
|
||||
CPL]
|
||||
(add CPL 1) (* ;
|
||||
"Recursive calls will be at 1 greater depth")
|
||||
(add CPL 1) (* ;
|
||||
"Recursive calls will be at 1 greater depth")
|
||||
(\CKPOSBOUT STREAM (CHARCODE %())
|
||||
LP [COND
|
||||
((AND CDRCNT (IGREATERP (add CDRCNT 1)
|
||||
*PRINT-LENGTH*)) (* ;
|
||||
"have printed as many elements as allowed")
|
||||
*PRINT-LENGTH*)) (* ;
|
||||
"have printed as many elements as allowed")
|
||||
(\ELIDE.PRINT.TAIL STREAM T))
|
||||
(T (\PRINDATUM (CAR OBJECT)
|
||||
STREAM CPL)
|
||||
(COND
|
||||
((LISTP (SETQ OBJECT (CDR OBJECT)))
|
||||
(\CKPOSBOUT STREAM (CHARCODE SPACE))
|
||||
(if (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P OBJECT
|
||||
))
|
||||
then (* ; "Must print as a dotted tail")
|
||||
(\CKPOSSOUT STREAM ". ")
|
||||
(\PRINDATUM OBJECT STREAM CPL)
|
||||
(if (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P OBJECT))
|
||||
then (* ; "Must print as a dotted tail")
|
||||
(\CKPOSSOUT STREAM ". ")
|
||||
(\PRINDATUM OBJECT STREAM CPL)
|
||||
else (GO LP)))
|
||||
(OBJECT (* ; "Dotted tail")
|
||||
(OBJECT (* ; "Dotted tail")
|
||||
(\CKPOSSOUT STREAM " . ")
|
||||
(\PRINDATUM OBJECT STREAM]
|
||||
(\CKPOSBOUT STREAM (CHARCODE ")"])
|
||||
@@ -1193,20 +1196,18 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS .SPACECHECK. MACRO ((STRM N)
|
||||
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N
|
||||
(fetch
|
||||
CHARPOSITION
|
||||
of STRM))
|
||||
\THISFILELINELENGTH)
|
||||
(FRESHLINE STRM))))
|
||||
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch CHARPOSITION
|
||||
of STRM))
|
||||
\THISFILELINELENGTH)
|
||||
(FRESHLINE STRM))))
|
||||
|
||||
(PUTPROPS \CHECKRADIX MACRO [LAMBDA (R)
|
||||
(COND
|
||||
((OR (NOT (SMALLP R))
|
||||
(ILESSP R 1)
|
||||
(IGREATERP R 36))
|
||||
(\INVALID.RADIX R))
|
||||
(T R])
|
||||
(COND
|
||||
((OR (NOT (SMALLP R))
|
||||
(ILESSP R 1)
|
||||
(IGREATERP R 36))
|
||||
(\INVALID.RADIX R))
|
||||
(T R])
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
@@ -1280,8 +1281,8 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PNAMESTREAMP DMACRO ((STRM)
|
||||
(EQ (fetch (STREAM DEVICE) of STRM)
|
||||
\PNAMEDEVICE)))
|
||||
(EQ (fetch (STREAM DEVICE) of STRM)
|
||||
\PNAMEDEVICE)))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -1312,8 +1313,8 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DOCOPY
|
||||
|
||||
(ADDTOVAR SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-CASE*
|
||||
*PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY*
|
||||
*PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*)
|
||||
*PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE*
|
||||
*PRINT-ARRAY* *PACKAGE*)
|
||||
)
|
||||
|
||||
|
||||
@@ -1455,6 +1456,8 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQ? NILNUMPRINTFLG )
|
||||
|
||||
(PUTPROPS APRINT FILETYPE TCOMPL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
@@ -1471,22 +1474,21 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS APRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
|
||||
2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3743 13280 (PRIN1 3753 . 5238) (PRIN2 5240 . 6433) (PRIN3 6435 . 7469) (PRIN4 7471 .
|
||||
8654) (PRINT 8656 . 8892) (PRINTCCODE 8894 . 9167) (\PRINTCCODE 9169 . 9638) (PRINTLEVEL 9640 . 10346)
|
||||
(RADIX 10348 . 10530) (SPACES 10532 . 10878) (TERPRI 10880 . 11065) (FRESHLINE 11067 . 11744) (
|
||||
DEFPRINT 11746 . 12318) (LINELENGTH 12320 . 13278)) (13942 18274 (PRINT-CIRCLE-LOOKUP 13952 . 15118) (
|
||||
PRINT-CIRCLE-LABEL-P 15120 . 15596) (PRINT-CIRCLE-SCAN 15598 . 17560) (PRINT-CIRCLE-ENTER 17562 .
|
||||
18272)) (18275 62434 (\PRINDATUM 18285 . 21227) (\PRINT-USING-DEFPRINT 21229 . 22601) (
|
||||
\PRINT-USING-ADDRESS 22603 . 23579) (\ELIDE.PRINT.ELEMENT 23581 . 23751) (\ELIDE.ELEMENT.CHAR 23753 .
|
||||
24036) (\ELIDE.PRINT.TAIL 24038 . 24462) (\ELIDE.TAIL.STRING 24464 . 24685) (\CKPOSBOUT 24687 . 24852)
|
||||
(\CKPOSSOUT 24854 . 25068) (\CONVERTNUMBER 25070 . 29559) (\LITPRIN 29561 . 36096) (\LITPRIN.INTERNAL
|
||||
36098 . 44453) (\SYMBOL.ESCAPE.COUNT 44455 . 51223) (\NUMERIC.PNAMEP 51225 . 57808) (\PRINSTACKP
|
||||
57810 . 59115) (\PRINTADDR 59117 . 60214) (\PRINSTRING 60216 . 61712) (\SOUT 61714 . 62432)) (67877
|
||||
68045 (\INVALID.RADIX 67887 . 68043)) (68149 70224 (\MAPPNAME 68159 . 69154) (\MAPPNAME.INTERNAL 69156
|
||||
. 69867) (PNAMESTREAMP 69869 . 70222)) (70907 71295 (\MAPCHARS 70917 . 71293)) (71626 78665 (PRINTNUM
|
||||
71636 . 74693) (FLTFMT 74695 . 75085) (\CHECKFLTFMT 75087 . 75655) (PRINTNUM-TO-STRING 75657 . 78663)
|
||||
))))
|
||||
(FILEMAP (NIL (3664 13201 (PRIN1 3674 . 5159) (PRIN2 5161 . 6354) (PRIN3 6356 . 7390) (PRIN4 7392 .
|
||||
8575) (PRINT 8577 . 8813) (PRINTCCODE 8815 . 9088) (\PRINTCCODE 9090 . 9559) (PRINTLEVEL 9561 . 10267)
|
||||
(RADIX 10269 . 10451) (SPACES 10453 . 10799) (TERPRI 10801 . 10986) (FRESHLINE 10988 . 11665) (
|
||||
DEFPRINT 11667 . 12239) (LINELENGTH 12241 . 13199)) (13863 18195 (PRINT-CIRCLE-LOOKUP 13873 . 15039) (
|
||||
PRINT-CIRCLE-LABEL-P 15041 . 15517) (PRINT-CIRCLE-SCAN 15519 . 17481) (PRINT-CIRCLE-ENTER 17483 .
|
||||
18193)) (18196 18426 (OCTALSTRING 18206 . 18424)) (18427 62586 (\PRINDATUM 18437 . 21379) (
|
||||
\PRINT-USING-DEFPRINT 21381 . 22753) (\PRINT-USING-ADDRESS 22755 . 23731) (\ELIDE.PRINT.ELEMENT 23733
|
||||
. 23903) (\ELIDE.ELEMENT.CHAR 23905 . 24188) (\ELIDE.PRINT.TAIL 24190 . 24614) (\ELIDE.TAIL.STRING
|
||||
24616 . 24837) (\CKPOSBOUT 24839 . 25004) (\CKPOSSOUT 25006 . 25220) (\CONVERTNUMBER 25222 . 29711) (
|
||||
\LITPRIN 29713 . 36248) (\LITPRIN.INTERNAL 36250 . 44605) (\SYMBOL.ESCAPE.COUNT 44607 . 51375) (
|
||||
\NUMERIC.PNAMEP 51377 . 57960) (\PRINSTACKP 57962 . 59267) (\PRINTADDR 59269 . 60366) (\PRINSTRING
|
||||
60368 . 61864) (\SOUT 61866 . 62584)) (63167 66808 (\PRINDATUM-LISTP 63167 . 66808)) (67634 67802 (
|
||||
\INVALID.RADIX 67644 . 67800)) (67906 69981 (\MAPPNAME 67916 . 68911) (\MAPPNAME.INTERNAL 68913 .
|
||||
69624) (PNAMESTREAMP 69626 . 69979)) (70648 71036 (\MAPCHARS 70658 . 71034)) (71358 78397 (PRINTNUM
|
||||
71368 . 74425) (FLTFMT 74427 . 74817) (\CHECKFLTFMT 74819 . 75387) (PRINTNUM-TO-STRING 75389 . 78395))
|
||||
)))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
459
sources/FONT
459
sources/FONT
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "31-Dec-2025 22:41:44" {WMEDLEY}<sources>FONT.;655 285234
|
||||
(FILECREATED "26-Jan-2026 16:37:58" {WMEDLEY}<sources>FONT.;664 276319
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS FONTCOMS)
|
||||
(FNS \CREATEFONT FONTPROP)
|
||||
|
||||
:PREVIOUS-DATE "25-Dec-2025 10:58:30" {WMEDLEY}<sources>FONT.;654)
|
||||
:PREVIOUS-DATE "22-Jan-2026 14:25:36" {WMEDLEY}<sources>FONT.;659)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT FONTCOMS)
|
||||
@@ -46,16 +47,7 @@
|
||||
(FNS MOVECHARBITMAP MOVEFONTCHARS \MOVEFONTCHAR \MOVEFONTCHARS.SOURCEDATA \MAKESLUGCHAR
|
||||
SLUGCHARP.DISPLAY)
|
||||
(MACROS UPDATEINFOELEMENT))
|
||||
(COMS
|
||||
(* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories. That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places. ")
|
||||
|
||||
(FNS FONTFILES \FINDFONTFILE \FONTFILENAMES \FONTFILENAME \FONTFILENAME.OLD
|
||||
\FONTFILENAME.NEW FONTSPECFROMFILENAME \FONTINFOFROMFILENAME.OLD)
|
||||
(* (* ; "Do we still want old fonts?")
|
||||
(ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE)))
|
||||
(INITVARS (*OLD-FONT-EXTENSIONS* NIL))
|
||||
(INITVARS (*USEOLDFONTDIRECTORIES* NIL))
|
||||
(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*))
|
||||
(FNS FONTFILES \FINDFONTFILE \FONTFILENAMES \FONTFILENAME FONTSPECFROMFILENAME)
|
||||
(FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \COERCECHARSET
|
||||
\BUILDSLUGCSINFO \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR SETFONTCHARENCODING
|
||||
)
|
||||
@@ -1179,7 +1171,8 @@
|
||||
(fetch (FONTDESCRIPTOR \SFHeight) of (FONTCREATE FONTSPEC])
|
||||
|
||||
(FONTPROP
|
||||
[LAMBDA (FONT PROP) (* ; "Edited 2-Dec-2025 16:01 by rmk")
|
||||
[LAMBDA (FONT PROP) (* ; "Edited 25-Jan-2026 20:08 by rmk")
|
||||
(* ; "Edited 2-Dec-2025 16:01 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 22:21 by rmk")
|
||||
(* ; "Edited 12-Aug-2025 21:10 by rmk")
|
||||
(* ; "Edited 10-Aug-2025 13:28 by rmk")
|
||||
@@ -1256,6 +1249,7 @@
|
||||
\MAXCHARSET
|
||||
eachtime (SETQ CSINFO (\GETBASEPTR CSVECTOR (UNFOLD CS 2))) when CSINFO
|
||||
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CS))
|
||||
(AVGCHARWIDTH (ffetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT))
|
||||
(FONTTOMCCSFN (ffetch FONTTOMCCSFN of FONT))
|
||||
(\ILLEGAL.ARG PROP])
|
||||
|
||||
@@ -1820,13 +1814,6 @@
|
||||
(freplace (CHARSETINFO FIELD) of DCSINFO with DBLOCK))
|
||||
(\FSETWIDTH DBLOCK DTHINCODE NEWVAL))])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories. That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places. "
|
||||
)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(FONTFILES
|
||||
@@ -1853,6 +1840,7 @@
|
||||
|
||||
(\FINDFONTFILE
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST)
|
||||
(* ; "Edited 22-Jan-2026 08:54 by rmk")
|
||||
(* ; "Edited 3-Dec-2025 23:38 by rmk")
|
||||
(* ; "Edited 9-Jun-2025 09:40 by rmk")
|
||||
(* ; "Edited 15-May-2025 22:41 by rmk")
|
||||
@@ -1864,13 +1852,9 @@
|
||||
(CL:UNLESS DIRLST
|
||||
(SETQ DIRLST (CONS NIL)))
|
||||
|
||||
(* ;; "Find any font file on any directory with any naming convention with any extension. Note that ROTATION and DEVICE are just place holders. DEVICE is irrelevant because DIRLST already incorporates the device information. The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup. If set to a list of extensions, just those will be looked up with old-style conventions.")
|
||||
(* ;; "Find any font file on any directory with any naming convention with any extension. Note that ROTATION and DEVICE are just place holders. DEVICE is irrelevant because DIRLST already incorporates the device information. ")
|
||||
|
||||
(for EXT FONTFILE inside EXTLST join (SETQ FONTFILE (if (FMEMB EXT *OLD-FONT-EXTENSIONS*)
|
||||
then (\FONTFILENAME.OLD FAMILY SIZE FACE
|
||||
EXT CHARSET)
|
||||
else (\FONTFILENAME FAMILY SIZE FACE EXT
|
||||
CHARSET)))
|
||||
(for EXT FONTFILE inside EXTLST join (SETQ FONTFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET))
|
||||
(for DIR FOUND inside DIRLST
|
||||
when (SETQ FOUND (INFILEP (PACKFILENAME.STRING
|
||||
'DIRECTORY DIR 'BODY FONTFILE)
|
||||
@@ -1883,165 +1867,61 @@
|
||||
(RETURN (CAR $$VAL)))])
|
||||
|
||||
(\FONTFILENAMES
|
||||
[LAMBDA (FAMILY SIZE FACE DEVICE EXTENSIONS) (* ; "Edited 7-Oct-2025 12:21 by rmk")
|
||||
[LAMBDA (FAMILY SIZE FACE DEVICE EXTENSIONS) (* ; "Edited 22-Jan-2026 09:01 by rmk")
|
||||
(* ; "Edited 7-Oct-2025 12:21 by rmk")
|
||||
(* ; "Edited 17-May-2025 12:15 by rmk")
|
||||
(APPEND [for EXT inside EXTENSIONS collect (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*)
|
||||
THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT
|
||||
'NOCHARSET)
|
||||
ELSE (\FONTFILENAME FAMILY SIZE FACE EXT
|
||||
'NOCHARSET]
|
||||
(for EXT inside EXTENSIONS collect (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*)
|
||||
THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT 0)
|
||||
ELSE (\FONTFILENAME FAMILY SIZE FACE EXT 0])
|
||||
(APPEND (for EXT inside EXTENSIONS collect (\FONTFILENAME FAMILY SIZE FACE EXT 'NOCHARSET))
|
||||
(for EXT inside EXTENSIONS collect (\FONTFILENAME FAMILY SIZE FACE EXT 0])
|
||||
|
||||
(\FONTFILENAME
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 11-Jul-2025 09:39 by rmk")
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 22-Jan-2026 14:25 by rmk")
|
||||
(* ; "Edited 11-Jul-2025 09:39 by rmk")
|
||||
(* ; "Edited 15-May-2025 15:51 by rmk")
|
||||
(* ; "Edited 5-Mar-93 16:10 by rmk:")
|
||||
|
||||
(* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported. New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD")
|
||||
|
||||
(* ;; "**bvm 10/5/89 Slight change: partition fonts into subdirectories by charset, e.g., all Charset zero fonts are in subdirectory C0>. This significantly speeds up any font operation that requires any local directory work (e.g., NFS servers on both Sun and D machine), and FONTSAVAILABLE on any device (since it doesn't have to wade thru all those charsets). This behavior is conditioned on the value of *USEOLDFONTDIRECTORIES*")
|
||||
(* ;; "FAMILY can be a FONTSPEC")
|
||||
|
||||
(DECLARE (SPECVARS FAMILY SIZE FACE))
|
||||
(SETQ FACE (\FONTFACE FACE)) (* ; "Validate face")
|
||||
(LET* ([SIZEPATT (COND
|
||||
((EQ SIZE '*)
|
||||
SIZE)
|
||||
((FIXP SIZE)
|
||||
(if (< SIZE 10)
|
||||
then (CONCAT 0 SIZE)
|
||||
else SIZE))
|
||||
(T (\ILLEGAL.ARG SIZE]
|
||||
(CSETNAME (COND
|
||||
((OR (NULL CHARSET)
|
||||
(EQ CHARSET 0)) (* ; "Charset defaults to zero.")
|
||||
"0")
|
||||
((FIXP CHARSET)
|
||||
(LET ((*PRINT-BASE* 8)
|
||||
(*PRINT-RADIX* NIL)) (* ; "Longhand for (cl:write-to-string charset :radix nil :base 8), which is twice as slow, due to lousy keyword handling")
|
||||
(\PRINDATUM.TO.STRING CHARSET)))
|
||||
((EQ CHARSET 'NOCHARSET) (* ; "Don't want the charset indicated")
|
||||
NIL)
|
||||
(T (* ; "Somebody made the string already?")
|
||||
CHARSET)))
|
||||
[FACESPEC (LIST (CHCON1 (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(CHCON1 (fetch (FONTFACE SLOPE) of FACE))
|
||||
(CHCON1 (fetch (FONTFACE EXPANSION) of FACE]
|
||||
(TAIL FACESPEC))
|
||||
[if (OR (EQ (CAR TAIL)
|
||||
(CHARCODE *))
|
||||
(EQ (CAR (SETQ TAIL (CDR TAIL)))
|
||||
(CHARCODE *)))
|
||||
then (* ;
|
||||
"Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.")
|
||||
(while (EQ (CADR TAIL)
|
||||
(CHARCODE *)) do (RPLACD TAIL (CDDR TAIL]
|
||||
(LET (ROTATION DEVICE SIZEPATT CSETNAME FACESPEC STARPOS FILENAME)
|
||||
(DECLARE (SPECVARS ROTATION DEVICE))
|
||||
(CL:WHEN (type? FONTSPEC FAMILY)
|
||||
(SPREADFONTSPEC FAMILY))
|
||||
(SETQ SIZEPATT (CL:IF (OR (EQ SIZE '*)
|
||||
(>= SIZE 10))
|
||||
SIZE
|
||||
(CONCAT "0" SIZE)))
|
||||
(SETQ CSETNAME (if (FIXP CHARSET)
|
||||
then (OCTALSTRING CHARSET)
|
||||
elseif (MEMB CHARSET '(NIL NOCHARSET))
|
||||
then (* ; "Don't want the charset indicated")
|
||||
NIL
|
||||
else (* ; "Somebody made the string already?")
|
||||
CHARSET))
|
||||
|
||||
(* ;; "Fortunately, CONCAT ignores packages.")
|
||||
(* ;; "Fortunately, PACKFILENAME ignores packages")
|
||||
|
||||
(PACKFILENAME.STRING 'NAME (CONCAT (if *USEOLDFONTDIRECTORIES*
|
||||
then ""
|
||||
elseif CSETNAME
|
||||
then (CONCAT (PROGN
|
||||
(* ;
|
||||
"Lowercase because it's in a directory name, so maybe Unix will find it sooner?")
|
||||
"c")
|
||||
CSETNAME ">")
|
||||
else "")
|
||||
FAMILY SIZEPATT "-" (CONCATCODES FACESPEC)
|
||||
(CL:IF CSETNAME
|
||||
(CONCAT "-C" CSETNAME)
|
||||
""))
|
||||
'EXTENSION EXTENSION])
|
||||
(SETQ FILENAME (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF CSETNAME
|
||||
(CONCAT "c" CSETNAME ">")
|
||||
"")
|
||||
FAMILY SIZEPATT "-" (FONTFACETOATOM FACE)
|
||||
(CL:IF CSETNAME
|
||||
(CONCAT "-C" CSETNAME)
|
||||
""))
|
||||
'EXTENSION EXTENSION))
|
||||
|
||||
(\FONTFILENAME.OLD
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 23-Sep-92 18:22 by jds")
|
||||
(* ;;
|
||||
" Avoid adjacent wildcards because some devices (notably old DSK) get exponentially slower.")
|
||||
|
||||
(* ;; "Returns old style font file names. They were ambiguous because you could not ask for e.g. FACE (MEDIUM * REGULAR) because it maps to FamilySize-*-Charset, which also matches (BOLD * COMPRESSED), etc. Keep this function around though for user's who don't rename their files.")
|
||||
(* ;
|
||||
"Returns the name of the file that should contain the information for a font.")
|
||||
(SETQ FACE (\FONTFACE FACE)) (* ; "Force legal canonical face")
|
||||
(SETQ FACE (COND
|
||||
((AND (EQ (CAR FACE)
|
||||
'*)
|
||||
(EQ (CADR FACE)
|
||||
'*))
|
||||
|
||||
(* ;; "Avoid adjacent wildcards because DSK gets slower exponentially (can take loooong tiiiiiime). No need to check compression.")
|
||||
|
||||
'*)
|
||||
(T FACE)))
|
||||
(PACKFILENAME.STRING 'NAME [PROGN
|
||||
(* ;; "DISPLAYFONT AC WD and the default case")
|
||||
|
||||
(CONCAT (CDR (SASSOC FAMILY *DISPLAY-FONT-NAME-MAP*))
|
||||
(COND
|
||||
((EQ SIZE '*)
|
||||
SIZE)
|
||||
((FIXP SIZE)
|
||||
(COND
|
||||
((< SIZE 10)
|
||||
(CONCAT 0 SIZE))
|
||||
(T SIZE)))
|
||||
(T (\ILLEGAL.ARG SIZE)))
|
||||
[COND
|
||||
((EQ FACE '*)
|
||||
'*)
|
||||
(T (SELECTQ (fetch WEIGHT of FACE)
|
||||
(BOLD (SELECTQ (fetch SLOPE of FACE)
|
||||
(ITALIC "D")
|
||||
"B"))
|
||||
(SELECTQ (fetch SLOPE of FACE)
|
||||
(ITALIC "I")
|
||||
"R"]
|
||||
(COND
|
||||
((FIXP CHARSET)
|
||||
(LET ((*PRINT-BASE* 8))
|
||||
(CL:FORMAT NIL "~O" CHARSET)))
|
||||
(T "000"]
|
||||
'EXTENSION EXTENSION])
|
||||
|
||||
(\FONTFILENAME.NEW
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 30-Mar-87 20:00 by FS")
|
||||
|
||||
(* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.")
|
||||
|
||||
(LET (NAME SIZEPATT)
|
||||
(SETQ FACE (\FONTFACE FACE)) (* ; "Validate face")
|
||||
[SETQ SIZEPATT (COND
|
||||
((EQ SIZE '*)
|
||||
SIZE)
|
||||
((FIXP SIZE)
|
||||
(if (< SIZE 10)
|
||||
then (CONCAT 0 SIZE)
|
||||
else SIZE))
|
||||
(T (\ILLEGAL.ARG SIZE]
|
||||
|
||||
(* ;; "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower. Nicely, PACK & CONCAT ignore packages.")
|
||||
|
||||
(PACKFILENAME.STRING 'NAME (CONCAT FAMILY SIZEPATT "-"
|
||||
[COND
|
||||
((EQUAL FACE '
|
||||
|
||||
(* * *)
|
||||
)
|
||||
'*)
|
||||
(T (CONCAT (NTHCHAR (fetch (FONTFACE WEIGHT)
|
||||
of FACE)
|
||||
1)
|
||||
(NTHCHAR (fetch (FONTFACE SLOPE)
|
||||
of FACE)
|
||||
1)
|
||||
(NTHCHAR (fetch (FONTFACE EXPANSION)
|
||||
of FACE)
|
||||
1]
|
||||
(COND
|
||||
[(FIXP CHARSET)
|
||||
(LET ((*PRINT-BASE* 8))
|
||||
(CONCAT "-C" (\PRINDATUM.TO.STRING CHARSET]
|
||||
(CHARSET (CONCAT "-C" CHARSET))
|
||||
(T "-C0")))
|
||||
'EXTENSION EXTENSION])
|
||||
(CL:IF (STRPOS "**" FILENAME)
|
||||
(CONCATCODES (for I C from 1 while (SETQ C (NTHCHARCODE FILENAME I))
|
||||
unless [AND (EQ (CHARCODE *)
|
||||
C)
|
||||
(EQ (CHARCODE *)
|
||||
(NTHCHARCODE FILENAME (ADD1 I] collect C))
|
||||
FILENAME)])
|
||||
|
||||
(FONTSPECFROMFILENAME
|
||||
[LAMBDA (FONTFILE DEVICE) (* ; "Edited 23-Nov-2025 21:42 by rmk")
|
||||
@@ -2120,56 +2000,6 @@
|
||||
FSFACE _ FACE
|
||||
FSROTATION _ 0
|
||||
FSDEVICE _ DEVICE])
|
||||
|
||||
(\FONTINFOFROMFILENAME.OLD
|
||||
[LAMBDA (FONTFILE DEVICE) (* ; "Edited 1-Jan-87 01:29 by FS")
|
||||
|
||||
(* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.")
|
||||
|
||||
(PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
|
||||
SIZEBEG SIZEND NAME FAMILY SIZE)
|
||||
(SETQ NAME (LISTGET FILENAMELIST 'NAME)) (* ;
|
||||
"find where the name and size are.")
|
||||
(SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#))
|
||||
do (RETURN CH#)))
|
||||
[SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG]
|
||||
(SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
|
||||
do (RETURN CH#)))
|
||||
[SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
|
||||
(RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST 'EXTENSION)
|
||||
((DISPLAYFONT AC WD)
|
||||
(LIST (COND
|
||||
((STRPOS "-B" NAME SIZEND NIL T)
|
||||
'BOLD)
|
||||
(T 'MEDIUM))
|
||||
(COND
|
||||
((STRPOS "-I" NAME SIZEND NIL)
|
||||
'ITALIC)
|
||||
(T 'REGULAR))
|
||||
'REGULAR))
|
||||
(LIST (COND
|
||||
((STRPOS "B" NAME SIZEND NIL T)
|
||||
'BOLD)
|
||||
(T 'MEDIUM))
|
||||
(COND
|
||||
((STRPOS "I" NAME SIZEND NIL)
|
||||
'ITALIC)
|
||||
(T 'REGULAR))
|
||||
'REGULAR))
|
||||
0 DEVICE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* (* ; "Do we still want old fonts?") (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE)))
|
||||
|
||||
|
||||
(RPAQ? *OLD-FONT-EXTENSIONS* NIL)
|
||||
|
||||
(RPAQ? *USEOLDFONTDIRECTORIES* NIL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -2839,7 +2669,8 @@
|
||||
then FILEFONTS)))])
|
||||
|
||||
(FONTEXISTS?
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOCOERCIONS) (* ; "Edited 18-Dec-2025 13:10 by rmk")
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOCOERCIONS) (* ; "Edited 22-Jan-2026 09:07 by rmk")
|
||||
(* ; "Edited 18-Dec-2025 13:10 by rmk")
|
||||
(* ; "Edited 25-Nov-2025 20:18 by rmk")
|
||||
(* ; "Edited 26-Sep-2025 10:10 by rmk")
|
||||
(* ; "Edited 28-Aug-2025 22:16 by rmk")
|
||||
@@ -2876,7 +2707,7 @@
|
||||
(FUNCTION NILL))
|
||||
FONTSPEC)))
|
||||
(if VAL
|
||||
then (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL |(QUOTE SASSOC)|)
|
||||
then (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL 'SASSOC)
|
||||
elseif [AND (NOT NOCOERCIONS)
|
||||
(SETQ VAL (COERCEFONTSPEC FONTSPEC (FONTDEVICEPROP DEVICE
|
||||
'FONTCOERCIONS]
|
||||
@@ -3099,37 +2930,38 @@
|
||||
COLOR _ COLOR])
|
||||
|
||||
(FONTFACETOATOM
|
||||
[LAMBDA (FACE NOERROR) (* ; "Edited 7-Sep-2025 09:19 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 08:45 by rmk")
|
||||
(if (type? FONTFACE FACE)
|
||||
then [PACK (LIST* (SELECTQ (fetch (FONTFACE WEIGHT) of FACE)
|
||||
(MEDIUM 'M)
|
||||
(BOLD 'B)
|
||||
(LIGHT 'L)
|
||||
(fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE SLOPE) of FACE)
|
||||
(ITALIC 'I)
|
||||
(REGULAR 'R)
|
||||
(fetch (FONTFACE SLOPE) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
|
||||
(REGULAR 'R)
|
||||
(COMPRESSED 'C)
|
||||
(EXPANDED 'E)
|
||||
(fetch (FONTFACE EXPANSION) of FACE))
|
||||
(CL:WHEN (fetch (FONTFACE COLOR) of FACE)
|
||||
(LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
|
||||
"-"
|
||||
(fetch (FONTFACE FORECOLOR) of FACE)))]
|
||||
elseif (AND FACE (LITATOM FACE)
|
||||
(MEMB (NTHCHARCODE FACE 1)
|
||||
(CHARCODE M B L))
|
||||
(MEMB (NTHCHARCODE FACE 2)
|
||||
(CHARCODE I R))
|
||||
(MEMB (NTHCHARCODE FACE 3)
|
||||
(CHARCODE R C E)))
|
||||
then FACE
|
||||
elseif (NOT NOERROR)
|
||||
then (\ILLEGAL.ARG FACE])
|
||||
[LAMBDA (FACE NOERROR) (* ; "Edited 22-Jan-2026 08:13 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 09:19 by rmk")
|
||||
(LET (ATOM)
|
||||
(SETQ ATOM (if (type? FONTFACE FACE)
|
||||
then [PACK (LIST* (SELECTQ (fetch (FONTFACE WEIGHT) of FACE)
|
||||
(MEDIUM 'M)
|
||||
(BOLD 'B)
|
||||
(LIGHT 'L)
|
||||
(fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE SLOPE) of FACE)
|
||||
(ITALIC 'I)
|
||||
(REGULAR 'R)
|
||||
(fetch (FONTFACE SLOPE) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
|
||||
(REGULAR 'R)
|
||||
(COMPRESSED 'C)
|
||||
(EXPANDED 'E)
|
||||
(fetch (FONTFACE EXPANSION) of FACE))
|
||||
(CL:WHEN (fetch (FONTFACE COLOR) of FACE)
|
||||
(LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
|
||||
"-"
|
||||
(fetch (FONTFACE FORECOLOR) of FACE)))]
|
||||
elseif (AND FACE (LITATOM FACE)
|
||||
(MEMB (NTHCHARCODE FACE 1)
|
||||
(CHARCODE M B L *))
|
||||
(MEMB (NTHCHARCODE FACE 2)
|
||||
(CHARCODE I R *))
|
||||
(MEMB (NTHCHARCODE FACE 3)
|
||||
(CHARCODE R C E *)))
|
||||
then FACE
|
||||
elseif (NOT NOERROR)
|
||||
then (\ILLEGAL.ARG FACE])
|
||||
)
|
||||
|
||||
(RPAQ? \FONTSINCORE NIL)
|
||||
@@ -3253,7 +3085,8 @@
|
||||
OFFSETS _ (\CREATECSINFOELEMENT)
|
||||
CHARSETNO _ MAX.SMALLP)
|
||||
|
||||
(RECORD FONTSPEC (FSFAMILY FSSIZE FSFACE FSROTATION FSDEVICE))
|
||||
(RECORD FONTSPEC (FSFAMILY FSSIZE FSFACE FSROTATION FSDEVICE)
|
||||
(TYPE? LISTP))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
|
||||
@@ -3620,7 +3453,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\CREATEFONT
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 25-Dec-2025 10:58 by rmk")
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 26-Jan-2026 15:24 by rmk")
|
||||
(* ; "Edited 25-Dec-2025 10:58 by rmk")
|
||||
(* ; "Edited 25-Sep-2025 21:24 by rmk")
|
||||
(* ; "Edited 28-Aug-2025 14:30 by rmk")
|
||||
(* ; "Edited 18-Aug-2025 00:17 by rmk")
|
||||
@@ -3636,18 +3470,28 @@
|
||||
(LET ([FN (CAR (GETMULTI IMAGESTREAMTYPES (fetch (FONTSPEC FSDEVICE) of FONTSPEC)
|
||||
'FONTCREATE]
|
||||
FONT)
|
||||
(CL:WHEN FN
|
||||
(SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (* ; "Old form: spreading FONTSPEC")
|
||||
(APPLY FN FONTSPEC)))
|
||||
(CL:UNLESS FONT
|
||||
(CL:WHEN (SETQ FONTSPEC (COERCEFONTSPEC FONTSPEC))
|
||||
(SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (APPLY FN FONTSPEC))))))
|
||||
[if FN
|
||||
then (SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (* ; "Old form: spreading FONTSPEC")
|
||||
(APPLY FN FONTSPEC)))
|
||||
(CL:UNLESS FONT
|
||||
(CL:WHEN (SETQ FONTSPEC (COERCEFONTSPEC FONTSPEC))
|
||||
(SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (APPLY FN FONTSPEC)))))
|
||||
else (SETQ FONT (create FONTDESCRIPTOR
|
||||
FONTFAMILY _ (fetch (FONTSPEC FSFAMILY) of FONTSPEC)
|
||||
FONTSIZE _ (fetch (FONTSPEC FSSIZE) of FONTSPEC)
|
||||
FONTFACE _ (fetch (FONTSPEC FSFACE) of FONTSPEC)
|
||||
ROTATION _ (fetch (FONTSPEC FSROTATION) of FONTSPEC)
|
||||
FONTDEVICE _ (fetch (FONTSPEC FSDEVICE) of FONTSPEC)
|
||||
\SFAscent _ 0
|
||||
\SFDescent _ 0
|
||||
\SFHeight _ 0
|
||||
FONTDEVICESPEC _ (create FONTSPEC using FONTSPEC]
|
||||
FONT])
|
||||
|
||||
(\CREATECHARSET
|
||||
@@ -4640,44 +4484,43 @@
|
||||
(ADDTOVAR LAMA FONTCOPY)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (12139 21852 (CHARWIDTH 12149 . 12934) (CHARWIDTHY 12936 . 14453) (STRINGWIDTH 14455 .
|
||||
15548) (\CHARWIDTH.DISPLAY 15550 . 15963) (\STRINGWIDTH.DISPLAY 15965 . 16389) (\STRINGWIDTH.GENERIC
|
||||
16391 . 21850)) (21853 28373 (DEFAULTFONT 21863 . 23148) (FONTCLASS 23150 . 25312) (FONTCLASSUNPARSE
|
||||
25314 . 26213) (FONTCLASSCOMPONENT 26215 . 26803) (SETFONTCLASSCOMPONENT 26805 . 27247) (
|
||||
GETFONTCLASSCOMPONENT 27249 . 28371)) (30086 47590 (FONTCREATE 30096 . 33341) (FONTCREATE1 33343 .
|
||||
35958) (FONTCREATE.SLUGFD 35960 . 37442) (\FONT.CHECKARGS1 37444 . 41967) (\FONTCREATE1.NOFN 41969 .
|
||||
42183) (FONTFILEP 42185 . 43073) (\READCHARSET 43075 . 47588)) (47591 54667 (\FONT.CHECKARGS 47601 .
|
||||
54350) (\CHARSET.CHECK 54352 . 54665)) (54668 61279 (COERCEFONTSPEC 54678 . 60590) (
|
||||
COERCEFONTSPEC.TARGETFACE 60592 . 61277)) (63474 64813 (MAKEFONTSPEC 63484 . 64811)) (64814 72991 (
|
||||
COMPLETE.FONT 64824 . 67347) (COMPLETEFONTP 67349 . 67972) (COMPLETE.CHARSET 67974 . 70659) (
|
||||
PRUNESLUGCSINFOS 70661 . 71586) (MONOSPACEFONTP 71588 . 72989)) (73030 81285 (FONTASCENT 73040 . 73424
|
||||
) (FONTDESCENT 73426 . 73911) (FONTHEIGHT 73913 . 74315) (FONTPROP 74317 . 80562) (\AVGCHARWIDTH 80564
|
||||
. 81283)) (81942 82850 (FONTDEVICEPROP 81952 . 82848)) (82896 83750 (EDITCHAR 82906 . 83748)) (83796
|
||||
95986 (GETCHARBITMAP 83806 . 84930) (PUTCHARBITMAP 84932 . 87090) (\GETCHARBITMAP.CSINFO 87092 . 89108
|
||||
) (\PUTCHARBITMAP.CSINFO 89110 . 95984)) (95987 116467 (MOVECHARBITMAP 95997 . 97891) (MOVEFONTCHARS
|
||||
97893 . 101853) (\MOVEFONTCHAR 101855 . 106698) (\MOVEFONTCHARS.SOURCEDATA 106700 . 112805) (
|
||||
\MAKESLUGCHAR 112807 . 115342) (SLUGCHARP.DISPLAY 115344 . 116465)) (117400 138565 (FONTFILES 117410
|
||||
. 119243) (\FINDFONTFILE 119245 . 121554) (\FONTFILENAMES 121556 . 122551) (\FONTFILENAME 122553 .
|
||||
126536) (\FONTFILENAME.OLD 126538 . 129487) (\FONTFILENAME.NEW 129489 . 131746) (FONTSPECFROMFILENAME
|
||||
131748 . 136284) (\FONTINFOFROMFILENAME.OLD 136286 . 138563)) (138832 175407 (FONTCOPY 138842 . 143905
|
||||
) (FONTP 143907 . 144206) (FONTUNPARSE 144208 . 145927) (SETFONTDESCRIPTOR 145929 . 147393) (
|
||||
\STREAMCHARWIDTH 147395 . 151559) (\COERCECHARSET 151561 . 154928) (\BUILDSLUGCSINFO 154930 . 158553)
|
||||
(\FONTSYMBOL 158555 . 159205) (\DEVICESYMBOL 159207 . 160076) (\FONTFACE 160078 . 167268) (
|
||||
\FONTFACE.COLOR 167270 . 174190) (SETFONTCHARENCODING 174192 . 175405)) (175408 194969 (FONTSAVAILABLE
|
||||
175418 . 180772) (FONTEXISTS? 180774 . 184213) (\SEARCHFONTFILES 184215 . 187300) (FLUSHFONTCACHE
|
||||
187302 . 189525) (FINDFONTFILES 189527 . 192741) (SORTFONTSPECS 192743 . 194967)) (194970 198579 (
|
||||
MATCHFONTFACE 194980 . 195795) (MAKEFONTFACE 195797 . 196823) (FONTFACETOATOM 196825 . 198577)) (
|
||||
199210 199702 (\UNITWIDTHSVECTOR 199220 . 199700)) (214296 216363 (FONTDESCRIPTOR.DEFPRINT 214306 .
|
||||
215885) (FONTCLASS.DEFPRINT 215887 . 216361)) (220192 222982 (\CREATEKERNELEMENT 220202 . 220560) (
|
||||
\FSETLEFTKERN 220562 . 221053) (\FGETLEFTKERN 221055 . 222980)) (222983 233135 (\CREATEFONT 222993 .
|
||||
224948) (\CREATECHARSET 224950 . 228886) (\INSTALLCHARSETINFO 228888 . 232222) (
|
||||
\INSTALLCHARSETINFO.CHARENCODING 232224 . 233133)) (233457 234821 (\FONTRESETCHARWIDTHS 233467 .
|
||||
234819)) (235451 245492 (\CREATEDISPLAYFONT 235461 . 237310) (\CREATECHARSET.DISPLAY 237312 . 243021)
|
||||
(\FONTEXISTS?.DISPLAY 243023 . 245490)) (245493 260358 (STRIKEFONT.FILEP 245503 . 246391) (
|
||||
STRIKEFONT.GETCHARSET 246393 . 251985) (WRITESTRIKEFONTFILE 251987 . 256898) (STRIKECSINFO 256900 .
|
||||
260356)) (260389 276706 (MAKEBOLD.CHARSET 260399 . 264048) (MAKEBOLD.CHAR 264050 . 265802) (
|
||||
MAKEITALIC.CHARSET 265804 . 269477) (MAKEITALIC.CHAR 269479 . 271825) (\SFMAKEBOLD 271827 . 274051) (
|
||||
\SFMAKEITALIC 274053 . 276704)) (276707 280856 (\SFMAKEROTATEDFONT 276717 . 278118) (\SFROTATECSINFO
|
||||
278120 . 278757) (\SFROTATEFONTCHARACTERS 278759 . 279139) (\SFROTATECSINFOOFFSETS 279141 . 280854)) (
|
||||
280857 282238 (\SFMAKECOLOR 280867 . 282236)))))
|
||||
(FILEMAP (NIL (11455 21168 (CHARWIDTH 11465 . 12250) (CHARWIDTHY 12252 . 13769) (STRINGWIDTH 13771 .
|
||||
14864) (\CHARWIDTH.DISPLAY 14866 . 15279) (\STRINGWIDTH.DISPLAY 15281 . 15705) (\STRINGWIDTH.GENERIC
|
||||
15707 . 21166)) (21169 27689 (DEFAULTFONT 21179 . 22464) (FONTCLASS 22466 . 24628) (FONTCLASSUNPARSE
|
||||
24630 . 25529) (FONTCLASSCOMPONENT 25531 . 26119) (SETFONTCLASSCOMPONENT 26121 . 26563) (
|
||||
GETFONTCLASSCOMPONENT 26565 . 27687)) (29402 46906 (FONTCREATE 29412 . 32657) (FONTCREATE1 32659 .
|
||||
35274) (FONTCREATE.SLUGFD 35276 . 36758) (\FONT.CHECKARGS1 36760 . 41283) (\FONTCREATE1.NOFN 41285 .
|
||||
41499) (FONTFILEP 41501 . 42389) (\READCHARSET 42391 . 46904)) (46907 53983 (\FONT.CHECKARGS 46917 .
|
||||
53666) (\CHARSET.CHECK 53668 . 53981)) (53984 60595 (COERCEFONTSPEC 53994 . 59906) (
|
||||
COERCEFONTSPEC.TARGETFACE 59908 . 60593)) (62790 64129 (MAKEFONTSPEC 62800 . 64127)) (64130 72307 (
|
||||
COMPLETE.FONT 64140 . 66663) (COMPLETEFONTP 66665 . 67288) (COMPLETE.CHARSET 67290 . 69975) (
|
||||
PRUNESLUGCSINFOS 69977 . 70902) (MONOSPACEFONTP 70904 . 72305)) (72346 80792 (FONTASCENT 72356 . 72740
|
||||
) (FONTDESCENT 72742 . 73227) (FONTHEIGHT 73229 . 73631) (FONTPROP 73633 . 80069) (\AVGCHARWIDTH 80071
|
||||
. 80790)) (81449 82357 (FONTDEVICEPROP 81459 . 82355)) (82403 83257 (EDITCHAR 82413 . 83255)) (83303
|
||||
95493 (GETCHARBITMAP 83313 . 84437) (PUTCHARBITMAP 84439 . 86597) (\GETCHARBITMAP.CSINFO 86599 . 88615
|
||||
) (\PUTCHARBITMAP.CSINFO 88617 . 95491)) (95494 115974 (MOVECHARBITMAP 95504 . 97398) (MOVEFONTCHARS
|
||||
97400 . 101360) (\MOVEFONTCHAR 101362 . 106205) (\MOVEFONTCHARS.SOURCEDATA 106207 . 112312) (
|
||||
\MAKESLUGCHAR 112314 . 114849) (SLUGCHARP.DISPLAY 114851 . 115972)) (116632 128360 (FONTFILES 116642
|
||||
. 118475) (\FINDFONTFILE 118477 . 120345) (\FONTFILENAMES 120347 . 120907) (\FONTFILENAME 120909 .
|
||||
123820) (FONTSPECFROMFILENAME 123822 . 128358)) (128361 164936 (FONTCOPY 128371 . 133434) (FONTP
|
||||
133436 . 133735) (FONTUNPARSE 133737 . 135456) (SETFONTDESCRIPTOR 135458 . 136922) (\STREAMCHARWIDTH
|
||||
136924 . 141088) (\COERCECHARSET 141090 . 144457) (\BUILDSLUGCSINFO 144459 . 148082) (\FONTSYMBOL
|
||||
148084 . 148734) (\DEVICESYMBOL 148736 . 149605) (\FONTFACE 149607 . 156797) (\FONTFACE.COLOR 156799
|
||||
. 163719) (SETFONTCHARENCODING 163721 . 164934)) (164937 184598 (FONTSAVAILABLE 164947 . 170301) (
|
||||
FONTEXISTS? 170303 . 173842) (\SEARCHFONTFILES 173844 . 176929) (FLUSHFONTCACHE 176931 . 179154) (
|
||||
FINDFONTFILES 179156 . 182370) (SORTFONTSPECS 182372 . 184596)) (184599 188706 (MATCHFONTFACE 184609
|
||||
. 185424) (MAKEFONTFACE 185426 . 186452) (FONTFACETOATOM 186454 . 188704)) (189337 189829 (
|
||||
\UNITWIDTHSVECTOR 189347 . 189827)) (204458 206525 (FONTDESCRIPTOR.DEFPRINT 204468 . 206047) (
|
||||
FONTCLASS.DEFPRINT 206049 . 206523)) (210354 213144 (\CREATEKERNELEMENT 210364 . 210722) (
|
||||
\FSETLEFTKERN 210724 . 211215) (\FGETLEFTKERN 211217 . 213142)) (213145 224220 (\CREATEFONT 213155 .
|
||||
216033) (\CREATECHARSET 216035 . 219971) (\INSTALLCHARSETINFO 219973 . 223307) (
|
||||
\INSTALLCHARSETINFO.CHARENCODING 223309 . 224218)) (224542 225906 (\FONTRESETCHARWIDTHS 224552 .
|
||||
225904)) (226536 236577 (\CREATEDISPLAYFONT 226546 . 228395) (\CREATECHARSET.DISPLAY 228397 . 234106)
|
||||
(\FONTEXISTS?.DISPLAY 234108 . 236575)) (236578 251443 (STRIKEFONT.FILEP 236588 . 237476) (
|
||||
STRIKEFONT.GETCHARSET 237478 . 243070) (WRITESTRIKEFONTFILE 243072 . 247983) (STRIKECSINFO 247985 .
|
||||
251441)) (251474 267791 (MAKEBOLD.CHARSET 251484 . 255133) (MAKEBOLD.CHAR 255135 . 256887) (
|
||||
MAKEITALIC.CHARSET 256889 . 260562) (MAKEITALIC.CHAR 260564 . 262910) (\SFMAKEBOLD 262912 . 265136) (
|
||||
\SFMAKEITALIC 265138 . 267789)) (267792 271941 (\SFMAKEROTATEDFONT 267802 . 269203) (\SFROTATECSINFO
|
||||
269205 . 269842) (\SFROTATEFONTCHARACTERS 269844 . 270224) (\SFROTATECSINFOOFFSETS 270226 . 271939)) (
|
||||
271942 273323 (\SFMAKECOLOR 271952 . 273321)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 9-Oct-2025 15:20:59" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;242 59604
|
||||
(FILECREATED "23-Jan-2026 15:10:16" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;249 60332
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS MEDLEYFONT.GETCHARSET)
|
||||
:CHANGES-TO (FNS MEDLEYFONT.FILENAME MEDLEYFONT.WRITE.FONT MEDLEYFONT.READ.FONT
|
||||
MEDLEYFONT.READ.VERIFIEDFONT)
|
||||
|
||||
:PREVIOUS-DATE " 7-Oct-2025 12:43:33" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;241)
|
||||
:PREVIOUS-DATE " 9-Oct-2025 15:20:59" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;242)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
|
||||
@@ -59,7 +60,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.WRITE.FONT
|
||||
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 2-Sep-2025 23:01 by rmk")
|
||||
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "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")
|
||||
@@ -70,8 +72,7 @@
|
||||
(* ; "Edited 16-May-2025 20:17 by rmk")
|
||||
(* ; "Edited 14-May-2025 17:45 by rmk")
|
||||
(SETQ FONT (FONTCREATE FONT))
|
||||
(CL:UNLESS FILE
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FONT CHARSETNOS)))
|
||||
(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)
|
||||
@@ -279,14 +280,15 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.READ.FONT
|
||||
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 31-Aug-2025 14:42 by rmk")
|
||||
[LAMBDA (FILE CHARSETNOS FONT) (* ; "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")
|
||||
(CL:UNLESS FILE (SETQ FILE FONT))
|
||||
(CL:WHEN (OR (type? FONTDESCRIPTOR FILE)
|
||||
(LISTP FILE))
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FILE)))
|
||||
(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)
|
||||
@@ -510,14 +512,13 @@
|
||||
(bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR])
|
||||
|
||||
(MEDLEYFONT.READ.VERIFIEDFONT
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 2-Sep-2025 23:52 by rmk")
|
||||
[LAMBDA (STREAM FONT) (* ; "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")
|
||||
(CL:UNLESS FONT
|
||||
(SETQ FONT (create FONTDESCRIPTOR)))
|
||||
(LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)))
|
||||
(for P VAL in FONTPROPS do (SETQ VAL (CADR P))
|
||||
(SELECTQ (CAR P)
|
||||
@@ -842,35 +843,33 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.FILENAME
|
||||
[LAMBDA (FONT CHARSET EXTENSION DIRECTORY) (* ; "Edited 7-Oct-2025 11:50 by rmk")
|
||||
[LAMBDA (FILE FONT CHARSET EXTENSION DIRECTORY) (* ; "Edited 23-Jan-2026 15:10 by rmk")
|
||||
(* ; "Edited 20-Jan-2026 17:39 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")
|
||||
|
||||
(* ;; "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.")
|
||||
|
||||
(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 DIRECTORY
|
||||
[SETQ DIRECTORY (PSEUDOFILENAME (CONCAT (MEDLEYDIR)
|
||||
(CONCAT "fonts/" (L-CASE EXTENSION)
|
||||
"s"])
|
||||
(SETQ FILENAME (PACK* FAMILY (CL:IF (ILEQ SIZE 9)
|
||||
"0"
|
||||
"")
|
||||
SIZE "-" (FONTFACETOATOM FACE)
|
||||
(CL:IF (SMALLP CHARSET)
|
||||
(CONCAT "-C" (OCTALSTRING CHARSET))
|
||||
"")
|
||||
"." EXTENSION))
|
||||
(CONCAT DIRECTORY ">" FILENAME])
|
||||
(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])
|
||||
)
|
||||
|
||||
(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
|
||||
@@ -921,11 +920,11 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(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)))))
|
||||
(FILEMAP (NIL (2222 16857 (MEDLEYFONT.WRITE.FONT 2232 . 7287) (MEDLEYFONT.GETCHARSET 7289 . 11316) (
|
||||
MEDLEYFONT.CHARSET? 11318 . 12787) (MEDLEYFONT.GETFILEPROP 12789 . 14889) (MEDLEYFONT.FILEP 14891 .
|
||||
16855)) (16883 39217 (MEDLEYFONT.READ.FONT 16893 . 21429) (MEDLEYFONT.READ.CHARSET 21431 . 26789) (
|
||||
MEDLEYFONT.READ.ITEM 26791 . 32940) (MEDLEYFONT.PEEK.ITEM 32942 . 33804) (MEDLEYFONT.READ.FONTPROPS
|
||||
33806 . 34271) (MEDLEYFONT.READ.VERIFIEDFONT 34273 . 39215)) (39243 57080 (MEDLEYFONT.WRITE.CHARSET
|
||||
39253 . 43815) (MEDLEYFONT.WRITE.ITEM 43817 . 52870) (MEDLEYFONT.WRITE.FONTPROPS 52872 . 56425) (
|
||||
MEDLEYFONT.WRITE.HEADER 56427 . 57078)) (57081 59447 (MEDLEYFONT.FILENAME 57091 . 59445)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user