diff --git a/docs/internal/FONTCODECHANGES.tedit b/docs/internal/FONTCODECHANGES.tedit new file mode 100644 index 000000000..732c117e0 Binary files /dev/null and b/docs/internal/FONTCODECHANGES.tedit differ diff --git a/docs/internal/MEDLEYFONTFORMAT.TEDIT b/docs/internal/MEDLEYFONTFORMAT.TEDIT new file mode 100644 index 000000000..36fe18ff0 Binary files /dev/null and b/docs/internal/MEDLEYFONTFORMAT.TEDIT differ diff --git a/fonts/medleydisplayfonts/GACHA10-MRR.MEDLEYDISPLAYFONT b/fonts/medleydisplayfonts/GACHA10-MRR.MEDLEYDISPLAYFONT new file mode 100644 index 000000000..09a0ad9ab Binary files /dev/null and b/fonts/medleydisplayfonts/GACHA10-MRR.MEDLEYDISPLAYFONT differ diff --git a/fonts/medleydisplayfonts/HELVETICA10-MRR.MEDLEYDISPLAYFONT b/fonts/medleydisplayfonts/HELVETICA10-MRR.MEDLEYDISPLAYFONT new file mode 100644 index 000000000..a418135dd Binary files /dev/null and b/fonts/medleydisplayfonts/HELVETICA10-MRR.MEDLEYDISPLAYFONT differ diff --git a/internal/FONT-DEBUG b/internal/FONT-DEBUG new file mode 100644 index 000000000..52587e8ab --- /dev/null +++ b/internal/FONT-DEBUG @@ -0,0 +1,352 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "19-Jul-2025 16:43:34" {WMEDLEY}FONT-DEBUG.;46 19345 + + :EDIT-BY rmk + + :CHANGES-TO (FNS CSBMSIZE FONTSIZE CSSIZE EQCHARBM) + (VARS FONT-DEBUGCOMS) + + :PREVIOUS-DATE "19-Jul-2025 12:36:48" {WMEDLEY}FONT-DEBUG.;41) + + +(PRETTYCOMPRINT FONT-DEBUGCOMS) + +(RPAQQ FONT-DEBUGCOMS ( + (* ;; "Little tools to help in debugging display fonts") + + (FNS DEBUGCHARSET IBM ICS SHOWCACHE SHOWCSBITMAP EQCSBM EQCHARBM CHARSETCHARS + CHARBMDIFFS SHOWCSCHAR CSCOMPARE SHOWBMS SHOWCHARBITMAPS CANDS) + (FNS FONTSIZE CSSIZE CSBMSIZE))) + + + +(* ;; "Little tools to help in debugging display fonts") + +(DEFINEQ + +(DEBUGCHARSET + [LAMBDA (FONTSPEC CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 9-Jul-2025 16:26 by rmk") + (* ; "Edited 6-Jul-2025 22:33 by rmk") + (* ; "Edited 2-Jul-2025 16:50 by rmk") + (* ; "Edited 30-Jun-2025 09:27 by rmk") + (* ; "Edited 25-Jun-2025 19:25 by rmk") + (* ; "Edited 20-Jun-2025 16:37 by rmk") + + (* ;; "Reads the CHARSETINFO for FONTSPEC and CHARSET, where FONTSPEC can be a (family size...) specification or the name of a fontfile (ac, strike, medleyfont format). Avoids the MEDLEYFONT files if NOTMEDLEYFONT.") + + (if (type? CHARSETINFO FONTSPEC) + then FONTSPEC + elseif (type? FONTDESCRIPTOR FONTSPEC) + then (\XGETCHARSETINFO FONTSPEC (OR CHARSET 0)) + else (RESETLST + (CL:UNLESS INCLUDEMEDLEYFONT + (RESETSAVE DISPLAYFONTEXTENSIONS (REMOVE 'MEDLEYDISPLAYFONT DISPLAYFONTEXTENSIONS) + )) + [if (OR (LITATOM FONTSPEC) + (STRINGP FONTSPEC)) + then (CL:UNLESS CHARSET (SETQ CHARSET 0)) + (LET (STRM) + [RESETSAVE (SETQ STRM (OPENSTREAM FONTSPEC 'INPUT)) + `(PROGN (CLOSEF? OLDVALUE] + (for FNS CSINFO (FI _ (\FONTINFOFROMFILENAME FONTSPEC 'DISPLAY)) + in DISPLAYCHARSETFNS + do (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS) + STRM))) + (SETQ CSINFO (APPLY* (CADDR FNS) + STRM + (CAR FI) + (CADR FI) + (CADDR FI) + (CADDDR FI) + (CAR (CDDDDR FI)) + CHARSET)) + (PUTMULTI (fetch (CHARSETINFO CSINFOPROPS) of CSINFO) + 'FILE + (PSEUDOFILENAME FONTSPEC)) + (RETURN CSINFO)) + (CLOSEF? STRM))) + else (LET ((CS CHARSET)) + (CL:MULTIPLE-VALUE-BIND (FAMILY SIZE FACE ROTATION DEVICE CHARSET) + (\FONT.CHECKARGS FONTSPEC) + (CL:WHEN CS (SETQ CHARSET CS)) + (\READCHARSET FAMILY SIZE FACE ROTATION 'DISPLAY CHARSET])]) + +(IBM + [LAMBDA (FONT CHARSET) (* ; "Edited 29-Jun-2025 17:05 by rmk") + (* ; "Edited 20-Jun-2025 16:35 by rmk") + (* ; "Edited 18-Jun-2025 14:09 by rmk") + + (* ;; "Inspects the character set bitmap for CHARSET in FONT, which may also be a charset info. If necessary, builds the font (unlike ICS).") + + (SHOWCSBITMAP (if (type? CHARSETINFO FONT) + then FONT + else (\XGETCHARSETINFO (SETQ FONT (FONTCREATE FONT)) + (OR CHARSET 0]) + +(ICS + [LAMBDA (FONT CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 7-Jul-2025 23:12 by rmk") + (* ; "Edited 6-Jul-2025 22:04 by rmk") + (* ; "Edited 2-Jul-2025 16:11 by rmk") + (* ; "Edited 29-Jun-2025 17:07 by rmk") + (* ; "Edited 21-Jun-2025 22:00 by rmk") + (* ; "Edited 20-Jun-2025 17:10 by rmk") + (* ; "Edited 18-Jun-2025 14:23 by rmk") + + (* ;; "Inspects the charset bitmap for CHARSET in FONT. If FONT is a filename, gets the csinfo directly from the file, doesn't build the font.") + + (LET ((CSINFO (DEBUGCHARSET FONT CHARSET INCLUDEMEDLEYFONT))) + (if CSINFO + then (INSPECT CSINFO) + (SHOWCSBITMAP CSINFO) + (LIST (GETMULTI (fetch (CHARSETINFO CSINFOPROPS) of CSINFO) + 'FILE) + CSINFO) + else "NO CSINFO"]) + +(SHOWCACHE + [LAMBDA NIL (* ; "Edited 29-Jun-2025 17:19 by rmk") + (* ; "Edited 18-Jun-2025 22:50 by rmk") + + (* ;; "Keyboard shortcut to show the current caches") + + (DV \FONTSINCORE) + (DV \FONTEXISTS?-CACHE]) + +(SHOWCSBITMAP + [LAMBDA (CSINFO) (* ; "Edited 29-Jun-2025 17:07 by rmk") + (* ; "Edited 20-Jun-2025 16:38 by rmk") + + (* ;; "Given a charsetinfo, shows the whole bitmap using EDITBM. Unfortunately, that runs in a separate process, so we can't directly get the window to put something useful in the title. If EDITBM is called directly, it doen't return until you quit...in which case it's gone. We'd really like just the displayer.") + + (* ;; "If we call the inspector, it asks for contents vs. fields, also a pain, and we still don't get the window.") + + (LET (BM) + (if (NOT CSINFO) + then (PRINTOUT T "NO CSINFO" T) + elseif (AND (IGREATERP (BITMAPWIDTH (SETQ BM (fetch CHARSETBITMAP of CSINFO))) + 0) + (IGREATERP (BITMAPHEIGHT BM) + 0)) + then (EVAL.AS.PROCESS (LIST 'EDITBM BM)) + else "EMPTY BITMAP") + CSINFO]) + +(EQCSBM + [LAMBDA (CS1 CS2 CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 6-Jul-2025 22:04 by rmk") + (* ; "Edited 2-Jul-2025 16:12 by rmk") + (* ; "Edited 29-Jun-2025 17:52 by rmk") + (* ; "Edited 21-Jun-2025 21:20 by rmk") + + (* ;; "True if the two charsetinfos are equivalent in all respects. If either of CS1 or CS2 is a fontdescriptor (not a charsetinfo), then coerces to CHARSET in that font.") + + (SETQ CS1 (DEBUGCHARSET CS1 CHARSET INCLUDEMEDLEYFONT)) + (SETQ CS2 (DEBUGCHARSET CS2 CHARSETINCLUDEMEDLEYFONT)) + (EQUALALL (fetch (CHARSETINFO CHARSETBITMAP) of CS1) + (fetch (CHARSETINFO CHARSETBITMAP) of CS2]) + +(EQCHARBM + [LAMBDA (CHAR1 CHAR2 CS1 CS2 EXCLUDEMEDLEYFONT) (* ; "Edited 19-Jul-2025 12:46 by rmk") + + (* ;; + "True if the character bitmap for CHAR1 in CS1 is equivalent to the bitmap for CHAR2 in CS2. ") + + (CL:UNLESS (CHARCODEP CHAR1) + (SETQ CHAR1 (CHARCODE.DECODE CHAR1))) + (CL:UNLESS (CHARCODEP CHAR2) + (SETQ CHAR2 (CHARCODE.DECODE CHAR2))) + (SETQ CS1 (DEBUGCHARSET CS1 (\CHARSET CHAR1) + (NOT EXCLUDEMEDLEYFONT))) + (SETQ CS2 (DEBUGCHARSET CS2 (\CHARSET CHAR2) + (NOT EXCLUDEMEDLEYFONT))) + (EQUALALL (\GETCHARBITMAP.CSINFO (\CHAR8CODE CHAR1) + CS1) + (\GETCHARBITMAP.CSINFO (\CHAR8CODE CHAR2) + CS2]) + +(CHARSETCHARS + [LAMBDA (CSINFO CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 6-Jul-2025 22:04 by rmk") + (* ; "Edited 2-Jul-2025 16:12 by rmk") + (* ; "Edited 29-Jun-2025 17:52 by rmk") + + (* ;; "Returns a list of character codes that are instantiated in CSINFO (which may be specified as a font/charset combination).") + + (SETQ CSINFO (DEBUGCHARSET CSINFO CHARSET INCLUDEMEDLEYFONT)) + (for CODE from 0 to \MAXTHINCHAR unless (SLUGCHARP.DISPLAY CODE CSINFO) collect CODE]) + +(CHARBMDIFFS + [LAMBDA (CS1 CS2 CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 6-Jul-2025 22:04 by rmk") + (* ; "Edited 2-Jul-2025 16:12 by rmk") + (* ; "Edited 29-Jun-2025 17:51 by rmk") + + (* ;; + "Returns the codes whose bitmaps in CS1 and CS2 differ in some way. Use EDITCHAR to view them.") + + (SETQ CS1 (DEBUGCHARSET CS1 CHARSET INCLUDEMEDLEYFONT)) + (SETQ CS2 (DEBUGCHARSET CS2 CHARSET INCLUDEMEDLEYFONT)) + (for CODE in (INTERSECTION (CHARSETCHARS CS1) + (CHARSETCHARS CS2)) unless (EQUALALL (\GETCHARBITMAP.CSINFO CODE CS1) + (\GETCHARBITMAP.CSINFO CODE CS2)) + collect CODE]) + +(SHOWCSCHAR + [LAMBDA (CODE CSINFO CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 6-Jul-2025 22:04 by rmk") + (* ; "Edited 2-Jul-2025 16:12 by rmk") + (* ; "Edited 29-Jun-2025 18:01 by rmk") + (EDITBM (\GETCHARBITMAP.CSINFO CODE (DEBUGCHARSET CSINFO CHARSET INCLUDEMEDLEYFONT]) + +(CSCOMPARE + [LAMBDA (CS1 CS2 CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 6-Jul-2025 22:04 by rmk") + (* ; "Edited 2-Jul-2025 16:13 by rmk") + (* ; "Edited 30-Jun-2025 14:02 by rmk") + (CL:UNLESS CS2 + (CL:WHEN (OR (LITATOM CS1) + (STRINGP CS1)) + (SETQ CS2 (\FONTINFOFROMFILENAME CS1 'DISPLAY)) + [if CHARSET + then (CL:UNLESS (EQ CHARSET (CAR (LAST CS2))) + (ERROR "MISMATCHING CHARSETS")) + else (SETQ CHARSET (CAR (LAST CS2])) + (SETQ CS1 (OR (DEBUGCHARSET CS1 CHARSET INCLUDEMEDLEYFONT) + (ERROR CS1 "not found"))) + (SETQ CS2 (OR (DEBUGCHARSET CS2 CHARSET INCLUDEMEDLEYFONT) + (ERROR CS2 "not found"))) + (LET ((CS1CHARS (CHARSETCHARS CS1)) + (CS2CHARS (CHARSETCHARS CS2)) + (ASCENT1 (fetch (CHARSETINFO CHARSETASCENT) of CS1)) + (ASCENT2 (fetch (CHARSETINFO CHARSETASCENT) of CS2)) + (DESCENT1 (fetch (CHARSETINFO CHARSETDESCENT) of CS1)) + (DESCENT2 (fetch (CHARSETINFO CHARSETDESCENT) of CS2)) + DIFF) + (if (EQ ASCENT1 ASCENT2) + then (PRINTOUT T "Same ascent = " .I2 ASCENT1 T) + else (PRINTOUT T " Ascent1 = " .I2 ASCENT1 " Ascent2 = " .I2 ASCENT2 T)) + (if (EQ DESCENT1 DESCENT2) + then (PRINTOUT T "Same descent = " .I2 DESCENT1 T) + else (PRINTOUT T "Descent1 = " .I2 DESCENT1 " Descent2 = " .I2 DESCENT2 T)) + (PRINTOUT T "Common chars:" 14 .PPV (SORT (INTERSECTION CS1CHARS CS2CHARS)) + T) + (SETQ DIFF (SORT (CHARBMDIFFS CS1 CS2))) + (if (NULL DIFF) + then (PRINTOUT T 5 "All common chars have the SAME bitmaps" T) + elseif (EQUAL DIFF (SORT (INTERSECTION CS1CHARS CS2CHARS))) + then (PRINTOUT T 5 "All common chars have DIFFERENT bitmaps" T) + else (PRINTOUT T 5 "Common chars with different bitmaps: " .PPV DIFF T)) + (CL:WHEN (SETQ DIFF (LDIFFERENCE CS1CHARS CS2CHARS)) + (PRINTOUT T "1 but not 2:" 14 .PPV (SORT (LDIFFERENCE CS1CHARS CS2CHARS)) + T)) + (CL:WHEN (SETQ DIFF (LDIFFERENCE CS2CHARS CS1CHARS)) + (PRINTOUT T "2 but not 1:" 14 .PPV (SORT (LDIFFERENCE CS2CHARS CS1CHARS)) + T)) + (LIST CS1 CS2]) + +(SHOWBMS + [LAMBDA (CHARSETINFOS) (* ; "Edited 30-Jun-2025 08:47 by rmk") + (for CS in CHARSETINFOS do (ICS CS]) + +(SHOWCHARBITMAPS + [LAMBDA (CODE CSINFOS CHARSET INCLUDEMEDLEYFONT CLOSEPREVIOUS) + (* ; "Edited 6-Jul-2025 22:04 by rmk") + (* ; "Edited 2-Jul-2025 11:48 by rmk") + (* ; "Edited 20-Jun-2025 16:38 by rmk") + + (* ;; "Shows the bitmap for CODE in each of the CSINFOS") + + (* ;; "If we call the inspector directly, it asks for contents vs. fields, also a pain, and we still don't get our hands on the window.") + + [SETQ CSINFOS (for CS inside CSINFOS collect (OR (DEBUGCHARSET CS CHARSET INCLUDEMEDLEYFONT) + (ERROR CS "not found"] + (CL:WHEN CLOSEPREVIOUS + (for W in (OPENWINDOWS) when (EQ 'EDITBMREPAINTFN (WINDOWPROP W 'REPAINTFN)) + do (CLOSEW W))) + (if (CHARCODEP CODE) + then (for CS BM in CSINFOS do (SETQ BM (\GETCHARBITMAP.CSINFO CODE CS)) + (if (AND (IGREATERP (BITMAPWIDTH BM) + 0) + (IGREATERP (BITMAPHEIGHT BM) + 0)) + then (EVAL.AS.PROCESS (LIST 'EDITBM BM)) + else "EMPTY BITMAP")) + else (for CS in CSINFOS do (SHOWCSBITMAP CS]) + +(CANDS + [LAMBDA (CS1 CS2 CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 2-Jul-2025 11:47 by rmk") + + (* ;; "Wraps comparing and showing, closes previous bitmap windows") + + (LET ((CINFOS (CSCOMPARE CS1 CS2 CHARSET INCLUDEMEDLEYFONT))) + (SHOWCHARBITMAPS NIL CINFOS CHARSET INCLUDEMEDLEYFONT T) + CINFOS]) +) +(DEFINEQ + +(FONTSIZE + [LAMBDA (FONT CHARSETS FILETOO NOERROR) (* ; "Edited 19-Jul-2025 16:42 by rmk") + (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY NOERROR)) + (CL:UNLESS CHARSETS + (SETQ CHARSETS (for CS CSINFO BM from 0 to 255 when (SETQ CSINFO (\XGETCHARSETINFO FONT CS)) + unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CS))) + (PRINTOUT T "Charsets: ") + (for CS CSINFO inside CHARSETS sum (PRINTOUT T CS " ") + (CSSIZE (\XGETCHARSETINFO FONT CS) + T) finally (PRINTOUT T T]) + +(CSSIZE + [LAMBDA (CSINFO INCLUDEBM) (* ; "Edited 19-Jul-2025 16:37 by rmk") + + (* ;; "Returns") + + (LET ((BLOCKSIZE (UNFOLD (IPLUS \MAXCHARSET 3) + 2)) + BM) + (IPLUS (CL:IF (fetch (CHARSETINFO OFFSETS) of CSINFO) + BLOCKSIZE + 0) + (CL:IF (fetch (CHARSETINFO WIDTHS) of CSINFO) + BLOCKSIZE + 0) + (CL:IF (AND (NEQ (fetch (CHARSETINFO WIDTHS) of CSINFO) + (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) + (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) + BLOCKSIZE + 0) + (CL:IF (fetch (CHARSETINFO YWIDTHS) of CSINFO) + BLOCKSIZE + 0) + (CL:IF (ARRAYP (fetch (CHARSETINFO LEFTKERN) of CSINFO)) + (UNFOLD (ARRAYSIZE (fetch (CHARSETINFO LEFTKERN) of CSINFO)) + 4) + 0) + (CL:IF (AND INCLUDEBM (SETQ BM (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) + (IQUOTIENT (ITIMES (BITMAPWIDTH BM) + (BITMAPHEIGHT BM)) + 8) + 0)]) + +(CSBMSIZE + [LAMBDA (FONT CHARSETS FILETOO NOERROR) (* ; "Edited 19-Jul-2025 16:14 by rmk") + (* ; "Edited 17-Jul-2025 13:23 by rmk") + + (* ;; "Returns the number of bytes in the CHARSET bitmap for FONT, what's in core unless FILETOO") + + (if (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY NOERROR)) + then (CL:UNLESS CHARSETS + (SETQ CHARSETS (for CS CSINFO BM from 0 to 255 when (SETQ CSINFO (\XGETCHARSETINFO + FONT CS)) + unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CS))) + (PRINTOUT T "Charsets: ") + (for CS CSINFO BM inside CHARSETS sum (PRINTOUT T CS " ") + (SETQ BM (fetch (CHARSETINFO CHARSETBITMAP) + of (\XGETCHARSETINFO FONT CS))) + (IQUOTIENT (ITIMES (BITMAPWIDTH BM) + (BITMAPHEIGHT BM)) + 8) finally (PRINTOUT T T)) + else 0]) +) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (818 15839 (DEBUGCHARSET 828 . 4007) (IBM 4009 . 4717) (ICS 4719 . 6013) (SHOWCACHE 6015 + . 6362) (SHOWCSBITMAP 6364 . 7478) (EQCSBM 7480 . 8366) (EQCHARBM 8368 . 9129) (CHARSETCHARS 9131 . +9797) (CHARBMDIFFS 9799 . 10675) (SHOWCSCHAR 10677 . 11112) (CSCOMPARE 11114 . 13706) (SHOWBMS 13708 + . 13886) (SHOWCHARBITMAPS 13888 . 15479) (CANDS 15481 . 15837)) (15840 19322 (FONTSIZE 15850 . 16535) + (CSSIZE 16537 . 17946) (CSBMSIZE 17948 . 19320))))) +STOP diff --git a/internal/FONT-DEBUG.LCOM b/internal/FONT-DEBUG.LCOM new file mode 100644 index 000000000..301a5ac24 Binary files /dev/null and b/internal/FONT-DEBUG.LCOM differ diff --git a/internal/loadups/LOADUP-FULL b/internal/loadups/LOADUP-FULL index 155ab7077..9d7c67a51 100644 --- a/internal/loadups/LOADUP-FULL +++ b/internal/loadups/LOADUP-FULL @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "23-Apr-2025 05:14:27" {DSK}larry>il>medley>internal>loadups>LOADUP-FULL.;2 4662 +(FILECREATED "13-Jul-2025 11:41:03" {WMEDLEY}loadups>LOADUP-FULL.;28 5184 - :EDIT-BY "lmm" + :EDIT-BY rmk :CHANGES-TO (FNS LOADFULLFONTS) - :PREVIOUS-DATE "31-Jul-2023 18:28:53" {DSK}larry>il>medley>internal>loadups>LOADUP-FULL.;1 -) + :PREVIOUS-DATE "30-Jun-2025 00:04:34" {WMEDLEY}loadups>LOADUP-FULL.;27) (PRETTYCOMPRINT LOADUP-FULLCOMS) @@ -17,32 +16,37 @@ (DEFINEQ (LOADFULLFONTS - [LAMBDA NIL (* ; "Edited 23-Apr-2025 05:13 by lmm") + [LAMBDA NIL (* ; "Edited 13-Jul-2025 11:40 by rmk") + (* ; "Edited 30-Jun-2025 00:04 by rmk") + (* ; "Edited 20-Jun-2025 11:16 by rmk") + (* ; "Edited 16-Jun-2025 15:34 by rmk") + (* ; "Edited 23-Apr-2025 05:13 by lmm") (* ; "Edited 13-Feb-2021 22:51 by larry") (* ;; " Don't do Interpress. Do character set 0 and the symbol character sets 41Q, 42Q, 356Q, 357Q and extended and accented Latin 43Q and 361Q") (PRINTOUT T "Loading FULL fonts..." T) - (SETQ DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE)) (SETQ *POSTSCRIPT-FILE-TYPE* 'TEXT) - (RESETVARS ((MISSINGDISPLAYFONTCOERCIONS NIL) - (MISSINGCHARSETDISPLAYFONTCOERCIONS NIL)) (* ; - "Don't let the font loader substitute just because a server went catatonic on us") - (for FAMILY in '(CLASSIC MODERN TERMINAL) - do (PRINTOUT T " Loading " FAMILY " ") - [for SIZE in '(8 10 12) - do (PRINTOUT T SIZE " ") - (for FACE in '(MRR BRR MIR) - do (for CSET in '(0 33 34 35 238 239 241) - do (NLSETQ (FONTCREATE FAMILY SIZE FACE NIL 'DISPLAY NIL CSET] - (PRINTOUT T T)) - (PRINTOUT T " Loading postscript fonts" T) - (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES) - ">c0>*.PSCFONT")) do (PSCFONT.READFONT F)) - (PRINTOUT T "FULL fonts loaded" T]) + + (* ;; "Previous code reset the coercion variables to NIL, which would have resulted in glyph-incomplete charsets. With Medley-formatted fonts, the completions have already been installed in the files and there is no need to deal with those variables.") + + (for FAMILY in '(CLASSIC MODERN TERMINAL) + do (PRINTOUT T " Loading " FAMILY " ") + [for SIZE in '(8 10 12) + do (PRINTOUT T SIZE " ") + (for FACE in '(MRR BRR MIR) + do (FONTCREATE FAMILY SIZE FACE 0 'DISPLAY NIL 0) + (for CSET in '(33 34 35 238 239 241) + do (NLSETQ (FONTCREATE FAMILY SIZE FACE 0 'DISPLAY NIL CSET] + (PRINTOUT T T)) + (PRINTOUT T " Loading postscript fonts" T) + (for F in (FILDIR (CONCAT (CAR POSTSCRIPTFONTDIRECTORIES) + ">c0>*.PSCFONT")) do (PSCFONT.READFONT F)) + (PRINTOUT T "FULL fonts loaded" T]) (LOADUP-FULL - [LAMBDA (DRIBBLEFILE) (* ; "Edited 18-Jan-2023 16:22 by FGH") + [LAMBDA (DRIBBLEFILE) (* ; "Edited 21-Jun-2025 23:33 by rmk") + (* ; "Edited 18-Jan-2023 16:22 by FGH") (* ; "Edited 12-Aug-2022 11:17 by lmm") (* ; "Edited 14-Jul-2022 12:32 by rmk") (* ; "Edited 12-Jul-2022 21:57 by rmk") @@ -67,6 +71,7 @@ " while connected to " (DIRECTORYNAME T) T T) + (LOADUP '(MULTI-ALIST)) (* ; "For FONTSAVAILABLE lookup") (LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT") (LOADFULLFONTS) (LISTPUT IDLE.PROFILE 'TIMEOUT 0) @@ -89,5 +94,5 @@ (FIXMETA) (DECLARE%: DONTCOPY - (FILEMAP (NIL (493 4624 (LOADFULLFONTS 503 . 2059) (LOADUP-FULL 2061 . 4374) (FIXMETA 4376 . 4622))))) + (FILEMAP (NIL (458 5146 (LOADFULLFONTS 468 . 2373) (LOADUP-FULL 2375 . 4896) (FIXMETA 4898 . 5144))))) STOP diff --git a/internal/loadups/LOADUP-FULL.LCOM b/internal/loadups/LOADUP-FULL.LCOM index 1332ec1f6..6cf1563dc 100644 Binary files a/internal/loadups/LOADUP-FULL.LCOM and b/internal/loadups/LOADUP-FULL.LCOM differ diff --git a/internal/loadups/LOADUP-LISP b/internal/loadups/LOADUP-LISP index 5000cbff0..bf91823b4 100644 --- a/internal/loadups/LOADUP-LISP +++ b/internal/loadups/LOADUP-LISP @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "21-Mar-2024 10:56:13" |{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;4| 5586 +(FILECREATED "15-Jun-2025 14:39:57" |{WMEDLEY}loadups>LOADUP-LISP.;20| 6425 - :EDIT-BY "lmm" + :EDIT-BY |rmk| :CHANGES-TO (FNS LOADUP-LISP) - :PREVIOUS-DATE "14-Mar-2024 12:16:33" -|{DSK}larry>il>medley>internal>loadups>LOADUP-LISP.;3|) + :PREVIOUS-DATE "24-May-2025 10:20:14" |{WMEDLEY}loadups>LOADUP-LISP.;14|) (PRETTYCOMPRINT LOADUP-LISPCOMS) @@ -20,7 +19,12 @@ (DEFINEQ (LOADUP-LISP - (LAMBDA (DRIBBLEFILE) (* \; "Edited 21-Mar-2024 10:55 by lmm") + (LAMBDA (DRIBBLEFILE) (* \; "Edited 15-Jun-2025 14:39 by rmk") + (* \; "Edited 24-May-2025 10:20 by rmk") + (* \; "Edited 21-May-2025 09:25 by rmk") + (* \; "Edited 5-May-2025 21:25 by rmk") + (* \; "Edited 2-May-2025 22:12 by rmk") + (* \; "Edited 21-Mar-2024 10:55 by lmm") (* \; "Edited 14-Mar-2024 12:16 by lmm") (* \; "Edited 26-Feb-2023 12:17 by lmm") (* \; "Edited 13-Jul-2022 14:09 by rmk") @@ -61,8 +65,8 @@ (LOADUP '(STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS)) (LOADUP '(COMMON XCLC-RUNTIME CMLTYPES CL-ERROR)) - (LOADUP '(AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS - DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE)) + (LOADUP '(AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF SPELLFILE PRINTFN LOADFNS DMISC + DIRECTORY SPELLFILE FILEPKG RESOURCE)) (* |;;| "needed for makesys") @@ -79,9 +83,12 @@ CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES)) (LOADUP '(PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT)) (LOADUP '(ADDARITH)) - (LOADUP '(UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW - WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE - CMLARRAYINSPECTOR EDITINTERFACE TTYIN)) + + (* |;;| "Before the MEDLEYFONT implementation, FONTPROFILE came after NEWPRINTDEF above, but the loadup failed for undiagnosed reasons. After moving it around, it appears that it must come before MENU, because it creates thw WINDOWTITLEFONT, but after HLDISPLAY. Not yet known what the HLDISPLAY dependency is. ") + + (LOADUP '(UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU WINDOWOBJ + WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT + DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)) (LOADUP '(BREAK-AND-TRACE)) (LOADUP '(FASDUMP XCL-COMPILER ADVISE)) @@ -131,5 +138,5 @@ (GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST) ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (673 5380 (LOADUP-LISP 683 . 5378))))) + (FILEMAP (NIL (640 6219 (LOADUP-LISP 650 . 6217))))) STOP diff --git a/internal/loadups/LOADUP-LISP.LCOM b/internal/loadups/LOADUP-LISP.LCOM index d83abfd5d..87001c262 100644 Binary files a/internal/loadups/LOADUP-LISP.LCOM and b/internal/loadups/LOADUP-LISP.LCOM differ diff --git a/library/FX-80DRIVER b/library/FX-80DRIVER index 96cfefe43..39183cc9b 100644 --- a/library/FX-80DRIVER +++ b/library/FX-80DRIVER @@ -1,33 +1,35 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "11-Jun-90 15:57:59" {DSK}local>lde>lispcore>library>FX-80DRIVER.;2 233870 - changes to%: (VARS FX-80DRIVERCOMS) +(FILECREATED "15-Jul-2025 22:01:24"  +{DSK}kaplan>Local>medley3.5>working-medley>library>FX-80DRIVER.;2 231869 - previous date%: "23-Sep-88 10:26:48" {DSK}local>lde>lispcore>library>FX-80DRIVER.;1) + :EDIT-BY rmk + :CHANGES-TO (VARS FX-80.HIGH-QUALITY-DRIVERCOMS) + (FNS \HQFX80.CHANGEFONT) + + :PREVIOUS-DATE "11-Jun-90 15:57:59" +{DSK}kaplan>Local>medley3.5>working-medley>library>FX-80DRIVER.;1) -(* ; " -Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT FX-80DRIVERCOMS) (RPAQQ FX-80DRIVERCOMS ( -(* ;;; "FX-80 driver") +(* ;;; "FX-80 driver") - (COMS * FX-80.FAST-DRIVERCOMS (* ; "the fast driver")) - (COMS * FX-80.HIGH-QUALITY-DRIVERCOMS (* ; "the higher quality driver")) - (COMS * FX80-PRINTCOMS (* ; "FXPrinter emulation")) - (COMS (* ; "common routines") - (FUNCTIONS (* ; "abort window stuff") + (COMS * FX-80.FAST-DRIVERCOMS (* ; "the fast driver")) + (COMS * FX-80.HIGH-QUALITY-DRIVERCOMS (* ; "the higher quality driver")) + (COMS * FX80-PRINTCOMS (* ; "FXPrinter emulation")) + (COMS (* ; "common routines") + (FUNCTIONS (* ; "abort window stuff") WITH-ABORT-WINDOW \FX80.CREATE-SEND-ABORT-WINDOW) - (FUNCTIONS (* ; "font profile hacking") + (FUNCTIONS (* ; "font profile hacking") \ADD-TO-FONTPROFILE \GET-FROM-FONTPROFILE)) -(* ;;; "initialization") +(* ;;; "initialization") [COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\HQFX80.INIT) (\FASTFX80.INIT] @@ -40,35 +42,35 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (RPAQQ FX-80.FAST-DRIVERCOMS [ - (* ;; "Fast driver") + (* ;; "Fast driver") - (* ;; "") + (* ;; "") (STRUCTURES FASTFX80DATA) (FNS \FASTFX80.INIT) - (* ;; "Imagestream methods") + (* ;; "Imagestream methods") (COMS - (* ;; "opening/closing imagestream") + (* ;; "opening/closing imagestream") (COMS (FNS OPENFASTFX80STREAM) (FUNCTIONS \FASTFX80.PREAMBLE \FASTFX80.RESET-PRINTER \FASTFX80.OUTPUT-SIGNATURE) ) (FNS \FASTFX80.CLOSE)) (COMS - (* ;; "methods that hack fonts") + (* ;; "methods that hack fonts") (FNS \FASTFX80.CHANGEFONT \FASTFX80.FONTCREATE \FASTFX80.CREATECHARSET) (FUNCTIONS \FASTFX80.INIT-FONT-PROFILE)) (COMS - (* ;; "methods for measuring") + (* ;; "methods for measuring") (FNS \FASTFX80.STRINGWIDTH \FASTFX80.CHARWIDTH \FASTFX80.SUBCHARWIDTH) (FUNCTIONS \FASTFX80.SPACEFACTOR)) (COMS - (* ;; "methods that affect the current position/size of drawing surface") + (* ;; "methods that affect the current position/size of drawing surface") (FNS \FASTFX80.CLIPPINGREGION \FASTFX80.MOVETO \FASTFX80.XPOSITION \FASTFX80.YPOSITION \FASTFX80.BACKUP.PAPER \FASTFX80.ADVANCE.PAPER \FASTFX80.NEWPAGE \FASTFX80.OUTCHAR @@ -77,28 +79,28 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r \FASTFX80.BOTTOMMARGIN \FASTFX80.LEFTMARGIN \FASTFX80.RIGHTMARGIN \FASTFX80.CUR-POS-VISIBLE? \FASTFX80.HORIZONTAL)) (COMS - (* ;; "printer code") + (* ;; "printer code") (FUNCTIONS \FASTFX80.SEND MAKE-FASTFX80 FASTFX80FILEP \FASTFX80.CANNOT-PRINT-BITMAPS) (FNS \FASTFX80.CONVERT-TEDIT)) (COMS - (* ;; "Character transmission method") + (* ;; "Character transmission method") (FNS \FASTFX80.BOUT)) - (* ;; "Miscellany") + (* ;; "Miscellany") (FUNCTIONS \FASTFX80.TRANSLATE-CHAR WITH-FASTFX80-DATA) (CONSTANTS (\FASTFX80.DOTSPERINCH 72) (\FASTFX80.LINESPERINCH 6) (\FASTFX80.LINEHEIGHT 12) - (* ; "in dots") + (* ; "in dots") (\FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ")) (INITVARS (FASTFX80-DEFAULT-DESTINATION "{TTY}") (\FASTFX80.INCHES-PER-PAGE 11) (\FASTFX80.INCHES-PER-LINE 8.5)) (COMS - (* ;; "need to load these exports") + (* ;; "need to load these exports") (DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) ADISPLAY]) @@ -115,7 +117,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFSTRUCT FASTFX80DATA - (* ;; "the imagedata vector for a fastfx80 imagestream") + (* ;; "the imagedata vector for a fastfx80 imagestream") (VIRTUAL-XPOS 0) (VIRTUAL-YPOS 0) @@ -235,48 +237,44 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \FASTFX80.PREAMBLE (FASTFX80STREAM) - (* ;; "start a FASTFX80 master") + (* ;; "start a FASTFX80 master") -(* ;;; "must change FASTFX80FILEP when this changes") +(* ;;; "must change FASTFX80FILEP when this changes") (DECLARE (GLOBALVARS \FASTFX80.INCHES-PER-PAGE)) - (\FASTFX80.RESET-PRINTER FASTFX80STREAM \FASTFX80.INCHES-PER-PAGE) - (\FASTFX80.OUTPUT-SIGNATURE FASTFX80STREAM) + (\FASTFX80.RESET-PRINTER FASTFX80STREAM \FASTFX80.INCHES-PER-PAGE) + (\FASTFX80.OUTPUT-SIGNATURE FASTFX80STREAM) (\FASTFX80.CHANGEFONT FASTFX80STREAM (DEFAULTFONT 'FASTFX80)) - (\FASTFX80.STARTPAGE FASTFX80STREAM)) + (\FASTFX80.STARTPAGE FASTFX80STREAM)) (CL:DEFUN \FASTFX80.RESET-PRINTER (FASTFX80STREAM INCHES-PER-PAGE) - (* ;; "send a reset sequence to the fx-80") + (* ;; "send a reset sequence to the fx-80") (IF (AND (<= 1 INCHES-PER-PAGE) - (<= INCHES-PER-PAGE 21)) + (<= INCHES-PER-PAGE 21)) THEN + (* ;; "send a reset sequence to the fx-80...") - (* ;; "send a reset sequence to the fx-80...") - - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE @)) + (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) + (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE @)) - (* ;; "...and set the form length") + (* ;; "...and set the form length") - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE C)) - (\FASTFX80.BOUT FASTFX80STREAM (FIXR (TIMES INCHES-PER-PAGE \FASTFX80.LINESPERINCH)) - ) + (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) + (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE C)) + (\FASTFX80.BOUT FASTFX80STREAM (FIXR (TIMES INCHES-PER-PAGE \FASTFX80.LINESPERINCH))) ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE))) (CL:DEFUN \FASTFX80.OUTPUT-SIGNATURE (FASTFX80STREAM) - (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") + (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") - (* ;; "This will not work if SIGNATURE contains line-ending characters.") + (* ;; "This will not work if SIGNATURE contains line-ending characters.") (LET ((DEL-BYTE 127)) - (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM - BYTE)) - (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM - DEL-BYTE)))) + (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM BYTE)) + (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM DEL-BYTE)))) (DEFINEQ (\FASTFX80.CLOSE @@ -394,15 +392,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \FASTFX80.INIT-FONT-PROFILE () - (* ;; "set up the fonts for the FASTFX80, based on the DISPLAY font profile entries") + (* ;; "set up the fonts for the FASTFX80, based on the DISPLAY font profile entries") - [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT - COMMENTFONT TEXTFONT) DO (\ADD-TO-FONTPROFILE - FONTPROFILE FONT-CLASS - 'FASTFX80 - (\GET-FROM-FONTPROFILE - FONTPROFILE FONT-CLASS - 'DISPLAY] + [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT + TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'FASTFX80 + (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS + 'DISPLAY] (FONTPROFILE FONTPROFILE) T) @@ -476,13 +471,13 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \FASTFX80.SPACEFACTOR (FASTFX80STREAM FACTOR) - (* ;; "returns/sets the width of the space character (32 ASCII) for FASTFX80STREAM") + (* ;; "returns/sets the width of the space character (32 ASCII) for FASTFX80STREAM") - [WITH-FASTFX80-DATA (DATA FASTFX80STREAM) + [WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (PROG1 (FASTFX80DATA-SPACEFACTOR DATA) (AND FACTOR (IF (NUMBERP FACTOR) THEN (CL:SETF (FASTFX80DATA-SPACEFACTOR DATA) - FACTOR) + FACTOR) ELSE (\ILLEGAL.ARG FACTOR))))]) @@ -718,11 +713,11 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r ) (CL:DEFUN \FASTFX80.STARTPAGE (FASTFX80STREAM) - (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) + (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) (LET [(ASCENT (FONTPROP (DSPFONT NIL FASTFX80STREAM) 'ASCENT] - (* ;; "set the %"actual%" position of printhead on paper after a newpage, then let the driver figure out how to get to (leftmargin, topmargin).") + (* ;; "set the %"actual%" position of printhead on paper after a newpage, then let the driver figure out how to get to (leftmargin, topmargin).") (CL:SETF (FASTFX80DATA-VIRTUAL-XPOS DATA) 0) @@ -733,7 +728,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:SETF (FASTFX80DATA-REAL-YPOS DATA) (FASTFX80DATA-PAPER-HEIGHT DATA)) - (* ;; "move the paper") + (* ;; "move the paper") (MOVETO (FASTFX80DATA-LEFTMARGIN DATA) (- (FASTFX80DATA-TOPMARGIN DATA) @@ -743,7 +738,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \FASTFX80.SMART-XPOSITION (CURRENT-XPOS DESIRED-XPOS FASTFX80STREAM) - (* ;; "if it would create less output to space from the left margin, rather than to backspace from the current position, do so") + (* ;; "if it would create less output to space from the left margin, rather than to backspace from the current position, do so") (LET* ((SPACEWIDTH (\FASTFX80.CHARWIDTH FASTFX80STREAM (CHARCODE SP))) (CURRENT-XPOS-IN-SPACES (IQUOTIENT CURRENT-XPOS SPACEWIDTH)) @@ -751,51 +746,49 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (NUM-BACKSPACES-NEEDED (- CURRENT-XPOS-IN-SPACES DESIRED-XPOS-IN-SPACES))) (IF (< NUM-BACKSPACES-NEEDED DESIRED-XPOS-IN-SPACES) THEN + (* ;; "if backspacing's cheaper, backspace away") - (* ;; "if backspacing's cheaper, backspace away") - - (\FASTFX80.HORIZONTAL (- NUM-BACKSPACES-NEEDED) - FASTFX80STREAM) + (\FASTFX80.HORIZONTAL (- NUM-BACKSPACES-NEEDED) + FASTFX80STREAM) ELSE + (* ;; "otherwise, go to the left margin... ") - (* ;; "otherwise, go to the left margin... ") - - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE CR)) + (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE CR)) - (* ;; "... and then space to the right spot") + (* ;; "... and then space to the right spot") - (\FASTFX80.HORIZONTAL DESIRED-XPOS-IN-SPACES FASTFX80STREAM)))) + (\FASTFX80.HORIZONTAL DESIRED-XPOS-IN-SPACES FASTFX80STREAM)))) (CL:DEFUN \FASTFX80.TOPMARGIN (STREAM &OPTIONAL YPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) + [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-TOPMARGIN DATA) (AND YPOSITION (IF (SMALLP YPOSITION) THEN (CL:SETF (FASTFX80DATA-TOPMARGIN DATA) - YPOSITION) + YPOSITION) ELSE (\ILLEGAL.ARG YPOSITION))))]) (CL:DEFUN \FASTFX80.BOTTOMMARGIN (STREAM &OPTIONAL YPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) + [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-BOTTOMMARGIN DATA) (AND YPOSITION (IF (SMALLP YPOSITION) THEN (CL:SETF (FASTFX80DATA-BOTTOMMARGIN DATA) - YPOSITION) + YPOSITION) ELSE (\ILLEGAL.ARG YPOSITION))))]) (CL:DEFUN \FASTFX80.LEFTMARGIN (STREAM &OPTIONAL XPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) + [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-LEFTMARGIN DATA) (AND XPOSITION (IF (SMALLP XPOSITION) THEN (CL:SETF (FASTFX80DATA-LEFTMARGIN DATA) - XPOSITION) + XPOSITION) ELSE (\ILLEGAL.ARG XPOSITION))))]) (CL:DEFUN \FASTFX80.RIGHTMARGIN (STREAM &OPTIONAL XPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) + [WITH-FASTFX80-DATA (DATA STREAM) (PROG1 (FASTFX80DATA-RIGHTMARGIN DATA) (AND XPOSITION (IF (SMALLP XPOSITION) THEN (CL:SETF (FASTFX80DATA-RIGHTMARGIN DATA) - XPOSITION) + XPOSITION) ELSE (\ILLEGAL.ARG XPOSITION))))]) (DEFMACRO \FASTFX80.CUR-POS-VISIBLE? (FASTFX80DATA) @@ -805,14 +798,11 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \FASTFX80.HORIZONTAL (SPACES FASTFX80STREAM) - (* ;; "print SPACES space characters if SPACES > 0, print SPACES backspaces if < 0, and do nothing if SPACES=0.") + (* ;; "print SPACES space characters if SPACES > 0, print SPACES backspaces if < 0, and do nothing if SPACES=0.") [if (MINUSP SPACES) - then (for SPACE from 1 to (ABS SPACES) by 1 - do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE BS))) - else (for SPACE from 1 to SPACES by 1 do (\FASTFX80.BOUT - FASTFX80STREAM - (CHARCODE SP]) + then (for SPACE from 1 to (ABS SPACES) by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE BS))) + else (for SPACE from 1 to SPACES by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE SP]) @@ -821,65 +811,61 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \FASTFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS) - (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to FASTFX80-DEFAULT-DESTINATION") + (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to FASTFX80-DEFAULT-DESTINATION") (DECLARE (GLOBALVARS FASTFX80-DEFAULT-DESTINATION)) [LET [(COPIES (LISTGET OPTIONS '%#COPIES] (FOR COPY FROM 1 TO COPIES DO + (* ;; "allow the user to abort it while running") - (* ;; - "allow the user to abort it while running") - - (WITH-ABORT-WINDOW ((THIS.PROCESS) - FILENAME PRINTER COPY) - (COPYFILE FILENAME - FASTFX80-DEFAULT-DESTINATION - '((TYPE FASTFX80]) + (WITH-ABORT-WINDOW ((THIS.PROCESS) + FILENAME PRINTER COPY) + (COPYFILE FILENAME FASTFX80-DEFAULT-DESTINATION + '((TYPE FASTFX80]) (CL:DEFUN MAKE-FASTFX80 (FILE FASTFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS) - (* ;; "turn FILE into a FASTFX80 master") + (* ;; "turn FILE into a FASTFX80 master") (TEXTTOIMAGEFILE FILE FASTFX80FILE 'FASTFX80 FONTS HEADING TABS OPTIONS)) (CL:DEFUN FASTFX80FILEP (FASTFX80FILE?) - (* ;; "is FILE (a filename or stream) a fastfx80 file?") + (* ;; "is FILE (a filename or stream) a fastfx80 file?") [LET [(FILE-TYPE (GETFILEINFO FASTFX80FILE? 'TYPE] (IF (EQ FILE-TYPE 'FASTFX80) - THEN (* ; - "if file has a type, and type=FASTFX80, we win") - T - ELSE (* ; - "no filetype or filetype not FASTFX80, so read the file") - (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING FASTFX80FILE?) - 'INPUT - 'OLD - '(SEQUENTIAL] - - (* ;; "file looks like ESC@ESCCn...") - - (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) - (+ 5 (NCHARS \FASTFX80.FILE-SIGNATURE))) - - (* ;; "yuck...") - - (EQ (CHARCODE ESC) - (BIN STREAM)) - (EQ (CHARCODE @) - (BIN STREAM)) - (EQ (CHARCODE ESC) - (BIN STREAM)) - (EQ (CHARCODE C) - (BIN STREAM)) - (BIN STREAM) - (FOR CH INSTRING \FASTFX80.FILE-SIGNATURE - ALWAYS (EQ CH (BIN STREAM] - (CLOSEF STREAM]) - -(CL:DEFUN \FASTFX80.CANNOT-PRINT-BITMAPS (&OPTIONAL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE - ) + THEN (* ; + "if file has a type, and type=FASTFX80, we win") + T + ELSE (* ; + "no filetype or filetype not FASTFX80, so read the file") + (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING FASTFX80FILE?) + 'INPUT + 'OLD + '(SEQUENTIAL] + + (* ;; "file looks like ESC@ESCCn...") + + (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) + (+ 5 (NCHARS \FASTFX80.FILE-SIGNATURE))) + + (* ;; "yuck...") + + (EQ (CHARCODE ESC) + (BIN STREAM)) + (EQ (CHARCODE @) + (BIN STREAM)) + (EQ (CHARCODE ESC) + (BIN STREAM)) + (EQ (CHARCODE C) + (BIN STREAM)) + (BIN STREAM) + (FOR CH INSTRING \FASTFX80.FILE-SIGNATURE + ALWAYS (EQ CH (BIN STREAM] + (CLOSEF STREAM]) + +(CL:DEFUN \FASTFX80.CANNOT-PRINT-BITMAPS (&OPTIONAL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE) (PRINTOUT PROMPTWINDOW "Sorry, FASTFX80 cannot render graphics." T "Use HQFX80 instead.")) (DEFINEQ @@ -917,17 +903,17 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DEFMACRO \FASTFX80.TRANSLATE-CHAR (CHARCODE) `(SELCHARQ ,CHARCODE - (357,146 (* ; "bullet") + (357,146 (* ; "bullet") (CHARCODE *)) - (357,45 (* ; "em-dash") + (357,45 (* ; "em-dash") 95) - (357,44 (* ; "en-dash") + (357,44 (* ; "en-dash") 45) (\CHAR8CODE ,CHARCODE))) (DEFMACRO WITH-FASTFX80-DATA ((VAR-NAME STREAM) - &BODY - (BODY DECLS ENV)) + &BODY + (BODY DECLS ENV)) `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM] ,@DECLS ,@BODY)) @@ -966,36 +952,36 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (RPAQQ FX-80.HIGH-QUALITY-DRIVERCOMS [ - (* ;; "High-quality driver") + (* ;; "High-quality driver") - (* ;; "") + (* ;; "") (STRUCTURES HQFX80DATA) (FNS \HQFX80.INIT) (COMS - (* ;; "imagestream methods") + (* ;; "imagestream methods") (COMS - (* ;; "opening/closing imagestream") + (* ;; "opening/closing imagestream") (COMS (FNS OPENHQFX80STREAM) (FUNCTIONS \HQFX80.PREAMBLE \HQFX80.RESET-PRINTER \HQFX80.OUTPUT-SIGNATURE) ) (FNS \HQFX80.CLOSE)) (COMS - (* ;; "methods that hack fonts") + (* ;; "methods that hack fonts") (FNS \HQFX80.FONTCREATE \HQFX80.CHANGEFONT \HQFX80.CREATECHARSET \HQFX80.CHANGE-CHARSET \HQFX80.READ-FONT-FILE \HQFX80.SEARCH-FONTS) (FUNCTIONS \HQFX80.INIT-FONT-PROFILE)) (COMS - (* ;; "methods for measuring") + (* ;; "methods for measuring") (FNS \HQFX80.CHARWIDTH \HQFX80.STRINGWIDTH) (FUNCTIONS \HQFX80.SPACEFACTOR)) (COMS - (* ;; "methods that affect the current position/size of drawing surface") + (* ;; "methods that affect the current position/size of drawing surface") (FNS \HQFX80.CLIPPINGREGION \HQFX80.LEFTMARGIN \HQFX80.RIGHTMARGIN \HQFX80.TOPMARGIN \HQFX80.BOTTOMMARGIN \HQFX80.XPOSITION \HQFX80.YPOSITION @@ -1003,7 +989,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r \HQFX80.STARTPAGE) (FUNCTIONS \HQFX80.CUR-POS-VISIBLE?)) (COMS - (* ;; "graphical operations") + (* ;; "graphical operations") (RESOURCES \HQFX80.BRUSHBBT) (FNS \HQFX80.BITBLT \HQFX80.BLTSHADE \HQFX80.DRAWELLIPSE \HQFX80.OPERATION @@ -1014,7 +1000,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (COMS (FNS \HQFX80.FILLCIRCLE \HQFX80.DRAWARC) (FUNCTIONS \HQFX80.FILL-CIRCLE-BLT)) (COMS - (* ;; "curve-drawing") + (* ;; "curve-drawing") (FNS \HQFX80.DRAWCURVE \HQFX80.DRAWCURVE2 \HQFX80.DRAWCURVE3 \HQFX80.LINEWITHBRUSH) @@ -1022,38 +1008,38 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (MACROS \HQFX80.CURVEPT) (FUNCTIONS \HQFX80.SMOOTH-CURVE .SETUP.FOR.\HQFX80.BBTCURVEPT.))) (COMS - (* ;; "character printing methods") + (* ;; "character printing methods") (FNS \HQFX80.OUTCHAR \HQFX80.BLT-CHAR)) (COMS - (* ;; "printer code") + (* ;; "printer code") (FNS \HQFX80.DUMP-PAGE-BUFFER \HQFX80.ADVANCE-8-LINES) (FUNCTIONS \HQFX80.EIGHT-LINES-BLANK? \HQFX80.BITMAP-LDB \HQFX80.CLEAR-SCANLINE \HQFX80.CLEAR-WORD-BOX) (FUNCTIONS \HQFX80.SEND MAKE-HQFX80 HQFX80FILEP)) (COMS - (* ;; "window hardcopy") + (* ;; "window hardcopy") (FNS \HQFX80.BITMAP-FILE \HQFX80.CONVERT-TEDIT)) (COMS - (* ;; "character transmission method") + (* ;; "character transmission method") (FNS \HQFX80.BOUT)) (COMS - (* ;; "handling font-information caching") + (* ;; "handling font-information caching") (FNS \HQFX80.FIX-LINE-LENGTH \HQFX80.FIX-FONT \HQFX80.FIX-Y) (FUNCTIONS \HQFX80.INVALIDATE-CACHE \HQFX80.INVALIDATE-FONT-CACHE \HQFX80.GET-CACHED-CHAR-WIDTH \HQFX80.GET-CHARACTER-OFFSET)) (COMS - (* ;; "auxiliary functions") + (* ;; "auxiliary functions") (FUNCTIONS \HQFX80.GRAPHICS-MODE) (FNS \HQFX80.PRINTER-MODE) (FUNCTIONS WITH-HQFX80-DATA)) - (* ;; "and miscellany") + (* ;; "and miscellany") (CONSTANTS (\HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ") (\HQFX80.1-TO-1-MODE-DPI 72) @@ -1064,7 +1050,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (HQFX80-FONT-EXTENSIONS DISPLAYFONTEXTENSIONS) (HQFX80-FONT-DIRECTORIES DISPLAYFONTDIRECTORIES) (HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS) - (HQFX80-MISSING-FONT-COERCIONS MISSINGDISPLAYFONTCOERCIONS]) + (HQFX80-MISSING-FONT-COERCIONS DISPLAYFONTCOERCIONS]) @@ -1078,7 +1064,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFSTRUCT HQFX80DATA - (* ;; "the imagedata vector for an HQFX80 imagestream") + (* ;; "the imagedata vector for an HQFX80 imagestream") BACKINGBITMAP BACKINGSTREAM @@ -1094,8 +1080,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r FONT (CHARSET-ASCENT-CACHE MAX.SMALLP) WIDTHS-CACHE OFFSETS-CACHE IMAGE-WIDTHS-CACHE (CHARSET-CACHE MAX.SMALLP) - CHARSET-DESCENT-CACHE CHARHEIGHTDELTA (SPACEWIDTH 1.0) (* ; - "a misnomer -- this is actually the space factor, not its width") + CHARSET-DESCENT-CACHE CHARHEIGHTDELTA (SPACEWIDTH 1.0) (* ; + "a misnomer -- this is actually the space factor, not its width") [SERIALIZING-BOX (fetch (ARRAYP BASE) of (ARRAY 1 'BYTE] SERIALIZING-PILOTBBT SCRATCH-SCANLINE SCRATCH-SCANLINE-PILOTBBT [EIGHT-LINES-BLANK (fetch (ARRAYP BASE) @@ -1276,45 +1262,43 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \HQFX80.PREAMBLE (HQFX80STREAM) - (* ;; "start an HQFX80 master") + (* ;; "start an HQFX80 master") (DECLARE (GLOBALVARS \HQFX80.INCHES-PER-PAGE)) - (\HQFX80.RESET-PRINTER HQFX80STREAM \HQFX80.INCHES-PER-PAGE) - (\HQFX80.OUTPUT-SIGNATURE HQFX80STREAM) + (\HQFX80.RESET-PRINTER HQFX80STREAM \HQFX80.INCHES-PER-PAGE) + (\HQFX80.OUTPUT-SIGNATURE HQFX80STREAM) (DSPFONT (DEFAULTFONT 'HQFX80) HQFX80STREAM) (\HQFX80.STARTPAGE HQFX80STREAM)) (CL:DEFUN \HQFX80.RESET-PRINTER (HQFX80STREAM INCHES-PER-PAGE) - (* ;; "send a reset sequence to the fx-80") + (* ;; "send a reset sequence to the fx-80") (IF (AND (<= 1 INCHES-PER-PAGE) - (<= INCHES-PER-PAGE 22)) + (<= INCHES-PER-PAGE 22)) THEN + (* ;; "send a reset sequence to the fx-80...") - (* ;; "send a reset sequence to the fx-80...") - - (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) - (\HQFX80.BOUT HQFX80STREAM (CHARCODE @)) + (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) + (\HQFX80.BOUT HQFX80STREAM (CHARCODE @)) - (* ;; "...and set the form length") + (* ;; "...and set the form length") - (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) - (\HQFX80.BOUT HQFX80STREAM (CHARCODE C)) - (\HQFX80.BOUT HQFX80STREAM (FIXR (TIMES 6 INCHES-PER-PAGE))) + (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) + (\HQFX80.BOUT HQFX80STREAM (CHARCODE C)) + (\HQFX80.BOUT HQFX80STREAM (FIXR (TIMES 6 INCHES-PER-PAGE))) ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE))) (CL:DEFUN \HQFX80.OUTPUT-SIGNATURE (HQFX80TREAM) - (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") + (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") - (* ;; "This will not work if SIGNATURE contains line-ending characters.") + (* ;; "This will not work if SIGNATURE contains line-ending characters.") (LET ((DEL-BYTE 127)) - (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM BYTE)) - (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM - DEL-BYTE)))) + (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM BYTE)) + (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM DEL-BYTE)))) (DEFINEQ (\HQFX80.CLOSE @@ -1361,32 +1345,33 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r FONTDESC]) (\HQFX80.CHANGEFONT - [LAMBDA (HQFX80STREAM FONT) (* ; "Edited 4-Feb-87 11:48 by hdj") - - (* ;; "sets/returns the font of an HQFX80 imagestream") + [LAMBDA (HQFX80STREAM FONT) (* ; "Edited 15-Jul-2025 22:01 by rmk") + (* ; "Edited 4-Feb-87 11:48 by hdj") - (WITH-HQFX80-DATA + (* ;; "sets/returns the font of an HQFX80 imagestream") + + (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) (LET ((OLD-FONT (HQFX80DATA-FONT HQFX80DATA))) - + (* ;; "save old value to return, smash new value and update the record.") - (PROG1 OLD-FONT (if FONT - then (LET [(NEW-FONT (OR (\COERCEFONTDESC FONT HQFX80STREAM T) - (FONTCOPY (HQFX80DATA-FONT HQFX80DATA) - FONT] - - (* ;; + (PROG1 OLD-FONT + [if FONT + then (LET [(NEW-FONT (OR (FONTCREATE FONT NIL NIL NIL HQFX80STREAM T) + (FONTCOPY (HQFX80DATA-FONT HQFX80DATA) + FONT] + + (* ;;  "updating font information is fairly expensive operation. Don't bother unless font has changed.") - (OR (EQ OLD-FONT NEW-FONT) - (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-FONT HQFX80DATA) - NEW-FONT) - (CL:SETF (HQFX80DATA-LINEFEED HQFX80DATA) - (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) - of NEW-FONT))) - (\HQFX80.FIX-FONT HQFX80STREAM HQFX80DATA))]) + (OR (EQ OLD-FONT NEW-FONT) + (UNINTERRUPTABLY + (CL:SETF (HQFX80DATA-FONT HQFX80DATA) + NEW-FONT) + (CL:SETF (HQFX80DATA-LINEFEED HQFX80DATA) + (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of NEW-FONT))) + (\HQFX80.FIX-FONT HQFX80STREAM HQFX80DATA))])]) (\HQFX80.CREATECHARSET [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) @@ -1617,15 +1602,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \HQFX80.INIT-FONT-PROFILE () - (* ;; "set up the fonts for the HQFX80, based on the DISPLAY font profile entries") + (* ;; "set up the fonts for the HQFX80, based on the DISPLAY font profile entries") - [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT - COMMENTFONT TEXTFONT) DO (\ADD-TO-FONTPROFILE - FONTPROFILE FONT-CLASS - 'HQFX80 - (\GET-FROM-FONTPROFILE - FONTPROFILE FONT-CLASS - 'DISPLAY] + [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT + TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'HQFX80 + (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS + 'DISPLAY] (FONTPROFILE FONTPROFILE) T) @@ -1673,13 +1655,13 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \HQFX80.SPACEFACTOR (HQFX80STREAM FACTOR) - (* ;; "returns/sets the width of the space character (32 ASCII) for HQFX80STREAM") + (* ;; "returns/sets the width of the space character (32 ASCII) for HQFX80STREAM") - [WITH-HQFX80-DATA (DATA HQFX80STREAM) + [WITH-HQFX80-DATA (DATA HQFX80STREAM) (PROG1 (HQFX80DATA-SPACEWIDTH DATA) (AND FACTOR (IF (NUMBERP FACTOR) THEN (CL:SETF (HQFX80DATA-SPACEWIDTH DATA) - FACTOR) + FACTOR) ELSE (\ILLEGAL.ARG FACTOR))))]) @@ -2761,7 +2743,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DEFMACRO \HQFX80.DRAW-4-CIRCLE-POINTS (CENTER-X CENTER-Y EDGE-X EDGE-Y) - (* ;; "draw four points 90 degress apart on the circumference of a circle") + (* ;; "draw four points 90 degress apart on the circumference of a circle") `[PROGN (\HQFX80.CURVEPT (+ ,CENTER-X ,EDGE-X) (+ ,CENTER-Y ,EDGE-Y)) @@ -2915,7 +2897,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DEFMACRO \HQFX80.FILL-CIRCLE-BLT (CENTER-X CENTER-Y X Y) - (* ;; "calls bitblt twice to fill in one line of the circle.") + (* ;; "calls bitblt twice to fill in one line of the circle.") `(PROGN (\LINEBLT FCBBT (- ,CENTER-X ,X) (+ ,CENTER-Y ,Y) @@ -3429,27 +3411,25 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (PUTPROPS \HQFX80.CURVEPT MACRO [OPENLAMBDA (X Y) - (* ;; "puts a brush shape at point X,Y. Assumes X and Y have been corrected so that it is the lower left corner of the brush. Does a clipping to the region defined by LEFT RIGHTPLUS1 BOTTOM and LEFTMINUSBRUSH TOPMINUSBRUSH BOTTOMMINUSBRUSH.") + (* ;; "puts a brush shape at point X,Y. Assumes X and Y have been corrected so that it is the lower left corner of the brush. Does a clipping to the region defined by LEFT RIGHTPLUS1 BOTTOM and LEFTMINUSBRUSH TOPMINUSBRUSH BOTTOMMINUSBRUSH.") - (COND - ((OR (ILEQ X LEFTMINUSBRUSH) - (IGEQ X RIGHTPLUS1) - (ILEQ Y BOTTOMMINUSBRUSH) - (IGEQ Y TOP)) - (* ; "Brush is entirely out of region") - NIL) - ((NULL BBT)(* ; - "Special case of single point brush") - (\FBITMAPBIT DESTINATIONBASE X Y OPERATION - HEIGHTMINUS1 RASTERWIDTH)) - (T (* ; - "Some part of the brush in in the region") - (\HQFX80.BBTCURVEPT X Y BBT LEFT BRUSHWIDTH - LEFTMINUSBRUSH RIGHTPLUS1 TOPMINUSBRUSH - DESTINATION-BITMAP BRUSHHEIGHT - BOTTOMMINUSBRUSH TOP BRUSHBASE - DESTINATIONBASE RASTERWIDTH - BRUSHRASTERWIDTH HQFX80DATA]) + (COND + ((OR (ILEQ X LEFTMINUSBRUSH) + (IGEQ X RIGHTPLUS1) + (ILEQ Y BOTTOMMINUSBRUSH) + (IGEQ Y TOP)) (* ; "Brush is entirely out of region") + NIL) + ((NULL BBT) (* ; + "Special case of single point brush") + (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 + RASTERWIDTH)) + (T (* ; + "Some part of the brush in in the region") + (\HQFX80.BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH + RIGHTPLUS1 TOPMINUSBRUSH DESTINATION-BITMAP + BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE + DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH + HQFX80DATA]) ) (DEFMACRO \HQFX80.SMOOTH-CURVE (NEWX NEWY USERFN HQFX80STREAM) @@ -3494,20 +3474,20 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (SETQ BBT (\HQFX80.CREATE-BRUSH-BBT BRUSHBM ,HQFX80DATA BBT)) (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) of BRUSHBM)) - (* ;; "keep Brush width and raster width in number of bits units.") + (* ;; "keep Brush width and raster width in number of bits units.") (SETQ BRUSHRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BRUSHBM)) [COND ((NULL BBT) - (* ;; "BBT is NIL if single point brush. Set the destination bitmap base.") + (* ;; "BBT is NIL if single point brush. Set the destination bitmap base.") (SETQ HEIGHTMINUS1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of DESTINATION-BITMAP))) (COND ((EQ (HQFX80DATA-OPERATION ,HQFX80DATA) 'INVERT) - (* ;; "really do invert in single brush case.") + (* ;; "really do invert in single brush case.") (SETQ OPERATION 'INVERT] (SETQ BRUSHWIDTH (fetch (BITMAP BITMAPWIDTH) of BRUSHBM)) @@ -3679,41 +3659,42 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (\HQFX80.BOUT HQFX80STREAM (CHARCODE LF]) ) -(DEFMACRO \HQFX80.EIGHT-LINES-BLANK? (BITMAP-BASE Y-COORD BITMAP-WIDTH-IN-WORDS - EIGHT-INTO-ONE-PBBT SCANLINE-INTO-WORD-PBBT WORD-BOX) +(DEFMACRO \HQFX80.EIGHT-LINES-BLANK? (BITMAP-BASE Y-COORD BITMAP-WIDTH-IN-WORDS EIGHT-INTO-ONE-PBBT + SCANLINE-INTO-WORD-PBBT WORD-BOX) - (* ;; "returns T if the next 8 lines of the bitmap are all blank. This is done by or'ing the 8 scanlines into a scratch bitmap, then or'ing the words of that scanline into a result word, and comparing that to 0. We clear the scanline and word buffers at the end.") + (* ;; "returns T if the next 8 lines of the bitmap are all blank. This is done by or'ing the 8 scanlines into a scratch bitmap, then or'ing the words of that scanline into a result word, and comparing that to 0. We clear the scanline and word buffers at the end.") `(LET ((EIGHT-INTO-ONE-PBBT ,EIGHT-INTO-ONE-PBBT) (SCANLINE-INTO-WORD-PBBT ,SCANLINE-INTO-WORD-PBBT) (WORD-BOX ,WORD-BOX) (BITMAP-WIDTH-IN-WORDS ,BITMAP-WIDTH-IN-WORDS)) - [FREPLACE (PILOTBBT PBTSOURCE) OF EIGHT-INTO-ONE-PBBT - WITH (\ADDBASE ,BITMAP-BASE (TIMES ,BITMAP-WIDTH-IN-WORDS ,Y-COORD] + [FREPLACE (PILOTBBT PBTSOURCE) OF EIGHT-INTO-ONE-PBBT WITH (\ADDBASE ,BITMAP-BASE + (TIMES + , + BITMAP-WIDTH-IN-WORDS + ,Y-COORD] (\PILOTBITBLT EIGHT-INTO-ONE-PBBT 0) (\PILOTBITBLT SCANLINE-INTO-WORD-PBBT 0) (PROG1 (EQ (\GETBASE WORD-BOX 0) 0) - (\HQFX80.CLEAR-SCANLINE EIGHT-INTO-ONE-PBBT BITMAP-WIDTH-IN-WORDS) - (\HQFX80.CLEAR-WORD-BOX WORD-BOX)))) + (\HQFX80.CLEAR-SCANLINE EIGHT-INTO-ONE-PBBT BITMAP-WIDTH-IN-WORDS) + (\HQFX80.CLEAR-WORD-BOX WORD-BOX)))) (DEFMACRO \HQFX80.BITMAP-LDB (BITMAP-BASE X Y PILOTBBT BITMAP-WIDTH-IN-WORDS) - (* ;; "point the serializing bitblt table at a new column of the bitmap. The X coord increases left to right, the Y coord increases top to bottom, and names the uppermost pixel of the column we're moving.") + (* ;; "point the serializing bitblt table at a new column of the bitmap. The X coord increases left to right, the Y coord increases top to bottom, and names the uppermost pixel of the column we're moving.") `(LET ((X ,X) (PILOTBBT ,PILOTBBT)) - [FREPLACE (PILOTBBT PBTSOURCE) OF PILOTBBT WITH - (\ADDBASE ,BITMAP-BASE - (+ (TIMES ,Y - ,BITMAP-WIDTH-IN-WORDS) - (FOLDLO X BITSPERWORD] + [FREPLACE (PILOTBBT PBTSOURCE) OF PILOTBBT WITH (\ADDBASE ,BITMAP-BASE + (+ (TIMES ,Y ,BITMAP-WIDTH-IN-WORDS) + (FOLDLO X BITSPERWORD] (FREPLACE (PILOTBBT PBTSOURCEBIT) OF PILOTBBT WITH (LOGAND 15 X)) (\PILOTBITBLT PILOTBBT 0))) (DEFMACRO \HQFX80.CLEAR-SCANLINE (SCANLINE-PILOTBBT SCANLINE-WIDTH-IN-WORDS) - (* ;; "clear out the destination of the pilotbbt the fast way - store a zero in its last word and perform an overlapping blt (which runs back to front).") + (* ;; "clear out the destination of the pilotbbt the fast way - store a zero in its last word and perform an overlapping blt (which runs back to front).") `(LET [(SCANLINE (FETCH (PILOTBBT PBTDEST) OF ,SCANLINE-PILOTBBT)) (LAST-WORD (SUB1 ,SCANLINE-WIDTH-IN-WORDS] @@ -3726,55 +3707,52 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \HQFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS) - (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to HQFX80-DEFAULT-DESTINATION") + (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to HQFX80-DEFAULT-DESTINATION") (DECLARE (GLOBALVARS HQFX80-DEFAULT-DESTINATION)) [LET ((COPIES (OR (LISTGET OPTIONS '%#COPIES) 1))) (FOR COPY FROM 1 TO COPIES DO + (* ;; "allow the user to abort it while running") - (* ;; - "allow the user to abort it while running") - - (WITH-ABORT-WINDOW ((THIS.PROCESS) - FILENAME PRINTER COPY) - (COPYFILE FILENAME - HQFX80-DEFAULT-DESTINATION - '((TYPE HQFX80]) + (WITH-ABORT-WINDOW ((THIS.PROCESS) + FILENAME PRINTER COPY) + (COPYFILE FILENAME HQFX80-DEFAULT-DESTINATION + '((TYPE HQFX80]) (CL:DEFUN MAKE-HQFX80 (FILE HQFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS) - (* ;; "turn FILE into an HQFX80 master") + (* ;; "turn FILE into an HQFX80 master") (TEXTTOIMAGEFILE FILE HQFX80FILE 'HQFX80 FONTS HEADING TABS OPTIONS)) (CL:DEFUN HQFX80FILEP (HQFX80FILE?) - (* ;; "is FILE (a filename or stream) an hqfx80 file?") + (* ;; "is FILE (a filename or stream) an hqfx80 file?") [LET [(FILE-TYPE (GETFILEINFO HQFX80FILE? 'TYPE] (IF (EQ FILE-TYPE 'HQFX80) - THEN (* ; - "if file has a type, and type=HQFX80, we win") - T - ELSE (* ; - "no filetype or filetype not HQFX80, so read the file") - (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING HQFX80FILE?) - 'INPUT - 'OLD - '(SEQUENTIAL] - - (* ;; "file looks like ESC@...") - - (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) - (+ 2 (NCHARS \HQFX80.FILE-SIGNATURE))) - (EQ (CHARCODE ESC) - (BIN STREAM)) - (EQ (CHARCODE @) - (BIN STREAM)) - (FOR CH INSTRING \HQFX80.FILE-SIGNATURE - ALWAYS (EQ CH (BIN STREAM] - (CLOSEF STREAM]) + THEN (* ; + "if file has a type, and type=HQFX80, we win") + T + ELSE (* ; + "no filetype or filetype not HQFX80, so read the file") + (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING HQFX80FILE?) + 'INPUT + 'OLD + '(SEQUENTIAL] + + (* ;; "file looks like ESC@...") + + (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) + (+ 2 (NCHARS \HQFX80.FILE-SIGNATURE))) + (EQ (CHARCODE ESC) + (BIN STREAM)) + (EQ (CHARCODE @) + (BIN STREAM)) + (FOR CH INSTRING \HQFX80.FILE-SIGNATURE + ALWAYS (EQ CH (BIN STREAM] + (CLOSEF STREAM]) @@ -3935,8 +3913,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DEFMACRO \HQFX80.INVALIDATE-CACHE (HQFX80DATA) - (* ;; - "marks the stream as needing to have its cached fields recomputed. used when font changes, etc.") + (* ;; + "marks the stream as needing to have its cached fields recomputed. used when font changes, etc.") `(PROGN (CL:SETF (HQFX80DATA-CHARSET-CACHE ,HQFX80DATA) MAX.SMALLP) @@ -3951,7 +3929,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DEFMACRO \HQFX80.GET-CACHED-CHAR-WIDTH (CHARCODE HQFX80DATA) - (* ;; "get the cached image width of CHARCODE") + (* ;; "get the cached image width of CHARCODE") `(\FGETIMAGEWIDTH (HQFX80DATA-IMAGE-WIDTHS-CACHE ,HQFX80DATA) ,CHARCODE)) @@ -3967,12 +3945,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \HQFX80.GRAPHICS-MODE (ROWS COMPRESSED? BACKING-STREAM) - (* ;; "put the FX-80 in some graphics mode") + (* ;; "put the FX-80 in some graphics mode") (BOUT BACKING-STREAM (CHARCODE ESC)) (BOUT BACKING-STREAM (CHARCODE *)) - (BOUT BACKING-STREAM (* ; - "compressed prints at 120 dpi, regular at 72") + (BOUT BACKING-STREAM (* ; + "compressed prints at 120 dpi, regular at 72") (if COMPRESSED? then 1 else 5)) @@ -4037,8 +4015,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r ) (DEFMACRO WITH-HQFX80-DATA ((VAR-NAME STREAM) - &BODY - (BODY DECLS ENV)) + &BODY + (BODY DECLS ENV)) `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM] ,@DECLS ,@BODY)) @@ -4073,24 +4051,24 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (RPAQ? HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS) -(RPAQ? HQFX80-MISSING-FONT-COERCIONS MISSINGDISPLAYFONTCOERCIONS) +(RPAQ? HQFX80-MISSING-FONT-COERCIONS DISPLAYFONTCOERCIONS) (RPAQQ FX80-PRINTCOMS ( - (* ;; "The FXPrinter emulator") + (* ;; "The FXPrinter emulator") (COMS - (* ;; "top level routine") + (* ;; "top level routine") (FUNCTIONS FX80-PRINT)) (COMS - (* ;; "how to print bitmaps") + (* ;; "how to print bitmaps") (FUNCTIONS FX80-PRINT.BITMAP) (FUNCTIONS FX80-PRINT.PRINT-BITMAP FX80-PRINT.PRINT-BITMAP-PORTRAIT FX80-PRINT.PRINT-BITMAP-LANDSCAPE)) (COMS - (* ;; "how to print files") + (* ;; "how to print files") (FUNCTIONS FX80-PRINT.FILE)))) @@ -4107,8 +4085,8 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN FX80-PRINT (THING-TO-PRINT &KEY LANDSCAPE? COMPRESS? HIGH-QUALITY?) "Prints thing-to-print on the FX-80 printer" (CL:ETYPECASE THING-TO-PRINT - ((OR WINDOW BITMAP) (FX80-PRINT.BITMAP THING-TO-PRINT LANDSCAPE? COMPRESS?)) - ((OR CL:SYMBOL STRING PATHNAME) (FX80-PRINT.FILE THING-TO-PRINT HIGH-QUALITY?))) + ((OR WINDOW BITMAP) (FX80-PRINT.BITMAP THING-TO-PRINT LANDSCAPE? COMPRESS?)) + ((OR CL:SYMBOL STRING PATHNAME) (FX80-PRINT.FILE THING-TO-PRINT HIGH-QUALITY?))) THING-TO-PRINT) @@ -4123,14 +4101,14 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (BM (BITMAPCREATE (FETCH (REGION WIDTH) OF WINDOW-REGION) (FETCH (REGION HEIGHT) OF WINDOW-REGION] (BITBLT BITMAP-OR-WINDOW NIL NIL BM) - (FX80-PRINT.BITMAP BM LANDSCAPE? COMPRESS?))) - (BITMAP (FX80-PRINT.PRINT-BITMAP BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?)))) + (FX80-PRINT.BITMAP BM LANDSCAPE? COMPRESS?))) + (BITMAP (FX80-PRINT.PRINT-BITMAP BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?)))) (CL:DEFUN FX80-PRINT.PRINT-BITMAP (BITMAP LANDSCAPE? COMPRESS?) "Print a bitmap on the FX-80, either landscape or portrait" (IF LANDSCAPE? - THEN (FX80-PRINT.PRINT-BITMAP-LANDSCAPE BITMAP COMPRESS?) - ELSE (FX80-PRINT.PRINT-BITMAP-PORTRAIT BITMAP COMPRESS?))) + THEN (FX80-PRINT.PRINT-BITMAP-LANDSCAPE BITMAP COMPRESS?) + ELSE (FX80-PRINT.PRINT-BITMAP-PORTRAIT BITMAP COMPRESS?))) (CL:DEFUN FX80-PRINT.PRINT-BITMAP-PORTRAIT (BITMAP COMPRESS?) "Prints a bitmap on the FX-80 in portrait mode" @@ -4138,12 +4116,12 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r COMPRESS?))) (WIDTH (BITMAPWIDTH BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP))) - (WITH-HQFX80-DATA (DATA HQFX80STREAM) + (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA))) (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA)) (HQFX80DATA-CLIPPINGREGION DATA))) - (* ;; "center it if possible") + (* ;; "center it if possible") (BITBLT BITMAP NIL NIL HQFX80STREAM (MAX 0 (/ (- PAGE-WIDTH WIDTH) 2)) @@ -4159,7 +4137,7 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (WIDTH (BITMAPHEIGHT BITMAP)) (HEIGHT (BITMAPWIDTH BITMAP)) (ROTATED-BITMAP (ROTATE-BITMAP BITMAP))) - (WITH-HQFX80-DATA (DATA HQFX80STREAM) + (WITH-HQFX80-DATA (DATA HQFX80STREAM) (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA))) (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA)) (HQFX80DATA-CLIPPINGREGION DATA))) @@ -4188,10 +4166,10 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (DEFMACRO WITH-ABORT-WINDOW ((PROCESS FILE-NAME PRINTER-NAME COPY#) - &BODY - (FORMS DECLS)) + &BODY + (FORMS DECLS)) "executes FORMS, allowing termination by menu selection" - `(LET [(WINDOW (\FX80.CREATE-SEND-ABORT-WINDOW ,PROCESS ,FILE-NAME ,PRINTER-NAME ,COPY#] + `(LET [(WINDOW (\FX80.CREATE-SEND-ABORT-WINDOW ,PROCESS ,FILE-NAME ,PRINTER-NAME ,COPY#] (CL:UNWIND-PROTECT (PROGN ,@DECLS (BLOCK 3000) ,@FORMS) @@ -4199,15 +4177,11 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \FX80.CREATE-SEND-ABORT-WINDOW (SENDING-PROCESS FILE-OR-STREAM PRINTER-NAME COPY#) (LET* [(DOCUMENT-TYPE-AND-NAME-STRING (IF (STREAMP FILE-OR-STREAM) - THEN (IF (FETCH (STREAM NAMEDP) OF - - FILE-OR-STREAM - ) - THEN (CONCAT "the file " (FULLNAME - - FILE-OR-STREAM - )) - ELSE "an unnamed document") + THEN (IF (FETCH (STREAM NAMEDP) OF FILE-OR-STREAM) + THEN (CONCAT "the file " (FULLNAME + FILE-OR-STREAM) + ) + ELSE "an unnamed document") ELSE FILE-OR-STREAM)) (WINDOW-WIDTH (WIDTHIFWINDOW 270)) (WINDOW-HEIGHT (HEIGHTIFWINDOW 120)) @@ -4242,61 +4216,59 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r (CL:DEFUN \ADD-TO-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE FONT-DESCRIPTION) - (* ;; "sets the DEVICE component of the FONTCLASS entry of FONTPROFILE to be FONT-DESCRIPTION.") + (* ;; "sets the DEVICE component of the FONTCLASS entry of FONTPROFILE to be FONT-DESCRIPTION.") (LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE))) (IF (NULL BUCKET) THEN (ERROR "No such fontclass as " FONTCLASS) ELSE - - (* ;; "the bucket looks like") - - (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") - - (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") - - [SELECTQ DEVICE - (DISPLAY (CL:SETF (CL:THIRD BUCKET) - FONT-DESCRIPTION)) - (PRESS (CL:SETF (CL:FOURTH BUCKET) - FONT-DESCRIPTION)) - (INTERPRESS (CL:SETF (CL:FIFTH BUCKET) - FONT-DESCRIPTION)) - (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT - INTERPRESS-FONT . A-LIST) - BUCKET - (IF (NULL A-LIST) - THEN (RPLACD (LAST BUCKET) - (LIST (LIST DEVICE FONT-DESCRIPTION))) - ELSE (PUTASSOC DEVICE (LIST FONT-DESCRIPTION) - A-LIST] - BUCKET))) + (* ;; "the bucket looks like") + + (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") + + (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") + + [SELECTQ DEVICE + (DISPLAY (CL:SETF (CL:THIRD BUCKET) + FONT-DESCRIPTION)) + (PRESS (CL:SETF (CL:FOURTH BUCKET) + FONT-DESCRIPTION)) + (INTERPRESS (CL:SETF (CL:FIFTH BUCKET) + FONT-DESCRIPTION)) + (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT + INTERPRESS-FONT . A-LIST) + BUCKET + (IF (NULL A-LIST) + THEN (RPLACD (LAST BUCKET) + (LIST (LIST DEVICE FONT-DESCRIPTION))) + ELSE (PUTASSOC DEVICE (LIST FONT-DESCRIPTION) + A-LIST] + BUCKET))) (CL:DEFUN \GET-FROM-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE) - (* ;; "Retunrs the DEVICE component of the FONTCLASS entry of FONTPROFILE.") + (* ;; "Retunrs the DEVICE component of the FONTCLASS entry of FONTPROFILE.") [LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE))) (IF (NULL BUCKET) THEN (ERROR "No such fontclass as " FONTCLASS) ELSE + (* ;; "the bucket looks like") - (* ;; "the bucket looks like") - - (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") + (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") - (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") + (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") - (SELECTQ DEVICE - (DISPLAY (CL:THIRD BUCKET)) - (PRESS (CL:FOURTH BUCKET)) - (INTERPRESS (CL:FIFTH BUCKET)) - (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT - INTERPRESS-FONT . A-LIST) - BUCKET - (IF (NULL A-LIST) - THEN NIL - ELSE (CADR (FASSOC DEVICE A-LIST]) + (SELECTQ DEVICE + (DISPLAY (CL:THIRD BUCKET)) + (PRESS (CL:FOURTH BUCKET)) + (INTERPRESS (CL:FIFTH BUCKET)) + (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT + INTERPRESS-FONT . A-LIST) + BUCKET + (IF (NULL A-LIST) + THEN NIL + ELSE (CADR (FASSOC DEVICE A-LIST]) @@ -4310,38 +4282,65 @@ Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights r ) (PUTPROPS FX-80DRIVER FILETYPE CL:COMPILE-FILE) -(PUTPROPS FX-80DRIVER COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4418 8707 (\FASTFX80.INIT 4428 . 8705)) (8790 10727 (OPENFASTFX80STREAM 8800 . 10725)) -(12632 13264 (\FASTFX80.CLOSE 12642 . 13262)) (13306 18268 (\FASTFX80.CHANGEFONT 13316 . 16540) ( -\FASTFX80.FONTCREATE 16542 . 17305) (\FASTFX80.CREATECHARSET 17307 . 18266)) (19096 22229 ( -\FASTFX80.STRINGWIDTH 19106 . 20565) (\FASTFX80.CHARWIDTH 20567 . 21204) (\FASTFX80.SUBCHARWIDTH 21206 - . 22227)) (22810 35399 (\FASTFX80.CLIPPINGREGION 22820 . 23756) (\FASTFX80.MOVETO 23758 . 24027) ( -\FASTFX80.XPOSITION 24029 . 26173) (\FASTFX80.YPOSITION 26175 . 28678) (\FASTFX80.BACKUP.PAPER 28680 - . 29447) (\FASTFX80.ADVANCE.PAPER 29449 . 30313) (\FASTFX80.NEWPAGE 30315 . 30661) (\FASTFX80.OUTCHAR - 30663 . 33017) (\FASTFX80.NEWLINE 33019 . 34075) (\FASTFX80.LINEFEED 34077 . 35114) ( -\FASTFX80.DRAWLINE 35116 . 35397)) (43264 43641 (\FASTFX80.CONVERT-TEDIT 43274 . 43639)) (43689 43991 -(\FASTFX80.BOUT 43699 . 43989)) (51112 55226 (\HQFX80.INIT 51122 . 55224)) (55309 60662 ( -OPENHQFX80STREAM 55319 . 60660)) (62320 63172 (\HQFX80.CLOSE 62330 . 63170)) (63214 81061 ( -\HQFX80.FONTCREATE 63224 . 63964) (\HQFX80.CHANGEFONT 63966 . 65474) (\HQFX80.CREATECHARSET 65476 . -74398) (\HQFX80.CHANGE-CHARSET 74400 . 76923) (\HQFX80.READ-FONT-FILE 76925 . 78694) ( -\HQFX80.SEARCH-FONTS 78696 . 81059)) (81883 83843 (\HQFX80.CHARWIDTH 81893 . 82479) ( -\HQFX80.STRINGWIDTH 82481 . 83841)) (84408 93048 (\HQFX80.CLIPPINGREGION 84418 . 85640) ( -\HQFX80.LEFTMARGIN 85642 . 86407) (\HQFX80.RIGHTMARGIN 86409 . 87138) (\HQFX80.TOPMARGIN 87140 . 87704 -) (\HQFX80.BOTTOMMARGIN 87706 . 88282) (\HQFX80.XPOSITION 88284 . 88753) (\HQFX80.YPOSITION 88755 . -89450) (\HQFX80.NEWLINE 89452 . 90869) (\HQFX80.NEWPAGE 90871 . 91300) (\HQFX80.LINEFEED 91302 . 91840 -) (\HQFX80.RESET 91842 . 92080) (\HQFX80.STARTPAGE 92082 . 93046)) (93370 121105 (\HQFX80.BITBLT 93380 - . 100624) (\HQFX80.BLTSHADE 100626 . 105377) (\HQFX80.DRAWELLIPSE 105379 . 119620) (\HQFX80.OPERATION - 119622 . 120519) (\HQFX80.DRAWPOINT 120521 . 121103)) (121106 138506 (\HQFX80.DRAWLINE 121116 . -124334) (\HQFX80.CLIP-AND-DRAW-LINE 124336 . 129547) (\HQFX80.CLIP-AND-DRAW-LINE1 129549 . 138504)) ( -138507 147502 (\HQFX80.DRAWCIRCLE 138517 . 145135) (\HQFX80.CREATE-BRUSH-BBT 145137 . 147500)) (148030 - 158201 (\HQFX80.FILLCIRCLE 148040 . 157839) (\HQFX80.DRAWARC 157841 . 158199)) (158800 187712 ( -\HQFX80.DRAWCURVE 158810 . 160703) (\HQFX80.DRAWCURVE2 160705 . 172341) (\HQFX80.DRAWCURVE3 172343 . -177985) (\HQFX80.LINEWITHBRUSH 177987 . 187710)) (187713 191170 (\HQFX80.BBTCURVEPT 187723 . 191168)) -(196235 200273 (\HQFX80.OUTCHAR 196245 . 198172) (\HQFX80.BLT-CHAR 198174 . 200271)) (200304 204819 ( -\HQFX80.DUMP-PAGE-BUFFER 200314 . 204475) (\HQFX80.ADVANCE-8-LINES 204477 . 204817)) (210073 213672 ( -\HQFX80.BITMAP-FILE 210083 . 213303) (\HQFX80.CONVERT-TEDIT 213305 . 213670)) (213720 214019 ( -\HQFX80.BOUT 213730 . 214017)) (214071 217696 (\HQFX80.FIX-LINE-LENGTH 214081 . 214882) ( -\HQFX80.FIX-FONT 214884 . 215200) (\HQFX80.FIX-Y 215202 . 217694)) (219246 222132 ( -\HQFX80.PRINTER-MODE 219256 . 222130))))) + (FILEMAP (NIL (4439 8728 (\FASTFX80.INIT 4449 . 8726)) (8811 10748 (OPENFASTFX80STREAM 8821 . 10746)) +(10750 11195 (\FASTFX80.PREAMBLE 10750 . 11195)) (11197 11950 (\FASTFX80.RESET-PRINTER 11197 . 11950)) + (11952 12475 (\FASTFX80.OUTPUT-SIGNATURE 11952 . 12475)) (12476 13108 (\FASTFX80.CLOSE 12486 . 13106) +) (13150 18112 (\FASTFX80.CHANGEFONT 13160 . 16384) (\FASTFX80.FONTCREATE 16386 . 17149) ( +\FASTFX80.CREATECHARSET 17151 . 18110)) (18114 18665 (\FASTFX80.INIT-FONT-PROFILE 18114 . 18665)) ( +18705 21838 (\FASTFX80.STRINGWIDTH 18715 . 20174) (\FASTFX80.CHARWIDTH 20176 . 20813) ( +\FASTFX80.SUBCHARWIDTH 20815 . 21836)) (21840 22336 (\FASTFX80.SPACEFACTOR 21840 . 22336)) (22419 +35008 (\FASTFX80.CLIPPINGREGION 22429 . 23365) (\FASTFX80.MOVETO 23367 . 23636) (\FASTFX80.XPOSITION +23638 . 25782) (\FASTFX80.YPOSITION 25784 . 28287) (\FASTFX80.BACKUP.PAPER 28289 . 29056) ( +\FASTFX80.ADVANCE.PAPER 29058 . 29922) (\FASTFX80.NEWPAGE 29924 . 30270) (\FASTFX80.OUTCHAR 30272 . +32626) (\FASTFX80.NEWLINE 32628 . 33684) (\FASTFX80.LINEFEED 33686 . 34723) (\FASTFX80.DRAWLINE 34725 + . 35006)) (35010 36021 (\FASTFX80.STARTPAGE 35010 . 36021)) (36023 37129 (\FASTFX80.SMART-XPOSITION +36023 . 37129)) (37131 37544 (\FASTFX80.TOPMARGIN 37131 . 37544)) (37546 37968 (\FASTFX80.BOTTOMMARGIN + 37546 . 37968)) (37970 38386 (\FASTFX80.LEFTMARGIN 37970 . 38386)) (38388 38807 ( +\FASTFX80.RIGHTMARGIN 38388 . 38807)) (38809 39023 (\FASTFX80.CUR-POS-VISIBLE? 38809 . 39023)) (39025 +39482 (\FASTFX80.HORIZONTAL 39025 . 39482)) (39514 40336 (\FASTFX80.SEND 39514 . 40336)) (40338 40550 +(MAKE-FASTFX80 40338 . 40550)) (40552 42254 (FASTFX80FILEP 40552 . 42254)) (42256 42452 ( +\FASTFX80.CANNOT-PRINT-BITMAPS 42256 . 42452)) (42453 42830 (\FASTFX80.CONVERT-TEDIT 42463 . 42828)) ( +42878 43180 (\FASTFX80.BOUT 42888 . 43178)) (43210 43637 (\FASTFX80.TRANSLATE-CHAR 43210 . 43637)) ( +43639 43876 (WITH-FASTFX80-DATA 43639 . 43876)) (50288 54402 (\HQFX80.INIT 50298 . 54400)) (54485 +59838 (OPENHQFX80STREAM 54495 . 59836)) (59840 60194 (\HQFX80.PREAMBLE 59840 . 60194)) (60196 60904 ( +\HQFX80.RESET-PRINTER 60196 . 60904)) (60906 61410 (\HQFX80.OUTPUT-SIGNATURE 60906 . 61410)) (61411 +62263 (\HQFX80.CLOSE 61421 . 62261)) (62305 80084 (\HQFX80.FONTCREATE 62315 . 63055) ( +\HQFX80.CHANGEFONT 63057 . 64497) (\HQFX80.CREATECHARSET 64499 . 73421) (\HQFX80.CHANGE-CHARSET 73423 + . 75946) (\HQFX80.READ-FONT-FILE 75948 . 77717) (\HQFX80.SEARCH-FONTS 77719 . 80082)) (80086 80631 ( +\HQFX80.INIT-FONT-PROFILE 80086 . 80631)) (80671 82631 (\HQFX80.CHARWIDTH 80681 . 81267) ( +\HQFX80.STRINGWIDTH 81269 . 82629)) (82633 83113 (\HQFX80.SPACEFACTOR 82633 . 83113)) (83196 91836 ( +\HQFX80.CLIPPINGREGION 83206 . 84428) (\HQFX80.LEFTMARGIN 84430 . 85195) (\HQFX80.RIGHTMARGIN 85197 . +85926) (\HQFX80.TOPMARGIN 85928 . 86492) (\HQFX80.BOTTOMMARGIN 86494 . 87070) (\HQFX80.XPOSITION 87072 + . 87541) (\HQFX80.YPOSITION 87543 . 88238) (\HQFX80.NEWLINE 88240 . 89657) (\HQFX80.NEWPAGE 89659 . +90088) (\HQFX80.LINEFEED 90090 . 90628) (\HQFX80.RESET 90630 . 90868) (\HQFX80.STARTPAGE 90870 . 91834 +)) (91838 92026 (\HQFX80.CUR-POS-VISIBLE? 91838 . 92026)) (92158 119893 (\HQFX80.BITBLT 92168 . 99412) + (\HQFX80.BLTSHADE 99414 . 104165) (\HQFX80.DRAWELLIPSE 104167 . 118408) (\HQFX80.OPERATION 118410 . +119307) (\HQFX80.DRAWPOINT 119309 . 119891)) (119894 137294 (\HQFX80.DRAWLINE 119904 . 123122) ( +\HQFX80.CLIP-AND-DRAW-LINE 123124 . 128335) (\HQFX80.CLIP-AND-DRAW-LINE1 128337 . 137292)) (137295 +146290 (\HQFX80.DRAWCIRCLE 137305 . 143923) (\HQFX80.CREATE-BRUSH-BBT 143925 . 146288)) (146292 146817 + (\HQFX80.DRAW-4-CIRCLE-POINTS 146292 . 146817)) (146818 156989 (\HQFX80.FILLCIRCLE 146828 . 156627) ( +\HQFX80.DRAWARC 156629 . 156987)) (156991 157556 (\HQFX80.FILL-CIRCLE-BLT 156991 . 157556)) (157588 +186500 (\HQFX80.DRAWCURVE 157598 . 159491) (\HQFX80.DRAWCURVE2 159493 . 171129) (\HQFX80.DRAWCURVE3 +171131 . 176773) (\HQFX80.LINEWITHBRUSH 176775 . 186498)) (186501 189958 (\HQFX80.BBTCURVEPT 186511 . +189956)) (191660 192811 (\HQFX80.SMOOTH-CURVE 191660 . 192811)) (192813 194697 ( +.SETUP.FOR.\HQFX80.BBTCURVEPT. 192813 . 194697)) (194742 198780 (\HQFX80.OUTCHAR 194752 . 196679) ( +\HQFX80.BLT-CHAR 196681 . 198778)) (198811 203326 (\HQFX80.DUMP-PAGE-BUFFER 198821 . 202982) ( +\HQFX80.ADVANCE-8-LINES 202984 . 203324)) (203328 204752 (\HQFX80.EIGHT-LINES-BLANK? 203328 . 204752)) + (204754 205508 (\HQFX80.BITMAP-LDB 204754 . 205508)) (205510 206000 (\HQFX80.CLEAR-SCANLINE 205510 . +206000)) (206002 206079 (\HQFX80.CLEAR-WORD-BOX 206002 . 206079)) (206081 206923 (\HQFX80.SEND 206081 + . 206923)) (206925 207128 (MAKE-HQFX80 206925 . 207128)) (207130 208512 (HQFX80FILEP 207130 . 208512) +) (208546 212145 (\HQFX80.BITMAP-FILE 208556 . 211776) (\HQFX80.CONVERT-TEDIT 211778 . 212143)) ( +212193 212492 (\HQFX80.BOUT 212203 . 212490)) (212544 216169 (\HQFX80.FIX-LINE-LENGTH 212554 . 213355) + (\HQFX80.FIX-FONT 213357 . 213673) (\HQFX80.FIX-Y 213675 . 216167)) (216171 216531 ( +\HQFX80.INVALIDATE-CACHE 216171 . 216531)) (216533 216776 (\HQFX80.INVALIDATE-FONT-CACHE 216533 . +216776)) (216778 216988 (\HQFX80.GET-CACHED-CHAR-WIDTH 216778 . 216988)) (216990 217132 ( +\HQFX80.GET-CHARACTER-OFFSET 216990 . 217132)) (217171 217722 (\HQFX80.GRAPHICS-MODE 217171 . 217722)) + (217723 220609 (\HQFX80.PRINTER-MODE 217733 . 220607)) (220611 220842 (WITH-HQFX80-DATA 220611 . +220842)) (222170 222530 (FX80-PRINT 222170 . 222530)) (222570 223191 (FX80-PRINT.BITMAP 222570 . +223191)) (223193 223490 (FX80-PRINT.PRINT-BITMAP 223193 . 223490)) (223492 224601 ( +FX80-PRINT.PRINT-BITMAP-PORTRAIT 223492 . 224601)) (224603 225722 (FX80-PRINT.PRINT-BITMAP-LANDSCAPE +224603 . 225722)) (225760 226002 (FX80-PRINT.FILE 225760 . 226002)) (226036 226472 (WITH-ABORT-WINDOW +226036 . 226472)) (226474 229154 (\FX80.CREATE-SEND-ABORT-WINDOW 226474 . 229154)) (229156 230619 ( +\ADD-TO-FONTPROFILE 229156 . 230619)) (230621 231679 (\GET-FROM-FONTPROFILE 230621 . 231679))))) STOP diff --git a/library/FX-80DRIVER.LCOM b/library/FX-80DRIVER.LCOM index 10ea2e830..b364e9535 100644 Binary files a/library/FX-80DRIVER.LCOM and b/library/FX-80DRIVER.LCOM differ diff --git a/library/IMAGEOBJ b/library/IMAGEOBJ index 2348610cf..457956e1d 100644 --- a/library/IMAGEOBJ +++ b/library/IMAGEOBJ @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 7-Dec-2024 19:44:25" {WMEDLEY}IMAGEOBJ.;4 34381 +(FILECREATED " 9-Jun-2025 20:33:49" {WMEDLEY}IMAGEOBJ.;5 32874 :EDIT-BY rmk - :CHANGES-TO (FNS GET.OBJ.FROM.USER) + :CHANGES-TO (VARS IMAGEOBJCOMS) - :PREVIOUS-DATE " 7-Jul-2024 21:04:16" {WMEDLEY}IMAGEOBJ.;3) + :PREVIOUS-DATE " 7-Dec-2024 19:44:25" {WMEDLEY}IMAGEOBJ.;4) (PRETTYCOMPRINT IMAGEOBJCOMS) @@ -15,8 +15,7 @@ ((COMS (* ;; "Bit-map image objects") - (FNS BITMAPTEDITOBJ COERCETOBITMAP WINDOWTITLEFONT \PRINTBINARYBITMAP \READBINARYBITMAP - ) + (FNS BITMAPTEDITOBJ COERCETOBITMAP WINDOWTITLEFONT) (* ;; "fns for the bitmap tedit object.") @@ -117,42 +116,6 @@ (* reset type of function that changes  the title font) (DSPFONT FONT WindowTitleDisplayStream))) - -(\PRINTBINARYBITMAP - (LAMBDA (BITMAP STREAM) (* rrb "23-Jul-84 15:16") - - (* * prints the representation of a bitmap onto STREAM in a form that can be - read back by \READBINARYBITMAP.) - - (PROG ((STREAM (GETSTREAM STREAM 'OUTPUT)) - BMH) - (OR (BITMAPP BITMAP) - (\ILLEGAL.ARG BITMAP)) - (\WOUT STREAM (BITMAPWIDTH BITMAP)) - (\WOUT STREAM (SETQ BMH (BITMAPHEIGHT BITMAP))) - (\WOUT STREAM (BITSPERPIXEL BITMAP)) - (\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP) - 0 - (ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP) - BMH BYTESPERWORD)) - (RETURN BITMAP)))) - -(\READBINARYBITMAP - (LAMBDA (STREAM) (* rrb "23-Jul-84 15:17") - - (* * reads a bitmap printed on STREAM by \PRINTBINARYBITMAP.) - - (SETQ STREAM (GETSTREAM STREAM 'INPUT)) - (PROG ((BMW (\WIN STREAM)) - (BMH (\WIN STREAM)) - (BPP (\WIN STREAM)) - BITMAP) - (SETQ BITMAP (BITMAPCREATE BMW BMH BPP)) - (\BINS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP) - 0 - (ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP) - BMH BYTESPERWORD)) - (RETURN BITMAP)))) ) @@ -770,12 +733,11 @@ (FILESLOAD EDITBITMAP) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2975 7471 (BITMAPTEDITOBJ 2985 . 3628) (COERCETOBITMAP 3630 . 5674) (WINDOWTITLEFONT -5676 . 6023) (\PRINTBINARYBITMAP 6025 . 6816) (\READBINARYBITMAP 6818 . 7469)) (7522 23640 ( -BMOBJ.BUTTONEVENTINFN 7532 . 12078) (BMOBJ.COPYFN 12080 . 12706) (BMOBJ.DISPLAYFN 12708 . 16437) ( -BMOBJ.IMAGEBOXFN 16439 . 18854) (BMOBJ.PUTFN 18856 . 19788) (BMOBJ.INIT 19790 . 20829) (BMOBJ.GETFN5 -20831 . 21421) (BMOBJ.CREATE.MENU 21423 . 23638)) (23730 27014 (SCALED.BITMAP.GETFN 23740 . 24166) ( -BMOBJ.GETFN 24168 . 24703) (BMOBJ.GETFN2 24705 . 25190) (BMOBJ.GETFN3 25192 . 25980) (BMOBJ.GETFN4 -25982 . 27012)) (28949 34281 (GET.OBJ.FROM.USER 28959 . 30925) (BITMAPOBJ.SNAPW 30927 . 32053) ( -PROMPTFOREVALED 32055 . 34279))))) + (FILEMAP (NIL (2914 5964 (BITMAPTEDITOBJ 2924 . 3567) (COERCETOBITMAP 3569 . 5613) (WINDOWTITLEFONT +5615 . 5962)) (6015 22133 (BMOBJ.BUTTONEVENTINFN 6025 . 10571) (BMOBJ.COPYFN 10573 . 11199) ( +BMOBJ.DISPLAYFN 11201 . 14930) (BMOBJ.IMAGEBOXFN 14932 . 17347) (BMOBJ.PUTFN 17349 . 18281) ( +BMOBJ.INIT 18283 . 19322) (BMOBJ.GETFN5 19324 . 19914) (BMOBJ.CREATE.MENU 19916 . 22131)) (22223 25507 + (SCALED.BITMAP.GETFN 22233 . 22659) (BMOBJ.GETFN 22661 . 23196) (BMOBJ.GETFN2 23198 . 23683) ( +BMOBJ.GETFN3 23685 . 24473) (BMOBJ.GETFN4 24475 . 25505)) (27442 32774 (GET.OBJ.FROM.USER 27452 . +29418) (BITMAPOBJ.SNAPW 29420 . 30546) (PROMPTFOREVALED 30548 . 32772))))) STOP diff --git a/library/IMAGEOBJ.LCOM b/library/IMAGEOBJ.LCOM index 3ab45fd98..7d00568cb 100644 Binary files a/library/IMAGEOBJ.LCOM and b/library/IMAGEOBJ.LCOM differ diff --git a/lispusers/MULTI-ALIST b/library/MULTI-ALIST similarity index 72% rename from lispusers/MULTI-ALIST rename to library/MULTI-ALIST index f07050de4..4bed1e973 100644 --- a/lispusers/MULTI-ALIST +++ b/library/MULTI-ALIST @@ -1,20 +1,20 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Jan-2025 19:34:13" {WMEDLEY}MULTI-ALIST.;15 12223 +(FILECREATED "10-Jul-2025 12:37:33" {WMEDLEY}MULTI-ALIST.;19 12851 :EDIT-BY rmk - :CHANGES-TO (FNS MAPMULTI) + :CHANGES-TO (VARS MULTI-ALISTCOMS) + (MACROS PUSHMULTI PUTMULTI PUSHMULTI-NEW FPUSHMULTI FPUSHMULTI-NEW) - :PREVIOUS-DATE "25-Jan-2025 15:04:13" {WMEDLEY}MULTI-ALIST.;14) + :PREVIOUS-DATE " 8-Jul-2025 12:54:37" {WMEDLEY}MULTI-ALIST.;18) (PRETTYCOMPRINT MULTI-ALISTCOMS) (RPAQQ MULTI-ALISTCOMS - ((MACROS GETMULTI PUTMULTI PUTMULTI-D PUTMULTI-NEW PUTMULTI-COUNT PUTMULTI-SUM REMOVEMULTI - REMOVEMULTIALL) - (MACROS FGETMULTI FPUTMULTI FPUTMULTI-D FPUTMULTI-NEW) + ((MACROS GETMULTI PUSHMULTI PUTMULTI PUSHMULTI-NEW CHANGEMULTI REMOVEMULTI REMOVEMULTIALL) + (MACROS FGETMULTI FPUSHMULTI FPUTMULTI FPUSHMULTI-NEW FCHANGEMULTI) (FNS MAPMULTI MAPMULTI1 COLLECTMULTI) (FNS GETMULTI.EXPAND PUTMULTI.EXPAND REMOVEMULTI.EXPAND) (MACROS ADDTOMULTI) @@ -24,16 +24,13 @@ (PUTPROPS GETMULTI MACRO (ARGS (GETMULTI.EXPAND 'SASSOC ARGS))) -(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS))) +(PUTPROPS PUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS))) -(PUTPROPS PUTMULTI-D MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL T))) +(PUTPROPS PUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL T))) -(PUTPROPS PUTMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS))) +(PUTPROPS PUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS))) -(PUTPROPS PUTMULTI-COUNT MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC (APPEND ARGS '(1)) - NIL NIL T))) - -(PUTPROPS PUTMULTI-SUM MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL NIL T))) +(PUTPROPS CHANGEMULTI MACRO (ARGS (PUTMULTI.EXPAND 'SASSOC ARGS NIL NIL T))) (PUTPROPS REMOVEMULTI MACRO (ARGS (REMOVEMULTI.EXPAND ARGS))) @@ -43,11 +40,13 @@ (PUTPROPS FGETMULTI MACRO (ARGS (GETMULTI.EXPAND 'FASSOC ARGS))) +(PUTPROPS FPUSHMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS))) + (PUTPROPS FPUTMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS))) -(PUTPROPS FPUTMULTI-D MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS NIL T))) +(PUTPROPS FPUSHMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS))) -(PUTPROPS FPUTMULTI-NEW MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS))) +(PUTPROPS FCHANGEMULTI MACRO (ARGS (PUTMULTI.EXPAND 'FASSOC ARGS NIL NIL T))) ) (DEFINEQ @@ -95,7 +94,8 @@ (DEFINEQ (GETMULTI.EXPAND - [LAMBDA (ASSOCFN ARGS) (* ; "Edited 16-Jan-2025 10:27 by rmk") + [LAMBDA (ASSOCFN ARGS) (* ; "Edited 14-Jun-2025 09:47 by rmk") + (* ; "Edited 16-Jan-2025 10:27 by rmk") (* ; "Edited 19-Jul-2020 00:38 by rmk:") (* ; "Edited 22-Mar-2020 13:21 by rmk:") (* ; "Edited 27-Feb-2020 13:44 by rmk:") @@ -114,7 +114,9 @@ ELSE (CAR ARGS]) (PUTMULTI.EXPAND - [LAMBDA (ASSOCFN ARGS ALLOWREPEATS SINGLEVALUE SUM) (* ; "Edited 23-Jan-2025 09:40 by rmk") + [LAMBDA (ASSOCFN ARGS ALLOWREPEATS SINGLEVALUE CHANGE) (* ; "Edited 8-Jul-2025 12:52 by rmk") + (* ; "Edited 14-Jun-2025 09:44 by rmk") + (* ; "Edited 23-Jan-2025 09:40 by rmk") (* ; "Edited 16-Jan-2025 10:18 by rmk") (* ; "Edited 17-Aug-2020 14:09 by rmk:") @@ -122,7 +124,7 @@ (* ;; "If SINGLEVALUE, new value smashes out old") - (* ;; "For SUM, the last argument is the increment to be added to the current value, and the incremented value is returned for PUTMULTISUM and for GETMULT") + (* ;; "For CHANGE, the last argument is the change expression to be evaluated, with the current value denoted by the atom DATUM") (* ;; "") @@ -131,34 +133,41 @@ (CL:MULTIPLE-VALUE-BIND (TEMPVARS VALFORMS STOREVARS STOREFORM ACCESSFORM) (CL:GET-SETF-METHOD (CAR ARGS)) - (CL:IF (CDR ARGS) - `(LET* - ,(FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF)) - (DECLARE (LOCALVARS ,@TEMPVARS)) - (LET - ($$ARG1$$ $$ARG2$$) - (DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$)) - ,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL) - JOIN - (IF (AND SUM (NULL (CDDR ATAIL))) - THEN (POP ATAIL) - `[(CL:UNLESS ,HEAD (RPLACD $$ARG1$$ 0)) - (SETQ $$ARG2$$ (ADD ,HEAD ,(CAR ATAIL] - ELSE - (PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL)) - ,(IF (CDDR ATAIL) - THEN `[SETQ $$ARG1$$ (OR (,ASSOCFN $$ARG2$$ ,HEAD) - (CAR (CL:PUSH (CONS $$ARG2$$) - ,HEAD] - ELSEIF ALLOWREPEATS - THEN `(push ,HEAD $$ARG2$$) - ELSEIF SINGLEVALUE - THEN `(RPLACD $$ARG2$$) - ELSE `(OR (MEMBER $$ARG2$$ ,HEAD) - (push ,HEAD $$ARG2$$] - (SETQ HEAD '(CDR $$ARG1$$)))] - $$ARG2$$)) - (CAR ARGS))]) + (if (CDR ARGS) + then + (LET + ((VALBINDINGS (FOR VF IN VALFORMS AS TV IN TEMPVARS COLLECT (LIST TV VF))) + EXPANSION) + (SETQ EXPANSION + `(LET + ($$ARG1$$ $$ARG2$$) + (DECLARE (LOCALVARS $$ARG1$$ $$ARG2$$)) + ,@[FOR ATAIL (HEAD _ ACCESSFORM) ON ARGS WHILE (CDR ATAIL) + JOIN + (IF (AND CHANGE (NULL (CDDR ATAIL))) + THEN (POP ATAIL) + [AND NIL `((CL:UNLESS ,HEAD (RPLACD $$ARG1$$ 0)) + (SETQ $$ARG2$$ (ADD ,HEAD ,(CAR ATAIL] + `[(SETQ $$ARG2$$ ,(SUBST HEAD 'DATUM (CAR ATAIL] + ELSE + (PROG1 `[(SETQ $$ARG2$$ ,(CADR ATAIL)) + ,(IF (CDDR ATAIL) + THEN `[SETQ $$ARG1$$ (OR (,ASSOCFN $$ARG2$$ ,HEAD) + (CAR (CL:PUSH (CONS $$ARG2$$) + ,HEAD] + ELSEIF ALLOWREPEATS + THEN `(push ,HEAD $$ARG2$$) + ELSEIF SINGLEVALUE + THEN `(CL:SETF ,HEAD $$ARG2$$) + ELSE `(OR (MEMBER $$ARG2$$ ,HEAD) + (push ,HEAD $$ARG2$$] + (SETQ HEAD '(CDR $$ARG1$$)))] + $$ARG2$$)) + (CL:IF VALBINDINGS + `(LET* ,VALBINDINGS (DECLARE (LOCALVARS ,@TEMPVARS)) + ,EXPANSION) + EXPANSION)) + else (CAR ARGS]) (REMOVEMULTI.EXPAND [LAMBDA (ARGS ALLFLAG) (* ; "Edited 16-Jan-2025 10:34 by rmk") @@ -233,7 +242,7 @@ (LOCALVARS . T) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1837 4449 (MAPMULTI 1847 . 2915) (MAPMULTI1 2917 . 3974) (COLLECTMULTI 3976 . 4447)) ( -4450 10311 (GETMULTI.EXPAND 4460 . 5581) (PUTMULTI.EXPAND 5583 . 7995) (REMOVEMULTI.EXPAND 7997 . -10309)) (11461 12146 (ADDTOMULTI1 11471 . 12144))))) + (FILEMAP (NIL (1845 4457 (MAPMULTI 1855 . 2923) (MAPMULTI1 2925 . 3982) (COLLECTMULTI 3984 . 4455)) ( +4458 10939 (GETMULTI.EXPAND 4468 . 5698) (PUTMULTI.EXPAND 5700 . 8623) (REMOVEMULTI.EXPAND 8625 . +10937)) (12089 12774 (ADDTOMULTI1 12099 . 12772))))) STOP diff --git a/lispusers/MULTI-ALIST.LCOM b/library/MULTI-ALIST.LCOM similarity index 59% rename from lispusers/MULTI-ALIST.LCOM rename to library/MULTI-ALIST.LCOM index d4cd756ca..6f75b9953 100644 Binary files a/lispusers/MULTI-ALIST.LCOM and b/library/MULTI-ALIST.LCOM differ diff --git a/lispusers/MULTI-ALIST.TEDIT b/library/MULTI-ALIST.TEDIT similarity index 53% rename from lispusers/MULTI-ALIST.TEDIT rename to library/MULTI-ALIST.TEDIT index fa2ba6f57..a613b5d09 100644 Binary files a/lispusers/MULTI-ALIST.TEDIT and b/library/MULTI-ALIST.TEDIT differ diff --git a/library/POSTSCRIPTSTREAM b/library/POSTSCRIPTSTREAM index ab44fd309..3b96c4ae3 100644 --- a/library/POSTSCRIPTSTREAM +++ b/library/POSTSCRIPTSTREAM @@ -1,16 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Jun-2025 16:12:21" {DSK}matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;5 258146 +(FILECREATED "14-Jul-2025 22:21:34" {WMEDLEY}POSTSCRIPTSTREAM.;24 258986 - :EDIT-BY "mth" + :EDIT-BY rmk - :CHANGES-TO (FNS \BLTSHADE.PSC \PSC.COLOR.TO.RGB \DRAWLINE.PSC \DRAWARC.PSC POSTSCRIPTSEND - \TERPRI.PSC POSTSCRIPT.PUTCOMMAND POSTSCRIPT.PUTRGBCOLOR \DSPCOLOR.PSC - \DRAWCIRCLE.PSC \DRAWELLIPSE.PSC \DRAWPOINT.PSC \DRAWPOLYGON.PSC - \FILLCIRCLE.PSC \FILLPOLYGON.PSC POSTSCRIPT.TEDIT \BITBLT.PSC) + :CHANGES-TO (FNS \DSPFONT.PSC) - :PREVIOUS-DATE "28-Apr-2025 00:17:24" -{DSK}matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;1) + :PREVIOUS-DATE "16-Jun-2025 00:04:32" {WMEDLEY}POSTSCRIPTSTREAM.;23) (PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS) @@ -46,7 +42,7 @@ (FNS PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.COERCEFILE PSCFONTFROMCACHE.SPELLFILE PSCFONTFROMCACHE.COERCEFILE PSCFONT.WRITEFONT READ-AFM-FILE CONVERT-AFM-FILES POSTSCRIPT.GETFONTID POSTSCRIPT.FONTCREATE \POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS - POSTSCRIPT.FONTSAVAILABLE) + POSTSCRIPT.FONTSAVAILABLE POSTSCRIPT.FONTEXISTS?) (COMS (* ;; "Until macro in FONT is exported") @@ -175,7 +171,8 @@ (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) - (CREATECHARSET \CREATECHARSET.PSC] + (CREATECHARSET \CREATECHARSET.PSC) + (FONTEXISTS? POSTSCRIPT.FONTEXISTS?] (INITVARS (POSTSCRIPT.PAGETYPE 'LETTER)) (* ;; "NIL means initial clipping is same as paper size. Don't know why the other regions were specified--rmk") @@ -619,11 +616,12 @@ PF]) (PSCFONT.SPELLFILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Oct-93 22:15 by rmk:") - (* ; "Edited 5-Oct-92 15:23 by jds") + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 15-Jun-2025 23:31 by rmk") + (* ; "Edited 5-Oct-93 22:15 by rmk:") + (* ; "Edited 5-Oct-92 15:23 by jds") - (* ;; - "Find the font file for a postscript font. Does the display-name conversion as well, for DOS.") + (* ;; + "Find the font file for a postscript font. Does the display-name conversion as well, for DOS.") (CL:WHEN POSTSCRIPTFONTDIRECTORIES (\FINDFONTFILE (OR (CDR (FASSOC FAMILY POSTSCRIPT.FONT.ALIST)) @@ -883,43 +881,44 @@ FONTID]) (POSTSCRIPT.FONTCREATE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 29-Oct-93 16:39 by rmk:") - (* ; "Edited 3-Feb-93 17:22 by jds") + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 15-Jun-2025 23:40 by rmk") + (* ; "Edited 29-Oct-93 16:39 by rmk:") + (* ; "Edited 3-Feb-93 17:22 by jds") (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS PSCWIDTHSBLOCK WIDTHSBLOCK FD FACECHANGED (WEIGHT (CAR FACE)) (SLOPE (CADR FACE)) (EXPANSION (CADDR FACE))) - (* ;; - "Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.") + (* ;; + "Ignore rotations, it is **MUCH** easier to rotate the Postscript stream user space coordinates.") [COND [(EQ SIZE 1) - (* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info") + (* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, a 1 point font is presumed to be the unit size Postscript font info") (COND ((SETQ PSCFD (PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) - (* ;; "Check in-core cache for exact match first") + (* ;; "Check in-core cache for exact match first") (SETQ FACECHANGED NIL)) ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) - (* ;; "Check file for exact match next") + (* ;; "Check file for exact match next") (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ FACECHANGED NIL)) - ((SETQ PSCFD (PSCFONTFROMCACHE.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION - ROTATION DEVICE)) + ((SETQ PSCFD (PSCFONTFROMCACHE.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION + DEVICE)) - (* ;; "Then check cache for coerced match") + (* ;; "Then check cache for coerced match") (SETQ FACECHANGED T)) ((SETQ FULLNAME (PSCFONT.COERCEFILE FAMILY SIZE WEIGHT SLOPE EXPANSION ROTATION DEVICE)) - (* ;; "Check file for coerced match") + (* ;; "Check file for coerced match") (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ FACECHANGED T))) @@ -930,15 +929,14 @@ 0.1))) (COND (FACECHANGED (replace (PSCFONT IL-FONTID) of PSCFD - with (POSTSCRIPT.GETFONTID (fetch (PSCFONT - FID) - of PSCFD) - WEIGHT SLOPE EXPANSION] + with (POSTSCRIPT.GETFONTID (fetch (PSCFONT FID) + of PSCFD) + WEIGHT SLOPE EXPANSION] ((SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T)) (SETQ PSCFD (LISTGET (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) of UNITFONT) 'PSCFONT)) - (* ;; "Scale the ASCENT and DESCENT") + (* ;; "Scale the ASCENT and DESCENT") (SETQ ASCENT (FIXR (TIMES SIZE (fetch (PSCFONT ASCENT) of PSCFD) 0.1))) @@ -946,20 +944,20 @@ 0.1))) (SETQ SCALEFONTP T)) (T - (* ;; "Here for fonts that only come in specific sizes. Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.") + (* ;; "Here for fonts that only come in specific sizes. Their info is not scaled like built-in Postscript fonts, it is already correct for this pointsize.") (COND ([SETQ PSCFD (COND ((PSCFONTFROMCACHE.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) - ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION - DEVICE)) + ((SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE + )) (PSCFONT.READFONT FULLNAME] (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD)) (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD)) (SETQ SCALEFONTP NIL] (COND (PSCFD - (* ;; "Set up the Charset descriptions and Widths vectors for character set 0:") + (* ;; "Set up the Charset descriptions and Widths vectors for character set 0:") (SETQ FD (create FONTDESCRIPTOR @@ -977,37 +975,35 @@ (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD)) [COND [SCALEFONTP (for CH from 0 to 255 - do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE - (ELT FIXPWIDTHS - CH) - 0.1] - (T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH - (ELT FIXPWIDTHS CH] + do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE (ELT FIXPWIDTHS + CH) + 0.1] + (T (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (ELT FIXPWIDTHS CH] (SETQ PSCWIDTHSBLOCK (\CREATECSINFOELEMENT)) - (* ;; "PSCWIDTHSBLOCK preserves the scaled widths from the original postscript metrics, not the NS mapping of them, which goes into WIDTHSBLOCK.") + (* ;; "PSCWIDTHSBLOCK preserves the scaled widths from the original postscript metrics, not the NS mapping of them, which goes into WIDTHSBLOCK.") - (for CH from 0 to 255 do (\FSETWIDTH PSCWIDTHSBLOCK CH - (\FGETWIDTH WIDTHSBLOCK CH))) + (for CH from 0 to 255 do (\FSETWIDTH PSCWIDTHSBLOCK CH (\FGETWIDTH WIDTHSBLOCK CH) + )) [LET [(TMP (COND (FULLNAME (\FONTINFOFROMFILENAME FULLNAME DEVICE)) (UNITFONT (fetch FONTDEVICESPEC of UNITFONT] - (* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got") + (* ;; "If face got coerced (possibly in recursive call for unit font) then set FONTDEVICESPEC to describe what we really got") (COND ((AND TMP (NEQ FAMILY (CAR TMP))) (replace FONTDEVICESPEC of FD with (LIST (CAR TMP) - SIZE - (COPY FACE) - 0 DEVICE] - [LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION - DEVICE)) - (DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD - ROTATION DEVICE))) + SIZE + (COPY FACE) + 0 DEVICE] + [LET ((SYMWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'SYMBOL FD ROTATION DEVICE) + ) + (DINGWIDTHS (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 'ZAPFDINGBATS FD ROTATION + DEVICE))) - (* ;; - "Now run thru the mapping table, filling in the new font from whatever source is specified:") + (* ;; + "Now run thru the mapping table, filling in the new font from whatever source is specified:") [MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE) @@ -1015,13 +1011,12 @@ (KIND CODE2 BASECHAR) MAPPING - (* ;; - "Depending on what kind of item it is, process it:") + (* ;; "Depending on what kind of item it is, process it:") (SELECTQ KIND (NIL - (* ;; - "Translating an NS character to a PSC char in CS 0.") + (* ;; + "Translating an NS character to a PSC char in CS 0.") (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK @@ -1036,8 +1031,8 @@ (\CHAR8CODE CODE2]) (FUNCTION - (* ;; - "This is fake and only works for the fractions. Need a better case.") + (* ;; + "This is fake and only works for the fractions. Need a better case.") [\FSETCHARWIDTH FD CODE @@ -1046,25 +1041,25 @@ (\FGETWIDTH PSCWIDTHSBLOCK (CHARCODE 1]) - (ACCENT (* ; - "CODE2 is the rendering character but width comes from width of basechar") + (ACCENT (* ; + "CODE2 is the rendering character but width comes from width of basechar") (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK BASECHAR))) (ACCENTPAIR - (* ;; "CODE2 and BASECHAR are overprinted, width is taken from CODE2 (the real character), basechar is the accent") + (* ;; "CODE2 and BASECHAR are overprinted, width is taken from CODE2 (the real character), basechar is the accent") (\FSETCHARWIDTH FD CODE (\FGETWIDTH PSCWIDTHSBLOCK CODE2))) (PROGN - (* ;; "Skip APPLY*'s on this pass, waiting until normal characters get set up, so that widths of other NS characters are available. Also skip anything else") + (* ;; "Skip APPLY*'s on this pass, waiting until normal characters get set up, so that widths of other NS characters are available. Also skip anything else") NIL] - (* ;; "Now do APPLY*'s. MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)") + (* ;; "Now do APPLY*'s. MAPPING is of the form ('APPLY* DATA PRINTFN WIDTHFN). WIDTHFN gets applied to FD and DATA (coerced by INITFN)") (MAPHASH *POSTSCRIPT-NS-HASH* (FUNCTION (LAMBDA (MAPPING CODE) (CL:WHEN (EQ (CAR MAPPING) @@ -1173,6 +1168,22 @@ NF)) else (LIST FD))) else FONTSAVAILABLE]) + +(POSTSCRIPT.FONTEXISTS? + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 16-Jun-2025 00:04 by rmk") + (* ; "Edited 29-Oct-93 16:39 by rmk:") + (* ; "Edited 3-Feb-93 17:22 by jds") + + (* ;; "Non-NIL if a postscript font with these parameters can be constructed.") + + (* ;; "Since a 1 point font is ridiculously small, and it is the standard size for Postscript font info, size 1 is presumed to be the base for all postscript fonts.") + + (LET ((WEIGHT (fetch (FONTFACE WEIGHT) of FACE)) + (SLOPE (fetch (FONTFACE SLOPE) of FACE)) + (EXPANSION (fetch (FONTFACE EXPANSION) of FACE))) + (OR (PSCFONT.SPELLFILE FAMILY 1 FACE ROTATION DEVICE) + (PSCFONTFROMCACHE.COERCEFILE FAMILY 1 WEIGHT SLOPE EXPANSION ROTATION DEVICE) + (PSCFONT.COERCEFILE FAMILY 1 WEIGHT SLOPE EXPANSION ROTATION DEVICE]) ) @@ -2681,7 +2692,8 @@ CURRENT]) (\DSPFONT.PSC - [LAMBDA (STREAM FONT) (* ; + [LAMBDA (STREAM FONT) (* ; "Edited 14-Jul-2025 22:21 by rmk") + (* ;  "Edited 26-May-93 01:06 by sybalsky:mv:envos") (* ; "Edited 11-May-93 02:11 by jds") (* ; "Edited 19-Jan-93 17:17 by jds") @@ -2694,7 +2706,7 @@ (OLDFONT (fetch (\POSTSCRIPTDATA POSTSCRIPTFONT) of IMAGEDATA)) NEWFONT FONTID) (COND - ((AND FONT (SETQ NEWFONT (OR (\COERCEFONTDESC FONT STREAM) + ((AND FONT (SETQ NEWFONT (OR (FONTCREATE FONT NIL NIL NIL STREAM T) (FONTCOPY OLDFONT FONT))) (type? FONTDESCRIPTOR NEWFONT) (NEQ NEWFONT OLDFONT)) @@ -4357,7 +4369,8 @@ (ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) - (CREATECHARSET \CREATECHARSET.PSC))) + (CREATECHARSET \CREATECHARSET.PSC) + (FONTEXISTS? POSTSCRIPT.FONTEXISTS?))) (RPAQ? POSTSCRIPT.PAGETYPE 'LETTER) @@ -4401,38 +4414,39 @@ (ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (22736 33232 (POSTSCRIPT.INIT 22746 . 29838) (POSTSCRIPT.PUTRGBCOLOR 29840 . 30862) ( -\PSC.COLOR.TO.RGB 30864 . 33230)) (34218 69002 (PSCFONT.READFONT 34228 . 36136) (PSCFONT.SPELLFILE -36138 . 36716) (PSCFONT.COERCEFILE 36718 . 38290) (PSCFONTFROMCACHE.SPELLFILE 38292 . 39277) ( -PSCFONTFROMCACHE.COERCEFILE 39279 . 40931) (PSCFONT.WRITEFONT 40933 . 41948) (READ-AFM-FILE 41950 . -47821) (CONVERT-AFM-FILES 47823 . 49035) (POSTSCRIPT.GETFONTID 49037 . 50432) (POSTSCRIPT.FONTCREATE -50434 . 62833) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 62835 . 65232) (POSTSCRIPT.FONTSAVAILABLE 65234 - . 69000)) (69557 78842 (OPENPOSTSCRIPTSTREAM 69567 . 78508) (CLOSEPOSTSCRIPTSTREAM 78510 . 78840)) ( -78887 84941 (POSTSCRIPT.HARDCOPYW 78897 . 82004) (POSTSCRIPT.TEDIT 82006 . 82490) (POSTSCRIPT.TEXT -82492 . 82783) (POSTSCRIPTFILEP 82785 . 83892) (MAKEEPSFILE 83894 . 84939)) (84942 128516 ( -POSTSCRIPT.BITMAPSCALE 84952 . 87408) (POSTSCRIPT.CLOSESTRING 87410 . 87963) (POSTSCRIPT.ENDPAGE 87965 - . 88856) (POSTSCRIPT.OUTSTR 88858 . 90075) (POSTSCRIPT.PUTBITMAPBYTES 90077 . 98548) ( -POSTSCRIPT.PUTCOMMAND 98550 . 99539) (POSTSCRIPT.SET-FAKE-LANDSCAPE 99541 . 104061) ( -POSTSCRIPT.SHOWACCUM 104063 . 106218) (POSTSCRIPT.STARTPAGE 106220 . 108752) (\POSTSCRIPTTAB 108754 . -109551) (\PS.BOUTFIXP 109553 . 110833) (\PS.SCALEHACK 110835 . 113478) (\PS.SCALEREGION 113480 . -114040) (\SCALEDBITBLT.PSC 114042 . 118352) (\SETPOS.PSC 118354 . 118835) (\SETXFORM.PSC 118837 . -121421) (\STRINGWIDTH.PSC 121423 . 121896) (\SWITCHFONTS.PSC 121898 . 127390) (\TERPRI.PSC 127392 . -128514)) (128551 182631 (\BITBLT.PSC 128561 . 129113) (\BLTSHADE.PSC 129115 . 133776) (\CHARWIDTH.PSC -133778 . 134285) (\CREATECHARSET.PSC 134287 . 135985) (\DRAWARC.PSC 135987 . 138365) (\DRAWCIRCLE.PSC -138367 . 140618) (\DRAWCURVE.PSC 140620 . 144464) (\DRAWELLIPSE.PSC 144466 . 146830) (\DRAWLINE.PSC -146832 . 149572) (\DRAWPOINT.PSC 149574 . 150150) (\DRAWPOLYGON.PSC 150152 . 153281) ( -\DSPBOTTOMMARGIN.PSC 153283 . 153970) (\DSPCLIPPINGREGION.PSC 153972 . 155347) (\DSPCOLOR.PSC 155349 - . 156280) (\DSPFONT.PSC 156282 . 159801) (\DSPLEFTMARGIN.PSC 159803 . 160489) (\DSPLINEFEED.PSC -160491 . 161081) (\DSPPUSHSTATE.PSC 161083 . 162543) (\DSPPOPSTATE.PSC 162545 . 166030) (\DSPRESET.PSC - 166032 . 166697) (\DSPRIGHTMARGIN.PSC 166699 . 167388) (\DSPROTATE.PSC 167390 . 168389) ( -\DSPSCALE.PSC 168391 . 169343) (\DSPSCALE2.PSC 169345 . 170185) (\DSPSPACEFACTOR.PSC 170187 . 171108) -(\DSPTOPMARGIN.PSC 171110 . 171681) (\DSPTRANSLATE.PSC 171683 . 173714) (\DSPXPOSITION.PSC 173716 . -174280) (\DSPYPOSITION.PSC 174282 . 174873) (\FILLCIRCLE.PSC 174875 . 177100) (\FILLPOLYGON.PSC 177102 - . 180339) (\FIXLINELENGTH.PSC 180341 . 181660) (\MOVETO.PSC 181662 . 182432) (\NEWPAGE.PSC 182434 . -182629)) (182687 204710 (\POSTSCRIPT.CHANGECHARSET 182697 . 183434) (\POSTSCRIPT.OUTCHARFN 183436 . -195564) (\POSTSCRIPT.PRINTSLUG 195566 . 197290) (\POSTSCRIPT.SPECIALOUTCHARFN 197292 . 199643) ( -\UPDATE.PSC 199645 . 200891) (\POSTSCRIPT.ACCENTFN 200893 . 201835) (\POSTSCRIPT.ACCENTPAIR 201837 . -204708)) (204808 206453 (\PSC.SPACEDISP 204818 . 205097) (\PSC.SPACEWID 205099 . 205718) (\PSC.SYMBOLS - 205720 . 206451)) (206562 209553 (\POSTSCRIPT.NSHASH 206572 . 209551)) (254327 255033 (POSTSCRIPTSEND - 254337 . 255031))))) + (FILEMAP (NIL (22458 32954 (POSTSCRIPT.INIT 22468 . 29560) (POSTSCRIPT.PUTRGBCOLOR 29562 . 30584) ( +\PSC.COLOR.TO.RGB 30586 . 32952)) (33940 69653 (PSCFONT.READFONT 33950 . 35858) (PSCFONT.SPELLFILE +35860 . 36557) (PSCFONT.COERCEFILE 36559 . 38131) (PSCFONTFROMCACHE.SPELLFILE 38133 . 39118) ( +PSCFONTFROMCACHE.COERCEFILE 39120 . 40772) (PSCFONT.WRITEFONT 40774 . 41789) (READ-AFM-FILE 41791 . +47662) (CONVERT-AFM-FILES 47664 . 48876) (POSTSCRIPT.GETFONTID 48878 . 50273) (POSTSCRIPT.FONTCREATE +50275 . 62428) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 62430 . 64827) (POSTSCRIPT.FONTSAVAILABLE 64829 + . 68595) (POSTSCRIPT.FONTEXISTS? 68597 . 69651)) (70208 79493 (OPENPOSTSCRIPTSTREAM 70218 . 79159) ( +CLOSEPOSTSCRIPTSTREAM 79161 . 79491)) (79538 85592 (POSTSCRIPT.HARDCOPYW 79548 . 82655) ( +POSTSCRIPT.TEDIT 82657 . 83141) (POSTSCRIPT.TEXT 83143 . 83434) (POSTSCRIPTFILEP 83436 . 84543) ( +MAKEEPSFILE 84545 . 85590)) (85593 129167 (POSTSCRIPT.BITMAPSCALE 85603 . 88059) ( +POSTSCRIPT.CLOSESTRING 88061 . 88614) (POSTSCRIPT.ENDPAGE 88616 . 89507) (POSTSCRIPT.OUTSTR 89509 . +90726) (POSTSCRIPT.PUTBITMAPBYTES 90728 . 99199) (POSTSCRIPT.PUTCOMMAND 99201 . 100190) ( +POSTSCRIPT.SET-FAKE-LANDSCAPE 100192 . 104712) (POSTSCRIPT.SHOWACCUM 104714 . 106869) ( +POSTSCRIPT.STARTPAGE 106871 . 109403) (\POSTSCRIPTTAB 109405 . 110202) (\PS.BOUTFIXP 110204 . 111484) +(\PS.SCALEHACK 111486 . 114129) (\PS.SCALEREGION 114131 . 114691) (\SCALEDBITBLT.PSC 114693 . 119003) +(\SETPOS.PSC 119005 . 119486) (\SETXFORM.PSC 119488 . 122072) (\STRINGWIDTH.PSC 122074 . 122547) ( +\SWITCHFONTS.PSC 122549 . 128041) (\TERPRI.PSC 128043 . 129165)) (129202 183400 (\BITBLT.PSC 129212 . +129764) (\BLTSHADE.PSC 129766 . 134427) (\CHARWIDTH.PSC 134429 . 134936) (\CREATECHARSET.PSC 134938 . +136636) (\DRAWARC.PSC 136638 . 139016) (\DRAWCIRCLE.PSC 139018 . 141269) (\DRAWCURVE.PSC 141271 . +145115) (\DRAWELLIPSE.PSC 145117 . 147481) (\DRAWLINE.PSC 147483 . 150223) (\DRAWPOINT.PSC 150225 . +150801) (\DRAWPOLYGON.PSC 150803 . 153932) (\DSPBOTTOMMARGIN.PSC 153934 . 154621) ( +\DSPCLIPPINGREGION.PSC 154623 . 155998) (\DSPCOLOR.PSC 156000 . 156931) (\DSPFONT.PSC 156933 . 160570) + (\DSPLEFTMARGIN.PSC 160572 . 161258) (\DSPLINEFEED.PSC 161260 . 161850) (\DSPPUSHSTATE.PSC 161852 . +163312) (\DSPPOPSTATE.PSC 163314 . 166799) (\DSPRESET.PSC 166801 . 167466) (\DSPRIGHTMARGIN.PSC 167468 + . 168157) (\DSPROTATE.PSC 168159 . 169158) (\DSPSCALE.PSC 169160 . 170112) (\DSPSCALE2.PSC 170114 . +170954) (\DSPSPACEFACTOR.PSC 170956 . 171877) (\DSPTOPMARGIN.PSC 171879 . 172450) (\DSPTRANSLATE.PSC +172452 . 174483) (\DSPXPOSITION.PSC 174485 . 175049) (\DSPYPOSITION.PSC 175051 . 175642) ( +\FILLCIRCLE.PSC 175644 . 177869) (\FILLPOLYGON.PSC 177871 . 181108) (\FIXLINELENGTH.PSC 181110 . +182429) (\MOVETO.PSC 182431 . 183201) (\NEWPAGE.PSC 183203 . 183398)) (183456 205479 ( +\POSTSCRIPT.CHANGECHARSET 183466 . 184203) (\POSTSCRIPT.OUTCHARFN 184205 . 196333) ( +\POSTSCRIPT.PRINTSLUG 196335 . 198059) (\POSTSCRIPT.SPECIALOUTCHARFN 198061 . 200412) (\UPDATE.PSC +200414 . 201660) (\POSTSCRIPT.ACCENTFN 201662 . 202604) (\POSTSCRIPT.ACCENTPAIR 202606 . 205477)) ( +205577 207222 (\PSC.SPACEDISP 205587 . 205866) (\PSC.SPACEWID 205868 . 206487) (\PSC.SYMBOLS 206489 . +207220)) (207331 210322 (\POSTSCRIPT.NSHASH 207341 . 210320)) (255096 255802 (POSTSCRIPTSEND 255106 . +255800))))) STOP diff --git a/library/POSTSCRIPTSTREAM.LCOM b/library/POSTSCRIPTSTREAM.LCOM index 6466f5df9..b96019038 100644 Binary files a/library/POSTSCRIPTSTREAM.LCOM and b/library/POSTSCRIPTSTREAM.LCOM differ diff --git a/library/PRESS b/library/PRESS index 2dad0227a..1dc8916cf 100644 --- a/library/PRESS +++ b/library/PRESS @@ -1,21 +1,17 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "10-Apr-2023 07:15:37" {DSK}larry>il>medley>library>PRESS.;2 452576Q +(FILECREATED "14-Jul-2025 22:58:49" {WMEDLEY}PRESS.;4 453237Q - :EDIT-BY "lmm" + :EDIT-BY rmk - :CHANGES-TO (VARS PRESSCOMS) + :CHANGES-TO (FNS \DSPFONT.PRESS) - :PREVIOUS-DATE " 5-Feb-2021 22:18:06" {DSK}larry>il>medley>library>PRESS.;1) + :PREVIOUS-DATE " 5-Jul-2025 18:52:40" {WMEDLEY}PRESS.;3) -(* ; " -Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. -") - (PRETTYCOMPRINT PRESSCOMS) -(RPAQQ PRESSCOMS +(RPAQQ PRESSCOMS [ (* ;;; "PRESS printing support module") @@ -1321,46 +1317,44 @@ Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. (freplace PRClippingRegion of PRDATA with REGION))])]) (\DSPFONT.PRESS - [LAMBDA (PRSTREAM FONT) (* ; "Edited 12-Jun-90 10:40 by mitani") + [LAMBDA (PRSTREAM FONT) (* ; "Edited 14-Jul-2025 22:58 by rmk") + (* ; "Edited 5-Jul-2025 18:49 by rmk") - (* * The DSPFONT method for PRESS-type image streams -- - change the stream's current font to FONT) +(* ;;; "The DSPFONT method for PRESS-type image streams -- change the stream's current font to FONT") + + (* * The DSPFONT method for PRESS-type image streams -- + change the stream's current font to FONT) (PROG ((PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM)) CSINFO OLDFONT FDENTRY) (SETQ OLDFONT (ffetch PRFONT of PRDATA)) (COND ([OR (NULL FONT) - (EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT 'PRESS T) + (EQ OLDFONT (SETQ FONT (OR (FONTCREATE FONT NIL NIL NIL 'PRESS T) (FONTCOPY OLDFONT FONT] - - (* If no new font was specified, or it's the same font, don't bother with it.) - + (* ; + "If no new font was specified, or it's the same font, don't bother with it.") (RETURN OLDFONT))) (SHOW.PRESS PRSTREAM) - (SETQ CSINFO (\GETCHARSETINFO 0 FONT T)) (* Since PRESS only uses charset 0 - for now....) + (SETQ CSINFO (\GETCHARSETINFO 0 FONT T)) (* ; + "Since PRESS only uses charset 0 for now....") (SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM FONT)) (COND ((NEQ (ffetch FONTSET# of FDENTRY) (ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA))) - (* Swtich font sets) + (* ; "Swtich font sets") (\ENTITYEND.PRESS PRSTREAM) (\ENTITYSTART.PRESS PRSTREAM))) (freplace PRCURRFDE of PRDATA with FDENTRY) (freplace PRFONT of PRDATA with FONT) (\BOUT (ffetch ELSTREAM of PRDATA) (LOGOR FontCode (ffetch FONT# of FDENTRY))) - (freplace PRWIDTHSCACHE of PRDATA with (fetch (CHARSETINFO WIDTHS) - OF CSINFO)) + (freplace PRWIDTHSCACHE of PRDATA with (fetch (CHARSETINFO WIDTHS) OF CSINFO)) [\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA) - (\FGETWIDTH (ffetch PRWIDTHSCACHE - of PRDATA) - (CHARCODE SPACE] - [freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS - MicasPerPoint - )) - (FONTPROP FONT 'HEIGHT] + (\FGETWIDTH (ffetch PRWIDTHSCACHE of PRDATA) + (CHARCODE SPACE] + [freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS MicasPerPoint)) + (FONTPROP FONT 'HEIGHT] (\FIXLINELENGTH.PRESS PRSTREAM) (RETURN OLDFONT]) @@ -2417,51 +2411,55 @@ Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE -(DATATYPE PRESSDATA (PRHEADING (* The string to be printed atop each - page.) - PRHEADINGFONT (* Font to print the heading in) - PRXPOS (* Current X position) - PRYPOS (* Current Y position) - PRFONT (* Current font) - PRCURRFDE PRESSFONTDIR PRWIDTHSCACHE PRCOLOR PRLINEFEED PRPAGESTATE - PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME (PRLEFT WORD) - (* Page left margin) - (PRBOTTOM WORD) (* Page bottom margin) - (PRRIGHT WORD) (* Page right margin) - (PRTOP WORD) (* Page top margin) - (PRPAGENUM WORD) (* Current Page number) +(DATATYPE PRESSDATA (PRHEADING (* ; + "The string to be printed atop each page.") + PRHEADINGFONT (* ; "Font to print the heading in") + PRXPOS (* ; "Current X position") + PRYPOS (* ; "Current Y position") + PRFONT (* ; "Current font") + PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER + (* ; + "Widths table for the current logical character set") + ) + PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME + (PRLEFT WORD) (* ; "Page left margin") + (PRBOTTOM WORD) (* ; "Page bottom margin") + (PRRIGHT WORD) (* ; "Page right margin") + (PRTOP WORD) (* ; "Page top margin") + (PRPAGENUM WORD) (* ; "Current Page number") (PRNEXTFONT# BYTE) (PRMAXFONTSET BYTE) (PRPARTSTART INTEGER) (DLSTARTBYTE INTEGER) (ELSTARTBYTE INTEGER) (STARTCHARBYTE INTEGER) - (VECMOVINGRIGHT FLAG) (* If we're drawing a curve with - vector fonts, are we moving to the - right?) + (VECMOVINGRIGHT FLAG) (* ; + "If we're drawing a curve with vector fonts, are we moving to the right?") (VECWASDISPLAYING FLAG) - (* Used during curve/line clipping to remember whether we were on-screen or not, - so we know when to force a SETXY.) + (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.") - VECSEGCHARS (* Cache for vector characters while - we're moving to the left.) - VECCURX (* Current X position within vector - code, in Dover spots) - VECCURY (* Current Y position with vector - code, in Dover spots) + VECSEGCHARS (* ; + "Cache for vector characters while we're moving to the left.") + VECCURX (* ; + "Current X position within vector code, in Dover spots") + VECCURY (* ; + "Current Y position with vector code, in Dover spots") PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG) - (* Says whether we have been printing - characters inside the clipping region) + (* ; + "Says whether we have been printing characters inside the clipping region") PRClippingRegion - (* The edges of the paper, as far as PRESS is concerned. - Used to protect SPRUCE users who get killed when the image goes off-paper) + (* ;; "The edges of the paper, as far as PRESS is concerned. Used to protect SPRUCE users who get killed when the image goes off-paper") - ) - PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0 (* We assume that the origin is - translated to the bottom-left of the - page region) + PRLOGICALFONT (* ; "Current logical font") + PRLOGICALCHARSET (* ; + "Current logical character set, whose info is cached. NIL if cache is invalid") + (PRTRANSLATIONCACHE POINTER (* ; + "Translation table for the current logical character set") + )) + PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0 (* ; + "We assume that the origin is translated to the bottom-left of the page region") PRClippingRegion _ (create REGION LEFT _ SPRUCEPAPERLEFTMICAS BOTTOM _ SPRUCEPAPERBOTTOMMICAS @@ -2492,7 +2490,8 @@ Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. (/DECLAREDATATYPE 'PRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP - FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER) + FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER + ) '((PRESSDATA 0 POINTER) (PRESSDATA 2 POINTER) (PRESSDATA 4 POINTER) @@ -2527,14 +2526,18 @@ Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. (PRESSDATA 50 POINTER) (PRESSDATA 52 POINTER) (PRESSDATA 52 (FLAGBITS . 0)) - (PRESSDATA 54 POINTER)) - '56) + (PRESSDATA 54 POINTER) + (PRESSDATA 56 POINTER) + (PRESSDATA 58 POINTER) + (PRESSDATA 60 POINTER)) + '62) ) (/DECLAREDATATYPE 'PRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP - FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER) + FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER + ) '((PRESSDATA 0 POINTER) (PRESSDATA 2 POINTER) (PRESSDATA 4 POINTER) @@ -2569,8 +2572,11 @@ Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. (PRESSDATA 50 POINTER) (PRESSDATA 52 POINTER) (PRESSDATA 52 (FLAGBITS . 0)) - (PRESSDATA 54 POINTER)) - '56) + (PRESSDATA 54 POINTER) + (PRESSDATA 56 POINTER) + (PRESSDATA 58 POINTER) + (PRESSDATA 60 POINTER)) + '62) (RPAQ? DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 24765)) @@ -2597,7 +2603,7 @@ Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. -(RPAQQ PRESSOPS +(RPAQQ PRESSOPS (SetX SetY ShowCharacters ShowCharactersShortCode SkipCharactersShortCode ShowCharactersAndSkipCode SetSpaceXShortCode SetSpaceYShortCode FontCode SkipControlBytesImmediateCode AlternativeCode OnlyOnCopyCode SetXCode SetYCode @@ -2722,60 +2728,59 @@ Copyright (c) 1981-1987, 1990, 1993, 2021 by Venue & Xerox Corporation. (CREATECHARSET \CREATECHARSET.PRESS) (FONTSAVAILABLE \SEARCHPRESSFONTS))) -(ADDTOVAR PRINTERTYPES ((PRESS SPRUCE PENGUIN DOVER) - (CANPRINT (PRESS)) - (STATUS PUP.PRINTER.STATUS) - (PROPERTIES PUP.PRINTER.PROPERTIES) - (SEND EFTP) - (BITMAPSCALE NIL) - (BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))) - ((FULLPRESS RAVEN) +(ADDTOVAR PRINTERTYPES + ((PRESS SPRUCE PENGUIN DOVER) + (CANPRINT (PRESS)) + (STATUS PUP.PRINTER.STATUS) + (PROPERTIES PUP.PRINTER.PROPERTIES) + (SEND EFTP) + (BITMAPSCALE NIL) + (BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))) + ((FULLPRESS RAVEN) (* ;  "same as PRESS but can scale bitmaps") - (CANPRINT (PRESS)) - (STATUS TRUE) - (PROPERTIES NILL) - (SEND EFTP) - (BITMAPSCALE PRESS.BITMAPSCALE) - (BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) - -(ADDTOVAR PRINTFILETYPES [PRESS (TEST PRESSFILEP) - (EXTENSION (PRESS)) - (CONVERSION (TEXT MAKEPRESS TEDIT - (LAMBDA (FILE PFILE FONTS HEADING) - (SETQ FILE (OPENTEXTSTREAM FILE)) - (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL - NIL 'PRESS) - (CLOSEF? FILE) - PFILE]) -(PUTPROPS PRESS COPYRIGHT ("Venue & Xerox Corporation" 3675Q 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3706Q - 3711Q 3745Q)) + (CANPRINT (PRESS)) + (STATUS TRUE) + (PROPERTIES NILL) + (SEND EFTP) + (BITMAPSCALE PRESS.BITMAPSCALE) + (BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) + +(ADDTOVAR PRINTFILETYPES + [PRESS (TEST PRESSFILEP) + (EXTENSION (PRESS)) + (CONVERSION (TEXT MAKEPRESS TEDIT (LAMBDA (FILE PFILE FONTS HEADING) + (SETQ FILE (OPENTEXTSTREAM FILE)) + (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL + NIL 'PRESS) + (CLOSEF? FILE) + PFILE]) (DECLARE%: DONTCOPY - (FILEMAP (NIL (15752Q 72731Q (\SEARCHPRESSFONTS 15764Q . 17721Q) (\GETPRESSFONTNAMES 17723Q . 26561Q) -(\PRESSFAMILYCODELST 26563Q . 30505Q) (\DECODEPRESSFACEBYTE 30507Q . 33276Q) (\CREATEPRESSFONT 33300Q - . 35545Q) (\CREATECHARSET.PRESS 35547Q . 72727Q)) (73366Q 127171Q (PRESSBITMAP 73400Q . 103002Q) ( -FULLPRESSBITMAP 103004Q . 111016Q) (SHOWREGION 111020Q . 112362Q) (SHOWPRESSBITMAPREGION 112364Q . -113026Q) (PRESSWINDOW 113030Q . 117167Q) (\WRITEPRESSBITMAP 117171Q . 127167Q)) (127267Q 157142Q ( -\BCPLSOUT.PRESS 127301Q . 130256Q) (\PAGEPAD.PRESS 130260Q . 131515Q) (\ENTITYEND.PRESS 131517Q . -137013Q) (\PARTEND.PRESS 137015Q . 141402Q) (\ENTITYSTART.PRESS 141404Q . 145015Q) (SETX.PRESS 145017Q - . 146652Q) (SETXY.PRESS 146654Q . 151656Q) (SETY.PRESS 151660Q . 153260Q) (SHOW.PRESS 153262Q . -157140Q)) (157224Q 274041Q (OPENPRSTREAM 157236Q . 164365Q) (\BITBLT.PRESS 164367Q . 167001Q) ( -\BLTSHADE.PRESS 167003Q . 170436Q) (\SCALEDBITBLT.PRESS 170440Q . 173064Q) (\BITMAPSIZE.PRESS 173066Q - . 174026Q) (\CHARWIDTH.PRESS 174030Q . 176077Q) (\CLOSEF.PRESS 176101Q . 206070Q) (\DRAWLINE.PRESS -206072Q . 207430Q) (\ENDPAGE.PRESS 207432Q . 210702Q) (NEWLINE.PRESS 210704Q . 212315Q) (NEWPAGE.PRESS - 212317Q . 212611Q) (SETUPFONTS.PRESS 212613Q . 216344Q) (\DEFINEFONT.PRESS 216346Q . 220470Q) ( -\DSPBOTTOMMARGIN.PRESS 220472Q . 221266Q) (\DSPCLIPPINGREGION.PRESS 221270Q . 222662Q) (\DSPFONT.PRESS - 222664Q . 227656Q) (\DSPLEFTMARGIN.PRESS 227660Q . 230540Q) (\DSPLINEFEED.PRESS 230542Q . 232052Q) ( -\DSPRIGHTMARGIN.PRESS 232054Q . 232737Q) (\DSPSPACEFACTOR.PRESS 232741Q . 234345Q) ( -\DSPTOPMARGIN.PRESS 234347Q . 235132Q) (\DSPXPOSITION.PRESS 235134Q . 235652Q) (\DSPYPOSITION.PRESS -235654Q . 236372Q) (\FIXLINELENGTH.PRESS 236374Q . 240471Q) (\OUTCHARFN.PRESS 240473Q . 247527Q) ( -\SETSPACE.PRESS 247531Q . 251025Q) (\STARTPAGE.PRESS 251027Q . 255370Q) (\STRINGWIDTH.PRESS 255372Q . -270750Q) (SHOWRECTANGLE.PRESS 270752Q . 271473Q) (\PRESS.CONVERT.NSCHARACTER 271475Q . 274037Q)) ( -274101Q 405143Q (\ENDVECRUN 274113Q . 303731Q) (\VECENCODE 303733Q . 304762Q) (\VECPUT 304764Q . -314412Q) (\VECSKIP 314414Q . 315147Q) (\VECFONTINIT 315151Q . 322274Q) (\DRAWCIRCLE.PRESS 322276Q . -324601Q) (\DRAWARC.PRESS 324603Q . 325374Q) (\DRAWCURVE.PRESS 325376Q . 333334Q) ( -\DRAWCURVE.PRESS.LINE 333336Q . 342203Q) (\DRAWELLIPSE.PRESS 342205Q . 345764Q) (\GETBRUSHFONT.PRESS -345766Q . 347670Q) (\PRESSCURVE2 347672Q . 405141Q)) (410775Q 415621Q (\PRESSINIT 411007Q . 415617Q)) -(443570Q 446657Q (MAKEPRESS 443602Q . 444106Q) (PRESSFILEP 444110Q . 445665Q) (PRESS.BITMAPSCALE -445667Q . 446655Q))))) + (FILEMAP (NIL (15566Q 72545Q (\SEARCHPRESSFONTS 15600Q . 17535Q) (\GETPRESSFONTNAMES 17537Q . 26375Q) +(\PRESSFAMILYCODELST 26377Q . 30321Q) (\DECODEPRESSFACEBYTE 30323Q . 33112Q) (\CREATEPRESSFONT 33114Q + . 35361Q) (\CREATECHARSET.PRESS 35363Q . 72543Q)) (73202Q 127005Q (PRESSBITMAP 73214Q . 102616Q) ( +FULLPRESSBITMAP 102620Q . 110632Q) (SHOWREGION 110634Q . 112176Q) (SHOWPRESSBITMAPREGION 112200Q . +112642Q) (PRESSWINDOW 112644Q . 117003Q) (\WRITEPRESSBITMAP 117005Q . 127003Q)) (127103Q 156756Q ( +\BCPLSOUT.PRESS 127115Q . 130072Q) (\PAGEPAD.PRESS 130074Q . 131331Q) (\ENTITYEND.PRESS 131333Q . +136627Q) (\PARTEND.PRESS 136631Q . 141216Q) (\ENTITYSTART.PRESS 141220Q . 144631Q) (SETX.PRESS 144633Q + . 146466Q) (SETXY.PRESS 146470Q . 151472Q) (SETY.PRESS 151474Q . 153074Q) (SHOW.PRESS 153076Q . +156754Q)) (157040Q 273644Q (OPENPRSTREAM 157052Q . 164201Q) (\BITBLT.PRESS 164203Q . 166615Q) ( +\BLTSHADE.PRESS 166617Q . 170252Q) (\SCALEDBITBLT.PRESS 170254Q . 172700Q) (\BITMAPSIZE.PRESS 172702Q + . 173642Q) (\CHARWIDTH.PRESS 173644Q . 175713Q) (\CLOSEF.PRESS 175715Q . 205704Q) (\DRAWLINE.PRESS +205706Q . 207244Q) (\ENDPAGE.PRESS 207246Q . 210516Q) (NEWLINE.PRESS 210520Q . 212131Q) (NEWPAGE.PRESS + 212133Q . 212425Q) (SETUPFONTS.PRESS 212427Q . 216160Q) (\DEFINEFONT.PRESS 216162Q . 220304Q) ( +\DSPBOTTOMMARGIN.PRESS 220306Q . 221102Q) (\DSPCLIPPINGREGION.PRESS 221104Q . 222476Q) (\DSPFONT.PRESS + 222500Q . 227461Q) (\DSPLEFTMARGIN.PRESS 227463Q . 230343Q) (\DSPLINEFEED.PRESS 230345Q . 231655Q) ( +\DSPRIGHTMARGIN.PRESS 231657Q . 232542Q) (\DSPSPACEFACTOR.PRESS 232544Q . 234150Q) ( +\DSPTOPMARGIN.PRESS 234152Q . 234735Q) (\DSPXPOSITION.PRESS 234737Q . 235455Q) (\DSPYPOSITION.PRESS +235457Q . 236175Q) (\FIXLINELENGTH.PRESS 236177Q . 240274Q) (\OUTCHARFN.PRESS 240276Q . 247332Q) ( +\SETSPACE.PRESS 247334Q . 250630Q) (\STARTPAGE.PRESS 250632Q . 255173Q) (\STRINGWIDTH.PRESS 255175Q . +270553Q) (SHOWRECTANGLE.PRESS 270555Q . 271276Q) (\PRESS.CONVERT.NSCHARACTER 271300Q . 273642Q)) ( +273704Q 404746Q (\ENDVECRUN 273716Q . 303534Q) (\VECENCODE 303536Q . 304565Q) (\VECPUT 304567Q . +314215Q) (\VECSKIP 314217Q . 314752Q) (\VECFONTINIT 314754Q . 322077Q) (\DRAWCIRCLE.PRESS 322101Q . +324404Q) (\DRAWARC.PRESS 324406Q . 325177Q) (\DRAWCURVE.PRESS 325201Q . 333137Q) ( +\DRAWCURVE.PRESS.LINE 333141Q . 342006Q) (\DRAWELLIPSE.PRESS 342010Q . 345567Q) (\GETBRUSHFONT.PRESS +345571Q . 347473Q) (\PRESSCURVE2 347475Q . 404744Q)) (410600Q 415424Q (\PRESSINIT 410612Q . 415422Q)) +(444757Q 450046Q (MAKEPRESS 444771Q . 445275Q) (PRESSFILEP 445277Q . 447054Q) (PRESS.BITMAPSCALE +447056Q . 450044Q))))) STOP diff --git a/library/PRESS.LCOM b/library/PRESS.LCOM index 511b8ded8..5887ff08a 100644 Binary files a/library/PRESS.LCOM and b/library/PRESS.LCOM differ diff --git a/library/tedit/TEDIT-LOOKS b/library/tedit/TEDIT-LOOKS index 8cb88535a..512bee84a 100644 --- a/library/tedit/TEDIT-LOOKS +++ b/library/tedit/TEDIT-LOOKS @@ -1,13 +1,16 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "13-Jul-2025 19:39:57" {WMEDLEY}TEDIT>TEDIT-LOOKS.;426 158882 +(FILECREATED " 1-Aug-2025 13:43:51"  +{DSK}kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-LOOKS.;443 160489 :EDIT-BY rmk - :CHANGES-TO (VARS TEDIT-LOOKSCOMS) - (FNS \TEDIT.GET.INSERT.CHARLOOKS TEDIT.CARETLOOKS \TEDIT.CARETPIECE) + :CHANGES-TO (RECORDS CHARLOOKS) + (FNS \TEDIT.EQCLOOKS \TEDIT.TRANSLATE.ASCIICHARS \TEDIT.UNIQUIFY.ALL + \TEDIT.FLUSH.UNUSED.LOOKS TEDIT.GET.LOOKS TEDIT.SUBLOOKS TEDIT.FINDLOOKS + \TEDIT.CHANGE.CHARLOOKS) - :PREVIOUS-DATE "24-Apr-2025 23:47:54" {WMEDLEY}TEDIT>TEDIT-LOOKS.;425) + :PREVIOUS-DATE "29-Jul-2025 09:30:33" {WMEDLEY}tedit>TEDIT-LOOKS.;435) (PRETTYCOMPRINT TEDIT-LOOKSCOMS) @@ -29,21 +32,23 @@ (* ;;  "Added by yabu.fx, for SUNLOADUP without DWIM. Not sure any of these are needed/used.") - (FNS \TEDIT.CREATE.DEFAULT.FMTSPEC \TEDIT.CREATE.FACE.MENU \TEDIT.CREATE.SIZE.MENU)) - [INITVARS (TEDIT.DEFAULT.FOLIO) - (TEDIT.KNOWN.FONTS '((Classic 'CLASSIC) + (FNS \TEDIT.CREATE.FACE.MENU \TEDIT.CREATE.SIZE.MENU)) + (INITVARS (TEDIT.DEFAULT.FOLIO) + [TEDIT.KNOWN.FONTS '((Classic 'CLASSIC) (Modern 'MODERN) (Terminal 'TERMINAL) (Titan 'TITAN) (Gacha 'GACHA) (Helvetica 'HELVETICA) (Times% Roman 'TIMESROMAN] - (VARS TEDIT.CHARLOOKS.FEATURES (TEDIT.DEFAULT.FMTSPEC (\TEDIT.CREATE.DEFAULT.FMTSPEC)) - (TEDIT.FACE.MENU (\TEDIT.CREATE.FACE.MENU)) + (TEDIT.DEFAULT.TAB 36) + (TEDIT.DEFAULT.PARALOOKS `(QUAD LEFT LEFTMARGIN 0 1STLEFTMARGIN 0 RIGHTMARGIN 0 + PARALEADING 0 POSTPARALEADING 0 DEFAULTTAB 36)) + (TEDIT.DEFAULT.FMTSPEC TEDIT.DEFAULT.PARALOOKS)) + (VARS TEDIT.CHARLOOKS.FEATURES (TEDIT.FACE.MENU (\TEDIT.CREATE.FACE.MENU)) (TEDIT.SIZE.MENU (\TEDIT.CREATE.SIZE.MENU))) (FNS \TEDIT.CHARLOOKS.FEATURE.CHECK) - (GLOBALVARS TEDIT.CHARLOOKS.FEATURES TEDIT.KNOWN.FONTS TEDIT.FACE.MENU TEDIT.SIZE.MENU - TEDIT.DEFAULT.FMTSPEC) + (GLOBALVARS TEDIT.CHARLOOKS.FEATURES TEDIT.KNOWN.FONTS TEDIT.FACE.MENU TEDIT.SIZE.MENU) (ADDVARS (FONTVARS (TEDIT.PROMPT.FONT DEFAULTFONT) (TEDIT.ICON.FONT MENUFONT))) (COMS (* ; "Character looks functions") @@ -130,8 +135,8 @@  "Spaces are treated as nonbreaking spaces") CLSTYLE (* ;  "The style to be used in marking these characters; overridden by the other fields") - CLUSERINFO (* ; - "Any information that an outsider wants to include") + CLPROPS (* ; + "Was CLUSERINFO:Any information that an outsider wants to include") CLLEADER (* ;  "For creating dotted and other kinds of leader") CLRULES @@ -148,8 +153,9 @@ CLOFFSET _ 0 CLCOLOR _ 'BLACK (INIT (DEFPRINT 'CHARLOOKS (FUNCTION \TEDIT.CHARLOOKS.DEFPRINT ))) - (ACCESSFNS (CLNAME (fetch (CHARLOOKS CLFONTUNPARSE) of DATUM) - (replace (CHARLOOKS CLFONTUNPARSE) of DATUM with NEWVALUE)))) + (ASSOCRECORD CLPROPS (CLUSERINFO CLCHARENCODING)) + [ACCESSFNS ((CLNAME (fetch (CHARLOOKS CLFONTUNPARSE) of DATUM) + (replace (CHARLOOKS CLFONTUNPARSE) of DATUM with NEWVALUE]) (DATATYPE PARALOOKS ( (* ;; "Describe the paragraph formatting for a paragraph in a TEdit document.") @@ -452,21 +458,6 @@ (DEFINEQ -(\TEDIT.CREATE.DEFAULT.FMTSPEC - [LAMBDA NIL (* ; "Edited 8-Feb-2025 22:05 by rmk") - (* ; "Edited 4-Aug-2024 17:13 by rmk") - (* ; "Edited 28-Jul-2024 12:57 by rmk") - (* ; "Edited 24-Aug-2023 23:31 by rmk") - (create PARALOOKS - QUAD _ 'LEFT - 1STLEFTMAR _ 0 - LEFTMAR _ 0 - RIGHTMAR _ 0 - LEADBEFORE _ 0 - LEADAFTER _ 0 - LINELEAD _ 0 - FMTDEFAULTTAB _ DEFAULTTAB]) - (\TEDIT.CREATE.FACE.MENU [LAMBDA NIL (create MENU @@ -494,14 +485,19 @@ (Helvetica 'HELVETICA) (Times% Roman 'TIMESROMAN))) +(RPAQ? TEDIT.DEFAULT.TAB 36) + +(RPAQ? TEDIT.DEFAULT.PARALOOKS `(QUAD LEFT LEFTMARGIN 0 1STLEFTMARGIN 0 RIGHTMARGIN 0 PARALEADING 0 + POSTPARALEADING 0 DEFAULTTAB 36)) + +(RPAQ? TEDIT.DEFAULT.FMTSPEC TEDIT.DEFAULT.PARALOOKS) + (RPAQQ TEDIT.CHARLOOKS.FEATURES (DEVICE FAMILY SIZE FACE ITALIC WEIGHT SLOPE BOLD EXPANSION FONT INVERTED INVISIBLE OFFSET OFFSETINCREMENT OVERLINE PROTECTED SELECTPOINT SELAFTER SELBEFORE SIZEINCREMENT SMALLCAPS STRIKEOUT STYLE SUBSCRIPT SUPERSCRIPT UNBREAKABLE UNDERLINE USERINFO OFFSETTYPE COLOR)) -(RPAQ TEDIT.DEFAULT.FMTSPEC (\TEDIT.CREATE.DEFAULT.FMTSPEC)) - (RPAQ TEDIT.FACE.MENU (\TEDIT.CREATE.FACE.MENU)) (RPAQ TEDIT.SIZE.MENU (\TEDIT.CREATE.SIZE.MENU)) @@ -535,8 +531,7 @@ ) (DECLARE%: DOEVAL@COMPILE DONTCOPY -(GLOBALVARS TEDIT.CHARLOOKS.FEATURES TEDIT.KNOWN.FONTS TEDIT.FACE.MENU TEDIT.SIZE.MENU - TEDIT.DEFAULT.FMTSPEC) +(GLOBALVARS TEDIT.CHARLOOKS.FEATURES TEDIT.KNOWN.FONTS TEDIT.FACE.MENU TEDIT.SIZE.MENU) ) (ADDTOVAR FONTVARS (TEDIT.PROMPT.FONT DEFAULTFONT) @@ -576,7 +571,9 @@ CLNAME _ (FONTUNPARSE FONT]) (\TEDIT.EQCLOOKS - [LAMBDA (CLOOK1 CLOOK2) (* ; "Edited 15-Apr-2025 16:45 by rmk") + [LAMBDA (CLOOK1 CLOOK2) (* ; "Edited 1-Aug-2025 11:43 by rmk") + (* ; "Edited 21-Jul-2025 23:43 by rmk") + (* ; "Edited 15-Apr-2025 16:45 by rmk") (* ; "Edited 2-Jan-2025 21:01 by rmk") (* ; "Edited 18-Oct-2024 22:29 by rmk") (* ; "Edited 11-Aug-2024 20:41 by rmk") @@ -622,11 +619,12 @@ (FGETCLOOKS CLOOK2 CLSTYLE)) (EQ (FGETCLOOKS CLOOK1 CLUNBREAKABLE) (FGETCLOOKS CLOOK2 CLUNBREAKABLE)) - (EQUAL (FGETCLOOKS CLOOK1 CLUSERINFO) - (FGETCLOOKS CLOOK2 CLUSERINFO]) + (EQUAL (FGETCLOOKS CLOOK1 CLPROPS) + (FGETCLOOKS CLOOK2 CLPROPS]) (\TEDIT.SAMECLOOKS - [LAMBDA (CLOOK1 CLOOK2 FEATURES) (* ; "Edited 15-Apr-2025 16:42 by rmk") + [LAMBDA (CLOOK1 CLOOK2 FEATURES) (* ; "Edited 21-Jul-2025 23:45 by rmk") + (* ; "Edited 15-Apr-2025 16:42 by rmk") (* ; "Edited 2-Jan-2025 20:31 by rmk") (* ; "Edited 31-Dec-2024 23:59 by rmk") (* ; "Edited 31-Jul-2024 00:06 by rmk") @@ -662,10 +660,12 @@ (FGETCLOOKS CLOOK2 CLSTRIKE))) (UNDERLINE (EQ (FGETCLOOKS CLOOK1 CLULINE) (FGETCLOOKS CLOOK2 CLULINE))) - (UNBREAKABLE (FGETCLOOKS CLOOK1 CLUNBREAKABLE) - (FGETCLOOKS CLOOK2 CLUNBREAKABLE)) - (COLOR (FGETCLOOKS CLOOK1 CLCOLOR) - (FGETCLOOKS CLOOK2 CLCOLOR)) + (UNBREAKABLE (EQ (FGETCLOOKS CLOOK1 CLUNBREAKABLE) + (FGETCLOOKS CLOOK2 CLUNBREAKABLE))) + (COLOR (EQUAL (FGETCLOOKS CLOOK1 CLCOLOR) + (FGETCLOOKS CLOOK2 CLCOLOR))) + (CHARENCODING (EQ (FGETCLOOKS CLOOK1 CLCHARENCODING) + (FGETCLOOKS CLOOK2 CLCHARENCODING CLCOLOR))) (FACE (EQUAL (FONTPROP FONT1 'FACE) (FONTPROP FONT2 'FACE))) (ERROR (CONCAT F @@ -932,7 +932,9 @@ (DEFINEQ (\TEDIT.TRANSLATE.ASCIICHARS - [LAMBDA (TSTREAM NOASCIIFONTS) (* ; "Edited 24-Apr-2025 23:47 by rmk") + [LAMBDA (TSTREAM NOASCIIFONTS) (* ; "Edited 31-Jul-2025 09:56 by rmk") + (* ; "Edited 28-Jul-2025 23:35 by rmk") + (* ; "Edited 24-Apr-2025 23:47 by rmk") (* ; "Edited 30-Mar-2025 22:00 by rmk") (* ; "Edited 28-Mar-2025 14:24 by rmk") (* ; "Edited 2-Jan-2025 23:30 by rmk") @@ -967,7 +969,7 @@ ) (for CHNO CLOOKS TRANS MAPARRAY NEWFONTNAME STRING FAT CLOOKSLIST FAMILY TARRAYLAST from 1 by (PLEN PC) as PC inpieces (\TEDIT.FIRSTPIECE TEXTOBJ) - eachtime (SETQ CLOOKS (PLOOKS PC)) + eachtime (SETQ CLOOKS (PCHARLOOKS PC)) (SETQ FAMILY (FONTPROP (GETCLOOKS CLOOKS CLFONT) 'FAMILY)) unless (OR (EQ OBJECT.PTYPE (PTYPE PC)) (EQ FAMILY 'CLASSIC)) @@ -984,7 +986,7 @@ (* ;; " Look backward for NEWFONTNAME, since that piece has already been coerced. The idea is to get Cyrillic to continue the previous looks (serif, san-serif)") - (SETQ NEWFONTNAME (FONTPROP (GETCLOOKS (PLOOKS (PREVPIECE PC)) + (SETQ NEWFONTNAME (FONTPROP (GETCLOOKS (PCHARLOOKS (PREVPIECE PC)) CLFONT) 'FAMILY)))) (if (OR MAPARRAY NOASCIIFONTS) @@ -1022,8 +1024,8 @@ (UNFOLD (PLEN PC) 2) (PLEN PC))) - (FSETPC PC PLOOKS (\TEDIT.TRANSLATE.ASCII.CHARLOOKS TEXTOBJ CLOOKS - NEWFONTNAME)) + (FSETPC PC PCHARLOOKS (\TEDIT.TRANSLATE.ASCII.CHARLOOKS TEXTOBJ CLOOKS + NEWFONTNAME)) else (* ;; "Must be a text font (GACHA, TIMESROMAN, HELVETICA) \ASCIITONS is the translation array, mostly identities. ") @@ -1047,19 +1049,12 @@ do (\TEDIT.RPLCHARCODE TSTREAM I NEWCODE NEWLOOKS)) (RETURN))) finally - (* ;; "Here we change the default and caret looks. Perhaps this should be done only if NOASCIIFONTS. But there is a risk that Ascii fonts and characters would slip in by future editing. ") + (* ;; "Here we change the caret looks. Perhaps this should be done only if NOASCIIFONTS. But there is a risk that Ascii fonts and characters would slip in by future editing. ") (CL:WHEN NOASCIIFONTS (SETQ CLOOKS (FGETTOBJ TEXTOBJ DEFAULTCHARLOOKS)) (SETQ FAMILY (FONTPROP (GETCLOOKS CLOOKS CLFONT) 'FAMILY)) - (CL:WHEN (AND (NEQ FAMILY 'CLASSIC) - (SETQ TRANS (ASSOC FAMILY - ASCIITONSTRANSLATIONS - ))) - (FSETTOBJ TEXTOBJ DEFAULTCHARLOOKS - (\TEDIT.TRANSLATE.ASCII.CHARLOOKS - TEXTOBJ CLOOKS (CADDR TRANS)))) (SETQ CLOOKS (FGETTOBJ TEXTOBJ CARETLOOKS)) (SETQ FAMILY (FONTPROP (GETCLOOKS CLOOKS CLFONT) 'FAMILY)) @@ -1222,7 +1217,8 @@ (RETURN NEWLOOK]) (\TEDIT.UNIQUIFY.ALL - [LAMBDA (TEXTOBJ) (* ; "Edited 8-Feb-2025 20:24 by rmk") + [LAMBDA (TEXTOBJ) (* ; "Edited 31-Jul-2025 09:17 by rmk") + (* ; "Edited 8-Feb-2025 20:24 by rmk") (* ; "Edited 16-Mar-2024 10:03 by rmk") (* ; "Edited 14-Nov-2023 16:20 by rmk") (* ; "Edited 25-Aug-2023 08:57 by rmk") @@ -1236,7 +1232,7 @@ (* ;;  "Assure that the CHARLOOKS and PARALOOKS of every piece are in the cache.") - (change (PLOOKS PC) + (change (PCHARLOOKS PC) (\TEDIT.UNIQUIFY.CHARLOOKS DATUM TEXTOBJ)) (change (PPARALOOKS PC) (\TEDIT.UNIQUIFY.PARALOOKS DATUM TEXTOBJ)) @@ -1250,7 +1246,8 @@ (\TEDIT.UNIQUIFY.PARALOOKS DATUM TEXTOBJ]) (\TEDIT.FLUSH.UNUSED.LOOKS - [LAMBDA (TEXTOBJ) (* ; "Edited 19-Feb-2025 11:56 by rmk") + [LAMBDA (TEXTOBJ) (* ; "Edited 31-Jul-2025 09:17 by rmk") + (* ; "Edited 19-Feb-2025 11:56 by rmk") (* ; "Edited 8-Feb-2025 20:36 by rmk") (* ; "Edited 16-Mar-2024 10:03 by rmk") (* ; "Edited 25-Aug-2023 08:03 by rmk") @@ -1269,7 +1266,7 @@ (* ;; "Run thru the pieces in the document, marking the looks that are really in use.") - (for PC inpieces (\TEDIT.FIRSTPIECE TEXTOBJ) do (FSETCLOOKS (PLOOKS PC) + (for PC inpieces (\TEDIT.FIRSTPIECE TEXTOBJ) do (FSETCLOOKS (PCHARLOOKS PC) CLMARK T) (FSETPLOOKS (PPARALOOKS PC) FMTMARK T)) @@ -1323,7 +1320,8 @@ TSTREAM]) (TEDIT.GET.LOOKS - [LAMBDA (TEXTOBJ CH#ORCHARLOOKS) (* ; "Edited 17-Mar-2024 00:27 by rmk") + [LAMBDA (TEXTOBJ CH#ORCHARLOOKS) (* ; "Edited 31-Jul-2025 09:18 by rmk") + (* ; "Edited 17-Mar-2024 00:27 by rmk") (* ; "Edited 14-Dec-2023 21:00 by rmk") (* ; "Edited 21-Jun-2023 11:10 by rmk") (* ; "Edited 22-Aug-2022 13:14 by rmk") @@ -1339,18 +1337,21 @@ then (* ;  "Empty document, use extant caret looks.") (FGETTOBJ TEXTOBJ CARETLOOKS) - else (PLOOKS (\TEDIT.CHTOPC - (OR (FIXP CH#ORCHARLOOKS) - (GETSEL (if (type? SELECTION CH#ORCHARLOOKS) - then CH#ORCHARLOOKS - elseif (NULL CH#ORCHARLOOKS) - then (TEXTSEL TEXTOBJ) - else (\ILLEGAL.ARG CH#ORCHARLOOKS)) - CH#)) - TEXTOBJ]) + else (PCHARLOOKS (\TEDIT.CHTOPC + (OR (FIXP CH#ORCHARLOOKS) + (GETSEL (if (type? SELECTION + CH#ORCHARLOOKS) + then CH#ORCHARLOOKS + elseif (NULL CH#ORCHARLOOKS) + then (TEXTSEL TEXTOBJ) + else (\ILLEGAL.ARG + CH#ORCHARLOOKS)) + CH#)) + TEXTOBJ]) (TEDIT.SUBLOOKS - [LAMBDA (TSTREAM OLDLOOKSLIST NEWLOOKSLIST) (* ; "Edited 22-Apr-2025 20:41 by rmk") + [LAMBDA (TSTREAM OLDLOOKSLIST NEWLOOKSLIST) (* ; "Edited 31-Jul-2025 09:20 by rmk") + (* ; "Edited 22-Apr-2025 20:41 by rmk") (* ; "Edited 20-Apr-2025 13:26 by rmk") (* ; "Edited 6-Apr-2025 14:27 by rmk") (* ; "Edited 5-Apr-2025 13:31 by rmk") @@ -1377,7 +1378,7 @@ (NEWLOOKS _ (\TEDIT.PARSE.CHARLOOKS.LIST NEWLOOKSLIST NIL TEXTOBJ)) (FEATURELIST _ (for A on OLDLOOKSLIST by (CDDR A) collect (CAR A))) inpieces (\TEDIT.FIRSTPIECE TEXTOBJ) as CH# from 1 by (PLEN PC) - when (\TEDIT.SAMECLOOKS OLDLOOKS (PLOOKS PC) + when (\TEDIT.SAMECLOOKS OLDLOOKS (PCHARLOOKS PC) FEATURELIST) do (CL:UNLESS CHANGEMADE (SETQ CHANGEMADE T) (SETQ SEL (TEXTSEL TEXTOBJ)) @@ -1388,12 +1389,12 @@ (* ;;  "Note that we may be creating new looks each time, depending on what is there and what is changed.") - (FSETPC PC PLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS - (\TEDIT.PARSE.CHARLOOKS.LIST - NEWLOOKSLIST - (PLOOKS PC) - TEXTOBJ) - TEXTOBJ)) + (FSETPC PC PCHARLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS + (\TEDIT.PARSE.CHARLOOKS.LIST + NEWLOOKSLIST + (PCHARLOOKS PC) + TEXTOBJ) + TEXTOBJ)) (* ;; "This goes piece by piece, each one adding to the collection of dirty lines. We keep track of the first and last changes") @@ -1406,7 +1407,8 @@ (RETURN CHANGEMADE)))]) (TEDIT.FINDLOOKS - [LAMBDA (TEXTSTREAM OLDLOOKSLIST CH#) (* ; "Edited 17-Mar-2024 00:27 by rmk") + [LAMBDA (TEXTSTREAM OLDLOOKSLIST CH#) (* ; "Edited 31-Jul-2025 09:18 by rmk") + (* ; "Edited 17-Mar-2024 00:27 by rmk") (* ; "Edited 3-Dec-2023 00:09 by rmk") (* ; "Edited 13-Nov-2023 00:26 by rmk") (* ; "Edited 18-Apr-2023 23:53 by rmk") @@ -1428,10 +1430,11 @@ [for PC PCLAST FOUNDCH# (OLDLOOKS _ (\TEDIT.PARSE.CHARLOOKS.LIST OLDLOOKSLIST NIL TEXTOBJ)) (FEATURELIST _ (for A on OLDLOOKSLIST by (CDDR A) collect (CAR A))) - inpieces (\TEDIT.CHTOPC CH# TEXTOBJ) when (\TEDIT.SAMECLOOKS OLDLOOKS (PLOOKS PC) + inpieces (\TEDIT.CHTOPC CH# TEXTOBJ) when (\TEDIT.SAMECLOOKS OLDLOOKS (PCHARLOOKS + PC) FEATURELIST) do [SETQ PCLAST (find PC1 inpieces (NEXTPIECE PC) - suchthat (NOT (\TEDIT.SAMECLOOKS OLDLOOKS (PLOOKS PC1) + suchthat (NOT (\TEDIT.SAMECLOOKS OLDLOOKS (PCHARLOOKS PC1) FEATURELIST] (SETQ PCLAST (CL:IF PCLAST (PREVPIECE PCLAST) @@ -1449,7 +1452,8 @@ (DEFINEQ (\TEDIT.CHANGE.CHARLOOKS - [LAMBDA (TSTREAM NEWLOOKS TARGETSEL) (* ; "Edited 22-Apr-2025 20:17 by rmk") + [LAMBDA (TSTREAM NEWLOOKS TARGETSEL) (* ; "Edited 31-Jul-2025 09:18 by rmk") + (* ; "Edited 22-Apr-2025 20:17 by rmk") (* ; "Edited 21-Apr-2025 20:17 by rmk") (* ; "Edited 20-Apr-2025 13:27 by rmk") (* ; "Edited 16-Apr-2025 09:03 by rmk") @@ -1508,7 +1512,7 @@ (* ;; "Verify that all of the new looks are OK before we change anything") [SETQ NEWLOOKSLIST (for PC OLDCHARLOOKS inselpieces SELPIECES - collect (SETQ OLDCHARLOOKS (PLOOKS PC)) + collect (SETQ OLDCHARLOOKS (PCHARLOOKS PC)) (OR (CL:IF (type? CHARLOOKS NEWLOOKS) NEWLOOKS (\TEDIT.CHANGE.CHARLOOKS.NEW NEWLOOKS OLDCHARLOOKS @@ -1519,12 +1523,12 @@ [for PC UNDOLIST NEWCHARLOOKS (FIRSTCHAR _ (GETSPC SELPIECES SPFIRSTCHAR)) (ORIGFILEPTR _ (\TEDIT.TEXTGETFILEPTR TSTREAM)) OLDCHARLOOKS inselpieces SELPIECES as NEWCHARLOOKS in NEWLOOKSLIST - do (SETQ OLDCHARLOOKS (PLOOKS PC)) + do (SETQ OLDCHARLOOKS (PCHARLOOKS PC)) (add FIRSTCHAR (PLEN PC)) (* ;  "Beginning of next piece--where to stop undoing if new pieces inserted") (if (\TEDIT.EQCLOOKS OLDCHARLOOKS NEWCHARLOOKS) then (SETQ OLDCHARLOOKS NIL) (* ; "Undo skips if NIL") - else (FSETPC PC PLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS NEWCHARLOOKS TEXTOBJ)) + else (FSETPC PC PCHARLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS NEWCHARLOOKS TEXTOBJ)) (CL:UNLESS DIRTY (* ;  "Resetting DIRTY is expensive, only do it once ") (FSETTOBJ TEXTOBJ \DIRTY T) @@ -2033,7 +2037,8 @@ join (LIST PROPNAME PROP]) (\TEDIT.PARSE.PARALOOKS.LIST - [LAMBDA (NEWLOOKS OLDLOOKS TEXTOBJ) (* ; "Edited 19-Feb-2025 11:57 by rmk") + [LAMBDA (NEWLOOKS OLDPARALOOKS) (* ; "Edited 28-Jul-2025 23:19 by rmk") + (* ; "Edited 19-Feb-2025 11:57 by rmk") (* ; "Edited 8-Feb-2025 22:27 by rmk") (* ; "Edited 28-Jul-2024 22:14 by rmk") (* ; "Edited 29-Apr-2024 11:03 by rmk") @@ -2042,17 +2047,28 @@ (* ; "Edited 5-Sep-2022 15:39 by rmk") (* ;  "Edited 3-Jul-93 21:49 by sybalskY:MV:ENVOS") - (* ; - "Apply a given format spec to the paragraphs which are included in this guy.") + + (* ;; "Produce a PARALOOKS based on the priority union of NEWLOOKS over OLDLOOKS. ") + + (* ;; "This causes errors for invalid arguments (e.g. nonnumeric). User values should be checked and reported by the caller.ÿÿ") + (if (type? PARALOOKS NEWLOOKS) - then (* ; - "if we were given a PARALOOKS it replace the PARALOOKS of all pieces affected") + then + (* ;; "A PARALOOKS is complete, OLDPARALOOKS ignored ") + NEWLOOKS - else (LET (NEWFMT 1STLEFT LEFT RIGHT LEADB LEADA LLEAD TABSPEC QUADD NLOOKSAVE TYPE SUBTYPE - TYPESET SUBTYPESET NEWBEFORESET NEWBEFORE NEWAFTERSET NEWAFTER KEEP KEEPSET - HEADINGKEEP BASETOBASE BASESET REVISED REVISEDSET COLUMN COLUMNSET USERINFO - USERINFOSET SPECIALX SPECXSET SPECIALY SPECYSET STYLE STYLESET CHARSTYLES - CHARSTYLESSET DEFTAB TABS) (* ; "create PARALOOKS from the Plist") + else (LET (NEWPARALOOKS 1STLEFT LEFT RIGHT LEADB LEADA LLEAD TABSPEC QUADD NLOOKSAVE TYPE + SUBTYPE TYPESET SUBTYPESET NEWBEFORESET NEWBEFORE NEWAFTERSET NEWAFTER KEEP + KEEPSET HEADINGKEEP HEADINGKEEPSET BASETOBASE BASESET REVISED REVISEDSET + COLUMN COLUMNSET USERINFO USERINFOSET SPECIALX SPECXSET SPECIALY SPECYSET + STYLE STYLESET CHARSTYLES CHARSTYLESSET DEFTAB TABS) + (* ; "create PARALOOKS from the Plist") + (CL:WHEN (LISTP OLDPARALOOKS) (* ; "Defaults from OLDPARALOOKS") + (SETQ NEWLOOKS (APPEND NEWLOOKS OLDPARALOOKS))) + + (* ;; + "For values that can be NIL, we have to keep track of what was there. ALIST would have been better") + (SETQ 1STLEFT (LISTGET NEWLOOKS '1STLEFTMARGIN)) (SETQ LEFT (LISTGET NEWLOOKS 'LEFTMARGIN)) (SETQ RIGHT (LISTGET NEWLOOKS 'RIGHTMARGIN)) @@ -2067,11 +2083,12 @@ (SETQ NEWBEFORE (LISTGET NEWLOOKS 'NEWPAGEBEFORE)) (SETQ NEWAFTERSET (FMEMB 'NEWPAGEAFTER NEWLOOKS)) (SETQ NEWAFTER (LISTGET NEWLOOKS 'NEWPAGEAFTER)) + (SETQ HEADINGKEEPSET (FMEMB 'HEADINGKEEP NEWLOOKS)) (SETQ HEADINGKEEP (LISTGET NEWLOOKS 'HEADINGKEEP)) (* ; "Keep for headings") - (SETQ KEEP (LISTGET NEWLOOKS 'KEEP)) (* ; - "More general `Keep-together' spec -- undefined as of 5/22/85") (SETQ KEEPSET (FMEMB 'KEEP NEWLOOKS)) + (SETQ KEEP (LISTGET NEWLOOKS 'KEEP)) (* ; + "More general `Keep-together' spec -- undefined as of 5/22/8ÿÿ5") (SETQ BASETOBASE (LISTGET NEWLOOKS 'BASETOBASE)) (SETQ BASESET (FMEMB 'BASETOBASE NEWLOOKS)) (SETQ REVISED (LISTGET NEWLOOKS 'REVISED)) @@ -2093,6 +2110,9 @@ (SETQ TABS (LISTGET NEWLOOKS 'TABS)) (SETQ TABSPEC (LISTGET NEWLOOKS 'TABSPEC)) (CL:WHEN TABSPEC + + (* ;; "Cÿœœœÿhange from the users list to the real tabspec, a CONS pair of default width and LIST of TAB record instances") + (SETQ DEFTAB (fetch (TABSPEC DEFAULTTAB) of TABSPEC)) (SETQ TABS (fetch (TABSPEC TABS) of TABSPEC))) [SELECTQ QUADD @@ -2106,39 +2126,36 @@ ((C CENTER) (SETQQ QUADD CENTERED)) (PROGN (* ; - "We got an illegal QUAD value. Use LEFT.") - (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "Illegal paragraph quad " QUADD - ", replaced with LEFT.") - T) + "Value should have been checked, error reported") (SETQ QUADD 'LEFT] - - (* ;; "change from the users list to the real tabspec, a CONS pair of default width and LIST of TAB record instances") - - (SETQ NEWFMT (create PARALOOKS using (OR OLDLOOKS TEDIT.DEFAULT.FMTSPEC))) - (AND 1STLEFT (FSETPLOOKS NEWFMT 1STLEFTMAR 1STLEFT)) - (AND LEFT (FSETPLOOKS NEWFMT LEFTMAR LEFT)) - (AND RIGHT (FSETPLOOKS NEWFMT RIGHTMAR RIGHT)) - (AND LEADB (FSETPLOOKS NEWFMT LEADBEFORE LEADB)) - (AND LEADA (FSETPLOOKS NEWFMT LEADAFTER LEADA)) - (AND LLEAD (FSETPLOOKS NEWFMT LINELEAD LLEAD)) - (AND TABS (FSETPLOOKS NEWFMT FMTTABS TABS)) - (AND DEFTAB (FSETPLOOKS NEWFMT FMTDEFAULTTAB DEFTAB)) - (AND QUADD (FSETPLOOKS NEWFMT QUAD QUADD)) - (AND TYPESET (FSETPLOOKS NEWFMT FMTPARATYPE TYPE)) - (AND SUBTYPESET (FSETPLOOKS NEWFMT FMTPARASUBTYPE SUBTYPE)) - (AND NEWBEFORESET (FSETPLOOKS NEWFMT FMTNEWPAGEBEFORE NEWBEFORE)) - (AND NEWAFTERSET (FSETPLOOKS NEWFMT FMTNEWPAGEAFTER NEWAFTER)) - [AND HEADINGKEEP (FSETPLOOKS NEWFMT FMTHEADINGKEEP (EQ HEADINGKEEP 'ON] - (AND KEEPSET (FSETPLOOKS NEWFMT FMTKEEP KEEP)) - (AND BASESET (FSETPLOOKS NEWFMT FMTBASETOBASE BASETOBASE)) - (AND REVISEDSET (FSETPLOOKS NEWFMT FMTREVISED REVISED)) - (AND COLUMNSET (FSETPLOOKS NEWFMT FMTCOLUMN COLUMN)) - (AND SPECXSET (FSETPLOOKS NEWFMT FMTSPECIALX SPECIALX)) - (AND SPECYSET (FSETPLOOKS NEWFMT FMTSPECIALY SPECIALY)) - (AND STYLESET (FSETPLOOKS NEWFMT FMTSTYLE STYLE)) - (AND CHARSTYLESSET (FSETPLOOKS NEWFMT FMTCHARSTYLES CHARSTYLES)) - (AND USERINFOSET (FSETPLOOKS NEWFMT FMTUSERINFO USERINFO)) - NEWFMT]) + (SETQ NEWPARALOOKS (if (type? PARALOOKS OLDPARALOOKS) + then (create PARALOOKS using OLDPARALOOKS) + else (create PARALOOKS))) + (AND 1STLEFT (FSETPLOOKS NEWPARALOOKS 1STLEFTMAR 1STLEFT)) + (AND LEFT (FSETPLOOKS NEWPARALOOKS LEFTMAR LEFT)) + (AND RIGHT (FSETPLOOKS NEWPARALOOKS RIGHTMAR RIGHT)) + (AND LEADB (FSETPLOOKS NEWPARALOOKS LEADBEFORE LEADB)) + (AND LEADA (FSETPLOOKS NEWPARALOOKS LEADAFTER LEADA)) + (AND LLEAD (FSETPLOOKS NEWPARALOOKS LINELEAD LLEAD)) + (AND TABS (FSETPLOOKS NEWPARALOOKS FMTTABS TABS)) + (AND DEFTAB (FSETPLOOKS NEWPARALOOKS FMTDEFAULTTAB DEFTAB)) + (AND QUADD (FSETPLOOKS NEWPARALOOKS QUAD QUADD)) + (AND TYPESET (FSETPLOOKS NEWPARALOOKS FMTPARATYPE TYPE)) + (AND SUBTYPESET (FSETPLOOKS NEWPARALOOKS FMTPARASUBTYPE SUBTYPE)) + (AND NEWBEFORESET (FSETPLOOKS NEWPARALOOKS FMTNEWPAGEBEFORE NEWBEFORE)) + (AND NEWAFTERSET (FSETPLOOKS NEWPARALOOKS FMTNEWPAGEAFTER NEWAFTER)) + [AND HEADINGKEEPSET (FSETPLOOKS NEWPARALOOKS FMTHEADINGKEEP (EQ HEADINGKEEP + 'ON] + (AND KEEPSET (FSETPLOOKS NEWPARALOOKS FMTKEEP KEEP)) + (AND BASESET (FSETPLOOKS NEWPARALOOKS FMTBASETOBASE BASETOBASE)) + (AND REVISEDSET (FSETPLOOKS NEWPARALOOKS FMTREVISED REVISED)) + (AND COLUMNSET (FSETPLOOKS NEWPARALOOKS FMTCOLUMN COLUMN)) + (AND SPECXSET (FSETPLOOKS NEWPARALOOKS FMTSPECIALX SPECIALX)) + (AND SPECYSET (FSETPLOOKS NEWPARALOOKS FMTSPECIALY SPECIALY)) + (AND STYLESET (FSETPLOOKS NEWPARALOOKS FMTSTYLE STYLE)) + (AND CHARSTYLESSET (FSETPLOOKS NEWPARALOOKS FMTCHARSTYLES CHARSTYLES)) + (AND USERINFOSET (FSETPLOOKS NEWPARALOOKS FMTUSERINFO USERINFO)) + NEWPARALOOKS]) (TEDIT.PARALOOKS [LAMBDA (TSTREAM NEWLOOKS SELORCH# LEN) (* ; "Edited 10-Aug-2024 00:23 by rmk") @@ -2394,7 +2411,8 @@ (DEFINEQ (TEDIT.SUBPARALOOKS - [LAMBDA (TSTREAM OLDLOOKSLIST NEWLOOKSLIST) (* ; "Edited 21-Apr-2025 20:15 by rmk") + [LAMBDA (TSTREAM OLDLOOKSLIST NEWLOOKSLIST) (* ; "Edited 28-Jul-2025 22:57 by rmk") + (* ; "Edited 21-Apr-2025 20:15 by rmk") (* ; "Edited 20-Apr-2025 13:27 by rmk") (* ; "Edited 6-Apr-2025 14:31 by rmk") (* ; "Edited 25-Nov-2024 22:00 by rmk") @@ -2416,7 +2434,6 @@ (LET ((TEXTOBJ (FTEXTOBJ TSTREAM))) (for PC CHANGEMADE SEL FIRSTCHANGEDCHNO (NCHARSCHANGED _ 0) (OLDLOOKS _ (\TEDIT.PARSE.PARALOOKS.LIST OLDLOOKSLIST)) - (NEWLOOKS _ (\TEDIT.PARSE.PARALOOKS.LIST NEWLOOKSLIST)) (FEATURELIST _ (for A on OLDLOOKSLIST by (CDDR A) collect (CAR A))) inpieces (\TEDIT.FIRSTPIECE TEXTOBJ) as CH# from 1 by (PLEN PC) when (SAMEPARALOOKS OLDLOOKS (PPARALOOKS PC PPARALOOKS) @@ -2429,8 +2446,7 @@ (FSETPC PC PPARALOOKS (\TEDIT.UNIQUIFY.PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST NEWLOOKSLIST - (PPARALOOKS PC) - TEXTOBJ) + (PPARALOOKS PC)) TEXTOBJ)) (* ;; "This goes piece by piece, each one adding to the collection of dirty lines. We keep track of the first and last changes") @@ -2517,26 +2533,26 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (22170 24112 (\TEDIT.CHARLOOKS.DEFPRINT 22180 . 23316) (\TEDIT.PARALOOKS.DEFPRINT 23318 - . 24110)) (24216 25312 (\TEDIT.CREATE.DEFAULT.FMTSPEC 24226 . 24934) (\TEDIT.CREATE.FACE.MENU 24936 - . 25108) (\TEDIT.CREATE.SIZE.MENU 25110 . 25310)) (26111 28000 (\TEDIT.CHARLOOKS.FEATURE.CHECK 26121 - . 27998)) (28302 52994 (\TEDIT.CHARLOOKS.FROM.FONT 28312 . 30525) (\TEDIT.EQCLOOKS 30527 . 33349) ( -\TEDIT.SAMECLOOKS 33351 . 36237) (TEDIT.CARETLOOKS 36239 . 37785) (TEDIT.COPY.LOOKS 37787 . 41070) ( -\TEDIT.UNPARSE.CHARLOOKS.LIST 41072 . 44566) (\TEDIT.MODIFYLOOKS 44568 . 46728) (TEDIT.NEW.FONT 46730 - . 47177) (\TEDIT.CARETLOOKS.VERIFY 47179 . 48016) (\TEDIT.CARETPIECE 48018 . 48323) ( -\TEDIT.GET.INSERT.CHARLOOKS 48325 . 51372) (\TEDIT.GET.TERMSA.WIDTHS 51374 . 51790) ( -\TEDIT.PARSE.CHARLOOKS.LIST 51792 . 52992)) (52995 70141 (\TEDIT.TRANSLATE.ASCIICHARS 53005 . 63877) ( -\TEDIT.CONVERT.TO.FORMATTED 63879 . 70139)) (71153 78264 (\TEDIT.UNIQUIFY.CHARLOOKS 71163 . 72823) ( -\TEDIT.UNIQUIFY.PARALOOKS 72825 . 74092) (\TEDIT.UNIQUIFY.ALL 74094 . 76069) ( -\TEDIT.FLUSH.UNUSED.LOOKS 76071 . 78262)) (78297 89604 (TEDIT.LOOKS 78307 . 80696) (TEDIT.GET.LOOKS -80698 . 82727) (TEDIT.SUBLOOKS 82729 . 86968) (TEDIT.FINDLOOKS 86970 . 89602)) (89679 119187 ( -\TEDIT.CHANGE.CHARLOOKS 89689 . 98346) (\TEDIT.CHANGE.CHARLOOKS.NEW 98348 . 102142) ( -\TEDIT.CHARLOOKS.CHANGE.FONT 102144 . 110451) (\TEDIT.FONT.NEXTSIZE 110453 . 112074) (\TEDIT.LOOKS -112076 . 115405) (\TEDIT.FONTCOPY 115407 . 116908) (\TEDIT.COERCE.FONTCLASS 116910 . 118061) ( -\TEDIT.FONTCLASS.TO.FONT 118063 . 119185)) (119230 150187 (\TEDIT.EQFMTSPEC 119240 . 122455) ( -TEDIT.GET.PARALOOKS 122457 . 126504) (\TEDIT.PARSE.PARALOOKS.LIST 126506 . 133848) (TEDIT.PARALOOKS -133850 . 134890) (\TEDIT.CHANGE.PARALOOKS 134892 . 141860) (\TEDIT.CHANGE.PARALOOKS.NEW 141862 . -145845) (TEDIT.COPY.PARALOOKS 145847 . 148521) (\TEDIT.PARABOUNDS 148523 . 150185)) (150247 158000 ( -TEDIT.SUBPARALOOKS 150257 . 154396) (SAMEPARALOOKS 154398 . 157998)) (158001 158688 ( -\TEDIT.MARK.REVISION 158011 . 158686))))) + (FILEMAP (NIL (22579 24521 (\TEDIT.CHARLOOKS.DEFPRINT 22589 . 23725) (\TEDIT.PARALOOKS.DEFPRINT 23727 + . 24519)) (24625 25011 (\TEDIT.CREATE.FACE.MENU 24635 . 24807) (\TEDIT.CREATE.SIZE.MENU 24809 . 25009 +)) (26015 27904 (\TEDIT.CHARLOOKS.FEATURE.CHECK 26025 . 27902)) (28176 53365 ( +\TEDIT.CHARLOOKS.FROM.FONT 28186 . 30399) (\TEDIT.EQCLOOKS 30401 . 33435) (\TEDIT.SAMECLOOKS 33437 . +36608) (TEDIT.CARETLOOKS 36610 . 38156) (TEDIT.COPY.LOOKS 38158 . 41441) ( +\TEDIT.UNPARSE.CHARLOOKS.LIST 41443 . 44937) (\TEDIT.MODIFYLOOKS 44939 . 47099) (TEDIT.NEW.FONT 47101 + . 47548) (\TEDIT.CARETLOOKS.VERIFY 47550 . 48387) (\TEDIT.CARETPIECE 48389 . 48694) ( +\TEDIT.GET.INSERT.CHARLOOKS 48696 . 51743) (\TEDIT.GET.TERMSA.WIDTHS 51745 . 52161) ( +\TEDIT.PARSE.CHARLOOKS.LIST 52163 . 53363)) (53366 70096 (\TEDIT.TRANSLATE.ASCIICHARS 53376 . 63832) ( +\TEDIT.CONVERT.TO.FORMATTED 63834 . 70094)) (71108 78445 (\TEDIT.UNIQUIFY.CHARLOOKS 71118 . 72778) ( +\TEDIT.UNIQUIFY.PARALOOKS 72780 . 74047) (\TEDIT.UNIQUIFY.ALL 74049 . 76137) ( +\TEDIT.FLUSH.UNUSED.LOOKS 76139 . 78443)) (78478 90436 (TEDIT.LOOKS 78488 . 80877) (TEDIT.GET.LOOKS +80879 . 83214) (TEDIT.SUBLOOKS 83216 . 87596) (TEDIT.FINDLOOKS 87598 . 90434)) (90511 120140 ( +\TEDIT.CHANGE.CHARLOOKS 90521 . 99299) (\TEDIT.CHANGE.CHARLOOKS.NEW 99301 . 103095) ( +\TEDIT.CHARLOOKS.CHANGE.FONT 103097 . 111404) (\TEDIT.FONT.NEXTSIZE 111406 . 113027) (\TEDIT.LOOKS +113029 . 116358) (\TEDIT.FONTCOPY 116360 . 117861) (\TEDIT.COERCE.FONTCLASS 117863 . 119014) ( +\TEDIT.FONTCLASS.TO.FONT 119016 . 120138)) (120183 151831 (\TEDIT.EQFMTSPEC 120193 . 123408) ( +TEDIT.GET.PARALOOKS 123410 . 127457) (\TEDIT.PARSE.PARALOOKS.LIST 127459 . 135492) (TEDIT.PARALOOKS +135494 . 136534) (\TEDIT.CHANGE.PARALOOKS 136536 . 143504) (\TEDIT.CHANGE.PARALOOKS.NEW 143506 . +147489) (TEDIT.COPY.PARALOOKS 147491 . 150165) (\TEDIT.PARABOUNDS 150167 . 151829)) (151891 159607 ( +TEDIT.SUBPARALOOKS 151901 . 156003) (SAMEPARALOOKS 156005 . 159605)) (159608 160295 ( +\TEDIT.MARK.REVISION 159618 . 160293))))) STOP diff --git a/library/tedit/TEDIT-LOOKS.LCOM b/library/tedit/TEDIT-LOOKS.LCOM index 896365536..2eba0287f 100644 Binary files a/library/tedit/TEDIT-LOOKS.LCOM and b/library/tedit/TEDIT-LOOKS.LCOM differ diff --git a/library/tedit/TEDIT-STREAM b/library/tedit/TEDIT-STREAM index c5592e9bf..3d4abb27e 100644 --- a/library/tedit/TEDIT-STREAM +++ b/library/tedit/TEDIT-STREAM @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-May-2025 19:06:45" {WMEDLEY}tedit>TEDIT-STREAM.;901 191318 +(FILECREATED "29-Jul-2025 11:58:01" {WMEDLEY}TEDIT>TEDIT-STREAM.;912 190401 :EDIT-BY rmk - :CHANGES-TO (FNS \TEDIT.OPENTEXTSTREAM.PIECES) + :CHANGES-TO (FNS \TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS) - :PREVIOUS-DATE "26-Apr-2025 12:59:53" {WMEDLEY}tedit>TEDIT-STREAM.;900) + :PREVIOUS-DATE "28-Jul-2025 23:52:41" {WMEDLEY}TEDIT>TEDIT-STREAM.;911) (PRETTYCOMPRINT TEDIT-STREAMCOMS) @@ -14,8 +14,8 @@ (RPAQQ TEDIT-STREAMCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS PIECE TEXTOBJ TEXTSTREAM) - (MACROS NEXTPIECE PREVPIECE PLEN PTYPE PCONTENTS PLOOKS PCHARLOOKS PCHARSET - PPARALOOKS PPARALAST PFPOS PBYTELEN PNEW PBINABLE PBYTESPERCHAR POBJ) + (MACROS NEXTPIECE PREVPIECE PLEN PTYPE PCONTENTS PCHARLOOKS PCHARSET PPARALOOKS + PPARALAST PFPOS PBYTELEN PNEW PBINABLE PBYTESPERCHAR POBJ) (MACROS SETPC FSETPC GETPC FGETPC) (MACROS THINPIECEP) (MACROS VISIBLEPIECEP \NEXT.VISIBLE.PIECE \PREV.VISIBLE.PIECE) @@ -126,14 +126,8 @@  "The number of bytes in the UTF-8 encoding of all the Unicode characters in this piece") [ACCESSFNS ((POBJ (AND (EQ OBJECT.PTYPE (PTYPE DATUM)) (type? IMAGEOBJ (PCONTENTS DATUM)) - (PCONTENTS DATUM))) - (PLOOKS (STANDARD (fetch (PIECE PCHARLOOKS) of DATUM) - FAST - (fetch (PIECE PCHARLOOKS) of DATUM)) - (STANDARD (replace (PIECE PCHARLOOKS) of DATUM with NEWVALUE) - FAST - (freplace (PIECE PCHARLOOKS) of DATUM with NEWVALUE] - PFPOS _ 0 PLEN _ 0 PBYTELEN _ 0 PPARALOOKS _ TEDIT.DEFAULT.FMTSPEC) + (PCONTENTS DATUM] + PFPOS _ 0 PLEN _ 0 PBYTELEN _ 0) (DATATYPE TEXTOBJ ( (* ;; @@ -202,7 +196,7 @@  "Flag for paragraph formatting. T if this document is to contain paragraph formatting information.") (TXTREADONLY FLAG) (* ;  "This is only available for shift selection.") - (TXTEDITING FLAG) (* ; "T => This document is in a window and there is an edit process behind it. For example, it only makes sense to have a caret show up if you are editing.") + (UNDERTEDIT FLAG) (* ; "Was TXTEDITING, but it was never fetched. T => This document is in a window and there is an edit process behind it. For example, it only makes sense to have a caret show up if you are editing.") (TXTNOTSPLITTABLE FLAG) (* ; "Can't split into panes, split-region not show. Was TXTNONSCHARS: T => If TEdit rns into a 255, it won't attempt to convert to NS characters. Used for REALLY plain-text manipulation.") TXTTERMSA (* ;  "Special instructions for displaying characters on the screen") @@ -252,8 +246,7 @@ (freplace \XDIRTY OF DATUM WITH NEWVALUE))] SEL _ (create SELECTION) TEXTLEN _ 0 WTOP _ 0 MOUSEREGION _ 'TEXT THISLINE _ (create THISLINE) - DEFAULTPARALOOKS _ TEDIT.DEFAULT.FMTSPEC PARABREAKCHARS _ - (CHARCODE (EOL FORM LF CR))) + PARABREAKCHARS _ (CHARCODE (EOL FORM LF CR))) (ACCESSFNS TEXTSTREAM ( @@ -410,9 +403,6 @@ (PUTPROPS PCONTENTS MACRO ((PC) (ffetch (PIECE PCONTENTS) of PC))) -(PUTPROPS PLOOKS MACRO ((PC) - (ffetch (PIECE PCHARLOOKS) of PC))) - (PUTPROPS PCHARLOOKS MACRO ((PC) (ffetch (PIECE PCHARLOOKS) of PC))) @@ -1640,18 +1630,8 @@ WINDOW]) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS - [LAMBDA (TEXTOBJ) (* ; "Edited 22-Mar-2025 21:37 by rmk") - (* ; "Edited 8-Feb-2025 22:04 by rmk") - (* ; "Edited 29-Dec-2024 20:37 by rmk") - (* ; "Edited 20-Dec-2024 11:56 by rmk") - (* ; "Edited 16-Dec-2024 13:14 by rmk") - (* ; "Edited 21-Nov-2024 14:35 by rmk") - (* ; "Edited 29-Aug-2024 09:46 by rmk") - (* ; "Edited 31-Jul-2024 12:09 by rmk") - (* ; "Edited 29-Apr-2024 11:05 by rmk") - (* ; "Edited 11-Nov-2023 16:13 by rmk") - (* ; "Edited 17-Sep-2023 07:43 by rmk") - (* ; "Edited 3-Aug-2023 23:02 by rmk") + [LAMBDA (TEXTOBJ) (* ; "Edited 29-Jul-2025 11:53 by rmk") + (* ; "Edited 22-Mar-2025 21:37 by rmk") (* ; "Edited 26-Apr-2023 14:29 by rmk") (* ;; @@ -1663,21 +1643,26 @@ (SETQ FONT (OR (GETTEXTPROP TEXTOBJ 'FONT) (FONTCREATE DEFAULTFONT))) - (SETQ CHARLOOKS (GETTEXTPROP TEXTOBJ 'CHARLOOKS)) + + (* ;; "LOOKS for backward compatibility and compatibility with documentation") + + [SETQ CHARLOOKS (OR (GETTEXTPROP TEXTOBJ 'CHARLOOKS) + (GETTEXTPROP TEXTOBJ 'LOOKS] (SETQ CHARLOOKS (OR (AND CHARLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST CHARLOOKS NIL TEXTOBJ)) (AND (type? CHARLOOKS FONT) FONT) (\TEDIT.CHARLOOKS.FROM.FONT FONT))) (SETQ CHARLOOKS (\TEDIT.UNIQUIFY.CHARLOOKS CHARLOOKS TEXTOBJ)) - (SETQ PARALOOKS (\TEDIT.UNIQUIFY.PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST - (OR (GETTEXTPROP TEXTOBJ 'PARALOOKS) - (create PARALOOKS using - TEDIT.DEFAULT.FMTSPEC - )) - NIL TEXTOBJ) - TEXTOBJ)) (SETTOBJ TEXTOBJ DEFAULTCHARLOOKS CHARLOOKS) (SETTOBJ TEXTOBJ CARETLOOKS CHARLOOKS) + + (* ;; "PARALOOKS") + + (SETQ PARALOOKS (\TEDIT.UNIQUIFY.PARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST (GETTEXTPROP + TEXTOBJ + 'PARALOOKS) + TEDIT.DEFAULT.PARALOOKS) + TEXTOBJ)) (SETTOBJ TEXTOBJ DEFAULTPARALOOKS PARALOOKS]) (\TEDIT.OPENTEXTFILE @@ -1709,7 +1694,8 @@ (ERROR TEXT " does not identify a Tedit document")))]) (\TEDIT.CREATE.TEXTSTREAM - [LAMBDA (PROPS) (* ; "Edited 7-Feb-2025 08:09 by rmk") + [LAMBDA (PROPS) (* ; "Edited 28-Jul-2025 22:56 by rmk") + (* ; "Edited 7-Feb-2025 08:09 by rmk") (* ; "Edited 16-Mar-2024 09:52 by rmk") (* ; "Edited 21-Jan-2024 15:16 by rmk") (* ; "Edited 17-Sep-2023 00:38 by rmk") @@ -1717,15 +1703,15 @@ (* ;; "Creates and initializes an empty, windowless textstream") - (LET (TSTREAM (TEXTOBJ (create TEXTOBJ))) - (SETQ TSTREAM (create TEXTSTREAM - TEXTOBJ _ TEXTOBJ)) - (SETTOBJ TEXTOBJ STREAMHINT TSTREAM) - (\TEDIT.OPENTEXTSTREAM.PROPS TEXTOBJ PROPS) - (\TEDIT.MAKEPCTB TEXTOBJ) - (\TEDIT.INSTALL.PIECE TSTREAM (FGETTOBJ TEXTOBJ SUFFIXPIECE) - 0) - TSTREAM]) + (LET* ((TEXTOBJ (create TEXTOBJ)) + (TSTREAM (create TEXTSTREAM + TEXTOBJ _ TEXTOBJ))) + (SETTOBJ TEXTOBJ STREAMHINT TSTREAM) + (\TEDIT.OPENTEXTSTREAM.PROPS TEXTOBJ PROPS) + (\TEDIT.MAKEPCTB TEXTOBJ) + (\TEDIT.INSTALL.PIECE TSTREAM (FGETTOBJ TEXTOBJ SUFFIXPIECE) + 0) + TSTREAM]) (\TEDIT.REOPEN.STREAM [LAMBDA (TSTREAM PIECESTREAM) (* ; "Edited 14-May-2024 18:00 by rmk") @@ -1766,7 +1752,8 @@ NEWSTREAM]) (\TEDIT.TEXTINIT - [LAMBDA NIL (* ; "Edited 15-Apr-2025 23:10 by rmk") + [LAMBDA NIL (* ; "Edited 10-Jul-2025 11:28 by rmk") + (* ; "Edited 15-Apr-2025 23:10 by rmk") (* ; "Edited 4-Sep-2024 22:05 by rmk") (* ; "Edited 22-May-2024 14:53 by rmk") (* ; "Edited 19-Mar-2024 18:16 by rmk") @@ -1817,7 +1804,7 @@ IMCOLOR _ (FUNCTION \TEDIT.TEXTCOLOR))) (FONTPROFILE.ADDDEVICE 'TEXT 'DISPLAY) (ADDTOVAR IMAGESTREAMTYPES (TEXT (FONTCREATE \CREATEDISPLAYFONT) - (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES) + (FONTSAVAILABLE \SEARCHFONTFILES) (CREATECHARSET \CREATECHARSET.DISPLAY))) (* ;; "Maybe more functions later. The INCODE and BACK functions possibly need to count. If \TEXTBACKFILEPTR takes a count variable, the extra level wouldn't be needed. But INCCODE wants to go through the BIN opcode") @@ -1936,7 +1923,9 @@ (CLOSEF? (GETTOBJ TEXTOBJ TXTFILE]) (\TEDIT.TEXTDSPFONT - [LAMBDA (TSTREAM NEWFONT) (* ; "Edited 17-Mar-2024 11:49 by rmk") + [LAMBDA (TSTREAM NEWFONT) (* ; "Edited 14-Jul-2025 22:57 by rmk") + (* ; "Edited 5-Jul-2025 18:55 by rmk") + (* ; "Edited 17-Mar-2024 11:49 by rmk") (* ; "Edited 15-Oct-2023 17:13 by rmk") (* ; "Edited 8-Sep-2022 14:16 by rmk") (* ; "Edited 31-May-91 14:02 by jds") @@ -1946,7 +1935,7 @@ (LET ((TEXTOBJ (TEXTOBJ TSTREAM))) (PROG1 (fetch (CHARLOOKS CLFONT) of (FGETTOBJ TEXTOBJ CARETLOOKS)) (CL:WHEN NEWFONT - (TEDIT.CARETLOOKS TSTREAM (\GETFONTDESC NEWFONT 'DISPLAY)) + (TEDIT.CARETLOOKS TSTREAM (FONTCREATE NEWFONT NIL NIL NIL 'DISPLAY)) (for PANE inpanes (PROGN TEXTOBJ) do (DSPFONT NEWFONT PANE))))]) (\TEDIT.TEXTEOFP @@ -2337,7 +2326,8 @@ TSTREAM))]) (\TEDIT.PIECE.RPLCHARCODE - [LAMBDA (TEXTOBJ PC OFFSET NEWCHARCODE NEWCHARLOOKS) (* ; "Edited 24-Apr-2025 16:30 by rmk") + [LAMBDA (TEXTOBJ PC OFFSET NEWCHARCODE NEWCHARLOOKS) (* ; "Edited 28-Jul-2025 23:38 by rmk") + (* ; "Edited 24-Apr-2025 16:30 by rmk") (* ; "Edited 20-Apr-2025 13:25 by rmk") (* ; "Edited 28-Mar-2025 10:04 by rmk") @@ -2353,7 +2343,7 @@ (MEMB (PTYPE PC) STRING.PTYPES) (OR (NULL NEWCHARLOOKS) - (EQ NEWCHARLOOKS (PLOOKS PC))) + (EQ NEWCHARLOOKS (PCHARLOOKS PC))) (NEQ PC (FGETTOBJ TEXTOBJ SUFFIXPIECE)) (NOT PARALAST)) then @@ -2375,7 +2365,7 @@ elseif [AND (IMAGEOBJP NEWCHARCODE) (EQ OBJECT.PTYPE (PTYPE PC)) (OR (NULL NEWCHARLOOKS) - (EQ NEWCHARLOOKS (PLOOKS PC] + (EQ NEWCHARLOOKS (PCHARLOOKS PC] then (SETQ OLDCHAR (POBJ PC)) (* ; "We know PLEN is 1") (FSETPC PC PCONTENTS NEWCHARCODE) else @@ -2419,11 +2409,11 @@ (FSETPC PC PCHARSET 0))) (FSETPC PC PFPOS NIL) (CL:WHEN NEWCHARLOOKS - (FSETPC PC PLOOKS (CL:IF (FONTP NEWCHARLOOKS) - (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CHARLOOKS.FROM.FONT - NEWCHARLOOKS) - TEXTOBJ) - NEWCHARLOOKS)))] + (FSETPC PC PCHARLOOKS (CL:IF (FONTP NEWCHARLOOKS) + (\TEDIT.UNIQUIFY.CHARLOOKS (\TEDIT.CHARLOOKS.FROM.FONT + NEWCHARLOOKS) + TEXTOBJ) + NEWCHARLOOKS)))] (CL:WHEN PARALAST (FSETPC PC PPARALAST T)) OLDCHAR]) @@ -2520,7 +2510,8 @@ T)]) (\TEDIT.INSERTCH - [LAMBDA (CH CH# TEXTOBJ PARALAST) (* ; "Edited 26-Mar-2025 00:29 by rmk") + [LAMBDA (CH CH# TEXTOBJ PARALAST) (* ; "Edited 26-Jul-2025 21:13 by rmk") + (* ; "Edited 26-Mar-2025 00:29 by rmk") (* ; "Edited 22-Nov-2024 13:48 by rmk") (* ; "Edited 22-Sep-2024 12:32 by rmk") (* ; "Edited 13-Aug-2024 08:30 by rmk") @@ -2603,7 +2594,7 @@ PCONTENTS _ INSERTION PLEN _ ILEN PCHARLOOKS _ (FGETTOBJ TEXTOBJ CARETLOOKS) - PPARALOOKS _ (PPARALOOKS (OR PREVPC INSERTPC)) + PPARALOOKS _ (PPARALOOKS (OR INSERTPC PREVPC)) PNEW _ T)) (SELECTC INSERTPTYPE (THINSTRING.PTYPE @@ -2967,7 +2958,8 @@ OLDITEMS]) (\TEDIT.TEXTPROP - [LAMBDA (TEXTOBJ PROP SETNEWVALUE NEWVALUE) (* ; "Edited 16-Feb-2025 23:27 by rmk") + [LAMBDA (TEXTOBJ PROP SETNEWVALUE NEWVALUE) (* ; "Edited 17-Jul-2025 00:19 by rmk") + (* ; "Edited 16-Feb-2025 23:27 by rmk") (* ; "Edited 15-Feb-2025 14:02 by rmk") (* ; "Edited 22-Dec-2024 00:23 by rmk") (* ; "Edited 23-Nov-2024 09:47 by rmk") @@ -2998,9 +2990,8 @@ (FSETTOBJ TEXTOBJ TXTREADONLY NEWVALUE) (FSETTOBJ TEXTOBJ TXTREADONLYQUIET (EQ 'QUIET NEWVALUE)) (\TEDIT.HISTORY.PROP TEXTOBJ T 'OFF)))) - ((BEING-EDITED ACTIVE) - (PROG1 (FGETTOBJ TEXTOBJ TXTEDITING) - (CL:IF SETNEWVALUE (FSETTOBJ TEXTOBJ TXTEDITING NEWVALUE)))) + (ACTIVE (PROG1 (FGETTOBJ TEXTOBJ EDITOPACTIVE) + (CL:IF SETNEWVALUE (FSETTOBJ TEXTOBJ EDITOPACTIVE NEWVALUE)))) (READTABLE (PROG1 (FGETTOBJ TEXTOBJ TXTRTBL) (CL:IF SETNEWVALUE (FSETTOBJ TEXTOBJ TXTRTBL NEWVALUE)))) (TERMTABLE (PROG1 (FSETTOBJ TEXTOBJ TXTTERMSA (fetch (TERMTABLEP TERMSA) of NEWVALUE)) @@ -3132,34 +3123,34 @@ (ADDTOVAR LAMA TEXTPROP) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (37559 68375 (\TEDIT.TEXTBIN 37569 . 48319) (\TEDIT.TEXTPEEKBIN 48321 . 53871) ( -\TEDIT.TEXTBACKFILEPTR 53873 . 59546) (\TEDIT.TEXTBOUT 59548 . 64165) (\TEDIT.INSTALL.FILEBUFFER 64167 - . 68373)) (69273 73564 (\TEDIT.TEXTOUTCHARFN 69283 . 70839) (\TEDIT.TEXTINCCODEFN 70841 . 71580) ( -\TEDIT.TEXTBACKCCODEFN 71582 . 72174) (\TEDIT.TEXTFORMATBYTESTREAM 72176 . 73013) ( -\TEDIT.TEXTFORMATBYTESTRING 73015 . 73562)) (73611 85252 (OPENTEXTSTREAM 73621 . 80573) ( -COPYTEXTSTREAM 80575 . 84475) (TEDIT.STREAMCHANGEDP 84477 . 84779) (TXTFILE 84781 . 85250)) (85253 -116062 (\TEDIT.REOPENTEXTSTREAM 85263 . 86615) (\TEDIT.OPENTEXTSTREAM.PIECES 86617 . 91551) ( -\TEDIT.OPENTEXTSTREAM.PROPS 91553 . 92655) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL 92657 . 97898) ( -\TEDIT.OPENTEXTSTREAM.WINDOW 97900 . 100691) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS 100693 . 103663) ( -\TEDIT.OPENTEXTFILE 103665 . 105378) (\TEDIT.CREATE.TEXTSTREAM 105380 . 106425) (\TEDIT.REOPEN.STREAM -106427 . 108763) (\TEDIT.TEXTINIT 108765 . 116060)) (116100 117288 (\TEDIT.TTYBOUT 116110 . 117286)) ( -117406 137175 (\TEDIT.TEXTCLOSEF 117416 . 118740) (\TEDIT.TEXTDSPFONT 118742 . 119712) ( -\TEDIT.TEXTEOFP 119714 . 121469) (\TEDIT.TEXTGETEOFPTR 121471 . 121794) (\TEDIT.TEXTSETEOFPTR 121796 - . 123083) (\TEDIT.TEXTGETFILEPTR 123085 . 125920) (\TEDIT.TEXTSETFILEINFO 125922 . 126430) ( -\TEDIT.TEXTOPENF 126432 . 127363) (\TEDIT.TEXTSETEOF 127365 . 127981) (\TEDIT.TEXTSETFILEPTR 127983 . -130093) (\TEDIT.TEXTDSPXPOSITION 130095 . 131112) (\TEDIT.TEXTDSPYPOSITION 131114 . 131855) ( -\TEDIT.TEXTLEFTMARGIN 131857 . 132448) (\TEDIT.TEXTCOLOR 132450 . 133033) (\TEDIT.TEXTRIGHTMARGIN -133035 . 136324) (\TEDIT.TEXTDSPCHARWIDTH 136326 . 136630) (\TEDIT.TEXTDSPSTRINGWIDTH 136632 . 136938) - (\TEDIT.TEXTDSPLINEFEED 136940 . 137173)) (137213 149689 (\TEDIT.NTHCHARCODE 137223 . 138674) ( -\TEDIT.PIECE.NTHCHARCODE 138676 . 142586) (\TEDIT.RPLCHARCODE 142588 . 144046) ( -\TEDIT.PIECE.RPLCHARCODE 144048 . 149334) (\TEDIT.NTHCHARLOOKS 149336 . 149687)) (150736 171721 ( -\TEDIT.DELETE.SELPIECES 150746 . 154371) (\TEDIT.INSERTCH 154373 . 162303) (\TEDIT.INSERTCH.HISTORY -162305 . 165769) (\TEDIT.INSERTEOL 165771 . 167596) (\TEDIT.INSERTCH.INSERTION 167598 . 170435) ( -\TEDIT.INSERTCH.EXTEND 170437 . 171719)) (171722 173226 (\TEDIT.NEXTCHANGEABLE.CHNO 171732 . 172447) ( -\TEDIT.LASTCHANGEABLE.CHNO 172449 . 173224)) (173227 174931 (\SETUPGETCH 173237 . 174929)) (174989 -179447 (\TEDIT.INSTALL.PIECE 174999 . 179445)) (179485 188499 (TEXTPROP 179495 . 179842) (GETTEXTPROP -179844 . 180088) (PUTTEXTPROP 180090 . 180347) (GETTEXTPROPS 180349 . 180793) (PUTTEXTPROPS 180795 . -181699) (TEXTPROP.ADD 181701 . 181964) (\TEDIT.TEXTPROP 181966 . 188497)) (188500 190570 ( -\TEDIT.TEXTOBJ.PROPNAMES 188510 . 189462) (\TEDIT.TEXTOBJ.PROPFETCHFN 189464 . 189980) ( -\TEDIT.TEXTOBJ.PROPSTOREFN 189982 . 190568))))) + (FILEMAP (NIL (36908 67724 (\TEDIT.TEXTBIN 36918 . 47668) (\TEDIT.TEXTPEEKBIN 47670 . 53220) ( +\TEDIT.TEXTBACKFILEPTR 53222 . 58895) (\TEDIT.TEXTBOUT 58897 . 63514) (\TEDIT.INSTALL.FILEBUFFER 63516 + . 67722)) (68622 72913 (\TEDIT.TEXTOUTCHARFN 68632 . 70188) (\TEDIT.TEXTINCCODEFN 70190 . 70929) ( +\TEDIT.TEXTBACKCCODEFN 70931 . 71523) (\TEDIT.TEXTFORMATBYTESTREAM 71525 . 72362) ( +\TEDIT.TEXTFORMATBYTESTRING 72364 . 72911)) (72960 84601 (OPENTEXTSTREAM 72970 . 79922) ( +COPYTEXTSTREAM 79924 . 83824) (TEDIT.STREAMCHANGEDP 83826 . 84128) (TXTFILE 84130 . 84599)) (84602 +114584 (\TEDIT.REOPENTEXTSTREAM 84612 . 85964) (\TEDIT.OPENTEXTSTREAM.PIECES 85966 . 90900) ( +\TEDIT.OPENTEXTSTREAM.PROPS 90902 . 92004) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL 92006 . 97247) ( +\TEDIT.OPENTEXTSTREAM.WINDOW 97249 . 100040) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS 100042 . 101981) ( +\TEDIT.OPENTEXTFILE 101983 . 103696) (\TEDIT.CREATE.TEXTSTREAM 103698 . 104845) (\TEDIT.REOPEN.STREAM +104847 . 107183) (\TEDIT.TEXTINIT 107185 . 114582)) (114622 115810 (\TEDIT.TTYBOUT 114632 . 115808)) ( +115928 135925 (\TEDIT.TEXTCLOSEF 115938 . 117262) (\TEDIT.TEXTDSPFONT 117264 . 118462) ( +\TEDIT.TEXTEOFP 118464 . 120219) (\TEDIT.TEXTGETEOFPTR 120221 . 120544) (\TEDIT.TEXTSETEOFPTR 120546 + . 121833) (\TEDIT.TEXTGETFILEPTR 121835 . 124670) (\TEDIT.TEXTSETFILEINFO 124672 . 125180) ( +\TEDIT.TEXTOPENF 125182 . 126113) (\TEDIT.TEXTSETEOF 126115 . 126731) (\TEDIT.TEXTSETFILEPTR 126733 . +128843) (\TEDIT.TEXTDSPXPOSITION 128845 . 129862) (\TEDIT.TEXTDSPYPOSITION 129864 . 130605) ( +\TEDIT.TEXTLEFTMARGIN 130607 . 131198) (\TEDIT.TEXTCOLOR 131200 . 131783) (\TEDIT.TEXTRIGHTMARGIN +131785 . 135074) (\TEDIT.TEXTDSPCHARWIDTH 135076 . 135380) (\TEDIT.TEXTDSPSTRINGWIDTH 135382 . 135688) + (\TEDIT.TEXTDSPLINEFEED 135690 . 135923)) (135963 148576 (\TEDIT.NTHCHARCODE 135973 . 137424) ( +\TEDIT.PIECE.NTHCHARCODE 137426 . 141336) (\TEDIT.RPLCHARCODE 141338 . 142796) ( +\TEDIT.PIECE.RPLCHARCODE 142798 . 148221) (\TEDIT.NTHCHARLOOKS 148223 . 148574)) (149623 170717 ( +\TEDIT.DELETE.SELPIECES 149633 . 153258) (\TEDIT.INSERTCH 153260 . 161299) (\TEDIT.INSERTCH.HISTORY +161301 . 164765) (\TEDIT.INSERTEOL 164767 . 166592) (\TEDIT.INSERTCH.INSERTION 166594 . 169431) ( +\TEDIT.INSERTCH.EXTEND 169433 . 170715)) (170718 172222 (\TEDIT.NEXTCHANGEABLE.CHNO 170728 . 171443) ( +\TEDIT.LASTCHANGEABLE.CHNO 171445 . 172220)) (172223 173927 (\SETUPGETCH 172233 . 173925)) (173985 +178443 (\TEDIT.INSTALL.PIECE 173995 . 178441)) (178481 187582 (TEXTPROP 178491 . 178838) (GETTEXTPROP +178840 . 179084) (PUTTEXTPROP 179086 . 179343) (GETTEXTPROPS 179345 . 179789) (PUTTEXTPROPS 179791 . +180695) (TEXTPROP.ADD 180697 . 180960) (\TEDIT.TEXTPROP 180962 . 187580)) (187583 189653 ( +\TEDIT.TEXTOBJ.PROPNAMES 187593 . 188545) (\TEDIT.TEXTOBJ.PROPFETCHFN 188547 . 189063) ( +\TEDIT.TEXTOBJ.PROPSTOREFN 189065 . 189651))))) STOP diff --git a/library/tedit/TEDIT-STREAM.LCOM b/library/tedit/TEDIT-STREAM.LCOM index 69243baaf..db8655802 100644 Binary files a/library/tedit/TEDIT-STREAM.LCOM and b/library/tedit/TEDIT-STREAM.LCOM differ diff --git a/library/tedit/TEDIT-TFBRAVO b/library/tedit/TEDIT-TFBRAVO index dfa977abe..9e2b9b10b 100644 --- a/library/tedit/TEDIT-TFBRAVO +++ b/library/tedit/TEDIT-TFBRAVO @@ -1,13 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "10-May-2025 12:53:24" {WMEDLEY}TEDIT>TEDIT-TFBRAVO.;183 97073 +(FILECREATED "28-Jul-2025 23:34:14"  +{DSK}kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-TFBRAVO.;185 97353 :EDIT-BY rmk - :CHANGES-TO (FNS \TFBRAVO.GET.USER.CM TEDITFROMBRAVO \TFBRAVO.USER.CM.LOOKS) - (VARS TEDIT-TFBRAVOCOMS) + :CHANGES-TO (FNS \TFBRAVO.INSERT.RUN \TFBRAVO.INIT.PARALOOKS) - :PREVIOUS-DATE " 9-May-2025 09:51:51" {WMEDLEY}TEDIT>TEDIT-TFBRAVO.;178) + :PREVIOUS-DATE "10-May-2025 12:53:24" {WMEDLEY}TEDIT>TEDIT-TFBRAVO.;183) (PRETTYCOMPRINT TEDIT-TFBRAVOCOMS) @@ -419,7 +419,8 @@ (GO LLP)))]) (\TFBRAVO.INIT.PARALOOKS - [LAMBDA (ALIST) (* ; "Edited 8-Feb-2025 22:09 by rmk") + [LAMBDA (ALIST) (* ; "Edited 28-Jul-2025 23:12 by rmk") + (* ; "Edited 8-Feb-2025 22:09 by rmk") (* ; "Edited 4-Aug-2024 22:17 by rmk") (* ; "Edited 28-Jul-2024 21:36 by rmk") (* ; "Edited 13-Aug-2023 11:27 by rmk") @@ -429,7 +430,7 @@ (* ;; "creates the default paragraph looks from the USER.CM. The numeric values are Bravo defaults as specfied in the Bravo documentation. This assumes that all mica values in the USER.CM have already been converted to points. ") - (LET ((INITPARALOOKS (create PARALOOKS using TEDIT.DEFAULT.FMTSPEC))) + (LET ((INITPARALOOKS (\TEDIT.PARSE.PARALOOKS.LIST TEDIT.DEFAULT.PARALOOKS))) (* ;; "Bravo User Manual says that default tab is 36, the Bravo file format document says 60. I'm going with 36.") @@ -1010,7 +1011,8 @@ (\TFBRAVO.INSERT.RUN RUN BSTREAM PARALOOKS TEXTOBJ]) (\TFBRAVO.INSERT.RUN - [LAMBDA (RUN BSTREAM PARALOOKS TEXTOBJ) (* ; "Edited 8-Feb-2025 23:08 by rmk") + [LAMBDA (RUN BSTREAM PARALOOKS TEXTOBJ) (* ; "Edited 28-Jul-2025 23:33 by rmk") + (* ; "Edited 8-Feb-2025 23:08 by rmk") (* ; "Edited 17-Mar-2024 12:41 by rmk") (* ; "Edited 16-Jan-2024 18:28 by rmk") (* ; "Edited 29-Dec-2023 11:50 by rmk") @@ -1030,8 +1032,9 @@ FATP PC) (SETQ PC (create PIECE PLEN _ NCHARS - PLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (RUN RUNLOOKS) of RUN) - TEXTOBJ) + PCHARLOOKS _ (\TEDIT.UNIQUIFY.CHARLOOKS (fetch (RUN RUNLOOKS) + of RUN) + TEXTOBJ) PPARALOOKS _ (\TEDIT.UNIQUIFY.PARALOOKS PARALOOKS TEXTOBJ) PPARALAST _ (fetch (RUN RUNLAST) of RUN))) (if (STRINGP RUNSTART) @@ -1552,18 +1555,18 @@ (AND NIL (\TEDIT.NAMEDTAB.INIT)) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (7682 14673 (TEDIT.BRAVOFILE? 7692 . 9422) (TEDITFROMBRAVO 9424 . 14671)) (14784 31092 ( -\TFBRAVO.GET.USER.CM 14794 . 17974) (\TFBRAVO.USER.CM.LOOKS 17976 . 19469) (\TFBRAVO.READ.USER.CM -19471 . 24094) (\TFBRAVO.INIT.PARALOOKS 24096 . 26205) (\TFBRAVO.INIT.PAGEFORMAT 26207 . 27087) ( -\TFBRAVO.GETPARAMS 27089 . 29943) (\TFBRAVO.FIND.LAST.TRAILER 29945 . 31090)) (31134 51832 ( -\TFBRAVO.PARSE.PARA 31144 . 35071) (\TFBRAVO.READ.PARALOOKS 35073 . 41963) (\TFBRAVO.CREATE.RUNS 41965 - . 43353) (\TFBRAVO.READ.CHARLOOKS 43355 . 48384) (\TFBRAVO.FONT.FROM.CHARLOOKS 48386 . 49933) ( -\TFBRAVO.READNUM? 49935 . 51830)) (51869 62910 (\TFBRAVO.HANDLE.HEADING 51879 . 54606) ( -\TFBRAVO.PARSE.PROFILE.PARA 54608 . 62908)) (62953 85098 (\TFBRAVO.INSERT.PARA 62963 . 63804) ( -\TFBRAVO.INSERT.RUN 63806 . 67108) (\TFBRAVO.SPLIT.PARA 67110 . 74534) (\TFBRAVO.RUN.TABSPEC 74536 . -79403) (\TFBRAVO.INSTALL.PAGEFORMAT 79405 . 85096)) (85099 89242 (\TFBRAVO.ASSERT 85109 . 85639) ( -\TEST.CHARACTER.LOOKS 85641 . 87527) (\TEST.PARAGRAPH.LOOKS 87529 . 89240)) (90252 96907 ( -\TFBRAVO.ADD.NAMEDTAB 90262 . 93865) (\TFBRAVO.COPY.NAMEDTAB 93867 . 94315) (\TFBRAVO.PUT.NAMEDTAB -94317 . 94597) (\TFBRAVO.GET.NAMEDTAB 94599 . 94976) (\NAMEDTABNYET 94978 . 95138) (\NAMEDTABSIZE -95140 . 95655) (\NAMEDTABPREPRINT 95657 . 95855) (\TEDIT.NAMEDTAB.INIT 95857 . 96905))))) + (FILEMAP (NIL (7665 14656 (TEDIT.BRAVOFILE? 7675 . 9405) (TEDITFROMBRAVO 9407 . 14654)) (14767 31183 ( +\TFBRAVO.GET.USER.CM 14777 . 17957) (\TFBRAVO.USER.CM.LOOKS 17959 . 19452) (\TFBRAVO.READ.USER.CM +19454 . 24077) (\TFBRAVO.INIT.PARALOOKS 24079 . 26296) (\TFBRAVO.INIT.PAGEFORMAT 26298 . 27178) ( +\TFBRAVO.GETPARAMS 27180 . 30034) (\TFBRAVO.FIND.LAST.TRAILER 30036 . 31181)) (31225 51923 ( +\TFBRAVO.PARSE.PARA 31235 . 35162) (\TFBRAVO.READ.PARALOOKS 35164 . 42054) (\TFBRAVO.CREATE.RUNS 42056 + . 43444) (\TFBRAVO.READ.CHARLOOKS 43446 . 48475) (\TFBRAVO.FONT.FROM.CHARLOOKS 48477 . 50024) ( +\TFBRAVO.READNUM? 50026 . 51921)) (51960 63001 (\TFBRAVO.HANDLE.HEADING 51970 . 54697) ( +\TFBRAVO.PARSE.PROFILE.PARA 54699 . 62999)) (63044 85378 (\TFBRAVO.INSERT.PARA 63054 . 63895) ( +\TFBRAVO.INSERT.RUN 63897 . 67388) (\TFBRAVO.SPLIT.PARA 67390 . 74814) (\TFBRAVO.RUN.TABSPEC 74816 . +79683) (\TFBRAVO.INSTALL.PAGEFORMAT 79685 . 85376)) (85379 89522 (\TFBRAVO.ASSERT 85389 . 85919) ( +\TEST.CHARACTER.LOOKS 85921 . 87807) (\TEST.PARAGRAPH.LOOKS 87809 . 89520)) (90532 97187 ( +\TFBRAVO.ADD.NAMEDTAB 90542 . 94145) (\TFBRAVO.COPY.NAMEDTAB 94147 . 94595) (\TFBRAVO.PUT.NAMEDTAB +94597 . 94877) (\TFBRAVO.GET.NAMEDTAB 94879 . 95256) (\NAMEDTABNYET 95258 . 95418) (\NAMEDTABSIZE +95420 . 95935) (\NAMEDTABPREPRINT 95937 . 96135) (\TEDIT.NAMEDTAB.INIT 96137 . 97185))))) STOP diff --git a/library/tedit/TEDIT-TFBRAVO.LCOM b/library/tedit/TEDIT-TFBRAVO.LCOM index 2ef5d468d..b6b5aa027 100644 Binary files a/library/tedit/TEDIT-TFBRAVO.LCOM and b/library/tedit/TEDIT-TFBRAVO.LCOM differ diff --git a/library/tedit/TEDIT-WINDOW b/library/tedit/TEDIT-WINDOW index 6a9754708..758e60e90 100644 --- a/library/tedit/TEDIT-WINDOW +++ b/library/tedit/TEDIT-WINDOW @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "21-Jul-2025 11:55:26" {WMEDLEY}TEDIT>TEDIT-WINDOW.;861 229641 +(FILECREATED "26-Jul-2025 15:45:59" {WMEDLEY}TEDIT>TEDIT-WINDOW.;862 229373 :EDIT-BY rmk - :CHANGES-TO (FNS \TEDIT.WINDOW.CREATE) + :CHANGES-TO (FNS \TEDIT.SET.WINDOW.EXTENT) - :PREVIOUS-DATE "30-May-2025 12:54:56" {WMEDLEY}TEDIT>TEDIT-WINDOW.;860) + :PREVIOUS-DATE "21-Jul-2025 11:55:26" {WMEDLEY}TEDIT>TEDIT-WINDOW.;861) (PRETTYCOMPRINT TEDIT-WINDOWCOMS) @@ -937,7 +937,8 @@ (RETURN MOVINGPOINT]) (\TEDIT.SET.WINDOW.EXTENT - [LAMBDA (TEXTOBJ PANE) (* ; "Edited 1-Dec-2024 11:28 by rmk") + [LAMBDA (TEXTOBJ PANE) (* ; "Edited 26-Jul-2025 15:45 by rmk") + (* ; "Edited 1-Dec-2024 11:28 by rmk") (* ; "Edited 29-Nov-2024 10:59 by rmk") (* ; "Edited 17-Nov-2024 18:59 by rmk") (* ; "Edited 28-Jun-2024 15:11 by rmk") @@ -960,55 +961,44 @@ (LET ((TEXTLEN (FGETTOBJ TEXTOBJ TEXTLEN)) (PHEIGHT (PANEHEIGHT PANE)) (PBOTTOM (PANEBOTTOM PANE)) - FIRSTLINE LASTLINE TOPCHAR BOTCHAR EXTHEIGHT EXTBOT YBOT) - - (* ;; "First visible line") - - (SETQ FIRSTLINE (find L inlines (PANEPREFIX PANE) - suchthat (ILESSP (FGETLD L YBOT) - PHEIGHT))) - - (* ;; "Last visible line") - - (for L inlines FIRSTLINE while (IGEQ (FGETLD L YBOT) - PBOTTOM) do (SETQ LASTLINE L)) + (FIRSTLINE (PANETOPLINE PANE)) + (LASTLINE (PANEBOTTOMLINE PANE)) + TOPCHAR BOTCHAR EXTHEIGHT EXTBOT YBOT) (* ;; "Start of first visible line") (SETQ TOPCHAR (CL:IF FIRSTLINE (FGETLD FIRSTLINE LCHAR1) TEXTLEN)) - (COND - (LASTLINE - - (* ;; "There IS a last line on the screen. Grab its last character as the bottom character on the screen, and set the lowest-Y position to the bottom of that line") - - (SETQ BOTCHAR (IMIN TEXTLEN (FGETLD LASTLINE LCHARLAST))) - (SETQ YBOT (FGETLD LASTLINE YBOT))) - (T - (* ;; "Everything is off the top of the screen. Bottom character is also the last char in the document, and the lowest Y we encountered is the top of the edit window.") - - (SETQ BOTCHAR TEXTLEN) - (SETQ YBOT PHEIGHT))) - [COND - ((AND (IEQP BOTCHAR TEXTLEN) - (IEQP TOPCHAR TEXTLEN)) (* ; "At the bottom of the document") - (SETQ EXTBOT (SUB1 YBOT)) - (SETQ EXTHEIGHT PHEIGHT)) - (T - (* ;; "Otherwise, set the bottom in proportion to what is left below the bottom of the screen, and the extent height in proportion to how much text appears in the window") - - [SETQ EXTHEIGHT (FIXR (FQUOTIENT (ITIMES (IDIFFERENCE PHEIGHT YBOT) - TEXTLEN) - (IMAX (IDIFFERENCE BOTCHAR TOPCHAR) - 1] - (SETQ EXTBOT (IDIFFERENCE YBOT (FIXR (FQUOTIENT (ITIMES (IDIFFERENCE PHEIGHT - YBOT) - (IDIFFERENCE TEXTLEN - BOTCHAR)) - (IMAX (IDIFFERENCE BOTCHAR TOPCHAR - ) - 1] + (if LASTLINE + then + (* ;; "There IS a last line on the screen. Grab its last character as the bottom character on the screen, and set the lowest-Y position to the bottom of that line") + + (SETQ BOTCHAR (IMIN TEXTLEN (FGETLD LASTLINE LCHARLAST))) + (SETQ YBOT (FGETLD LASTLINE YBOT)) + else + (* ;; "Everything is off the top of the screen. Bottom character is also the last char in the document, and the lowest Y we encountered is the top of the edit window.") + + (SETQ BOTCHAR TEXTLEN) + (SETQ YBOT PHEIGHT)) + [if (AND (IEQP BOTCHAR TEXTLEN) + (IEQP TOPCHAR TEXTLEN)) + then (SETQ EXTBOT (SUB1 YBOT)) (* ; "At the bottom of the document") + (SETQ EXTHEIGHT PHEIGHT) + else + (* ;; "Otherwise, set the bottom in proportion to what is left below the bottom of the screen, and the extent height in proportion to how much text appears in the window") + + [SETQ EXTHEIGHT (FIXR (FQUOTIENT (ITIMES (IDIFFERENCE PHEIGHT YBOT) + TEXTLEN) + (IMAX (IDIFFERENCE BOTCHAR TOPCHAR) + 1] + (SETQ EXTBOT (IDIFFERENCE YBOT (FIXR (FQUOTIENT (ITIMES (IDIFFERENCE PHEIGHT + YBOT) + (IDIFFERENCE TEXTLEN + BOTCHAR)) + (IMAX (IDIFFERENCE BOTCHAR + TOPCHAR) + 1] (WINDOWPROP PANE 'EXTENT (create REGION BOTTOM _ EXTBOT HEIGHT _ (IMAX 1 EXTHEIGHT) @@ -3629,36 +3619,36 @@ (RPAQ? TEDIT.TITLED.ICON.TEMPLATE (create TITLEDICON ICON _ TEDITICON MASK _ TEDITMASK TITLEREG _ TEDIT.ICON.TITLE.REGION)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (17100 17996 (TEDIT.DEFER.UPDATES 17110 . 17994)) (17997 43942 (\TEDIT.WINDOW.CREATE -18007 . 25337) (\TEDIT.WINDOW.GETREGION 25339 . 28829) (\TEDIT.WINDOW.SETUP 28831 . 33161) ( -\TEDIT.MINIMAL.WINDOW.SETUP 33163 . 40574) (\TEDIT.CLEARPANE 40576 . 41293) (\TEDIT.FILL.PANES 41295 - . 43940)) (43943 67916 (\TEDIT.CURSORMOVEDFN 43953 . 49563) (\TEDIT.CURSOROUTFN 49565 . 50253) ( -\TEDIT.ACTIVE.WINDOWP 50255 . 51325) (\TEDIT.EXPANDFN 51327 . 51890) (\TEDIT.MAINW 51892 . 53172) ( -\TEDIT.MAINSTREAM 53174 . 53508) (\TEDIT.PRIMARYPANE 53510 . 54280) (\TEDIT.PANELIST 54282 . 54778) ( -\TEDIT.NEWREGIONFN 54780 . 57296) (\TEDIT.SET.WINDOW.EXTENT 57298 . 62552) (\TEDIT.SHRINK.ICONCREATE -62554 . 65287) (\TEDIT.SHRINKFN 65289 . 65698) (\TEDIT.PANEREGION 65700 . 67914)) (67948 100994 ( -\TEDIT.BUTTONEVENTFN 67958 . 80931) (\TEDIT.BUTTONEVENTFN.DOOPERATION 80933 . 88196) ( -\TEDIT.BUTTONEVENTFN.GETOPERATION 88198 . 90040) (\TEDIT.BUTTONEVENTFN.CURSEL.INIT 90042 . 93712) ( -\TEDIT.BUTTONEVENTFN.INACTIVE 93714 . 96144) (\TEDIT.BUTTONEVENTFN.INTITLE 96146 . 97981) ( -\TEDIT.COPYINSERTFN 97983 . 99115) (\TEDIT.FOREIGN.COPY 99117 . 100992)) (100995 118237 ( -\TEDIT.PANE.SPLIT 101005 . 104953) (\TEDIT.SPLITW 104955 . 112693) (\TEDIT.UNSPLITW 112695 . 116894) ( -\TEDIT.LINKPANES 116896 . 117659) (\TEDIT.UNLINKPANE 117661 . 118235)) (119671 120562 (TEDITWINDOWP -119681 . 120560)) (120599 123702 (TEDIT.GETINPUT 120609 . 123052) (\TEDIT.MAKEFILENAME 123054 . 123700 -)) (123751 131378 (TEDIT.PROMPTWINDOW 123761 . 124075) (TEDIT.PROMPTPRINT 124077 . 126704) ( -TEDIT.PROMPTCLEAR 126706 . 128425) (TEDIT.PROMPTFLASH 128427 . 129685) (\TEDIT.PROMPT.PAGEFULLFN -129687 . 131376)) (131616 142020 (\TEDIT.FILENAME 131626 . 132398) (\TEDIT.DEFAULT.TITLE 132400 . -134779) (\TEDIT.WINDOW.TITLE 134781 . 136950) (\TEDIT.LIKELY.FILENAME 136952 . 139502) ( -\TEDIT.UPDATE.TITLE 139504 . 142018)) (142063 154547 (TEDIT.DEACTIVATE.WINDOW 142073 . 147646) ( -\TEDIT.RESHAPEFN 147648 . 149733) (\TEDIT.REPAINTFN 149735 . 149959) (\TEDIT.CLOSESPLITS 149961 . -152406) (\TEDIT.CLOSEPANE 152408 . 154545)) (154548 197347 (\TEDIT.SCROLLFN 154558 . 156789) ( -\TEDIT.SCROLLCH.TOP 156791 . 158902) (\TEDIT.SCROLLCH.BOTTOM 158904 . 163234) (\TEDIT.SCROLLUP 163236 - . 168962) (\TEDIT.TOPLINE.YTOP 168964 . 170633) (\TEDIT.SCROLLDOWN 170635 . 177674) ( -\TEDIT.SCROLL.CARET 177676 . 180514) (\TEDIT.VISIBLECARETP 180516 . 182810) (\TEDIT.VISIBLECHARP -182812 . 183903) (\TEDIT.BITMAPLINES 183905 . 187825) (\TEDIT.SETPANE.TOPLINE 187827 . 188439) ( -\TEDIT.SHIFTLINES 188441 . 197345)) (197348 208217 (\TEDIT.ONSCREEN? 197358 . 201909) ( -\TEDIT.ONSCREEN.REGION 201911 . 205562) (\TEDIT.AFTERMOVEFN 205564 . 206461) (OFFSCREENP 206463 . -208215)) (208259 211073 (\TEDIT.PROCIDLEFN 208269 . 209929) (\TEDIT.PROCENTRYFN 209931 . 210376) ( -\TEDIT.PROCEXITFN 210378 . 211071)) (211152 224377 (\TEDIT.DOWNCARET 211162 . 211955) ( -\TEDIT.FLASHCARET 211957 . 214068) (\TEDIT.UPCARET 214070 . 215174) (TEDIT.NORMALIZECARET 215176 . -218394) (\TEDIT.SETCARET 218396 . 223747) (\TEDIT.CARET 223749 . 224375))))) + (FILEMAP (NIL (17104 18000 (TEDIT.DEFER.UPDATES 17114 . 17998)) (18001 43946 (\TEDIT.WINDOW.CREATE +18011 . 25341) (\TEDIT.WINDOW.GETREGION 25343 . 28833) (\TEDIT.WINDOW.SETUP 28835 . 33165) ( +\TEDIT.MINIMAL.WINDOW.SETUP 33167 . 40578) (\TEDIT.CLEARPANE 40580 . 41297) (\TEDIT.FILL.PANES 41299 + . 43944)) (43947 67648 (\TEDIT.CURSORMOVEDFN 43957 . 49567) (\TEDIT.CURSOROUTFN 49569 . 50257) ( +\TEDIT.ACTIVE.WINDOWP 50259 . 51329) (\TEDIT.EXPANDFN 51331 . 51894) (\TEDIT.MAINW 51896 . 53176) ( +\TEDIT.MAINSTREAM 53178 . 53512) (\TEDIT.PRIMARYPANE 53514 . 54284) (\TEDIT.PANELIST 54286 . 54782) ( +\TEDIT.NEWREGIONFN 54784 . 57300) (\TEDIT.SET.WINDOW.EXTENT 57302 . 62284) (\TEDIT.SHRINK.ICONCREATE +62286 . 65019) (\TEDIT.SHRINKFN 65021 . 65430) (\TEDIT.PANEREGION 65432 . 67646)) (67680 100726 ( +\TEDIT.BUTTONEVENTFN 67690 . 80663) (\TEDIT.BUTTONEVENTFN.DOOPERATION 80665 . 87928) ( +\TEDIT.BUTTONEVENTFN.GETOPERATION 87930 . 89772) (\TEDIT.BUTTONEVENTFN.CURSEL.INIT 89774 . 93444) ( +\TEDIT.BUTTONEVENTFN.INACTIVE 93446 . 95876) (\TEDIT.BUTTONEVENTFN.INTITLE 95878 . 97713) ( +\TEDIT.COPYINSERTFN 97715 . 98847) (\TEDIT.FOREIGN.COPY 98849 . 100724)) (100727 117969 ( +\TEDIT.PANE.SPLIT 100737 . 104685) (\TEDIT.SPLITW 104687 . 112425) (\TEDIT.UNSPLITW 112427 . 116626) ( +\TEDIT.LINKPANES 116628 . 117391) (\TEDIT.UNLINKPANE 117393 . 117967)) (119403 120294 (TEDITWINDOWP +119413 . 120292)) (120331 123434 (TEDIT.GETINPUT 120341 . 122784) (\TEDIT.MAKEFILENAME 122786 . 123432 +)) (123483 131110 (TEDIT.PROMPTWINDOW 123493 . 123807) (TEDIT.PROMPTPRINT 123809 . 126436) ( +TEDIT.PROMPTCLEAR 126438 . 128157) (TEDIT.PROMPTFLASH 128159 . 129417) (\TEDIT.PROMPT.PAGEFULLFN +129419 . 131108)) (131348 141752 (\TEDIT.FILENAME 131358 . 132130) (\TEDIT.DEFAULT.TITLE 132132 . +134511) (\TEDIT.WINDOW.TITLE 134513 . 136682) (\TEDIT.LIKELY.FILENAME 136684 . 139234) ( +\TEDIT.UPDATE.TITLE 139236 . 141750)) (141795 154279 (TEDIT.DEACTIVATE.WINDOW 141805 . 147378) ( +\TEDIT.RESHAPEFN 147380 . 149465) (\TEDIT.REPAINTFN 149467 . 149691) (\TEDIT.CLOSESPLITS 149693 . +152138) (\TEDIT.CLOSEPANE 152140 . 154277)) (154280 197079 (\TEDIT.SCROLLFN 154290 . 156521) ( +\TEDIT.SCROLLCH.TOP 156523 . 158634) (\TEDIT.SCROLLCH.BOTTOM 158636 . 162966) (\TEDIT.SCROLLUP 162968 + . 168694) (\TEDIT.TOPLINE.YTOP 168696 . 170365) (\TEDIT.SCROLLDOWN 170367 . 177406) ( +\TEDIT.SCROLL.CARET 177408 . 180246) (\TEDIT.VISIBLECARETP 180248 . 182542) (\TEDIT.VISIBLECHARP +182544 . 183635) (\TEDIT.BITMAPLINES 183637 . 187557) (\TEDIT.SETPANE.TOPLINE 187559 . 188171) ( +\TEDIT.SHIFTLINES 188173 . 197077)) (197080 207949 (\TEDIT.ONSCREEN? 197090 . 201641) ( +\TEDIT.ONSCREEN.REGION 201643 . 205294) (\TEDIT.AFTERMOVEFN 205296 . 206193) (OFFSCREENP 206195 . +207947)) (207991 210805 (\TEDIT.PROCIDLEFN 208001 . 209661) (\TEDIT.PROCENTRYFN 209663 . 210108) ( +\TEDIT.PROCEXITFN 210110 . 210803)) (210884 224109 (\TEDIT.DOWNCARET 210894 . 211687) ( +\TEDIT.FLASHCARET 211689 . 213800) (\TEDIT.UPCARET 213802 . 214906) (TEDIT.NORMALIZECARET 214908 . +218126) (\TEDIT.SETCARET 218128 . 223479) (\TEDIT.CARET 223481 . 224107))))) STOP diff --git a/library/tedit/TEDIT-WINDOW.LCOM b/library/tedit/TEDIT-WINDOW.LCOM index b09443701..9dd57e66f 100644 Binary files a/library/tedit/TEDIT-WINDOW.LCOM and b/library/tedit/TEDIT-WINDOW.LCOM differ diff --git a/lispusers/NSDISPLAYSIZES b/lispusers/NSDISPLAYSIZES index 6e54589e3..207b126d7 100644 --- a/lispusers/NSDISPLAYSIZES +++ b/lispusers/NSDISPLAYSIZES @@ -1,19 +1,18 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "10-Apr-2024 09:49:11" {WMEDLEY}NSDISPLAYSIZES.;5 9232 +(FILECREATED "15-Jul-2025 10:25:11" {WMEDLEY}NSDISPLAYSIZES.;7 7757 :EDIT-BY rmk - :CHANGES-TO (FNS NSDISPLAYSIZE) + :CHANGES-TO (FNS PURGENSFONTS) - :PREVIOUS-DATE " 8-Apr-2024 11:48:01" {WMEDLEY}NSDISPLAYSIZES.;4) + :PREVIOUS-DATE " 9-Jun-2025 19:52:26" {WMEDLEY}NSDISPLAYSIZES.;6) (PRETTYCOMPRINT NSDISPLAYSIZESCOMS) (RPAQQ NSDISPLAYSIZESCOMS [(FNS NSDISPLAYSIZE NS\FONTFILENAME NS\FONTFILENAME.OLD PURGENSFONTS) - (ADDVARS (NSFONTFAMILIES CLASSIC MODERN TERMINAL OPTIMA TITAN)) (INITVARS (*SMALLSCREEN* (ILESSP SCREENWIDTH 700))) [COMS (* ;  "VirtualKeyboard font needs adjusting so that real Classic 12 still appears") @@ -90,45 +89,20 @@ FACE EXTENSION CHARACTERSET]) (PURGENSFONTS - [LAMBDA (TYPES) (* ; "Edited 14-Sep-96 09:27 by rmk:") - (* ; "Edited 14-Dec-87 14:53 by bvm:") - (/SETTOPVAL - '\FONTSINCORE - (FOR ENTRY IN \FONTSINCORE BIND BADTYPES TMP - COLLECT - (SETQ BADTYPES (IF (AND (MEMB (CAR ENTRY) - NSFONTFAMILIES) - (OR (NULL TYPES) - (EQMEMB 'NS TYPES))) - THEN (CONS 'DISPLAY TYPES) - ELSE (MKLIST TYPES))) - (CONS - (CAR ENTRY) - (FOR SIZES IN (CDR ENTRY) - WHEN [SETQ TMP - (IF (AND (NULL TYPES) - (> (CAR SIZES) - 12)) - THEN (* ; - "Only have to get rid of sizes smaller than 14") - (CDR SIZES) - ELSE (FOR FACE IN (CDR SIZES) - WHEN (SETQ TMP - (FOR ROT IN (CDR FACE) - WHEN (SETQ TMP (FOR DEV - IN (CDR ROT) COLLECT - DEV - UNLESS (MEMB (CAR DEV) - BADTYPES))) - COLLECT (CONS (CAR ROT) - TMP))) - COLLECT (CONS (CAR FACE) - TMP] COLLECT (CONS (CAR SIZES) - TMP]) + [LAMBDA (TYPES) (* ; "Edited 15-Jul-2025 09:47 by rmk") + (* ; "Edited 14-Sep-96 09:27 by rmk:") + (* ; "Edited 14-Dec-87 14:53 by bvm:") + + (* ;; "Removes current NS display fonts with sizes LEQ 12. No need to be undoable, cache entries will be recreated on demand.") + + (DECLARE (GLOBALVARS \FONTSINCORE)) + (MAPMULTI \FONTSINCORE (FUNCTION (LAMBDA (FM S FC R TAIL) + (CL:WHEN (AND (MEMB FM NSFONTFAMILIES) + (ILEQ S 12) + (EQ 'DISPLAY (CAR TAIL))) + (RPLACD TAIL]) ) -(ADDTOVAR NSFONTFAMILIES CLASSIC MODERN TERMINAL OPTIMA TITAN) - (RPAQ? *SMALLSCREEN* (ILESSP SCREENWIDTH 700)) @@ -170,7 +144,7 @@ (VKBD.FIX.FONT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1522 7564 (NSDISPLAYSIZE 1532 . 4862) (NS\FONTFILENAME 4864 . 5105) ( -NS\FONTFILENAME.OLD 5107 . 5356) (PURGENSFONTS 5358 . 7562)) (7776 8814 (VKBD.FIX.FONT 7786 . 8812)))) + (FILEMAP (NIL (1449 6157 (NSDISPLAYSIZE 1459 . 4789) (NS\FONTFILENAME 4791 . 5032) ( +NS\FONTFILENAME.OLD 5034 . 5283) (PURGENSFONTS 5285 . 6155)) (6301 7339 (VKBD.FIX.FONT 6311 . 7337)))) ) STOP diff --git a/lispusers/NSDISPLAYSIZES.LCOM b/lispusers/NSDISPLAYSIZES.LCOM index b77f701e9..7cae55885 100644 Binary files a/lispusers/NSDISPLAYSIZES.LCOM and b/lispusers/NSDISPLAYSIZES.LCOM differ diff --git a/lispusers/PRESSFROMNS b/lispusers/PRESSFROMNS index eb26ff15b..9817f18d6 100644 --- a/lispusers/PRESSFROMNS +++ b/lispusers/PRESSFROMNS @@ -1,66 +1,61 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 9-Mar-88 15:54:25" {IVY}LISP>MEDLEY>PRESSFROMNS.;13 81335 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (VARS PRESSFROMNSCOMS) - (FNS \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS \CREATEPRESSFONT \COERCEFONT) - (RECORDS PRESSDATA) +(FILECREATED "14-Jul-2025 23:24:28"  +{DSK}kaplan>Local>medley3.5>working-medley>lispusers>PRESSFROMNS.;3 80159 - previous date%: " 4-Mar-88 12:52:46" {IVY}LISP>MEDLEY>PRESSFROMNS.;9) + :EDIT-BY rmk + :CHANGES-TO (FNS GETCHARPRESSTRANSLATION PUTCHARPRESSTRANSLATION) + + :PREVIOUS-DATE " 5-Jul-2025 18:52:47" +{DSK}kaplan>Local>medley3.5>working-medley>lispusers>PRESSFROMNS.;2) -(* " -Copyright (c) 1986, 1988 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT PRESSFROMNSCOMS) -(RPAQQ PRESSFROMNSCOMS [(* This file uses CONSTANTS defined in PRESS, so it is necessary to - LOADFROM PRESS before changing this file.) - (FNS \SMASHPRESSFONTS) - (FNS GETCHARPRESSTRANSLATION PRESS.NSARRAY PUTCHARPRESSTRANSLATION) - (FNS \DSPFONT.PRESS \DSPSPACEFACTOR.PRESS \ENTITYSTART.PRESS - \SETSPACE.PRESS \STARTPAGE.PRESS \PRESS.COERCEFONT - \DSPFONT.PRESSFONT SETUPFONTS.PRESS) - (FNS \CREATEPRESSFONT \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS) - (FNS \PRESSCURVE2) - (COMS (* Generic utility for coercing fonts, could be used by other - devices) - (FNS \COERCEFONT)) - (ALISTS (FONTCOERCIONS PRESS) - (MISSINGFONTCOERCIONS PRESS)) - (GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS) - (FNS \STRINGWIDTH.PRESS \CHARWIDTH.PRESS \OUTCHARFN.PRESS) - (* * new declaration for PRESSDATA) - (DECLARE%: DONTCOPY (RECORDS PRESSDATA)) - (INITRECORDS PRESSDATA) - (* * NSTOASCIITRANSLATIONS is a list with elements of the form - (charset translationArrayName) - %, where translationArrayName is bound to a translation array for - charset which contains (fontFamily charcode) - lists) - (FNS \NSTOASCIIARRAY \NSTOASCIITRANSLATION) - (GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES) - [INITVARS (PRESSFONTFAMILIES '((GACHA) - (TIMESROMAN) - (HELVETICA) - (SYMBOL) - (MATH) - (HIPPO) - (CYRILLIC) - (NEWVEC) - (SNEWVEC) - (HNEWVEC) - (VNEWVEC] - (INITVARS (NSTOASCIITRANSLATIONS)) - (ADDVARS (NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY) - (38 ASCIIFROM38ARRAY) - (39 ASCIIFROM39ARRAY) - (239 ASCIIFROM239ARRAY))) - (UGLYVARS ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY - ASCIIFROM239ARRAY) - (P (\SMASHPRESSFONTS)) - (DECLARE%: DONTCOPY (CONSTANTS (unknownCharTranslation - '(MATH 59]) +(RPAQQ PRESSFROMNSCOMS + [(* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before + changing this file.) + (FNS \SMASHPRESSFONTS) + (FNS GETCHARPRESSTRANSLATION PRESS.NSARRAY PUTCHARPRESSTRANSLATION) + (FNS \DSPFONT.PRESS \DSPSPACEFACTOR.PRESS \ENTITYSTART.PRESS \SETSPACE.PRESS \STARTPAGE.PRESS + \PRESS.COERCEFONT \DSPFONT.PRESSFONT SETUPFONTS.PRESS) + (FNS \CREATEPRESSFONT \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS) + (FNS \PRESSCURVE2) + (COMS (* Generic utility for coercing fonts, could be used by other devices) + (FNS \COERCEFONT)) + (ALISTS (FONTCOERCIONS PRESS) + (MISSINGFONTCOERCIONS PRESS)) + (GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS) + (FNS \STRINGWIDTH.PRESS \CHARWIDTH.PRESS \OUTCHARFN.PRESS) + (* * new declaration for PRESSDATA) + (DECLARE%: DONTCOPY (RECORDS PRESSDATA)) + (INITRECORDS PRESSDATA) + (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) + %, where translationArrayName is bound to a translation array for charset which contains + (fontFamily charcode) + lists) + (FNS \NSTOASCIIARRAY \NSTOASCIITRANSLATION) + (GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES) + [INITVARS (PRESSFONTFAMILIES '((GACHA) + (TIMESROMAN) + (HELVETICA) + (SYMBOL) + (MATH) + (HIPPO) + (CYRILLIC) + (NEWVEC) + (SNEWVEC) + (HNEWVEC) + (VNEWVEC] + (INITVARS (NSTOASCIITRANSLATIONS)) + (ADDVARS (NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY) + (38 ASCIIFROM38ARRAY) + (39 ASCIIFROM39ARRAY) + (239 ASCIIFROM239ARRAY))) + (UGLYVARS ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY) + (P (\SMASHPRESSFONTS)) + (DECLARE%: DONTCOPY (CONSTANTS (unknownCharTranslation '(MATH 59]) @@ -79,30 +74,28 @@ this file.) (DEFINEQ (GETCHARPRESSTRANSLATION - [LAMBDA (CHARCODE FONT) (* thh%: "28-Feb-86 12:03") - - (* returns the Press translation for a character in a font) - + [LAMBDA (CHARCODE FONT) (* ; "Edited 14-Jul-2025 23:23 by rmk") + (* ; "Edited 5-Jul-2025 18:51 by rmk") + (* thh%: "28-Feb-86 12:03") + (* ; + "returns the Press translation for a character in a font") (COND ((OR (CHARCODEP CHARCODE) - (EQ CHARCODE 256)) - - (* bitmap for char 256 is what gets printed if char not found) - + (EQ CHARCODE 256)) (* ; + "bitmap for char 256 is what gets printed if char not found") ) ((OR (STRINGP CHARCODE) (LITATOM CHARCODE)) (SETQ CHARCODE (CHCON1 CHARCODE))) (T (\ILLEGAL.ARG CHARCODE))) - (LET [TR CSINFO (FONTDESC (\GETFONTDESC FONT 'PRESS] - - (* fetch the csinfo for the character set of this character.) - + (LET [TR CSINFO (FONTDESC (FONTCOPY FONT NIL NIL NIL 'PRESS] + (* ; + "fetch the csinfo for the character set of this character.") (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (SETQ TR (\GETBASEPTR (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO) (UNFOLD (\CHAR8CODE CHARCODE) - 2))) (* Return a copy) + 2))) (* ; "Return a copy") (LIST (CAR TR) (CDR TR]) @@ -135,17 +128,18 @@ this file.) array]) (PUTCHARPRESSTRANSLATION - [LAMBDA (CHARCODE FONT NEWTRANSLATION) (* ; "Edited 29-Feb-88 10:28 by thh:") + [LAMBDA (CHARCODE FONT NEWTRANSLATION) (* ; "Edited 14-Jul-2025 23:24 by rmk") + (* ; "Edited 5-Jul-2025 18:51 by rmk") + (* ; "Edited 29-Feb-88 10:28 by thh:") (* ; - "Changes the Press translation for a character in a font") - + "Changes the Press translation for a character in a font") (COND ((CHARCODEP CHARCODE)) ((OR (STRINGP CHARCODE) (LITATOM CHARCODE)) (SETQ CHARCODE (CHCON1 CHARCODE))) (T (\ILLEGAL.ARG CHARCODE))) - (PROG* ((FONTDESC (\GETFONTDESC FONT 'PRESS)) + (PROG* ((FONTDESC (FONTCREATE FONT NIL NIL NIL 'PRESS)) (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (CHAR8CODE (\CHAR8CODE CHARCODE)) @@ -162,11 +156,12 @@ this file.) (MAX DATUM (ffetch \SFAscent of (CAR TR] [change (ffetch CHARSETDESCENT of CSINFO) (MAX DATUM (ffetch \SFDescent of (CAR TR] - [freplace \SFHeight of FONTDESC - with (PLUS (change (ffetch \SFAscent of FONTDESC) - (MAX DATUM (ffetch CHARSETASCENT of CSINFO))) - (change (ffetch \SFDescent of FONTDESC) - (MAX DATUM (ffetch CHARSETDESCENT of CSINFO]) + [freplace \SFHeight of FONTDESC with (PLUS (change (ffetch \SFAscent of FONTDESC) + (MAX DATUM (ffetch CHARSETASCENT + of CSINFO))) + (change (ffetch \SFDescent of FONTDESC) + (MAX DATUM (ffetch CHARSETDESCENT + of CSINFO]) (RETURN NEWTRANSLATION]) ) (DEFINEQ @@ -1000,16 +995,16 @@ this file.) ) (ADDTOVAR FONTCOERCIONS (PRESS ((SYMBOL (< 10)) - (SYMBOL 10)) - ((SYMBOL (> 12)) - (SYMBOL 12)))) + (SYMBOL 10)) + ((SYMBOL (> 12)) + (SYMBOL 12)))) (ADDTOVAR MISSINGFONTCOERCIONS (PRESS (MODERN HELVETICA) - (CLASSIC TIMESROMAN) - (LOGOTYPE LOGO) - (TERMINAL GACHA) - (MODERN FRUTIGER) - (CLASSIC CENTURY))) + (CLASSIC TIMESROMAN) + (LOGOTYPE LOGO) + (TERMINAL GACHA) + (MODERN FRUTIGER) + (CLASSIC CENTURY))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS) @@ -1112,90 +1107,83 @@ this file.) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE -(DATATYPE PRESSDATA (PRHEADING (* ; - "The string to be printed atop each page.") - PRHEADINGFONT (* ; "Font to print the heading in") - PRXPOS (* ; "Current X position") - PRYPOS (* ; "Current Y position") - PRFONT (* ; "Current font") - PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER +(DATATYPE PRESSDATA (PRHEADING (* ; + "The string to be printed atop each page.") + PRHEADINGFONT (* ; "Font to print the heading in") + PRXPOS (* ; "Current X position") + PRYPOS (* ; "Current Y position") + PRFONT (* ; "Current font") + PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER (* ; - "Widths table for the current logical character set") - ) - PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION - PRDOCNAME (PRLEFT WORD) (* ; "Page left margin") - (PRBOTTOM WORD) (* ; "Page bottom margin") - (PRRIGHT WORD) (* ; "Page right margin") - (PRTOP WORD) (* ; "Page top margin") - (PRPAGENUM WORD) (* ; "Current Page number") - (PRNEXTFONT# BYTE) - (PRMAXFONTSET BYTE) - (PRPARTSTART INTEGER) - (DLSTARTBYTE INTEGER) - (ELSTARTBYTE INTEGER) - (STARTCHARBYTE INTEGER) - (VECMOVINGRIGHT FLAG) (* ; - "If we're drawing a curve with vector fonts, are we moving to the right?") - (VECWASDISPLAYING FLAG) - (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.") - - VECSEGCHARS (* ; - "Cache for vector characters while we're moving to the left.") - VECCURX (* ; - "Current X position within vector code, in Dover spots") - VECCURY (* ; - "Current Y position with vector code, in Dover spots") - PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG) + "Widths table for the current logical character set") + ) + PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME + (PRLEFT WORD) (* ; "Page left margin") + (PRBOTTOM WORD) (* ; "Page bottom margin") + (PRRIGHT WORD) (* ; "Page right margin") + (PRTOP WORD) (* ; "Page top margin") + (PRPAGENUM WORD) (* ; "Current Page number") + (PRNEXTFONT# BYTE) + (PRMAXFONTSET BYTE) + (PRPARTSTART INTEGER) + (DLSTARTBYTE INTEGER) + (ELSTARTBYTE INTEGER) + (STARTCHARBYTE INTEGER) + (VECMOVINGRIGHT FLAG) (* ; + "If we're drawing a curve with vector fonts, are we moving to the right?") + (VECWASDISPLAYING FLAG) + + (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.") + + VECSEGCHARS (* ; + "Cache for vector characters while we're moving to the left.") + VECCURX (* ; + "Current X position within vector code, in Dover spots") + VECCURY (* ; + "Current Y position with vector code, in Dover spots") + PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG) (* ; - "Says whether we have been printing characters inside the clipping region") - PRClippingRegion - (* ;; "The edges of the paper, as far as PRESS is concerned. Used to protect SPRUCE users who get killed when the image goes off-paper") - - PRLOGICALFONT (* ; "Current logical font") - PRLOGICALCHARSET (* ; - "Current logical character set, whose info is cached. NIL if cache is invalid") - (PRTRANSLATIONCACHE POINTER (* ; - "Translation table for the current logical character set") - )) - PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0 - (* ; - "We assume that the origin is translated to the bottom-left of the page region") - PRClippingRegion _ (create REGION - LEFT _ SPRUCEPAPERLEFTMICAS - BOTTOM _ SPRUCEPAPERBOTTOMMICAS - WIDTH _ (DIFFERENCE SPRUCEPAPERRIGHTMICAS - SPRUCEPAPERLEFTMICAS) - HEIGHT _ 29210) - [ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of - DATUM) - (fetch (PRESSDATA PRLEFT) of DATUM))) - (PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM) - (fetch (PRESSDATA PRBOTTOM) of DATUM))) - (PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM) - (PROGN (replace (PRESSDATA XPRPAGEREGION) of - DATUM - with NEWVALUE) - (replace (PRESSDATA PRLEFT) of DATUM - with (fetch (REGION LEFT) of - NEWVALUE - )) - (replace (PRESSDATA PRBOTTOM) of DATUM - with (fetch (REGION BOTTOM) of - NEWVALUE)) - (replace (PRESSDATA PRRIGHT) of DATUM - with (IPLUS (fetch (REGION LEFT) - of NEWVALUE) - (fetch (REGION WIDTH) - of NEWVALUE))) - (replace (PRESSDATA PRTOP) of DATUM - with (IPLUS (fetch (REGION BOTTOM) - of NEWVALUE) - (fetch (REGION HEIGHT) - of NEWVALUE]) + "Says whether we have been printing characters inside the clipping region") + PRClippingRegion + + (* ;; "The edges of the paper, as far as PRESS is concerned. Used to protect SPRUCE users who get killed when the image goes off-paper") + + PRLOGICALFONT (* ; "Current logical font") + PRLOGICALCHARSET (* ; + "Current logical character set, whose info is cached. NIL if cache is invalid") + (PRTRANSLATIONCACHE POINTER (* ; + "Translation table for the current logical character set") + )) + PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0 (* ; + "We assume that the origin is translated to the bottom-left of the page region") + PRClippingRegion _ (create REGION + LEFT _ SPRUCEPAPERLEFTMICAS + BOTTOM _ SPRUCEPAPERBOTTOMMICAS + WIDTH _ (DIFFERENCE SPRUCEPAPERRIGHTMICAS + SPRUCEPAPERLEFTMICAS) + HEIGHT _ 29210) + [ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of DATUM) + (fetch (PRESSDATA PRLEFT) of DATUM))) + (PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM) + (fetch (PRESSDATA PRBOTTOM) of DATUM))) + (PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM) + (PROGN (replace (PRESSDATA XPRPAGEREGION) of DATUM + with NEWVALUE) + (replace (PRESSDATA PRLEFT) of DATUM + with (fetch (REGION LEFT) of NEWVALUE)) + (replace (PRESSDATA PRBOTTOM) of DATUM + with (fetch (REGION BOTTOM) of NEWVALUE)) + (replace (PRESSDATA PRRIGHT) of DATUM + with (IPLUS (fetch (REGION LEFT) of NEWVALUE) + (fetch (REGION WIDTH) of NEWVALUE))) + (replace (PRESSDATA PRTOP) of DATUM + with (IPLUS (fetch (REGION BOTTOM) of NEWVALUE) + (fetch (REGION HEIGHT) of NEWVALUE]) ) + (/DECLAREDATATYPE 'PRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP + POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER ) '((PRESSDATA 0 POINTER) @@ -1218,14 +1206,14 @@ this file.) (PRESSDATA 32 (BITS . 15)) (PRESSDATA 33 (BITS . 15)) (PRESSDATA 34 (BITS . 15)) - (PRESSDATA 28 (BITS . 7)) - (PRESSDATA 26 (BITS . 7)) - (PRESSDATA 35 FIXP) - (PRESSDATA 37 FIXP) - (PRESSDATA 39 FIXP) - (PRESSDATA 41 FIXP) - (PRESSDATA 24 (FLAGBITS . 0)) - (PRESSDATA 24 (FLAGBITS . 16)) + (PRESSDATA 35 (BITS . 7)) + (PRESSDATA 35 (BITS . 135)) + (PRESSDATA 36 FIXP) + (PRESSDATA 38 FIXP) + (PRESSDATA 40 FIXP) + (PRESSDATA 42 FIXP) + (PRESSDATA 28 (FLAGBITS . 0)) + (PRESSDATA 28 (FLAGBITS . 16)) (PRESSDATA 44 POINTER) (PRESSDATA 46 POINTER) (PRESSDATA 48 POINTER) @@ -1238,9 +1226,10 @@ this file.) (PRESSDATA 60 POINTER)) '62) ) + (/DECLAREDATATYPE 'PRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP + POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER ) '((PRESSDATA 0 POINTER) @@ -1263,14 +1252,14 @@ this file.) (PRESSDATA 32 (BITS . 15)) (PRESSDATA 33 (BITS . 15)) (PRESSDATA 34 (BITS . 15)) - (PRESSDATA 28 (BITS . 7)) - (PRESSDATA 26 (BITS . 7)) - (PRESSDATA 35 FIXP) - (PRESSDATA 37 FIXP) - (PRESSDATA 39 FIXP) - (PRESSDATA 41 FIXP) - (PRESSDATA 24 (FLAGBITS . 0)) - (PRESSDATA 24 (FLAGBITS . 16)) + (PRESSDATA 35 (BITS . 7)) + (PRESSDATA 35 (BITS . 135)) + (PRESSDATA 36 FIXP) + (PRESSDATA 38 FIXP) + (PRESSDATA 40 FIXP) + (PRESSDATA 42 FIXP) + (PRESSDATA 28 (FLAGBITS . 0)) + (PRESSDATA 28 (FLAGBITS . 16)) (PRESSDATA 44 POINTER) (PRESSDATA 46 POINTER) (PRESSDATA 48 POINTER) @@ -1282,9 +1271,9 @@ this file.) (PRESSDATA 58 POINTER) (PRESSDATA 60 POINTER)) '62) - (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) %, -where translationArrayName is bound to a translation array for charset which contains (fontFamily -charcode) lists) + (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) %, where + translationArrayName is bound to a translation array for charset which contains (fontFamily charcode) + lists) (DEFINEQ @@ -1322,24 +1311,26 @@ charcode) lists) ) (RPAQ? PRESSFONTFAMILIES '((GACHA) - (TIMESROMAN) - (HELVETICA) - (SYMBOL) - (MATH) - (HIPPO) - (CYRILLIC) - (NEWVEC) - (SNEWVEC) - (HNEWVEC) - (VNEWVEC))) + (TIMESROMAN) + (HELVETICA) + (SYMBOL) + (MATH) + (HIPPO) + (CYRILLIC) + (NEWVEC) + (SNEWVEC) + (HNEWVEC) + (VNEWVEC))) (RPAQ? NSTOASCIITRANSLATIONS ) (ADDTOVAR NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY) - (38 ASCIIFROM38ARRAY) - (39 ASCIIFROM39ARRAY) - (239 ASCIIFROM239ARRAY)) -(READVARS-FROM-STRINGS '(ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY) "({Y256 POINTER 0 {R163 NIL} (SYMBOL 126) (SYMBOL 127) NIL NIL (SYMBOL 120) NIL 96 NIL NIL (SYMBOL + (38 ASCIIFROM38ARRAY) + (39 ASCIIFROM39ARRAY) + (239 ASCIIFROM239ARRAY)) + +(READVARS-FROM-STRINGS '(ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY) + "({Y256 POINTER 0 {R163 NIL} (SYMBOL 126) (SYMBOL 127) NIL NIL (SYMBOL 120) NIL 96 NIL NIL (SYMBOL 55) (SYMBOL 34) (SYMBOL 33) (SYMBOL 35) NIL (SYMBOL 6) NIL NIL (SYMBOL 2) NIL (SYMBOL 123) NIL (SYMBOL 13) 39 {R25 NIL} (SYMBOL 125) {R44 NIL} } {Y256 POINTER 0 (HIPPO 118) {R64 NIL} (HIPPO 65) (HIPPO 66) NIL (HIPPO 71) (HIPPO 68) (HIPPO 69) NIL NIL (HIPPO 90) (HIPPO 72) (HIPPO 81) ( @@ -1372,24 +1363,25 @@ MATH 7) (SYMBOL 39) NIL (SYMBOL 25) (MATH 19) (MATH 1) (SYMBOL 112) (SYMBO SYMBOL 59) {R6 NIL} (MATH 82) NIL (SYMBOL 100) (SYMBOL 101) (SYMBOL 98) (SYMBOL 99) (SYMBOL 57) (SYMBOL 56) (SYMBOL 94) (SYMBOL 95) (MATH 90) (MATH 68) (MATH 100) {R69 NIL} }) ") -(\SMASHPRESSFONTS) + +(\SMASHPRESSFONTS) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ unknownCharTranslation (MATH 59)) + [CONSTANTS (unknownCharTranslation '(MATH 59] ) ) -(PUTPROPS PRESSFROMNS COPYRIGHT ("Xerox Corporation" 1986 1988)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3994 4370 (\SMASHPRESSFONTS 4004 . 4368)) (4371 8600 (GETCHARPRESSTRANSLATION 4381 . -5419) (PRESS.NSARRAY 5421 . 6744) (PUTCHARPRESSTRANSLATION 6746 . 8598)) (8601 19311 (\DSPFONT.PRESS -8611 . 10062) (\DSPSPACEFACTOR.PRESS 10064 . 10916) (\ENTITYSTART.PRESS 10918 . 12640) ( -\SETSPACE.PRESS 12642 . 13344) (\STARTPAGE.PRESS 13346 . 15454) (\PRESS.COERCEFONT 15456 . 16922) ( -\DSPFONT.PRESSFONT 16924 . 18298) (SETUPFONTS.PRESS 18300 . 19309)) (19312 41000 (\CREATEPRESSFONT -19322 . 20520) (\CREATECHARSET.PRESS 20522 . 25622) (\CREATECHARSETZERO.PRESS 25624 . 40998)) (41001 -55544 (\PRESSCURVE2 41011 . 55542)) (55624 59376 (\COERCEFONT 55634 . 59374)) (60032 65529 ( -\STRINGWIDTH.PRESS 60042 . 60535) (\CHARWIDTH.PRESS 60537 . 61002) (\OUTCHARFN.PRESS 61004 . 65527)) ( -75785 76950 (\NSTOASCIIARRAY 75795 . 76147) (\NSTOASCIITRANSLATION 76149 . 76948))))) + (FILEMAP (NIL (2898 3274 (\SMASHPRESSFONTS 2908 . 3272)) (3275 8422 (GETCHARPRESSTRANSLATION 3285 . +4793) (PRESS.NSARRAY 4795 . 6118) (PUTCHARPRESSTRANSLATION 6120 . 8420)) (8423 19133 (\DSPFONT.PRESS +8433 . 9884) (\DSPSPACEFACTOR.PRESS 9886 . 10738) (\ENTITYSTART.PRESS 10740 . 12462) (\SETSPACE.PRESS +12464 . 13166) (\STARTPAGE.PRESS 13168 . 15276) (\PRESS.COERCEFONT 15278 . 16744) (\DSPFONT.PRESSFONT +16746 . 18120) (SETUPFONTS.PRESS 18122 . 19131)) (19134 40822 (\CREATEPRESSFONT 19144 . 20342) ( +\CREATECHARSET.PRESS 20344 . 25444) (\CREATECHARSETZERO.PRESS 25446 . 40820)) (40823 55366 ( +\PRESSCURVE2 40833 . 55364)) (55446 59198 (\COERCEFONT 55456 . 59196)) (59822 65319 ( +\STRINGWIDTH.PRESS 59832 . 60325) (\CHARWIDTH.PRESS 60327 . 60792) (\OUTCHARFN.PRESS 60794 . 65317)) ( +74712 75877 (\NSTOASCIIARRAY 74722 . 75074) (\NSTOASCIITRANSLATION 75076 . 75875))))) STOP diff --git a/sources/ADISPLAY b/sources/ADISPLAY index 479caf2ae..bccc0ab80 100644 --- a/sources/ADISPLAY +++ b/sources/ADISPLAY @@ -1,12 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Dec-2023 11:23:08" {WMEDLEY}ADISPLAY.;13 245192 +(FILECREATED " 8-Jul-2025 20:19:58"  +{DSK}kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;14 244883 :EDIT-BY rmk - :CHANGES-TO (FNS \CARET.FLASH?) + :CHANGES-TO (VARS ADISPLAYCOMS) - :PREVIOUS-DATE " 2-Nov-2023 23:35:15" {WMEDLEY}ADISPLAY.;12) + :PREVIOUS-DATE "19-Dec-2023 11:23:08" +{DSK}kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;13) (PRETTYCOMPRINT ADISPLAYCOMS) @@ -68,7 +70,7 @@ (MACROS \CURVEPT .SETUP.FOR.\BBTCURVEPT. \CIRCLEPTS \CURVESMOOTH)) (FNS \FILLCIRCLE.DISPLAY \LINEBLT)) [COMS (* ; "making and copying bitmaps") - (FNS SCREENBITMAP BITMAPP BITMAPHEIGHT BITSPERPIXEL) + (FNS SCREENBITMAP BITMAPP BITSPERPIXEL) (EXPORT (FILEPKGCOMS BITMAPS CURSORS)) (DECLARE%: EVAL@COMPILE (EXPORT (ADDVARS (GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap] @@ -3750,18 +3752,6 @@ (AND (type? BITMAP X) X]) -(BITMAPHEIGHT - [LAMBDA (BITMAP) (* kbr%: " 8-Jul-85 16:01") - - (* ;; "returns the height in pixels of a bitmap.") - - (COND - ((type? BITMAP BITMAP) - (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) - ((type? WINDOW BITMAP) - (WINDOWPROP BITMAP 'HEIGHT)) - (T (\ILLEGAL.ARG BITMAP]) - (BITSPERPIXEL [LAMBDA (BITMAP) (* ; "Edited 15-Feb-94 16:10 by nilsson") @@ -4434,40 +4424,40 @@ (ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (10520 10714 (SCREENREGIONP 10530 . 10712)) (12158 19519 (\BBTCURVEPT 12168 . 19517)) ( -19520 29336 (CREATETEXTUREFROMBITMAP 19530 . 21460) (PRINTBITMAP 21462 . 22813) (PRINT-BITMAPS-NICELY -22815 . 26666) (PRINTCURSOR 26668 . 27701) (\WRITEBITMAP 27703 . 29334)) (29379 31927 (\GETINTEGERPART - 29389 . 30934) (\CONVERTTOFRACTION 30936 . 31925)) (32064 32936 (CURSORP 32074 . 32293) (CURSORBITMAP - 32295 . 32341) (CreateCursorBitMap 32343 . 32934)) (37298 46221 (CARET 37308 . 39068) (\CARET.CREATE -39070 . 39248) (\CARET.DOWN 39250 . 40602) (\CARET.FLASH? 40604 . 42298) (\CARET.SHOW 42300 . 42869) ( -CARETRATE 42871 . 43529) (\CARET.FLASH.AGAIN 43531 . 44697) (\CARET.FLASH.MULTIPLE 44699 . 45222) ( -\CARET.FLASH 45224 . 46219)) (46222 51294 (\MEDW.CARET.SHOW 46232 . 51292)) (51658 53493 ( -\AREAVISIBLE? 51668 . 52592) (\REGIONOVERLAPAREAP 52594 . 53139) (\AREAINREGIONP 53141 . 53491)) ( -53542 66018 (CREATEREGION 53552 . 53888) (REGIONP 53890 . 54036) (INTERSECTREGIONS 54038 . 56808) ( -UNIONREGIONS 56810 . 58961) (REGIONSINTERSECTP 58963 . 59571) (SUBREGIONP 59573 . 60218) (EXTENDREGION - 60220 . 62377) (EXTENDREGIONBOTTOM 62379 . 63021) (EXTENDREGIONLEFT 63023 . 63642) (EXTENDREGIONRIGHT - 63644 . 64197) (EXTENDREGIONTOP 64199 . 64740) (INSIDEP 64742 . 65510) (STRINGREGION 65512 . 66016)) -(66263 71537 (\BRUSHBITMAP 66273 . 67990) (\GETBRUSH 67992 . 68303) (\GETBRUSHBBT 68305 . 70333) ( -\InitCurveBrushes 70335 . 71401) (\BrushFromWidth 71403 . 71535)) (71538 74605 (\MAKEBRUSH.DIAGONAL -71548 . 71828) (\MAKEBRUSH.HORIZONTAL 71830 . 72224) (\MAKEBRUSH.VERTICAL 72226 . 72538) ( -\MAKEBRUSH.SQUARE 72540 . 72817) (\MAKEBRUSH.ROUND 72819 . 74603)) (74606 75771 (INSTALLBRUSH 74616 . -75769)) (76172 87574 (\DRAWLINE.DISPLAY 76182 . 86289) (RELMOVETO 86291 . 86678) (MOVETOUPPERLEFT -86680 . 87572)) (87575 111060 (\CLIPANDDRAWLINE 87585 . 94031) (\CLIPANDDRAWLINE1 94033 . 105781) ( -\CLIPCODE 105783 . 107157) (\LEASTPTAT 107159 . 107757) (\GREATESTPTAT 107759 . 108387) (\DRAWLINE1 -108389 . 109505) (\DRAWLINE.UFN 109507 . 111058)) (115590 161637 (\DRAWCIRCLE.DISPLAY 115600 . 124413) - (\DRAWARC.DISPLAY 124415 . 124705) (\DRAWARC.GENERIC 124707 . 125460) (\COMPUTE.ARC.POINTS 125462 . -127727) (\DRAWELLIPSE.DISPLAY 127729 . 143398) (\DRAWCURVE.DISPLAY 143400 . 145689) ( -\DRAWPOINT.DISPLAY 145691 . 146887) (\DRAWPOLYGON.DISPLAY 146889 . 150417) (\LINEWITHBRUSH 150419 . -161635)) (161638 193330 (LOADPOLY 161648 . 162208) (PARAMETRICSPLINE 162210 . 172407) (\CURVE 172409 - . 178011) (\CURVE2 178013 . 189344) (\CURVEEND 189346 . 189828) (\CURVESLOPE 189830 . 192313) ( -\CURVESTART 192315 . 192639) (\FDIFS/FROM/DERIVS 192641 . 193328)) (205859 220195 (\FILLCIRCLE.DISPLAY - 205869 . 216617) (\LINEBLT 216619 . 220193)) (220239 222239 (SCREENBITMAP 220249 . 220726) (BITMAPP -220728 . 220962) (BITMAPHEIGHT 220964 . 221340) (BITSPERPIXEL 221342 . 222237)) (222880 223873 ( -DSPFILL 222890 . 223573) (INVERTW 223575 . 223871)) (223874 227517 (\DSPCOLOR.DISPLAY 223884 . 225181) - (\DSPBACKCOLOR.DISPLAY 225183 . 226562) (DSPEOLFN 226564 . 227515)) (227950 232604 (DSPCLEOL 227960 - . 228836) (DSPRUBOUTCHAR 228838 . 229270) (\DSPMOVELR 229272 . 232602)) (232734 233852 ( -\CURSOR.DEFPRINT 232744 . 233850)) (234264 242838 (TEXTUREOFCOLOR 234274 . 235536) (\PRIMARYTEXTURE -235538 . 236120) (\LEVELTEXTURE 236122 . 236623) (INSURE.B&W.TEXTURE 236625 . 238020) ( -INSURE.RGB.COLOR 238022 . 239450) (\LOOKUPCOLORNAME 239452 . 239722) (RGBP 239724 . 240489) (HLSP -240491 . 240866) (HLSTORGB 240868 . 242008) (\HLSVALUEFN 242010 . 242836))))) + (FILEMAP (NIL (10589 10783 (SCREENREGIONP 10599 . 10781)) (12227 19588 (\BBTCURVEPT 12237 . 19586)) ( +19589 29405 (CREATETEXTUREFROMBITMAP 19599 . 21529) (PRINTBITMAP 21531 . 22882) (PRINT-BITMAPS-NICELY +22884 . 26735) (PRINTCURSOR 26737 . 27770) (\WRITEBITMAP 27772 . 29403)) (29448 31996 (\GETINTEGERPART + 29458 . 31003) (\CONVERTTOFRACTION 31005 . 31994)) (32133 33005 (CURSORP 32143 . 32362) (CURSORBITMAP + 32364 . 32410) (CreateCursorBitMap 32412 . 33003)) (37367 46290 (CARET 37377 . 39137) (\CARET.CREATE +39139 . 39317) (\CARET.DOWN 39319 . 40671) (\CARET.FLASH? 40673 . 42367) (\CARET.SHOW 42369 . 42938) ( +CARETRATE 42940 . 43598) (\CARET.FLASH.AGAIN 43600 . 44766) (\CARET.FLASH.MULTIPLE 44768 . 45291) ( +\CARET.FLASH 45293 . 46288)) (46291 51363 (\MEDW.CARET.SHOW 46301 . 51361)) (51727 53562 ( +\AREAVISIBLE? 51737 . 52661) (\REGIONOVERLAPAREAP 52663 . 53208) (\AREAINREGIONP 53210 . 53560)) ( +53611 66087 (CREATEREGION 53621 . 53957) (REGIONP 53959 . 54105) (INTERSECTREGIONS 54107 . 56877) ( +UNIONREGIONS 56879 . 59030) (REGIONSINTERSECTP 59032 . 59640) (SUBREGIONP 59642 . 60287) (EXTENDREGION + 60289 . 62446) (EXTENDREGIONBOTTOM 62448 . 63090) (EXTENDREGIONLEFT 63092 . 63711) (EXTENDREGIONRIGHT + 63713 . 64266) (EXTENDREGIONTOP 64268 . 64809) (INSIDEP 64811 . 65579) (STRINGREGION 65581 . 66085)) +(66332 71606 (\BRUSHBITMAP 66342 . 68059) (\GETBRUSH 68061 . 68372) (\GETBRUSHBBT 68374 . 70402) ( +\InitCurveBrushes 70404 . 71470) (\BrushFromWidth 71472 . 71604)) (71607 74674 (\MAKEBRUSH.DIAGONAL +71617 . 71897) (\MAKEBRUSH.HORIZONTAL 71899 . 72293) (\MAKEBRUSH.VERTICAL 72295 . 72607) ( +\MAKEBRUSH.SQUARE 72609 . 72886) (\MAKEBRUSH.ROUND 72888 . 74672)) (74675 75840 (INSTALLBRUSH 74685 . +75838)) (76241 87643 (\DRAWLINE.DISPLAY 76251 . 86358) (RELMOVETO 86360 . 86747) (MOVETOUPPERLEFT +86749 . 87641)) (87644 111129 (\CLIPANDDRAWLINE 87654 . 94100) (\CLIPANDDRAWLINE1 94102 . 105850) ( +\CLIPCODE 105852 . 107226) (\LEASTPTAT 107228 . 107826) (\GREATESTPTAT 107828 . 108456) (\DRAWLINE1 +108458 . 109574) (\DRAWLINE.UFN 109576 . 111127)) (115659 161706 (\DRAWCIRCLE.DISPLAY 115669 . 124482) + (\DRAWARC.DISPLAY 124484 . 124774) (\DRAWARC.GENERIC 124776 . 125529) (\COMPUTE.ARC.POINTS 125531 . +127796) (\DRAWELLIPSE.DISPLAY 127798 . 143467) (\DRAWCURVE.DISPLAY 143469 . 145758) ( +\DRAWPOINT.DISPLAY 145760 . 146956) (\DRAWPOLYGON.DISPLAY 146958 . 150486) (\LINEWITHBRUSH 150488 . +161704)) (161707 193399 (LOADPOLY 161717 . 162277) (PARAMETRICSPLINE 162279 . 172476) (\CURVE 172478 + . 178080) (\CURVE2 178082 . 189413) (\CURVEEND 189415 . 189897) (\CURVESLOPE 189899 . 192382) ( +\CURVESTART 192384 . 192708) (\FDIFS/FROM/DERIVS 192710 . 193397)) (205928 220264 (\FILLCIRCLE.DISPLAY + 205938 . 216686) (\LINEBLT 216688 . 220262)) (220308 221930 (SCREENBITMAP 220318 . 220795) (BITMAPP +220797 . 221031) (BITSPERPIXEL 221033 . 221928)) (222571 223564 (DSPFILL 222581 . 223264) (INVERTW +223266 . 223562)) (223565 227208 (\DSPCOLOR.DISPLAY 223575 . 224872) (\DSPBACKCOLOR.DISPLAY 224874 . +226253) (DSPEOLFN 226255 . 227206)) (227641 232295 (DSPCLEOL 227651 . 228527) (DSPRUBOUTCHAR 228529 . +228961) (\DSPMOVELR 228963 . 232293)) (232425 233543 (\CURSOR.DEFPRINT 232435 . 233541)) (233955 +242529 (TEXTUREOFCOLOR 233965 . 235227) (\PRIMARYTEXTURE 235229 . 235811) (\LEVELTEXTURE 235813 . +236314) (INSURE.B&W.TEXTURE 236316 . 237711) (INSURE.RGB.COLOR 237713 . 239141) (\LOOKUPCOLORNAME +239143 . 239413) (RGBP 239415 . 240180) (HLSP 240182 . 240557) (HLSTORGB 240559 . 241699) (\HLSVALUEFN + 241701 . 242527))))) STOP diff --git a/sources/ADISPLAY.LCOM b/sources/ADISPLAY.LCOM index c15326934..106b59961 100644 Binary files a/sources/ADISPLAY.LCOM and b/sources/ADISPLAY.LCOM differ diff --git a/sources/AFONT b/sources/AFONT index bf251a72a..e62df98e4 100644 --- a/sources/AFONT +++ b/sources/AFONT @@ -1,26 +1,35 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "IL") -(FILECREATED "16-May-90 11:59:31" {DSK}local>lde>lispcore>sources>AFONT.;2 41645 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (VARS AFONTCOMS) +(FILECREATED "14-Jul-2025 19:53:00" {WMEDLEY}AFONT.;13 43176 - previous date%: "14-Sep-87 11:59:36" {DSK}local>lde>lispcore>sources>AFONT.;1) + :EDIT-BY rmk + :CHANGES-TO (FNS ACFONT.GETCHARSET \READACFONTFILE) + + :PREVIOUS-DATE " 8-Jul-2025 22:09:41" {WMEDLEY}AFONT.;12) -(* ; " -Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT AFONTCOMS) (RPAQQ AFONTCOMS - ((XCL:FILE-ENVIRONMENTS "AFONT") + ( + (* ;; "AC and Interpress font file support. ACFILEP is on FONT") + + (XCL:FILE-ENVIRONMENTS "AFONT") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX) (CONSTANTS noInfoCode)) - (FNS \CREATESTARFONT \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST \ACCHARWIDTHLIST - \GETFBB \ACCHARPOSLIST \ACROTATECHAR \READFONTWDFILE \FACECODE \FAMILYCODE \FINDFONT) - [INITVARS (INTERPRESSFONTDIRECTORIES '("{Erinyes}Fonts>"] + (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))) + + +(* ;; "AC and Interpress font file support. ACFILEP is on FONT") + + (XCL:DEFINE-FILE-ENVIRONMENT "AFONT" :PACKAGE "IL" :READTABLE "INTERLISP" :COMPILER :COMPILE-FILE) @@ -31,23 +40,21 @@ Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All ri (* * The bounding box for a character in an AC file) - BBOX (* Offset from the left edge of the - bounding box to the character's - origin) - BBOY (* Offset from the bottom of the - bounding box to the character's - origin) - BBDX (* Width of the character's bounding - box in pixels) - BBDY (* Height of the bounding box in - bits; -1 if this character doesn't - really exist) - RASTERWIDTHX (* Width of the character's image - (i.e., the escapement for this - character) in raster bits) - RASTERWIDTHY (* Amount this char moves in Y, in - raster units.) - )) + BBOX (* Offset from the left edge of the + bounding box to the character's origin) + BBOY (* Offset from the bottom of the + bounding box to the character's origin) + BBDX (* Width of the character's bounding + box in pixels) + BBDY (* Height of the bounding box in bits; + -1 if this character doesn't really + exist) + RASTERWIDTHX (* Width of the character's image + (i.e., the escapement for this + character) in raster bits) + RASTERWIDTHY (* Amount this char moves in Y, in + raster units.) + )) (RECORD FONTBOUNDINGBOX (FBBBDX FBBBDY FBBBOX FBBBOY)) ) @@ -62,35 +69,61 @@ Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All ri ) (DEFINEQ +(ACFONT.FILEP + [LAMBDA (FILE) (* ; "Edited 15-May-2025 17:48 by rmk") + (RESETLST + (CL:UNLESS (OPENP FILE 'INPUT) + [RESETSAVE (SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD)) + `(PROGN (CLOSEF? OLDVALUE]) + + (* ;; "This is the length of a standard index header. Other files could also have this value, but it's a pretty good discriminator") + + (* ;; "Skip to byte 25; do it with BINS so works for non-randaccessp devices. This skips the standard name header, then look for type 3 in the following header") + + (CL:WHEN (EQ (\WIN FILE) + (LOGOR (LLSH 16 8) + 12)) + (FRPTQ 22 (\BIN FILE)) (* ; "(SETFILEPTR STRM 25)") + (EQ 3 (LRSH (\BIN FILE) + 4))))]) + +(ACFONT.GETCHARSET + [LAMBDA (STRM CHARSET) (* ; "Edited 14-Jul-2025 19:50 by rmk") + (* ; "Edited 17-May-2025 10:15 by rmk") + + (* ;; + "STRM must be good for this CHARSET. This defaults the padding arguments of \READACFONTFILE") + + (\READACFONTFILE STRM]) + (\CREATESTARFONT - [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* 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") + [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") - - (PROG [(CS (OR CHARSET \DEFAULTCHARSET)) - (NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540) - 72))) - (FD (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ PSIZE - FONTFACE _ FACE - \SFFACECODE _ (\FACECODE FACE) - ROTATION _ ROTATION - OTHERDEVICEFONTPROPS _ \ASCIITONS - FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72] - (RETURN (if (NOT (\GETCHARSETINFO CS FD T)) - then (* ; - "return NIL and let FONTCREATE decide whether or not to cause an error") - - NIL - else FD]) + (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") @@ -126,188 +159,180 @@ Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All ri BITSPERWORD]) (\READACFONTFILE - [LAMBDA (STRM FAMILY SIZE FACE PAD.LEFT DONT.PAD.RIGHT) (* ; "Edited 1-Sep-87 10:04 by Snow") - - (* ;; "Read an AC-format font file. Assumes that the file is open and has already been determined to be of type AC.") - - [COND - ((RANDACCESSP STRM) - (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) - STRM))) - (T (* ;; "This is necessary unless we figure out how to read the AC file sequentially. When we figure this out, we can factor the RESETSAVE back in \READDISPLAYFONTFILE") - - (SETQ STRM (OPENSTREAM (CLOSEF? STRM) - 'INPUT)) - (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) - STRM)) - (COPYBYTES STRM (SETQ STRM (OPENSTREAM '{NODIRCORE} 'BOTH] - (SETFILEPTR STRM 28) (* ; + [LAMBDA (STRM PAD.LEFT DONT.PAD.RIGHT) (* ; "Edited 14-Jul-2025 19:49 by rmk") + (* ; "Edited 8-Jul-2025 22:04 by rmk") + (* ; "Edited 9-Jun-2025 14:17 by rmk") + (* ; "Edited 16-May-2025 17:44 by rmk") + (* ; "Edited 1-Sep-87 10:04 by Snow") + (RESETLST + (PROG [FBBLIST STARTCHAR ENDCHAR CHARWIDTHLIST CHARIMAGEWIDTHLIST OFFSETS WIDTHS IMAGEWIDTHS + FONTDESC FBBBITMAP CHARBITMAP STARTWORDLIST BBOXLIST DUMMYCHAROFFSET DUMMYWIDTH + (CSINFO (create CHARSETINFO + IMAGEWIDTHS _ (\CREATECSINFOELEMENT) + LEFTKERN _ (\CREATEKERNELEMENT] + (CL:UNLESS (GETSTREAM STRM 'INPUT T) + [RESETSAVE (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD)) + `(PROGN (CLOSEF? OLDVALUE]) + [COND + ((AND (GETSTREAM STRM 'INPUT T) + (RANDACCESSP STRM)) (* ; + "Presumably open from \READDISPLAYFONTFILE") + (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) + STRM))) + (T + (* ;; "This is necessary unless we figure out how to read the AC file sequentially. When we figure this out, we can factor the RESETSAVE back in \READDISPLAYFONTFILE") + + (SETQ STRM (OPENSTREAM (CLOSEF? STRM) + 'INPUT)) + (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) + STRM)) + (COPYBYTES STRM (SETQ STRM (OPENSTREAM '{NODIRCORE} 'BOTH] + (SETFILEPTR STRM 0) + (CL:UNLESS (ACFONT.FILEP STRM) + (ERROR "Not an AC font file" STRM)) + (SETFILEPTR STRM 28) (* ;  "Starting at 28 skips the family and face bytes.") - - (PROG [FBBLIST STARTCHAR ENDCHAR CHARWIDTHLIST CHARIMAGEWIDTHLIST LEFTKERNS OFFSETS WIDTHS - IMAGEWIDTHS FONTDESC FBBBITMAP CHARBITMAP STARTWORDLIST BBOXLIST DUMMYCHAROFFSET - DUMMYWIDTH (CSINFO (create CHARSETINFO - IMAGEWIDTHS _ (\CREATECSINFOELEMENT) - LEFTKERN _ (\CREATEKERNELEMENT] - (SETQ STARTCHAR (BIN STRM)) (* ; + (SETQ STARTCHAR (BIN STRM)) (* ;  "Get the first and last characters in this font") - - (SETQ ENDCHAR (BIN STRM)) - (SETQ BBOXLIST (\READACFONTBOXES STRM STARTCHAR ENDCHAR)) + (SETQ ENDCHAR (BIN STRM)) + (SETQ BBOXLIST (\READACFONTBOXES STRM STARTCHAR ENDCHAR)) (* ;  "Read the list of bounding boxes for all the chars in the font") - - (SETQ FBBLIST (\GETFBB BBOXLIST)) - (SETQ CHARWIDTHLIST (\ACCHARIMAGELIST BBOXLIST)) (* ; + (SETQ FBBLIST (\GETFBB BBOXLIST)) + (SETQ CHARWIDTHLIST (\ACCHARIMAGELIST BBOXLIST)) + (* ;  "And the escapement for each character.") - - (SETQ CHARIMAGEWIDTHLIST (\ACCHARWIDTHLIST BBOXLIST FBBLIST)) + (SETQ CHARIMAGEWIDTHLIST (\ACCHARWIDTHLIST BBOXLIST FBBLIST)) (* ;  "Create the list of character widths for the characters in the font.") - - (COND - ([EVERY (CDR CHARWIDTHLIST) - (FUNCTION (LAMBDA (WID) - (OR (ZEROP WID) - (EQP WID (CAR CHARWIDTHLIST] + (COND + ([EVERY (CDR CHARWIDTHLIST) + (FUNCTION (LAMBDA (WID) + (OR (ZEROP WID) + (EQP WID (CAR CHARWIDTHLIST] (* ;  "Fixed-pitch font. Make the dummy character (for non-existent chars) the same width.") - - (SETQ DUMMYWIDTH (CAR CHARWIDTHLIST))) - (T (* ; "Otherwise, make the dummy 6 wide.") - - (SETQ DUMMYWIDTH 6))) - (COND - ((NULL (REMOVE 0 CHARIMAGEWIDTHLIST)) - (ERROR "No raster images" NIL) - (RETURN))) - (SETQ LEFTKERNS (FETCH (CHARSETINFO LEFTKERN) OF CSINFO)) - (FOR I FROM STARTCHAR TO ENDCHAR AS BOX IN BBOXLIST DO - (* ; "set the left kerning values. the default value is ZERO which is set when the element is created. Currently it is an array because kerning values can be negative values.") - - (\FSETLEFTKERN LEFTKERNS I - (FFETCH (BOUNDINGBOX BBOX) - OF BOX))) - (SETQ IMAGEWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) - (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETIMAGEWIDTH IMAGEWIDTHS I DUMMYWIDTH)) - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETWIDTH WIDTHS I DUMMYWIDTH)) - (* SETQ IMAGEWIDTHS (ARRAY 258 - (QUOTE (BITS 16)) DUMMYWIDTH 0)) - - (* ;; "Create the array of character widths, assuming the dummy width for all characters--we'll write over it later") - - [for X from STARTCHAR to ENDCHAR as Y in CHARIMAGEWIDTHLIST - do - - (* ;; "Fill in the image widths (the width of the image, as against how far to space over after printing the character)") - - (\FSETIMAGEWIDTH IMAGEWIDTHS X (COND - ((ZEROP Y) - 0) - (T (IPLUS Y (COND - (PAD.LEFT 1) - (T 0)) - (COND - (DONT.PAD.RIGHT 0) - (T 1] + (SETQ DUMMYWIDTH (CAR CHARWIDTHLIST))) + (T (* ; "Otherwise, make the dummy 6 wide.") + (SETQ DUMMYWIDTH 6))) + (COND + ((NULL (REMOVE 0 CHARIMAGEWIDTHLIST)) + (ERROR "No raster mages" NIL) + (RETURN))) + (FOR I FROM STARTCHAR TO ENDCHAR AS BOX IN BBOXLIST + DO (* ; "set the left kerning values. the default value is ZERO which is set when the element is created. Currently it is an array because kerning values can be negative values.") + (\FSETLEFTKERN CSINFO I (FFETCH (BOUNDINGBOX BBOX) OF BOX))) + (SETQ IMAGEWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) + (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETIMAGEWIDTH IMAGEWIDTHS I DUMMYWIDTH)) + (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETWIDTH WIDTHS I DUMMYWIDTH)) + + (* ;; "Create the array of character widths, assuming the dummy width for all characters--we'll write over it later") + + [for X from STARTCHAR to ENDCHAR as Y in CHARIMAGEWIDTHLIST + do + (* ;; "Fill in the image widths (the width of the image, as against how far to space over after printing the character)") + + (\FSETIMAGEWIDTH IMAGEWIDTHS X (COND + ((ZEROP Y) + 0) + (T (IPLUS Y (COND + (PAD.LEFT 1) + (T 0)) + (COND + (DONT.PAD.RIGHT 0) + (T 1] (* ;  "And the array of image escapements") - - (for X from STARTCHAR to ENDCHAR as Y in CHARWIDTHLIST do (\FSETWIDTH WIDTHS X Y)) - [replace CHARSETDESCENT of CSINFO with (IMAX 0 (IMINUS (fetch (FONTBOUNDINGBOX FBBBOY) - of FBBLIST] - [replace CHARSETASCENT of CSINFO with (IMAX 0 (IPLUS (fetch (FONTBOUNDINGBOX FBBBDY) - of FBBLIST) - (fetch (FONTBOUNDINGBOX FBBBOY) - of FBBLIST] - [replace CHARSETBITMAP of CSINFO with (SETQ CHARBITMAP - (BITMAPCREATE (IPLUS (SETQ DUMMYCHAROFFSET - (for (X _ STARTCHAR) - to ENDCHAR - sum (\FGETWIDTH IMAGEWIDTHS - X))) - DUMMYWIDTH) - (fetch (FONTBOUNDINGBOX FBBBDY) of FBBLIST] - (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETOFFSET OFFSETS I DUMMYCHAROFFSET)) - (SETQ STARTWORDLIST (\ACCHARPOSLIST STRM STARTCHAR ENDCHAR)) - (bind (DESTLEFT _ 0) for NTHCHAR from STARTCHAR to ENDCHAR as BBLIST in BBOXLIST - as STARTWORD in STARTWORDLIST as CHARWIDTH in CHARWIDTHLIST - do (PROG (RASTERINFO BBOX BBBITMAP BBBMBASE) (* ; + (for X from STARTCHAR to ENDCHAR as Y in CHARWIDTHLIST + do (\FSETWIDTH WIDTHS X Y)) + [replace CHARSETDESCENT of CSINFO with (IMAX 0 (IMINUS (fetch (FONTBOUNDINGBOX FBBBOY) + of FBBLIST] + [replace CHARSETASCENT of CSINFO with (IMAX 0 (IPLUS (fetch (FONTBOUNDINGBOX FBBBDY) + of FBBLIST) + (fetch (FONTBOUNDINGBOX FBBBOY) + of FBBLIST] + [replace CHARSETBITMAP of CSINFO with (SETQ CHARBITMAP + (BITMAPCREATE (IPLUS (SETQ DUMMYCHAROFFSET + (for (X _ STARTCHAR) + to ENDCHAR + sum (\FGETWIDTH + IMAGEWIDTHS + X))) + DUMMYWIDTH) + (fetch (FONTBOUNDINGBOX FBBBDY) + of FBBLIST] + (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETOFFSET OFFSETS I DUMMYCHAROFFSET)) + (SETQ STARTWORDLIST (\ACCHARPOSLIST STRM STARTCHAR ENDCHAR)) + (bind (DESTLEFT _ 0) for NTHCHAR from STARTCHAR to ENDCHAR as BBLIST in BBOXLIST + as STARTWORD in STARTWORDLIST as CHARWIDTH in CHARWIDTHLIST + do (PROG (RASTERINFO BBOX BBBITMAP BBBMBASE)(* ;  "\ACCHARPOSLIST returns NIL if no raster exists for the code") + (COND + ((NULL STARTWORD) - (COND - ((NULL STARTWORD) - - (* ;; "This character has no image; use the dummy char's offset (already in the offset and width arrays from earlier)") + (* ;; "This character has no image; use the dummy char's offset (already in the offset and width arrays from earlier)") - (add DESTLEFT (\FGETWIDTH IMAGEWIDTHS NTHCHAR)) - (\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH) - (\FSETIMAGEWIDTH IMAGEWIDTHS NTHCHAR DUMMYWIDTH) - (GO L2))) - (SETFILEPTR STRM STARTWORD) (* ; + (add DESTLEFT (\FGETWIDTH IMAGEWIDTHS NTHCHAR)) + (\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH) + (\FSETIMAGEWIDTH IMAGEWIDTHS NTHCHAR DUMMYWIDTH) + (GO L2))) + (SETFILEPTR STRM STARTWORD) (* ;  "If could flush this, would work on non-randaccessp devices") - - (SETQ RASTERINFO (\WIN STRM)) - (COND - ((EQ -1 (fetch BBDY of BBLIST)) - (\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH) - (\FSETIMAGEWIDTH IMAGEWIDTHS NTHCHAR DUMMYWIDTH) - (GO L2))) (* ; + (SETQ RASTERINFO (\WIN STRM)) + (COND + ((EQ -1 (fetch BBDY of BBLIST)) + (\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH) + (\FSETIMAGEWIDTH IMAGEWIDTHS NTHCHAR DUMMYWIDTH) + (GO L2))) (* ;  "\ACCHARPOSLIST returns NIL if no raster exists for the code") - - (SETQ BBOX (fetch BBOX of BBLIST)) - (COND - ((AND (ZEROP (fetch BBDX of BBLIST)) - (ZEROP (fetch BBDY of BBLIST))) + (SETQ BBOX (fetch BBOX of BBLIST)) + (COND + ((AND (ZEROP (fetch BBDX of BBLIST)) + (ZEROP (fetch BBDY of BBLIST))) (* ;  "The image is zero wide or zero high. Don't bother reading a bitmap image") + ) + ((SETQ BBBITMAP (BITMAPCREATE (TIMES 16 (FOLDLO RASTERINFO 1024)) + (IMOD RASTERINFO 1024))) + (SETQ BBBMBASE (fetch BITMAPBASE of BBBITMAP)) - ) - ((SETQ BBBITMAP (BITMAPCREATE (TIMES 16 (FOLDLO RASTERINFO 1024)) - (IMOD RASTERINFO 1024))) - (SETQ BBBMBASE (fetch BITMAPBASE of BBBITMAP)) - - (* ;; "STARTWORD is the characters raster information word. The high 6 bits record number of words per scan line and the lower 10 bits is the same as bbdx bbdx. The raster for the char follows STARTWORD") + (* ;; "STARTWORD is the characters raster information word. The high 6 bits record number of words per scan line and the lower 10 bits is the same as bbdx bbdx. The raster for the char follows STARTWORD") - (\BINS STRM BBBMBASE 0 (TIMES 2 (FOLDLO RASTERINFO 1024) - (IMOD RASTERINFO 1024))) - (SETQ BBBITMAP (\ACROTATECHAR BBBITMAP)) + (\BINS STRM BBBMBASE 0 (TIMES 2 (FOLDLO RASTERINFO 1024) + (IMOD RASTERINFO 1024))) + (SETQ BBBITMAP (\ACROTATECHAR BBBITMAP)) (* ;  "here is the place to add a rotation function to manipulate the character images coming off *.ac") - - (BITBLT BBBITMAP 0 0 CHARBITMAP [PLUS DESTLEFT (IMAX 0 - (COND - (PAD.LEFT - (ADD1 BBOX)) - (T BBOX] - (DIFFERENCE (fetch BBOY of BBLIST) - (fetch (FONTBOUNDINGBOX FBBBOY) of FBBLIST)) - (\FGETWIDTH IMAGEWIDTHS NTHCHAR) - (CADDDR BBLIST) - 'INPUT - 'REPLACE) (* ; + (BITBLT BBBITMAP 0 0 CHARBITMAP [PLUS DESTLEFT + (IMAX 0 (COND + (PAD.LEFT (ADD1 BBOX)) + (T BBOX] + (DIFFERENCE (fetch BBOY of BBLIST) + (fetch (FONTBOUNDINGBOX FBBBOY) of FBBLIST)) + (\FGETWIDTH IMAGEWIDTHS NTHCHAR) + (CADDDR BBLIST) + 'INPUT + 'REPLACE) (* ;  "ADD1 to BBOX because we add an empty column to each raster image to the left") + )) + (\FSETOFFSET OFFSETS NTHCHAR DESTLEFT) - )) - (\FSETOFFSET OFFSETS NTHCHAR DESTLEFT) - - (* ;; "on screen ac fonts, there are no spaces stored so that the width of the char is exactly that of the character image without any spacing columns") + (* ;; "on screen ac fonts, there are no spaces stored so that the width of the char is exactly that of the character image without any spacing columns") - (add DESTLEFT (\FGETWIDTH IMAGEWIDTHS NTHCHAR)) - L2 (* ; + (add DESTLEFT (\FGETWIDTH IMAGEWIDTHS NTHCHAR)) + L2 (* ;  "add 2 because of the two blank columns we add; one on either side of the ac raster image") -)) - (BITBLT NIL 0 0 CHARBITMAP (ADD1 DUMMYCHAROFFSET) - 0 - (IDIFFERENCE DUMMYWIDTH 2) - NIL - 'TEXTURE - 'REPLACE BLACKSHADE) (* ; + )) + (BITBLT NIL 0 0 CHARBITMAP (ADD1 DUMMYCHAROFFSET) + 0 + (IDIFFERENCE DUMMYWIDTH 2) + NIL + 'TEXTURE + 'REPLACE BLACKSHADE) (* ;  "Fill in the dummy-character black blot") - - (RETURN CSINFO]) + (RETURN CSINFO)))]) (\ACCHARIMAGELIST [LAMBDA (BOXLIST) (* jds "15-Jun-85 11:37") @@ -595,51 +620,48 @@ Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All ri (HELP]) ) -(RPAQ? INTERPRESSFONTDIRECTORIES '("{Erinyes}Fonts>")) +(ADDTOVAR DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET)) + +(RPAQ? INTERPRESSFONTDIRECTORIES ) (DECLARE%: EVAL@COMPILE (PUTPROPS \POSITIONFONTFILE MACRO - ((WSTRM NSMICASIZE FIRSTCHAR LASTCHAR FAMILY FACECODE) + ((WSTRM NSMICASIZE FIRSTCHAR LASTCHAR FAMILY FACECODE) (* gbn "25-Jul-85 02:15") - (* ; - "sets FIRSTCHAR LASTCHAR, and positions the file correctly") - - (* ;; "Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. FIRSTCHAR and LASTCHAR are passed 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. --- --- Returns NIL if the font is not found") - (bind TYPE LENGTH SIZE FAMCODE FILEFAM FILEFACE (NEXT _ 0) first (OR (SETQ FAMCODE (\FAMILYCODE (OR FAMILY T) - WSTRM)) - (RETURN NIL)) + 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)) (* ; "This is the right family/face") - [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)))) + (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)))) ) -(PUTPROPS AFONT COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2792 38939 (\CREATESTARFONT 2802 . 4480) (\READACFONTBOXES 4482 . 6709) ( -\READACFONTFILE 6711 . 18604) (\ACCHARIMAGELIST 18606 . 18963) (\ACCHARWIDTHLIST 18965 . 20231) ( -\GETFBB 20233 . 23513) (\ACCHARPOSLIST 23515 . 24565) (\ACROTATECHAR 24567 . 25131) (\READFONTWDFILE -25133 . 33166) (\FACECODE 33168 . 33762) (\FAMILYCODE 33764 . 35068) (\FINDFONT 35070 . 38937))))) + (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))))) STOP diff --git a/sources/AFONT.DFASL b/sources/AFONT.DFASL index f54e1d02b..3a69ea175 100644 Binary files a/sources/AFONT.DFASL and b/sources/AFONT.DFASL differ diff --git a/sources/APUTDQ b/sources/APUTDQ index c9192b34e..7fbeb9529 100644 --- a/sources/APUTDQ +++ b/sources/APUTDQ @@ -1,18 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "16-Jan-2025 13:35:20" {DSK}matt>Interlisp>medley>sources>APUTDQ.;2 10901 +(FILECREATED "11-Jun-2025 08:43:36" {WMEDLEY}APUTDQ.;5 10433 - :EDIT-BY "mth" + :EDIT-BY rmk - :CHANGES-TO (FNS LOADUP) + :CHANGES-TO (VARS APUTDQCOMS) - :PREVIOUS-DATE "25-Oct-2022 11:44:17" {DSK}matt>Interlisp>medley>sources>APUTDQ.;1) + :PREVIOUS-DATE "23-May-2025 09:03:46" {WMEDLEY}APUTDQ.;4) -(* ; " -Copyright (c) 1981-1988, 1990, 2021-2022, 2025 by Venue & Xerox Corporation. -") - (PRETTYCOMPRINT APUTDQCOMS) (RPAQQ APUTDQCOMS @@ -33,10 +29,8 @@ Copyright (c) 1981-1988, 1990, 2021-2022, 2025 by Venue & Xerox Corporation. (LOGINHOST/DIR '{DSK})) (FNS LOADUP ENDLOADUP) (ALISTS (SYSTEMINITVARS \CONNECTED.DIRECTORY DWIMFLG ADDSPELLFLG FILEPKGFLG BUILDMAPFLG - UPDATEMAPFLG DEFAULTREGISTRY DEFAULTPRINTINGHOST DIRECTORIES USERGREETFILES - NETWORKOSTYPES CH.NET.HINT CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION - ADVISEDFNS LISPUSERSDIRECTORIES DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS - INTERPRESSFONTDIRECTORIES)) + UPDATEMAPFLG DEFAULTREGISTRY DEFAULTPRINTINGHOST NETWORKOSTYPES CH.NET.HINT + CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION ADVISEDFNS)) [DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "many of these are obsolete and can be removed, but it is unclear which ones") @@ -173,26 +167,19 @@ Copyright (c) 1981-1988, 1990, 2021-2022, 2025 by Venue & Xerox Corporation. (CLRPROMPT]) ) -(ADDTOVAR SYSTEMINITVARS - (\CONNECTED.DIRECTORY . {DSK}) - (DWIMFLG . T) - (ADDSPELLFLG . T) - (FILEPKGFLG . T) - (BUILDMAPFLG . T) - (UPDATEMAPFLG . T) - (DEFAULTREGISTRY) - (DEFAULTPRINTINGHOST) - (DIRECTORIES) - (USERGREETFILES) - (NETWORKOSTYPES) - (CH.NET.HINT) - (CH.DEFAULT.DOMAIN) - (CH.DEFAULT.ORGANIZATION) - (ADVISEDFNS) - (LISPUSERSDIRECTORIES {DSK}) - (DISPLAYFONTDIRECTORIES {DSK}) - (DISPLAYFONTEXTENSIONS DISPLAYFONT) - (INTERPRESSFONTDIRECTORIES {DSK})) +(ADDTOVAR SYSTEMINITVARS (\CONNECTED.DIRECTORY . {DSK}) + (DWIMFLG . T) + (ADDSPELLFLG . T) + (FILEPKGFLG . T) + (BUILDMAPFLG . T) + (UPDATEMAPFLG . T) + (DEFAULTREGISTRY) + (DEFAULTPRINTINGHOST) + (NETWORKOSTYPES) + (CH.NET.HINT) + (CH.DEFAULT.DOMAIN) + (CH.DEFAULT.ORGANIZATION) + (ADVISEDFNS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (DUMMYDEF (ADDSTATS *) @@ -261,10 +248,8 @@ Copyright (c) 1981-1988, 1990, 2021-2022, 2025 by Venue & Xerox Corporation. (ADDTOVAR LAMA ) ) -(PUTPROPS APUTDQ COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 -2021 2022 2025)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3999 6207 (GREETFILENAME 4009 . 5882) (FAULTEVAL 5884 . 5956) (FAULTAPPLY 5958 . 6044) -(ERRORX 6046 . 6112) (SET-DOCUMENTATION 6114 . 6205)) (6208 7228 (SMASHFILECOMS 6218 . 6560) ( -SMASHFILECOMSLST 6562 . 7226)) (7322 8926 (LOADUP 7332 . 7916) (ENDLOADUP 7918 . 8924))))) + (FILEMAP (NIL (3701 5909 (GREETFILENAME 3711 . 5584) (FAULTEVAL 5586 . 5658) (FAULTAPPLY 5660 . 5746) +(ERRORX 5748 . 5814) (SET-DOCUMENTATION 5816 . 5907)) (5910 6930 (SMASHFILECOMS 5920 . 6262) ( +SMASHFILECOMSLST 6264 . 6928)) (7024 8628 (LOADUP 7034 . 7618) (ENDLOADUP 7620 . 8626))))) STOP diff --git a/sources/APUTDQ.LCOM b/sources/APUTDQ.LCOM index cd668212f..568867e67 100644 Binary files a/sources/APUTDQ.LCOM and b/sources/APUTDQ.LCOM differ diff --git a/sources/FILESETS b/sources/FILESETS index 0aea357f3..5f450a863 100644 --- a/sources/FILESETS +++ b/sources/FILESETS @@ -1,9 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "23-May-2023 08:11:56" {DSK}larry>il>medley>sources>FILESETS.;24 - :EDIT-BY "lmm" +(FILECREATED "17-Jul-2025 12:07:14" {DSK}kaplan>Local>medley3.5>git-medley>sources>FILESETS.;15 6295 + + :EDIT-BY rmk + + :CHANGES-TO (VARS EXPORTFILES 0LISPSET) + + :PREVIOUS-DATE "17-Jul-2025 09:32:58" +{DSK}kaplan>Local>medley3.5>git-medley>sources>FILESETS.;14) - :PREVIOUS-DATE " 1-Mar-2023 07:49:03" {DSK}larry>il>medley>sources>FILESETS.;23) (PRETTYCOMPRINT FILESETSCOMS) @@ -53,8 +58,8 @@ (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY - DSK UFS UFSCALLC PASSWORDS FONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST - CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) + DSK UFS UFSCALLC PASSWORDS FONT MEDLEYFONTFORMAT APUTDQ COMPATIBILITY DMISC CMLMACROS + CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT LLDISPLAY)) (RPAQQ 2LISPSET (MACHINEINDEPENDENT)) @@ -65,7 +70,7 @@ LLCHAR LLSTK PMAP LLGC ATBL FILEIO EXTERNALFORMAT LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER IMAGEIO PROC XCCS PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS LLETHER PUP UFS - DTDECLARE BIGBITMAPS)) + DTDECLARE)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) diff --git a/sources/FONT b/sources/FONT index ebef461de..39591da8e 100644 --- a/sources/FONT +++ b/sources/FONT @@ -1,13 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 1-Feb-2025 12:28:10" {DSK}matt>Interlisp>medley>sources>FONT.;4 191871 +(FILECREATED "27-Jul-2025 13:39:57"  +{DSK}kaplan>Local>medley3.5>working-medley>sources>FONT.;375 239724 - :EDIT-BY "mth" + :EDIT-BY rmk - :CHANGES-TO (VARS FONTCOMS) - (FNS WRITESTRIKEFONTFILE) + :CHANGES-TO (FNS \FONT.CHECKARGS \FONT.CHECKARGS1 \COERCEFONTDESC) + (MACROS FONTASCENT FONTDESCENT FONTHEIGHT) - :PREVIOUS-DATE "19-Dec-2024 15:25:17" {DSK}matt>Interlisp>medley>sources>FONT.;1) + :PREVIOUS-DATE "25-Jul-2025 21:38:56" {WMEDLEY}FONT.;372) (PRETTYCOMPRINT FONTCOMS) @@ -16,129 +17,164 @@ [ (* ;; "font functions ") + (DECLARE%: EVAL@COMPILE DONTCOPY (* ; + "Can't be loaded/not needed during INIT, load at end of LOAD-LISP.") + (FILES (SYSLOAD) + MULTI-ALIST)) (FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY \STRINGWIDTH.GENERIC) - (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT) - [COMS (* ; - "Until we pin down the exact interface") - (P (MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT) - (MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT] - [COMS (* ; "MAPPING FOR DOS FILENAMES ") - (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) - (HELVETICA . HV) - (TIMESROMAND . TD) - (HELVETICAD . HD) - (MODERN . MD) - (CLASSIC . CL) - (GACHA . GC) - (TITAN . TI) - (LETTERGOTHIC . LG) - (BOLDPS . BP) - (TERMINAL . TM) - (CLASSICTHIN . CT) - (HIPPO . HP) - (LOGO . LG) - (MATH . MA) - (OLDENGLISH . OE) - (SYMBOL . SY] + (COMS (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT + GETFONTCLASSCOMPONENT) + (MACROS \GETFONTCLASSCOMPONENT \SETFONTCLASSCOMPONENT)) + (VARS NSFONTFAMILIES ALTOFONTFAMILIES) (COMS (* ;; "Creation: ") - (FNS FONTCREATE \FONT.SYMBOLMEMB \FONT.SYMBOLASSOC \FONT.COMPARESYMBOL)) + (FNS FONTCREATE FONTCREATE1 FONTCREATE.SLUGFD \FONT.CHECKARGS \FONT.CHECKARGS1 + \FONTCREATE1.NOFN FONTFILEP \READCHARSET \COERCEFONTSPEC) + (FNS \COERCEFONTDESC) + (MACROS SPREADFONTSPEC) + (FNS COMPLETE.FONT COMPLETEFONTP COMPLETE.CHARSET PRUNEFONTSLUGS)) (COMS (* ;; "Property extraction:") (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH)) (COMS - (* ;; "Bitmap editing/manipulation:") - - (FNS GETCHARBITMAP PUTCHARBITMAP MOVECHARBITMAP)) - (FNS FONTCOPY FONTSAVAILABLE FONTFILEFORMAT FONTP FONTUNPARSE SETFONTDESCRIPTOR CHARCODEP - EDITCHAR \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY - \CREATE-REAL-CHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \SEARCHFONTFILES - \FINDFONTFILE \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR \FONTFILENAME - \FONTFILENAME.OLD \FONTFILENAME.NEW \FONTINFOFROMFILENAME \FONTINFOFROMFILENAME.OLD - \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE \READDISPLAYFONTFILE) + (* ;; "Moving character information") + + (FNS EDITCHAR) + (* ; "Should this be on EDITFONT ?") + (FNS GETCHARBITMAP PUTCHARBITMAP \GETCHARBITMAP.CSINFO \PUTCHARBITMAP.CSINFO) + (FNS MOVECHARBITMAP MOVEFONTCHARS \MOVEFONTCHAR SLUGCHARP.DISPLAY \GETCHARINFO) + (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. ") - (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE)) + (FNS FONTFILES \FINDFONTFILE \FONTFILENAMES \FONTFILENAME \FONTFILENAME.OLD + \FONTFILENAME.NEW \FONTINFOFROMFILENAME \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*) - - (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)") -) - (COMS - (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)") - - (INITVARS (CACHEDISPLAYFONTS)) - (GLOBALVARS CACHEDISPLAYFONTS) - (* ; "STRIKE format file support") - (FNS \READSTRIKEFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO - \SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS - \SFMAKECOLOR) - (FNS WRITESTRIKEFONTFILE STRIKECSINFO)) + (GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)) + (FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \UNITWIDTHSVECTOR + \COERCECHARSET \BUILDSLUGCSINFO \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR + SETFONTCHARENCODING) + (FNS FONTSAVAILABLE FONTEXISTS? \FONTSAVAILABLE.INCORE \SEARCHFONTFILES FLUSHFONTSINCORE + MATCHFONTFACE FINDFONTFILES) + (INITVARS \FONTEXISTS?-CACHE) + (COMS (* ; + "Functions for DISPLAY IMAGESTREAMTYPES ") + (FNS \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY \FONTEXISTS?.DISPLAY)) + (FNS STRIKEFONT.FILEP STRIKEFONT.GETCHARSET WRITESTRIKEFONTFILE STRIKECSINFO) + (COMS (* ; "Bitmap faking") + (FNS MAKEBOLD.CHARSET MAKEBOLD.CHAR MAKEITALIC.CHARSET MAKEITALIC.CHAR \SFMAKEBOLD + \SFMAKEITALIC) + (FNS \SFMAKEROTATEDFONT \SFROTATECSINFO \SFROTATEFONTCHARACTERS \SFROTATECSINFOOFFSETS) + (FNS \SFMAKECOLOR)) (FNS FONTDESCRIPTOR.DEFPRINT FONTCLASS.DEFPRINT) (INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO) (SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO) (INITVARS (\FONTSINCORE) (\DEFAULTDEVICEFONTS) (\UNITWIDTHSVECTOR)) - (GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) + (GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR))) - (CONSTANTS (NORUNCODE 255)) (EXPORT (OPTIMIZERS FONTPROP)) - [DECLARE%: DONTCOPY - (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO) - (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET \FGETWIDTH - \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH \FGETIMAGEWIDTH \FSETIMAGEWIDTH - \GETCHARSETINFO \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR) - (FUNCTIONS \CREATEKERNELEMENT \FSETLEFTKERN) - (CONSTANTS (\MAXNSCHAR 65535] - (FNS \FGETLEFTKERN) - (COMS (* ; "NS Character specific code") - (FNS \CREATECHARSET \INSTALLCHARSETINFO) - (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS - MISSINGCHARSETDISPLAYFONTCOERCIONS CHARSETERRORFLG) - (INITVARS (DISPLAYFONTCOERCIONS NIL) - [MISSINGCHARSETDISPLAYFONTCOERCIONS '(((GACHA) - (TERMINAL)) - ((MODERN) - (CLASSIC)) - ((TIMESROMAN) - (CLASSIC)) - ((HELVETICA) - (MODERN)) - ((TERMINAL 6) - (MODERN 6)) - ((TERMINAL 8) - (MODERN 8)) - ((TERMINAL 10) - (MODERN 10)) - ((TERMINAL 12) - (MODERN 12] - [MISSINGDISPLAYFONTCOERCIONS '(((GACHA) - (TERMINAL)) - ((MODERN) - (CLASSIC)) - ((TIMESROMAN) - (CLASSIC)) - ((HELVETICA) - (MODERN)) - ((TERMINAL) - (MODERN] - (CHARSETERRORFLG NIL) - (\DEFAULTCHARSET 0))) + (DECLARE%: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO) + (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET + \FGETWIDTH \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH + \FGETIMAGEWIDTH \FSETIMAGEWIDTH) + (MACROS \XGETCHARSETINFO \GETCHARSETINFO \INSURECHARSETINFO + \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR CHARSETPROP) + (CONSTANTS (\MAXNSCHAR 65535))) + (MACROS INDIRECTCHARSETP MAKECSSOURCE)) + (FNS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN) + [COMS (FNS \CREATEFONT \CREATECHARSET \INSTALLCHARSETINFO \INSTALLCHARSETINFO.CHARENCODING) + (EXPORT (GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYGLYPHCOERCIONS + DISPLAYFONTCOERCIONS)) + + (* ;; "Removed ((CLASSIC 36) (CLASSIC 24)) so that TIMESROMAN 36 BOLD boldifies rather than coercing to CLASSIC 24 BOLD.") + + (INITVARS [DISPLAYFONTCOERCIONS '(((HELVETICA 1) + (HELVETICA 4)) + ((HELVETICA 2) + (HELVETICA 4)) + ((MODERN 60) + (MODERN 48)) + ((MODERN 96) + (MODERN 72)) + ((MODERN 120) + (MODERN 72)) + ((PALATINO 9) + (PALATINO 12)) + ((PALATINO 8) + (PALATINO 10)) + ((PALATINO 6) + (PALATINO 10)) + ((TITAN 6) + (TITAN 10)) + ((TITAN 9 (TITAN 10))) + ((LPT) + (AMTEX] + [DISPLAYGLYPHCOERCIONS '(((GACHA) + (TERMINAL)) + ((MODERN) + (CLASSIC)) + ((TIMESROMAN) + (CLASSIC)) + ((HELVETICA) + (MODERN)) + ((TERMINAL) + (MODERN] + [ADOBEDISPLAYFONTCOERCIONS '(((HELVETICABLACK 16) + (HELVETICABLACK 18)) + ((SYMBOL) + (ADOBESYMBOL)) + ((SYMBOL 11) + (ADOBESYMBOL 10)) + ((AVANTGARDE-DEMI) + (AVANTGARDE)) + ((AVANTGARDE-BOOK) + (AVANTGARDE)) + ((NEWCENTURYSCHLBK) + (CENTURYSCHOOLBOOK)) + ((BOOKMAN-LIGHT) + (BOOKMAN)) + ((BOOKMAN-DEMI) + (BOOKMAN)) + ((HELVETICA-NARROW) + (HELVETICANARROW)) + ((HELVETICA 24) + (ADOBEHELVETICA 24] + (\DEFAULTCHARSET 0)) + (COMS (* ; "MAPPING FOR DOS FILENAMES ") + (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) + (HELVETICA . HV) + (TIMESROMAND . TD) + (HELVETICAD . HD) + (MODERN . MD) + (CLASSIC . CL) + (GACHA . GC) + (TITAN . TI) + (LETTERGOTHIC . LG) + (BOLDPS . BP) + (TERMINAL . TM) + (CLASSICTHIN . CT) + (HIPPO . HP) + (LOGO . LG) + (MATH . MA) + (OLDENGLISH . OE) + (SYMBOL . SY] (FNS \FONTRESETCHARWIDTHS) - [DECLARE%: DONTEVAL@LOAD (INITVARS (DISPLAYFONTEXTENSIONS 'DISPLAYFONT) - (DISPLAYFONTDIRECTORIES '( - {DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ - - {dsk}/usr/local/lde/fonts/display/publishing/ - ] + (GLOBALVARS DISPLAYCHARSETFNS) + [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DISPLAYFONTDIRECTORIES NIL)) + (ADDVARS (DISPLAYCHARSETFNS (STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET] + (DECLARE%: DONTEVAL@LOAD DOCOPY (* ; "The loadup might have fewer") + (ADDVARS (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT DISPLAYFONT))) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MAXCODE 255) (DUMMYINDEX 256))) - (MACROS \FGETCHARIMAGEWIDTH \GETFONTDESC \SETCHARSETINFO) + (MACROS \FGETCHARIMAGEWIDTH \SETCHARSETINFO) (LOCALVARS . T) (PROP FILETYPE FONT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) @@ -149,6 +185,11 @@ (* ;; "font functions ") +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SYSLOAD) + MULTI-ALIST) +) (DEFINEQ (CHARWIDTH @@ -168,26 +209,27 @@ CHARCODE]) (CHARWIDTHY - [LAMBDA (CHARCODE FONT) (* edited%: "18-Mar-86 19:30") + [LAMBDA (CHARCODE FONT) (* ; "Edited 22-May-2025 09:47 by rmk") + (* edited%: "18-Mar-86 19:30") (* ; - "Gets the Y-component of the width of a character code in a font.") + "Gets the Y-component of the width of a character code in a font.") (OR (\CHARCODEP CHARCODE) (\ILLEGAL.ARG CHARCODE)) (LET (TEMP WY) (COND ((type? FONTDESCRIPTOR FONT) - (SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) - FONT))) + (SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\INSURECHARSETINFO (\CHARSET CHARCODE) + FONT))) (COND ((FIXP WY)) (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE))) (T 0))) ((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T))) (* ; - "NIL font goes thru here--primary output file") + "NIL font goes thru here--primary output file") (IMAGEOP 'IMCHARWIDTHY TEMP TEMP CHARCODE)) - (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) - (FONTCREATE FONT] + (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\INSURECHARSETINFO (\CHARSET CHARCODE) + (FONTCREATE FONT] (COND ((FIXP WY)) (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE))) @@ -232,7 +274,8 @@ (ffetch DDSPACEWIDTH of DD]) (\STRINGWIDTH.GENERIC - [LAMBDA (STR FONT RDTBL SPACEWIDTH) (* ; "Edited 3-Apr-87 13:47 by jop") + [LAMBDA (STR FONT RDTBL SPACEWIDTH) (* ; "Edited 22-May-2025 09:51 by rmk") + (* ; "Edited 3-Apr-87 13:47 by jop") (* ;; "Returns the width of STR with SPACEWIDTH for the width of spaces. RDTBL has already been coerced, so no FLG is needed ") @@ -246,45 +289,44 @@ (if RDTBL then (GO SLOW) else (RETURN (for C WIDTHSBASE CSET inatom STR - sum [COND - ((NEQ CSET (\CHARSET C)) - (SETQ CSET (\CHARSET C)) - (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) - of (\GETCHARSETINFO CSET FONT - ] - (COND - ((EQ C (CHARCODE SPACE)) - SPACEWIDTH) - (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C] + sum [COND + ((NEQ CSET (\CHARSET C)) + (SETQ CSET (\CHARSET C)) + (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) + of (\INSURECHARSETINFO CSET FONT] + (COND + ((EQ C (CHARCODE SPACE)) + SPACEWIDTH) + (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C] ((STRINGP STR) (RETURN (LET ((TOTAL 0) ESC ESCWIDTH WIDTHSBASE CSET) [COND (RDTBL (* ; - "Count delimiting quotes and internal escapes") + "Count delimiting quotes and internal escapes") (SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %")) 2)) (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL)) (SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC] [for C instring STR do [COND - ((NEQ (\CHARSET C) - CSET) (* ; - "Get the widths vector for this character set") - (SETQ CSET (\CHARSET C)) - (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) - of (\GETCHARSETINFO CSET FONT] - (add TOTAL (COND - ((EQ C (CHARCODE SPACE)) - SPACEWIDTH) - (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C)) - (COND - ((AND RDTBL (OR (EQ C (CHARCODE %")) - (EQ C ESC))) + ((NEQ (\CHARSET C) + CSET) (* ; + "Get the widths vector for this character set") + (SETQ CSET (\CHARSET C)) + (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\INSURECHARSETINFO + CSET FONT] + (add TOTAL (COND + ((EQ C (CHARCODE SPACE)) + SPACEWIDTH) + (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C)) + (COND + ((AND RDTBL (OR (EQ C (CHARCODE %")) + (EQ C ESC))) (* ; "String char must be escaped") - ESCWIDTH) - (T 0] + ESCWIDTH) + (T 0] TOTAL] SLOW (* ; "Do the general case here") @@ -294,54 +336,44 @@ (DECLARE (SPECVARS TOTALWIDTH WIDTHSBASE CSET FONT SPACEWIDTH)) (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC) (add TOTALWIDTH (COND - ((EQ CC (CHARCODE SPACE)) - SPACEWIDTH) - ((EQ CSET (\CHARSET CC)) - (\FGETWIDTH WIDTHSBASE - (\CHAR8CODE CC))) - (T (SETQ CSET (\CHARSET CC)) - (SETQ WIDTHSBASE - (ffetch (CHARSETINFO - WIDTHS) - of (\GETCHARSETINFO - CSET FONT))) - (\FGETWIDTH WIDTHSBASE - (\CHAR8CODE CC] + ((EQ CC (CHARCODE SPACE)) + SPACEWIDTH) + ((EQ CSET (\CHARSET CC)) + (\FGETWIDTH WIDTHSBASE (\CHAR8CODE + CC))) + (T (SETQ CSET (\CHARSET CC)) + (SETQ WIDTHSBASE + (ffetch (CHARSETINFO WIDTHS) + of (\INSURECHARSETINFO CSET + FONT))) + (\FGETWIDTH WIDTHSBASE + (\CHAR8CODE CC] STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*) TOTALWIDTH]) ) (DEFINEQ (DEFAULTFONT - [LAMBDA (DEVICE FONT NOERRORFLG) (* ; "Edited 28-Jul-88 13:15 by rmk:") + [LAMBDA (DEVICE FONT NOERRORFLG) (* ; "Edited 14-Jul-2025 22:43 by rmk") + (* ; "Edited 5-Jul-2025 13:30 by rmk") + (* ; "Edited 28-Jul-88 13:15 by rmk:") (* ; "Edited 24-Mar-87 14:41 by FS") + (DECLARE (GLOBALVARS DEFAULTFONT)) - (* ;; "Returns the default font for an image type. Really only needed to guarantee validity of the display default font for system critical routines, in case the user has smashed the variable DEFAULTFONT. Note that SETFONTCLASSCOMPONENT and FONTCLASS guarantee that the display component is either NIL or a fontdescriptor.") - - (* ;; "FS- If FONT provided set the font descriptor. Do not bother to check if NOERRORFLG is NEW. (old code had (AND FONT (EQ NOERRORFLG 'NEW)))") - - [OR (type? FONTCLASS DEFAULTFONT) - (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT] - (if FONT - then - - (* ;; "FS- Not clear the fontclass should be smashed, perhaps instead should make a new FONTCLASS and then rebind DEFAULTFONT. Leaving alone for histerical reasons") - - (SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE FONT) - else - - (* ;; "The code below (not mine!) is messy but is correct (unless weirdness pops up because of deep recursion).") + (* ;; "It is a natural mistake for the user to set DEFAULTFONT to an actual font instead of a class. In that case we up it into a class, ignoring FONT if the given DEFAULTFONT designates a font descriptor.") - (COND - ((\COERCEFONTDESC DEFAULTFONT DEVICE T)) - (NOERRORFLG NIL) - ((EQ (\DEVICESYMBOL DEVICE T) - 'DISPLAY) + (CL:UNLESS DEVICE + (SETQ DEVICE 'DISPLAY)) + (CL:UNLESS (type? FONTCLASS DEFAULTFONT) - (* ;; "If getting for the display and the font can't be found perhaps because of garbage in the display field of the DEFAULTFONTCLASS, then the system-guaranteed displayfont. Otherwise, cause the error in the re-coercion. Can never tell when DEVICE is just a symbol.") + (* ;; "If total garbage, we want to fall through to the coerce, to protect the system. NLSETQ to suppress even invalid-argument errors.") - \GUARANTEEDDISPLAYFONT) - ((\COERCEFONTDESC DEFAULTFONT DEVICE]) + (CL:WHEN DEFAULTFONT + [SETQ FONT (CAR (NLSETQ (FONTCREATE DEFAULTFONT NIL NIL NIL DEVICE T]) + (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT))) + (CL:IF FONT + (SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE FONT) + (FONTCREATE DEFAULTFONT NIL NIL NIL DEVICE NOERRORFLG))]) (FONTCLASS [LAMBDA (NAME FONTLIST CREATEFORDEVICES) (* jds " 9-Sep-86 18:49") @@ -387,63 +419,69 @@ (FONTUNPARSE (CDR X]) (FONTCLASSCOMPONENT - [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* rmk%: "14-Sep-84 19:34") + [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* ; "Edited 4-Jul-2025 10:32 by rmk") + (* rmk%: "14-Sep-84 19:34") + + (* ;; "Returns the old DEVICE-specific font of the class. Only if FONT designates a font descriptor is that descriptor installed.") + (PROG1 (FONTCREATE FONTCLASS NIL NIL NIL DEVICE NOERRORFLG) - (* ; - "This works its way down to \COERCEFONTDESC, where it needs to be done quickly") (AND FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG)) (SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT)))]) (SETFONTCLASSCOMPONENT - [LAMBDA (FONTCLASS DEVICE FONT) (* ; "Edited 29-Aug-91 12:20 by jds") - (PROG ((NEWFONT (FONTCREATE FONT NIL NIL NIL DEVICE))) - - (* ;; "replaces will barf if FONTCLASS is not a fontclass") - - (SELECTQ (SETQ DEVICE (FONTPROP NEWFONT 'DEVICE)) - (DISPLAY (replace (FONTCLASS DISPLAYFD) of FONTCLASS with NEWFONT)) - (INTERPRESS (replace (FONTCLASS INTERPRESSFD) of FONTCLASS with NEWFONT - )) - (PRESS (replace (FONTCLASS PRESSFD) of FONTCLASS with NEWFONT)) - (RPLACD [OR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of FONTCLASS)) - (CAR (push (fetch (FONTCLASS OTHERFDS) of FONTCLASS) - (CONS DEVICE] - NEWFONT)) - (RETURN NEWFONT]) + [LAMBDA (FONTCLASS DEVICE FONT) (* ; "Edited 5-Jul-2025 09:53 by rmk") + (* ; "Edited 15-Jun-2025 00:02 by rmk") + (* ; "Edited 29-Aug-91 12:20 by jds") + (\SETFONTCLASSCOMPONENT FONTCLASS DEVICE (FONTCREATE FONT NIL NIL NIL DEVICE]) + +(GETFONTCLASSCOMPONENT + [LAMBDA (FONTCLASS DEVICE NOERRORFLG) (* ; "Edited 5-Jul-2025 09:54 by rmk") + (* ; "Edited 14-Jun-2025 20:32 by rmk") + + (* ;; "This is a user entry") + + (LET (FONT) + (if (type? FONTCLASS FONTCLASS) + then (SETQ FONT (\GETFONTCLASSCOMPONENT FONTCLASS DEVICE)) + + (* ;; "Component may no be a properly instantiated font description. Let FONTCREATE have a try, possibly error.") + + (CL:UNLESS (type? FONTDESCRIPTOR FONT) + (if (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DEVICE T)) + then (\SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT) + elseif NOERRORFLG + else (ERROR (CONCAT "Invalid " DEVICE " fontclass component") + FONTCLASS))) + FONT + elseif NOERRORFLG + then NIL + else (ERROR "NOT A FONTCLASS" FONTCLASS]) ) +(DECLARE%: EVAL@COMPILE +(PUTPROPS \GETFONTCLASSCOMPONENT MACRO (OPENLAMBDA (FCLASS DEVICE) + (SELECTQ DEVICE + (DISPLAY (fetch (FONTCLASS DISPLAYFD) of FCLASS)) + (INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of FCLASS)) + (PRESS (fetch (FONTCLASS PRESSFD) of FCLASS)) + (GETMULTI (fetch (FONTCLASS OTHERFDS) of FCLASS) + DEVICE)))) + +(PUTPROPS \SETFONTCLASSCOMPONENT MACRO (OPENLAMBDA (FCLASS DEVICE NEWFONT) + (SELECTQ DEVICE + (DISPLAY (replace (FONTCLASS DISPLAYFD) of FCLASS + with NEWFONT)) + (INTERPRESS (replace (FONTCLASS INTERPRESSFD) + of FCLASS with NEWFONT)) + (PRESS (replace (FONTCLASS PRESSFD) of FCLASS + with NEWFONT)) + (PUTMULTI (fetch (FONTCLASS OTHERFDS) of FCLASS) + DEVICE NEWFONT)))) +) +(RPAQQ NSFONTFAMILIES (CLASSIC MODERN TERMINAL OPTIMA TITAN BOLDPS PCTERMINAL)) -(* ; "Until we pin down the exact interface") - - -(MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT) - -(MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT) - - - -(* ; "MAPPING FOR DOS FILENAMES ") - - -(RPAQ? *DISPLAY-FONT-NAME-MAP* - '((TIMESROMAN . TR) - (HELVETICA . HV) - (TIMESROMAND . TD) - (HELVETICAD . HD) - (MODERN . MD) - (CLASSIC . CL) - (GACHA . GC) - (TITAN . TI) - (LETTERGOTHIC . LG) - (BOLDPS . BP) - (TERMINAL . TM) - (CLASSICTHIN . CT) - (HIPPO . HP) - (LOGO . LG) - (MATH . MA) - (OLDENGLISH . OE) - (SYMBOL . SY))) +(RPAQQ ALTOFONTFAMILIES (GACHA TIMESROMAN TIMESROMAND HELVETICA OLDENGLISH SNAIL TONTO)) @@ -453,211 +491,476 @@ (FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) + (* ; "Edited 21-Jul-2025 09:11 by rmk") + (* ; "Edited 11-Jul-2025 10:23 by rmk") + (* ; "Edited 4-Jul-2025 12:10 by rmk") + (* ; "Edited 27-Jun-2025 10:29 by rmk") + (* ; "Edited 21-Jun-2025 14:53 by rmk") + (* ; "Edited 20-May-2025 20:41 by rmk") (* ; "Edited 10-Oct-88 09:53 by rmk:") (* ; "Edited 28-Jul-88 14:43 by rmk:") (* ; "Edited 10-Nov-87 18:08 by FS") - (* ;; "Create a font descriptor for the specified font. If NOERRORFLG, return NIL if the font doesn't exist; otherwise cause an error.") - - (* ;; "Cache and fonts.widths traffic in uppercase only.") - - (* ;; "character set is optional and defaults to \DEFAULTCHARSET (0 in our world)") - - (DECLARE (GLOBALVARS IMAGESTREAMTYPES \DEFAULTCHARSET)) - (PROG (FONTX (CHSET (OR CHARSET \DEFAULTCHARSET))) - (RETURN (COND - ((LISTP FAMILY) - (SELECTQ (CAR FAMILY) - (FONT (SETQ FONTX (CDR FAMILY))) - (CLASS (COND - ((LITATOM (CADR FAMILY)) (* ; "litatom class name") - (RETURN (FONTCLASS (CADR FAMILY) - (CDDR FAMILY) - DEVICE))) - (T (* ; - "Allows for a font named CLASS--distinguished cause its size is not a litatom") - (SETQ FONTX FAMILY)))) - (SETQ FONTX FAMILY)) - (FONTCREATE (CAR FONTX) - (OR (CADR FONTX) - SIZE) - (OR (CADDR FONTX) - FACE) - (OR (CADDDR FONTX) - ROTATION) - (OR (CADR (CDDDR FONTX)) - DEVICE) - NOERRORFLG CHSET)) - ([SETQ FONTX (COND - ((type? FONTDESCRIPTOR FAMILY) - FAMILY) - ((NULL FAMILY) - (DEFAULTFONT DEVICE)) - ((type? FONTCLASS FAMILY) - - (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class. Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.") - - (\COERCEFONTDESC FAMILY DEVICE NOERRORFLG)) - ((OR (IMAGESTREAMP FAMILY) - (type? WINDOW FAMILY)) - (DSPFONT NIL FAMILY] - + (* ;; "Returns the requested font descriptor. If NOERRORFLG, return NIL if the requested font or CHARSET doesn't exist; otherwise cause an error. And always cause an error if any argument is bogus.") + + (* ;; "A font exists if it has at least one charset, even if the optionally desired CHARSET doesn't exist. There is no difference between all the characters in a missing charset and particular missing characters in an existing charset: they will show up as slugs. ") + + (* ;; "Original code picked off and returned a fontclass for (CLASS ...). That's now handled in \FONT.CHECKARGS, and it coerces to a fontdescriptor for DEVICE, not a class.") + + (PROG (FONTSPEC) + RETRY + (* ; "Back to here if ERROR returns") + (SETQ FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE CHARSET)) + + (* ;; "If FONTSPEC is a fontdescriptor, it's what we want") + + (RETURN (if (type? FONTDESCRIPTOR FONTSPEC) + then FONTSPEC + else (SPREADFONTSPEC FONTSPEC) + (if (FONTCREATE1 FAMILY SIZE FACE ROTATION DEVICE (OR CHARSET + \DEFAULTCHARSET)) + elseif NOERRORFLG + then NIL + else (ERROR "FONT NOT FOUND" FONTSPEC) + (GO RETRY]) + +(FONTCREATE1 + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 24-Jul-2025 19:52 by rmk") + (* ; "Edited 23-Jul-2025 10:01 by rmk") + (* ; "Edited 17-Jul-2025 23:48 by rmk") + (* ; "Edited 10-Jul-2025 12:38 by rmk") + (* ; "Edited 4-Jul-2025 17:05 by rmk") + (* ; "Edited 21-Jun-2025 09:28 by rmk") + (* ; "Edited 18-Jun-2025 14:50 by rmk") + (* ; "Edited 16-Jun-2025 12:07 by rmk") + (* ; "Edited 14-Jun-2025 20:53 by rmk") + (* ; "Edited 10-Jun-2025 23:54 by rmk") + + (* ;; "Causes an error only if the arguments are bogus, otherwise returns NIL if font or character set not found. Error happens at FONTCREATE") + + (DECLARE (GLOBALVARS IMAGESTREAMTYPES \FONTSINCORE)) + (LET (FONTX) + (CL:WHEN (if (SETQ FONTX (GETMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE)) + then (\INSURECHARSETINFO CHARSET FONTX) + elseif (AND (FONTEXISTS? FAMILY SIZE FACE ROTATION DEVICE CHARSET) + (SETQ FONTX (\CREATEFONT FAMILY SIZE FACE ROTATION DEVICE CHARSET)) + (\INSURECHARSETINFO CHARSET FONTX)) + then (PUTMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE FONTX)) + (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTX with (\AVGCHARWIDTH FONTX)) + FONTX)]) + +(FONTCREATE.SLUGFD + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 14-Jun-2025 23:25 by rmk") + (* ; "Edited 13-Jun-2025 09:44 by rmk") + (* ; "Edited 11-Jun-2025 10:59 by rmk") + + (* ;; "For the REMEMBER case, dummy font descriptor completely fillled with a slug charsetinfo") + + (LET* ([FONTDESC (create FONTDESCRIPTOR + FONTDEVICE _ DEVICE + FONTFAMILY _ FAMILY + FONTSIZE _ SIZE + FONTFACE _ FACE + \SFAscent _ SIZE + \SFDescent _ 0 + \SFHeight _ SIZE + ROTATION _ ROTATION + FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE) + FONTCHARENCODING _ 'MCCS + FONTAVGCHARWIDTH _ (FIXR (FTIMES SIZE 0.75] + (SLUGCSINFO (\BUILDSLUGCSINFO FONTDESC))) + (if CHARSET + then (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONTDESC) + CHARSET SLUGCSINFO) + else (for CS from 0 to (ADD1 \MAXCHARSET) do (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR + of FONTDESC) + CS SLUGCSINFO))) + FONTDESC]) + +(\FONT.CHECKARGS + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 27-Jul-2025 13:30 by rmk") + (* ; "Edited 22-Jul-2025 23:07 by rmk") + (* ; "Edited 21-Jul-2025 09:22 by rmk") + (* ; "Edited 14-Jul-2025 20:09 by rmk") + (* ; "Edited 11-Jul-2025 10:15 by rmk") + (* ; "Edited 5-Jul-2025 13:37 by rmk") + (* ; "Edited 2-Jul-2025 16:50 by rmk") + (* ; "Edited 27-Jun-2025 10:42 by rmk") + (* ; "Edited 15-Jun-2025 00:25 by rmk") + + (* ;; "Decodes and checks the various ways of specifying the arguments to font lookup functions.") + + (* ;; "If FAMILY can be coerced to a font descriptor and none of its properties are overwritten by the other aguments, then that font descriptor is returned. Otherwise the value is the coerce fontspec (family size face rotation device). CHARSET is checked for validity but not coerced.") + + (LET (FONTX) + (SETQ DEVICE (if (NULL DEVICE) + then (CL:IF (type? FONTDESCRIPTOR FAMILY) + (fetch (FONTDESCRIPTOR FONTDEVICE) of FAMILY) + 'DISPLAY) + elseif (OR (AND (LITATOM DEVICE) + (NEQ DEVICE T)) + (STRINGP DEVICE)) + then (\DEVICESYMBOL DEVICE) + elseif [AND (SETQ DEVICE (\GETSTREAM DEVICE 'OUTPUT T)) + (CAR (MKLIST (IMAGESTREAMTYPE DEVICE] + else (\ILLEGAL.ARG DEVICE))) + (CL:WHEN (AND (EQ 'CLASS (CAR FAMILY)) + (LITATOM (CADR FAMILY))) + + (* ;; "This used to be at the entry to FONTCREATE, and it returned the FONTCLASS. That seemed wrong--FONTCREATE should always return a fontdescriptor. So here we build a throwaway fontclass, coerce it to its device font, and fall through.") + + (SETQ FAMILY (\FONT.CHECKARGS1 (FONTCLASS (CADR FAMILY) + (CDDR FAMILY)) + DEVICE))) + (CL:UNLESS (AND FAMILY (LITATOM FAMILY) + (NEQ FAMILY T)) + + (* ;; "FAMILY T or NIL produces an error below") + + [if (LISTP FAMILY) + then (SETQ FONTX (CL:IF (EQ 'FONT (CAR FAMILY)) + (CDR FAMILY) + FAMILY)) + (SETQ FAMILY (pop FONTX)) + (SETQ SIZE (OR (pop FONTX) + SIZE)) + (SETQ FACE (OR (pop FONTX) + FACE)) + (SETQ ROTATION (OR (pop FONTX) + ROTATION)) + (SETQ DEVICE (OR (pop FONTX) + DEVICE)) + (SETQ CHARSET (pop FONTX)) + (SETQ FONTX NIL) + elseif (SETQ FONTX (CL:IF (type? FONTDESCRIPTOR FAMILY) + FAMILY + (\FONT.CHECKARGS1 FAMILY DEVICE T))) + then (* ;; - "FAMILY was a spec for a font descriptor, use it and extend it by the other args.") - - (COND - ((OR SIZE FACE ROTATION DEVICE) - (FONTCREATE (FONTPROP FONTX 'FAMILY) - (OR SIZE (FONTPROP FONTX 'SIZE)) - (OR FACE (FONTPROP FONTX 'FACE)) - (OR ROTATION (FONTPROP FONTX 'ROTATION)) - (OR DEVICE (FONTPROP FONTX 'DEVICE)) - NOERRORFLG)) - (T FONTX))) - (T (PROG (FONTFACE (DEV DEVICE)) - RETRY - [OR (LITATOM FAMILY) - (COND - (NOERRORFLG (RETURN)) - (T (LISPERROR "ARG NOT LITATOM" FAMILY T] - [OR (AND (FIXP SIZE) - (IGREATERP SIZE 0)) - (COND - (NOERRORFLG (RETURN NIL)) - (T (\ILLEGAL.ARG SIZE] - (COND - ((NULL ROTATION) - (SETQ ROTATION 0)) - ((AND (FIXP ROTATION) - (IGEQ ROTATION 0))) - (NOERRORFLG (RETURN NIL)) - (T (\ILLEGAL.ARG ROTATION))) - [SETQ DEV (COND - ((NULL DEVICE) - 'DISPLAY) - ((AND (LITATOM DEVICE) - (NEQ DEVICE T)) - (* ; -"Maybe wrong case or package, but we bet it's OK and defer expensive coercion until we've failed.") - DEV) - ((SETQ DEV (\GETSTREAM DEVICE 'OUTPUT T)) - (* ; - "T coerces here to primary output") - (fetch (IMAGEOPS IMFONTCREATE) - of (fetch (STREAM IMAGEOPS) of DEV))) - ((STRINGP DEVICE) - (MKATOM (U-CASE DEVICE))) - (NOERRORFLG (RETURN NIL)) - (T (\ILLEGAL.ARG DEVICE] - (* ; "DEV is now guanteed litatom") - NEWDEV + "FAMILY was a spec for a font descriptor. Are any of its properties overwritten?") + + (SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of FONTX)) + (CL:UNLESS SIZE + (SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONTX))) + (CL:UNLESS FACE + (SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of FONTX))) + (CL:UNLESS ROTATION + (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONTX))) + (CL:UNLESS DEVICE + (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX)))]) + + (* ;; "The arguments are now coerced, validate them.") + + (CL:UNLESS (AND FAMILY (LITATOM FAMILY) + (NEQ FAMILY T)) + (ERROR "Illegal font family" FAMILY)) + (SETQ FAMILY (U-CASE FAMILY)) + (CL:UNLESS (OR (AND (FIXP SIZE) + (IGREATERP SIZE 0)) + (EQ SIZE '*)) + (ERROR "Illegal font size" SIZE)) + (CL:UNLESS (EQ FACE '*) + (SETQ FACE (\FONTFACE FACE NIL DEVICE))) + (if (NULL ROTATION) + then (SETQ ROTATION 0) + elseif (AND (FIXP ROTATION) + (IGEQ ROTATION 0)) + elseif (EQ ROTATION '*) + else (\ILLEGAL.ARG ROTATION)) + (CL:WHEN CHARSET + (CL:UNLESS (<= 0 CHARSET \MAXCHARSET) + (\ILLEGAL.ARG CHARSET))) + (CL:WHEN FONTX + + (* ;; "Return FONTX only if no fields were overwritten") + + (CL:UNLESS (AND (EQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONTX)) + (EQUAL FACE (fetch (FONTDESCRIPTOR FONTFACE) of FONTX)) + (EQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONTX)) + (EQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX))) + (SETQ FONTX NIL))) + (OR FONTX (LIST FAMILY SIZE FACE ROTATION DEVICE]) + +(\FONT.CHECKARGS1 + [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 22-Jul-2025 18:47 by rmk") + (* ; "Edited 14-Jul-2025 19:40 by rmk") + (* ; "Edited 5-Jul-2025 14:16 by rmk") + (* ; "Edited 29-Aug-91 12:19 by jds") + + (* ;; "Coerces SPEC to a fontdescriptor appropriate for STREAM (defaulting to DISPLAY).") + + (* ;; "SPEC can be a font descriptor, a font class, any of the symbolic ways of describing those, or NIL (= DEFAULTFONT). If SPEC is a class whose component for a non-display device is uninstantiated, the display component is used as a template for the requested device font. ") + + (* ;; "STREAM denotes a device: NIL means DISPLAY, another atom is a device name itself, an IMAGESTREAM means its IMAGESTREAMTYPE. Anything else here maps to DISPLAY, but maybe that should be an illegal arg error, even of NOERRORFLG.") + + (DECLARE (GLOBALVARS DEFAULTFONT \GUARANTEEDDISPLAYFONT)) + (LET (FONT DEVICE TEMP) + (CL:UNLESS SPEC + (if DEFAULTFONT + then (SETQ SPEC DEFAULTFONT) + else (ERROR "No DEFAULTFONT"))) + (SETQ DEVICE (if (NULL STREAM) + then (* ; "Default is display") + 'DISPLAY + elseif (OR (LITATOM STREAM) + (STRINGP STREAM)) + then (\DEVICESYMBOL STREAM) + elseif (IMAGESTREAMP STREAM) + then (IMAGESTREAMTYPE STREAM) + elseif STREAM + else + (* ;; "Original jds comment: should this be allowed?") + + 'DISPLAY)) + (if (type? FONTCLASS SPEC) + then (SETQ FONT (\GETFONTCLASSCOMPONENT SPEC DEVICE)) + (if (type? FONTDESCRIPTOR FONT) + then + (* ;; "It must be a font for DEVICE") + + FONT + elseif (AND FONT (SETQ TEMP (FONTCREATE FONT NIL NIL NIL DEVICE T))) + then (\SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE TEMP) + elseif (MEMB DEVICE \DISPLAYSTREAMTYPES) + then (if (EQ SPEC DEFAULTFONT) + then (* ; "Guarantee system integrity") + (\SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE \GUARANTEEDDISPLAYFONT + ) + elseif NOERRORFLG + then NIL + else (ERROR (CONCAT "DISPLAY component for " SPEC " is invalid"))) + elseif (SETQ FONT (FONTCREATE (\GETFONTCLASSCOMPONENT SPEC 'DISPLAY) + NIL NIL NIL DEVICE NOERRORFLG)) + then + (* ;; "If the DEVICE component was garbage, we use the display component as a template for an appropriate FD.") + + (\SETFONTCLASSCOMPONENT SPEC DEVICE FONT) + elseif NOERRORFLG + then NIL + else (ERROR (CONCAT DEVICE " component for " SPEC " is invalid"))) + elseif (SETQ FONT (if (type? FONTDESCRIPTOR SPEC) + then SPEC + elseif (OR (IMAGESTREAMP SPEC) + (type? WINDOW SPEC)) + then (DSPFONT NIL SPEC))) + then (if (NULL STREAM) + then + (* ;; + "NIL device doesn't default to display if a fully-specified font was found") + + FONT + elseif (EQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT)) + then FONT + else + (* ;; "Switch device") + + (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG]) + +(\FONTCREATE1.NOFN + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 16-Jun-2025 12:08 by rmk") + (ERROR (CONCAT "FONTCREATE function is not specified for image-type " DEVICE]) + +(FONTFILEP + [LAMBDA (FILE DEVICE) (* ; "Edited 13-Jul-2025 13:41 by rmk") + (* ; "Edited 27-Jun-2025 22:54 by rmk") + (CL:UNLESS DEVICE + (SETQ DEVICE 'DISPLAY)) + (RESETLST + (if (EQ DEVICE 'DISPLAY) + then (for FNS STRM in (GETATOMVAL (PACK* DEVICE 'CHARSETFNS)) + first [RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT)) + `(PROGN (CLOSEF? OLDVALUE] + do (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS) + STRM))) + (RETURN (CAR FNS))) + (CLOSEF? STRM))))]) + +(\READCHARSET + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 21-Jul-2025 18:35 by rmk") + (* ; "Edited 14-Jul-2025 19:51 by rmk") + (* ; "Edited 12-Jul-2025 13:20 by rmk") + (* ; "Edited 10-Jul-2025 12:38 by rmk") + (* ; "Edited 6-Jul-2025 13:09 by rmk") + + (* ;; "This finds the first file in the directories/extensions order that contains information about charset, determines its format, and reads it in. The assumption is that the first such existing file is the one we want. ") + + (CL:WHEN (EQ ROTATION 0) + (RESETLST + (for FILE STRM CSINFO in (FONTFILES FAMILY SIZE FACE ROTATION DEVICE CHARSET) + do + (* ;; "We know that FILE exists and is the best source of information about charset--maybe none. We assume FILE is one of the valid formats, we open it separately for each format-type, and ensure it is closed on exit. We can't used CL:WITHOPEN-FILE because that doesn't exist in the loadup when the first font is created.") + + (for FNS in (GETATOMVAL (PACK* DEVICE 'CHARSETFNS)) + do [RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT)) + `(PROGN (CLOSEF? OLDVALUE] + (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS) + STRM))) + + (* ;; "Assume that predicate leaves stream (open or closed) in proper state for its retrieval function. The FILE may be of the right type, but it may not contain this CHARSET (e.g. a complete MEDLEYFONTFILE but CHARSET doesn't exist anywhere).") + + (SETQ CSINFO (APPLY* (CADDR FNS) + STRM CHARSET FAMILY SIZE FACE ROTATION DEVICE)) + (CL:WHEN (type? CHARSETINFO CSINFO) + (CL:UNLESS (CHARSETPROP CSINFO 'CSCHARENCODING) + + (* ;; "The file didn't know its own encoding") + + (CHARSETPROP CSINFO 'CSCHARENCODING (if (NEQ CHARSET 0) + then 'MCCS + elseif (MEMB FAMILY + NSFONTFAMILIES + ) + then 'XCCS$ + elseif (MEMB FAMILY + ALTOFONTFAMILIES + ) + then 'ALTOTEXT + else FAMILY))) + + (* ;; "Remember the file that this basic charset information came from, before any character coercions, for informational purposes. Path and version won't be valid if sysout moves, or if PSEUDOFILENAME's aren't aligned. Don't want files to be new atoms, for loadup.") + + (CHARSETPROP CSINFO 'FILE (MKSTRING (PSEUDOFILENAME FILE))) + (CL:UNLESS (CHARSETPROP CSINFO 'SOURCE) + (CHARSETPROP CSINFO 'SOURCE (MAKECSSOURCE FAMILY SIZE FACE + ROTATION DEVICE CHARSET))) + (RETURN))) + + (* ;; "Prepare for next format-type") + + (CLOSEF? STRM)) + (CL:WHEN CSINFO (RETURN CSINFO)))))]) + +(\COERCEFONTSPEC + [LAMBDA (COERCIONS FAMILY SIZE FACE ROTATION DEVICE CHARSET) + (* ; "Edited 23-Jul-2025 15:39 by rmk") + + (* ;; "Produces a list of coerced fontspecs, one for each coercion whose right side matches the given parameters.") + + (* ;; "If MFAMILY is NIL, use FAMILY--default when nothing else matches.") + + (for C MATCH TARGET MFAMILY MSIZE TFAMILY TSIZE COERCED in COERCIONS + eachtime (SETQ MATCH (CAR C)) + (if (LISTP MATCH) + then (SETQ MFAMILY (OR (CAR MATCH) + FAMILY)) + (SETQ MSIZE (OR (CADR MATCH) + SIZE)) + else (SETQ MFAMILY (OR MATCH FAMILY)) + (SETQ MSIZE SIZE)) when [AND (EQ FAMILY MFAMILY) + (EQ SIZE MSIZE) + (PROGN (SETQ TARGET (CADR C)) (* ; - "Check after device since it is device-dependent") - (SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG DEV) - (RETURN NIL))) - (* ; "Don't truly coerce to \FONTSYMBOL or \DEVICESYMBOL until we've had a shot at the font cache, since re-interning atoms is so expensive") - [RETURN (COND - ((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV)) - [(SETQ FONTX (CDR (ASSOC DEV IMAGESTREAMTYPES))) - - (* ;; "Device is valid, font just doesn't exist. FONTFACE, DEV already canonical. Make FAMILY so, so that each imagestream type doesn't have to.") - - (SETQ FAMILY (\FONTSYMBOL FAMILY)) - (COND - ((SETQ FONTX (APPLY* (OR (CADR (ASSOC 'FONTCREATE FONTX) - ) - (FUNCTION NILL)) - FAMILY SIZE FONTFACE ROTATION DEV - CHSET)) + "Don't include the input in the output, if the coercions have a loop") + (if (LISTP TARGET) + then (SETQ TFAMILY (OR (CAR TARGET) + FAMILY)) + (SETQ TSIZE (OR (CADR TARGET) + SIZE)) + else (SETQ TFAMILY TARGET) + (SETQ TSIZE SIZE)) + (NOT (AND (EQ FAMILY TFAMILY) + (EQ SIZE TSIZE] + unless (MEMBER (SETQ COERCED (LIST TFAMILY TSIZE FACE ROTATION DEVICE CHARSET)) + $$VAL) collect COERCED]) +) +(DEFINEQ - (* ;; "default creation case. Use fontcreate method from device, build a fontdescriptor and use setfontdescriptor to install it.") +(\COERCEFONTDESC + [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 27-Jul-2025 13:38 by rmk") + (* ; "Edited 22-Jul-2025 18:47 by rmk") + (* ; "Edited 14-Jul-2025 19:40 by rmk") + (* ; "Edited 5-Jul-2025 14:16 by rmk") + (* ; "Edited 29-Aug-91 12:19 by jds") - (* ;; "OBSOLETEd by the CHARSETINFO code (OR (ffetch FONTIMAGEWIDTHS of FONTX) (freplace FONTIMAGEWIDTHS of FONTX with (ffetch \SFWidths of FONTX)))") + (* ;; "It was intended to remove this function in favor of FONTCREATE as FONT was cleaned up to avoid stack overflows in certain situations. The calls in system code have been replaced, but the macros for FONTASCENT, FONTDESCENT, and FONTHEIGHT were putting out calls. So there may be calls in user code that still has compiled references.") - (* ;; - "the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.") + (* ;; "Those macro calls all had NIL for STREAM and NOERRORFLG. So here we give a dummy definition that just calls FONTCREATE") - (* ;; "We should probably force all device implementations to obey these conventions, then remove these generic updates") + (* ;; "We probably should put out a macro to compile \COERCEFONTDESC away.") - (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) - of FONTX with (\AVGCHARWIDTH FONTX)) - (SETFONTDESCRIPTOR FAMILY SIZE FONTFACE ROTATION - DEV FONTX)) - (T (GO NOTFOUND] - ((NEQ DEV (SETQ DEV (U-CASE DEV))) + (FONTCREATE SPEC]) +) +(DECLARE%: EVAL@COMPILE - (* ;; "We didn't recognize the device, so check to see whether coercion to U-CASE IL changes anything. Could be slow, but we're heading for an error.") +(PUTPROPS SPREADFONTSPEC MACRO (OPENLAMBDA (FONTSPEC) + (CL:WHEN (type? FONTDESCRIPTOR FONTSPEC) + (SETQ FONTSPEC (FONTPROP FONTSPEC 'SPEC))) + (SETQ SIZE (CADR FONTSPEC)) + (SETQ FACE (CADDR FONTSPEC)) + (SETQ ROTATION (CADDDR FONTSPEC)) + (SETQ DEVICE (CAR (CDDDDR FONTSPEC))) + (SETQ CHARSET (CADR (CDDDDR FONTSPEC))) + (SETQ FAMILY (CAR FONTSPEC)))) +) +(DEFINEQ - (GO NEWDEV)) - (T (GO NOTFOUND] - NOTFOUND - (COND - (NOERRORFLG (RETURN NIL)) - (T (ERROR "FONT NOT FOUND (coerced to)" - (LIST FAMILY SIZE FONTFACE ROTATION DEV)) - (GO RETRY]) - -(\FONT.SYMBOLMEMB - [LAMBDA (USERINPUT LIST) (* ; "Edited 7-Feb-89 15:47 by jds") - (for X on LIST when (\FONT.COMPARESYMBOL USERINPUT (CAR X)) - do (RETURN X]) - -(\FONT.SYMBOLASSOC - [LAMBDA (USERINPUT LIST) (* ; "Edited 28-Jul-88 16:56 by rmk:") - (* ; "Edited 28-Jul-88 15:15 by rmk:") - (* ; "Edited 28-Jul-88 15:03 by rmk:") - (* ; "Edited 28-Jul-88 14:44 by rmk:") - (* ; "Edited 28-Jul-88 14:16 by rmk:") - (for X FIRSTC (NC _ (NCHARS USERINPUT)) in LIST - first (SETQ FIRSTC (CHCON1 USERINPUT)) - [if (AND (IGEQ FIRSTC (CHARCODE a)) - (ILEQ FIRSTC (CHARCODE z))) - then (SETQ FIRSTC (IDIFFERENCE FIRSTC (IDIFFERENCE (CHARCODE a) - (CHARCODE A] - when (AND (EQ NC (NCHARS (CAR X))) - (EQ FIRSTC (CHCON1 (CAR X))) - (\FONT.COMPARESYMBOL USERINPUT (CAR X) - NC FIRSTC)) do (RETURN X]) - -(\FONT.COMPARESYMBOL - [LAMBDA (USERINPUT KEY INPUTNC INPUTFIRSTC) (* ; - "Edited 24-May-93 16:45 by sybalsky:mv:envos") - - (* ;; " An open coded case- and package-insensitive comparison of atom pnames, assuming that KEY is already upper-case but USERINPUT may not be. Maybe there is a simple function that does this.") - - (* ;; "INPUTNC and INPUTFIRSTC can be passed in if they are common to lots of calls") +(COMPLETE.FONT + [LAMBDA (FONTSPEC EVENIFCOMPLETE) (* ; "Edited 21-Jun-2025 11:37 by rmk") + (* ; "Edited 19-Jun-2025 14:42 by rmk") + (* ; "Edited 12-Jun-2025 22:06 by rmk") + (* ; "Edited 8-Jun-2025 15:57 by rmk") + (* ; "Edited 7-Jun-2025 15:18 by rmk") + (* ; "Edited 23-May-2025 22:57 by rmk") + (* ; "Edited 20-May-2025 19:57 by rmk") + (* ; "Edited 16-May-2025 21:26 by rmk") + + (* ;; "This returns a FONTDESCRIPTOR for FONTSPEC that is complete with respect to all known character sources. A caller that wants to insure that only files sources are considered should reset \FONTSINCORE and \FONTEXISTS?-CACHE. If reset, we still get the benefit of previous completions/coercions in this run if medleyfont files have been created for them.") + + (LET ((FONT (FONTCREATE FONTSPEC))) (* ; + "This will pick up FAMILY/SIZE...properties from FONT") + (CL:WHEN (OR EVENIFCOMPLETE (NOT (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT))) + (for CS from 0 to \MAXCHARSET do + (* ;; + "Skips existing charsets--they already have as much information as they are ever going to get") + + (\INSURECHARSETINFO CS FONT)) + (replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with T)) + (PRUNEFONTSLUGS FONT) + FONT]) + +(COMPLETEFONTP + [LAMBDA (FONT) (* ; "Edited 24-May-2025 20:55 by rmk") + (* ; "Edited 20-May-2025 14:37 by rmk") + + (* ;; "A font is incomplete if there is a NIL in any charset slot. Completing will install a charset everywhere, even if it is a slug charset.") + + (SETQ FONT (FONTCREATE FONT)) + (for CS from 0 to \MAXCHARSET always (\XGETCHARSETINFO FONT CS]) + +(COMPLETE.CHARSET + [LAMBDA (CSINFO FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS FONTDESC) + (* ; "Edited 12-Jul-2025 13:15 by rmk") + (* ; "Edited 10-Jul-2025 12:38 by rmk") + (* ; "Edited 9-Jul-2025 09:12 by rmk") + (* ; "Edited 21-Jun-2025 08:49 by rmk") + (* ; "Edited 18-Jun-2025 23:18 by rmk") + (* ; "Edited 8-Jun-2025 20:20 by rmk") + (* ; "Edited 7-Jun-2025 13:52 by rmk") + + (* ;; "CSINFO has some characters for this charset, but others may fill in from later fonts in the coercion chain. We assume that CSINFO is or will be the charsetinfo for CHARSET in the font described by FAMILY SIZE... For each missing code we look through all the possible coercions to find the first font with real information about that character. We copy that character up to CSINFO.") + + (CL:UNLESS (fetch (CHARSETINFO CSCOMPLETEP) of CSINFO) + [for THINCODE SOURCECSINFO GLYPHADDED from 0 to \MAXTHINCHAR + when (AND (SLUGCHARP.DISPLAY THINCODE CSINFO) + (SETQ SOURCECSINFO (\COERCECHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET + COERCIONS THINCODE))) + do (\MOVEFONTCHAR SOURCECSINFO CSINFO THINCODE THINCODE FONTDESC) + (SETQ GLYPHADDED T) finally (CL:WHEN GLYPHADDED(* ; "The source is now here") + (CHARSETPROP CSINFO 'SOURCE + (MAKECSSOURCE FAMILY SIZE FACE ROTATION DEVICE + CHARSET)))] + (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with T)) + CSINFO]) - (COND - ((AND (LITATOM USERINPUT) - (EQ [CL:AREF *PACKAGE-FROM-INDEX* (fetch (PNAMECELL PACKAGEINDEX) - of (PROGN (\PNAMECELL USERINPUT] - *INTERLISP-PACKAGE*)) - - (* ;; "If the user's symbol is in the IL package (which is where all the KEYs are), we can use EQ, which is MUCH faster.") - - (OR (EQ USERINPUT KEY) - (EQ (U-CASE USERINPUT) - KEY))) - (T - (* ;; "Otherwise, we do the comparison character by character.") - - (AND (EQ (OR INPUTNC (NCHARS USERINPUT)) - (NCHARS KEY)) - [COND - (INPUTFIRSTC (EQ INPUTFIRSTC (CHCON1 KEY))) - ((EQ (SETQ INPUTFIRSTC (CHCON1 USERINPUT)) - (CHCON1 KEY))) - ((AND (IGEQ INPUTFIRSTC (CHARCODE a)) - (ILEQ INPUTFIRSTC (CHARCODE z))) - (EQ (IDIFFERENCE INPUTFIRSTC (IDIFFERENCE (CHARCODE a) - (CHARCODE A))) - (CHCON1 KEY] - (for CHAR1 inatom USERINPUT as CHAR2 inatom KEY - always (OR (EQ CHAR1 CHAR2) - (AND (IGEQ CHAR1 (CHARCODE a)) - (ILEQ CHAR1 (CHARCODE z)) - (EQ CHAR2 (IPLUS CHAR1 (CONSTANT (IDIFFERENCE (CHARCODE A) - (CHARCODE a]) +(PRUNEFONTSLUGS + [LAMBDA (FONT) (* ; "Edited 9-Jun-2025 15:02 by rmk") + (* ; "Edited 24-May-2025 21:11 by rmk") + (SETQ FONT (FONTCREATE FONT)) + (for CS CSINFO from 0 to \MAXCHARSET when (AND (SETQ CSINFO (\XGETCHARSETINFO FONT CS)) + (fetch (CHARSETINFO CSSLUGP) of CSINFO)) + do (\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT) + CS NIL)) + FONT]) ) @@ -667,21 +970,35 @@ (DEFINEQ (FONTASCENT - [LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:23") - (ffetch \SFAscent of (\GETFONTDESC FONTSPEC]) + [LAMBDA (FONTSPEC) (* ; "Edited 14-Jul-2025 22:52 by rmk") + (* ; "Edited 5-Jul-2025 18:47 by rmk") + (* lmm "19-NOV-82 00:23") + (ffetch \SFAscent of (FONTCREATE FONTSPEC]) (FONTDESCENT - [LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:24") + [LAMBDA (FONTSPEC) (* ; "Edited 14-Jul-2025 22:53 by rmk") + (* ; "Edited 5-Jul-2025 18:47 by rmk") + (* lmm "19-NOV-82 00:24") (* ; "See comment in FONTASCENT") - (ffetch \SFDescent of (\GETFONTDESC FONTSPEC]) + (ffetch \SFDescent of (FONTCREATE FONTSPEC]) (FONTHEIGHT - [LAMBDA (FONTSPEC) (* kbr%: " 9-Jan-86 18:29") - (fetch (FONTDESCRIPTOR \SFHeight) of (\GETFONTDESC FONTSPEC]) + [LAMBDA (FONTSPEC) (* ; "Edited 14-Jul-2025 22:52 by rmk") + (* ; "Edited 5-Jul-2025 18:47 by rmk") + (* kbr%: " 9-Jan-86 18:29") + (fetch (FONTDESCRIPTOR \SFHeight) of (FONTCREATE FONTSPEC]) (FONTPROP - [LAMBDA (FONT PROP) (* kbr%: "13-May-85 22:36") - (SETQ FONT (\GETFONTDESC FONT)) + [LAMBDA (FONT PROP) (* ; "Edited 23-Jul-2025 17:01 by rmk") + (* ; "Edited 13-Jul-2025 22:44 by rmk") + (* ; "Edited 8-Jun-2025 20:42 by rmk") + (* ; "Edited 24-May-2025 07:40 by rmk") + (* ; "Edited 18-May-2025 10:01 by rmk") + (* ; "Edited 16-May-2025 14:27 by rmk") + (* ; "Edited 13-May-2025 09:32 by rmk") + (* ; "Edited 2-May-2025 19:59 by rmk") + (* kbr%: "13-May-85 22:36") + (SETQ FONT (FONTCREATE FONT)) (SELECTQ PROP (HEIGHT (ffetch \SFHeight of FONT)) (ASCENT (ffetch \SFAscent of FONT)) @@ -696,13 +1013,24 @@ (BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT))) (ROTATION (ffetch ROTATION of FONT)) (DEVICE (ffetch FONTDEVICE of FONT)) + (CHARENCODING [OR (ffetch FONTCHARENCODING of FONT) + (freplace FONTCHARENCODING of FONT + with (if (NEQ CHARSET 0) + then 'MCCS + elseif (MEMB (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) + NSFONTFAMILIES) + then 'XCCS$ + elseif (MEMB (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) + ALTOFONTFAMILIES) + then 'ALTOTEXT + else (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT]) (SPEC (LIST (ffetch FONTFAMILY of FONT) (ffetch FONTSIZE of FONT) (COPY (ffetch FONTFACE of FONT)) (ffetch ROTATION of FONT) (ffetch FONTDEVICE of FONT))) (DEVICESPEC (* ; - "DEVICE fields are for communicating coercions to the particular printing device") + "DEVICE fields are for communicating coercions to the particular printing device") [COND ((ffetch FONTDEVICESPEC of FONT) (COPY (ffetch FONTDEVICESPEC of FONT))) @@ -712,18 +1040,18 @@ (CADDR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTFACE of FONT]) (DEVICESLOPE [fetch SLOPE of (COND - ((ffetch FONTDEVICESPEC of FONT) - (CADDR (ffetch FONTDEVICESPEC of FONT))) - (T (ffetch FONTFACE of FONT]) + ((ffetch FONTDEVICESPEC of FONT) + (CADDR (ffetch FONTDEVICESPEC of FONT))) + (T (ffetch FONTFACE of FONT]) (DEVICEWEIGHT [fetch WEIGHT of (COND - ((ffetch FONTDEVICESPEC of FONT) - (CADDR (ffetch FONTDEVICESPEC of FONT))) - (T (ffetch FONTFACE of FONT]) + ((ffetch FONTDEVICESPEC of FONT) + (CADDR (ffetch FONTDEVICESPEC of FONT))) + (T (ffetch FONTFACE of FONT]) (DEVICEEXPANSION [fetch EXPANSION of (COND - ((ffetch FONTDEVICESPEC of FONT) - (CADDR (ffetch FONTDEVICESPEC of FONT))) - (T (ffetch FONTFACE of FONT]) + ((ffetch FONTDEVICESPEC of FONT) + (CADDR (ffetch FONTDEVICESPEC of FONT))) + (T (ffetch FONTFACE of FONT]) (DEVICESIZE (COND ((ffetch FONTDEVICESPEC of FONT) (CADR (ffetch FONTDEVICESPEC of FONT))) @@ -733,216 +1061,237 @@ (CAR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTFAMILY of FONT)))) (SCALE (ffetch FONTSCALE of FONT)) + (CHARSETS (for CS CSINFO (CSVECTOR _ (ffetch FONTCHARSETVECTOR of FONT)) from 0 to + \MAXCHARSET + eachtime (SETQ CSINFO (\GETBASEPTR CSVECTOR (UNFOLD CS 2))) when CSINFO + unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CS)) (\ILLEGAL.ARG PROP]) (\AVGCHARWIDTH - [LAMBDA (FONT) (* rmk%: "27-Nov-84 18:40") + [LAMBDA (FONT) (* ; "Edited 10-Jul-2025 23:24 by rmk") + (* ; "Edited 20-May-2025 21:03 by rmk") + (* rmk%: "27-Nov-84 18:40") (* ;; "Returns the average width of a character, to be used in units-to-characters approximations, as in fixing the linelength") - (PROG ((W (CHARWIDTH (CHARCODE A) - FONT))) - (RETURN (COND - ((NEQ 0 W) - W) - ([NEQ 0 (SETQ W (FIXR (FTIMES 0.6 (FONTPROP FONT 'HEIGHT] - W) - (T 1]) + (LET ((W (CHARWIDTH (CHARCODE A) + FONT))) + (if (NEQ 0 W) + then W + elseif [NEQ 0 (SETQ W (FIXR (FTIMES 0.6 (FONTPROP FONT 'HEIGHT] + then W + else 1]) ) -(* ;; "Bitmap editing/manipulation:") +(* ;; "Moving character information") (DEFINEQ -(GETCHARBITMAP - [LAMBDA (CHARCODE FONT) (* ; "Edited 26-Apr-89 21:49 by atm") +(EDITCHAR + [LAMBDA (CHARCODE FONT) (* ; "Edited 14-Jul-2025 22:54 by rmk") + (* ; "Edited 5-Jul-2025 18:47 by rmk") + (* rrb "24-MAR-82 12:22") (* ; - "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.") - (COND - ((OR (CHARCODEP CHARCODE) - (EQ CHARCODE 256)) (* ; - "bitmap for char 256 is what gets printed if char not found") - ) - ((OR (STRINGP CHARCODE) - (LITATOM CHARCODE)) (* ; - "For strings & litatoms, take the first character") - (SETQ CHARCODE (CHCON1 CHARCODE))) - ((TYPEP CHARCODE 'CL:CHARACTER) (* ; - "For common-lisp CHARACTERs, convert it to the char code first.") - (SETQ CHARCODE (CL:CHAR-INT CHARCODE))) - (T (\ILLEGAL.ARG CHARCODE))) - (PROG (CBM (FONTDESC (\GETFONTDESC FONT)) - CSINFO CWDTH CHGHT) - - (* ;; "fetch the csinfo for the character set of this character. Bitmaps and widths must be fetched from it") - - (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) - FONTDESC)) - - (* ;; "(\\fgetwidth (|fetch| (charsetinfo widths) |of| csinfo) (\\char8code charcode))") - - [SETQ CBM (BITMAPCREATE [SETQ CWDTH (if (fetch (CHARSETINFO IMAGEWIDTHS) - of CSINFO) - then (\FGETIMAGEWIDTH (fetch (CHARSETINFO - IMAGEWIDTHS) - of CSINFO) - (\CHAR8CODE CHARCODE)) - else (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) - of CSINFO) - (\CHAR8CODE CHARCODE] - (SETQ CHGHT (FONTPROP FONTDESC 'HEIGHT)) - (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CHARSETINFO - CHARSETBITMAP) - of CSINFO] - (BITBLT (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO) - (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO) - (\CHAR8CODE CHARCODE)) - 0 CBM 0 0 CWDTH CHGHT) - (RETURN CBM]) + "calls the bitmap editor on a character of a font") + (LET ((FONTDESC (FONTCREATE FONT))) + (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC]) +) -(PUTCHARBITMAP - [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 27-Apr-89 11:19 by atm") - (* ;; "stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font descriptor FONTDESC. If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.") - (OR (TYPENAMEP NEWCHARBITMAP 'BITMAP) - (\ILLEGAL.ARG NEWCHARBITMAP)) - (COND - ((CHARCODEP CHARCODE)) - ((OR (STRINGP CHARCODE) - (LITATOM CHARCODE)) - (SETQ CHARCODE (CHCON1 CHARCODE))) - (T (\ILLEGAL.ARG CHARCODE))) - (PROG* ((FONTDESC (\GETFONTDESC FONT)) - (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) - FONTDESC)) - (CDESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) - (CASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) - (CHEIGHT (IPLUS CDESCENT CASCENT)) - (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) - (CIMWIDTH (if IMWIDTHS - then (\FGETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE)) - else NIL)) - (CWIDTH (OR CIMWIDTH (CHARWIDTH CHARCODE FONTDESC))) - (FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) - (OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP)) - TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET - (BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of FONTBITMAP))) - - (* ;; "fetch the ascents and descents of the bitmap and the new maximums.") - - (SETQ BWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP)) - (SETQ BHEIGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP)) - (SETQ BDESCENT (OR NEWCHARDESCENT CDESCENT)) - (SETQ BASCENT (IDIFFERENCE BHEIGHT BDESCENT)) - (SETQ NDESCENT (IMAX BDESCENT CDESCENT)) - (SETQ NASCENT (IMAX BASCENT CASCENT)) - (SETQ NHEIGHT (IPLUS NDESCENT NASCENT)) - (SETQ CHAROFFSET (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE))) - - (* ;; "set up a new target bitmap if any of the parameters have changed.") - - (COND - ((EQ CHAROFFSET (\FGETOFFSET OFFSETS \MAXTHINCHAR)) - - (* ;; "changing the bitmap for a character which formerly pointed at the slug character. Allocate a new bitmap character bitmap for this.") - - (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH BWIDTH) - NHEIGHT BITSPERPIXEL)) - (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) - OFWIDTH CHEIGHT) (* ; "copy the old characters over.") - (SETQ CHAROFFSET OFWIDTH)) - ((NEQ CWIDTH BWIDTH) - - (* ;; "The bitmaps differ in width; create a new bitmap with things at the right places, then update widths and offsets.") - - (SETQ DW (IDIFFERENCE BWIDTH CWIDTH)) (* ; "Difference in character widths") - (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW) - NHEIGHT BITSPERPIXEL))(* ; - "this may also be a taller bitmap if NHEIGHT is larger than CHEIGHT.") - (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) - CHAROFFSET CHEIGHT) (* ; - "Copy that portion to the left of the character.") - (BITBLT FONTBITMAP (IPLUS CHAROFFSET CWIDTH) - 0 TEMPBITMAP (IPLUS CHAROFFSET BWIDTH) - (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) - (ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWIDTH))) - CHEIGHT) (* ; - "Copy that portion to the right of the new character.") - ) - ((OR (IGREATERP BASCENT CASCENT) - (IGREATERP BDESCENT CDESCENT)) - - (* ;; "The new character is TALLER than the existing bitmap. Make a larger bitmap.") - - (SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL)) - (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) - OFWIDTH CHEIGHT) - - (* ;; "Copy the existing bitmap into it, adjusting for a larger descent in the new character (if there is one)") - - )) - - (* ;; "copy the new bitmap in and update parameters.") - - (BITBLT NEWCHARBITMAP 0 0 (OR TEMPBITMAP FONTBITMAP) - CHAROFFSET - (IMAX 0 (IDIFFERENCE NDESCENT BDESCENT)) - BWIDTH BHEIGHT) - [COND - (TEMPBITMAP (UNINTERRUPTABLY - - (* ;; "update the parameters for this character set.") - - (\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE) - BWIDTH) (* ; - "The new character's correct width") +(* ; "Should this be on EDITFONT ?") + +(DEFINEQ + +(GETCHARBITMAP + [LAMBDA (CHARCODE FONT) (* ; "Edited 7-Jun-2025 09:55 by rmk") + (* ; "Edited 22-May-2025 09:52 by rmk") + (* ; "Edited 25-Apr-2025 11:21 by rmk") + (* ; "Edited 26-Apr-89 21:49 by atm") + (* ; + "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.") + (SETQ CHARCODE (CHARCODE.DECODE CHARCODE)) + (\GETCHARBITMAP.CSINFO (\CHAR8CODE CHARCODE) + (\INSURECHARSETINFO (\CHARSET CHARCODE) + (FONTCREATE FONT]) + +(PUTCHARBITMAP + [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 7-Jun-2025 10:16 by rmk") + (* ; "Edited 25-May-2025 15:10 by rmk") + (* ; "Edited 22-May-2025 09:56 by rmk") + (* ; "Edited 1-May-2025 13:21 by rmk") + (* ; "Edited 25-Apr-2025 11:21 by rmk") + (* ; "Edited 27-Apr-89 11:19 by atm") + + (* ;; "Stores the bitmap NEWCHARBITMAP as the character CHARCODE in FONT. If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.") + + (CL:UNLESS (type? BITMAP NEWCHARBITMAP) + (\ILLEGAL.ARG NEWCHARBITMAP)) + (SETQ CHARCODE (CHARCODE.DECODE CHARCODE)) + (SETQ FONT (FONTCREATE FONT)) + (LET ((CSINFO (\INSURECHARSETINFO (\CHARSET CHARCODE) + FONT))) + (UNINTERRUPTABLY + (CL:WHEN (\PUTCHARBITMAP.CSINFO (\CHAR8CODE CHARCODE) + CSINFO NEWCHARBITMAP NEWCHARDESCENT) + + (* ;; "update the ascent/descent properties for the font as a whole.") + + (LET [(ASCENT (IMAX (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) + (fetch (FONTDESCRIPTOR \SFAscent) of FONT))) + (DESCENT (IMAX (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO) + (fetch (FONTDESCRIPTOR \SFDescent) of FONT] + (replace (FONTDESCRIPTOR \SFAscent) of FONT with ASCENT) + (replace (FONTDESCRIPTOR \SFDescent) of FONT with DESCENT) + (replace (FONTDESCRIPTOR \SFHeight) of FONT with (IPLUS ASCENT DESCENT))))) + NIL NEWCHARBITMAP]) + +(\GETCHARBITMAP.CSINFO + [LAMBDA (CODE CSINFO) (* ; "Edited 7-Jun-2025 09:56 by rmk") + (* ; "Edited 22-May-2025 09:52 by rmk") + (* ; "Edited 25-Apr-2025 11:21 by rmk") + (* ; "Edited 26-Apr-89 21:49 by atm") + (* ; + "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.") + + (* ;; "CODE is a thincode") + + (LET (CSBITMAP CBM CWDTH CHGHT) + (CL:WHEN (SETQ CSBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) + (SETQ CHGHT (BITMAPHEIGHT CSBITMAP)) + (SETQ CBM (BITMAPCREATE (SETQ CWDTH (if (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) + then (\FGETIMAGEWIDTH (fetch (CHARSETINFO + IMAGEWIDTHS) + of CSINFO) + CODE) + else (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) + of CSINFO) + CODE))) + CHGHT + (fetch (BITMAP BITMAPBITSPERPIXEL) of CSBITMAP))) + (BITBLT CSBITMAP (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO) + CODE) + 0 CBM 0 0 CWDTH CHGHT)) + CBM]) + +(\PUTCHARBITMAP.CSINFO + [LAMBDA (CODE CSINFO NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 7-Jun-2025 10:15 by rmk") + (* ; "Edited 25-May-2025 15:10 by rmk") + (* ; "Edited 22-May-2025 09:56 by rmk") + (* ; "Edited 1-May-2025 13:21 by rmk") + (* ; "Edited 25-Apr-2025 11:21 by rmk") + (* ; "Edited 27-Apr-89 11:19 by atm") + + (* ;; "Stores the bitmap NEWCHARBITMAP as the thin character CODE in CSINFO. If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.") + + (LET* ((CDESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (CASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) + (CHEIGHT (IPLUS CDESCENT CASCENT)) + (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) + (CIMWIDTH (AND IMWIDTHS (\FGETIMAGEWIDTH IMWIDTHS CODE))) + (CWIDTH (OR CIMWIDTH (\FGETWIDTH WIDTHS CODE))) + (FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) + (OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP)) + TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET + (BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of FONTBITMAP))) + + (* ;; "fetch the ascents and descents of the bitmap and the new maximums.") + + (SETQ BWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP)) + (SETQ BHEIGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP)) + (SETQ BDESCENT (OR NEWCHARDESCENT CDESCENT)) + (SETQ BASCENT (IDIFFERENCE BHEIGHT BDESCENT)) + (SETQ NDESCENT (IMAX BDESCENT CDESCENT)) + (SETQ NASCENT (IMAX BASCENT CASCENT)) + (SETQ NHEIGHT (IPLUS NDESCENT NASCENT)) + (SETQ CHAROFFSET (\FGETOFFSET OFFSETS CODE)) + + (* ;; "set up a new target bitmap if any of the parameters have changed.") + + (if (EQ CHAROFFSET (\FGETOFFSET OFFSETS \MAXTHINCHAR)) + then + (* ;; "changing the bitmap for a character which formerly pointed at the slug character. Allocate a new bitmap character bitmap for this.") + + (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH BWIDTH) + NHEIGHT BITSPERPIXEL)) + (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) + OFWIDTH CHEIGHT) (* ; "copy the old characters over.") + (SETQ CHAROFFSET OFWIDTH) + elseif (NEQ CWIDTH BWIDTH) + then + (* ;; "The bitmaps differ in width; create a new bitmap with things at the right places, then update widths and offsets.") + + (SETQ DW (IDIFFERENCE BWIDTH CWIDTH)) (* ; "Difference in character widths") + (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW) + NHEIGHT BITSPERPIXEL)) + (* ; + "this may also be a taller bitmap if NHEIGHT is larger than CHEIGHT.") + (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) + CHAROFFSET CHEIGHT) (* ; + "Copy that portion to the left of the character.") + (BITBLT FONTBITMAP (IPLUS CHAROFFSET CWIDTH) + 0 TEMPBITMAP (IPLUS CHAROFFSET BWIDTH) + (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) + (ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWIDTH))) + CHEIGHT) (* ; + "Copy that portion to the right of the new character.") + elseif (OR (IGREATERP BASCENT CASCENT) + (IGREATERP BDESCENT CDESCENT)) + then + (* ;; + "The new character is TALLER than the existing bitmap. Make a larger bitmap.") + + (SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL)) + + (* ;; "Copy the existing bitmap into it, adjusting for a larger descent in the new character (if there is one)") + + (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) + OFWIDTH CHEIGHT)) + + (* ;; "copy the new bitmap in and update parameters.") + + (BITBLT NEWCHARBITMAP 0 0 (OR TEMPBITMAP FONTBITMAP) + CHAROFFSET + (IMAX 0 (IDIFFERENCE NDESCENT BDESCENT)) + BWIDTH BHEIGHT) + (CL:WHEN TEMPBITMAP + (UNINTERRUPTABLY (* ; - "Make sure that we update imagewidths also") - (if IMWIDTHS - then (\FSETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE) - BWIDTH)) - (\FSETOFFSET OFFSETS (\CHAR8CODE CHARCODE) - CHAROFFSET) - [COND - (DW (for I from 0 to \MAXCHAR - do (* ; - "Run thru the offsets of later characters, adjusting them for the changed width of this character") - (if (IGREATERP (\FGETOFFSET OFFSETS I) - CHAROFFSET) - then (\FSETOFFSET OFFSETS I - (IPLUS DW (\FGETOFFSET OFFSETS I] - (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with - TEMPBITMAP - ) - (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with - NDESCENT) - (replace (CHARSETINFO CHARSETASCENT) of CSINFO with NASCENT - ) - - (* ;; "update the properties for the font as a whole.") - - [SETQ NASCENT (IMAX NASCENT (FONTPROP FONTDESC 'ASCENT] - [SETQ NDESCENT (IMAX NDESCENT (FONTPROP FONTDESC 'DESCENT] - (replace (FONTDESCRIPTOR \SFAscent) of FONTDESC with - NASCENT) - (replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with - NDESCENT) - (replace (FONTDESCRIPTOR \SFHeight) of FONTDESC - with (IPLUS NDESCENT NASCENT)))] - (RETURN NEWCHARBITMAP]) + "update the parameters for this character set.") + (\FSETWIDTH WIDTHS CODE BWIDTH) (* ; "The new character's correct width") + (* ; + "Make sure that we update imagewidths also") + (CL:WHEN IMWIDTHS (\FSETIMAGEWIDTH IMWIDTHS CODE BWIDTH)) + (\FSETOFFSET OFFSETS CODE CHAROFFSET) + (CL:WHEN DW + (for I from 0 to \MAXTHINCHAR when (IGREATERP (\FGETOFFSET OFFSETS I) + CHAROFFSET) + do + (* ;; + "If the imagewidth has changed, offsets after the modified character have to be adjusted. ") + + (add (\FGETOFFSET OFFSETS I) + DW))) + (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP) + (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with NDESCENT) + (replace (CHARSETINFO CHARSETASCENT) of CSINFO with NASCENT)) + NEWCHARBITMAP)]) +) +(DEFINEQ (MOVECHARBITMAP - [LAMBDA (SRCECODE SRCEFONT DESTCODE DESTFONT CLIP) (* ; "Edited 14-Dec-86 18:04 by Shih") + [LAMBDA (SRCECODE SRCEFONT DESTCODE DESTFONT CLIP) (* ; "Edited 14-Jul-2025 22:53 by rmk") + (* ; "Edited 5-Jul-2025 18:47 by rmk") + (* ; "Edited 14-Dec-86 18:04 by Shih") (* ;;; "moves a character from one font to another, clipping if necessary.") - (PROG ((SRCEDESC (\GETFONTDESC SRCEFONT)) - (DESTDESC (\GETFONTDESC DESTFONT)) + (PROG ((SRCEDESC (FONTCREATE SRCEFONT)) + (DESTDESC (FONTCREATE DESTFONT)) SRCEASCENT SRCEDESCENT DESTASCENT DESTDESCENT CHARBITMAP TEMPBITMAP NEWASCENT NEWDESCENT) (SETQ CHARBITMAP (GETCHARBITMAP SRCECODE SRCEFONT)) (SETQ SRCEASCENT (FONTPROP SRCEDESC 'ASCENT)) @@ -967,321 +1316,664 @@ (IPLUS NEWASCENT NEWDESCENT] (PUTCHARBITMAP DESTCODE DESTFONT (OR TEMPBITMAP CHARBITMAP) NEWDESCENT]) + +(MOVEFONTCHARS + [LAMBDA (PAIRS DESTFONT DEFAULTSOURCEFONT) (* ; "Edited 24-Jul-2025 21:05 by rmk") + (* ; "Edited 9-Jul-2025 09:13 by rmk") + (* ; "Edited 17-Jun-2025 19:53 by rmk") + (* ; "Edited 7-Jun-2025 00:06 by rmk") + (* ; "Edited 23-May-2025 15:02 by rmk") + (* ; "Edited 22-May-2025 09:52 by rmk") + (* ; "Edited 13-May-2025 08:56 by rmk") + (* ; "Edited 1-May-2025 13:20 by rmk") + + (* ;; "The character information for schar in sfont replaces the information for the destination character in the destination font.") + + (* ;; "Pairs is a list of (SOURCE DEST) pairs where each source is a list of the form (schar/code sfont) or just a character, and each DEST is a destination character/code. If a pair is a character code C, it is treated as (C C).") + + (* ;; "If a pair does not contain its own source font, then information is extracted from the DEFAULTSOURCEFONT. If the DEFAULTSOURCEFONT is not provided, thenSFONT it is assumed that the source is the DESTFONT (which must always be provided).") + + (* ;; "This collects the source information for all the pairs before it starts, to make sure that it doesn't step on itself when source and destination are the same font.") + + (CL:WHEN PAIRS + (SETQ DESTFONT (FONTCREATE DESTFONT)) + (LET ((DEVICE (FONTPROP DESTFONT 'DEVICE)) + PAIRINFO) + (SETQ DEFAULTSOURCEFONT (CL:IF DEFAULTSOURCEFONT + (FONTCREATE DEFAULTSOURCEFONT NIL NIL NIL DEVICE) + DESTFONT)) + + (* ;; "Fix/check arguments, and expand out the information for all the source characters, so there is no toe-stepping if there are overlaps.") + + (SETQ PAIRINFO (for P S SCODE SFONT DCODE SCSINFO DCSINFO in PAIRS + collect (CL:WHEN (SMALLP P) + (SETQ P (LIST P P))) + (SETQ S (CAR P)) + (SETQ DCODE (CADR P)) + (CL:UNLESS (CHARCODEP DCODE) + (SETQ DCODE (CHARCODE.DECODE DCODE))) + (CL:UNLESS (\INSURECHARSETINFO (\CHARSET DCODE) + DESTFONT)) + (SETQ SCODE (CL:IF (LISTP S) + (CAR S) + S)) + (CL:UNLESS (CHARCODEP SCODE) + (SETQ SCODE (CHARCODE.DECODE SCODE))) + (SETQ SFONT (CL:IF (LISTP S) + (FONTCREATE (CADR S) + NIL NIL NIL DEVICE) + DEFAULTSOURCEFONT)) + (CL:UNLESS (SETQ SCSINFO (\INSURECHARSETINFO (\CHARSET SCODE) + SFONT))) + (CL:UNLESS (SETQ DCSINFO (\INSURECHARSETINFO (\CHARSET DCODE) + DESTFONT)) + + (* ;; + "If the destination csinfo doesn't exist, initialize with a copy of the source character's csinfo") + + (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of DESTFONT) + (\CHARSET DCODE) + (COPYALL SCSINFO))) + (LIST (LIST SCODE (\GETCHARINFO SCSINFO (\CHAR8CODE SCODE))) + DCODE))) + + (* ;; "Install source character information into the destination font. ") + + (for P DCHARCODE DCSINFO ASCENT DESCENT in PAIRINFO + do (SETQ DCHARCODE (CADR P)) + (SETQ DCSINFO (\XGETCHARSETINFO DESTFONT (\CHARSET DCHARCODE))) + (CL:WHEN (fetch (CHARSETINFO CSSLUGP) of DCSINFO) + (* ; "Break the slug-sharing") + (SETQ DCSINFO (create CHARSETINFO copying DCSINFO CSSLUGP _ NIL)) + (\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR)) + (\CHARSET DCHARCODE) + DCSINFO)) + (\MOVEFONTCHAR (CADAR P) + DCSINFO + (\CHAR8CODE (CAAR P)) + (\CHAR8CODE DCHARCODE) + DESTFONT)))) + DESTFONT]) + +(\MOVEFONTCHAR + [LAMBDA (SCHARINFO DCSINFO SCODE DCODE DFONT) (* ; "Edited 24-Jul-2025 10:47 by rmk") + (* ; "Edited 22-Jul-2025 13:18 by rmk") + (* ; "Edited 8-Jul-2025 22:23 by rmk") + (* ; "Edited 17-Jun-2025 19:53 by rmk") + (* ; "Edited 7-Jun-2025 14:43 by rmk") + + (* ;; "Internal CSINFO-level function to move the information for (thinchar) SCODE in the source CSINFO to (thinchar) DCODE) in the destination CSINFO.") + + (* ;; "The caller (MOVEFONTCHARS) may have provided the source character information as an alist structure to avoid stepping on toes. If SCHARINFO is a CSINFO, the alist is extracted here.") + + (* ;; "If DFONT is provided, its ascent and descent may be adjusted to reflect SCHARINFO.") + + (CL:WHEN (type? CHARSETINFO SCHARINFO) + (SETQ SCHARINFO (\GETCHARINFO SCHARINFO SCODE))) + (LET (DESCENT ASCENT TEMP) + (CL:WHEN [AND (FGETMULTI SCHARINFO 'IMAGEWIDTHS) + (NEQ (FGETMULTI SCHARINFO 'WIDTHS) + (FGETMULTI SCHARINFO 'IMAGEWIDTHS)) + (OR (EQ (ffetch (CHARSETINFO WIDTHS) of DCSINFO) + (ffetch (CHARSETINFO IMAGEWIDTHS) of DCSINFO)) + (NULL (ffetch (CHARSETINFO IMAGEWIDTHS) of DCSINFO] + + (* ;; "We have to split the width and imagewidth vectors in preparation, if the character values are different but the dest vectors are EQ. ") + + (replace (CHARSETINFO IMAGEWIDTHS) of DCSINFO with (\COPYARRAYBLOCK (ffetch (CHARSETINFO + WIDTHS) + of DCSINFO)))) + (CL:WHEN (SETQ TEMP (FGETMULTI SCHARINFO 'BITMAP)) + (\PUTCHARBITMAP.CSINFO DCODE DCSINFO TEMP (FGETMULTI SCHARINFO 'DESCENT))) + (UPDATEINFOELEMENT WIDTHS) + (UPDATEINFOELEMENT IMAGEWIDTHS) + (UPDATEINFOELEMENT YWIDTHS) + (CL:WHEN (FGETMULTI SCHARINFO 'LEFTKERN) + (\FSETLEFTKERN DCSINFO DCODE (FGETMULTI SCHARINFO 'LEFTKERN))) + (SETQ DESCENT (IMAX (FGETMULTI SCHARINFO 'DESCENT) + (fetch (CHARSETINFO CHARSETDESCENT) of DCSINFO))) + (SETQ ASCENT (IMAX (FGETMULTI SCHARINFO 'ASCENT) + (fetch (CHARSETINFO CHARSETASCENT) of DCSINFO))) + (replace (CHARSETINFO CHARSETDESCENT) of DCSINFO with DESCENT) + (replace (CHARSETINFO CHARSETASCENT) of DCSINFO with ASCENT) + (replace (CHARSETINFO CSSLUGP) of DCSINFO with NIL) + (CL:WHEN DFONT + (SETQ DESCENT (IMAX DESCENT (fetch (FONTDESCRIPTOR \SFDescent) of DFONT))) + (SETQ ASCENT (IMAX ASCENT (fetch (FONTDESCRIPTOR \SFAscent) of DFONT))) + (replace (FONTDESCRIPTOR \SFAscent) of DFONT with ASCENT) + (replace (FONTDESCRIPTOR \SFDescent) of DFONT with DESCENT) + (replace (FONTDESCRIPTOR \SFHeight) of DFONT with (IPLUS DESCENT ASCENT))) + DCSINFO]) + +(SLUGCHARP.DISPLAY + [LAMBDA (CODE FONT/CHARSETINFO) (* ; "Edited 6-Jun-2025 10:24 by rmk") + (* ; "Edited 31-May-2025 23:44 by rmk") + + (* ;; "True if CODE is currently a slug in FONT or the particular CHARSETINFO. If we are given a CSINFO, CODE is alread charset-relative.") + + (LET [(CSINFO (CL:IF (type? CHARSETINFO FONT/CHARSETINFO) + FONT/CHARSETINFO + (\XGETCHARSETINFO FONT/CHARSETINFO (\CHARSET CODE)))] + (OR (NULL CSINFO) + (fetch (CHARSETINFO CSSLUGP) of CSINFO) + (EQ (\GETBASE (fetch (CHARSETINFO OFFSETS) of CSINFO) + (\CHAR8CODE CODE)) + (\GETBASE (fetch (CHARSETINFO OFFSETS) of CSINFO) + (ADD1 \MAXTHINCHAR]) + +(\GETCHARINFO + [LAMBDA (CSINFO CHAR8CODE) (* ; "Edited 23-Jul-2025 15:59 by rmk") + (* ; "Edited 22-Jul-2025 12:48 by rmk") + (* ; "Edited 8-Jul-2025 22:50 by rmk") + (* ; "Edited 7-Jun-2025 14:35 by rmk") + (LET (TEMP) + `((ASCENT \, (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) + (DESCENT \, (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (WIDTHS \, (CL:WHEN (SETQ TEMP (ffetch (CHARSETINFO WIDTHS) of CSINFO)) + (\FGETWIDTH TEMP CHAR8CODE))) + (YWIDTHS \, (CL:WHEN (SETQ TEMP (ffetch (CHARSETINFO YWIDTHS) of CSINFO)) + (\FGETWIDTH TEMP CHAR8CODE))) + (IMAGEWIDTHS \, (CL:WHEN (SETQ TEMP (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) + (\FGETWIDTH TEMP CHAR8CODE))) + (LEFTKERN \, (CL:WHEN (ARRAYP (fetch (CHARSETINFO LEFTKERN) of CSINFO)) + (ELT (fetch (CHARSETINFO LEFTKERN) of CSINFO) + CHAR8CODE))) + (BITMAP \, (CL:WHEN (SETQ TEMP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) + (\GETCHARBITMAP.CSINFO CHAR8CODE CSINFO]) ) -(DEFINEQ +(DECLARE%: EVAL@COMPILE -(FONTCOPY - [LAMBDA FONTSPECS (* ; "Edited 10-Nov-87 17:12 by FS") - (* ; - "makes a copy of a font changing the specified fields.") - (PROG (NOERROR ERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT) +(PUTPROPS UPDATEINFOELEMENT MACRO [(FIELD) + (LET [(DBLOCK (ffetch (CHARSETINFO FIELD) of DCSINFO)) + (NEWVAL (FGETMULTI SCHARINFO 'FIELD] + (CL:WHEN NEWVAL + (CL:UNLESS DBLOCK + (SETQ DBLOCK (\CREATECSINFOELEMENT)) + (freplace (CHARSETINFO FIELD) of DCSINFO with DBLOCK)) + (\FSETWIDTH DBLOCK DCODE NEWVAL))]) +) - (* ;; "Set NOERROR if we find it as a prop, but set ERROR if we find a PROP which is illegal. Then just return NIL if NOERROR and ERROR, otherwise, call FONTCREATE.") - [SETQ OLDFONT (\GETFONTDESC (ARG FONTSPECS 1) - (AND (type? FONTCLASS (ARG FONTSPECS 1)) - (COND - ((AND (EQ FONTSPECS 2) - (LISTP (ARG FONTSPECS 2))) - (LISTGET (ARG FONTSPECS 2) - 'DEVICE)) - (T (for I from 2 by 2 to FONTSPECS - do (COND - ((AND (NEQ I FONTSPECS) - (EQ (ARG FONTSPECS I) - 'DEVICE)) - (RETURN (ARG FONTSPECS (ADD1 I] - (SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT)) - (SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT)) - (SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT)) - (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT)) - (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT)) - [for I VAL from 2 by 2 to FONTSPECS - do [SETQ VAL (COND - ((NOT (EQ I FONTSPECS)) - (ARG FONTSPECS (ADD1 I] - (SELECTQ (ARG FONTSPECS I) - (FAMILY (SETQ FAMILY VAL)) - (SIZE (SETQ SIZE VAL)) - (FACE (SETQ FACE (\FONTFACE VAL))) - (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL))) - (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL))) - (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL))) - (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL))) - (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL))) - (ROTATION (SETQ ROTATION VAL)) - (DEVICE (SETQ DEVICE VAL)) - (NOERROR (SETQ NOERROR VAL)) - (COND - [(AND (EQ I 2) - (EQ FONTSPECS 2) - (LISTP (ARG FONTSPECS 2))) - (for J on (ARG FONTSPECS 2) by (CDDR J) - do (SETQ VAL (CADR J)) - (SELECTQ (CAR J) - (FAMILY (SETQ FAMILY VAL)) - (SIZE (SETQ SIZE VAL)) - (FACE (SETQ FACE (\FONTFACE VAL))) - (WEIGHT (SETQ FACE (create FONTFACE - using FACE WEIGHT _ VAL))) - (SLOPE (SETQ FACE (create FONTFACE - using FACE SLOPE _ VAL))) - (EXPANSION (SETQ FACE (create FONTFACE - using FACE EXPANSION _ VAL))) - (BACKCOLOR (SETQ FACE (create FONTFACE - using FACE BACKCOLOR _ VAL))) - (FORECOLOR (SETQ FACE (create FONTFACE - using FACE FORECOLOR _ VAL))) - (ROTATION (SETQ ROTATION VAL)) - (DEVICE (SETQ DEVICE VAL)) - (NOERROR (SETQ NOERROR VAL)) - (COND - (NOERROR - - (* ;; - "Fell through the SELECTQ, so an illegal PROP. But, if NOERROR, just note the error, otherwise ") - - (SETQ ERROR T)) - (T (\ILLEGAL.ARG (CAR J] - (T (if NOERROR - then (SETQ ERROR T) - else (\ILLEGAL.ARG (ARG FONTSPECS I] - (RETURN (if (AND NOERROR ERROR) - then NIL - else (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR]) -(FONTSAVAILABLE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) - (* rrb " 7-Nov-84 15:41") +(* ;; +"\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. " +) -(* ;;; "returns a list of the fonts fitting a description that are available. FAMILY SIZE FACE or ROTATION can be * which means get them all. if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.") - - (DECLARE (GLOBALVARS IMAGESTREAMTYPES)) - (PROG (FONTX DEV) - [SETQ DEV (COND - ((type? STREAM DEVICE) - (COND - ((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE))) - (CAR DEV)) - (T DEV))) - (DEVICE) - (T 'DISPLAY] - (RETURN - (COND - ((LISTP FAMILY) - (COND - ((EQ (CAR FAMILY) - 'FONT) - (SETQ FONTX (CDR FAMILY))) - (T (SETQ FONTX FAMILY))) - (FONTSAVAILABLE (CAR FONTX) - (OR (CADR FONTX) - SIZE) - (OR (CADDR FONTX) - FACE) - (OR (CADDDR FONTX) - ROTATION) - DEV CHECKFILESTOO?)) - ([SETQ FONTX (COND - ((type? FONTDESCRIPTOR FAMILY) - FAMILY) - ((NULL FAMILY) - (DEFAULTFONT DEV)) - ((type? FONTCLASS FAMILY) - - (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class. Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.") - (* ; - "I don't know what to do in this case- rrb.") - (\COERCEFONTDESC FAMILY DEV T)) - ((OR (IMAGESTREAMP FAMILY) - (type? WINDOW FAMILY)) - (DSPFONT NIL FAMILY] (* ; - "FAMILY was a spec for a font descriptor, use it and extend it by the other args.") - (FONTSAVAILABLE (FONTPROP FONTX 'FAMILY) - (OR SIZE (FONTPROP FONTX 'SIZE)) - (OR FACE (FONTPROP FONTX 'FACE)) - (OR ROTATION (FONTPROP FONTX 'ROTATION)) - (OR DEVICE (FONTPROP FONTX 'DEVICE)) - CHECKFILESTOO?)) - (T (PROG ((FONTFACE FACE)) - RETRY - (OR (LITATOM FAMILY) - (LISPERROR "ARG NOT LITATOM" FAMILY T)) - (OR (AND (FIXP SIZE) - (IGREATERP SIZE 0)) - (EQ SIZE '*) - (\ILLEGAL.ARG SIZE)) - [OR (EQ FONTFACE '*) - (SETQ FONTFACE (OR (\FONTFACE FACE T) - (RETURN NIL] - (OR (U-CASEP FAMILY) - (SETQ FAMILY (U-CASE FAMILY))) - (COND - ((NULL ROTATION) - (SETQ ROTATION 0)) - ((AND (FIXP ROTATION) - (IGEQ ROTATION 0))) - ((EQ ROTATION '*)) - (T (\ILLEGAL.ARG ROTATION))) - (RETURN (UNION (\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV) - (COND - ((NOT CHECKFILESTOO?) - NIL) - [(EQ DEV '*) (* ; "map thru all the devices.") - (for EXTANTDEV in IMAGESTREAMTYPES - join (APPLY* (OR (CADR (ASSOC 'FONTSAVAILABLE - (CDR EXTANTDEV))) - (FUNCTION NILL)) - FAMILY SIZE FONTFACE ROTATION - (CAR EXTANTDEV] - (T (* ; - "apply the device font lookup function.") - (APPLY* (OR [CADR (ASSOC 'FONTSAVAILABLE - (CDR (ASSOC DEV IMAGESTREAMTYPES - ] - (FUNCTION NILL)) - FAMILY SIZE FONTFACE ROTATION DEV]) - -(FONTFILEFORMAT - [LAMBDA (STRM LEAVEOPEN) (* rmk%: "11-Sep-84 17:16") - (* ; "Returns the font format of STRM") - [OR (OPENP STRM 'INPUT) - (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD] - (PROG1 (SELECTC (\WIN STRM) - ((LIST (LLSH 1 15) - (LOGOR (LLSH 1 15) - (LLSH 1 13))) - - (* ;; "If high bit of type is on, then must be strike. If 2nd bit is on, must be strike-index, and we punt. We don't care about the 3rd bit") - - - (* ;; "first word has high bits (onebit index fixed). Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width. Lisp doesn't care about 'fixed'") - - 'STRIKE) - ((LOGOR (LLSH 16 8) - 12) - (* ;; "This is the length of a standard index header. Other files could also have this value, but it's a pretty good discriminator") - - - (* ;; "Skip to byte 25; do it with BINS so works for non-randaccessp devices. This skips the standard name header, then look for type 3 in the following header") - - (FRPTQ 22 (\BIN STRM)) (* ; "(SETFILEPTR STRM 25)") - (AND (EQ 3 (LRSH (\BIN STRM) - 4)) - 'AC)) - NIL) - (OR LEAVEOPEN (CLOSEF STRM)))]) +(DEFINEQ -(FONTP - [LAMBDA (X) (* rmk%: "13-Sep-84 09:04") - (* ; "is X a FONTDESCRIPTOR?") - (COND - ((OR (type? FONTDESCRIPTOR X) - (type? FONTCLASS X)) - X]) +(FONTFILES + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST) + (* ; "Edited 11-Jul-2025 09:42 by rmk") + (* ; "Edited 6-Jul-2025 10:40 by rmk") + (* ; "Edited 19-Jun-2025 17:09 by rmk") + (* ; "Edited 13-Jun-2025 22:48 by rmk") + (* ; "Edited 9-Jun-2025 09:57 by rmk") + (* ; "Edited 17-May-2025 00:06 by rmk") + (* ; "Edited 15-May-2025 16:29 by rmk") -(FONTUNPARSE - [LAMBDA (FONT) (* kbr%: "25-Feb-86 19:40") + (* ;; "Considers all posible names for font files that respect the given characteristics, returns a list of the names of files that actually exist somewhere in DIRLST. Does not validate their contents.") - (* ;; "Produces a minimal specification of the font or fontclass specification, for dumping by Tedit, imageobjects.") + [SETQ DIRLST (MKLIST (OR DIRLST (GETATOMVAL (PACK* DEVICE "FONTDIRECTORIES"] + [SETQ EXTLST (MKLIST (OR EXTLST (GETATOMVAL (PACK* DEVICE "FONTEXTENSIONS"] + (CL:UNLESS CHARSET (SETQ CHARSET \DEFAULTCHARSET)) + (APPEND (MKLIST (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE 'NOCHARSET DIRLST EXTLST)) + (MKLIST (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST]) - (PROG (FACE SPEC) - (SETQ SPEC (COND - ((type? FONTDESCRIPTOR FONT) - (FONTPROP FONT 'SPEC)) - [(type? FONTCLASS FONT) - (RETURN (CONS 'CLASS (FONTCLASSUNPARSE FONT] - (T - (* ;; "Could be a non-instantiated specification in a fontclass, just use it as the spec without creating the font.") +(\FINDFONTFILE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST) + (* ; "Edited 9-Jun-2025 09:40 by rmk") + (* ; "Edited 15-May-2025 22:41 by rmk") + (* ; "Edited 14-Sep-96 10:53 by rmk:") + (* ; "Edited 6-Oct-89 11:18 by bvm") + + (* ;; "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.") + + (for EXT FONTFILE inside EXTLST + when (SETQ FONTFILE (FINDFILE (if (FMEMB EXT *OLD-FONT-EXTENSIONS*) + then (\FONTFILENAME.OLD FAMILY SIZE FACE EXT CHARSET) + else (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)) + T DIRLST)) collect FONTFILE finally + + (* ;; + "Backward compatibility for devices that expect a single file") + + (CL:UNLESS (CDR $$VAL) + (RETURN (CAR $$VAL)))]) + +(\FONTFILENAMES + [LAMBDA (FAMILY SIZE FACE DEVICE EXTENSIONS) (* ; "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 + 'ALL) + ELSE (\FONTFILENAME FAMILY SIZE FACE EXT + 'ALL] + (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]) - FONT))) - (OR SPEC (RETURN)) - (SETQ FACE (CADDR SPEC)) (* ; - "FACE and rotation can be NIL for a non-fontdescriptor fontclass component") - [SETQ FACE (COND - ([OR (NULL FACE) - (EQUAL FACE '(MEDIUM REGULAR REGULAR] - NIL) - ((LITATOM FACE) - FACE) - [(LISTP FACE) - (PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE) - 1) - (NTHCHAR (fetch (FONTFACE SLOPE) of FACE) - 1) - (NTHCHAR (fetch (FONTFACE EXPANSION) of FACE) - 1) - (COND - ((fetch (FONTFACE COLOR) of FACE) - (LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE) - "-" - (fetch (FONTFACE FORECOLOR) of FACE] - (T (SHOULDNT] (* ; - "Don't return device, or any trailing defaults") - (RETURN (CONS (CAR SPEC) - (CONS (CADR SPEC) - (COND - ([AND (CADDDR SPEC) - (NOT (EQ 0 (CADDDR SPEC] - (LIST (OR FACE 'MRR) - (CADDDR SPEC))) - (FACE (CONS FACE]) +(\FONTFILENAME + [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 11-Jul-2025 09:39 by rmk") + (* ; "Edited 15-May-2025 15:51 by rmk") + (* ; "Edited 5-Mar-93 16:10 by rmk:") -(SETFONTDESCRIPTOR - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* ; "Edited 1-Aug-88 16:16 by rmk:") - (* ; "Edited 5-Mar-87 19:28 by FS") + (* ;; "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") - (* ;; "saves a font descriptor under a family/size/face/rotation/device key so that it will be retreived by FONTCREATE. This is a user entry.") + (* ;; "**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*") - (DECLARE (GLOBALVARS \FONTSINCORE)) - (SETQ DEVICE (\DEVICESYMBOL DEVICE)) (* ; "Unpackageify") - (AND FONT (SETQ FONT (\COERCEFONTDESC FONT DEVICE))) (* ; - "NIL is used to clobber existing font so that next use will reread it.") - (SETQ FAMILY (\FONTSYMBOL FAMILY)) (* ; "Unpackageify") - (SETQ FACE (\FONTFACE FACE NIL DEVICE)) - (OR ROTATION (SETQ ROTATION 0)) - (OR (AND (FIXP SIZE) - (IGEQ SIZE 0)) - (\ILLEGAL.ARG SIZE)) - (PROG [(X (OR (FASSOC FAMILY \FONTSINCORE) - (CAR (push \FONTSINCORE (LIST FAMILY] - [SETQ X (OR (FASSOC SIZE (CDR X)) - (CAR (push (CDR X) - (LIST SIZE] - [SETQ X (OR (SASSOC FACE (CDR X)) - (CAR (push (CDR X) - (LIST FACE] (* ; "SASSOC cause FACE is listp") - [SETQ X (OR (FASSOC ROTATION (CDR X)) - (CAR (push (CDR X) - (LIST ROTATION] - [SETQ X (OR (FASSOC DEVICE (CDR X)) - (CAR (push (CDR X) - (LIST DEVICE] - (RPLACD X FONT) - (RETURN FONT]) - -(CHARCODEP - [LAMBDA (CHCODE) (* gbn "22-Jul-85 16:35") + (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] + + (* ;; "Fortunately, CONCAT ignores packages.") + + (PACKFILENAME.STRING 'NAME (CONCAT (if *USEOLDFONTDIRECTORIES* + then "" + elseif CSETNAME + then (CONCAT (PROGN (* ; - "is CHCODE a legal character code?") - (AND (SMALLP CHCODE) - (IGEQ CHCODE 0) - (ILEQ CHCODE \MAXNSCHAR]) + "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]) -(EDITCHAR - [LAMBDA (CHARCODE FONT) (* rrb "24-MAR-82 12:22") +(\FONTFILENAME.OLD + [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 23-Sep-92 18:22 by jds") + + (* ;; "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.") (* ; - "calls the bitmap editor on a character of a font") - (PROG ((FONTDESC (\GETFONTDESC FONT))) - (RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC]) + "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) + '*)) -(\STREAMCHARWIDTH - [LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31") + (* ;; "Avoid adjacent wildcards because DSK gets slower exponentially (can take loooong tiiiiiime). No need to check compression.") - (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences. Used by \ECHOCHAR") + '*) + (T FACE))) + (PACKFILENAME.STRING 'NAME [PROGN + (* ;; "DISPLAYFONT AC WD and the default case") - (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK)) - ((LAMBDA (WIDTHSVECTOR) + (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]) + +(\FONTINFOFROMFILENAME + [LAMBDA (FONTFILE DEVICE NOCHARSET) (* ; "Edited 10-Jul-2025 09:42 by rmk") + (* ; "Edited 26-Jun-2025 23:03 by rmk") + (* ; "Edited 14-Sep-96 10:23 by rmk:") + (* ; "Edited 5-Oct-89 18:28 by bvm") + + (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE. Rotation is 0 always. Parses both new & old format files.") + + (LET ((FILENAMELIST (UNPACKFILENAME.STRING FONTFILE)) + CH SIZEBEG SIZEND NAME FAMILY SIZE FACE EXT CHARSET) + (SETQ NAME (LISTGET FILENAMELIST 'NAME)) (* ; + "find where the name and size are. MUST check for ch nil below or possible infinite loop") + (SETQ SIZEBEG (for CH# from 1 when (OR (NUMBERP (SETQ CH (NTHCHAR NAME CH#))) + (NULL CH)) do (RETURN CH#))) + + (* ;; "Get Family") + + [SETQ FAMILY (MKATOM (U-CASE (SUBSTRING NAME 1 (SUB1 SIZEBEG] + + (* ;; "Get Size") + + [SETQ SIZEND (find CH# from SIZEBEG suchthat (NOT (NUMBERP (NTHCHAR NAME CH#] + [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND] + (if (EQ (NTHCHAR NAME SIZEND) + '-) + then (SETQ SIZEND (ADD1 SIZEND))) + + (* ;; "Get Face") + + (SETQ NAME (U-CASE NAME)) (* ; + "don't need name, but checks for lowercase face") + [SETQ FACE (LIST (COND + ((STRPOS "B" NAME SIZEND NIL T NIL UPPERCASEARRAY) + 'BOLD) + ((STRPOS "L" NAME SIZEND NIL T NIL UPPERCASEARRAY) + 'LIGHT) + (T 'MEDIUM)) + (COND + ((STRPOS "I" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) + 'ITALIC) + (T 'REGULAR)) + (COND + ((STRPOS "E" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) + 'EXPANDED) + ((STRPOS "C-" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) + 'COMPRESSED) + (T 'REGULAR] + (CL:WHEN (SETQ CHARSET (STRPOS "-c" NAME NIL NIL NIL T UPPERCASEARRAY)) + [SETQ CHARSET (FIXP (MKATOM (CONCAT (SUBSTRING NAME CHARSET) + "Q"]) + (LIST* FAMILY SIZE FACE 0 (COND + ((STREAMP DEVICE) + (IMAGESTREAMTYPE DEVICE)) + ((NULL DEVICE) + [SETQ EXT (MKATOM (U-CASE (LISTGET FILENAMELIST 'EXTENSION] + (SELECTQ EXT + ((WD MEDLEYINTERPRESSFONT) + 'INTERPRESS) + ((STRIKE AC DISPLAYFONT MEDLEYDISPLAYFONT) + 'DISPLAY) + EXT)) + ((LITATOM DEVICE) + (\FONTSYMBOL DEVICE)) + (T DEVICE)) + (CL:UNLESS NOCHARSET (CONS CHARSET]) + +(\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 + +(FONTCOPY + [LAMBDA FONTSPECS (* ; "Edited 14-Jul-2025 23:04 by rmk") + (* ; "Edited 5-Jul-2025 18:54 by rmk") + (* ; "Edited 10-Nov-87 17:12 by FS") + (* ; + "makes a copy of a font changing the specified fields.") + (PROG (NOERROR ERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT) + + (* ;; "Set NOERROR if we find it as a prop, but set ERROR if we find a PROP which is illegal. Then just return NIL if NOERROR and ERROR, otherwise, call FONTCREATE.") + + [SETQ OLDFONT (FONTCREATE (ARG FONTSPECS 1) + NIL NIL NIL + (CL:WHEN (type? FONTCLASS (ARG FONTSPECS 1)) + [COND + ((AND (EQ FONTSPECS 2) + (LISTP (ARG FONTSPECS 2))) + (LISTGET (ARG FONTSPECS 2) + 'DEVICE)) + (T (for I from 2 by 2 to FONTSPECS + do (COND + ((AND (NEQ I FONTSPECS) + (EQ (ARG FONTSPECS I) + 'DEVICE)) + (RETURN (ARG FONTSPECS (ADD1 I])] + (SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT)) + (SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT)) + (SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT)) + (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT)) + (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT)) + [for I VAL from 2 by 2 to FONTSPECS + do [SETQ VAL (COND + ((NOT (EQ I FONTSPECS)) + (ARG FONTSPECS (ADD1 I] + (SELECTQ (ARG FONTSPECS I) + (FAMILY (SETQ FAMILY VAL)) + (SIZE (SETQ SIZE VAL)) + (FACE (SETQ FACE (\FONTFACE VAL))) + (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL))) + (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL))) + (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL))) + (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL))) + (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL))) + (ROTATION (SETQ ROTATION VAL)) + (DEVICE (SETQ DEVICE VAL)) + (NOERROR (SETQ NOERROR VAL)) + (COND + [(AND (EQ I 2) + (EQ FONTSPECS 2) + (LISTP (ARG FONTSPECS 2))) + (for J on (ARG FONTSPECS 2) by (CDDR J) + do (SETQ VAL (CADR J)) + (SELECTQ (CAR J) + (FAMILY (SETQ FAMILY VAL)) + (SIZE (SETQ SIZE VAL)) + (FACE (SETQ FACE (\FONTFACE VAL))) + (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL))) + (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL))) + (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL))) + (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL))) + (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL))) + (ROTATION (SETQ ROTATION VAL)) + (DEVICE (SETQ DEVICE VAL)) + (NOERROR (SETQ NOERROR VAL)) + (COND + (NOERROR + + (* ;; + "Fell through the SELECTQ, so an illegal PROP. But, if NOERROR, just note the error, otherwise ") + + (SETQ ERROR T)) + (T (\ILLEGAL.ARG (CAR J] + (T (if NOERROR + then (SETQ ERROR T) + else (\ILLEGAL.ARG (ARG FONTSPECS I] + (RETURN (if (AND NOERROR ERROR) + then NIL + else (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR]) + +(FONTP + [LAMBDA (X) (* rmk%: "13-Sep-84 09:04") + (* ; "is X a FONTDESCRIPTOR?") + (COND + ((OR (type? FONTDESCRIPTOR X) + (type? FONTCLASS X)) + X]) + +(FONTUNPARSE + [LAMBDA (FONT) (* kbr%: "25-Feb-86 19:40") + + (* ;; "Produces a minimal specification of the font or fontclass specification, for dumping by Tedit, imageobjects.") + + (PROG (FACE SPEC) + (SETQ SPEC (COND + ((type? FONTDESCRIPTOR FONT) + (FONTPROP FONT 'SPEC)) + [(type? FONTCLASS FONT) + (RETURN (CONS 'CLASS (FONTCLASSUNPARSE FONT] + (T + (* ;; "Could be a non-instantiated specification in a fontclass, just use it as the spec without creating the font.") + + FONT))) + (OR SPEC (RETURN)) + (SETQ FACE (CADDR SPEC)) (* ; + "FACE and rotation can be NIL for a non-fontdescriptor fontclass component") + [SETQ FACE (COND + ([OR (NULL FACE) + (EQUAL FACE '(MEDIUM REGULAR REGULAR] + NIL) + ((LITATOM FACE) + FACE) + [(LISTP FACE) + (PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE) + 1) + (NTHCHAR (fetch (FONTFACE SLOPE) of FACE) + 1) + (NTHCHAR (fetch (FONTFACE EXPANSION) of FACE) + 1) + (COND + ((fetch (FONTFACE COLOR) of FACE) + (LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE) + "-" + (fetch (FONTFACE FORECOLOR) of FACE] + (T (SHOULDNT] (* ; + "Don't return device, or any trailing defaults") + (RETURN (CONS (CAR SPEC) + (CONS (CADR SPEC) + (COND + ([AND (CADDDR SPEC) + (NOT (EQ 0 (CADDDR SPEC] + (LIST (OR FACE 'MRR) + (CADDDR SPEC))) + (FACE (CONS FACE]) + +(SETFONTDESCRIPTOR + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* ; "Edited 21-Jul-2025 08:55 by rmk") + (* ; "Edited 14-Jul-2025 22:37 by rmk") + (* ; "Edited 10-Jul-2025 12:38 by rmk") + (* ; "Edited 19-Jun-2025 21:21 by rmk") + (* ; "Edited 14-Jun-2025 23:47 by rmk") + (* ; "Edited 1-Aug-88 16:16 by rmk:") + (* ; "Edited 5-Mar-87 19:28 by FS") + + (* ;; "Saves a font descriptor under a family/size/face/rotation/device key so that it will be retreived by FONTCREATE. This is a user entry.") + + (DECLARE (GLOBALVARS \FONTSINCORE)) + (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + (PUTMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE (AND FONT (FONTCREATE FONT NIL NIL NIL + DEVICE]) + +(\STREAMCHARWIDTH + [LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31") + + (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences. Used by \ECHOCHAR") + + (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK)) + ((LAMBDA (WIDTHSVECTOR) (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded; e.g., it may want #^A") @@ -1345,281 +2037,64 @@ (for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1)) \UNITWIDTHSVECTOR]) -(\CREATEDISPLAYFONT - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn%: "25-Jan-86 18:02") - (PROG [(FONTDESC (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - \SFAscent _ 0 - \SFDescent _ 0 - \SFHeight _ 0 - ROTATION _ ROTATION - FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE] - (RETURN (COND - ((\GETCHARSETINFO CHARSET FONTDESC T) - FONTDESC) - (T NIL]) - -(\CREATECHARSET.DISPLAY - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) - (* ; "Edited 14-Jan-88 23:42 by FS") - - (* ;; "Color Stuff removed -FS.") - - (* ;; "Replace Cond below with") - - (* ;; "(PROG (XCSINFO)") - - (* ;; "(SETQ XCSINFO &)") - - (* ;; "(COND ((FMEMB DEVICE \\COLORDISPLAYSTREAMTYPES) (SETQ XCSINFO (\\SFMAKECOLOR XCSINFO (OR (|fetch| (FONTFACE BACKCOLOR) |of| FACE) 0) (OR (|fetch| (FONTFACE FORECOLOR) |of| FACE) (MAXIMUMCOLOR (\\DISPLAYSTREAMTYPEBPP DEVICE))) (\\DISPLAYSTREAMTYPEBPP DEVICE)))))") - - (* ;; "(RETURN XCSINFO)))") - -(* ;;; "tries to build the csinfo required for CHARSET. Does the necessary coercions.") - -(* ;;; -"NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") - - (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS)) - - (* ;; "DISPLAYFONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...). Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.") - - (COND - ((PROG1 (for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT - when (AND (SETQ UFONT (CAR TRANSL)) - (EQ FAMILY (CAR UFONT)) - (OR (NOT (CADR UFONT)) - (EQ SIZE (CADR UFONT))) - (OR (NOT (CADDR UFONT)) - (EQ CHARSET (CADDR UFONT))) - (SETQ REALFONT (CADR TRANSL)) - (SETQ NEWCSINFO (\CREATECHARSET.DISPLAY (OR (CAR REALFONT) - FAMILY) - (OR (CADR REALFONT) - SIZE) - FACE ROTATION DEVICE (OR (CADDR REALFONT) - CHARSET) - FONTDESC NOSLUG?))) do (RETURN NEWCSINFO)) - (* ; - "Just recursively call ourselves to handle entries in DISPLAYFONTCOERCIONS") - )) - (T - (* ;; "One weirdness is, if you have a coercion, and the real-font is missing, you can't get a missingfont coercion on the user-font because the real-font missingfont coercion shadows it out.") - - (\CREATE-REAL-CHARSET.DISPLAY FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG? - ]) - -(\CREATE-REAL-CHARSET.DISPLAY - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) - (* ; "Edited 26-Jun-2022 12:37 by rmk") - (* ; "Edited 15-Jan-88 00:02 by FS") - (COND - [(AND (EQ ROTATION 0) - (PROG1 (\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION 'DISPLAY CHARSET) - (* ; - "If it is available, this will force the appropriate file to be read to fill in the charset entry") - ] - (T - (* ;; "if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised 'by hand'. Past that point, we do not allow DISPLAYFONTCOERCIONS, only MISSINGxxxxDISPLAYFONTCOERCIONS.") - - (PROG (NEWFONT XFONT XLATEDFAM CSINFO) - (RETURN (COND - [(NEQ ROTATION 0) - - (* ;; "to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo. If its still missing, then search for missing display font coercions (e.g. no avail. charset, *but*, do not recurse (avoid getting into infinite loops). This allows partial permutations of fonts.") - - (OR (MEMB ROTATION '(90 270)) - (ERROR "only implemented rotations are 0, 90 and 270." ROTATION)) - (COND - ((SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE FACE 0 'DISPLAY CHARSET)) - - (* ;; "Do not call FONTCREATE here. The user might have modified (via PUTCHARBITMAP, etc.) the in-memory version of the source. This also fixes a bug in which several font descriptors ended up sharing bitmaps or charsetvectors, causing havoc when the user modifies either fontdescriptor.") - - (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - then (\SFROTATECSINFO CSINFO ROTATION) - else NIL] - ((AND (EQ (fetch WEIGHT of FACE) - 'BOLD) - (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE - (create FONTFACE using FACE WEIGHT _ 'MEDIUM) - 0 - 'DISPLAY CHARSET))) - - (* ;; "if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo") - - (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - then (\SFMAKEBOLD CSINFO) - else NIL)) - ((AND (EQ (fetch (FONTFACE SLOPE) of FACE) - 'ITALIC) - (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE - (create FONTFACE using FACE SLOPE _ 'REGULAR) - 0 - 'DISPLAY CHARSET))) - (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - then (\SFMAKEITALIC CSINFO) - else NIL)) - [(AND CHARSET (NOT (EQL CHARSET 0)) - (for TRANSL in MISSINGCHARSETDISPLAYFONTCOERCIONS - bind NEWCSINFO UFONT REALFONT - when (AND (SETQ UFONT (CAR TRANSL)) - (EQ FAMILY (CAR UFONT)) - (OR (NOT (CADR UFONT)) - (EQ SIZE (CADR UFONT))) - (OR (NOT (CADDR UFONT)) - (EQ CHARSET (CADDR UFONT))) - (SETQ REALFONT (CADR TRANSL)) - (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY - (OR (CAR REALFONT) - FAMILY) - (OR (CADR REALFONT) - SIZE) - FACE ROTATION DEVICE - (OR (CADDR REALFONT) - CHARSET) - FONTDESC NOSLUG?))) - do (RETURN NEWCSINFO] - ((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT - when (AND (SETQ UFONT (CAR TRANSL)) - (EQ FAMILY (CAR UFONT)) - (OR (NOT (CADR UFONT)) - (EQ SIZE (CADR UFONT))) - (OR (NOT (CADDR UFONT)) - (EQ CHARSET (CADDR UFONT))) - (SETQ REALFONT (CADR TRANSL)) - (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY - (OR (CAR REALFONT) - FAMILY) - (OR (CADR REALFONT) - SIZE) - FACE ROTATION DEVICE (OR (CADDR REALFONT) - CHARSET) - FONTDESC NOSLUG?))) - do (RETURN NEWCSINFO))) - ((NOT NOSLUG?) - (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTDESC) - (FONTPROP FONTDESC 'ASCENT) - (FONTPROP FONTDESC 'DESCENT) - (FONTPROP FONTDESC 'DEVICE]) +(\COERCECHARSET + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS THINCODE) + (* ; "Edited 24-Jul-2025 00:19 by rmk") + (* ; "Edited 8-Jul-2025 08:14 by rmk") + (* ; "Edited 11-Jun-2025 09:13 by rmk") + (* ; "Edited 7-Jun-2025 13:39 by rmk") + (* ; "Edited 21-May-2025 10:50 by rmk") + + (* ;; "COERCIONS is a set of (oldspec newspec) pairs, where a spec is either just a font name or a font name with a size. If oldspec matches the current requested characteristics, then that csinfo is returned.") + (* ; "") + (for C CSINFO FONT in (\COERCEFONTSPEC COERCIONS FAMILY SIZE FACE ROTATION DEVICE CHARSET) + eachtime (SPREADFONTSPEC C) when [AND (SETQ FONT (FONTCREATE1 FAMILY SIZE FACE ROTATION DEVICE + CHARSET)) + (SETQ CSINFO (\INSURECHARSETINFO CHARSET FONT)) + (NOT (AND THINCODE (SLUGCHARP.DISPLAY THINCODE CSINFO] + do (RETURN CSINFO]) (\BUILDSLUGCSINFO - [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE) (* ; "Edited 9-May-93 23:12 by rmk:") - -(* ;;; "builds a csinfo which contains only the slug (black rectangle) character. Called only for display.") - - (SETQ SCALE (OR SCALE 1)) - (PROG ((CSINFO (create CHARSETINFO - CHARSETASCENT _ ASCENT - CHARSETDESCENT _ DESCENT)) - WIDTHS OFFSETS BITMAP IMAGEWIDTHS) - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) - (REPLACE IMAGEWIDTHS OF CSINFO WITH WIDTHS) - (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS ( - \CREATECSINFOELEMENT - ))) - (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) - [replace (CHARSETINFO CHARSETBITMAP) of CSINFO - with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE)) - (ROUND (QUOTIENT (IPLUS ASCENT DESCENT) - SCALE] - [BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE] - (RETURN CSINFO]) - -(\SEARCHDISPLAYFONTFILES - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Mar-87 18:55 by FS") - - (* ;; " This function called via APPLY in IMAGESTREAMTYPES.") - - (* ;; " Returns a list of the fonts that can be read in for displaylike devices. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") - - (* ;; " Note we *allow* a device that is not 'DISPLAY for guys like 4DISPLAY, 8DISPLAY, 24DISPLAY, and also possibly for FX80, etc. (guys that want DISPLAYFONTS anyway). Should have some hook though for FONTEXTENSIONS, FONTDIRECTORIES??") - - (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES)) - (SELECTQ (SYSTEMTYPE) - (D (\SEARCHFONTFILES FAMILY SIZE FACE ROTATION DEVICE DISPLAYFONTDIRECTORIES - DISPLAYFONTEXTENSIONS)) - (J (* OLD J code from \READDISPLAYFONT - (PROG ((FONTFILE (\FONTFILENAME - FAMILY SIZE FACE)) FONTDESC STRM) - (COND ((SETQ STRM (AND - FONTDIRECTORIES (FINDFILE FONTFILE T - FONTDIRECTORIES))) - (SETQ STRM (OPENSTREAM FONTFILE - (QUOTE INPUT))) (SETQ FONTDESC - (\READJERICHOFONTFILE FAMILY SIZE - FACE STRM)) (CLOSEF STRM))) - (RETURN FONTDESC))) - NIL) - (SHOULDNT]) - -(\SEARCHFONTFILES - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 14-Sep-96 10:54 by rmk:") - (* ; "Edited 6-Oct-89 12:34 by bvm") - - (* ;; "GENERIC FUNCTION") - - (* ;; "returns a list of the fonts that can be read in for a device. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") - - (SETQ FAMILY (\FONTSYMBOL FAMILY)) - (SETQ DEVICE (\FONTSYMBOL DEVICE)) - (SETQ FACE (\FONTFACE FACE)) - (BIND (FILING.ENUEMRATION.DEPTH _ 1) - FONTSFOUND THISFONT THISFACE FOR E INSIDE EXTLST - DO [FOR DIR INSIDE DIRLST - BIND (FILEPATTERN _ (IF (FMEMB E *OLD-FONT-EXTENSIONS*) - THEN (\FONTFILENAME.OLD FAMILY SIZE FACE E) - ELSE (\FONTFILENAME FAMILY SIZE FACE E))) - DO - - (* ;; "Hack above to handle both old and new font file names. 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") - - (FOR FONTFILE IN (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR - 'BODY FILEPATTERN)) - WHEN [PROGN (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE DEVICE)) - (SETQ THISFACE (CADDR THISFONT)) - - (* ;; - "make sure the face, size, and family really match.") - - (AND (NOT (MEMBER THISFONT FONTSFOUND)) - (OR (EQ FAMILY '*) - (EQ FAMILY (CAR THISFONT))) - (OR (EQ SIZE '*) - (EQ SIZE (CADR THISFONT))) - (OR (EQ FACE '*) - (EQUAL FACE THISFACE) - (AND (OR (EQ (CAR FACE) - '*) - (EQ (CAR FACE) - (CAR THISFACE))) - (OR (EQ (CADR FACE) - '*) - (EQ (CADR FACE) - (CADR THISFACE))) - (OR (EQ (CADDR FACE) - '*) - (EQ (CADDR FACE) - (CADDR THISFACE] - DO (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND] - FINALLY (RETURN FONTSFOUND]) - -(\FINDFONTFILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST) - (* ; "Edited 14-Sep-96 10:53 by rmk:") - (* ; "Edited 6-Oct-89 11:18 by bvm") - - (* ;; "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.") - - (BIND FONTFILE FOR EXT INSIDE EXTLST - WHEN (SETQ FONTFILE (FINDFILE (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*) - THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT - CHARSET) - ELSE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)) - T DIRLST)) DO (RETURN FONTFILE]) + [LAMBDA (WIDTH HEIGHT DESCENT DEVICE SCALE) (* ; "Edited 15-Jun-2025 12:42 by rmk") + (* ; "Edited 13-Jun-2025 22:55 by rmk") + (* ; "Edited 11-Jun-2025 10:56 by rmk") + (* ; "Edited 20-May-2025 14:50 by rmk") + (* ; "Edited 18-May-2025 21:52 by rmk") + (* ; "Edited 12-May-2025 21:09 by rmk") + (* ; "Edited 9-May-93 23:12 by rmk:") + + (* ;; "builds a csinfo which contains only the slug (black rectangle) character. Maybe there should only be a single FONTDESC argument") + + (CL:WHEN (type? FONTDESCRIPTOR WIDTH) + (SETQ HEIGHT (OR HEIGHT (fetch (FONTDESCRIPTOR \SFHeight) of WIDTH))) + (SETQ DESCENT (OR DESCENT (fetch (FONTDESCRIPTOR \SFDescent) of WIDTH))) + (SETQ DEVICE (OR DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of WIDTH))) + + (* ;; "SCALE is only used for the display bitmap") + + (SETQ SCALE (OR SCALE (fetch (FONTDESCRIPTOR FONTSCALE) of WIDTH) + 1)) + (SETQ WIDTH (CL:IF (EQ 0 (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of WIDTH)) + (FIXR (FTIMES HEIGHT 0.6)) + (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of WIDTH)))) + (LET ((CSINFO (create CHARSETINFO + CHARSETASCENT _ (IDIFFERENCE HEIGHT DESCENT) + CHARSETDESCENT _ DESCENT + CSSLUGP _ T + CSCOMPLETEP _ T)) + WIDTHS OFFSETS BITMAP IMAGEWIDTHS) + (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) + (replace IMAGEWIDTHS OF CSINFO with WIDTHS) + (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS (\CREATECSINFOELEMENT))) + (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) + (CL:WHEN (MEMB DEVICE \DISPLAYSTREAMTYPES) + (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE)) + (ROUND (QUOTIENT HEIGHT SCALE)) + 1)) + [BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE] + (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)) + CSINFO]) (\FONTSYMBOL [LAMBDA (X ElseReturnXFlg) (* ; "Edited 28-Jul-88 11:59 by rmk:") @@ -1652,7 +2127,8 @@ (\FONTSYMBOL X ElseReturnXFlg]) (\FONTFACE - [LAMBDA (FACE NOERRORFLG DEV) (* ; "Edited 1-Aug-88 09:44 by rmk:") + [LAMBDA (FACE NOERRORFLG DEV) (* ; "Edited 21-Jun-2025 23:16 by rmk") + (* ; "Edited 1-Aug-88 09:44 by rmk:") (* ; "Edited 28-Jul-88 15:50 by rmk:") (* ; "Edited 28-Jul-88 15:49 by rmk:") (* ; "Edited 28-Jul-88 15:41 by rmk:") @@ -1662,40 +2138,40 @@ (* ;; "Coerces FACE into standard FONTFACE record, usually returns a CONSTANT (so you'd better not RPLACD or REPLACE fields!!)") - (PROG (UNKNOWN (WEIGHT 'MEDIUM) - (SLOPE 'REGULAR) - (EXPANSION 'REGULAR) - (OLDFACE FACE)) + (PROG ((UNKNOWN (CL:IF (EQ NOERRORFLG 'REGULAR) + 'REGULAR + 'ERROR)) + (WEIGHT 'MEDIUM) + (SLOPE 'REGULAR) + (EXPANSION 'REGULAR) + (OLDFACE FACE)) (* ;; "On error, can signal, or return NIL, or return REGULAR face.") - [SETQ UNKNOWN (COND - ((EQ NOERRORFLG 'REGULAR) - 'REGULAR) - (T 'ERROR] [COND ((type? FONTFACE FACE) (* ;; "List Case. Unpack because want to validate fields") - (SETQ WEIGHT (fetch (FONTFACE WEIGHT) of FACE)) - (SETQ SLOPE (fetch (FONTFACE SLOPE) of FACE)) - (SETQ EXPANSION (fetch (FONTFACE EXPANSION) of FACE)) + (SETQ WEIGHT (U-CASE (fetch (FONTFACE WEIGHT) of FACE))) + (SETQ SLOPE (U-CASE (fetch (FONTFACE SLOPE) of FACE))) + (SETQ EXPANSION (U-CASE (fetch (FONTFACE EXPANSION) of FACE))) (* ;; "Handle unknown faces") - [OR (\FONT.SYMBOLMEMB WEIGHT ' (* BOLD MEDIUM LIGHT)) + (CL:UNLESS (MEMB WEIGHT '(BOLD MEDIUM LIGHT *))(* ; + "STRING.EQUAL is case and package insensitive") (SETQ WEIGHT (COND - ((\FONT.COMPARESYMBOL WEIGHT 'REGULAR) + ((STRING.EQUAL WEIGHT 'REGULAR) (* ;; "Clean up WEIGHT REGULAR vs. MEDIUM") (SETQ WEIGHT 'MEDIUM)) - (T UNKNOWN] - (OR (\FONT.SYMBOLMEMB SLOPE ' (* REGULAR ITALIC)) - (SETQ SLOPE UNKNOWN)) - (OR (\FONT.SYMBOLMEMB EXPANSION ' (* COMPRESSED REGULAR EXPANDED)) - (SETQ EXPANSION UNKNOWN))) + (T UNKNOWN)))) + (CL:UNLESS (MEMB SLOPE '(REGULAR ITALIC *)) + (SETQ SLOPE UNKNOWN)) + (CL:UNLESS (MEMB EXPANSION '(COMPRESSED REGULAR EXPANDED *)) + (SETQ EXPANSION UNKNOWN))) ((OR (LITATOM FACE) (STRINGP FACE)) (COND @@ -1733,20 +2209,19 @@ ((STANDARD REGULAR) T) NIL)) - ((\FONT.COMPARESYMBOL FACE 'BOLD) + ((STRING.EQUAL FACE 'BOLD) (SETQ WEIGHT 'BOLD)) - ((\FONT.COMPARESYMBOL FACE 'ITALIC) + ((STRING.EQUAL FACE 'ITALIC) (SETQ SLOPE 'ITALIC)) - ((\FONT.COMPARESYMBOL FACE 'BOLDITALIC) + ((STRING.EQUAL FACE 'BOLDITALIC) (SETQ WEIGHT 'BOLD) (SETQ SLOPE 'ITALIC)) - ((\FONT.SYMBOLMEMB FACE '(STANDARD REGULAR NIL NNN)) - (* ; "Vanilla case") + ((MEMB FACE '(STANDARD REGULAR NIL NNN)) (* ; "Vanilla case") ) ((STRPOS "-" FACE) (* ; "Color fontface spec!") (SETQ FACE (\FONTFACE.COLOR FACE NOERRORFLG DEV)) (RETURN FACE)) - ((\FONT.SYMBOLMEMB FACE ' (* ***)) + ((MEMB FACE ' (* ***)) (* ; "Wildcard case") (SETQ WEIGHT '*) (SETQ SLOPE '*) @@ -1756,11 +2231,11 @@ (SETQ SLOPE UNKNOWN) (SETQ EXPANSION UNKNOWN] (if (OR (EQ WEIGHT 'ERROR) - (EQ SLOPE 'ERROR) - (EQ EXPANSION 'ERROR)) + (EQ SLOPE 'ERROR) + (EQ EXPANSION 'ERROR)) then (if NOERRORFLG - then (RETURN NIL) - else (\ILLEGAL.ARG OLDFACE))) + then (RETURN NIL) + else (\ILLEGAL.ARG OLDFACE))) (* ;; "Avoid consing by returning constant faces (historical: really, would have been better to return MRR, but users have know about this for too long (rmk))") @@ -1902,794 +2377,458 @@ (NOERRORFLG (RETURN NIL)) (T (\ILLEGAL.ARG FACE]) -(\FONTFILENAME - [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 5-Mar-93 16:10 by rmk:") +(SETFONTCHARENCODING + [LAMBDA (FONT CHARENCODING) (* ; "Edited 19-Jul-2025 23:28 by rmk") + (* ; "Edited 12-Jul-2025 13:15 by rmk") + (* ; "Edited 10-Jul-2025 12:38 by rmk") + (* ; "Edited 6-Jul-2025 21:41 by rmk") + (* ; "Edited 23-May-2025 14:54 by rmk") + (* ; "Edited 21-May-2025 22:27 by rmk") + (* ; "Edited 2-May-2025 16:03 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") + (* ;; "The FONT charencoding is the same as its charset 0 encoding (e.g. ALTOTEXT). But all higher charsets are MCCS") - (* ;; "**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*") + (replace (FONTDESCRIPTOR FONTCHARENCODING) of (FONTCREATE FONT) with CHARENCODING) + (CHARSETPROP (\XGETCHARSETINFO FONT 0) + 'CSCHARENCODING CHARENCODING]) +) +(DEFINEQ - (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))) - (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] - - (* ;; "Fortunately, CONCAT ignores packages.") - - (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF *USEOLDFONTDIRECTORIES* - "" - (CONCAT (PROGN - (* ; - "Lowercase because it's in a directory name, so maybe Unix will find it sooner?") - "c") - CSETNAME ">")) - FAMILY SIZEPATT "-" (CONCATCODES FACESPEC) - "-C" CSETNAME) - 'EXTENSION EXTENSION]) - -(\FONTFILENAME.OLD - [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 23-Sep-92 18:22 by jds") - - (* ;; "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]) - -(\FONTINFOFROMFILENAME - [LAMBDA (FONTFILE DEVICE) (* ; "Edited 14-Sep-96 10:23 by rmk:") - (* ; "Edited 5-Oct-89 18:28 by bvm") - - (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE. Rotation is 0 always. Parses both new & old format files.") - - (LET ((FILENAMELIST (UNPACKFILENAME.STRING FONTFILE)) - CH SIZEBEG SIZEND NAME FAMILY SIZE FACE EXT) - (SETQ NAME (LISTGET FILENAMELIST 'NAME)) (* ; - "find where the name and size are. MUST check for ch nil below or possible infinite loop") - (SETQ SIZEBEG (for CH# from 1 when (OR (NUMBERP (SETQ CH (NTHCHAR NAME CH#))) - (NULL CH)) do (RETURN CH#))) - - (* ;; "Get Family") - - [SETQ FAMILY (MKATOM (U-CASE (SUBSTRING NAME 1 (SUB1 SIZEBEG] - - (* ;; "Get Size") - - [SETQ SIZEND (find CH# from SIZEBEG suchthat (NOT (NUMBERP (NTHCHAR NAME CH#] - [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND] - (if (EQ (NTHCHAR NAME SIZEND) - '-) - then (SETQ SIZEND (ADD1 SIZEND))) - - (* ;; "Get Face") - - (SETQ NAME (U-CASE NAME)) (* ; - "don't need name, but checks for lowercase face") - [SETQ FACE (LIST (COND - ((STRPOS "B" NAME SIZEND NIL T NIL UPPERCASEARRAY) - 'BOLD) - ((STRPOS "L" NAME SIZEND NIL T NIL UPPERCASEARRAY) - 'LIGHT) - (T 'MEDIUM)) - (COND - ((STRPOS "I" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) - 'ITALIC) - (T 'REGULAR)) - (COND - ((STRPOS "E" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) - 'EXPANDED) - ((STRPOS "C-" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) - 'COMPRESSED) - (T 'REGULAR] - (LIST FAMILY SIZE FACE 0 (COND - ((STREAMP DEVICE) - (IMAGESTREAMTYPE DEVICE)) - ((NULL DEVICE) - [SETQ EXT (MKATOM (U-CASE (LISTGET FILENAMELIST 'EXTENSION] - (SELECTQ EXT - (WD 'INTERPRESS) - ((STRIKE AC DISPLAYFONT) - 'DISPLAY) - EXT)) - ((LITATOM DEVICE) - (\FONTSYMBOL DEVICE)) - (T 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]) - -(\GETFONTDESC - [LAMBDA (SPEC DEVICE NOERRORFLG) (* J.Gibbons " 5-Dec-82 16:53") - - (* ;; "Coerces SPEC to a fontdescriptor") - (* ; - "\GETFONTDESC HAS MACRO, BUT OLD CALLS STILL EXIST") - (\COERCEFONTDESC SPEC DEVICE NOERRORFLG]) - -(\COERCEFONTDESC - [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 29-Aug-91 12:19 by jds") - - (* ;; "Coerces SPEC to a fontdescriptor appropriate for STREAM. Go back thru FONTCREATE for various coercions in order to make sure that the cache gets set up") - - (DECLARE (GLOBALVARS DEFAULTFONT)) - (PROG (FONT DEVICE) - [COND - ((type? FONTDESCRIPTOR SPEC) - (SETQ FONT SPEC)) - [(type? FONTCLASS SPEC) - [SETQ DEVICE (COND - ((NULL STREAM) (* ; "Default is display") - - (* ;; "COULDN'T THIS BRANCH BE INTENDED TO MEAN 4DISPLAY, 8DISPLAY, 24DISPLAY? PEOPLE PROBABLY SHOULDN'T BE CALLING \COERCEFONTDESC WITH STREAM = NIL.") - - 'DISPLAY) - ((IMAGESTREAMP STREAM) - (IMAGESTREAMTYPE STREAM)) - ((LITATOM STREAM) - (\DEVICESYMBOL STREAM)) - (STREAM STREAM) - (T - (* ;; "I don't think this case should be allowed.") - - 'DISPLAY] - [SETQ FONT (SELECTQ DEVICE - (DISPLAY (fetch (FONTCLASS DISPLAYFD) of SPEC)) - (INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of SPEC)) - (PRESS (fetch (FONTCLASS PRESSFD) of SPEC)) - (CDR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of SPEC] - (RETURN (COND - ((type? FONTDESCRIPTOR FONT) - - (* ;; - "We don't always create FD's for devices before they are needed, so do it now and save result") - - FONT) - [(NULL FONT) - - (* ;; "NIL means create FONT but don't cache.") - - (COND - ((AND (FMEMB DEVICE \DISPLAYSTREAMTYPES) - (SETQ FONT (\COERCEFONTDESC SPEC 'DISPLAY NOERRORFLG)) - (SETQ FONT (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG)) - ) - - (* ;; - "Coerce existing black & white font to color font, but don't cache.") - - FONT) - [(EQ SPEC DEFAULTFONT) - - (* ;; "Break cycles with NIL in the defaultfont") - - (COND - (NOERRORFLG NIL) - ((EQ DEVICE 'DISPLAY) - - (* ;; "Function DEFAULTFONT guarantees system integrity") - - (DEFAULTFONT 'DISPLAY)) - ((EQUAL DEVICE '(HARDCOPY DISPLAY)) - - (* ;; - "MAKE DISPLAY-HARDCOPY FONTS default to the corresponding display font, copied....") - - (FONTCOPY (DEFAULTFONT 'DISPLAY) - 'DEVICE STREAM 'NOERROR NOERRORFLG)) - (T (ERROR (CONCAT DEVICE " component for DEFAULTFONT undefined"] - (T (FONTCREATE DEFAULTFONT NIL NIL NIL STREAM NOERRORFLG] - ((SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM NOERRORFLG)) - - (* ;; "Might get NIL if NOERRORFLG") - - (SETFONTCLASSCOMPONENT SPEC DEVICE FONT] - ((NULL SPEC) - (RETURN (\COERCEFONTDESC DEFAULTFONT STREAM NOERRORFLG))) - ((OR (IMAGESTREAMP SPEC) - (type? WINDOW SPEC)) - (SETQ FONT (DSPFONT NIL SPEC))) - (T - (* ;; "If called with NOERRORFLG=T (e.g. from DSPFONT) we want to suppress invalid arg errors as well as font not found, so we can move on to other possible coercions.") - - (RETURN (FONTCREATE SPEC NIL NIL NIL STREAM NOERRORFLG] - - (* ;; "Here if arg was a fontdescriptor or imagestream") - - (RETURN (COND - ((NULL STREAM) - - (* ;; - "NIL device doesn't default to display if a fully-specified font was found") - - FONT) - ([OR (EQ STREAM (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT)) - (AND (type? STREAM STREAM) - (EQ (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM - IMAGEOPS) - of STREAM)) - (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT] - FONT) - (T - (* ;; "Here if doesn't match or if DEVICE is not explicitly a stream.") - - (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG]) - -(\LOOKUPFONT - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Jul-88 17:05 by rmk:") - (* ; "Edited 28-Jul-88 17:04 by rmk:") - (* ; "Edited 28-Jul-88 14:44 by rmk:") - (* ; "Edited 28-Jul-88 14:02 by rmk:") - (* ; "Edited 28-Jul-88 13:54 by rmk:") - (* ; "Edited 26-Feb-87 00:20 by FS") +(FONTSAVAILABLE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) (* ; "Edited 21-Jul-2025 08:55 by rmk") + (* ; "Edited 21-Jun-2025 15:41 by rmk") + (* ; "Edited 14-Jun-2025 11:06 by rmk") + (* ; "Edited 12-Jun-2025 10:48 by rmk") + (* rrb " 7-Nov-84 15:41") - (* ;; "looks up a font in the internal cache. SASSOC for listp FACE") +(* ;;; "returns a list of the fonts fitting a description that are available. FAMILY SIZE FACE or ROTATION can be * which means get them all. if CHECKFILESTOO? is NIL, only fonts in core will be considered. If ONLY, fonts in memory will be ignored.") + + (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + (UNION (CL:UNLESS (EQ 'ONLY CHECKFILESTOO?) + (\FONTSAVAILABLE.INCORE FAMILY SIZE FACE ROTATION DEVICE)) + (CL:WHEN CHECKFILESTOO? + (if (EQ DEVICE '*) + then (* ; + "map thru all the imagestream devices") + (for I in IMAGESTREAMTYPES + join (APPLY* (OR (CADR (ASSOC 'FONTSAVAILABLE (CDR I))) + (FUNCTION NILL)) + FAMILY SIZE FACE ROTATION (CAR I))) + else (* ; + "apply the device font lookup function.") + (APPLY* (OR [CADR (ASSOC 'FONTSAVAILABLE (CDR (ASSOC DEVICE IMAGESTREAMTYPES] + (FUNCTION NILL)) + FAMILY SIZE FACE ROTATION DEVICE)))]) + +(FONTEXISTS? + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET NOCOERCIONS) + (* ; "Edited 25-Jul-2025 21:21 by rmk") + (* ; "Edited 23-Jul-2025 13:02 by rmk") + (* ; "Edited 21-Jul-2025 09:05 by rmk") + (* ; "Edited 10-Jul-2025 12:38 by rmk") + (* ; "Edited 27-Jun-2025 10:27 by rmk") + (* ; "Edited 22-Jun-2025 09:02 by rmk") + (* ; "Edited 20-Jun-2025 00:37 by rmk") + (* ; "Edited 17-Jun-2025 23:06 by rmk") + (* ; "Edited 16-Jun-2025 10:08 by rmk") + + (* ;; "Do we have any way of finding or creating the font, even by coercion from other fonts? If not NIL, value is either the font in memory or the file that contains information about the requested CHARSET. The DEVICE can have a FONTEXISTS? function for the case where we can't find a file--presumably returns the file for a coercion to a different font specification.") + + (* ;; + "Tries device specific coercions if the original request can't be satisfied and NOCOERCIONS is NIL.") + + (DECLARE (GLOBALVARS \FONTSINCORE \FONTEXISTS?-CACHE IMAGESTREAMTYPES)) + (LET ((FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE CHARSET)) + VAL) + (if (type? FONTDESCRIPTOR FONTSPEC) + then + (* ;; + "FAMILY was a font descriptor, unmodified by other args: record that it exists") + + (SPREADFONTSPEC (FONTPROP FONTSPEC 'SPEC)) + (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTSPEC) + else (SPREADFONTSPEC FONTSPEC) + (if (GETMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE CHARSET) + elseif (SETQ VAL (GETMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE + CHARSET)) + then (CL:UNLESS (EQ VAL 'NO) + VAL) + else (CL:WHEN (MEMB ROTATION '(0 90 270)) (* ; + "Only 0 really exists. We cache just the first file. ") + (SETQ VAL (OR (CAR (FONTFILES FAMILY SIZE FACE 0 DEVICE 0)) + (AND CHARSET (NEQ CHARSET 0) + (FONTFILES FAMILY SIZE FACE 0 DEVICE CHARSET)) + (APPLY* (OR [CADR (ASSOC 'FONTEXISTS? + (CDR (ASSOC DEVICE IMAGESTREAMTYPES + ] + (FUNCTION NILL)) + FAMILY SIZE FACE 0 DEVICE CHARSET)))) + (if VAL + then (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET + VAL) + elseif [AND (NOT NOCOERCIONS) + (find FS in (\COERCEFONTSPEC (GETATOMVAL (PACK* DEVICE + "FONTCOERCIONS") + ) + FAMILY SIZE FACE ROTATION DEVICE CHARSET) + suchthat (SETQ VAL (FONTEXISTS? FS NIL NIL NIL DEVICE CHARSET + T] + then (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET + VAL) + else (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET + 'NO) + NIL]) + +(\FONTSAVAILABLE.INCORE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 21-Jul-2025 09:27 by rmk") + (* ; "Edited 21-Jun-2025 11:17 by rmk") + (* ; "Edited 25-Apr-93 13:07 by rmk:") + (* rrb "25-Sep-84 12:10") + + (* ;; "Returns a list of the fonts that are available in core. * matches anything. * can appear as a component of FACE") (DECLARE (GLOBALVARS \FONTSINCORE)) + (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + (COLLECTMULTI \FONTSINCORE (FUNCTION (LAMBDA (FM S FC R D FONT) + (CL:WHEN [AND (OR (EQ FAMILY FM) + (EQ FAMILY '*)) + (OR (EQ SIZE S) + (EQ SIZE '*)) + (MATCHFONTFACE FACE FC) + (OR (EQ ROTATION R) + (EQ ROTATION '*)) + (OR (EQ DEVICE D) + (EQ DEVICE '*] + (push $$COLLECT (LIST FM S FC R D)))]) - (* ;; "Someone had better have already made FACE canonical") - - (LET [(X (CDR (FASSOC ROTATION (CDR (SASSOC FACE (CDR (FASSOC SIZE (CDR (OR (FASSOC FAMILY - \FONTSINCORE) - (\FONT.SYMBOLASSOC - FAMILY \FONTSINCORE] - (CDR (OR (FASSOC DEVICE X) - (\FONT.SYMBOLASSOC DEVICE X]) - -(\LOOKUPFONTSINCORE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 25-Apr-93 13:07 by rmk:") - (* rrb "25-Sep-84 12:10") - -(* ;;; "returns a list of the fonts that are available in core. * is used to match anything.") - +(\SEARCHFONTFILES + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 21-Jul-2025 08:57 by rmk") + (* ; "Edited 10-Jul-2025 11:19 by rmk") + (* ; "Edited 21-Jun-2025 12:00 by rmk") + (* ; "Edited 13-Jun-2025 22:49 by rmk") + (* ; "Edited 12-Jun-2025 08:49 by rmk") + (* ; "Edited 17-May-2025 14:09 by rmk") + (* ; "Edited 15-May-2025 23:12 by rmk") + (* ; "Edited 14-Sep-96 10:54 by rmk:") + (* ; "Edited 6-Oct-89 12:34 by bvm") + + (* ;; "GENERIC FUNCTION") + + (* ;; "returns a list of the fonts that can be read in for a device. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") + + (* ;; "Just in case the caller hasn't check the arguments:") + + (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + (CL:UNLESS DIRLST + [SETQ DIRLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTDIRECTORIES"]) + (CL:UNLESS EXTLST + [SETQ EXTLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTEXTENSIONS"]) + (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH _ 1) + IN (\FONTFILENAMES FAMILY SIZE FACE DEVICE EXTLST) + do (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY)) + (SETQ FILEDIR (CL:IF FILEDIR + (CONCAT ">" FILEDIR ">") + "")) + (for DIR inside DIRLST eachtime + + (* ;; "The file pattern might have an extending subdirectory (C41>) that might not exist, but DIRECTORYNAMEP makes sure that it does.") + + (SETQ DIR (CONCAT DIR ">" (OR FILEDIR ""))) + when (DIRECTORYNAMEP DIR) do (for FONTFILE THISFONT in (DIRECTORY DIR) + eachtime (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE + DEVICE T)) + + (* ;; + "make sure the face, size, and family really match.") + when (AND (OR (EQ FAMILY '*) + (EQ FAMILY (CAR THISFONT))) + (OR (EQ SIZE '*) + (EQ SIZE (CADR THISFONT))) + (MATCHFONTFACE FACE (CADDR THISFONT))) unless (MEMBER THISFONT FONTSFOUND) + do (push FONTSFOUND THISFONT))) + finally (RETURN (DREVERSE FONTSFOUND]) + +(FLUSHFONTSINCORE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 21-Jul-2025 08:59 by rmk") + (* ; "Edited 21-Jun-2025 11:19 by rmk") (DECLARE (GLOBALVARS \FONTSINCORE)) - (for FAMBUCKET in \FONTSINCORE when (OR (EQ FAMILY '*) - (EQ FAMILY (CAR FAMBUCKET))) - join (for SIZEBUCKET in (CDR FAMBUCKET) when (OR (EQ SIZE '*) - (EQ SIZE (CAR SIZEBUCKET))) - join (for FACEBUCKET in (CDR SIZEBUCKET) - when (OR (EQ FACE '*) - (EQUAL FACE (CAR FACEBUCKET))) - join (for ROTBUCKET in (CDR FACEBUCKET) - when (OR (EQ ROTATION '*) - (EQ ROTATION (CAR ROTBUCKET))) - join (for DEVBUCKET in (CDR ROTBUCKET) - when (AND (OR (EQ DEVICE '*) - (EQ DEVICE (CAR DEVBUCKET))) - (TYPE? FONTDESCRIPTOR - (CDR DEVBUCKET))) - collect (LIST (CAR FAMBUCKET) - (CAR SIZEBUCKET) - (CAR FACEBUCKET) - (CAR ROTBUCKET) - (CAR DEVBUCKET]) - -(\READDISPLAYFONTFILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 8-Oct-96 10:17 by rmk:") - (* ; - "Edited 30-Sep-96 12:03 by kaplan") - (* ; "Edited 2-Jan-87 17:55 by FS") - - (* ;; "Look for new filename convention, then old file name convention, with extensions. If CACHEDISPLAYFONTS, this keeps a cache of what was read, on the canonical filename's property list, so that NSDISPLAYSIZES and SMALLSCREEN size coercions can be done and undone without always going out to the directories.") - - (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES CACHEDISPLAYFONTS)) - (BIND FONTFILE CSINFO STRM - FIRST - - (* ;; "Cache is indexed by canonical font file name, without the extension fields.") - - (CL:WHEN - [AND CACHEDISPLAYFONTS - (FIND EXT INSIDE DISPLAYFONTEXTENSIONS - SUCHTHAT (SETQ CSINFO - (GETP (L-CASE (FILENAMEFIELD (IF (FMEMB EXT - *OLD-FONT-EXTENSIONS* - ) - THEN (\FONTFILENAME.OLD - FAMILY SIZE FACE - EXT CHARSET) - ELSE (\FONTFILENAME - FAMILY SIZE FACE EXT - CHARSET)) - 'NAME)) - 'CACHEDCHARSET] - (RETURN (AND (NEQ CSINFO T) - (COPYALL CSINFO)))) FOR EXT INSIDE DISPLAYFONTEXTENSIONS - WHEN (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET - DISPLAYFONTDIRECTORIES (LIST EXT))) - DO - - (* ;; - "Cache is indexed by canonical font file name, without the directory or extension fields") - - (SETQ STRM (OPENSTREAM FONTFILE 'INPUT)) - (RESETLST - [SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T) - (STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF) - STRM)) - (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE)) - (AC - (* ;; "CLOSEF is guaranteed inside \READACFONTFILE, against the possibility that we have to copy to make randaccessp") - - (\READACFONTFILE STRM FAMILY SIZE FACE)) - (PROG1 (CLOSEF STRM) (* ; -"This would get done by RESETSAVE if AC's were read sequentially and we could factor the RESETSAVE") - (SHOULDNT))]) - (CL:WHEN CACHEDISPLAYFONTS - (PUTPROP (L-CASE (FILENAMEFIELD FONTFILE 'NAME)) - 'CACHEDCHARSET CSINFO) - (SETQ CSINFO (COPYALL CSINFO))) - - (* ;; "If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also be nice to tell the user that he has a bogus file.") - - (RETURN CSINFO) - FINALLY - - (* ;; "Didn't find the file, cache T to suppress future lookups") - - (CL:WHEN CACHEDISPLAYFONTS - (PUTPROP (L-CASE (FILENAMEFIELD (IF (FMEMB (CAR (MKLIST DISPLAYFONTEXTENSIONS)) - *OLD-FONT-EXTENSIONS*) - THEN (\FONTFILENAME.OLD - FAMILY SIZE FACE (CAR (MKLIST - DISPLAYFONTEXTENSIONS - )) - CHARSET) - ELSE (\FONTFILENAME FAMILY SIZE FACE - (CAR (MKLIST DISPLAYFONTEXTENSIONS - )) - CHARSET)) - 'NAME)) - 'CACHEDCHARSET T))]) + (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + (MAPMULTI \FONTSINCORE (FUNCTION (LAMBDA (FM S FC R TAIL) + (CL:WHEN [AND (OR (EQ FAMILY FM) + (EQ FAMILY '*)) + (OR (EQ SIZE S) + (EQ SIZE '*)) + (MATCHFONTFACE FACE FC) + (OR (EQ ROTATION R) + (EQ ROTATION '*)) + (OR (EQ DEVICE (CAR TAIL)) + (EQ DEVICE '*] + (RPLACD TAIL]) + +(MATCHFONTFACE + [LAMBDA (PATTERN FACE) (* ; "Edited 21-Jun-2025 11:57 by rmk") + + (* ;; "Does FACE match a PATTERN that may contain stars?") + + (OR (EQ PATTERN '*) + (EQUAL PATTERN FACE) + (LET ((PWEIGHT (fetch (FONTFACE WEIGHT) of PATTERN)) + (PSLOPE (fetch (FONTFACE SLOPE) of PATTERN)) + (PEXPANSION (fetch (FONTFACE EXPANSION) of PATTERN))) + (AND (OR (EQ PWEIGHT (fetch (FONTFACE WEIGHT) of FACE)) + (EQ PWEIGHT '*)) + (OR (EQ PSLOPE (fetch (FONTFACE SLOPE) of FACE)) + (EQ PSLOPE '*)) + (OR (EQ PEXPANSION (fetch (FONTFACE EXPANSION) of FACE)) + (EQ PEXPANSION '*]) + +(FINDFONTFILES + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 21-Jul-2025 09:00 by rmk") + (* ; "Edited 29-Jun-2025 09:08 by rmk") + + (* ;; "GENERIC FUNCTION") + + (* ;; "returns a list of the fontfiles that can be read in for a device. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") + + (* ;; "The same algorithm as \SEARCHFONTFILES except returns the file names. This may return several files for the same specification") + + (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + (CL:UNLESS DIRLST + [SETQ DIRLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTDIRECTORIES"]) + (CL:UNLESS EXTLST + [SETQ EXTLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTEXTENSIONS"]) + (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH _ 1) + IN (\FONTFILENAMES FAMILY SIZE FACE DEVICE EXTLST) + do (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY)) + (SETQ FILEDIR (CL:IF FILEDIR + (CONCAT ">" FILEDIR ">") + "")) + (for DIR inside DIRLST eachtime + + (* ;; "The file pattern might have an extending subdirectory (C41>) that might not exist, but DIRECTORYNAMEP makes sure that it does.") + + (SETQ DIR (CONCAT DIR ">" (OR FILEDIR ""))) + when (DIRECTORYNAMEP DIR) do (for FONTFILE FONTSPEC THISFACE in (DIRECTORY DIR) + eachtime (SETQ FONTSPEC (\FONTINFOFROMFILENAME FONTFILE + DEVICE)) + (SETQ THISFACE (CADDR FONTSPEC)) + + (* ;; + "make sure the face, size, and family really match.") + when (AND (NOT (MEMBER FONTFILE FONTSFOUND)) + (OR (EQ FAMILY '*) + (EQ FAMILY (CAR FONTSPEC))) + (OR (EQ SIZE '*) + (EQ SIZE (CADR FONTSPEC))) + (MATCHFONTFACE FACE THISFACE)) do (push FONTSFOUND FONTFILE))) + finally (RETURN (DREVERSE FONTSFOUND]) ) - - -(* ;; -"\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. " -) - - -(ADDTOVAR *OLD-FONT-EXTENSIONS* STRIKE) - -(RPAQ? *USEOLDFONTDIRECTORIES* NIL) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*) -) - - - -(* ;; -"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)" -) - - - - -(* ;; -"Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)" -) - - -(RPAQ? CACHEDISPLAYFONTS ) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS CACHEDISPLAYFONTS) -) +(RPAQ? \FONTEXISTS?-CACHE NIL) -(* ; "STRIKE format file support") +(* ; "Functions for DISPLAY IMAGESTREAMTYPES ") (DEFINEQ -(\READSTRIKEFONTFILE - [LAMBDA (STRM FAMILY SIZE FACE) (* ; "Edited 12-Jul-2022 09:19 by rmk") - (* ; "Edited 4-Dec-92 12:11 by jds") - (* ; - "STRM has already been determined to be a vanilla strike-format file.") - (* ; "returns a charsetinfo") - (COND - ((NEQ 2 (GETFILEPTR STRM)) - (SETFILEPTR STRM 2))) - (LET (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS) - (SETQ CSINFO (create CHARSETINFO)) - (SETQ FIRSTCHAR (\WIN STRM)) (* ; "minimum ascii code") - (SETQ LASTCHAR (\WIN STRM)) (* ; "maximum ascii code") - (\WIN STRM) (* ; - "MaxWidth which isn't used by anyone.") - (\WIN STRM) (* ; - "number of words in this StrikeBody") - (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM)) - (* ; - "ascent in scan lines (=FBBdy+FBBoy)") - (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM)) - (* ; "descent in scan-lines (=FBBoy)") - (\WIN STRM) (* ; - "offset in bits (<0 for kerning, else 0, =FBBox)") - (SETQ RW (\WIN STRM)) (* ; "raster width of bitmap") - (* ; "height of bitmap") - - (* ;; "JDS 12/4/92: Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.") +(\CREATEDISPLAYFONT + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 13-Jun-2025 22:58 by rmk") + (* ; "Edited 9-Jun-2025 17:42 by rmk") + (* ; "Edited 7-Jun-2025 15:11 by rmk") + (* ; "Edited 23-May-2025 14:59 by rmk") + (* ; "Edited 22-May-2025 09:52 by rmk") + + (* ;; "FONTCREATE1 has determined that there is at least one source file for this font, so the font exists in at least some character sets, although maybe not CHARSET.") + + (* ;; "This would be the right place to do DISPLAYFONTCOERCIONS, but that doesn't work if the target font is only partially instantiated. \GETCHARSETINFO has to know how to do the font coercion.") + (* gbn%: "25-Jan-86 18:02") + (LET [(FONTDESC (create FONTDESCRIPTOR + FONTDEVICE _ DEVICE + FONTFAMILY _ FAMILY + FONTSIZE _ SIZE + FONTFACE _ FACE + \SFAscent _ 0 + \SFDescent _ 0 + \SFHeight _ 0 + ROTATION _ ROTATION + FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE] + (\CREATECHARSET CHARSET FONTDESC) + FONTDESC]) - (SETQ HEIGHT (IPLUS (SIGNED (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) - 16) - (SIGNED (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO) - 16))) - (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD) - HEIGHT)) - (\BINS STRM (fetch BITMAPBASE of BITMAP) - 0 - (UNFOLD (ITIMES RW HEIGHT) - BYTESPERWORD)) (* ; "read bits into bitmap") - (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP) - (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR) - 3)) (* ; - "(SETQ OFFSETS (ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0))") - (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (* ; "initialise the offsets to 0") - (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0)) - (* ; - "(AIN OFFSETS FIRSTCHAR NUMBCODES STRM)") - (for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM))) - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0)) - (* ; - "(replace WIDTHS of (CHARSETINFO CSINFO) with (ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0))") - (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR) - (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO)) - CSINFO]) +(\CREATECHARSET.DISPLAY + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC)(* ; "Edited 22-Jul-2025 22:04 by rmk") + (* ; "Edited 13-Jul-2025 11:44 by rmk") + (* ; "Edited 11-Jul-2025 11:00 by rmk") + (* ; "Edited 8-Jul-2025 08:14 by rmk") + (* ; "Edited 6-Jul-2025 22:55 by rmk") + (* ; "Edited 8-Jun-2025 19:57 by rmk") + (* ; "Edited 20-May-2025 15:00 by rmk") + (* ; "Edited 18-May-2025 23:31 by rmk") + (* ; "Edited 14-Jan-88 23:42 by FS") -(\SFMAKEBOLD - [LAMBDA (CSINFO) (* gbn "25-Jul-85 04:52") - (PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) - (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) - (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) - NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH) - (SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP) - (fetch BITMAPHEIGHT of OLDCHARBITMAP))) - (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR))) - (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR))) - [for I from 0 to \MAXCHAR - do (COND - ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I)) - UNKNOWNOFFSET) (* ; - "if this is the magic charcode with the slug image (charcode 256) then leave it alone") - NIL) - (T (* ; - "overlap two blts to produce bold effect") - (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0 (\FGETWIDTH WIDTHS I - ) - HEIGHT - 'INPUT - 'REPLACE) - (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP (ADD1 OFFSET) - 0 - (SUB1 (\FGETWIDTH WIDTHS I)) - HEIGHT - 'INPUT - 'PAINT] (* ; - "fill in the slug for the magic charcode") - (BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT - 'INPUT - 'REPLACE) - (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWCHARBITMAP]) + (* ;; "The first case is simple: A DISPLAYFONTCOERCIONS substitution for one font for another. E.g. Use the information derived for HELVETICA 4 to construct the fontdescriptor for Helvetic 3. ") -(\SFMAKEITALIC - [LAMBDA (CSINFO) (* gbn "18-Sep-85 17:57") - (PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) - (DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) - (OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) - HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX) - (SETQ HEIGHT (IPLUS ASCENT DESCENT)) - (SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP) - (fetch BITMAPHEIGHT of OLDBITMAP))) - (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR))) - (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR))) - (SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3) - 4))) - (SETQ M (IQUOTIENT (IPLUS ASCENT 3) - 4)) - [for I from 0 to \MAXTHINCHAR - do (COND - ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I)) - UNKNOWNOFFSET) (* ; - "if this is the magic charcode with the slug image (charcode 256) then leave it alone") - NIL) - (T (SETQ WIDTH (\FGETWIDTH WIDTHS I)) - (for J from N to M - do (SETQ R (IPLUS OFFSET WIDTH)) - (SETQ XN (IMIN R (IMAX (IPLUS OFFSET J) - 0))) - (SETQ XX (IMIN R (IMAX (IPLUS R J) - 0))) - [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4] - [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4) - 4] - (COND - ((AND (IGREATERP XX XN) - (IGREATERP YX YN)) - (BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE - XX XN) - (IDIFFERENCE YX YN) - 'INPUT - 'REPLACE] - (BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT - 'INPUT - 'REPLACE) - (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWBITMAP]) + (* ;; "After that, it uses requested source files and/or DISPLAYGLYPHCOERCIONS to produce and complete the CHARSETINFO:") -(\SFMAKEROTATEDFONT - [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") + (* ;; "This first tries to find a source file that exactly matches the characteristics of the requested charset. The charset is %"completed%" by filling in any missing characters from further down the coercion chain. Thus, the missing characters for e.g. TERMINAL 357 will be filled in from MODERN357, and then perhaps CLASSIC357.") - (* ;; "takes a fontdecriptor and rotates it.") + (* ;; "If an exact match file cannot be found for a requested rotation, the rotation 0 charset is obtained and rotated.") - (* ;; "1/5/86 JDS. Masterscope claims nobody calls this. Let's find out....") + (* ;; "If a non-existent Kanji or Chinese charset is requested for a non-MRR face, the MRR charset is used unmodified. We don't try to boldify or italicize Kanji or Chinese.") - (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields") - (* (create FONTDESCRIPTOR using - FONTDESC (SETQ CHARACTERBITMAP - (\SFROTATEFONTCHARACTERS - (fetch (FONTDESCRIPTOR - CHARACTERBITMAP) of FONTDESC) - ROTATION)) (SETQ ROTATION ROTATION) - (SETQ \SFOffsets ( - \SFFIXOFFSETSAFTERROTATION FONTDESC - ROTATION)) (SETQ FONTCHARSETVECTOR - (\ALLOCBLOCK (ADD1 \MAXCHARSET) T)))) + (* ;; "When all coercions have been exhausted and FACE is bold and/or italic, the search process repeats with bold/italice changed to Regular, and algorithmic transformations are applied to the first result, if any.") - (* ;; "If you uncomment out the code above, remove this comment and the NIL below") + (* ;; "If all else fails, it looks for the next charset in the coercion list, and fills that in with further coercions for missing characters.") - NIL]) + (* ;; "") -(\SFROTATECSINFO - [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38") + (* ;; "Maybe nobody cares about Classic 36...let's remove that coercion and see what happens.") - (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.") + (* ;; "There is a strategy question about the priority of charset coercion with respect to the other transformations. It might seem better to coerce to a real charset, if any, before apply the algorithmic bolding/italicizing. But the glitch is that nonexistent MODERN 36 BOLD would first coerce to CLASSIC 36, which also doesn't exist. But CLASSIC 36 has a font-substitution to CLASSIC 24, and the result would be the glyphs for CLASSIC 24-BRR, which turns out to be much less attractive and appropriate than the boldified version of MODERN36-MRR. So, to get MODERN36 bold, either the CHARSET coercion has to come after the bolding, the coercion of CLASSIC36 to CLASSIC24 has to be removed or refined, or the whole-font substitution should come after the charset coercion. ") - (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS - (fetch (CHARSETINFO CHARSETBITMAP) - of CSINFO) - ROTATION) - OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION]) + (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS DISPLAYGLYPHCOERCIONS)) + (LET (CSINFO) -(\SFROTATEFONTCHARACTERS - [LAMBDA (CHARBITMAP ROTATION) (* ; "Edited 22-Sep-87 10:38 by Snow") + (* ;; "If no DISPLAYFONTCOERCIONS, skip that first \COERCECHARSET call--easier debugging of the other case.") -(* ;;; "rotate a bitmap either 90 or 270 for fonts.") + (SETQ CSINFO (if (AND DISPLAYFONTCOERCIONS (\COERCECHARSET FAMILY SIZE FACE ROTATION DEVICE + CHARSET DISPLAYFONTCOERCIONS)) + elseif (SETQ CSINFO (OR (\READCHARSET FAMILY SIZE FACE ROTATION DEVICE + CHARSET) + (\COERCECHARSET FAMILY SIZE FACE ROTATION DEVICE + CHARSET DISPLAYGLYPHCOERCIONS))) + then + (* ;; "This completes CSINFO with glyphs for all codes from possibly different sources, even if just asking for a single THINCODE. We never return an incomplete CSINFO.") - (CASE ROTATION - (0 CHARBITMAP) - (90 (ROTATE-BITMAP-LEFT CHARBITMAP)) - (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP))) - (270 (ROTATE-BITMAP CHARBITMAP)))]) + (COMPLETE.CHARSET CSINFO FAMILY SIZE FACE ROTATION DEVICE CHARSET + DISPLAYGLYPHCOERCIONS FONTDESC) + elseif (NEQ ROTATION 0) + then (CL:UNLESS (MEMB ROTATION '(90 270)) + (ERROR "only implemented rotations are 0, 90 and 270." ROTATION + )) + (CL:WHEN (SETQ CSINFO (\CREATECHARSET.DISPLAY FAMILY SIZE FACE 0 + DEVICE CHARSET FONTDESC)) + (\SFROTATECSINFO CSINFO ROTATION)) + elseif (OR (KANJICHARSETP CHARSET) + (CHINESECHARSETP CHARSET)) + then (CL:UNLESS (EQUAL FACE '(MEDIUM REGULAR REGULAR)) + (\CREATECHARSET.DISPLAY FAMILY SIZE '(MEDIUM REGULAR REGULAR) + ROTATION DEVICE CHARSET FONTDESC)) + elseif (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) + then (MAKEBOLD.CHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET + DISPLAYGLYPHCOERCIONS) + elseif (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE)) + then (MAKEITALIC.CHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET + DISPLAYGLYPHCOERCIONS))) + CSINFO]) -(\SFFIXOFFSETSAFTERROTATION - [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") +(\FONTEXISTS?.DISPLAY + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 25-Jul-2025 21:38 by rmk") + (* ; "Edited 13-Jul-2025 11:45 by rmk") + (* ; "Edited 22-Jun-2025 08:53 by rmk") + + (* ;; "Order doesn't matter here, only need one to work") + + (OR (AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) + (FONTEXISTS? FAMILY SIZE (create FONTFACE using FACE WEIGHT _ 'MEDIUM) + ROTATION DEVICE CHARSET)) + (AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE)) + (FONTEXISTS? FAMILY SIZE (create FONTFACE using FACE SLOPE _ 'REGULAR) + ROTATION DEVICE CHARSET)) + (for C VAL in (\COERCEFONTSPEC (APPEND DISPLAYFONTCOERCIONS DISPLAYGLYPHCOERCIONS) + FAMILY SIZE FACE ROTATION DEVICE CHARSET) when (SETQ VAL (FONTEXISTS? + C)) + do (RETURN VAL]) +) +(DEFINEQ - (* ;; "adjusts offsets in case where rotation turned things around.") - - (HELP "NEED TO UPDATE THIS FN TO NSCHARS & NEW FONT FIELDS") - (* (COND ((EQ ROTATION 270) - (PROG ((OFFSETS (fetch - (FONTDESCRIPTOR \SFOffsets) of - FONTDESC)) (WIDTHS - (fetch (FONTDESCRIPTOR \SFWidths) of - FONTDESC)) (BITMAPHEIGHT - (BITMAPWIDTH (fetch - (FONTDESCRIPTOR CHARACTERBITMAP) of - FONTDESC))) NEWOFFSETS) - (SETQ NEWOFFSETS (COPYARRAY OFFSETS)) - (for CHARCODE from 0 to \MAXCHAR do - (SETA NEWOFFSETS CHARCODE - (IDIFFERENCE BITMAPHEIGHT - (IPLUS (ELT OFFSETS CHARCODE) - (ELT WIDTHS CHARCODE))))) - (* ; - "may be some problem with dummy character representation.") - (RETURN NEWOFFSETS))) - (T (fetch (FONTDESCRIPTOR \SFOffsets) - of FONTDESC)))) +(STRIKEFONT.FILEP + [LAMBDA (FILE) (* ; "Edited 15-May-2025 17:47 by rmk") - (* ;; "If you uncomment out the code above, remove this comment and the NIL below") + (* ;; "If high bit of type is on, then must be strike. If 2nd bit is on, must be strike-index, and we punt. We don't care about the 3rd bit") - NIL]) + (* ;; "first word has high bits (onebit index fixed). Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width. Lisp doesn't care about 'fixed'") -(\SFROTATECSINFOOFFSETS - [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:36") - (* ; - "adjusts offsets in case where rotation turned things around.") - (COND - ((EQ ROTATION 270) - (PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) - NEWOFFSETS) - (SETQ NEWOFFSETS (\CREATECSINFOELEMENT)) - [for CHARCODE from 0 to \MAXCHAR - do (\FSETOFFSET NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT - (IPLUS (\FGETOFFSET OFFSETS CHARCODE) - (\FGETWIDTH WIDTHS CHARCODE] - (* ; - "may be some problem with dummy character representation.") - (RETURN NEWOFFSETS))) - (T (fetch (CHARSETINFO OFFSETS) of CSINFO]) + (RESETLST + (CL:UNLESS (OPENP FILE 'INPUT) + [RESETSAVE (SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD)) + `(PROGN (CLOSEF? OLDVALUE]) + (CL:WHEN [MEMB (\WIN FILE) + (CONSTANT (LIST (LLSH 1 15) + (LOGOR (LLSH 1 15) + (LLSH 1 13] + T))]) -(\SFMAKECOLOR - [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr%: " 6-Feb-86 18:17") +(STRIKEFONT.GETCHARSET + [LAMBDA (STRM) (* ; "Edited 14-Jul-2025 19:52 by rmk") + (* ; "Edited 9-Jun-2025 14:22 by rmk") + (* ; "Edited 12-Jul-2022 09:19 by rmk") + (* ; "Edited 4-Dec-92 12:11 by jds") - (* ;; "makes a csinfo that has a character bitmap that is colorized.") + (* ;; "STRM has already been determined to be a vanilla strike-format file holding only the desired charset.") + (* ; "returns a charsetinfo") + (RESETLST + (CL:UNLESS (\GETSTREAM STRM 'INPUT T) + [RESETSAVE (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD)) + `(PROGN (CLOSEF? OLDVALUE]) + (SETFILEPTR STRM 0) + (CL:UNLESS (STRIKEFONT.FILEP STRM) + (ERROR "Not a STRIKE font file" STRM)) + (CL:UNLESS (EQ 2 (GETFILEPTR STRM)) + (SETFILEPTR STRM 2)) + (LET (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS) + (SETQ CSINFO (create CHARSETINFO)) + (SETQ FIRSTCHAR (\WIN STRM)) (* ; "minimum ascii code") + (SETQ LASTCHAR (\WIN STRM)) (* ; "maximum ascii code") + (\WIN STRM) (* ; + "MaxWidth which isn't used by anyone.") + (\WIN STRM) (* ; + "number of words in this StrikeBody") + (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM)) + (* ; + "ascent in scan lines (=FBBdy+FBBoy)") + (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM)) + (* ; "descent in scan-lines (=FBBoy)") + (\WIN STRM) (* ; + "offset in bits (<0 for kerning, else 0, =FBBox)") + (SETQ RW (\WIN STRM)) (* ; "raster width of bitmap") + (* ; "height of bitmap") - (PROG (CHARACTERBITMAP COLORCSINFO) - [COND - ((IMAGESTREAMP BITSPERPIXEL) - (OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL))) - (OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL))) - (SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL] - [SETQ BITSPERPIXEL (COND - ((NUMBERP BITSPERPIXEL) - BITSPERPIXEL) - (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL] - (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL)) - (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL)) - (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of - BWCSINFO - ) - BACKCOLOR FORECOLOR BITSPERPIXEL)) - (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP _ - CHARACTERBITMAP)) - (RETURN COLORCSINFO]) -) -(DEFINEQ + (* ;; "JDS 12/4/92: Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.") + + (SETQ HEIGHT (IPLUS (SIGNED (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) + 16) + (SIGNED (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO) + 16))) + (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD) + HEIGHT)) + (\BINS STRM (fetch BITMAPBASE of BITMAP) + 0 + (UNFOLD (ITIMES RW HEIGHT) + BYTESPERWORD)) (* ; "read bits into bitmap") + (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP) + (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR) + 3)) (* ; + "(SETQ OFFSETS (ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0))") + (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (* ; "initialise the offsets to 0") + (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0)) + (* ; + "(AIN OFFSETS FIRSTCHAR NUMBCODES STRM)") + (for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM))) + (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0)) + (* ; + "(replace WIDTHS of (CHARSETINFO CSINFO) with (ARRAY (IPLUS \MAXCHAR 3) (QUOTE SMALLPOSP) 0 0))") + (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR) + (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) + of CSINFO)) + CSINFO))]) (WRITESTRIKEFONTFILE - [LAMBDA (FONT CHARSET FILE) (* ; "Edited 1-Feb-2025 12:27 by mth") + [LAMBDA (FONT CHARSET FILE) (* ; "Edited 22-May-2025 09:53 by rmk") + (* ; "Edited 1-Feb-2025 12:27 by mth") (* ; "Edited 12-Jul-2022 14:36 by rmk") (* kbr%: "21-Oct-85 15:08") (* ; @@ -2702,7 +2841,7 @@ (LISPERROR "ILLEGAL ARG" CHARSET)) (LET (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS MAXWIDTH LENGTH RASTERWIDTH DUMMYCHAR DUMMYOFFSET PREVIOUSOFFSET OFFSETS) - (SETQ CSINFO (\GETCHARSETINFO CHARSET FONT T)) + (SETQ CSINFO (\INSURECHARSETINFO CHARSET FONT T)) (CL:UNLESS CSINFO (ERROR "Couldn't find charset " CHARSET)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) @@ -2816,10 +2955,286 @@ CHARSETASCENT _ (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) CHARSETDESCENT _ (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]) ) + + + +(* ; "Bitmap faking") + +(DEFINEQ + +(MAKEBOLD.CHARSET + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS) + (* ; "Edited 21-Jun-2025 09:10 by rmk") + + (* ;; "BOLD is requested in FACE, so we look for an MRR or MIR that we can bold. If we find one, we presume that it is complete for all characters in its face. But there may be other fonts in the coercion chain that have true information about the bold face that we are after. We look for those before we try to adjust the characters in the non-bold CSINFO that we found.") + + (LET ((FONTX (FONTCREATE1 FAMILY SIZE (create FONTFACE using FACE WEIGHT _ 'MEDIUM) + 0 + 'DISPLAY CHARSET)) + CSINFO SOURCECSINFO) + (CL:WHEN (AND FONTX (SETQ CSINFO (\XGETCHARSETINFO FONTX CHARSET)) + (NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO))) + (SETQ CSINFO (create CHARSETINFO copying CSINFO)) + (for THINCODE from 0 to \MAXTHINCHAR + do (if (SLUGCHARP.DISPLAY THINCODE CSINFO) + then + (* ;; "Look for a bold glyph for THINCODE lurking somewhere down the chain, copy it up. There may be different sources for different codes.") + + (CL:WHEN (SETQ SOURCECSINFO + (\COERCECHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET + COERCIONS THINCODE)) + (\MOVEFONTCHAR SOURCECSINFO CSINFO THINCODE THINCODE)) + else (MAKEBOLD.CHAR THINCODE CSINFO))) + (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with T) + CSINFO)]) + +(MAKEBOLD.CHAR + [LAMBDA (THINCODE CSINFO) (* ; "Edited 17-Jun-2025 08:22 by rmk") + + (* ;; "Replaces the bitmap for THINCODE in CSINFO with a bolder one: overlaps 2 bits to produce the bold effect. Could be iterated for bigger fonts, but eventually the open spaces would be closed up.") + + (CL:UNLESS (SLUGCHARP.DISPLAY THINCODE CSINFO) + (LET* [(OLDCHARBITMAP (\GETCHARBITMAP.CSINFO THINCODE CSINFO)) + (NEWCHARBITMAP (BITMAPCREATE (ADD1 (fetch BITMAPWIDTH of OLDCHARBITMAP)) + (fetch BITMAPHEIGHT of OLDCHARBITMAP))) + (CWIDTH (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO) + THINCODE)) + (HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) + (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO] + + (* ;; + "Paint in a shifted copy 1 bit over. The new bitmap is 1 bit wider, to keep the margin.") + + (BITBLT OLDCHARBITMAP 0 0 NEWCHARBITMAP 0 0 CWIDTH HEIGHT 'INPUT 'REPLACE) + (BITBLT OLDCHARBITMAP 0 0 NEWCHARBITMAP 1 0 CWIDTH HEIGHT 'INPUT 'PAINT) + (\PUTCHARBITMAP.CSINFO THINCODE CSINFO NEWCHARBITMAP)))]) + +(MAKEITALIC.CHARSET + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS) + (* ; "Edited 21-Jun-2025 09:10 by rmk") + + (* ;; "ITALIC is requested, so we look for an MRR or MIR that we can italicize. If we find one, we presume that it is complete for all characters in its face. But there may be other fonts in the coercion chain that have true information about the italic face that we are after. We look for those before we try to adjust the characters in non-italic CSINFO that we found.") + + (LET ((FONTX (FONTCREATE1 FAMILY SIZE (create FONTFACE using FACE SLOPE _ 'REGULAR) + 0 + 'DISPLAY CHARSET)) + CSINFO SOURCECSINFO) + (CL:WHEN (AND FONTX (SETQ CSINFO (\XGETCHARSETINFO FONTX CHARSET)) + (NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO))) + (SETQ CSINFO (create CHARSETINFO copying CSINFO)) + (for THINCODE from 0 to \MAXTHINCHAR + do (if (SLUGCHARP.DISPLAY THINCODE CSINFO) + then + (* ;; "Look for an italic glyph for THINCODE lurking somewhere down the chain, copy it up. There may be different sources for different codes.") + + (CL:WHEN (SETQ SOURCECSINFO + (\COERCECHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET + COERCIONS THINCODE)) + (\MOVEFONTCHAR SOURCECSINFO CSINFO THINCODE THINCODE)) + else (MAKEITALIC.CHAR THINCODE CSINFO))) + (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with T) + CSINFO)]) + +(MAKEITALIC.CHAR + [LAMBDA (THINCODE CSINFO) (* ; "Edited 18-Jun-2025 14:12 by rmk") + (* ; "Edited 17-Jun-2025 09:54 by rmk") + + (* ;; "Replaces the bitmap for THINCODE in CSINFO with a slanted one: It shifts rows to the right as a function of their vertical position. ") + + (CL:UNLESS (SLUGCHARP.DISPLAY THINCODE CSINFO) + (LET* ((OLDBITMAP (\GETCHARBITMAP.CSINFO THINCODE CSINFO)) + (NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP) + (fetch BITMAPHEIGHT of OLDBITMAP))) + (WIDTH (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO) + THINCODE)) + (ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) + (DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (HEIGHT (IPLUS ASCENT DESCENT))) + [for ROW XX XN YN YX from (IMINUS (IQUOTIENT (IPLUS DESCENT 3) + 4)) to (IQUOTIENT (IPLUS ASCENT 3) + 4) + do (SETQ XN (IMIN WIDTH (IMAX ROW 0))) + (SETQ XX (IMIN WIDTH (IMAX (IPLUS WIDTH ROW) + 0))) + [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES ROW 4] + [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (ITIMES (ADD1 ROW) + 4] + (CL:WHEN (AND (IGREATERP XX XN) + (IGREATERP YX YN)) + (BITBLT OLDBITMAP 0 YN NEWBITMAP XN YN (IDIFFERENCE XX XN) + (IDIFFERENCE YX YN) + 'INPUT + 'REPLACE))] + (\PUTCHARBITMAP.CSINFO THINCODE CSINFO NEWBITMAP)))]) + +(\SFMAKEBOLD + [LAMBDA (CSINFO) (* ; "Edited 16-Jun-2025 23:22 by rmk") + (* gbn "25-Jul-85 04:52") + (LET ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) + (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) + (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) + NEWCHARBITMAP OFFSET SLUGOFFSET SLUGWIDTH) + (SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP) + (fetch BITMAPHEIGHT of OLDCHARBITMAP))) + (SETQ SLUGOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR))) + (SETQ SLUGWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR))) + (for I from 0 to \MAXCHAR unless (EQ SLUGOFFSET (SETQ OFFSET (\FGETOFFSET OFFSETS I))) + do (* ; + "overlap two blts to produce bold effect") + (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0 (\FGETWIDTH WIDTHS I) + HEIGHT + 'INPUT + 'REPLACE) + (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP (ADD1 OFFSET) + 0 + (SUB1 (\FGETWIDTH WIDTHS I)) + HEIGHT + 'INPUT + 'PAINT)) (* ; + "fill in the slug for the magic charcode") + (BITBLT OLDCHARBITMAP SLUGOFFSET 0 NEWCHARBITMAP SLUGOFFSET 0 SLUGWIDTH HEIGHT 'INPUT + 'REPLACE) + (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWCHARBITMAP]) + +(\SFMAKEITALIC + [LAMBDA (CSINFO) (* ; "Edited 16-Jun-2025 23:20 by rmk") + (* gbn "18-Sep-85 17:57") + (LET ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) + (DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) + HEIGHT OFFSET NEWBITMAP WIDTH SLUGOFFSET SLUGWIDTH N M R XN XX YN YX) + (SETQ HEIGHT (IPLUS ASCENT DESCENT)) + (SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP) + (fetch BITMAPHEIGHT of OLDBITMAP))) + (SETQ SLUGOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR))) + (SETQ SLUGWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR))) + (SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3) + 4))) + (SETQ M (IQUOTIENT (IPLUS ASCENT 3) + 4)) + [for I from 0 to \MAXTHINCHAR unless (EQ SLUGOFFSET (SETQ OFFSET (\FGETOFFSET OFFSETS I))) + do (SETQ WIDTH (\FGETWIDTH WIDTHS I)) + (for J from N to M do (SETQ R (IPLUS OFFSET WIDTH)) + (SETQ XN (IMIN R (IMAX (IPLUS OFFSET J) + 0))) + (SETQ XX (IMIN R (IMAX (IPLUS R J) + 0))) + [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4] + [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4) + 4] + (CL:WHEN (AND (IGREATERP XX XN) + (IGREATERP YX YN)) + (BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE + XX XN) + (IDIFFERENCE YX YN) + 'INPUT + 'REPLACE))] + (BITBLT OLDBITMAP SLUGOFFSET 0 NEWBITMAP SLUGOFFSET 0 SLUGWIDTH HEIGHT 'INPUT 'REPLACE) + (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWBITMAP]) +) +(DEFINEQ + +(\SFMAKEROTATEDFONT + [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") + + (* ;; "takes a fontdecriptor and rotates it.") + + (* ;; "1/5/86 JDS. Masterscope claims nobody calls this. Let's find out....") + + (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields") + (* (create FONTDESCRIPTOR using + FONTDESC (SETQ CHARACTERBITMAP + (\SFROTATEFONTCHARACTERS + (fetch (FONTDESCRIPTOR + CHARACTERBITMAP) of FONTDESC) + ROTATION)) (SETQ ROTATION ROTATION) + (SETQ \SFOffsets ( + \SFFIXOFFSETSAFTERROTATION FONTDESC + ROTATION)) (SETQ FONTCHARSETVECTOR + (\ALLOCBLOCK (ADD1 \MAXCHARSET) T)))) + + (* ;; "If you uncomment out the code above, remove this comment and the NIL below") + + NIL]) + +(\SFROTATECSINFO + [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38") + + (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.") + + (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS + (fetch (CHARSETINFO CHARSETBITMAP) + of CSINFO) + ROTATION) + OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION]) + +(\SFROTATEFONTCHARACTERS + [LAMBDA (CHARBITMAP ROTATION) (* ; "Edited 22-Sep-87 10:38 by Snow") + +(* ;;; "rotate a bitmap either 90 or 270 for fonts.") + + (CASE ROTATION + (0 CHARBITMAP) + (90 (ROTATE-BITMAP-LEFT CHARBITMAP)) + (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP))) + (270 (ROTATE-BITMAP CHARBITMAP)))]) + +(\SFROTATECSINFOOFFSETS + [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:36") + (* ; + "adjusts offsets in case where rotation turned things around.") + (COND + ((EQ ROTATION 270) + (PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) + NEWOFFSETS) + (SETQ NEWOFFSETS (\CREATECSINFOELEMENT)) + [for CHARCODE from 0 to \MAXCHAR + do (\FSETOFFSET NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT + (IPLUS (\FGETOFFSET OFFSETS CHARCODE) + (\FGETWIDTH WIDTHS CHARCODE] + (* ; + "may be some problem with dummy character representation.") + (RETURN NEWOFFSETS))) + (T (fetch (CHARSETINFO OFFSETS) of CSINFO]) +) +(DEFINEQ + +(\SFMAKECOLOR + [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr%: " 6-Feb-86 18:17") + + (* ;; "makes a csinfo that has a character bitmap that is colorized.") + + (PROG (CHARACTERBITMAP COLORCSINFO) + [COND + ((IMAGESTREAMP BITSPERPIXEL) + (OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL))) + (OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL))) + (SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL] + [SETQ BITSPERPIXEL (COND + ((NUMBERP BITSPERPIXEL) + BITSPERPIXEL) + (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL] + (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL)) + (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL)) + (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of + BWCSINFO + ) + BACKCOLOR FORECOLOR BITSPERPIXEL)) + (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP _ + CHARACTERBITMAP)) + (RETURN COLORCSINFO]) +) (DEFINEQ (FONTDESCRIPTOR.DEFPRINT - [LAMBDA (FONT STREAM) (* ; "Edited 14-Dec-2024 09:13 by rmk") + [LAMBDA (FONT STREAM) (* ; "Edited 10-Jul-2025 09:32 by rmk") + (* ; "Edited 14-Dec-2024 09:13 by rmk") (LET ((LOC (LOC FONT)) (FACE (fetch (FONTDESCRIPTOR FONTFACE) of FONT))) @@ -2833,6 +3248,7 @@ (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) @@ -2840,6 +3256,8 @@ (fetch (FONTFACE SLOPE) of FACE)) (SELECTQ (fetch (FONTFACE EXPANSION) of FACE) (REGULAR 'R) + (COMPRESSED 'C) + (EXPANDED 'E) (fetch (FONTFACE EXPANSION) of FACE)) "/" (OCTALSTRING (CAR LOC)) @@ -2871,10 +3289,11 @@ (DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)) (/DECLAREDATATYPE 'FONTDESCRIPTOR - '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD + '(POINTER FLAG POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER FLAG POINTER) '((FONTDESCRIPTOR 0 POINTER) + (FONTDESCRIPTOR 0 (FLAGBITS . 0)) (FONTDESCRIPTOR 2 POINTER) (FONTDESCRIPTOR 4 POINTER) (FONTDESCRIPTOR 6 POINTER) @@ -2901,22 +3320,27 @@ (DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)) -(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) +(/DECLAREDATATYPE 'CHARSETINFO '(POINTER FLAG FLAG POINTER POINTER POINTER POINTER WORD WORD POINTER + POINTER) '((CHARSETINFO 0 POINTER) + (CHARSETINFO 0 (FLAGBITS . 0)) + (CHARSETINFO 0 (FLAGBITS . 16)) (CHARSETINFO 2 POINTER) (CHARSETINFO 4 POINTER) (CHARSETINFO 6 POINTER) (CHARSETINFO 8 POINTER) (CHARSETINFO 10 (BITS . 15)) (CHARSETINFO 11 (BITS . 15)) - (CHARSETINFO 12 POINTER)) - '14) + (CHARSETINFO 12 POINTER) + (CHARSETINFO 14 POINTER)) + '16) (ADDTOVAR SYSTEMRECLST (DATATYPE FONTCLASS ((PRETTYFONT# BYTE) DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME)) (DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) + (FONTCOMPLETEP FLAG) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE POINTER) @@ -2935,14 +3359,16 @@ (FONTSCALE POINTER) (\SFFACECODE BITS 8) (FONTAVGCHARWIDTH WORD) - (FONTIMAGEWIDTHS POINTER) + (FONTCHARENCODING POINTER) (FONTCHARSETVECTOR POINTER) (FONTHASLEFTKERNS FLAG) (FONTEXTRAFIELD2 POINTER))) -(DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD) +(DATATYPE CHARSETINFO (WIDTHS (CSSLUGP FLAG) + (CSCOMPLETEP FLAG) + OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD) (CHARSETDESCENT WORD) - LEFTKERN)) + LEFTKERN CSINFOPROPS)) ) (RPAQ? \FONTSINCORE ) @@ -2952,19 +3378,12 @@ (RPAQ? \UNITWIDTHSVECTOR ) (DECLARE%: DOEVAL@COMPILE DONTCOPY -(GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) +(GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\UNITWIDTHSVECTOR) ) -(DECLARE%: EVAL@COMPILE - -(RPAQQ NORUNCODE 255) - - -(CONSTANTS (NORUNCODE 255)) -) (* "FOLLOWING DEFINITIONS EXPORTED") (DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS) @@ -2985,6 +3404,7 @@ (INIT (DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)))) (DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) + (FONTCOMPLETEP FLAG) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE POINTER) @@ -3009,8 +3429,8 @@ (\SFFACECODE BITS 8) (FONTAVGCHARWIDTH WORD) (* ;  "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called") - (FONTIMAGEWIDTHS POINTER) (* ; "This is the image width, as opposed to the advanced width; initial hack for accents, kerning. Fields is referenced by FONTCREATE.") - (FONTCHARSETVECTOR POINTER) (* ; "A 256-pointer block, with one pointer per 'character set' --each group of 256 character codes. Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset.") + (FONTCHARENCODING POINTER) (* ; "Was FONTIMAGEWIDTHS: This is the image width, as opposed to the advanced width; initial hack for accents, kerning. Fields is referenced by FONTCREATE.") + (FONTCHARSETVECTOR POINTER) (* ; "A 257-pointer block, with one pointer per 'character set' --each group of 256 character codes. Each pointer is either NIL if there's no info for that charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the characters in that charset. The last cell if not NIL is the %"slug%" charsetinfo that can be shared as the dummy entry for otherwise NIL charsets") (FONTHASLEFTKERNS FLAG) (* ;  "T if at least one character set has an entry for left kerns") (FONTEXTRAFIELD2 POINTER)) @@ -3042,10 +3462,12 @@ WEIGHT _ 'MEDIUM SLOPE _ 'REGULAR EXPANSION _ 'REGULAR (TYPE? LISTP)) (DATATYPE CHARSETINFO (WIDTHS (* ; "The advance-width of each character, an array indexed by charcode. Usually the same as the imagewidth, but can differ for accents, kerns kerns. This is what should be used for stringwidth calculations.") + (CSSLUGP FLAG) (* ; "True if this is a slug charset") + (CSCOMPLETEP FLAG) (* ; + "True if there is no further data to fill in any remaining slug-characters in a non-slug charset") OFFSETS (* ;  "Offset of each character into the image bitmap; X value of left edge") - IMAGEWIDTHS (* ; - "imagewidths is not automagically allocated since it is not always needed") + IMAGEWIDTHS (* ; "imagewidths is not automagically allocated since it is not always needed. But at least some times the IMAGEWIDTHS and WIDTHS vectors are EQ in this case.") CHARSETBITMAP (* ;  "Bitmap containing the character images, indexed by OFFSETS") YWIDTHS @@ -3053,7 +3475,7 @@  "Max ascent for all characters in this CHARSET") (CHARSETDESCENT WORD) (* ;  "Max descent for all characters in this CHARSET") - LEFTKERN) + LEFTKERN CSINFOPROPS (* ; "Alist of extra properties")) WIDTHS _ (\CREATECSINFOELEMENT) OFFSETS _ (\CREATECSINFOELEMENT)) ) @@ -3070,10 +3492,11 @@ (DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)) (/DECLAREDATATYPE 'FONTDESCRIPTOR - '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD + '(POINTER FLAG POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER FLAG POINTER) '((FONTDESCRIPTOR 0 POINTER) + (FONTDESCRIPTOR 0 (FLAGBITS . 0)) (FONTDESCRIPTOR 2 POINTER) (FONTDESCRIPTOR 4 POINTER) (FONTDESCRIPTOR 6 POINTER) @@ -3100,26 +3523,30 @@ (DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)) -(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) +(/DECLAREDATATYPE 'CHARSETINFO '(POINTER FLAG FLAG POINTER POINTER POINTER POINTER WORD WORD POINTER + POINTER) '((CHARSETINFO 0 POINTER) + (CHARSETINFO 0 (FLAGBITS . 0)) + (CHARSETINFO 0 (FLAGBITS . 16)) (CHARSETINFO 2 POINTER) (CHARSETINFO 4 POINTER) (CHARSETINFO 6 POINTER) (CHARSETINFO 8 POINTER) (CHARSETINFO 10 (BITS . 15)) (CHARSETINFO 11 (BITS . 15)) - (CHARSETINFO 12 POINTER)) - '14) + (CHARSETINFO 12 POINTER) + (CHARSETINFO 14 POINTER)) + '16) (DECLARE%: EVAL@COMPILE (PUTPROPS FONTASCENT MACRO ((FONTSPEC) - (ffetch \SFAscent of (\GETFONTDESC FONTSPEC)))) + (ffetch \SFAscent of (FONTCREATE FONTSPEC)))) (PUTPROPS FONTDESCENT MACRO ((FONTSPEC) - (ffetch \SFDescent of (\GETFONTDESC FONTSPEC)))) + (ffetch \SFDescent of (FONTCREATE FONTSPEC)))) (PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) - (ffetch \SFHeight of (\GETFONTDESC FONTSPEC)))) + (ffetch \SFHeight of (FONTCREATE FONTSPEC)))) (PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\GETBASE OFFSETSBLOCK CHAR8CODE))) @@ -3130,11 +3557,11 @@ (PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) (\GETBASE WIDTHSBLOCK CHAR8CODE))) -(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) - (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) +(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE VAL) + (\PUTBASE WIDTHSBLOCK CHAR8CODE VAL))) (PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) - (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO + (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\INSURECHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (\CHAR8CODE CHARCODE)))) @@ -3151,37 +3578,62 @@ (PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) +) +(DECLARE%: EVAL@COMPILE -(PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?) +(PUTPROPS \XGETCHARSETINFO MACRO ((FONTDESC CHARSET) - (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then creates the required charset.") + (* ;; + "Temporary until other callers of \GETCHARSETINFO are changes to \INSURECHARSETINFO") - (* ;; - "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") + (* ;; + "Fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. ") + + (* ;; + "NOTE Current \GETCHARSETINFO takes the vector, not the font, as does current \SETCHARSETINFO") + + (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC) + (UNFOLD CHARSET 2)))) + +(PUTPROPS \GETCHARSETINFO MACRO [(CHARSET FONTDESC) + + (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then creates the required charset, maybe a slug (with CSSLUGP T).") (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC) (UNFOLD CHARSET 2)) - (\CREATECHARSET CHARSET FONTDESC NOSLUG?)))) + (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONTDESC) + CHARSET + (\CREATECHARSET CHARSET FONTDESC]) + +(PUTPROPS \INSURECHARSETINFO MACRO [(CHARSET FONTDESC) + + (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then creates the required charset, maybe a slug (with CSSLUGP T).") + + (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC) + (UNFOLD CHARSET 2)) + (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONTDESC) + CHARSET + (\CREATECHARSET CHARSET FONTDESC]) (PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3) WORDSPERCELL)))) -(PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL (* ; - "Allocates a block for the character set records") - (\ALLOCBLOCK (ADD1 \MAXCHARSET) - T))) -) +(PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL + + (* ;; "Allocates a block for the character set records, including one extra slot to hold the common slug charsetinfo") -(DEFMACRO \CREATEKERNELEMENT () (* ; "Edited 19-Dec-2024 12:20 by rmk") - `(PROGN (HELP "THIS IS BOGUS, SEE \FGETLEFTKERN") - (CL:MAKE-ARRAY (IPLUS \MAXTHINCHAR 3) - :ELEMENT-TYPE - '(SIGNED-BYTE 16) - :INITIAL-ELEMENT 0))) + (\ALLOCBLOCK (IPLUS 2 \MAXCHARSET) + T))) -(DEFMACRO \FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE) - `(CL:SETF (CL:AREF ,LEFTKERNBLOCK ,INDEX) - ,KERNVALUE)) +(PUTPROPS CHARSETPROP MACRO [ARGS (if (CDDR ARGS) + then `(PUTMULTI (fetch (CHARSETINFO CSINFOPROPS) + of ,(CAR ARGS)) + ,(CADR ARGS) + ,(CADDR ARGS)) + else `(GETMULTI (fetch (CHARSETINFO CSINFOPROPS) + of ,(CAR ARGS)) + ,(CADR ARGS]) +) (DECLARE%: EVAL@COMPILE (RPAQQ \MAXNSCHAR 65535) @@ -3192,60 +3644,136 @@ (* "END EXPORTED DEFINITIONS") + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS INDIRECTCHARSETP MACRO [(CSINFO FONT CHARSET) + + (* ;; "An indirect points somewhere else") + + (LET ([SOURCE (CL:UNLESS (fetch (CHARSETINFO CSSLUGP) of CSINFO) + (CHARSETPROP CSINFO 'SOURCE))] + (FONTSPEC (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FONT))) + (NOT (AND SOURCE (EQ (pop SOURCE) + (pop FONTSPEC)) + (EQ (pop SOURCE) + (pop FONTSPEC)) + (EQUAL (pop SOURCE) + (pop FONTSPEC)) + (EQ (pop SOURCE) + (pop FONTSPEC)) + (EQ (pop SOURCE) + (pop FONTSPEC)) + (EQ (pop SOURCE) + CHARSET]) + +(PUTPROPS MAKECSSOURCE MACRO ((FAMILY SIZE FACE ROTATION DEVICE CHARSET) + (* ; + "Corresponds to order of \READCHARSET arguments") + + (* ;; + "If FAMILY is a font, the uses its properties, and SIZE is the charset.") + + (CL:IF (type? FONTDESCRIPTOR FAMILY) + (APPEND (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FAMILY) + (CONS SIZE)) + (LIST FAMILY SIZE FACE ROTATION DEVICE CHARSET)))) +) ) (DEFINEQ +(\CREATEKERNELEMENT + [LAMBDA NIL (* ; "Edited 8-Jul-2025 22:33 by rmk") + (* ; "Edited 17-May-2025 09:36 by rmk") + + (* ;; "ARRAY not CL:MAKE-ARRAY for MAKEINIT.") + + (ARRAY (IPLUS \MAXTHINCHAR 3) + 'POINTER 0 0]) + +(\FSETLEFTKERN + [LAMBDA (CSINFO INDEX KERNVALUE) (* ; "Edited 8-Jul-2025 22:50 by rmk") + (* ; "Edited 17-May-2025 09:18 by rmk") + (CL:UNLESS (ARRAYP (ffetch (CHARSETINFO LEFTKERN) of CSINFO)) + (replace (CHARSETINFO LEFTKERN) of CSINFO with (\CREATEKERNELEMENT))) + (SETA (fetch (CHARSETINFO LEFTKERN) of CSINFO) + INDEX KERNVALUE]) + (\FGETLEFTKERN - [LAMBDA (FONT PREVCHARCODE CHARCODE) (* ; "Edited 19-Dec-2024 15:25 by rmk") + [LAMBDA (FONT PREVCHARCODE CHARCODE) (* ; "Edited 8-Jul-2025 22:15 by rmk") + (* ; "Edited 22-May-2025 09:53 by rmk") + (* ; "Edited 18-May-2025 21:30 by rmk") + (* ; "Edited 1-May-2025 11:08 by rmk") + (* ; "Edited 19-Dec-2024 15:25 by rmk") (* ;; "Returns the kern information for CHARCODE in FONT, given that it is an immediate successor of PREVCHARCODE. Returns 0 if no PREVCHARCODE/CHARCODE kerning is specified. For now, assume that the kerning information is sparse for characters within a character set, stored as a 2-level alist. ") (* ;; "If the kerning information for a character is already a FIXP, then it is an offset no matter what the preceding character might be. This appears to be the way at least AC font files are set up.") - (OR [AND (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS) of FONT) - (LET [(CHARKERNS (CDR (FASSOC (\GETCHARSETINFO (\CHARSET CHARCODE) - FONT T) - (\CHAR8CODE CHARCODE] - (OR (FIXP CHARKERNS) - (CDR (FASSOC PREVCHARCODE CHARKERNS] - 0]) + (* ;; "ACFONTFILES STORE A SINGLE NUMBER. LOGIC OF CODES IS UNCLEAR") + + (LET [(KERN (AND (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS) of FONT) + (ELT (fetch (CHARSETINFO LEFTKERN) of (\INSURECHARSETINFO (\CHARSET PREVCHARCODE + ) + FONT)) + (\CHAR8CODE PREVCHARCODE] + (OR (FIXP KERN) + (FGETMULTI (LISTP KERN) + CHARCODE) + 0]) ) +(DEFINEQ +(\CREATEFONT + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 24-Jul-2025 19:51 by rmk") + (* ; "Edited 20-May-2025 21:10 by rmk") + (* ;; "Generic font creation. Uses fontcreate method from device, build a fontdescriptor but doesn't call SETFONTDESCRIPTOR to install it.") -(* ; "NS Character specific code") + (* ;; "\DEFAULTCHARSET is kind of foolish, since \AVGCHARWIDTH wants the width of A=0,101 and therefore forces charset 0. (A may be some random character in Symbol, Math, but...).") -(DEFINEQ + (LET (FN FONT) + (CL:WHEN (AND [SETQ FN (CADR (ASSOC 'FONTCREATE (CDR (ASSOC DEVICE IMAGESTREAMTYPES] + (SETQ FONT (APPLY* FN FAMILY SIZE FACE ROTATION DEVICE CHARSET))) + (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT)) + FONT)]) (\CREATECHARSET - [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 12-Jul-2022 14:37 by rmk") + [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 22-Jul-2025 22:48 by rmk") + (* ; "Edited 9-Jul-2025 11:12 by rmk") + (* ; "Edited 15-Jun-2025 14:50 by rmk") + (* ; "Edited 13-Jun-2025 20:00 by rmk") + (* ; "Edited 10-Jun-2025 13:55 by rmk") + (* ; "Edited 7-Jun-2025 15:10 by rmk") + (* ; "Edited 18-May-2025 21:40 by rmk") + (* ; "Edited 16-May-2025 21:37 by rmk") + (* ; "Edited 12-Jul-2022 14:37 by rmk") (* ; "Edited 8-May-93 23:42 by rmk:") (* ; "Edited 4-Dec-92 11:43 by jds") (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") (* ;  "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") - (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES)) - (CL:WHEN (OR (ILESSP CHARSET 0) - (IGREATERP CHARSET \MAXCHARSET)) + (CL:UNLESS (<= 0 CHARSET \MAXCHARSET) (\ILLEGAL.ARG CHARSET)) - (LET [CSINFO (CREATEFN (COND - ((FMEMB (FONTPROP FONT 'DEVICE) - \DISPLAYSTREAMTYPES) - (FUNCTION \CREATECHARSET.DISPLAY)) - (T (CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (FONTPROP FONT 'DEVICE) - IMAGESTREAMTYPES] - - (* ;; "Create a descriptor of info for that charset, and use it to fill things in.") - - (CL:WHEN [SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC) - (LIST CHARSET FONT NOSLUG?] - (* ; - "the create method did not return NIL--NOSLUG? must be T. ") - (\INSTALLCHARSETINFO FONT CSINFO CHARSET))]) + (LET [(CSINFO (if (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT) + then (\XGETCHARSETINFO FONT CHARSET) + else (APPLY [CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (fetch (FONTDESCRIPTOR + FONTDEVICE) + of FONT) + IMAGESTREAMTYPES] + (APPEND (FONTPROP FONT 'DEVICESPEC) + (LIST CHARSET FONT NOSLUG?] + + (* ;; "Create a descriptor of info for that charset. If we got one, the subfunction may have ignored NOSLUG?. But if not, we store it in the vector so that we don't search later. But we don't return a slug: higher ups recognize NIL as a doesn't-exist error. ") + + (CL:WHEN CSINFO (\INSTALLCHARSETINFO FONT CSINFO CHARSET)) + CSINFO]) (\INSTALLCHARSETINFO - [LAMBDA (FONT CSINFO CHARSET) (* ; "Edited 12-Jul-2022 15:08 by rmk") + [LAMBDA (FONT CSINFO CHARSET) (* ; "Edited 25-May-2025 07:48 by rmk") + (* ; "Edited 23-May-2025 14:44 by rmk") + (* ; "Edited 12-Jul-2022 15:08 by rmk") (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT) (SIGNED (fetch CHARSETASCENT of CSINFO) 16))) @@ -3267,48 +3795,119 @@ (* ;; "\AVGCHARWIDTH has to be confused after the CSINFO is stuck in.") (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT)) + (\INSTALLCHARSETINFO.CHARENCODING FONT CSINFO CHARSET) CSINFO]) + +(\INSTALLCHARSETINFO.CHARENCODING + [LAMBDA (FONT CSINFO CHARSET) (* ; "Edited 12-Jul-2025 10:57 by rmk") + (* ; "Edited 9-Jul-2025 09:38 by rmk") + (* ; "Edited 6-Jul-2025 21:46 by rmk") + (* ; "Edited 25-May-2025 23:05 by rmk") + (* ; "Edited 24-May-2025 21:42 by rmk") + + (* ;; "The font charencoding is its charset 0 encoding. All higher charsets are MCCS.") + + (CL:WHEN (AND (EQ CHARSET 0) + (NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO))) + (replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT with (CHARSETPROP CSINFO 'CSCHARENCODING))) + ]) ) -(DECLARE%: DOEVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY -(GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS - CHARSETERRORFLG) +(GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYGLYPHCOERCIONS DISPLAYFONTCOERCIONS) ) -(RPAQ? DISPLAYFONTCOERCIONS NIL) - -(RPAQ? MISSINGCHARSETDISPLAYFONTCOERCIONS - '(((GACHA) - (TERMINAL)) - ((MODERN) - (CLASSIC)) - ((TIMESROMAN) - (CLASSIC)) - ((HELVETICA) - (MODERN)) - ((TERMINAL 6) - (MODERN 6)) - ((TERMINAL 8) - (MODERN 8)) - ((TERMINAL 10) - (MODERN 10)) - ((TERMINAL 12) - (MODERN 12)))) - -(RPAQ? MISSINGDISPLAYFONTCOERCIONS '(((GACHA) - (TERMINAL)) - ((MODERN) - (CLASSIC)) - ((TIMESROMAN) - (CLASSIC)) - ((HELVETICA) - (MODERN)) - ((TERMINAL) - (MODERN)))) - -(RPAQ? CHARSETERRORFLG NIL) +(* "END EXPORTED DEFINITIONS") + + + + +(* ;; +"Removed ((CLASSIC 36) (CLASSIC 24)) so that TIMESROMAN 36 BOLD boldifies rather than coercing to CLASSIC 24 BOLD." +) + + +(RPAQ? DISPLAYFONTCOERCIONS + '(((HELVETICA 1) + (HELVETICA 4)) + ((HELVETICA 2) + (HELVETICA 4)) + ((MODERN 60) + (MODERN 48)) + ((MODERN 96) + (MODERN 72)) + ((MODERN 120) + (MODERN 72)) + ((PALATINO 9) + (PALATINO 12)) + ((PALATINO 8) + (PALATINO 10)) + ((PALATINO 6) + (PALATINO 10)) + ((TITAN 6) + (TITAN 10)) + ((TITAN 9 (TITAN 10))) + ((LPT) + (AMTEX)))) + +(RPAQ? DISPLAYGLYPHCOERCIONS '(((GACHA) + (TERMINAL)) + ((MODERN) + (CLASSIC)) + ((TIMESROMAN) + (CLASSIC)) + ((HELVETICA) + (MODERN)) + ((TERMINAL) + (MODERN)))) + +(RPAQ? ADOBEDISPLAYFONTCOERCIONS + '(((HELVETICABLACK 16) + (HELVETICABLACK 18)) + ((SYMBOL) + (ADOBESYMBOL)) + ((SYMBOL 11) + (ADOBESYMBOL 10)) + ((AVANTGARDE-DEMI) + (AVANTGARDE)) + ((AVANTGARDE-BOOK) + (AVANTGARDE)) + ((NEWCENTURYSCHLBK) + (CENTURYSCHOOLBOOK)) + ((BOOKMAN-LIGHT) + (BOOKMAN)) + ((BOOKMAN-DEMI) + (BOOKMAN)) + ((HELVETICA-NARROW) + (HELVETICANARROW)) + ((HELVETICA 24) + (ADOBEHELVETICA 24)))) (RPAQ? \DEFAULTCHARSET 0) + + + +(* ; "MAPPING FOR DOS FILENAMES ") + + +(RPAQ? *DISPLAY-FONT-NAME-MAP* + '((TIMESROMAN . TR) + (HELVETICA . HV) + (TIMESROMAND . TD) + (HELVETICAD . HD) + (MODERN . MD) + (CLASSIC . CL) + (GACHA . GC) + (TITAN . TI) + (LETTERGOTHIC . LG) + (BOLDPS . BP) + (TERMINAL . TM) + (CLASSICTHIN . CT) + (HIPPO . HP) + (LOGO . LG) + (MATH . MA) + (OLDENGLISH . OE) + (SYMBOL . SY))) (DEFINEQ (\FONTRESETCHARWIDTHS @@ -3341,12 +3940,20 @@ (\FSETOFFSET offsets (ADD1 \MAXCHAR) dummycharoffset]) ) -(DECLARE%: DONTEVAL@LOAD +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DISPLAYCHARSETFNS) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQ? DISPLAYFONTDIRECTORIES NIL) -(RPAQ? DISPLAYFONTEXTENSIONS 'DISPLAYFONT) -(RPAQ? DISPLAYFONTDIRECTORIES '({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ - {dsk}/usr/local/lde/fonts/display/publishing/)) +(ADDTOVAR DISPLAYCHARSETFNS (STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET)) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT DISPLAYFONT) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE @@ -3364,17 +3971,10 @@ (PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE) (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) - of (\GETCHARSETINFO (\CHARSET CHARCODE) + of (\INSURECHARSETINFO (\CHARSET CHARCODE) FONT)) (\CHAR8CODE CHARCODE)))) -(PROGN (PUTPROPS \GETFONTDESC DMACRO [X (COND - ((CDR X) - (CONS '\COERCEFONTDESC X)) - (T `(\DTEST ,(CAR X) - 'FONTDESCRIPTOR]) - (PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC))) - (PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO) (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2) CSINFO))) @@ -3394,31 +3994,41 @@ (ADDTOVAR LAMA FONTCOPY) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (8870 18389 (CHARWIDTH 8880 . 9665) (CHARWIDTHY 9667 . 11037) (STRINGWIDTH 11039 . 12132 -) (\CHARWIDTH.DISPLAY 12134 . 12547) (\STRINGWIDTH.DISPLAY 12549 . 12973) (\STRINGWIDTH.GENERIC 12975 - . 18387)) (18390 24772 (DEFAULTFONT 18400 . 20233) (FONTCLASS 20235 . 22397) (FONTCLASSUNPARSE 22399 - . 23298) (FONTCLASSCOMPONENT 23300 . 23809) (SETFONTCLASSCOMPONENT 23811 . 24770)) (25446 38178 ( -FONTCREATE 25456 . 34723) (\FONT.SYMBOLMEMB 34725 . 34955) (\FONT.SYMBOLASSOC 34957 . 36115) ( -\FONT.COMPARESYMBOL 36117 . 38176)) (38217 42841 (FONTASCENT 38227 . 38395) (FONTDESCENT 38397 . 38666 -) (FONTHEIGHT 38668 . 38854) (FONTPROP 38856 . 42299) (\AVGCHARWIDTH 42301 . 42839)) (42888 55527 ( -GETCHARBITMAP 42898 . 45788) (PUTCHARBITMAP 45790 . 53847) (MOVECHARBITMAP 53849 . 55525)) (55528 -140067 (FONTCOPY 55538 . 60846) (FONTSAVAILABLE 60848 . 66053) (FONTFILEFORMAT 66055 . 67679) (FONTP -67681 . 67980) (FONTUNPARSE 67982 . 70546) (SETFONTDESCRIPTOR 70548 . 72257) (CHARCODEP 72259 . 72620) - (EDITCHAR 72622 . 73051) (\STREAMCHARWIDTH 73053 . 77217) (\UNITWIDTHSVECTOR 77219 . 77582) ( -\CREATEDISPLAYFONT 77584 . 78337) (\CREATECHARSET.DISPLAY 78339 . 81255) (\CREATE-REAL-CHARSET.DISPLAY - 81257 . 88161) (\BUILDSLUGCSINFO 88163 . 89606) (\SEARCHDISPLAYFONTFILES 89608 . 91541) ( -\SEARCHFONTFILES 91543 . 94854) (\FINDFONTFILE 94856 . 96047) (\FONTSYMBOL 96049 . 96699) ( -\DEVICESYMBOL 96701 . 97570) (\FONTFACE 97572 . 104762) (\FONTFACE.COLOR 104764 . 111684) ( -\FONTFILENAME 111686 . 115101) (\FONTFILENAME.OLD 115103 . 118052) (\FONTFILENAME.NEW 118054 . 120311) - (\FONTINFOFROMFILENAME 120313 . 123427) (\FONTINFOFROMFILENAME.OLD 123429 . 125706) (\GETFONTDESC -125708 . 126099) (\COERCEFONTDESC 126101 . 131486) (\LOOKUPFONT 131488 . 132832) (\LOOKUPFONTSINCORE -132834 . 134907) (\READDISPLAYFONTFILE 134909 . 140065)) (140970 157694 (\READSTRIKEFONTFILE 140980 . -145182) (\SFMAKEBOLD 145184 . 147580) (\SFMAKEITALIC 147582 . 150485) (\SFMAKEROTATEDFONT 150487 . -151888) (\SFROTATECSINFO 151890 . 152527) (\SFROTATEFONTCHARACTERS 152529 . 152909) ( -\SFFIXOFFSETSAFTERROTATION 152911 . 155050) (\SFROTATECSINFOOFFSETS 155052 . 156321) (\SFMAKECOLOR -156323 . 157692)) (157695 165057 (WRITESTRIKEFONTFILE 157705 . 161597) (STRIKECSINFO 161599 . 165055)) - (165058 166897 (FONTDESCRIPTOR.DEFPRINT 165068 . 166419) (FONTCLASS.DEFPRINT 166421 . 166895)) ( -182093 182415 (\CREATEKERNELEMENT 182093 . 182415)) (182417 182545 (\FSETLEFTKERN 182417 . 182545)) ( -182671 183718 (\FGETLEFTKERN 182681 . 183716)) (183762 187272 (\CREATECHARSET 183772 . 185523) ( -\INSTALLCHARSETINFO 185525 . 187270)) (188427 190179 (\FONTRESETCHARWIDTHS 188437 . 190177))))) + (FILEMAP (NIL (11262 20708 (CHARWIDTH 11272 . 12057) (CHARWIDTHY 12059 . 13532) (STRINGWIDTH 13534 . +14627) (\CHARWIDTH.DISPLAY 14629 . 15042) (\STRINGWIDTH.DISPLAY 15044 . 15468) (\STRINGWIDTH.GENERIC +15470 . 20706)) (20709 27229 (DEFAULTFONT 20719 . 22004) (FONTCLASS 22006 . 24168) (FONTCLASSUNPARSE +24170 . 25069) (FONTCLASSCOMPONENT 25071 . 25659) (SETFONTCLASSCOMPONENT 25661 . 26103) ( +GETFONTCLASSCOMPONENT 26105 . 27227)) (28959 53120 (FONTCREATE 28969 . 31552) (FONTCREATE1 31554 . +33547) (FONTCREATE.SLUGFD 33549 . 35165) (\FONT.CHECKARGS 35167 . 41194) (\FONT.CHECKARGS1 41196 . +45719) (\FONTCREATE1.NOFN 45721 . 45935) (FONTFILEP 45937 . 46716) (\READCHARSET 46718 . 50970) ( +\COERCEFONTSPEC 50972 . 53118)) (53121 54300 (\COERCEFONTDESC 53131 . 54298)) (54951 60242 ( +COMPLETE.FONT 54961 . 56942) (COMPLETEFONTP 56944 . 57459) (COMPLETE.CHARSET 57461 . 59628) ( +PRUNEFONTSLUGS 59630 . 60240)) (60281 67749 (FONTASCENT 60291 . 60675) (FONTDESCENT 60677 . 61162) ( +FONTHEIGHT 61164 . 61566) (FONTPROP 61568 . 67026) (\AVGCHARWIDTH 67028 . 67747)) (67796 68445 ( +EDITCHAR 67806 . 68443)) (68491 80057 (GETCHARBITMAP 68501 . 69323) (PUTCHARBITMAP 69325 . 71402) ( +\GETCHARBITMAP.CSINFO 71404 . 73311) (\PUTCHARBITMAP.CSINFO 73313 . 80055)) (80058 93233 ( +MOVECHARBITMAP 80068 . 81962) (MOVEFONTCHARS 81964 . 87336) (\MOVEFONTCHAR 87338 . 90845) ( +SLUGCHARP.DISPLAY 90847 . 91745) (\GETCHARINFO 91747 . 93231)) (94162 113415 (FONTFILES 94172 . 95641) + (\FINDFONTFILE 95643 . 97360) (\FONTFILENAMES 97362 . 98236) (\FONTFILENAME 98238 . 102221) ( +\FONTFILENAME.OLD 102223 . 105172) (\FONTFILENAME.NEW 105174 . 107431) (\FONTINFOFROMFILENAME 107433 + . 111134) (\FONTINFOFROMFILENAME.OLD 111136 . 113413)) (113682 148361 (FONTCOPY 113692 . 118755) ( +FONTP 118757 . 119056) (FONTUNPARSE 119058 . 121622) (SETFONTDESCRIPTOR 121624 . 122870) ( +\STREAMCHARWIDTH 122872 . 127036) (\UNITWIDTHSVECTOR 127038 . 127401) (\COERCECHARSET 127403 . 128857) + (\BUILDSLUGCSINFO 128859 . 131615) (\FONTSYMBOL 131617 . 132267) (\DEVICESYMBOL 132269 . 133138) ( +\FONTFACE 133140 . 140330) (\FONTFACE.COLOR 140332 . 147252) (SETFONTCHARENCODING 147254 . 148359)) ( +148362 163750 (FONTSAVAILABLE 148372 . 150317) (FONTEXISTS? 150319 . 154810) (\FONTSAVAILABLE.INCORE +154812 . 156360) (\SEARCHFONTFILES 156362 . 159390) (FLUSHFONTSINCORE 159392 . 160540) (MATCHFONTFACE +160542 . 161357) (FINDFONTFILES 161359 . 163748)) (163843 172559 (\CREATEDISPLAYFONT 163853 . 165449) +(\CREATECHARSET.DISPLAY 165451 . 171385) (\FONTEXISTS?.DISPLAY 171387 . 172557)) (172560 185761 ( +STRIKEFONT.FILEP 172570 . 173458) (STRIKEFONT.GETCHARSET 173460 . 178295) (WRITESTRIKEFONTFILE 178297 + . 182301) (STRIKECSINFO 182303 . 185759)) (185792 197502 (MAKEBOLD.CHARSET 185802 . 187633) ( +MAKEBOLD.CHAR 187635 . 188965) (MAKEITALIC.CHARSET 188967 . 190804) (MAKEITALIC.CHAR 190806 . 192839) +(\SFMAKEBOLD 192841 . 194847) (\SFMAKEITALIC 194849 . 197500)) (197503 201208 (\SFMAKEROTATEDFONT +197513 . 198914) (\SFROTATECSINFO 198916 . 199553) (\SFROTATEFONTCHARACTERS 199555 . 199935) ( +\SFROTATECSINFOOFFSETS 199937 . 201206)) (201209 202590 (\SFMAKECOLOR 201219 . 202588)) (202591 204658 + (FONTDESCRIPTOR.DEFPRINT 202601 . 204180) (FONTCLASS.DEFPRINT 204182 . 204656)) (225140 227684 ( +\CREATEKERNELEMENT 225150 . 225508) (\FSETLEFTKERN 225510 . 226001) (\FGETLEFTKERN 226003 . 227682)) ( +227685 234183 (\CREATEFONT 227695 . 228604) (\CREATECHARSET 228606 . 231242) (\INSTALLCHARSETINFO +231244 . 233270) (\INSTALLCHARSETINFO.CHARENCODING 233272 . 234181)) (236577 238329 ( +\FONTRESETCHARWIDTHS 236587 . 238327))))) STOP diff --git a/sources/FONT.LCOM b/sources/FONT.LCOM index 4f13ebbee..30747eeb5 100644 Binary files a/sources/FONT.LCOM and b/sources/FONT.LCOM differ diff --git a/sources/HARDCOPY b/sources/HARDCOPY index 9bebf4144..28bf7c316 100644 --- a/sources/HARDCOPY +++ b/sources/HARDCOPY @@ -1,10 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 6-Apr-2024 20:46:31" {WMEDLEY}HARDCOPY.;18 156634 +(FILECREATED "14-Jul-2025 23:00:56" {WMEDLEY}HARDCOPY.;20 156777 :EDIT-BY rmk - :PREVIOUS-DATE " 6-Mar-2024 13:15:30" {WMEDLEY}HARDCOPY.;16) + :CHANGES-TO (FNS \DSPFONT.HCPYMODE) + + :PREVIOUS-DATE " 5-Jul-2025 18:52:09" {WMEDLEY}HARDCOPY.;19) (PRETTYCOMPRINT HARDCOPYCOMS) @@ -1873,7 +1875,9 @@ (\DASHINGCONVERT.HCPYMODE DASHING]) (\DSPFONT.HCPYMODE - [LAMBDA (HDCPYDSTREAM FONT) (* ; "Edited 20-Apr-88 11:53 by jds") + [LAMBDA (HDCPYDSTREAM FONT) (* ; "Edited 14-Jul-2025 23:00 by rmk") + (* ; "Edited 5-Jul-2025 18:49 by rmk") + (* ; "Edited 20-Apr-88 11:53 by jds") (* ;; "changes the font of a hardcopy display stream. Does what the display does then puts the hardcopy widths where they can be found {FOR NOW USE THE DDCHARIMAGEWIDTHS FIELD}") @@ -1882,10 +1886,9 @@  "save old value to return, smash new value and update the bitchar portion of the record.") (RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD)) [COND - (FONT (SETQ XFONT (OR (\GETFONTDESC FONT (fetch IMFONTCREATE - of (fetch IMAGEOPS of - HDCPYDSTREAM - )) + (FONT (SETQ XFONT (OR (FONTCREATE FONT NIL NIL NIL + (fetch IMFONTCREATE + of (fetch IMAGEOPS of HDCPYDSTREAM)) T) (FONTCOPY (ffetch DDFONT of DD) FONT)))(* ; @@ -2516,40 +2519,40 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (6190 12028 (HARDCOPY.SOMEHOW 6200 . 7566) (HARDCOPYIMAGEW 7568 . 7789) ( -HARDCOPYIMAGEW.TOFILE 7791 . 8099) (HARDCOPYIMAGEW.TOPRINTER 8101 . 9348) (HARDCOPYREGION.TOFILE 9350 - . 9892) (HARDCOPYREGION.TOPRINTER 9894 . 11007) (COPY.WINDOW.TO.BITMAP 11009 . 12026)) (12100 23887 ( -MakeMenuOfPrinters 12110 . 13642) (PRINTERS.WHENSELECTEDFN 13644 . 15267) (MakeMenuOfImageTypes 15269 - . 16088) (GetNewPrinterFromUser 16090 . 16532) (PopUpWindowAndGetAtom 16534 . 17985) ( -PopUpWindowAndGetList 17987 . 19557) (NewPrinter 19559 . 21058) (GetPrinterName 21060 . 21348) ( -GetImageFile 21350 . 23635) (FetchDefaultPrinter 23637 . 23885)) (23922 24687 ( -ExtensionForPrintFileType 23932 . 24179) (PRINTFILETYPE.FROM.EXTENSION 24181 . 24685)) (24742 45126 ( -DEFAULTPRINTER 24752 . 24992) (CAN.PRINT.DIRECTLY 24994 . 25190) (CONVERT.FILE.TO.TYPE.FOR.PRINTER -25192 . 26929) (EMPRESS 26931 . 27506) (HARDCOPYW 27508 . 32510) (LISTFILES1 32512 . 32689) ( -PRINTER.BITMAPFILE 32691 . 33080) (PRINTER.BITMAPSCALE 33082 . 33566) (PRINTER.SCRATCH.FILE 33568 . -33738) (PRINTERPROP 33740 . 33990) (PRINTERSTATUS 33992 . 34267) (PRINTERTYPE 34269 . 36839) ( -PRINTERNAME 36841 . 37262) (PRINTFILEPROP 37264 . 37520) (PRINTFILETYPE 37522 . 39478) ( -\EXPECTED.FILE.TYPE 39480 . 40270) (SEND.FILE.TO.PRINTER 40272 . 45124)) (45127 49746 (PRINTERDEVICE -45137 . 49744)) (50581 58826 (TEXTTOIMAGEFILE 50591 . 52787) (COPY.TEXT.TO.IMAGE 52789 . 58824)) ( -58827 60570 (\BLTSHADE.GENERICPRINTER 58837 . 60568)) (60698 96699 (MAKEHARDCOPYSTREAM 60708 . 62260) -(UNMAKEHARDCOPYSTREAM 62262 . 63192) (HARDCOPYSTREAMTYPE 63194 . 63528) (\CHARWIDTH.HDCPYDISPLAY 63530 - . 64262) (\DSPFONT.HDCPYDISPLAY 64264 . 66976) (\DSPRIGHTMARGIN.HDCPYDISPLAY 66978 . 67734) ( -\DSPXPOSITION.HDCPYDISPLAY 67736 . 68111) (\DSPYPOSITION.HDCPYDISPLAY 68113 . 68488) ( -\STRINGWIDTH.HDCPYDISPLAY 68490 . 69357) (\STRINGWIDTH.HCPYDISPLAYAUX 69359 . 74581) (\HDCPYBLTCHAR -74583 . 79575) (\HDCPYDISPLAY.FIX.XPOS 79577 . 80235) (\HDCPYDISPLAY.FIX.YPOS 80237 . 80895) ( -\HDCPYDISPLAYINIT 80897 . 82490) (\HDCPYDSPPRINTCHAR 82492 . 88405) (\SLOWHDCPYBLTCHAR 88407 . 94911) -(\CHANGECHARSET.HDCPYDISPLAY 94913 . 96697)) (97200 97341 (\MICASTOPTS 97200 . 97341)) (97512 156070 ( -MAKEHARDCOPYMODESTREAM 97522 . 100555) (UNMAKEHARDCOPYMODESTREAM 100557 . 102318) (\BLTSHADE.HCPYMODE -102320 . 102986) (\BITBLT.HCPYMODE 102988 . 103736) (\BRUSHCONVERT.HCPYMODE 103738 . 104287) ( -\CHANGECHARSET.HCPYMODE 104289 . 107384) (\DASHINGCONVERT.HCPYMODE 107386 . 107727) ( -\CHARWIDTH.HCPYMODE 107729 . 108166) (\DRAWLINE.HCPYMODE 108168 . 108697) (\DRAWCURVE.HCPYMODE 108699 - . 109286) (\DRAWCIRCLE.HCPYMODE 109288 . 109773) (\DRAWELLIPSE.HCPYMODE 109775 . 110459) ( -\DSPFONT.HCPYMODE 110461 . 113045) (\DSPLEFTMARGIN.HCPYMODE 113047 . 113789) (\DSPLINEFEED.HCPYMODE -113791 . 114424) (\DSPRIGHTMARGIN.HCPYMODE 114426 . 115494) (\DSPSPACEFACTOR.HCPYMODE 115496 . 116271) - (\DSPXPOSITION.HCPYMODE 116273 . 117291) (\DSPYPOSITION.HCPYMODE 117293 . 117943) (\MOVETO.HCPYMODE -117945 . 118159) (\FONTCREATE.HCPYMODE.PRESS 118161 . 120298) (\CREATECHARSET.HCPYMODE.PRESS 120300 . -121922) (\FONTCREATE.HCPYMODE.INTERPRESS 121924 . 123998) (\CREATECHARSET.HCPYMODE.INTERPRESS 124000 - . 125522) (\STRINGWIDTH.HCPYMODE 125524 . 126231) (\HCPYMODEBLTCHAR 126233 . 131983) ( -\HCPYMODEDISPLAYINIT 131985 . 140117) (\HCPYMODEDSPPRINTCHAR 140119 . 146053) (\SLOWHCPYMODEBLTCHAR -146055 . 152572) (\SFFixY.HCPYMODE 152574 . 156068))))) + (FILEMAP (NIL (6233 12071 (HARDCOPY.SOMEHOW 6243 . 7609) (HARDCOPYIMAGEW 7611 . 7832) ( +HARDCOPYIMAGEW.TOFILE 7834 . 8142) (HARDCOPYIMAGEW.TOPRINTER 8144 . 9391) (HARDCOPYREGION.TOFILE 9393 + . 9935) (HARDCOPYREGION.TOPRINTER 9937 . 11050) (COPY.WINDOW.TO.BITMAP 11052 . 12069)) (12143 23930 ( +MakeMenuOfPrinters 12153 . 13685) (PRINTERS.WHENSELECTEDFN 13687 . 15310) (MakeMenuOfImageTypes 15312 + . 16131) (GetNewPrinterFromUser 16133 . 16575) (PopUpWindowAndGetAtom 16577 . 18028) ( +PopUpWindowAndGetList 18030 . 19600) (NewPrinter 19602 . 21101) (GetPrinterName 21103 . 21391) ( +GetImageFile 21393 . 23678) (FetchDefaultPrinter 23680 . 23928)) (23965 24730 ( +ExtensionForPrintFileType 23975 . 24222) (PRINTFILETYPE.FROM.EXTENSION 24224 . 24728)) (24785 45169 ( +DEFAULTPRINTER 24795 . 25035) (CAN.PRINT.DIRECTLY 25037 . 25233) (CONVERT.FILE.TO.TYPE.FOR.PRINTER +25235 . 26972) (EMPRESS 26974 . 27549) (HARDCOPYW 27551 . 32553) (LISTFILES1 32555 . 32732) ( +PRINTER.BITMAPFILE 32734 . 33123) (PRINTER.BITMAPSCALE 33125 . 33609) (PRINTER.SCRATCH.FILE 33611 . +33781) (PRINTERPROP 33783 . 34033) (PRINTERSTATUS 34035 . 34310) (PRINTERTYPE 34312 . 36882) ( +PRINTERNAME 36884 . 37305) (PRINTFILEPROP 37307 . 37563) (PRINTFILETYPE 37565 . 39521) ( +\EXPECTED.FILE.TYPE 39523 . 40313) (SEND.FILE.TO.PRINTER 40315 . 45167)) (45170 49789 (PRINTERDEVICE +45180 . 49787)) (50624 58869 (TEXTTOIMAGEFILE 50634 . 52830) (COPY.TEXT.TO.IMAGE 52832 . 58867)) ( +58870 60613 (\BLTSHADE.GENERICPRINTER 58880 . 60611)) (60741 96742 (MAKEHARDCOPYSTREAM 60751 . 62303) +(UNMAKEHARDCOPYSTREAM 62305 . 63235) (HARDCOPYSTREAMTYPE 63237 . 63571) (\CHARWIDTH.HDCPYDISPLAY 63573 + . 64305) (\DSPFONT.HDCPYDISPLAY 64307 . 67019) (\DSPRIGHTMARGIN.HDCPYDISPLAY 67021 . 67777) ( +\DSPXPOSITION.HDCPYDISPLAY 67779 . 68154) (\DSPYPOSITION.HDCPYDISPLAY 68156 . 68531) ( +\STRINGWIDTH.HDCPYDISPLAY 68533 . 69400) (\STRINGWIDTH.HCPYDISPLAYAUX 69402 . 74624) (\HDCPYBLTCHAR +74626 . 79618) (\HDCPYDISPLAY.FIX.XPOS 79620 . 80278) (\HDCPYDISPLAY.FIX.YPOS 80280 . 80938) ( +\HDCPYDISPLAYINIT 80940 . 82533) (\HDCPYDSPPRINTCHAR 82535 . 88448) (\SLOWHDCPYBLTCHAR 88450 . 94954) +(\CHANGECHARSET.HDCPYDISPLAY 94956 . 96740)) (97243 97384 (\MICASTOPTS 97243 . 97384)) (97555 156213 ( +MAKEHARDCOPYMODESTREAM 97565 . 100598) (UNMAKEHARDCOPYMODESTREAM 100600 . 102361) (\BLTSHADE.HCPYMODE +102363 . 103029) (\BITBLT.HCPYMODE 103031 . 103779) (\BRUSHCONVERT.HCPYMODE 103781 . 104330) ( +\CHANGECHARSET.HCPYMODE 104332 . 107427) (\DASHINGCONVERT.HCPYMODE 107429 . 107770) ( +\CHARWIDTH.HCPYMODE 107772 . 108209) (\DRAWLINE.HCPYMODE 108211 . 108740) (\DRAWCURVE.HCPYMODE 108742 + . 109329) (\DRAWCIRCLE.HCPYMODE 109331 . 109816) (\DRAWELLIPSE.HCPYMODE 109818 . 110502) ( +\DSPFONT.HCPYMODE 110504 . 113188) (\DSPLEFTMARGIN.HCPYMODE 113190 . 113932) (\DSPLINEFEED.HCPYMODE +113934 . 114567) (\DSPRIGHTMARGIN.HCPYMODE 114569 . 115637) (\DSPSPACEFACTOR.HCPYMODE 115639 . 116414) + (\DSPXPOSITION.HCPYMODE 116416 . 117434) (\DSPYPOSITION.HCPYMODE 117436 . 118086) (\MOVETO.HCPYMODE +118088 . 118302) (\FONTCREATE.HCPYMODE.PRESS 118304 . 120441) (\CREATECHARSET.HCPYMODE.PRESS 120443 . +122065) (\FONTCREATE.HCPYMODE.INTERPRESS 122067 . 124141) (\CREATECHARSET.HCPYMODE.INTERPRESS 124143 + . 125665) (\STRINGWIDTH.HCPYMODE 125667 . 126374) (\HCPYMODEBLTCHAR 126376 . 132126) ( +\HCPYMODEDISPLAYINIT 132128 . 140260) (\HCPYMODEDSPPRINTCHAR 140262 . 146196) (\SLOWHCPYMODEBLTCHAR +146198 . 152715) (\SFFixY.HCPYMODE 152717 . 156211))))) STOP diff --git a/sources/HARDCOPY.LCOM b/sources/HARDCOPY.LCOM index 05e2ddb91..f8dc7103c 100644 Binary files a/sources/HARDCOPY.LCOM and b/sources/HARDCOPY.LCOM differ diff --git a/sources/IMAGEIO b/sources/IMAGEIO index 77770c5a5..cbe9b83a7 100644 --- a/sources/IMAGEIO +++ b/sources/IMAGEIO @@ -1,13 +1,15 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 8-Dec-2023 21:42:20" {WMEDLEY}IMAGEIO.;8 79284 +(FILECREATED "21-Jun-2025 11:48:01" {WMEDLEY}IMAGEIO.;11 79830 :EDIT-BY rmk - :CHANGES-TO (FNS \IMAGEIOINIT) - (RECORDS IMAGEOPS) + :CHANGES-TO (ALISTS (IMAGESTREAMTYPES DISPLAY) + (IMAGESTREAMTYPES 4DISPLAY) + (IMAGESTREAMTYPES 8DISPLAY) + (IMAGESTREAMTYPES 24DISPLAY)) - :PREVIOUS-DATE "30-Oct-2021 19:09:48" {WMEDLEY}IMAGEIO.;7) + :PREVIOUS-DATE "15-Jun-2025 20:46:26" {WMEDLEY}IMAGEIO.;10) (PRETTYCOMPRINT IMAGEIOCOMS) @@ -1472,16 +1474,24 @@ (ADDTOVAR IMAGESTREAMTYPES (DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) - (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)) + (FONTSAVAILABLE \SEARCHFONTFILES) + (CREATECHARSET \CREATECHARSET.DISPLAY) + (FONTEXISTS? \FONTEXISTS?.DISPLAY)) (4DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) - (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)) + (FONTSAVAILABLE \SEARCHFONTFILES) + (CREATECHARSET \CREATECHARSET.DISPLAY) + (FONTEXISTS? \FONTEXISTS?.DISPLAY)) (8DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) - (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)) + (FONTSAVAILABLE \SEARCHFONTFILES) + (CREATECHARSET \CREATECHARSET.DISPLAY) + (FONTEXISTS? \FONTEXISTS?.DISPLAY)) (24DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) - (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES))) + (FONTSAVAILABLE \SEARCHFONTFILES) + (CREATECHARSET \CREATECHARSET.DISPLAY) + (FONTEXISTS? \FONTEXISTS?.DISPLAY))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DisplayFDEV \4DISPLAYFDEV \8DISPLAYFDEV \24DISPLAYFDEV) @@ -1505,24 +1515,24 @@ (ADDTOVAR LAMA IMAGESTREAMP) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3234 11991 (IMAGESTREAMP 3244 . 4076) (IMAGESTREAMTYPE 4078 . 4291) (IMAGESTREAMTYPEP -4293 . 4928) (OPENIMAGESTREAM 4930 . 9884) (\GOOD.DASHLST 9886 . 11989)) (12026 14323 (DRAWDASHEDLINE -12036 . 14321)) (14324 21664 (DSPBACKCOLOR 14334 . 14706) (DSPBOTTOMMARGIN 14708 . 15093) (DSPCOLOR -15095 . 15459) (DSPCLIPPINGREGION 15461 . 16166) (DSPRESET 16168 . 16448) (DSPFONT 16450 . 16814) ( -DSPLEFTMARGIN 16816 . 17197) (DSPLINEFEED 17199 . 17499) (DSPOPERATION 17501 . 17878) (DSPRIGHTMARGIN -17880 . 18263) (DSPTOPMARGIN 18265 . 18644) (DSPSCALE 18646 . 19013) (DSPSPACEFACTOR 19015 . 19408) ( -DSPXPOSITION 19410 . 19715) (DSPYPOSITION 19717 . 20022) (DSPROTATE 20024 . 20319) (DSPPUSHSTATE 20321 - . 20567) (DSPPOPSTATE 20569 . 20812) (DSPDEFAULTSTATE 20814 . 21066) (DSPSCALE2 21068 . 21359) ( -DSPTRANSLATE 21361 . 21662)) (21665 30466 (DSPNEWPAGE 21675 . 22367) (DRAWBETWEEN 22369 . 23071) ( -DRAWCIRCLE 23073 . 23569) (DRAWARC 23571 . 24088) (DRAWCURVE 24090 . 24767) (DRAWELLIPSE 24769 . 25555 -) (DRAWLINE 25557 . 25947) (DRAWPOLYGON 25949 . 26404) (DRAWPOINT 26406 . 26825) (FILLPOLYGON 26827 . -27393) (DRAWTO 27395 . 27813) (FILLCIRCLE 27815 . 28038) (MOVETO 28040 . 28404) (RELDRAWTO 28406 . -29323) (BITMAPIMAGESIZE 29325 . 29496) (SCALEDBITBLT 29498 . 30464)) (30467 37506 (\DRAWPOINT.GENERIC -30477 . 30824) (\DRAWPOLYGON.GENERIC 30826 . 33134) (\DRAWCIRCLE.GENERIC 33136 . 34794) ( -\DRAWELLIPSE.GENERIC 34796 . 37504)) (37507 42451 (\IMAGEIOINIT 37517 . 40797) (\NOIMAGE.DSPFONT 40799 - . 42285) (\UNIMPIMAGEOP 42287 . 42449)) (42574 45698 (INSURE.BRUSH 42584 . 43958) (BRUSHP 43960 . -44750) (\POSSIBLECOLOR 44752 . 45303) (NEGSHADE 45305 . 45696)) (46254 46938 (DASHINGP 46264 . 46594) -(INSURE.DASHING 46596 . 46936)) (57676 78222 (\DisplayEventFn 57686 . 58196) (\DISPLAYINIT 58198 . -63781) (\4DISPLAYINIT 63783 . 68484) (\8DISPLAYINIT 68486 . 73189) (\24DISPLAYINIT 73191 . 77963) ( -\DISPLAYSTREAMTYPEBPP 77965 . 78220))))) + (FILEMAP (NIL (3376 12133 (IMAGESTREAMP 3386 . 4218) (IMAGESTREAMTYPE 4220 . 4433) (IMAGESTREAMTYPEP +4435 . 5070) (OPENIMAGESTREAM 5072 . 10026) (\GOOD.DASHLST 10028 . 12131)) (12168 14465 ( +DRAWDASHEDLINE 12178 . 14463)) (14466 21806 (DSPBACKCOLOR 14476 . 14848) (DSPBOTTOMMARGIN 14850 . +15235) (DSPCOLOR 15237 . 15601) (DSPCLIPPINGREGION 15603 . 16308) (DSPRESET 16310 . 16590) (DSPFONT +16592 . 16956) (DSPLEFTMARGIN 16958 . 17339) (DSPLINEFEED 17341 . 17641) (DSPOPERATION 17643 . 18020) +(DSPRIGHTMARGIN 18022 . 18405) (DSPTOPMARGIN 18407 . 18786) (DSPSCALE 18788 . 19155) (DSPSPACEFACTOR +19157 . 19550) (DSPXPOSITION 19552 . 19857) (DSPYPOSITION 19859 . 20164) (DSPROTATE 20166 . 20461) ( +DSPPUSHSTATE 20463 . 20709) (DSPPOPSTATE 20711 . 20954) (DSPDEFAULTSTATE 20956 . 21208) (DSPSCALE2 +21210 . 21501) (DSPTRANSLATE 21503 . 21804)) (21807 30608 (DSPNEWPAGE 21817 . 22509) (DRAWBETWEEN +22511 . 23213) (DRAWCIRCLE 23215 . 23711) (DRAWARC 23713 . 24230) (DRAWCURVE 24232 . 24909) ( +DRAWELLIPSE 24911 . 25697) (DRAWLINE 25699 . 26089) (DRAWPOLYGON 26091 . 26546) (DRAWPOINT 26548 . +26967) (FILLPOLYGON 26969 . 27535) (DRAWTO 27537 . 27955) (FILLCIRCLE 27957 . 28180) (MOVETO 28182 . +28546) (RELDRAWTO 28548 . 29465) (BITMAPIMAGESIZE 29467 . 29638) (SCALEDBITBLT 29640 . 30606)) (30609 +37648 (\DRAWPOINT.GENERIC 30619 . 30966) (\DRAWPOLYGON.GENERIC 30968 . 33276) (\DRAWCIRCLE.GENERIC +33278 . 34936) (\DRAWELLIPSE.GENERIC 34938 . 37646)) (37649 42593 (\IMAGEIOINIT 37659 . 40939) ( +\NOIMAGE.DSPFONT 40941 . 42427) (\UNIMPIMAGEOP 42429 . 42591)) (42716 45840 (INSURE.BRUSH 42726 . +44100) (BRUSHP 44102 . 44892) (\POSSIBLECOLOR 44894 . 45445) (NEGSHADE 45447 . 45838)) (46396 47080 ( +DASHINGP 46406 . 46736) (INSURE.DASHING 46738 . 47078)) (57818 78364 (\DisplayEventFn 57828 . 58338) ( +\DISPLAYINIT 58340 . 63923) (\4DISPLAYINIT 63925 . 68626) (\8DISPLAYINIT 68628 . 73331) ( +\24DISPLAYINIT 73333 . 78105) (\DISPLAYSTREAMTYPEBPP 78107 . 78362))))) STOP diff --git a/sources/IMAGEIO.LCOM b/sources/IMAGEIO.LCOM index 8a1433603..572b20320 100644 Binary files a/sources/IMAGEIO.LCOM and b/sources/IMAGEIO.LCOM differ diff --git a/sources/INTERPRESS b/sources/INTERPRESS index 923628fe6..86f6a0d31 100644 --- a/sources/INTERPRESS +++ b/sources/INTERPRESS @@ -1,13 +1,16 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "21-Dec-2024 19:05:30" {WMEDLEY}INTERPRESS.;44 220448 +(FILECREATED "14-Jul-2025 23:31:04"  +{DSK}kaplan>Local>medley3.5>git-medley>sources>INTERPRESS.;11 220765 :EDIT-BY rmk - :CHANGES-TO (VARS \ASCII2XCCSMAP INTERPRESSCOMS) - (FNS \ASCIIMAPARRAY \ASCIITONS \ASCII2XCCS \ASCII2MCCS \CREATEINTERPRESSFONT) + :CHANGES-TO (VARS INTERPRESSCOMS \SYMBOLTONSARRAY HIPPOTONSARRAY CYRILLICTONSARRAY + \MATHTONSARRAY) + (FNS \DSPFONT.IP) - :PREVIOUS-DATE "20-Dec-2024 13:43:13" {WMEDLEY}INTERPRESS.;36) + :PREVIOUS-DATE "13-Jul-2025 23:11:52" +{DSK}kaplan>Local>medley3.5>git-medley>sources>INTERPRESS.;10) (PRETTYCOMPRINT INTERPRESSCOMS) @@ -2618,7 +2621,9 @@ ]) (\DSPFONT.IP - [LAMBDA (IPSTREAM FONT) (* ; "Edited 2-May-2023 08:38 by lmm") + [LAMBDA (IPSTREAM FONT) (* ; "Edited 14-Jul-2025 23:30 by rmk") + (* ; "Edited 13-Jul-2025 23:10 by rmk") + (* ; "Edited 2-May-2023 08:38 by lmm") (* ; "Edited 21-Aug-91 16:33 by jds") (* ;; "Change fonts (or return the current font) for an IP stream") @@ -2630,7 +2635,7 @@ (SHOW.IP IPSTREAM) (* ;  "ALWAYS do the show, so that font changes force recomputation of the exact position in the printer.") (COND - ([EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT 'INTERPRESS) + ([EQ OLDFONT (SETQ FONT (OR (FONTCREATE FONT NIL NIL NIL 'INTERPRESS) (FONTCOPY OLDFONT FONT] (* ;  "There was no change, or he was only asking for the old font. Just return it.") @@ -3903,45 +3908,45 @@ (LOADDEF 'BRUSH 'RECORDS 'IMAGEIO) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (15741 16594 (\IPC 15741 . 16594)) (16827 22479 (APPENDBYTE.IP 16837 . 16973) ( -APPENDIDENTIFIER.IP 16975 . 17497) (APPENDINT.IP 17499 . 17950) (APPENDINTEGER.IP 17952 . 18524) ( -APPENDLARGEVECTOR.IP 18526 . 19491) (APPENDNUMBER.IP 19493 . 19962) (APPENDOP.IP 19964 . 20610) ( -APPENDRATIONAL.IP 20612 . 21105) (APPENDSEQUENCEDESCRIPTOR.IP 21107 . 22302) (BYTESININT.IP 22304 . -22477)) (22515 62322 (ARCTO.IP 22525 . 23806) (BEGINMASTER.IP 23808 . 24081) (BEGINPAGE.IP 24083 . -24439) (BEGINPREAMBLE.IP 24441 . 24812) (CLIPRECTANGLE.IP 24814 . 25304) (CONCAT.IP 25306 . 25571) ( -CONCATT.IP 25573 . 25840) (ENDMASTER.IP 25842 . 26286) (ENDPAGE.IP 26288 . 26665) (ENDPREAMBLE.IP -26667 . 27466) (FGET.IP 27468 . 27771) (FILLRECTANGLE.IP 27773 . 30101) (FILLTRAJECTORY.IP 30103 . -30738) (FILLNGON.IP 30740 . 33017) (FSET.IP 33019 . 33322) (GETFRAMEVAR.IP 33324 . 33642) ( -INITIALIZEMASTER.IP 33644 . 34245) (INITIALIZECOLOR.IP 34247 . 35568) (ISET.IP 35570 . 35941) ( -GETCP.IP 35943 . 36252) (LINETO.IP 36254 . 36859) (MASKSTROKE.IP 36861 . 37134) (MOVETO.IP 37136 . -37473) (ROTATE.IP 37475 . 37777) (SCALE.IP 37779 . 38082) (SCALE2.IP 38084 . 38421) (SETCOLOR.IP 38423 - . 40652) (SETRGB.IP 40654 . 41710) (SETCOLORLV.IP 41712 . 46325) (SETCOLOR16.IP 46327 . 49433) ( -SETFONT.IP 49435 . 50256) (SETSPACE.IP 50258 . 50570) (SETXREL.IP 50572 . 51756) (SETX.IP 51758 . -53275) (SETXY.IP 53277 . 54449) (SETXYREL.IP 54451 . 55757) (SETY.IP 55759 . 57068) (SETYREL.IP 57070 - . 57970) (SHOW.IP 57972 . 61232) (TRAJECTORY.IP 61234 . 61632) (TRANS.IP 61634 . 61973) (TRANSLATE.IP - 61975 . 62320)) (62353 68443 (\CHANGE-VISIBLE-REGION.IP 62363 . 66024) (\PAPERSIZE.IP 66026 . 66847) -(HEADINGOP.IP 66849 . 68441)) (68444 173454 (DEFINEFONT.IP 68454 . 69428) (FONTNAME.IP 69430 . 70360) -(INTERPRESS.BITMAPSCALE 70362 . 71171) (INTERPRESS.OUTCHARFN 71173 . 77345) (INTERPRESSFILEP 77347 . -78681) (MAKEINTERPRESS 78683 . 78867) (NEWLINE.IP 78869 . 79601) (NEWPAGE.IP 79603 . 84578) ( -NEWPAGE?.IP 84580 . 85059) (OPENIPSTREAM 85061 . 93412) (SETUPFONTS.IP 93414 . 94406) (SHOWBITMAP.IP -94408 . 98949) (\BITMAPSIZE.IP 98951 . 99728) (SHOWBITMAP1.IP 99730 . 104102) (SHOWSHADE.IP 104104 . -105057) (\BITBLT.IP 105059 . 109263) (\SCALEDBITBLT.IP 109265 . 112910) (\BLTSHADE.IP 112912 . 114370) - (\CHARWIDTH.IP 114372 . 114822) (\CLOSEIPSTREAM 114824 . 115151) (\DRAWARC.IP 115153 . 115600) ( -\DRAWCURVE.IP 115602 . 118039) (\DRAWPOINT.IP 118041 . 119078) (\DSPCOLOR.IP 119080 . 120031) ( -ENSURE.RGB 120033 . 120697) (\IPCURVE2 120699 . 133953) (\CLIPCURVELINE.IP 133955 . 138653) ( -\DRAWLINE.IP 138655 . 142387) (\CLIPLINE 142389 . 147089) (\DSPBOTTOMMARGIN.IP 147091 . 147507) ( -\DSPFONT.IP 147509 . 151556) (\DSPLEFTMARGIN.IP 151558 . 152018) (\DSPLINEFEED.IP 152020 . 152687) ( -\DSPRIGHTMARGIN.IP 152689 . 153486) (\DSPSPACEFACTOR.IP 153488 . 154617) (\DSPTOPMARGIN.IP 154619 . -155055) (\DSPXPOSITION.IP 155057 . 156044) (\DSPROTATE.IP 156046 . 156224) (\PUSHSTATE.IP 156226 . -157118) (\POPSTATE.IP 157120 . 157755) (\DEFAULTSTATE.IP 157757 . 158109) (\DSPTRANSLATE.IP 158111 . -158292) (\DSPSCALE2.IP 158294 . 158469) (\DSPYPOSITION.IP 158471 . 158772) (FILLCIRCLE.IP 158774 . -159857) (\FILLPOLYGON.IP 159859 . 161190) (\DRAWPOLYGON.IP 161192 . 167322) (\FIXLINELENGTH.IP 167324 - . 168538) (\MOVETO.IP 168540 . 168904) (\SETBRUSH.IP 168906 . 171072) (\STRINGWIDTH.IP 171074 . -171477) (\DSPCLIPPINGREGION.IP 171479 . 172655) (\DSPOPERATION.IP 172657 . 173452)) (173645 174400 ( -IP-TOS 173655 . 173915) (POP-IP-STACK 173917 . 174212) (PUSH-IP-STACK 174214 . 174398)) (174461 187025 - (\CREATECHARSET.IP 174471 . 186262) (\CHANGECHARSET.IP 186264 . 187023)) (187026 190646 ( -\INTERPRESSINIT 187036 . 190644)) (190647 191205 (SCALEREGION 190657 . 191203)) (204133 206557 ( -INTERPRESSBITMAP 204143 . 206555)) (208765 214180 (\COERCEASCIITONSFONT 208775 . 212264) ( -\CREATEINTERPRESSFONT 212266 . 213839) (\SEARCHINTERPRESSFONTS 213841 . 214178)) (219195 220126 ( -\ASCIIMAPARRAY 219205 . 220124))))) + (FILEMAP (NIL (15830 16683 (\IPC 15830 . 16683)) (16916 22568 (APPENDBYTE.IP 16926 . 17062) ( +APPENDIDENTIFIER.IP 17064 . 17586) (APPENDINT.IP 17588 . 18039) (APPENDINTEGER.IP 18041 . 18613) ( +APPENDLARGEVECTOR.IP 18615 . 19580) (APPENDNUMBER.IP 19582 . 20051) (APPENDOP.IP 20053 . 20699) ( +APPENDRATIONAL.IP 20701 . 21194) (APPENDSEQUENCEDESCRIPTOR.IP 21196 . 22391) (BYTESININT.IP 22393 . +22566)) (22604 62411 (ARCTO.IP 22614 . 23895) (BEGINMASTER.IP 23897 . 24170) (BEGINPAGE.IP 24172 . +24528) (BEGINPREAMBLE.IP 24530 . 24901) (CLIPRECTANGLE.IP 24903 . 25393) (CONCAT.IP 25395 . 25660) ( +CONCATT.IP 25662 . 25929) (ENDMASTER.IP 25931 . 26375) (ENDPAGE.IP 26377 . 26754) (ENDPREAMBLE.IP +26756 . 27555) (FGET.IP 27557 . 27860) (FILLRECTANGLE.IP 27862 . 30190) (FILLTRAJECTORY.IP 30192 . +30827) (FILLNGON.IP 30829 . 33106) (FSET.IP 33108 . 33411) (GETFRAMEVAR.IP 33413 . 33731) ( +INITIALIZEMASTER.IP 33733 . 34334) (INITIALIZECOLOR.IP 34336 . 35657) (ISET.IP 35659 . 36030) ( +GETCP.IP 36032 . 36341) (LINETO.IP 36343 . 36948) (MASKSTROKE.IP 36950 . 37223) (MOVETO.IP 37225 . +37562) (ROTATE.IP 37564 . 37866) (SCALE.IP 37868 . 38171) (SCALE2.IP 38173 . 38510) (SETCOLOR.IP 38512 + . 40741) (SETRGB.IP 40743 . 41799) (SETCOLORLV.IP 41801 . 46414) (SETCOLOR16.IP 46416 . 49522) ( +SETFONT.IP 49524 . 50345) (SETSPACE.IP 50347 . 50659) (SETXREL.IP 50661 . 51845) (SETX.IP 51847 . +53364) (SETXY.IP 53366 . 54538) (SETXYREL.IP 54540 . 55846) (SETY.IP 55848 . 57157) (SETYREL.IP 57159 + . 58059) (SHOW.IP 58061 . 61321) (TRAJECTORY.IP 61323 . 61721) (TRANS.IP 61723 . 62062) (TRANSLATE.IP + 62064 . 62409)) (62442 68532 (\CHANGE-VISIBLE-REGION.IP 62452 . 66113) (\PAPERSIZE.IP 66115 . 66936) +(HEADINGOP.IP 66938 . 68530)) (68533 173771 (DEFINEFONT.IP 68543 . 69517) (FONTNAME.IP 69519 . 70449) +(INTERPRESS.BITMAPSCALE 70451 . 71260) (INTERPRESS.OUTCHARFN 71262 . 77434) (INTERPRESSFILEP 77436 . +78770) (MAKEINTERPRESS 78772 . 78956) (NEWLINE.IP 78958 . 79690) (NEWPAGE.IP 79692 . 84667) ( +NEWPAGE?.IP 84669 . 85148) (OPENIPSTREAM 85150 . 93501) (SETUPFONTS.IP 93503 . 94495) (SHOWBITMAP.IP +94497 . 99038) (\BITMAPSIZE.IP 99040 . 99817) (SHOWBITMAP1.IP 99819 . 104191) (SHOWSHADE.IP 104193 . +105146) (\BITBLT.IP 105148 . 109352) (\SCALEDBITBLT.IP 109354 . 112999) (\BLTSHADE.IP 113001 . 114459) + (\CHARWIDTH.IP 114461 . 114911) (\CLOSEIPSTREAM 114913 . 115240) (\DRAWARC.IP 115242 . 115689) ( +\DRAWCURVE.IP 115691 . 118128) (\DRAWPOINT.IP 118130 . 119167) (\DSPCOLOR.IP 119169 . 120120) ( +ENSURE.RGB 120122 . 120786) (\IPCURVE2 120788 . 134042) (\CLIPCURVELINE.IP 134044 . 138742) ( +\DRAWLINE.IP 138744 . 142476) (\CLIPLINE 142478 . 147178) (\DSPBOTTOMMARGIN.IP 147180 . 147596) ( +\DSPFONT.IP 147598 . 151873) (\DSPLEFTMARGIN.IP 151875 . 152335) (\DSPLINEFEED.IP 152337 . 153004) ( +\DSPRIGHTMARGIN.IP 153006 . 153803) (\DSPSPACEFACTOR.IP 153805 . 154934) (\DSPTOPMARGIN.IP 154936 . +155372) (\DSPXPOSITION.IP 155374 . 156361) (\DSPROTATE.IP 156363 . 156541) (\PUSHSTATE.IP 156543 . +157435) (\POPSTATE.IP 157437 . 158072) (\DEFAULTSTATE.IP 158074 . 158426) (\DSPTRANSLATE.IP 158428 . +158609) (\DSPSCALE2.IP 158611 . 158786) (\DSPYPOSITION.IP 158788 . 159089) (FILLCIRCLE.IP 159091 . +160174) (\FILLPOLYGON.IP 160176 . 161507) (\DRAWPOLYGON.IP 161509 . 167639) (\FIXLINELENGTH.IP 167641 + . 168855) (\MOVETO.IP 168857 . 169221) (\SETBRUSH.IP 169223 . 171389) (\STRINGWIDTH.IP 171391 . +171794) (\DSPCLIPPINGREGION.IP 171796 . 172972) (\DSPOPERATION.IP 172974 . 173769)) (173962 174717 ( +IP-TOS 173972 . 174232) (POP-IP-STACK 174234 . 174529) (PUSH-IP-STACK 174531 . 174715)) (174778 187342 + (\CREATECHARSET.IP 174788 . 186579) (\CHANGECHARSET.IP 186581 . 187340)) (187343 190963 ( +\INTERPRESSINIT 187353 . 190961)) (190964 191522 (SCALEREGION 190974 . 191520)) (204450 206874 ( +INTERPRESSBITMAP 204460 . 206872)) (209082 214497 (\COERCEASCIITONSFONT 209092 . 212581) ( +\CREATEINTERPRESSFONT 212583 . 214156) (\SEARCHINTERPRESSFONTS 214158 . 214495)) (219512 220443 ( +\ASCIIMAPARRAY 219522 . 220441))))) STOP diff --git a/sources/INTERPRESS.LCOM b/sources/INTERPRESS.LCOM index 3d1bad66a..cc4a8f51f 100644 Binary files a/sources/INTERPRESS.LCOM and b/sources/INTERPRESS.LCOM differ diff --git a/sources/LLREAD b/sources/LLREAD index 2f5dbff98..85a336b33 100644 --- a/sources/LLREAD +++ b/sources/LLREAD @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 8-Mar-2025 09:05:43" {WMEDLEY}LLREAD.;107 90353 +(FILECREATED "13-Jun-2025 16:34:10" {WMEDLEY}LLREAD.;112 95152 :EDIT-BY rmk :CHANGES-TO (VARS LLREADCOMS) - :PREVIOUS-DATE "30-Jul-2023 17:42:27" {WMEDLEY}LLREAD.;105) + :PREVIOUS-DATE "12-Jun-2025 10:02:38" {WMEDLEY}LLREAD.;111) (PRETTYCOMPRINT LLREADCOMS) @@ -31,7 +31,7 @@ (FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER)) (COMS (* ; "Reading characters with #\") - (FNS CHARACTER.READ CHARCODE.DECODE) + (FNS CHARACTER.READ CHARCODE.DECODE CHARCODE.ENCODE CHARCODEP) (FNS HEXNUM? OCTALNUM?) (ALISTS (CHARACTERNAMES Page Form FF Rubout Del Null Escape Esc Bell Tab Backspace Bs Newline CR EOL Return Tenexeol Space Sp Linefeed LF Zero One Two Three @@ -1386,17 +1386,18 @@ (READ-EXTENDED-TOKEN STREAM]) (CHARCODE.DECODE - [LAMBDA (C NOERROR) (* ; "Edited 24-Aug-2021 10:03 by rmk:") - (* ; "Edited 18-Feb-87 22:03 by bvm:") + [LAMBDA (C NOERROR) (* ; "Edited 25-Apr-2025 11:14 by rmk") + (* ; "Edited 24-Aug-2021 10:03 by rmk:") + (* ; "Edited 18-Feb-87 22:03 by bvm:") (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) - (* ;; "RMK 2020: Added hexstring decoding for Unicode: no commas or other delimiters") + (* ;; "RMK 2020: Added hexstring decoding for Unicode: no commas or other delimiters") - (* ;; "RMK 2021: Moved single chars above atom test to be more precise about digits.") + (* ;; "RMK 2021: Moved single chars above atom test to be more precise about digits.") - (* ;; "Moved Unicode up, out of comma testing, allowed lower-case u.") + (* ;; "Moved Unicode up, out of comma testing, allowed lower-case u.") - (* ;; "Also disallowed unknown junk in the parse-integer strings and substrings so we know what's happening") + (* ;; "Also disallowed unknown junk in the parse-integer strings and substrings so we know what's happening") (COND ((NOT C) @@ -1407,70 +1408,150 @@ (CHARCODE.DECODE (CDR C) NOERROR))) ((EQ (NCHARS C) - 1) (* ; - "Includes singleton digits 0-9, the only FIXP's allowed. 0 is 0, not 48") + 1) (* ; + "Includes singleton digits 0-9, the only FIXP's allowed. 0 is 0, not 48") (CHCON1 C)) - ((NOT (OR (LITATOM C) - (STRINGP C))) (* ; - "LITATOM instead of ATOM stops numbers right here. ") - (AND (NOT NOERROR) - (ERROR "BAD CHARACTER SPECIFICATION" C))) + ((CHARCODEP C) + C) + ((CL:CHARACTERP C) + (CL:CHAR-CODE C)) ((HEXNUM? C T)) + ((NOT (OR (LITATOM C) + (STRINGP C))) (* ; + "LITATOM instead of ATOM stops numbers right here. ") + (CL:UNLESS NOERROR (ERROR "BAD CHARACTER SPECIFICATION" C))) (T (SELCHARQ (CHCON1 C) (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (LOGAND C (LOGNOT 96)))) (%# - (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char") + (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char") - (* ;; "RMK: I don't understand that comment: %"X,#a%" would map to the high panel corresponding to %"a%" in any character set X, including Meta or Function, wherever they happen to be. Won't adding and orring be the same?") + (* ;; "RMK: I don't understand that comment: %"X,#a%" would map to the high panel corresponding to %"a%" in any character set X, including Meta or Function, wherever they happen to be. Won't adding and orring be the same?") (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (IPLUS C 128))) (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) - C) - do (RETURN (OR (NUMBERP (CADR X)) - (CHARCODE.DECODE (CADR X) - NOERROR))) - finally (RETURN - (LET ([POS (find I from 1 - suchthat (FMEMB (OR (NTHCHARCODE C I) - (RETURN)) - (CHARCODE (%, - %. %|] - CH CSET SSTR) (* ; "In the form charset,char") - - (* ;; - "Don't use STRPOSL because CHARTABLE is not available in loadup sequence.") - - (* ;; "The character set loop is like the character loop with a different search list and no recursion for character sets.") - - (COND - ((AND POS (SETQ CH (OR [OCTALNUM? (SETQ SSTR - (SUBSTRING C (ADD1 POS] - (CHARCODE.DECODE SSTR NOERROR))) - (< CH 256) - (>= CH 0) - (SETQ CSET (OR [OCTALNUM? (SETQ SSTR - (SUBSTRING C 1 (SUB1 POS] - (CADR (find PAIR in - CHARACTERSETNAMES - suchthat - - (* ;; - "No recursion. If not a number the list is bad even if C is OK") - - (STRING.EQUAL (CAR PAIR) - SSTR))) - (HEXNUM? SSTR T))) - (< CSET 256) - (>= CSET 0)) (* ; - "parsed the charset part as an octal, standard charset name, or hex") - (LOGOR (LLSH CSET 8) - CH)) - ((NOT NOERROR) - (ERROR "BAD CHARACTER SPECIFICATION" C]) + C) do (RETURN (OR (NUMBERP (CADR X)) + (CHARCODE.DECODE (CADR X) + NOERROR))) + finally (RETURN (LET ([POS (find I from 1 + suchthat (FMEMB (OR (NTHCHARCODE C I) + (RETURN)) + (CHARCODE (%, - %. %|] + CH CSET SSTR) (* ; "In the form charset,char") + + (* ;; + "Don't use STRPOSL because CHARTABLE is not available in loadup sequence.") + + (* ;; "The character set loop is like the character loop with a different search list and no recursion for character sets.") + + (COND + ((AND POS (SETQ CH (OR [OCTALNUM? (SETQ SSTR + (SUBSTRING C (ADD1 POS] + (CHARCODE.DECODE SSTR NOERROR))) + (< CH 256) + (>= CH 0) + (SETQ CSET + (OR [OCTALNUM? (SETQ SSTR (SUBSTRING C 1 (SUB1 POS] + (CADR (find PAIR in CHARACTERSETNAMES + suchthat + + (* ;; + "No recursion. If not a number the list is bad even if C is OK") + + (STRING.EQUAL (CAR PAIR) + SSTR))) + (HEXNUM? SSTR T))) + (< CSET 256) + (>= CSET 0)) (* ; + "parsed the charset part as an octal, standard charset name, or hex") + (LOGOR (LLSH CSET 8) + CH)) + ((NOT NOERROR) + (ERROR "BAD CHARACTER SPECIFICATION" C]) + +(CHARCODE.ENCODE + [LAMBDA (CODE OCTALCHARS NONCHARIDENTITY) (* ; "Edited 23-Apr-2025 19:08 by rmk") + (* ; "Edited 26-Mar-2025 10:37 by rmk") + (* ; "Edited 23-Mar-2025 14:57 by rmk") + (* ; "Edited 18-Mar-2025 20:55 by rmk") + (* ; "Edited 6-Dec-2023 20:30 by rmk") + (* ; "Edited 20-Sep-2021 15:03 by rmk:") + + (* ;; "If CODE correspond to a named character, that character is returned.") + + (* ;; "Otherwise, if OCTALCHARS the result is of the form %"cset,octal-char%" where cset is a known name (Meta) or the octal string for an unknown character set. Ascii codes show up with %"0,xx%"") + + (* ;; "If not OCTALCHARS, the character-name part is constructed from the name of its Ascii equivalent, modified by ^ or #. %"0,%" is suppressed in front of the names for character-set 0.") + + (* ;; "If NONCHARIDENTITY, returns CODE if it isn't something that can be interpreted as a character code.") + + (DECLARE (USEDFREE CHARACTERSETNAMES CHARACTERNAMES)) + + (* ;; "") + + (if (LISTP CODE) + then (CONS (CHARCODE.ENCODE (CAR CODE) + OCTALCHARS NONCHARIDENTITY) + (AND (CDR CODE) + (CHARCODE.ENCODE (CDR CODE) + OCTALCHARS NONCHARIDENTITY))) + elseif (CL:CHARACTERP CODE) + then (CHARCODE.ENCODE (CL:CHAR-CODE CODE) + OCTALCHARS NONCHARIDENTITY) + elseif (NULL CODE) + then NIL + elseif (NOT (CHARCODEP CODE)) + then (CL:IF NONCHARIDENTITY + CODE + (\ILLEGAL.ARG CODE)) + elseif [CAR (find CN in CHARACTERNAMES suchthat (if (CHARCODEP (CADR CN)) + then (IEQP CODE (CADR CN)) + else (IEQP CODE (CHARCODE.DECODE (CADR CN] + else (LET ((CHARSET (LRSH CODE 8)) + (CHAR (LOGAND CODE 255)) + (ASCIICODE (LOGAND CODE 127)) + CSETNAME CHARNAME ASCIINAME) + (SETQ CSETNAME (if [CAR (find CN in CHARACTERSETNAMES + suchthat (STRING.EQUAL CHARSET (CADR CN] + else (OCTALSTRING CHARSET))) + [SETQ CHARNAME (if OCTALCHARS + then (OCTALSTRING CHAR) + else (CAR (for CC in CHARACTERNAMES when (EQ CHAR (CADR CC)) + smallest (NCHARS (CAR CC] + (CL:WHEN (STREQUAL CHARNAME "Tenexeol") (* ; + "Put (%"^_%" Tenexeol) in CHARACTERNAMES ?") + (SETQ CHARNAME "^_")) + + (* ;; "Didn't find the special character name, let's find a corresponding Asciiname to prefix with ^ and/or #") + + (CL:UNLESS CHARNAME + [SETQ ASCIINAME (if [CAR (for CC in CHARACTERNAMES + when (EQ ASCIICODE (CADR CC)) + smallest (NCHARS (CAR CC] + elseif (ILESSP ASCIICODE (CHARCODE SPACE)) + then [CONCAT "^" (CHARACTER (IPLUS ASCIICODE (CHARCODE @] + else + (* ;; "Not named and not a control") + + (CONCAT (CHARACTER ASCIICODE] + (SETQ CHARNAME (CL:IF (IGEQ CHAR 128) + (CONCAT "#" ASCIINAME) + ASCIINAME))) + (CL:IF (AND (ZEROP CHARSET) + (NOT OCTALCHARS)) + CHARNAME + (CONCAT CSETNAME "," CHARNAME))]) + +(CHARCODEP + [LAMBDA (CHCODE) (* gbn "22-Jul-85 16:35") + (* ; "is CHCODE a legal character code?") + (AND (SMALLP CHCODE) + (IGEQ CHCODE 0) + (ILEQ CHCODE \MAXNSCHAR]) ) (DEFINEQ @@ -1669,17 +1750,18 @@ (ADDTOVAR LAMA CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE CL:READ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3437 11881 (LASTC 3447 . 3753) (PEEKC 3755 . 4143) (PEEKCCODE 4145 . 4556) (RATOM 4558 - . 5639) (READ 5641 . 6201) (READC 6203 . 6844) (READCCODE 6846 . 7605) (READP 7607 . 8159) ( -SETREADMACROFLG 8161 . 8460) (SKIPSEPRCODES 8462 . 9542) (SKIPSEPRS 9544 . 9930) (SKREAD 9932 . 11879) -) (11927 20536 (CL:READ 11937 . 12486) (CL:READ-PRESERVING-WHITESPACE 12488 . 13210) ( -CL:READ-DELIMITED-LIST 13212 . 14127) (CL:PARSE-INTEGER 14129 . 20534)) (20629 33106 (RSTRING 20639 . -21371) (READ-EXTENDED-TOKEN 21373 . 25245) (\RSTRING2 25247 . 33104)) (33142 63875 (\TOP-LEVEL-READ -33152 . 35135) (\SUBREAD 35137 . 60291) (\SUBREADCONCAT 60293 . 60916) (\ORIG-READ.SYMBOL 60918 . -61986) (\ORIG-INVALID.SYMBOL 61988 . 62887) (\APPLYREADMACRO 62889 . 63305) (INREADMACROP 63307 . -63873)) (64034 64209 (READQUOTE 64044 . 64207)) (64234 76138 (READVBAR 64244 . 65575) (READHASHMACRO -65577 . 71387) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71389 . 71609) (DIGITBASEP 71611 . 72345) ( -READNUMBERINBASE 72347 . 74233) (ESTIMATE-DIMENSIONALITY 74235 . 74560) (SKIP.HASH.COMMENT 74562 . -75530) (CMLREAD.FEATURE.PARSER 75532 . 76136)) (76182 82526 (CHARACTER.READ 76192 . 77446) ( -CHARCODE.DECODE 77448 . 82524)) (82527 85697 (HEXNUM? 82537 . 84880) (OCTALNUM? 84882 . 85695))))) + (FILEMAP (NIL (3463 11907 (LASTC 3473 . 3779) (PEEKC 3781 . 4169) (PEEKCCODE 4171 . 4582) (RATOM 4584 + . 5665) (READ 5667 . 6227) (READC 6229 . 6870) (READCCODE 6872 . 7631) (READP 7633 . 8185) ( +SETREADMACROFLG 8187 . 8486) (SKIPSEPRCODES 8488 . 9568) (SKIPSEPRS 9570 . 9956) (SKREAD 9958 . 11905) +) (11953 20562 (CL:READ 11963 . 12512) (CL:READ-PRESERVING-WHITESPACE 12514 . 13236) ( +CL:READ-DELIMITED-LIST 13238 . 14153) (CL:PARSE-INTEGER 14155 . 20560)) (20655 33132 (RSTRING 20665 . +21397) (READ-EXTENDED-TOKEN 21399 . 25271) (\RSTRING2 25273 . 33130)) (33168 63901 (\TOP-LEVEL-READ +33178 . 35161) (\SUBREAD 35163 . 60317) (\SUBREADCONCAT 60319 . 60942) (\ORIG-READ.SYMBOL 60944 . +62012) (\ORIG-INVALID.SYMBOL 62014 . 62913) (\APPLYREADMACRO 62915 . 63331) (INREADMACROP 63333 . +63899)) (64060 64235 (READQUOTE 64070 . 64233)) (64260 76164 (READVBAR 64270 . 65601) (READHASHMACRO +65603 . 71413) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 71415 . 71635) (DIGITBASEP 71637 . 72371) ( +READNUMBERINBASE 72373 . 74259) (ESTIMATE-DIMENSIONALITY 74261 . 74586) (SKIP.HASH.COMMENT 74588 . +75556) (CMLREAD.FEATURE.PARSER 75558 . 76162)) (76208 87325 (CHARACTER.READ 76218 . 77472) ( +CHARCODE.DECODE 77474 . 82643) (CHARCODE.ENCODE 82645 . 87024) (CHARCODEP 87026 . 87323)) (87326 90496 + (HEXNUM? 87336 . 89679) (OCTALNUM? 89681 . 90494))))) STOP diff --git a/sources/LLREAD.LCOM b/sources/LLREAD.LCOM index 0639abb88..04766c429 100644 Binary files a/sources/LLREAD.LCOM and b/sources/LLREAD.LCOM differ diff --git a/sources/MEDLEYDIR b/sources/MEDLEYDIR index b4d4e6d90..56992e68c 100644 --- a/sources/MEDLEYDIR +++ b/sources/MEDLEYDIR @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 3-Jul-2025 09:54:45" {MEDLEY}MEDLEYDIR.;4 11322 +(FILECREATED "11-Jul-2025 00:17:20" {WMEDLEY}MEDLEYDIR.;32 11437 :EDIT-BY rmk :CHANGES-TO (VARS MEDLEY-INIT-VARS) + (FNS MEDLEY-INIT-VARS MEDLEYDIR MEDLEYSUBSTDIR SET-SYSOUT-COMMIT) - :PREVIOUS-DATE "15-May-2025 00:18:25" {MEDLEY}MEDLEYDIR.;3) + :PREVIOUS-DATE "15-May-2025 00:18:25" {WMEDLEY}MEDLEYDIR.;31) (PRETTYCOMPRINT MEDLEYDIRCOMS) @@ -200,7 +201,7 @@ LHD)) [USERGREETFILES (LIST (CONS LOGINHOST/DIR '("INIT" COM)) (CONS LOGINHOST/DIR '("INIT"] - (DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/displayfonts") + (DISPLAYFONTDIRECTORIES (MEDLEYDIR '("fonts/medleydisplayfonts" "fonts/displayfonts") NIL NIL T)) (POSTSCRIPTFONTDIRECTORIES (MEDLEYDIR '("fonts/postscriptfonts") NIL NIL T)) @@ -227,6 +228,6 @@ (ADDTOVAR GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS \SAVE.MEDLEYDIR DIRECTORIES SYSOUTCOMMITS) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1643 8717 (MEDLEY-INIT-VARS 1653 . 5131) (MEDLEYDIR 5133 . 7517) (MEDLEYSUBSTDIR 7519 - . 8497) (SET-SYSOUT-COMMIT 8499 . 8715))))) + (FILEMAP (NIL (1731 8805 (MEDLEY-INIT-VARS 1741 . 5219) (MEDLEYDIR 5221 . 7605) (MEDLEYSUBSTDIR 7607 + . 8585) (SET-SYSOUT-COMMIT 8587 . 8803))))) STOP diff --git a/sources/MEDLEYDIR.LCOM b/sources/MEDLEYDIR.LCOM index 565693b78..9c522e7a2 100644 Binary files a/sources/MEDLEYDIR.LCOM and b/sources/MEDLEYDIR.LCOM differ diff --git a/sources/MENU b/sources/MENU index 2435c186b..e6706c076 100644 --- a/sources/MENU +++ b/sources/MENU @@ -1,19 +1,19 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "16-Jul-99 15:51:36" {DSK}medley3.5>sources>MENU.;3 102161 - changes to%: (FNS UPDATE/MENU/IMAGE) +(FILECREATED "14-Jul-2025 22:35:12" {DSK}kaplan>Local>medley3.5>working-medley>sources>MENU.;3 101431 - previous date%: "28-Jun-99 17:05:55" {DSK}medley3.5>sources>MENU.;2) + :EDIT-BY rmk + :CHANGES-TO (FNS MENUTITLEFONT UPDATE/MENU/IMAGE) + + :PREVIOUS-DATE "16-Jul-99 15:51:36" +{DSK}kaplan>Local>medley3.5>working-medley>sources>MENU.;1) -(* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT MENUCOMS) (RPAQQ MENUCOMS - ((COMS (* ; "window functions") + ((COMS (* ; "window functions") (FNS MAXMENUITEMHEIGHT MAXMENUITEMWIDTH MENU MENUTITLEFONT ADDMENU DELETEMENU MENUREGION BLTMENUIMAGE ERASEMENUIMAGE DEFAULTMENUHELDFN DEFAULTWHENSELECTEDFN BACKGROUNDWHENSELECTEDFN GETMENUITEM MENUBUTTONFN MENU.HANDLER DOSELECTEDITEM @@ -26,13 +26,13 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (BITMAPS MENUSUBITEMMARK) (INITVARS (MENUFONT (FONTCREATE 'HELVETICA 10))) (DECLARE%: DONTCOPY (MACROS MENU.HELDSTATE.RESET MENU.PRIN2.FLG))) - (COMS (* ; - "scrolling menu functions and utilities") + (COMS (* ; + "scrolling menu functions and utilities") (FNS MENUREPAINTFN)) - (COMS (* ; "misc utility fns.") + (COMS (* ; "misc utility fns.") (FNS MAXSTRINGWIDTH CENTEREDPRIN1 CENTERPRINTINREGION CENTERPRINTINAREA STRICTLY/BETWEEN)) - (COMS (* ; "examples of use.") + (COMS (* ; "examples of use.") (FNS UNREADITEM TYPEINMENU SHADEITEM RESHADEITEM MOST/VISIBLE/OPERATION %#BITSON BUTTONPANEL BUTTONPANEL/SELECTION/FN GETSELECTEDITEMS) (VARS EDITCMDS MENUHELDWAIT) @@ -137,24 +137,25 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (CDR SELVAL]) (MENUTITLEFONT - [LAMBDA (MENU SCREEN) (* kbr%: " 2-Sep-85 14:35") - (* returns the title font for a - menu.) + [LAMBDA (MENU SCREEN) (* ; "Edited 14-Jul-2025 22:34 by rmk") + (* kbr%: " 2-Sep-85 14:35") + (* ; + "returns the title font for a menu.") + (* returns the title font for a menu.) (PROG (TITLEFONT) [COND ((NULL SCREEN) (COND [(type? WINDOW (fetch (MENU IMAGE) of MENU)) - (SETQ SCREEN (fetch (WINDOW SCREEN) of (fetch (MENU IMAGE) - of MENU] + (SETQ SCREEN (fetch (WINDOW SCREEN) of (fetch (MENU IMAGE) of MENU] (T (SETQ SCREEN LASTSCREEN] (RETURN (COND ((NULL (SETQ TITLEFONT (fetch (MENU MENUTITLEFONT) of MENU))) - (* use the window title font) + (* ; "use the window title font") (DSPFONT NIL (fetch (SCREEN SCTITLEDS) of SCREEN))) - ((EQ TITLEFONT T) (* use the menu item font) + ((EQ TITLEFONT T) (* ; "use the menu item font") (fetch (MENU MENUFONT) of MENU)) - ((FONTP (\COERCEFONTDESC TITLEFONT 'DISPLAY T))) + ((FONTP (FONTCREATE TITLEFONT NIL NIL NIL 'DISPLAY T))) (T (DSPFONT NIL (fetch (SCREEN SCTITLEDS) of SCREEN]) (ADDMENU @@ -795,11 +796,11 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (PROMPTPRINT (CADR ITEM]) (UPDATE/MENU/IMAGE - [LAMBDA (MNU SCREEN) (* ; "Edited 16-Jul-99 15:51 by rmk:") - (* ; - "Edited 10-Dec-93 16:01 by sybalsky") - (* ; - "recomputes the menu image from its labels.") + [LAMBDA (MNU SCREEN) (* ; "Edited 14-Jul-2025 22:34 by rmk") + (* ; "Edited 16-Jul-99 15:51 by rmk:") + (* ; "Edited 10-Dec-93 16:01 by sybalsky") + (* ; + "recomputes the menu image from its labels.") (PROG (NUMCOLS NUMROWS WIDTH HEIGHT DSP BLK COLWIDTH ROWHEIGHT BITSPERPIXEL MENUITEMS NITEMS BORDER OUTLINE FONT TITLEFONT TITLEHEIGHT TITLEWIDTH WINDOW TITLE ANYSUBITEMS? CENTER?) @@ -807,30 +808,27 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, ((NULL SCREEN) (COND [(type? WINDOW (fetch (MENU IMAGE) of MNU)) - (SETQ SCREEN (fetch (WINDOW SCREEN) of (fetch (MENU IMAGE) - of MNU] + (SETQ SCREEN (fetch (WINDOW SCREEN) of (fetch (MENU IMAGE) of MNU] (T (SETQ SCREEN LASTSCREEN] (SETQ MENUITEMS (fetch (MENU ITEMS) of MNU)) - (SETQ CENTER? (fetch (MENU CENTERFLG) of MNU)) - (* ; "check the font.") + (SETQ CENTER? (fetch (MENU CENTERFLG) of MNU)) (* ; "check the font.") (COND [(FONTP (SETQ FONT (AND (fetch (MENU MENUFONT) of MNU) - (\COERCEFONTDESC (fetch (MENU MENUFONT) of MNU) - 'DISPLAY T] + (FONTCREATE (fetch (MENU MENUFONT) of MNU) + NIL NIL NIL 'DISPLAY T] (T [SETQ FONT (COND ((FONTP MENUFONT)) (T (SETQ MENUFONT (FONTCREATE 'HELVETICA 10] - (* ; "keep font in the menu") + (* ; "keep font in the menu") (replace (MENU MENUFONT) of MNU with FONT))) (COND - ((SETQ TITLE (fetch (MENU TITLE) of MNU)) - (* ; "set the title font") + ((SETQ TITLE (fetch (MENU TITLE) of MNU)) (* ; "set the title font") (SETQ TITLEFONT (MENUTITLEFONT MNU SCREEN)) (SETQ TITLEHEIGHT (FONTPROP TITLEFONT 'HEIGHT)) (SETQ TITLEWIDTH (STRINGWIDTH TITLE TITLEFONT))) (T (SETQ TITLEHEIGHT 0) - (SETQ TITLEWIDTH 0))) (* ; - "calculate the number of columns and rows") + (SETQ TITLEWIDTH 0))) (* ; + "calculate the number of columns and rows") (SETQ NITEMS (LENGTH MENUITEMS)) (COND [(SETQ NUMCOLS (NUMBERP (fetch (MENU MENUCOLUMNS) of MNU))) @@ -844,20 +842,19 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (T (SETQ NUMCOLS 1) (SETQ NUMROWS NITEMS))) - (* ;; "set BORDER to the size of the outline around each menu item and OUTLINE to the size of the outline around the whole menu.") + (* ;; "set BORDER to the size of the outline around each menu item and OUTLINE to the size of the outline around the whole menu.") (SETQ BORDER (OR (FIXP (fetch (MENU MENUBORDERSIZE) of MNU)) (replace (MENU MENUBORDERSIZE) of MNU with 0))) [SETQ OUTLINE (OR (FIXP (fetch (MENU MENUOUTLINESIZE) of MNU)) - (replace (MENU MENUOUTLINESIZE) of MNU - with (IMAX BORDER 1] - (SETQ ANYSUBITEMS? (for I in (fetch (MENU ITEMS) of MNU) - when (\MENUSUBITEMS MNU I) do (RETURN T))) + (replace (MENU MENUOUTLINESIZE) of MNU with (IMAX BORDER 1] + (SETQ ANYSUBITEMS? (for I in (fetch (MENU ITEMS) of MNU) when (\MENUSUBITEMS MNU I) + do (RETURN T))) (COND ((IGREATERP (SETQ COLWIDTH (fetch (MENU ITEMWIDTH) of MNU)) 5000) - (* ;; "If ITEMWIDTH is greater than 5000, it was probably default clipping region. if no columnwidth is given {common case}, calculate it from the items widths.") + (* ;; "If ITEMWIDTH is greater than 5000, it was probably default clipping region. if no columnwidth is given {common case}, calculate it from the items widths.") [SETQ COLWIDTH (IPLUS (MAXMENUITEMWIDTH MNU T) (ITIMES (ADD1 BORDER) @@ -867,8 +864,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (T 0] [COND ((IGREATERP (IPLUS TITLEWIDTH 2) - (ITIMES COLWIDTH NUMCOLS)) (* ; - "adjust column width to cover title.") + (ITIMES COLWIDTH NUMCOLS)) (* ; + "adjust column width to cover title.") (SETQ COLWIDTH (IQUOTIENT (IPLUS TITLEWIDTH (SUB1 NUMCOLS)) NUMCOLS] (replace (MENU ITEMWIDTH) of MNU with COLWIDTH))) @@ -889,12 +886,11 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (NULL (fetch (MENU MENUCOLUMNS) of MNU)) (NULL (fetch (MENU MENUROWS) of MNU))) - (* ;; "it is too large to fit on the screen and menu is defaulting the number of columns and rows If the user specified either the number of rows or columns, assume they knew what they were doing.") + (* ;; "it is too large to fit on the screen and menu is defaulting the number of columns and rows If the user specified either the number of rows or columns, assume they knew what they were doing.") - (PROG (NITEMSTOFIT) (* ; - "menu is defaulting the number of columns") - (SETQ NITEMSTOFIT (IQUOTIENT (IDIFFERENCE (fetch (SCREEN SCHEIGHT) - of SCREEN) + (PROG (NITEMSTOFIT) (* ; + "menu is defaulting the number of columns") + (SETQ NITEMSTOFIT (IQUOTIENT (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of SCREEN) TITLEHEIGHT) ROWHEIGHT)) (SETQ NUMCOLS (ADD1 (IQUOTIENT (SUB1 NITEMS) @@ -907,32 +903,28 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (ITIMES OUTLINE 2) TITLEHEIGHT)) - (* ;; "changing the items field is suspect since conceivably the user might be depending upon it. At least the fact that MENUCOLUMNS is NIL keeps it from happening twice if it gets called again.") + (* ;; "changing the items field is suspect since conceivably the user might be depending upon it. At least the fact that MENUCOLUMNS is NIL keeps it from happening twice if it gets called again.") - (replace (MENU ITEMS) of MNU with (SETQ MENUITEMS - (\MAKE.ITEMS.VERT.ORDER - MENUITEMS NUMROWS NUMCOLS] + (replace (MENU ITEMS) of MNU with (SETQ MENUITEMS (\MAKE.ITEMS.VERT.ORDER + MENUITEMS NUMROWS + NUMCOLS] ((AND (NULL (fetch (MENU MENUCOLUMNS) of MNU)) (fetch (MENU MENUROWS) of MNU)) - (* ;; "user wants a certain number of rows but doesn't care about the columns, switch to vertical order so the blanks items appear in the last row.") + (* ;; "user wants a certain number of rows but doesn't care about the columns, switch to vertical order so the blanks items appear in the last row.") - (replace (MENU ITEMS) of MNU with (SETQ MENUITEMS ( - \MAKE.ITEMS.VERT.ORDER - MENUITEMS NUMROWS - NUMCOLS] + (replace (MENU ITEMS) of MNU with (SETQ MENUITEMS (\MAKE.ITEMS.VERT.ORDER MENUITEMS + NUMROWS NUMCOLS] (replace (MENU MENUCOLUMNS) of MNU with NUMCOLS) (replace (MENU MENUROWS) of MNU with NUMROWS) (SETQ BITSPERPIXEL (OR (fetch (SCREEN SCDEPTH) of SCREEN) (fetch (SCREEN SCBITSPERPIXEL) of SCREEN))) [SETQ BLK (COND ((AND [SETQ BLK (COND - ((type? BITMAP (SETQ BLK (fetch (MENU IMAGE) - of MNU))) + ((type? BITMAP (SETQ BLK (fetch (MENU IMAGE) of MNU))) BLK) - ((type? WINDOW BLK) - (* ; - "if it is a window, make sure it is not active, then") + ((type? WINDOW BLK)(* ; + "if it is a window, make sure it is not active, then") (CLOSEW BLK) (fetch (WINDOW SAVE) of BLK] (EQ (fetch (BITMAP BITMAPWIDTH) of BLK) @@ -940,13 +932,13 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (EQ (fetch (BITMAP BITMAPHEIGHT) of BLK) HEIGHT) (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BLK) - BITSPERPIXEL)) (* ; "reuse current image bitmap") + BITSPERPIXEL)) (* ; "reuse current image bitmap") BLK) - (T (* ; "create a new one") + (T (* ; "create a new one") (BITMAPCREATE WIDTH HEIGHT BITSPERPIXEL] (BITBLT NIL NIL NIL BLK 0 0 WIDTH HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) - (* ; "Draw box by nested BitBlts") - (* ; "leave outline") + (* ; "Draw box by nested BitBlts") + (* ; "leave outline") (BITBLT NIL NIL NIL BLK OUTLINE OUTLINE (IDIFFERENCE WIDTH (ITIMES OUTLINE 2)) (IDIFFERENCE HEIGHT (IPLUS TITLEHEIGHT (ITIMES OUTLINE 2))) 'TEXTURE @@ -955,24 +947,22 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (DSPRIGHTMARGIN MAX.SMALLP DSP) (DSPXOFFSET OUTLINE DSP) (DSPYOFFSET OUTLINE DSP) - (replace (REGION LEFT) of (fetch (MENU MENUGRID) of MNU) with - 0) - (replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of MNU) with - 0) + (replace (REGION LEFT) of (fetch (MENU MENUGRID) of MNU) with 0) + (replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of MNU) with 0) (GRID (fetch (MENU MENUGRID) of MNU) NUMCOLS NUMROWS BORDER DSP) - (DSPOPERATION 'INVERT DSP) (* ; - "calculate the offset from the top of the item box to the base line of the printed item.") + (DSPOPERATION 'INVERT DSP) (* ; + "calculate the offset from the top of the item box to the base line of the printed item.") [COND - (TITLE (* ; "if there is a title, display it") + (TITLE (* ; "if there is a title, display it") (DSPFONT TITLEFONT DSP) (\SHOWMENULABEL TITLE (create REGION - LEFT _ BORDER - BOTTOM _ (IDIFFERENCE (IPLUS HEIGHT BORDER) - (IPLUS TITLEHEIGHT - (ITIMES OUTLINE 2))) - WIDTH _ WIDTH - HEIGHT _ TITLEHEIGHT) + LEFT _ BORDER + BOTTOM _ (IDIFFERENCE (IPLUS HEIGHT BORDER) + (IPLUS TITLEHEIGHT (ITIMES OUTLINE 2 + ))) + WIDTH _ WIDTH + HEIGHT _ TITLEHEIGHT) MNU DSP CENTER?) (SETQ HEIGHT (IDIFFERENCE HEIGHT TITLEHEIGHT] [PROG (ITEMREGION MAJOR#) @@ -981,15 +971,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, BOTTOM _ (IDIFFERENCE (IPLUS HEIGHT BORDER) (IPLUS ROWHEIGHT (ITIMES OUTLINE 2))) WIDTH _ (IDIFFERENCE (IDIFFERENCE (fetch (REGION WIDTH) - of - (fetch (MENU - MENUGRID) - of MNU)) + of (fetch (MENU MENUGRID + ) + of MNU)) (ITIMES BORDER 2)) (COND (ANYSUBITEMS? - (* ; - "the subitem mark goes outside of the normal title space") + (* ; + "the subitem mark goes outside of the normal title space") (BITMAPWIDTH MENUSUBITEMMARK)) (T 0))) HEIGHT _ (IDIFFERENCE ROWHEIGHT (ITIMES BORDER 2] @@ -1000,44 +989,42 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, ITEMREGION MNU DSP CENTER?) (SETQ MENUITEMS (CDR MENUITEMS)) [COND - ((EQ MAJOR# NUMCOLS) (* ; "advance to the next row") + ((EQ MAJOR# NUMCOLS) (* ; "advance to the next row") (SETQ MAJOR# 1) (replace (REGION BOTTOM) of ITEMREGION with (IDIFFERENCE (fetch (REGION BOTTOM) of ITEMREGION) - ROWHEIGHT)) + ROWHEIGHT)) (replace (REGION LEFT) of ITEMREGION with BORDER)) (T (SETQ MAJOR# (ADD1 MAJOR#)) (replace (REGION LEFT) of ITEMREGION with (IPLUS (fetch (REGION LEFT) of ITEMREGION) - COLWIDTH] + COLWIDTH] (GO LP] [COND ((NULL (fetch (MENU MENUOFFSET) of MNU)) - (* ;; "set offset so cursor will be be in middle of the menu on first display if it is to move with the cursor. If it is fixed offset, initialize it to 0") + (* ;; "set offset so cursor will be be in middle of the menu on first display if it is to move with the cursor. If it is fixed offset, initialize it to 0") (replace (MENU MENUOFFSET) of MNU with (COND - ((fetch (MENU CHANGEOFFSETFLG) of MNU) - (create POSITION - XCOORD _ (IQUOTIENT WIDTH 2) - YCOORD _ (IQUOTIENT HEIGHT 2))) - (T (create POSITION - XCOORD _ 0 - YCOORD _ 0] + ((fetch (MENU CHANGEOFFSETFLG) of MNU) + (create POSITION + XCOORD _ (IQUOTIENT WIDTH 2) + YCOORD _ (IQUOTIENT HEIGHT 2))) + (T (create POSITION + XCOORD _ 0 + YCOORD _ 0] [COND ((AND (type? WINDOW (SETQ WINDOW (fetch (MENU IMAGE) of MNU))) (EQ (fetch (WINDOW SCREEN) of WINDOW) - SCREEN)) (* ; - "menu has a window, replace its save image.") + SCREEN)) (* ; + "menu has a window, replace its save image.") (replace (WINDOW SAVE) of WINDOW with BLK)) - (T (replace (MENU IMAGE) of MNU with (SETQ WINDOW (CREATEWFROMIMAGE - BLK SCREEN] - (* ; - "tell the window about its border") + (T (replace (MENU IMAGE) of MNU with (SETQ WINDOW (CREATEWFROMIMAGE BLK SCREEN] + (* ; "tell the window about its border") (replace (WINDOW WBORDER) of WINDOW with OUTLINE) - (ADVISEWDS WINDOW) (* ; - "snap circular link between the display stream created for printing and its stream.") + (ADVISEWDS WINDOW) (* ; + "snap circular link between the display stream created for printing and its stream.") (RETURN (fetch (WINDOW SAVE) of (fetch (MENU IMAGE) of MNU]) (\MAKE.ITEMS.VERT.ORDER @@ -1394,21 +1381,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE -(PUTPROPS MENU.HELDSTATE.RESET MACRO - ((BX BY) - [COND - (HELDSTATE (COND - ((SETQ HELDSTATE (fetch (MENU WHENUNHELDFN) of MENU)) - (APPLY* HELDSTATE (GETMENUITEM MENU BX BY) - MENU - (\FDECODE/BUTTON LASTBUTTONSTATE)) - (SETQ HELDSTATE NIL] - (SETQ HOLDTIMER (SETUPTIMER MENUHELDWAIT HOLDTIMER)))) - -(PUTPROPS MENU.PRIN2.FLG MACRO - ((MNU) - (LISTGET (fetch (MENU MENUUSERDATA) of MNU) - :ESCAPE))) +(PUTPROPS MENU.HELDSTATE.RESET MACRO ((BX BY) + [COND + (HELDSTATE (COND + ((SETQ HELDSTATE (fetch (MENU WHENUNHELDFN) + of MENU)) + (APPLY* HELDSTATE (GETMENUITEM MENU BX BY) + MENU + (\FDECODE/BUTTON LASTBUTTONSTATE)) + (SETQ HELDSTATE NIL] + (SETQ HOLDTIMER (SETUPTIMER MENUHELDWAIT HOLDTIMER)))) + +(PUTPROPS MENU.PRIN2.FLG MACRO ((MNU) + (LISTGET (fetch (MENU MENUUSERDATA) of MNU) + :ESCAPE))) ) ) @@ -1631,7 +1617,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (RPAQQ EDITCMDS ("P" "PP" ("LF" "% ") - 0 1 -1 2 3 "BK" "EF" "EVAL")) + 0 1 -1 2 3 "BK" "EF" "EVAL")) (RPAQQ MENUHELDWAIT 1200) (DECLARE%: EVAL@COMPILE @@ -1679,23 +1665,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, LEFT _ 0 BOTTOM _ 0) WHENHELDFN _ 'DEFAULTMENUHELDFN WHENUNHELDFN _ 'CLRPROMPT - [ACCESSFNS ((ITEMWIDTH (fetch (REGION WIDTH) of (fetch (MENU MENUGRID) - of DATUM)) - (replace (REGION WIDTH) of (fetch (MENU MENUGRID) - of DATUM) with NEWVALUE)) - (ITEMHEIGHT (fetch (REGION HEIGHT) of (fetch (MENU MENUGRID) - of DATUM)) - (replace (REGION HEIGHT) of (fetch (MENU MENUGRID) - of DATUM) with NEWVALUE)) + [ACCESSFNS ((ITEMWIDTH (fetch (REGION WIDTH) of (fetch (MENU MENUGRID) of DATUM)) + (replace (REGION WIDTH) of (fetch (MENU MENUGRID) of DATUM) with + NEWVALUE + )) + (ITEMHEIGHT (fetch (REGION HEIGHT) of (fetch (MENU MENUGRID) of DATUM)) + (replace (REGION HEIGHT) of (fetch (MENU MENUGRID) of DATUM) + with NEWVALUE)) (IMAGEWIDTH (BITMAPWIDTH (CHECK/MENU/IMAGE DATUM))) (IMAGEHEIGHT (BITMAPHEIGHT (CHECK/MENU/IMAGE DATUM))) - (MENUREGIONLEFT (IDIFFERENCE (fetch (REGION LEFT) - of (fetch (MENU MENUGRID) of DATUM) - ) + (MENUREGIONLEFT (IDIFFERENCE (fetch (REGION LEFT) of (fetch (MENU MENUGRID) + of DATUM)) (fetch (MENU MENUOUTLINESIZE) of DATUM))) (MENUREGIONBOTTOM (IDIFFERENCE (fetch (REGION BOTTOM) - of (fetch (MENU MENUGRID) - of DATUM)) + of (fetch (MENU MENUGRID) of DATUM)) (fetch (MENU MENUOUTLINESIZE) of DATUM]) ) @@ -1726,27 +1709,25 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, (MENU 40 POINTER) (MENU 42 POINTER)) '44) -(PUTPROPS MENU COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 -1993 1994 1999)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2642 87699 (MAXMENUITEMHEIGHT 2652 . 3589) (MAXMENUITEMWIDTH 3591 . 5290) (MENU 5292 . -8189) (MENUTITLEFONT 8191 . 9461) (ADDMENU 9463 . 14901) (DELETEMENU 14903 . 16384) (MENUREGION 16386 - . 17246) (BLTMENUIMAGE 17248 . 19276) (ERASEMENUIMAGE 19278 . 20200) (DEFAULTMENUHELDFN 20202 . 20492 -) (DEFAULTWHENSELECTEDFN 20494 . 20905) (BACKGROUNDWHENSELECTEDFN 20907 . 21342) (GETMENUITEM 21344 . -21933) (MENUBUTTONFN 21935 . 22566) (MENU.HANDLER 22568 . 40670) (DOSELECTEDITEM 40672 . 41097) ( -SHOWSHADEDITEMS 41099 . 42516) (\AddShade 42518 . 43710) (\DelShade 43712 . 43983) (\FDECODE/BUTTON -43985 . 44372) (MENUITEMREGION 44374 . 47109) (\MENUITEMLABEL 47111 . 47457) (\MENUSUBITEMS 47459 . -47697) (CHECK/MENU/IMAGE 47699 . 49705) (PPROMPT2 49707 . 50096) (UPDATE/MENU/IMAGE 50098 . 66458) ( -\MAKE.ITEMS.VERT.ORDER 66460 . 67987) (\SHOWMENULABEL 67989 . 71916) (\POSITION.MENU.IMAGE 71918 . -74773) (\SMASHMENUIMAGEONRESET 74775 . 75123) (CLOSE.PROCESS.MENU 75125 . 75307) (DEFAULTSUBITEMFN -75309 . 76029) (GETMENUPROP 76031 . 76223) (PUTMENUPROP 76225 . 76598) (WAKE.MY.PROCESS 76600 . 76783) - (\INVERTITEM 76785 . 77241) (\MENU.ITEM.SELECT 77243 . 78806) (\MENU.ITEM.DESELECT 78808 . 79510) ( -\ItemNumber 79512 . 80079) (\BOXITEM 80081 . 81628) (NESTED.SUBMENU 81630 . 84348) (NESTED.SUBMENU.POS - 84350 . 87321) (WFROMMENU 87323 . 87697)) (88489 88909 (MENUREPAINTFN 88499 . 88907)) (88944 91993 ( -MAXSTRINGWIDTH 88954 . 89197) (CENTEREDPRIN1 89199 . 89636) (CENTERPRINTINREGION 89638 . 90167) ( -CENTERPRINTINAREA 90169 . 91626) (STRICTLY/BETWEEN 91628 . 91991)) (92027 97969 (UNREADITEM 92037 . -92359) (TYPEINMENU 92361 . 92562) (SHADEITEM 92564 . 94308) (RESHADEITEM 94310 . 95403) ( -MOST/VISIBLE/OPERATION 95405 . 95676) (%#BITSON 95678 . 96396) (BUTTONPANEL 96398 . 97190) ( -BUTTONPANEL/SELECTION/FN 97192 . 97744) (GETSELECTEDITEMS 97746 . 97967)) (98289 98830 (MENUDESELECT -98299 . 98516) (MENUSELECT 98518 . 98828))))) + (FILEMAP (NIL (2583 86884 (MAXMENUITEMHEIGHT 2593 . 3530) (MAXMENUITEMWIDTH 3532 . 5231) (MENU 5233 . +8130) (MENUTITLEFONT 8132 . 9572) (ADDMENU 9574 . 15012) (DELETEMENU 15014 . 16495) (MENUREGION 16497 + . 17357) (BLTMENUIMAGE 17359 . 19387) (ERASEMENUIMAGE 19389 . 20311) (DEFAULTMENUHELDFN 20313 . 20603 +) (DEFAULTWHENSELECTEDFN 20605 . 21016) (BACKGROUNDWHENSELECTEDFN 21018 . 21453) (GETMENUITEM 21455 . +22044) (MENUBUTTONFN 22046 . 22677) (MENU.HANDLER 22679 . 40781) (DOSELECTEDITEM 40783 . 41208) ( +SHOWSHADEDITEMS 41210 . 42627) (\AddShade 42629 . 43821) (\DelShade 43823 . 44094) (\FDECODE/BUTTON +44096 . 44483) (MENUITEMREGION 44485 . 47220) (\MENUITEMLABEL 47222 . 47568) (\MENUSUBITEMS 47570 . +47808) (CHECK/MENU/IMAGE 47810 . 49816) (PPROMPT2 49818 . 50207) (UPDATE/MENU/IMAGE 50209 . 65643) ( +\MAKE.ITEMS.VERT.ORDER 65645 . 67172) (\SHOWMENULABEL 67174 . 71101) (\POSITION.MENU.IMAGE 71103 . +73958) (\SMASHMENUIMAGEONRESET 73960 . 74308) (CLOSE.PROCESS.MENU 74310 . 74492) (DEFAULTSUBITEMFN +74494 . 75214) (GETMENUPROP 75216 . 75408) (PUTMENUPROP 75410 . 75783) (WAKE.MY.PROCESS 75785 . 75968) + (\INVERTITEM 75970 . 76426) (\MENU.ITEM.SELECT 76428 . 77991) (\MENU.ITEM.DESELECT 77993 . 78695) ( +\ItemNumber 78697 . 79264) (\BOXITEM 79266 . 80813) (NESTED.SUBMENU 80815 . 83533) (NESTED.SUBMENU.POS + 83535 . 86506) (WFROMMENU 86508 . 86882)) (88093 88513 (MENUREPAINTFN 88103 . 88511)) (88548 91597 ( +MAXSTRINGWIDTH 88558 . 88801) (CENTEREDPRIN1 88803 . 89240) (CENTERPRINTINREGION 89242 . 89771) ( +CENTERPRINTINAREA 89773 . 91230) (STRICTLY/BETWEEN 91232 . 91595)) (91631 97573 (UNREADITEM 91641 . +91963) (TYPEINMENU 91965 . 92166) (SHADEITEM 92168 . 93912) (RESHADEITEM 93914 . 95007) ( +MOST/VISIBLE/OPERATION 95009 . 95280) (%#BITSON 95282 . 96000) (BUTTONPANEL 96002 . 96794) ( +BUTTONPANEL/SELECTION/FN 96796 . 97348) (GETSELECTEDITEMS 97350 . 97571)) (97889 98430 (MENUDESELECT +97899 . 98116) (MENUSELECT 98118 . 98428))))) STOP diff --git a/sources/MENU.LCOM b/sources/MENU.LCOM index 248b412b4..4f37be6b5 100644 Binary files a/sources/MENU.LCOM and b/sources/MENU.LCOM differ diff --git a/sources/XCCS b/sources/XCCS index 5c70c8d0b..12746d5da 100644 --- a/sources/XCCS +++ b/sources/XCCS @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Mar-2025 23:40:52" {WMEDLEY}XCCS.;72 14656 +(FILECREATED "13-Jul-2025 23:08:39" {DSK}kaplan>Local>medley3.5>git-medley>sources>XCCS.;10 15413 :EDIT-BY rmk :CHANGES-TO (VARS XCCSCOMS) - :PREVIOUS-DATE "26-Mar-2024 11:00:37" {WMEDLEY}XCCS.;70) + :PREVIOUS-DATE "25-Mar-2025 23:40:52" +{DSK}kaplan>Local>medley3.5>git-medley>sources>XCCS.;9) (PRETTYCOMPRINT XCCSCOMS) @@ -16,6 +17,7 @@ \XCCSCHARSETFN) (FNS \CREATE.XCCS.EXTERNALFORMAT) (FNS \NSIN.24BITENCODING.ERROR) + (FNS KANJICHARSETP CHINESECHARSETP) (INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*)) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (CONSTANTS (\NORUNCODE 255) (NSCHARSETSHIFT 255)) @@ -262,6 +264,25 @@ (* ; "Return charset zero") 0]) ) +(DEFINEQ + +(KANJICHARSETP + [LAMBDA (CHARSET) (* ; "Edited 13-Jun-2025 16:33 by rmk") + + (* ;; "Returns CHARSET if it is a charset with MCCS Kanji characters") + + (AND (<= 48 CHARSET 118) + CHARSET]) + +(CHINESECHARSETP + [LAMBDA (CHARSET) (* ; "Edited 18-Jun-2025 23:09 by rmk") + (* ; "Edited 13-Jun-2025 16:33 by rmk") + + (* ;; "Returns CHARSET if it is a charset with MCCS Chinese characters") + + (AND (<= 161 CHARSET 212) + CHARSET]) +) (RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* ) (DECLARE%: EVAL@COMPILE DONTCOPY @@ -294,8 +315,9 @@ (\CREATE.XCCS.EXTERNALFORMAT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (881 12137 (\XCCSINCCODE 891 . 3870) (\XCCSPEEKCCODE 3872 . 6541) (\XCCSOUTCHAR 6543 . -8763) (\XCCSBACKCCODE 8765 . 10309) (\XCCSFORMATBYTESTREAM 10311 . 10932) (\XCCSCHARSETFN 10934 . -12135)) (12138 12911 (\CREATE.XCCS.EXTERNALFORMAT 12148 . 12909)) (12912 13743 ( -\NSIN.24BITENCODING.ERROR 12922 . 13741))))) + (FILEMAP (NIL (997 12253 (\XCCSINCCODE 1007 . 3986) (\XCCSPEEKCCODE 3988 . 6657) (\XCCSOUTCHAR 6659 . +8879) (\XCCSBACKCCODE 8881 . 10425) (\XCCSFORMATBYTESTREAM 10427 . 11048) (\XCCSCHARSETFN 11050 . +12251)) (12254 13027 (\CREATE.XCCS.EXTERNALFORMAT 12264 . 13025)) (13028 13859 ( +\NSIN.24BITENCODING.ERROR 13038 . 13857)) (13860 14500 (KANJICHARSETP 13870 . 14126) (CHINESECHARSETP +14128 . 14498))))) STOP diff --git a/sources/XCCS.LCOM b/sources/XCCS.LCOM index b8ed53e68..031ae49db 100644 Binary files a/sources/XCCS.LCOM and b/sources/XCCS.LCOM differ