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..5de1c98be --- /dev/null +++ b/internal/FONT-DEBUG @@ -0,0 +1,285 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "17-Jul-2025 13:24:05" {MEDLEY}FONT-DEBUG.;3 15965 + + :EDIT-BY rmk + + :CHANGES-TO (FNS CSBMSIZE) + + :PREVIOUS-DATE "17-Jul-2025 13:15:51" {MEDLEY}FONT-DEBUG.;2) + + +(PRETTYCOMPRINT FONT-DEBUGCOMS) + +(RPAQQ FONT-DEBUGCOMS ( + (* ;; "Little tools to help in debugging display fonts") + + (FNS DEBUGCHARSET IBM ICS CSBMSIZE SHOWCACHE SHOWCSBITMAP EQCSBM CHARSETCHARS + CHARBMDIFFS SHOWCSCHAR CSCOMPARE SHOWBMS SHOWCHARBITMAPS CANDS))) + + + +(* ;; "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"]) + +(CSBMSIZE + [LAMBDA (FONT CHARSET FILETOO NOERROR) (* ; "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 CHARSET + (PRINTOUT T "Using CHARSET 0" T) + (SETQ CHARSET 0)) + (LET ((CSINFO (if FILETOO + then (DEBUGCHARSET FONT CHARSET) + else (\XGETCHARSETINFO FONT CHARSET))) + BM) + (if (AND CSINFO (SETQ BM (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) + then (IQUOTIENT (ITIMES (BITMAPWIDTH BM) + (BITMAPHEIGHT BM)) + 8) + else (PRINTOUT T "No charset/bitmap"))) + else 0]) + +(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]) + +(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]) +) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (695 15942 (DEBUGCHARSET 705 . 3884) (IBM 3886 . 4594) (ICS 4596 . 5890) (CSBMSIZE 5892 + . 6879) (SHOWCACHE 6881 . 7228) (SHOWCSBITMAP 7230 . 8344) (EQCSBM 8346 . 9232) (CHARSETCHARS 9234 . +9900) (CHARBMDIFFS 9902 . 10778) (SHOWCSCHAR 10780 . 11215) (CSCOMPARE 11217 . 13809) (SHOWBMS 13811 + . 13989) (SHOWCHARBITMAPS 13991 . 15582) (CANDS 15584 . 15940))))) +STOP diff --git a/internal/FONT-DEBUG.LCOM b/internal/FONT-DEBUG.LCOM new file mode 100644 index 000000000..a592f9d8e 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/PDFSTREAM b/library/PDFSTREAM index 414efd3de..5e8b27711 100644 --- a/library/PDFSTREAM +++ b/library/PDFSTREAM @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Jun-2025 08:42:11" {WMEDLEY}PDFSTREAM.;64 14885 +(FILECREATED "16-Jun-2025 00:52:44" {WMEDLEY}PDFSTREAM.;67 15409 :EDIT-BY rmk - :CHANGES-TO (FNS OPEN-PDF-STREAM) + :CHANGES-TO (VARS PDFSTREAMCOMS) + (FNS PDF.FONTSAVAILABLE) - :PREVIOUS-DATE "23-Feb-2025 12:18:57" {WMEDLEY}PDFSTREAM.;62) + :PREVIOUS-DATE "15-Jun-2025 23:42:56" {WMEDLEY}PDFSTREAM.;66) (PRETTYCOMPRINT PDFSTREAMCOMS) @@ -28,11 +29,12 @@ (CONVERSION (TEXT PDF.TEXT TEDIT PDF.TEDIT] (IMAGESTREAMTYPES (PDF (OPENSTREAM OPEN-PDF-STREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) - (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) - (CREATECHARSET \CREATECHARSET.PSC] + (FONTSAVAILABLE PDF.FONTSAVAILABLE) + (CREATECHARSET \CREATECHARSET.PSC) + (FONTEXISTS? POSTSCRIPT.FONTEXISTS?] (ALISTS (DEFAULTFILETYPELIST PDF)) (VARS (DEFAULTPRINTERTYPE 'PDF)) - (FNS PDFFILEP PDF.HARDCOPYW PDF.TEXT PDF.TEDIT) + (FNS PDFFILEP PDF.HARDCOPYW PDF.TEXT PDF.TEDIT PDF.FONTSAVAILABLE) (P (FONTPROFILE.ADDDEVICE 'PDF 'POSTSCRIPT] (* ;; "") @@ -71,8 +73,9 @@ (ADDTOVAR IMAGESTREAMTYPES (PDF (OPENSTREAM OPEN-PDF-STREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) - (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) - (CREATECHARSET \CREATECHARSET.PSC))) + (FONTSAVAILABLE PDF.FONTSAVAILABLE) + (CREATECHARSET \CREATECHARSET.PSC) + (FONTEXISTS? POSTSCRIPT.FONTEXISTS?))) (ADDTOVAR DEFAULTFILETYPELIST (PDF . BINARY)) @@ -123,6 +126,14 @@ (LET ((TSTREAM (OPENTEXTSTREAM FILE))) (TEDIT.FORMAT.HARDCOPY FILE PDFFILE T NIL NIL NIL 'PDF) (CLOSEF TSTREAM]) + +(PDF.FONTSAVAILABLE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 16-Jun-2025 00:46 by rmk") + (* ; "Edited 12-Jan-88 13:04 by Matt Heffron") + + (* ;; "") + + (POSTSCRIPT.FONTSAVAILABLE FAMILY SIZE FACE ROTATION 'PDF]) ) (FONTPROFILE.ADDDEVICE 'PDF 'POSTSCRIPT) @@ -292,8 +303,8 @@ thereis (ShellWhich (CAR TEMPLATE]) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3263 5877 (PDFFILEP 3273 . 4187) (PDF.HARDCOPYW 4189 . 4787) (PDF.TEXT 4789 . 5506) ( -PDF.TEDIT 5508 . 5875)) (6317 13962 (OPEN-PDF-STREAM 6327 . 9048) (CLOSE-PDF-STREAM 9050 . 10337) ( -PS-TO-PDF 10339 . 13960)) (13963 14527 (SEE-PDF 13973 . 14525)) (14578 14862 (PDFCONVERTER 14588 . -14860))))) + (FILEMAP (NIL (3460 6401 (PDFFILEP 3470 . 4384) (PDF.HARDCOPYW 4386 . 4984) (PDF.TEXT 4986 . 5703) ( +PDF.TEDIT 5705 . 6072) (PDF.FONTSAVAILABLE 6074 . 6399)) (6841 14486 (OPEN-PDF-STREAM 6851 . 9572) ( +CLOSE-PDF-STREAM 9574 . 10861) (PS-TO-PDF 10863 . 14484)) (14487 15051 (SEE-PDF 14497 . 15049)) (15102 + 15386 (PDFCONVERTER 15112 . 15384))))) STOP diff --git a/library/PDFSTREAM.LCOM b/library/PDFSTREAM.LCOM index 7d4e4dbe6..3c1bd1890 100644 Binary files a/library/PDFSTREAM.LCOM and b/library/PDFSTREAM.LCOM 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..032d77d03 100644 Binary files a/library/PRESS.LCOM and b/library/PRESS.LCOM differ diff --git a/library/tedit/TEDIT-STREAM b/library/tedit/TEDIT-STREAM index c5592e9bf..d51b55fb7 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 "14-Jul-2025 22:57:32" {WMEDLEY}tedit>TEDIT-STREAM.;904 191638 :EDIT-BY rmk - :CHANGES-TO (FNS \TEDIT.OPENTEXTSTREAM.PIECES) + :CHANGES-TO (FNS \TEDIT.TEXTDSPFONT) - :PREVIOUS-DATE "26-Apr-2025 12:59:53" {WMEDLEY}tedit>TEDIT-STREAM.;900) + :PREVIOUS-DATE "10-Jul-2025 11:29:53" {WMEDLEY}tedit>TEDIT-STREAM.;903) (PRETTYCOMPRINT TEDIT-STREAMCOMS) @@ -1766,7 +1766,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 +1818,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 +1937,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 +1949,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 @@ -3132,34 +3135,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 (37549 68365 (\TEDIT.TEXTBIN 37559 . 48309) (\TEDIT.TEXTPEEKBIN 48311 . 53861) ( +\TEDIT.TEXTBACKFILEPTR 53863 . 59536) (\TEDIT.TEXTBOUT 59538 . 64155) (\TEDIT.INSTALL.FILEBUFFER 64157 + . 68363)) (69263 73554 (\TEDIT.TEXTOUTCHARFN 69273 . 70829) (\TEDIT.TEXTINCCODEFN 70831 . 71570) ( +\TEDIT.TEXTBACKCCODEFN 71572 . 72164) (\TEDIT.TEXTFORMATBYTESTREAM 72166 . 73003) ( +\TEDIT.TEXTFORMATBYTESTRING 73005 . 73552)) (73601 85242 (OPENTEXTSTREAM 73611 . 80563) ( +COPYTEXTSTREAM 80565 . 84465) (TEDIT.STREAMCHANGEDP 84467 . 84769) (TXTFILE 84771 . 85240)) (85243 +116154 (\TEDIT.REOPENTEXTSTREAM 85253 . 86605) (\TEDIT.OPENTEXTSTREAM.PIECES 86607 . 91541) ( +\TEDIT.OPENTEXTSTREAM.PROPS 91543 . 92645) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL 92647 . 97888) ( +\TEDIT.OPENTEXTSTREAM.WINDOW 97890 . 100681) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS 100683 . 103653) ( +\TEDIT.OPENTEXTFILE 103655 . 105368) (\TEDIT.CREATE.TEXTSTREAM 105370 . 106415) (\TEDIT.REOPEN.STREAM +106417 . 108753) (\TEDIT.TEXTINIT 108755 . 116152)) (116192 117380 (\TEDIT.TTYBOUT 116202 . 117378)) ( +117498 137495 (\TEDIT.TEXTCLOSEF 117508 . 118832) (\TEDIT.TEXTDSPFONT 118834 . 120032) ( +\TEDIT.TEXTEOFP 120034 . 121789) (\TEDIT.TEXTGETEOFPTR 121791 . 122114) (\TEDIT.TEXTSETEOFPTR 122116 + . 123403) (\TEDIT.TEXTGETFILEPTR 123405 . 126240) (\TEDIT.TEXTSETFILEINFO 126242 . 126750) ( +\TEDIT.TEXTOPENF 126752 . 127683) (\TEDIT.TEXTSETEOF 127685 . 128301) (\TEDIT.TEXTSETFILEPTR 128303 . +130413) (\TEDIT.TEXTDSPXPOSITION 130415 . 131432) (\TEDIT.TEXTDSPYPOSITION 131434 . 132175) ( +\TEDIT.TEXTLEFTMARGIN 132177 . 132768) (\TEDIT.TEXTCOLOR 132770 . 133353) (\TEDIT.TEXTRIGHTMARGIN +133355 . 136644) (\TEDIT.TEXTDSPCHARWIDTH 136646 . 136950) (\TEDIT.TEXTDSPSTRINGWIDTH 136952 . 137258) + (\TEDIT.TEXTDSPLINEFEED 137260 . 137493)) (137533 150009 (\TEDIT.NTHCHARCODE 137543 . 138994) ( +\TEDIT.PIECE.NTHCHARCODE 138996 . 142906) (\TEDIT.RPLCHARCODE 142908 . 144366) ( +\TEDIT.PIECE.RPLCHARCODE 144368 . 149654) (\TEDIT.NTHCHARLOOKS 149656 . 150007)) (151056 172041 ( +\TEDIT.DELETE.SELPIECES 151066 . 154691) (\TEDIT.INSERTCH 154693 . 162623) (\TEDIT.INSERTCH.HISTORY +162625 . 166089) (\TEDIT.INSERTEOL 166091 . 167916) (\TEDIT.INSERTCH.INSERTION 167918 . 170755) ( +\TEDIT.INSERTCH.EXTEND 170757 . 172039)) (172042 173546 (\TEDIT.NEXTCHANGEABLE.CHNO 172052 . 172767) ( +\TEDIT.LASTCHANGEABLE.CHNO 172769 . 173544)) (173547 175251 (\SETUPGETCH 173557 . 175249)) (175309 +179767 (\TEDIT.INSTALL.PIECE 175319 . 179765)) (179805 188819 (TEXTPROP 179815 . 180162) (GETTEXTPROP +180164 . 180408) (PUTTEXTPROP 180410 . 180667) (GETTEXTPROPS 180669 . 181113) (PUTTEXTPROPS 181115 . +182019) (TEXTPROP.ADD 182021 . 182284) (\TEDIT.TEXTPROP 182286 . 188817)) (188820 190890 ( +\TEDIT.TEXTOBJ.PROPNAMES 188830 . 189782) (\TEDIT.TEXTOBJ.PROPFETCHFN 189784 . 190300) ( +\TEDIT.TEXTOBJ.PROPSTOREFN 190302 . 190888))))) STOP diff --git a/library/tedit/TEDIT-STREAM.LCOM b/library/tedit/TEDIT-STREAM.LCOM index 69243baaf..62a75102f 100644 Binary files a/library/tedit/TEDIT-STREAM.LCOM and b/library/tedit/TEDIT-STREAM.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..a3cfa83f1 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 "17-Jul-2025 23:48:31"  +{DSK}kaplan>Local>medley3.5>working-medley>sources>FONT.;343 232594 - :EDIT-BY "mth" + :EDIT-BY rmk - :CHANGES-TO (VARS FONTCOMS) - (FNS WRITESTRIKEFONTFILE) + :CHANGES-TO (FNS FONTCREATE1) - :PREVIOUS-DATE "19-Dec-2024 15:25:17" {DSK}matt>Interlisp>medley>sources>FONT.;1) + :PREVIOUS-DATE "15-Jul-2025 11:06:43" +{DSK}kaplan>Local>medley3.5>working-medley>sources>FONT.;342) (PRETTYCOMPRINT FONTCOMS) @@ -16,13 +17,15 @@ [ (* ;; "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 (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT + GETFONTCLASSCOMPONENT) + (MACROS \GETFONTCLASSCOMPONENT \SETFONTCLASSCOMPONENT)) [COMS (* ; "MAPPING FOR DOS FILENAMES ") (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) (HELVETICA . HV) @@ -41,104 +44,134 @@ (MATH . MA) (OLDENGLISH . OE) (SYMBOL . SY] + (VARS NSFONTFAMILIES ALTOFONTFAMILIES) (COMS (* ;; "Creation: ") - (FNS FONTCREATE \FONT.SYMBOLMEMB \FONT.SYMBOLASSOC \FONT.COMPARESYMBOL)) + (FNS FONTCREATE FONTCREATE1 FONTCREATE.SLUGFD \FONT.CHECKARGS \FONTCREATE1.NOFN + FONTFILEP) + (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)) (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 + \COERCEFONTDESC SETFONTCHARENCODING) + (FNS FONTSAVAILABLE \FONTSAVAILABLE.INCORE \SEARCHFONTFILES FONTEXISTS? FLUSHFONTSINCORE + MATCHFONTFACE FINDFONTFILES \READCHARSET) + (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) + (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))) (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 +182,11 @@ (* ;; "font functions ") +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SYSLOAD) + MULTI-ALIST) +) (DEFINEQ (CHARWIDTH @@ -168,26 +206,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 +271,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 +286,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 +333,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,39 +416,65 @@ (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 - - -(* ; "Until we pin down the exact interface") - - -(MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT) - -(MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT) +(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)))) +) @@ -445,6 +500,10 @@ (OLDENGLISH . OE) (SYMBOL . SY))) +(RPAQQ NSFONTFAMILIES (CLASSIC MODERN TERMINAL OPTIMA TITAN BOLDPS PCTERMINAL)) + +(RPAQQ ALTOFONTFAMILIES (GACHA TIMESROMAN TIMESROMAND HELVETICA OLDENGLISH SNAIL TONTO)) + (* ;; "Creation: ") @@ -453,211 +512,282 @@ (FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) + (* ; "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.") - (* ;; - "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 - (* ; - "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))) + (* ;; "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. ") - (* ;; "Device is valid, font just doesn't exist. FONTFACE, DEV already canonical. Make FAMILY so, so that each imagestream type doesn't have to.") + (* ;; "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.") - (SETQ FAMILY (\FONTSYMBOL FAMILY)) - (COND - ((SETQ FONTX (APPLY* (OR (CADR (ASSOC 'FONTCREATE FONTX) - ) - (FUNCTION NILL)) - FAMILY SIZE FONTFACE ROTATION DEV - CHSET)) + (PROG (FONTX) + RETRY + (* ; "Back to here if ERROR returns") + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTX) + (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE CHARSET)) - (* ;; "default creation case. Use fontcreate method from device, build a fontdescriptor and use setfontdescriptor to install it.") + (* ;; "If FONTX is non-NIL, it is already the desired font descriptor.") - (* ;; "OBSOLETEd by the CHARSETINFO code (OR (ffetch FONTIMAGEWIDTHS of FONTX) (freplace FONTIMAGEWIDTHS of FONTX with (ffetch \SFWidths of FONTX)))") + (RETURN (if FONTX + elseif (FONTCREATE1 FAMILY SIZE FACE ROTATION DEVICE CHARSET) + elseif NOERRORFLG + then NIL + else (ERROR "FONT NOT FOUND" (LIST FAMILY SIZE FACE ROTATION DEVICE)) + (GO RETRY]) + +(FONTCREATE1 + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "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 (AND (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 (APPLY* (OR [CADR (ASSOC 'FONTCREATE + (CDR (ASSOC DEVICE + IMAGESTREAMTYPES + ] + (FUNCTION \FONTCREATE1.NOFN)) + FAMILY SIZE FACE ROTATION DEVICE CHARSET)) + (\INSURECHARSETINFO CHARSET FONTX)) + then (PUTMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE FONTX)) + (\INSURECHARSETINFO CHARSET 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 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 as the FONTX argument.") + + (DECLARE (GLOBALVARS \DEFAULTCHARSET)) + (LET (FONTX) + (SETQ DEVICE (if (NULL DEVICE) + then '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 (\COERCEFONTDESC (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 + (\COERCEFONTDESC FAMILY DEVICE T))) + then + (* ;; + "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)) + (if (NULL CHARSET) + then (SETQ CHARSET \DEFAULTCHARSET) + elseif (<= 0 CHARSET \MAXCHARSET) + else (\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))) + (CL:VALUES FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTX]) + +(\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))))]) +) +(DEFINEQ +(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 (* ;; - "the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.") - - (* ;; "We should probably force all device implementations to obey these conventions, then remove these generic updates") - - (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))) - - (* ;; "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.") - - (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") + "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 +797,34 @@ (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 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 +839,14 @@ (BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT))) (ROTATION (ffetch ROTATION of FONT)) (DEVICE (ffetch FONTDEVICE of FONT)) + (CHARENCODING (ffetch FONTCHARENCODING 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 +856,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 +877,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 + (* ; + "update the parameters for this character set.") + (\FSETWIDTH WIDTHS CODE BWIDTH) (* ; "The new character's correct width") (* ; - "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]) + "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,346 +1132,674 @@ (IPLUS NEWASCENT NEWDESCENT] (PUTCHARBITMAP DESTCODE DESTFONT (OR TEMPBITMAP CHARBITMAP) NEWDESCENT]) -) -(DEFINEQ -(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) +(MOVEFONTCHARS + [LAMBDA (PAIRS DEVICE DESTFONT DEFAULTSOURCEFONT) (* ; "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.") + + (* ;; "For DISPLAY devices (the default), the bitmap is also moved.") + + (CL:UNLESS DEVICE + (SETQ DEVICE 'DISPLAY)) + (SETQ DESTFONT (FONTCREATE DESTFONT NIL NIL NIL DEVICE)) + (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 PAIRS (for P S SCODE SFONT DCODE 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))) + (SETQ SCODE (CL:IF (LISTP S) + (CAR S) + S)) + (CL:UNLESS (CHARCODEP S) + (SETQ SCODE (CHARCODE.DECODE SCODE))) + (SETQ SFONT (CL:IF (LISTP S) + (FONTCREATE (CADR S) + NIL NIL NIL DEVICE) + DEFAULTSOURCEFONT)) + (LIST (LIST SCODE (\GETCHARINFO (\INSURECHARSETINFO (\CHARSET SCODE) + SFONT) + (\CHAR8CODE SCODE))) + DCODE))) + + (* ;; "Install source character information into the destination font. ") + + (for P DCHARCODE DCSINFO ASCENT DESCENT in PAIRS + do (SETQ DCHARCODE (CADR P)) + (SETQ DCSINFO (\INSURECHARSETINFO (\CHARSET DCHARCODE) + DESTFONT)) + (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 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) + + (* ;; "We have to split the width and imagewidth vectors in preparation, if the source values are different but the dest vectors are EQ. ") + + (CL:WHEN [AND (NEQ (FGETMULTI SCHARINFO 'WIDTH) + (FGETMULTI SCHARINFO 'IMAGEWIDTH)) + (OR (EQ (ffetch (CHARSETINFO WIDTHS) of DCSINFO) + (ffetch (CHARSETINFO IMAGEWIDTHS) of DCSINFO)) + (NULL (ffetch (CHARSETINFO IMAGEWIDTHS) of DCSINFO] + (replace (CHARSETINFO IMAGEWIDTHS) of DCSINFO with (\COPYARRAYBLOCK (ffetch (CHARSETINFO + WIDTHS) + of DCSINFO)))) + (CL:WHEN (FGETMULTI SCHARINFO 'BITMAP) + (\PUTCHARBITMAP.CSINFO DCODE DCSINFO (FGETMULTI SCHARINFO 'BITMAP) + (FGETMULTI SCHARINFO 'DESCENT))) + (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of DCSINFO) + DCODE + (FGETMULTI SCHARINFO 'WIDTH)) + (\FSETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) of DCSINFO) + DCODE + (FGETMULTI SCHARINFO 'IMAGEWIDTH)) + (CL:WHEN (AND (FGETMULTI SCHARINFO 'YWIDTH) + (ffetch (CHARSETINFO YWIDTHS) of DCSINFO)) + (* ; "Is YWIDTHS real?") + (\FSETWIDTH (ffetch (CHARSETINFO YWIDTHS) of DCSINFO) + DCODE + (FGETMULTI SCHARINFO 'YWIDTH))) + (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 8-Jul-2025 22:50 by rmk") + (* ; "Edited 7-Jun-2025 14:35 by rmk") + + (* ;; "Extracts the information about CHAR8CODE from its CSINFO, holding it against the possibility that the CSINFO gets smashed.") + + `((ASCENT \, (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) + (DESCENT \, (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (WIDTH \, (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of CSINFO) + CHAR8CODE)) + (YWIDTH \, (\FGETWIDTH (ffetch (CHARSETINFO YWIDTHS) of CSINFO) + CHAR8CODE)) + (IMAGEWIDTH \, (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) + CHAR8CODE)) + (LEFTKERN \, (CL:WHEN (ARRAYP (fetch (CHARSETINFO LEFTKERN) of CSINFO)) + (ELT (fetch (CHARSETINFO LEFTKERN) of CSINFO) + CHAR8CODE))) + ,@(CL:WHEN (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO) + (LIST (CONS 'BITMAP (\GETCHARBITMAP.CSINFO CHAR8CODE CSINFO))))]) +) - (* ;; "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]) - (* ;; "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") +(\FONTFILENAME.NEW + [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 30-Mar-87 20:00 by FS") - (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM) - (SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM)) - (ffetch DDWIDTHSCACHE of WIDTHSVECTOR)) - \UNITWIDTHSVECTOR)) - (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA) - of (OR (TERMTABLEP TTBL) - \PRIMTERMTABLE)) - CHARCODE)) - (INDICATE.CCE ([LAMBDA (CC) - (IPLUS (if (IGEQ CHARCODE (CHARCODE %#^@)) - then (* ; - "A META charcode -- implies that the 8th bit is non-zero") - (SETQ CC (LOADBYTE CHARCODE 0 7)) - (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#)) - else 0) - (if (ILESSP CC (CHARCODE SPACE)) - then (* ; "A CONTROL charcode") - (add CC (CONSTANT (LLSH 1 6))) - (\FGETWIDTH WIDTHSVECTOR (CHARCODE ^)) - else 0) - (\FGETWIDTH WIDTHSVECTOR CC] - CHARCODE)) + (* ;; "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 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)) + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE) + (\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") + + (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM) + (SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM)) + (ffetch DDWIDTHSCACHE of WIDTHSVECTOR)) + \UNITWIDTHSVECTOR)) + (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA) + of (OR (TERMTABLEP TTBL) + \PRIMTERMTABLE)) + CHARCODE)) + (INDICATE.CCE ([LAMBDA (CC) + (IPLUS (if (IGEQ CHARCODE (CHARCODE %#^@)) + then (* ; + "A META charcode -- implies that the 8th bit is non-zero") + (SETQ CC (LOADBYTE CHARCODE 0 7)) + (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#)) + else 0) + (if (ILESSP CC (CHARCODE SPACE)) + then (* ; "A CONTROL charcode") + (add CC (CONSTANT (LLSH 1 6))) + (\FGETWIDTH WIDTHSVECTOR (CHARCODE ^)) + else 0) + (\FGETWIDTH WIDTHSVECTOR CC] + CHARCODE)) (SIMULATE.CCE (SELCHARQ CHARCODE ((EOL CR LF BELL) NIL) @@ -1345,287 +1838,90 @@ (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") +(\COERCECHARSET + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS THINCODE) + (* ; "Edited 8-Jul-2025 08:14 by rmk") + (* ; "Edited 21-Jun-2025 09:10 by rmk") + (* ; "Edited 15-Jun-2025 15:20 by rmk") + (* ; "Edited 12-Jun-2025 21:21 by rmk") + (* ; "Edited 11-Jun-2025 09:13 by rmk") + (* ; "Edited 8-Jun-2025 19:36 by rmk") + (* ; "Edited 7-Jun-2025 13:39 by rmk") + (* ; "Edited 21-May-2025 10:50 by rmk") + (* ; "Edited 17-May-2025 21:32 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.") + + (* ;; "But if THINCODE is provided, this passes over the candidate character sets that don't instantiate THINCODE.") + + (* ;; " ") + + (for C CSINFO OLDSPEC NEWSPEC NEWFONT in COERCIONS + when [AND (SETQ OLDSPEC (CAR C)) + (EQ FAMILY (pop OLDSPEC)) + (OR (NOT (CAR OLDSPEC)) + (EQ SIZE (CAR OLDSPEC))) + (OR (NOT (CADR OLDSPEC)) + (EQ CHARSET (CADR OLDSPEC))) + (SETQ NEWSPEC (CADR C)) + (SETQ NEWFONT (FONTCREATE1 (OR (CAR NEWSPEC) + FAMILY) + (OR (CADR NEWSPEC) + SIZE) + FACE ROTATION DEVICE (OR (CADDR NEWSPEC) + CHARSET))) + (SETQ CSINFO (\INSURECHARSETINFO (OR (CADDR NEWSPEC) + CHARSET) + NEWFONT)) + (NOT (AND THINCODE (SLUGCHARP.DISPLAY THINCODE CSINFO] do (RETURN CSINFO]) - (* ;; "(PROG (XCSINFO)") - - (* ;; "(SETQ XCSINFO &)") +(\BUILDSLUGCSINFO + [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]) - (* ;; "(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)))))") +(\FONTSYMBOL + [LAMBDA (X ElseReturnXFlg) (* ; "Edited 28-Jul-88 11:59 by rmk:") + (* ; "Edited 24-Mar-87 14:32 by FS") - (* ;; "(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]) - -(\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]) - -(\FONTSYMBOL - [LAMBDA (X ElseReturnXFlg) (* ; "Edited 28-Jul-88 11:59 by rmk:") - (* ; "Edited 24-Mar-87 14:32 by FS") - - (* ;; "Return a symbol in IL package and is in uppercase. Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook. ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.") + (* ;; "Return a symbol in IL package and is in uppercase. Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook. ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.") (COND ((LITATOM X) @@ -1652,7 +1948,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 +1959,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 +2030,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 +2052,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 +2198,582 @@ (NOERRORFLG (RETURN NIL)) (T (\ILLEGAL.ARG FACE]) -(\FONTFILENAME - [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 5-Mar-93 16:10 by rmk:") - - (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported. New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD") - - (* ;; "**bvm 10/5/89 Slight change: partition fonts into subdirectories by charset, e.g., all Charset zero fonts are in subdirectory C0>. This significantly speeds up any font operation that requires any local directory work (e.g., NFS servers on both Sun and D machine), and FONTSAVAILABLE on any device (since it doesn't have to wade thru all those charsets). This behavior is conditioned on the value of *USEOLDFONTDIRECTORIES*") - - (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) + [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "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 NOERROR + 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]) + +(SETFONTCHARENCODING + [LAMBDA (FONT CHARENCODING) (* ; "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") + + (* ;; "The FONT charencoding is the same as its charset 0 encoding (e.g. ALTOTEXT). But all higher charsets are MCCS") + + (replace (FONTDESCRIPTOR FONTCHARENCODING) of (FONTCREATE FONT) with CHARENCODING) + (CHARSETINFOPROP (\XGETCHARSETINFO FONT 0) + 'CSCHARENCODING CHARENCODING]) +) +(DEFINEQ - (* ;; - "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-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.") + + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE) + (\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)))]) + +(\FONTSAVAILABLE.INCORE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "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)) + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE) + (\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 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:") + + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE) + (\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]) + +(FONTEXISTS? + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "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.") + + (DECLARE (GLOBALVARS \FONTSINCORE \FONTEXISTS?-CACHE IMAGESTREAMTYPES)) + (LET (VAL) + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE) + (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE CHARSET VAL)) + (if (type? FONTDESCRIPTOR VAL) + then + (* ;; "FAMILY was a font descriptor") + + VAL + elseif (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)))) + (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET + (OR VAL 'NO]) + +(FLUSHFONTSINCORE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "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))]) + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE) + (\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 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") + + (CL:MULTIPLE-VALUE-SETQ (FAMILY SIZE FACE ROTATION DEVICE) + (\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]) + +(\READCHARSET + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "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)) + (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)))))]) ) +(RPAQ? \FONTEXISTS?-CACHE NIL) -(* ;; -"\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) -) - - - -(* ; "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.") - - (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]) - -(\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]) - -(\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]) - -(\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)))) +(\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]) - (* ;; "If you uncomment out the code above, remove this comment and the NIL below") +(\CREATECHARSET.DISPLAY + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC)(* ; "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 21-Jun-2025 21:37 by rmk") + (* ; "Edited 18-Jun-2025 23:11 by rmk") + (* ; "Edited 12-Jun-2025 21:17 by rmk") + (* ; "Edited 11-Jun-2025 10:54 by rmk") + (* ; "Edited 8-Jun-2025 19:57 by rmk") + (* ; "Edited 7-Jun-2025 14:47 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") - NIL]) + (* ;; "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. ") -(\SFROTATECSINFO - [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38") + (* ;; "After that, it uses requested source files and/or DISPLAYGLYPHCOERCIONS to produce and complete the CHARSETINFO:") - (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.") + (* ;; "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.") - (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS - (fetch (CHARSETINFO CHARSETBITMAP) - of CSINFO) - ROTATION) - OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION]) + (* ;; "If an exact match file cannot be found for a requested rotation, the rotation 0 charset is obtained and rotated.") -(\SFROTATEFONTCHARACTERS - [LAMBDA (CHARBITMAP ROTATION) (* ; "Edited 22-Sep-87 10:38 by Snow") + (* ;; "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.") -(* ;;; "rotate a bitmap either 90 or 270 for fonts.") + (* ;; "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.") - (CASE ROTATION - (0 CHARBITMAP) - (90 (ROTATE-BITMAP-LEFT CHARBITMAP)) - (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP))) - (270 (ROTATE-BITMAP CHARBITMAP)))]) + (* ;; "If all else fails, it looks for the next charset in the coercion list, and fills that in with further coercions for missing characters.") -(\SFFIXOFFSETSAFTERROTATION - [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") + (* ;; "") - (* ;; "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)))) + (* ;; "Maybe nobody cares about Classic 36...let's remove that coercion and see what happens.") - (* ;; "If you uncomment out the code above, remove this comment and the NIL below") + (* ;; "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. ") - NIL]) + (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS DISPLAYGLYPHCOERCIONS)) + (LET (CSINFO) -(\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]) + (* ;; "If no DISPLAYFONTCOERCIONS, skip that first \COERCECHARSET call--easier debugging of the other case.") -(\SFMAKECOLOR - [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr%: " 6-Feb-86 18:17") + (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.") - (* ;; "makes a csinfo that has a character bitmap that is colorized.") + (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]) - (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]) +(\FONTEXISTS?.DISPLAY + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 13-Jul-2025 11:45 by rmk") + (* ; "Edited 22-Jun-2025 08:53 by rmk") + (* ; "Edited 15-Jun-2025 21:41 by rmk") + (for C OLDSPEC NEWSPEC VAL in (APPEND DISPLAYFONTCOERCIONS DISPLAYGLYPHCOERCIONS) + when [AND (SETQ OLDSPEC (CAR C)) + (EQ FAMILY (pop OLDSPEC)) + (OR (NOT (CAR OLDSPEC)) + (EQ SIZE (CAR OLDSPEC))) + (OR (NOT (CADR OLDSPEC)) + (EQ CHARSET (CADR OLDSPEC))) + (SETQ NEWSPEC (CADR C)) + (SETQ VAL (OR (FONTEXISTS? (OR (CAR NEWSPEC) + FAMILY) + (OR (CADR NEWSPEC) + SIZE) + FACE ROTATION DEVICE (OR (CADDR NEWSPEC) + CHARSET)) + (CL:WHEN (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) + (FONTEXISTS? (OR (CAR NEWSPEC) + FAMILY) + (OR (CADR NEWSPEC) + SIZE) + (create FONTFACE using FACE WEIGHT _ 'MEDIUM) + ROTATION DEVICE (OR (CADDR NEWSPEC) + CHARSET))) + (CL:WHEN (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE)) + (FONTEXISTS? (OR (CAR NEWSPEC) + FAMILY) + (OR (CADR NEWSPEC) + SIZE) + (create FONTFACE using FACE SLOPE _ 'REGULAR) + ROTATION DEVICE (OR (CADDR NEWSPEC) + CHARSET)))] do (RETURN VAL]) ) (DEFINEQ +(STRIKEFONT.FILEP + [LAMBDA (FILE) (* ; "Edited 15-May-2025 17:47 by rmk") + + (* ;; "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'") + + (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))]) + +(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") + + (* ;; "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") + + (* ;; "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 +2786,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 +2900,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 +3193,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 +3201,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 +3234,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 +3265,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 +3304,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 +3323,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 +3349,7 @@ (INIT (DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)))) (DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) + (FONTCOMPLETEP FLAG) (FONTFAMILY POINTER) (FONTSIZE POINTER) (FONTFACE POINTER) @@ -3009,8 +3374,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 +3407,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 +3420,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 +3437,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 +3468,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 (\COERCEFONTDESC FONTSPEC)))) (PUTPROPS FONTDESCENT MACRO ((FONTSPEC) - (ffetch \SFDescent of (\GETFONTDESC FONTSPEC)))) + (ffetch \SFDescent of (\COERCEFONTDESC FONTSPEC)))) (PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) - (ffetch \SFHeight of (\GETFONTDESC FONTSPEC)))) + (ffetch \SFHeight of (\COERCEFONTDESC FONTSPEC)))) (PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) (\GETBASE OFFSETSBLOCK CHAR8CODE))) @@ -3130,11 +3502,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 +3523,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,33 +3589,116 @@ (* "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 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 + (DECLARE (GLOBALVARS \DEFAULTCHARSET)) + (CL:UNLESS DEVICE + (SETQ DEVICE 'DISPLAY)) + (LET (FN FONT) + (CL:WHEN [AND [SETQ FN (CADR (ASSOC 'FONTCREATE (CDR (ASSOC DEVICE IMAGESTREAMTYPES] + (SETQ FONT (APPLY* FN (\FONTSYMBOL FAMILY) + SIZE + (\FONTFACE FACE) + (OR ROTATION 0) + DEVICE + (OR CHARSET \DEFAULTCHARSET] + (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 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") @@ -3226,26 +3706,26 @@ (* ;  "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 (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FONT) + (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,46 +3747,93 @@ (* ;; "\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) (DEFINEQ @@ -3341,12 +3868,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 +3899,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 +3922,40 @@ (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 (10972 20418 (CHARWIDTH 10982 . 11767) (CHARWIDTHY 11769 . 13242) (STRINGWIDTH 13244 . +14337) (\CHARWIDTH.DISPLAY 14339 . 14752) (\STRINGWIDTH.DISPLAY 14754 . 15178) (\STRINGWIDTH.GENERIC +15180 . 20416)) (20419 26939 (DEFAULTFONT 20429 . 21714) (FONTCLASS 21716 . 23878) (FONTCLASSUNPARSE +23880 . 24779) (FONTCLASSCOMPONENT 24781 . 25369) (SETFONTCLASSCOMPONENT 25371 . 25813) ( +GETFONTCLASSCOMPONENT 25815 . 26937)) (29168 41983 (FONTCREATE 29178 . 31512) (FONTCREATE1 31514 . +33829) (FONTCREATE.SLUGFD 33831 . 35447) (\FONT.CHECKARGS 35449 . 40984) (\FONTCREATE1.NOFN 40986 . +41200) (FONTFILEP 41202 . 41981)) (41984 47275 (COMPLETE.FONT 41994 . 43975) (COMPLETEFONTP 43977 . +44492) (COMPLETE.CHARSET 44494 . 46661) (PRUNEFONTSLUGS 46663 . 47273)) (47314 53935 (FONTASCENT 47324 + . 47708) (FONTDESCENT 47710 . 48195) (FONTHEIGHT 48197 . 48599) (FONTPROP 48601 . 53212) ( +\AVGCHARWIDTH 53214 . 53933)) (53982 54631 (EDITCHAR 53992 . 54629)) (54677 66243 (GETCHARBITMAP 54687 + . 55509) (PUTCHARBITMAP 55511 . 57588) (\GETCHARBITMAP.CSINFO 57590 . 59497) (\PUTCHARBITMAP.CSINFO +59499 . 66241)) (66244 78206 (MOVECHARBITMAP 66254 . 68148) (MOVEFONTCHARS 68150 . 72277) ( +\MOVEFONTCHAR 72279 . 76071) (SLUGCHARP.DISPLAY 76073 . 76971) (\GETCHARINFO 76973 . 78204)) (78482 +97735 (FONTFILES 78492 . 79961) (\FINDFONTFILE 79963 . 81680) (\FONTFILENAMES 81682 . 82556) ( +\FONTFILENAME 82558 . 86541) (\FONTFILENAME.OLD 86543 . 89492) (\FONTFILENAME.NEW 89494 . 91751) ( +\FONTINFOFROMFILENAME 91753 . 95454) (\FONTINFOFROMFILENAME.OLD 95456 . 97733)) (98002 137956 ( +FONTCOPY 98012 . 103075) (FONTP 103077 . 103376) (FONTUNPARSE 103378 . 105942) (SETFONTDESCRIPTOR +105944 . 107135) (\STREAMCHARWIDTH 107137 . 111301) (\UNITWIDTHSVECTOR 111303 . 111666) ( +\COERCECHARSET 111668 . 114145) (\BUILDSLUGCSINFO 114147 . 116903) (\FONTSYMBOL 116905 . 117555) ( +\DEVICESYMBOL 117557 . 118426) (\FONTFACE 118428 . 125618) (\FONTFACE.COLOR 125620 . 132540) ( +\COERCEFONTDESC 132542 . 136952) (SETFONTCHARENCODING 136954 . 137954)) (137957 155291 (FONTSAVAILABLE + 137967 . 139857) (\FONTSAVAILABLE.INCORE 139859 . 141352) (\SEARCHFONTFILES 141354 . 144327) ( +FONTEXISTS? 144329 . 146929) (FLUSHFONTSINCORE 146931 . 148024) (MATCHFONTFACE 148026 . 148841) ( +FINDFONTFILES 148843 . 151177) (\READCHARSET 151179 . 155289)) (155384 165691 (\CREATEDISPLAYFONT +155394 . 156990) (\CREATECHARSET.DISPLAY 156992 . 163362) (\FONTEXISTS?.DISPLAY 163364 . 165689)) ( +165692 178893 (STRIKEFONT.FILEP 165702 . 166590) (STRIKEFONT.GETCHARSET 166592 . 171427) ( +WRITESTRIKEFONTFILE 171429 . 175433) (STRIKECSINFO 175435 . 178891)) (178924 190634 (MAKEBOLD.CHARSET +178934 . 180765) (MAKEBOLD.CHAR 180767 . 182097) (MAKEITALIC.CHARSET 182099 . 183936) (MAKEITALIC.CHAR + 183938 . 185971) (\SFMAKEBOLD 185973 . 187979) (\SFMAKEITALIC 187981 . 190632)) (190635 194340 ( +\SFMAKEROTATEDFONT 190645 . 192046) (\SFROTATECSINFO 192048 . 192685) (\SFROTATEFONTCHARACTERS 192687 + . 193067) (\SFROTATECSINFOOFFSETS 193069 . 194338)) (194341 195722 (\SFMAKECOLOR 194351 . 195720)) ( +195723 197790 (FONTDESCRIPTOR.DEFPRINT 195733 . 197312) (FONTCLASS.DEFPRINT 197314 . 197788)) (218287 +220831 (\CREATEKERNELEMENT 218297 . 218655) (\FSETLEFTKERN 218657 . 219148) (\FGETLEFTKERN 219150 . +220829)) (220832 227552 (\CREATEFONT 220842 . 222007) (\CREATECHARSET 222009 . 224611) ( +\INSTALLCHARSETINFO 224613 . 226639) (\INSTALLCHARSETINFO.CHARENCODING 226641 . 227550)) (229447 +231199 (\FONTRESETCHARWIDTHS 229457 . 231197))))) STOP diff --git a/sources/FONT.LCOM b/sources/FONT.LCOM index 4f13ebbee..dc0f69c7c 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..6a2641114 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..7972f07a3 100644 Binary files a/sources/INTERPRESS.LCOM and b/sources/INTERPRESS.LCOM differ diff --git a/sources/LLDISPLAY b/sources/LLDISPLAY index 634f7a058..a5129d813 100644 --- a/sources/LLDISPLAY +++ b/sources/LLDISPLAY @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "31-Jul-2023 14:50:58" {WMEDLEY}LLDISPLAY.;19 270570 +(FILECREATED "14-Jul-2025 22:06:59" {WMEDLEY}LLDISPLAY.;23 272681 :EDIT-BY rmk - :CHANGES-TO (FNS BITMAPEQUAL) + :CHANGES-TO (FNS \DSPFONT.DISPLAY) - :PREVIOUS-DATE "31-Jul-2023 14:45:32" {WMEDLEY}LLDISPLAY.;18) + :PREVIOUS-DATE " 8-Jul-2025 20:19:45" {WMEDLEY}LLDISPLAY.;22) (PRETTYCOMPRINT LLDISPLAYCOMS) @@ -30,9 +30,10 @@ [COMS (* ; "bitmap functions.") (FNS BITBLT BLTSHADE \BITBLTSUB \GETPILOTBBTSCRATCHBM BITMAPCOPY BITMAPCREATE BITMAPBIT BITMAPEQUAL BLTCHAR \BLTCHAR \MEDW.BLTCHAR \CHANGECHARSET.DISPLAY \INDICATESTRING - \SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH READBITMAP - \INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR MAXIMUMSHADE OPPOSITESHADE - \MEDW.BITBLT) + \SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH + BITMAPHEIGHT READBITMAP \INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR + MAXIMUMSHADE OPPOSITESHADE \MEDW.BITBLT) + (FNS \READBINARYBITMAP \PRINTBINARYBITMAP) (FUNCTIONS FINISH-READING-BITMAP) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) @@ -1361,6 +1362,18 @@ (WINDOWPROP BITMAP 'WIDTH)) (T (\ILLEGAL.ARG BITMAP]) +(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]) + (READBITMAP [LAMBDA (FILE) (* ; "Edited 8-Aug-2021 00:18 by rmk:") @@ -1501,6 +1514,44 @@ (T (SHOULDNT "Invalid argument to \XW.BIBLT"))) T]) ) +(DEFINEQ + +(\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]) + +(\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]) +) (CL:DEFUN FINISH-READING-BITMAP (STREAM) @@ -3249,34 +3300,33 @@ (\INVALIDATEDISPLAYCACHE DD))])]) (\DSPFONT.DISPLAY - [LAMBDA (DISPLAYSTREAM FONT) (* ; "Edited 11-Nov-87 15:36 by FS") + [LAMBDA (DISPLAYSTREAM FONT) (* ; "Edited 14-Jul-2025 22:06 by rmk") + (* ; "Edited 11-Nov-87 15:36 by FS") (* ;; "sets the font that a display stream uses to print characters. DISPLAYSTREAM is guaranteed to be a stream of type display") (PROG (XFONT OLDFONT DD) (SETQ DD (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (* ; - "save old value to return, smash new value and update the bitchar portion of the record.") + "save old value to return, smash new value and update the bitchar portion of the record.") (RETURN (PROG1 (SETQ OLDFONT (fetch (\DISPLAYDATA DDFONT) of DD)) [COND (FONT (* ;; "Either FONT is coerceable to a font, or its a proplist of ways to change the current font (see IRM), otherwise an error.") - (SETQ XFONT (OR (\COERCEFONTDESC FONT DISPLAYSTREAM T) - (FONTCOPY (ffetch (\DISPLAYDATA DDFONT) - of DD) + (SETQ XFONT (OR (FONTCREATE FONT NIL NIL NIL DISPLAYSTREAM T) + (FONTCOPY (ffetch (\DISPLAYDATA DDFONT) of DD) (CONS 'NOERROR (CONS T FONT))) (ERROR "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER") )) (* ; - "updating font information is fairly expensive operation. Don't bother unless font has changed.") + "updating font information is fairly expensive operation. Don't bother unless font has changed.") (OR (EQ XFONT OLDFONT) (UNINTERRUPTABLY (freplace (\DISPLAYDATA DDFONT) of DD with XFONT) (freplace (\DISPLAYDATA DDLINEFEED) of DD - with (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) - of XFONT))) + with (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of XFONT))) (* ; - "This will be difference when spacefactor is implemented for the display. ") + "This will be difference when spacefactor is implemented for the display. ") (freplace (\DISPLAYDATA DDSPACEWIDTH) of DD with (\FGETCHARWIDTH XFONT (CHARCODE SPACE))) (\SFFixFont DISPLAYSTREAM DD))])]) @@ -4541,14 +4591,17 @@ (DEFINEQ (INITIALIZEDISPLAYSTREAMS - [LAMBDA NIL (* lmm " 7-Jan-86 16:51") + [LAMBDA NIL (* ; "Edited 6-Jul-2025 12:57 by rmk") + (* lmm " 7-Jan-86 16:51") (SETQ WHOLEDISPLAY (create REGION)) - (SETQ \SYSPILOTBBT (create PILOTBBT)) (* ; "For BITBLT") - (SETQ \SYSBBTEXTURE (BITMAPCREATE 16 16)) (* ; - "For texture handling in \BITBLTSUB") + (SETQ \SYSPILOTBBT (create PILOTBBT)) (* ; "For BITBLT") + (SETQ \SYSBBTEXTURE (BITMAPCREATE 16 16)) (* ; + "For texture handling in \BITBLTSUB") (* ; - "A guaranteed display font is initialized here after pup, font, and bitmap code has been loaded.") - (SETQ \GUARANTEEDDISPLAYFONT (FONTCREATE 'GACHA 10 NIL NIL 'DISPLAY)) + "A guaranteed display font is initialized here after pup, font, and bitmap code has been loaded.") + (SETQ \GUARANTEEDDISPLAYFONT (FONTCREATE 'GACHA 10 '(MEDIUM REGULAR REGULAR) + NIL + 'DISPLAY)) (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT (LIST 1 \GUARANTEEDDISPLAYFONT]) ) (DECLARE%: DOCOPY DONTEVAL@LOAD @@ -4573,43 +4626,44 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (20459 23127 (\FBITMAPBIT 20469 . 20929) (\FBITMAPBIT.UFN 20931 . 21950) ( -\NEWPAGE.DISPLAY 21952 . 22087) (INITBITMASKS 22089 . 23125)) (25052 25561 (\CreateCursorBitMap 25062 - . 25559)) (25678 86230 (BITBLT 25688 . 36078) (BLTSHADE 36080 . 36858) (\BITBLTSUB 36860 . 46995) ( -\GETPILOTBBTSCRATCHBM 46997 . 47612) (BITMAPCOPY 47614 . 48190) (BITMAPCREATE 48192 . 49752) ( -BITMAPBIT 49754 . 58141) (BITMAPEQUAL 58143 . 59605) (BLTCHAR 59607 . 60223) (\BLTCHAR 60225 . 60727) -(\MEDW.BLTCHAR 60729 . 65607) (\CHANGECHARSET.DISPLAY 65609 . 68567) (\INDICATESTRING 68569 . 69765) ( -\SLOWBLTCHAR 69767 . 76863) (TEXTUREP 76865 . 77135) (INVERT.TEXTURE 77137 . 77411) ( -INVERT.TEXTURE.BITMAP 77413 . 78948) (BITMAPWIDTH 78950 . 79322) (READBITMAP 79324 . 81834) ( -\INSUREBITSPERPIXEL 81836 . 82131) (MAXIMUMCOLOR 82133 . 82274) (OPPOSITECOLOR 82276 . 82455) ( -MAXIMUMSHADE 82457 . 82668) (OPPOSITESHADE 82670 . 82849) (\MEDW.BITBLT 82851 . 86228)) (86232 91418 ( -FINISH-READING-BITMAP 86232 . 91418)) (92540 93021 (BITMAPBIT.EXPANDER 92550 . 93019)) (93022 141556 ( -\BITBLT.DISPLAY 93032 . 116271) (\BITBLT.BITMAP 116273 . 125372) (\BITBLT.MERGE 125374 . 127627) ( -\BLTSHADE.DISPLAY 127629 . 134729) (\BLTSHADE.BITMAP 134731 . 141554)) (141557 150877 ( -\BITBLT.BITMAP.SLOW 141567 . 150875)) (150878 167259 (\PUNT.BLTSHADE.BITMAP 150888 . 157984) ( -\PUNT.BITBLT.BITMAP 157986 . 167257)) (167260 170700 (\SCALEDBITBLT.DISPLAY 167270 . 168903) ( -\BACKCOLOR.DISPLAY 168905 . 170698)) (174555 176828 (DISPLAYSTREAMP 174565 . 175173) (DSPSOURCETYPE -175175 . 176184) (DSPXOFFSET 176186 . 176505) (DSPYOFFSET 176507 . 176826)) (176829 191024 ( -DSPDESTINATION 176839 . 179942) (DSPTEXTURE 179944 . 180106) (\DISPLAYSTREAMINCRXPOSITION 180108 . -180395) (\SFFixDestination 180397 . 181575) (\SFFixClippingRegion 181577 . 183749) (\SFFixFont 183751 - . 184801) (\SFFIXLINELENGTH 184803 . 186299) (\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 186301 . 188114 -) (\SFFixY 188116 . 191022)) (191025 194872 (\SIMPLE.DSPCREATE 191035 . 191585) (\COMMON.DSPCREATE -191587 . 194870)) (194973 197167 (\MEDW.XOFFSET 194983 . 196124) (\MEDW.YOFFSET 196126 . 197165)) ( -197168 205094 (\DSPCLIPPINGREGION.DISPLAY 197178 . 197924) (\DSPFONT.DISPLAY 197926 . 200296) ( -\DISPLAY.PILOTBITBLT 200298 . 200447) (\DSPLINEFEED.DISPLAY 200449 . 201020) (\DSPLEFTMARGIN.DISPLAY -201022 . 201753) (\DSPOPERATION.DISPLAY 201755 . 202779) (\DSPRIGHTMARGIN.DISPLAY 202781 . 203626) ( -\DSPXPOSITION.DISPLAY 203628 . 204485) (\DSPYPOSITION.DISPLAY 204487 . 205092)) (209282 214318 ( -TTYDISPLAYSTREAM 209292 . 214316)) (214621 215651 (DSPSCROLL 214631 . 215331) (PAGEHEIGHT 215333 . -215649)) (215696 218718 (\DSPRESET.DISPLAY 215706 . 218716)) (218754 219277 (\MAYBE-DRIBBLE-CHAR -218754 . 219277)) (219278 239916 (\DSPPRINTCHAR 219288 . 227126) (\DSPPRINTCR/LF 227128 . 239914)) ( -239917 240509 (\TTYBACKGROUND 239927 . 240507)) (240510 243797 (DSPBACKUP 240520 . 243795)) (243981 -244237 (COLORDISPLAYP 243991 . 244235)) (244238 246309 (DISPLAYBEFOREEXIT 244248 . 245074) ( -DISPLAYAFTERENTRY 245076 . 246307)) (246681 251213 (\DSPCLIPTRANSFORMX 246691 . 247280) ( -\DSPCLIPTRANSFORMY 247282 . 248007) (\DSPTRANSFORMREGION 248009 . 248541) (\DSPUNTRANSFORMY 248543 . -248803) (\DSPUNTRANSFORMX 248805 . 249065) (\OFFSETCLIPPINGREGION 249067 . 251211)) (252527 255114 ( -UPDATESCREENDIMENSIONS 252537 . 253166) (\CreateScreenBitMap 253168 . 255112)) (255673 268832 ( -\CoerceToDisplayDevice 255683 . 256096) (\CREATEDISPLAY 256098 . 257938) (DISPLAYSTREAMINIT 257940 . -261084) (\STARTDISPLAY 261086 . 263997) (\MOVE.WINDOWS.ONTO.SCREEN 263999 . 266191) ( -\UPDATE.PBT.RASTERWIDTHS 266193 . 267975) (\STOPDISPLAY 267977 . 268469) (\DEFINEDISPLAYINFO 268471 . -268830)) (269440 270201 (INITIALIZEDISPLAYSTREAMS 269450 . 270199))))) + (FILEMAP (NIL (20535 23203 (\FBITMAPBIT 20545 . 21005) (\FBITMAPBIT.UFN 21007 . 22026) ( +\NEWPAGE.DISPLAY 22028 . 22163) (INITBITMASKS 22165 . 23201)) (25128 25637 (\CreateCursorBitMap 25138 + . 25635)) (25754 86684 (BITBLT 25764 . 36154) (BLTSHADE 36156 . 36934) (\BITBLTSUB 36936 . 47071) ( +\GETPILOTBBTSCRATCHBM 47073 . 47688) (BITMAPCOPY 47690 . 48266) (BITMAPCREATE 48268 . 49828) ( +BITMAPBIT 49830 . 58217) (BITMAPEQUAL 58219 . 59681) (BLTCHAR 59683 . 60299) (\BLTCHAR 60301 . 60803) +(\MEDW.BLTCHAR 60805 . 65683) (\CHANGECHARSET.DISPLAY 65685 . 68643) (\INDICATESTRING 68645 . 69841) ( +\SLOWBLTCHAR 69843 . 76939) (TEXTUREP 76941 . 77211) (INVERT.TEXTURE 77213 . 77487) ( +INVERT.TEXTURE.BITMAP 77489 . 79024) (BITMAPWIDTH 79026 . 79398) (BITMAPHEIGHT 79400 . 79776) ( +READBITMAP 79778 . 82288) (\INSUREBITSPERPIXEL 82290 . 82585) (MAXIMUMCOLOR 82587 . 82728) ( +OPPOSITECOLOR 82730 . 82909) (MAXIMUMSHADE 82911 . 83122) (OPPOSITESHADE 83124 . 83303) (\MEDW.BITBLT +83305 . 86682)) (86685 88114 (\READBINARYBITMAP 86695 . 87333) (\PRINTBINARYBITMAP 87335 . 88112)) ( +88116 93302 (FINISH-READING-BITMAP 88116 . 93302)) (94424 94905 (BITMAPBIT.EXPANDER 94434 . 94903)) ( +94906 143440 (\BITBLT.DISPLAY 94916 . 118155) (\BITBLT.BITMAP 118157 . 127256) (\BITBLT.MERGE 127258 + . 129511) (\BLTSHADE.DISPLAY 129513 . 136613) (\BLTSHADE.BITMAP 136615 . 143438)) (143441 152761 ( +\BITBLT.BITMAP.SLOW 143451 . 152759)) (152762 169143 (\PUNT.BLTSHADE.BITMAP 152772 . 159868) ( +\PUNT.BITBLT.BITMAP 159870 . 169141)) (169144 172584 (\SCALEDBITBLT.DISPLAY 169154 . 170787) ( +\BACKCOLOR.DISPLAY 170789 . 172582)) (176439 178712 (DISPLAYSTREAMP 176449 . 177057) (DSPSOURCETYPE +177059 . 178068) (DSPXOFFSET 178070 . 178389) (DSPYOFFSET 178391 . 178710)) (178713 192908 ( +DSPDESTINATION 178723 . 181826) (DSPTEXTURE 181828 . 181990) (\DISPLAYSTREAMINCRXPOSITION 181992 . +182279) (\SFFixDestination 182281 . 183459) (\SFFixClippingRegion 183461 . 185633) (\SFFixFont 185635 + . 186685) (\SFFIXLINELENGTH 186687 . 188183) (\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 188185 . 189998 +) (\SFFixY 190000 . 192906)) (192909 196756 (\SIMPLE.DSPCREATE 192919 . 193469) (\COMMON.DSPCREATE +193471 . 196754)) (196857 199051 (\MEDW.XOFFSET 196867 . 198008) (\MEDW.YOFFSET 198010 . 199049)) ( +199052 206982 (\DSPCLIPPINGREGION.DISPLAY 199062 . 199808) (\DSPFONT.DISPLAY 199810 . 202184) ( +\DISPLAY.PILOTBITBLT 202186 . 202335) (\DSPLINEFEED.DISPLAY 202337 . 202908) (\DSPLEFTMARGIN.DISPLAY +202910 . 203641) (\DSPOPERATION.DISPLAY 203643 . 204667) (\DSPRIGHTMARGIN.DISPLAY 204669 . 205514) ( +\DSPXPOSITION.DISPLAY 205516 . 206373) (\DSPYPOSITION.DISPLAY 206375 . 206980)) (211170 216206 ( +TTYDISPLAYSTREAM 211180 . 216204)) (216509 217539 (DSPSCROLL 216519 . 217219) (PAGEHEIGHT 217221 . +217537)) (217584 220606 (\DSPRESET.DISPLAY 217594 . 220604)) (220642 221165 (\MAYBE-DRIBBLE-CHAR +220642 . 221165)) (221166 241804 (\DSPPRINTCHAR 221176 . 229014) (\DSPPRINTCR/LF 229016 . 241802)) ( +241805 242397 (\TTYBACKGROUND 241815 . 242395)) (242398 245685 (DSPBACKUP 242408 . 245683)) (245869 +246125 (COLORDISPLAYP 245879 . 246123)) (246126 248197 (DISPLAYBEFOREEXIT 246136 . 246962) ( +DISPLAYAFTERENTRY 246964 . 248195)) (248569 253101 (\DSPCLIPTRANSFORMX 248579 . 249168) ( +\DSPCLIPTRANSFORMY 249170 . 249895) (\DSPTRANSFORMREGION 249897 . 250429) (\DSPUNTRANSFORMY 250431 . +250691) (\DSPUNTRANSFORMX 250693 . 250953) (\OFFSETCLIPPINGREGION 250955 . 253099)) (254415 257002 ( +UPDATESCREENDIMENSIONS 254425 . 255054) (\CreateScreenBitMap 255056 . 257000)) (257561 270720 ( +\CoerceToDisplayDevice 257571 . 257984) (\CREATEDISPLAY 257986 . 259826) (DISPLAYSTREAMINIT 259828 . +262972) (\STARTDISPLAY 262974 . 265885) (\MOVE.WINDOWS.ONTO.SCREEN 265887 . 268079) ( +\UPDATE.PBT.RASTERWIDTHS 268081 . 269863) (\STOPDISPLAY 269865 . 270357) (\DEFINEDISPLAYINFO 270359 . +270718)) (271328 272312 (INITIALIZEDISPLAYSTREAMS 271338 . 272310))))) STOP diff --git a/sources/LLDISPLAY.LCOM b/sources/LLDISPLAY.LCOM index 7aba939d9..639ff24ae 100644 --- a/sources/LLDISPLAY.LCOM +++ b/sources/LLDISPLAY.LCOM @@ -1,9 +1,9 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "31-Jul-2023 14:50:58" ("compiled on " {WMEDLEY}LLDISPLAY.;19) -"31-Jul-2023 14:48:17" "COMPILE-FILEd" in "FULL 31-Jul-2023 ..." dated "31-Jul-2023 14:48:24") -(FILECREATED "31-Jul-2023 14:50:58" {WMEDLEY}LLDISPLAY.;19 270570 :EDIT-BY rmk :CHANGES-TO ( -FNS BITMAPEQUAL) :PREVIOUS-DATE "31-Jul-2023 14:45:32" {WMEDLEY}LLDISPLAY.;18) +(FILECREATED "14-Jul-2025 22:06:59" ("compiled on " {WMEDLEY}LLDISPLAY.;23) +"14-Jul-2025 12:50:47" "COMPILE-FILEd" in "FULL 14-Jul-2025 ..." dated "14-Jul-2025 12:50:58") +(FILECREATED "14-Jul-2025 22:06:59" {WMEDLEY}LLDISPLAY.;23 272681 :EDIT-BY rmk :CHANGES-TO ( +FNS \DSPFONT.DISPLAY) :PREVIOUS-DATE " 8-Jul-2025 20:19:45" {WMEDLEY}LLDISPLAY.;22) (RPAQQ LLDISPLAYCOMS ((DECLARE%: DONTCOPY (EXPORT (RECORDS PILOTBBT \DISPLAYDATA DISPLAYSTATE DISPLAYINFO) (MACROS \GETDISPLAYDATA))) (* ; "User-visible records are on ADISPLAY --- must be init'ed here") (INITRECORDS BITMAP PILOTBBT REGION @@ -14,12 +14,13 @@ WORDMASK 65535)))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITBITMASKS)))) (COMS (* \CreateCursorBitMap) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (CursorBitMap (\CreateCursorBitMap))))) ( COMS (* ; "bitmap functions.") (FNS BITBLT BLTSHADE \BITBLTSUB \GETPILOTBBTSCRATCHBM BITMAPCOPY BITMAPCREATE BITMAPBIT BITMAPEQUAL BLTCHAR \BLTCHAR \MEDW.BLTCHAR \CHANGECHARSET.DISPLAY -\INDICATESTRING \SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH READBITMAP -\INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR MAXIMUMSHADE OPPOSITESHADE \MEDW.BITBLT) (FUNCTIONS -FINISH-READING-BITMAP) (CONSTANTS (MINIMUMCOLOR 0) (MINIMUMSHADE 0)) (P (MOVD (QUOTE BITMAPBIT) (QUOTE - \BITMAPBIT))) (DECLARE%: DONTCOPY (EXPORT (MACROS \INVALIDATEDISPLAYCACHE))) (OPTIMIZERS BITMAPBIT -BITMAPP) (FNS BITMAPBIT.EXPANDER) (FNS \BITBLT.DISPLAY \BITBLT.BITMAP \BITBLT.MERGE \BLTSHADE.DISPLAY -\BLTSHADE.BITMAP) (FNS (* ;; "For SunLoadup") \BITBLT.BITMAP.SLOW) (FNS (* ;; +\INDICATESTRING \SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH BITMAPHEIGHT +READBITMAP \INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR MAXIMUMSHADE OPPOSITESHADE \MEDW.BITBLT) ( +FNS \READBINARYBITMAP \PRINTBINARYBITMAP) (FUNCTIONS FINISH-READING-BITMAP) (CONSTANTS (MINIMUMCOLOR 0 +) (MINIMUMSHADE 0)) (P (MOVD (QUOTE BITMAPBIT) (QUOTE \BITMAPBIT))) (DECLARE%: DONTCOPY (EXPORT ( +MACROS \INVALIDATEDISPLAYCACHE))) (OPTIMIZERS BITMAPBIT BITMAPP) (FNS BITMAPBIT.EXPANDER) (FNS +\BITBLT.DISPLAY \BITBLT.BITMAP \BITBLT.MERGE \BLTSHADE.DISPLAY \BLTSHADE.BITMAP) (FNS (* ;; +"For SunLoadup") \BITBLT.BITMAP.SLOW) (FNS (* ;; " punt case for C funcs.bitblt_bitmap,bitshade.bitmap") \PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP) ( FNS (* ;; "from SUMEX-AIM") \SCALEDBITBLT.DISPLAY \BACKCOLOR.DISPLAY) (DECLARE%: DONTCOPY (CONSTANTS ( \DisplayWordAlign 16) (\MaxBitMapWidth 65535) (\MaxBitMapHeight 65535) (\MaxBitMapWords 131066)) ( @@ -192,7 +193,7 @@ BLTCHAR :D8 (42 \DISPLAYDATA 35 STREAM 24 OUTPUT) () \BLTCHAR :D8 -(P 0 A0229 I 2 DISPLAYDATA I 1 DISPLAYSTREAM I 0 CHARCODE) (Agh bÉ.ÉZ@ABlH(11 \GETSTREAM) +(P 0 A0828 I 2 DISPLAYDATA I 1 DISPLAYSTREAM I 0 CHARCODE) (Agh bÉ.ÉZ@ABlH(11 \GETSTREAM) (25 IMAGEOPS 18 STREAM 5 OUTPUT) () \MEDW.BLTCHAR :D8 @@ -205,10 +206,11 @@ BLTCHAR :D8 (256 \EM.DISPINTERRUPT 191 \TOPWDS 175 \EM.DISPINTERRUPT 167 \EM.DISPINTERRUPT 132 PILOTBBT) () \CHANGECHARSET.DISPLAY :D8 -(P 4 \INTERRUPTABLE P 2 BM P 1 CSINFO P 0 PBT I 1 CHARSET I 0 DISPLAYDATA) Š@É*@É ÉAàÐɵ A@É h "@IÉ¿@IÉ¿@IÉ0¿@A>¿IɺHJÈàààànÿÿåÍ¿@È'IÈ -ð—@È@IÈ ð©@I -¿°#JÉJÈ@ÉBÚлHKÒÍ¿HKÓÍh(98 \SFFixY 24 \CREATECHARSET) -(130 PILOTBBT 119 PILOTBBT) +(P 7 \INTERRUPTABLE P 5 BM P 4 CSINFO P 3 PBT I 1 CHARSET I 0 DISPLAYDATA) œ@É*@É ÉAàÐɵ@É ÉAàA@É +HIÐJ¿J"@LÉ¿@LÉ¿@LÉ0¿@A>¿LɽKMÈàààànÿÿåÍ¿@È'LÈ +ð—@È@LÈ ð©@L +¿°#MÉMÈ@ÉBÚоKNÒÍ¿KNÓÍh(116 \SFFixY 30 \CREATECHARSET) +(148 PILOTBBT 137 PILOTBBT) () \INDICATESTRINGA0001 :D8 (NAME SI::*UNWIND-PROTECT* I 0 SI::*CLEANUP-FORMS* F 0 SI::*RESETFORMS* F 1 CHARCODE) Hgd gi @@ -220,17 +222,18 @@ BLTCHAR :D8 (75 ^ 52 %# 16 SI::RESETUNWIND) ( 81 "" 58 "") \SLOWBLTCHAR :D8 -(P 16 CSINFO P 15 HEIGHTMOVED P 14 YPOS P 13 SOFTCURSORUP P 12 DISPINTERRUPT P 11 SOURCEBIT P 10 WIDTH P 9 DESTBIT P 8 PILOTBBT P 7 CURX P 6 RIGHT P 5 LEFT P 4 NEWX P 2 DD P 1 CHAR8CODE P 0 ROTATION I 1 DISPLAYSTREAM I 0 CHARCODE F 17 \SOFTCURSORP F 18 \SOFTCURSORUPP F 19 \CURSORDESTINATION F 20 \SCREENBITMAPS) K@@lÿåYAÉ0ZdÉ È Xdjð¢±~€ JÉ_JÉIÐÈØ\JÉñ²l A -¿JÉ_JÉIÐÈؼJL¿OJÉØ_¿JÈ"dOñ¢¿O½JÈ#LJÉØ»dKñ‘¿K¾JÉ*_¿NMñ¢± OÈ jð’±M_¿NMÙ_¿JÉIÐÈMØOÙ_¿JÉÈdkð³adlð²¿Oàà_¿Oàà_¿Oàà_°Ddlð²¿Oààà_¿Oààà_¿Oààà_°$lð²lOÚ_¿lOÚ_¿lOÚ_„¿ W"²-W$´ hA -W&ð_²`È_¿`jÍ¿¿A`ð³hA -W(–A ¿OOÍ¿OOÍ¿OOÍ¿Ojv¿OŸ¿`OÍ¿±·0JÉ_¿JÉIÐÈ_¿JÉ É@ãàÐɵ @ãJÉ h _ ¿HdlZð²;¿AOOØ +(P 16 CSINFO P 15 HEIGHTMOVED P 14 YPOS P 13 SOFTCURSORUP P 12 DISPINTERRUPT P 11 SOURCEBIT P 10 WIDTH P 9 DESTBIT P 8 PILOTBBT P 7 CURX P 6 RIGHT P 5 LEFT P 4 NEWX P 2 DD P 1 CHAR8CODE P 0 ROTATION I 1 DISPLAYSTREAM I 0 CHARCODE F 20 \SOFTCURSORP F 21 \SOFTCURSORUPP F 22 \CURSORDESTINATION F 23 \SCREENBITMAPS) b@@lÿåYAÉ0ZdÉ È Xdjð¢±~€ JÉ_JÉIÐÈØ\JÉñ²l A +¿JÉ_JÉIÐÈؼJL¿OJÉØ_¿JÈ"dOñ¢¿O½JÈ#LJÉØ»dKñ‘¿K¾JÉ*_¿NMñ¢± OÈ jð’±M_¿NMÙ_¿JÉIÐÈMØOÙ_¿JÉÈdkð³adlð²¿Oàà_¿Oàà_¿Oàà_°Ddlð²¿Oààà_¿Oààà_¿Oààà_°$lð²lOÚ_¿lOÚ_¿lOÚ_„¿ W(²-W*´ hA +W,ð_²`È_¿`jÍ¿¿A`ð³hA +W.–A ¿OOÍ¿OOÍ¿OOÍ¿Ojv¿OŸ¿`OÍ¿±Î0JÉ_¿JÉIÐÈ_¿JÉ É@ãàÐɵ$JÉ É@ãà@ãJÉ +O"O$ÐO&¿O&_ ¿HdlZð²;¿AOOØ ¿O ÉjJÉIÐÈAJÉO È ÙkØOO È O È ØO °Hnð²8AOOÙ ¿O ÉjJÉIÐÈAJÉO È ÙJÉO È -O È ØO ‰o h(583 ERROR 572 BKBITBLT 530 \DSPYPOSITION.DISPLAY 511 BKBITBLT 468 \DSPYPOSITION.DISPLAY 446 \CREATECHARSET 387 \SOFTCURSORUPCURRENT 352 \TOTOPWDS 342 DSPDESTINATION 325 \SOFTCURSORDOWN 294 DSPDESTINATION 275 SHOULDNT 55 \DSPPRINTCR/LF) +O È ØO ‰o h(606 ERROR 595 BKBITBLT 553 \DSPYPOSITION.DISPLAY 534 BKBITBLT 491 \DSPYPOSITION.DISPLAY 453 \CREATECHARSET 387 \SOFTCURSORUPCURRENT 352 \TOTOPWDS 342 DSPDESTINATION 325 \SOFTCURSORDOWN 294 DSPDESTINATION 275 SHOULDNT 55 \DSPPRINTCR/LF) (393 \EM.DISPINTERRUPT 332 \TOPWDS 316 \EM.DISPINTERRUPT 306 \EM.DISPINTERRUPT 111 \DISPLAYDATA 83 \DISPLAYDATA) -( 578 "Not implemented to rotate by other than 0, 90 or 270") +( 601 "Not implemented to rotate by other than 0, 90 or 270") TEXTUREP :D8 (I 0 OBJECT) @d3 ³ô@Èkð´@NIL (18 BITMAP 10 BITMAP) @@ -250,6 +253,11 @@ BITMAPWIDTH :D8 @ (35 \ILLEGAL.ARG 28 GETWINDOWPROP) (23 WIDTH 16 WINDOW 5 BITMAP) () +BITMAPHEIGHT :D8 +(I 0 BITMAP) +@Ø@È@Û@g +@ (40 \ILLEGAL.ARG 33 GETWINDOWPROP) +(28 HEIGHT 21 WINDOW 12 BITMAP 5 BITMAP) +() READBITMAP :D8 (P 6 BITSPERPIXEL P 5 W P 4 BM P 3 BASE P 2 STRM P 1 HEIGHT P 0 WIDTH I 0 FILE) @ @ gðªo ¿@ @ @g CJ dgð§dgð’¿k†¿@ ^HÚlØââââ½HIN \É»Ij𒱊J gð²jIdjñ²tJ ¿J l"ð²QMdjñ²@KjJ l@ÙààààJ l@ÙäÇ¿KkJ l@ÙààààJ l@ÙäÇ¿KkлkÙ°¿¿J l"ð¬¿o hkÙ°‹¿J ¿J l)ð²ßL(270 \INCCODE 263 SKIPSEPRS 250 ERROR 235 \INCCODE 214 \INCCODE 201 \INCCODE 187 \INCCODE 174 \INCCODE 155 \INCCODE 148 SKIPSEPRS 128 SKIPSEPRS 106 BITMAPCREATE 87 RATOM 61 SKIPSEPRS 52 GETSTREAM 41 RATOM 35 RATOM 28 ERROR 11 READC 5 SKIPSEPRS) @@ -278,7 +286,7 @@ OPPOSITESHADE :D8 NIL () \MEDW.BITBLT :D8 -(P 9 A0232 P 8 A0231 P 7 SOURCEBOTTOMTRANSFORMED P 6 SOURCELEFTTRANSFORMED P 3 SRCWIN P 2 A0230 P 1 DD P 0 DSTWIN I 11 CLIPPINGREGION I 10 TEXTURE I 9 OPERATION I 8 SOURCETYPE I 7 HEIGHT I 6 WIDTH I 5 DESTINATIONBOTTOM I 4 DESTINATIONLEFT I 3 DESTINATION I 2 SOURCEBOTTOM I 1 SOURCELEFT I 0 SOURCE F 10 \SCREENBITMAPS)  +(P 9 A0831 P 8 A0830 P 7 SOURCEBOTTOMTRANSFORMED P 6 SOURCELEFTTRANSFORMED P 3 SRCWIN P 2 A0829 P 1 DD P 0 DSTWIN I 11 CLIPPINGREGION I 10 TEXTURE I 9 OPERATION I 8 SOURCETYPE I 7 HEIGHT I 6 WIDTH I 5 DESTINATIONBOTTOM I 4 DESTINATIONLEFT I 3 DESTINATION I 2 SOURCEBOTTOM I 1 SOURCELEFT I 0 SOURCE F 10 \SCREENBITMAPS)   @ ³C ªo ¿@òZ@²WCi Cgh É0HÉ2ÉHºHÉ2@ABCDEFGGGGGABlJ±–Cô‚±¯C´‚±¨@i !@gh É0AIÉصABIÉصBKÉ2ÉJ_¿KÉ2IÉNOCDEFGGGGGNIÈ"¼dLñ¡¿LOIÈ$½dMñ¡¿MlO±Þ@ @@ -288,6 +296,25 @@ NIL W–@ ¿KÉ2ÉL KÉ2IÉNOCDEFGGGGGNIÈ"¼dLñ¡¿LOIÈ$½dMñ¡¿MlO‰o i(524 SHOULDNT 418 \TOTOPWDS 408 DSPDESTINATION 345 \GETSTREAM 330 WFROMDS 318 DSPDESTINATION 311 DSPDESTINATION 162 \GETSTREAM 147 WFROMDS 55 \GETSTREAM 43 WFROMDS 24 SHOULDNT 13 IMAGESTREAMP 5 IMAGESTREAMP) (494 \DISPLAYDATA 477 \DISPLAYDATA 451 \DISPLAYDATA 443 WINDOW 432 SCREEN 425 WINDOW 398 \TOPWDS 383 \DISPLAYDATA 367 \DISPLAYDATA 357 \DISPLAYDATA 350 STREAM 339 OUTPUT 284 \DISPLAYDATA 267 \DISPLAYDATA 241 \DISPLAYDATA 233 WINDOW 222 SCREEN 215 WINDOW 200 \DISPLAYDATA 184 \DISPLAYDATA 174 \DISPLAYDATA 167 STREAM 156 OUTPUT 127 BITMAP 92 WINDOW 83 SCREEN 76 WINDOW 67 \DISPLAYDATA 60 STREAM 49 OUTPUT 31 BITMAP) ( 519 "Invalid argument to \XW.BIBLT" 19 "Neither SOURCE nor DESTINATION is an imagestream.") +\READBINARYBITMAP :D8 +(P 3 BITMAP P 2 BPP P 1 BMH P 0 BMW I 0 STREAM) `@g +bd á@ Ø@ á@ Ø@ á@ Ø#HIJ [@KÉKÈIÚlÚMÉ +É>¼MNjOlLK(41 BITMAPCREATE 10 GETSTREAM) +(80 FDEV 73 STREAM 57 BITMAP 49 BITMAP 5 INPUT) +() +\PRINTBINARYBITMAP :D8 +(P 1 BMH P 0 STREAM I 1 STREAM I 0 BITMAP) ­ Ag +q@Ñ@¦@ ¿H@ »ZKã +¿JKlÿå +¿H@ ¹\Iã +¿LIlÿå +¿H@ ¾]Nã +¿MNlÿå +¿H@É@ÈIÚlÚ +OÉ +É@_¿OOjOlO@(112 \BOUT 101 \BOUT 92 BITSPERPIXEL 84 \BOUT 73 \BOUT 64 BITMAPHEIGHT 56 \BOUT 45 \BOUT 36 BITMAPWIDTH 28 \ILLEGAL.ARG 10 GETSTREAM) +(152 FDEV 145 STREAM 128 BITMAP 120 BITMAP 19 BITMAP 5 OUTPUT) +() FINISH-READING-BITMAP :D8 (L (0 STREAM) F 29 *READ-SUPPRESS*) (@ ñ Hd²µoH ¿°íYºI[¼K]µLk¾M_¿J3 šL3 –N3 ’O›oH @@ -414,8 +441,8 @@ JI (RPAQQ \PILOTBBTSCRATCHBM NIL) (MOVD? (QUOTE BITBLT) (QUOTE BKBITBLT)) DISPLAYSTREAMP :D8 -(I 0 X F 0 \DISPLAYSTREAMTYPES) :@ô2@É.ÉP³@É.É…dP¤µùh´@NIL -(39 IMAGEOPS 32 STREAM 20 IMAGEOPS 13 STREAM 5 STREAM) +(I 0 X) B@ô:@É.É`³"@É.ɉd`¤µõh´@NIL +(53 \DISPLAYSTREAMTYPES 43 IMAGEOPS 36 STREAM 27 \DISPLAYSTREAMTYPES 20 IMAGEOPS 13 STREAM 5 STREAM) () DSPSOURCETYPE :D8 (P 1 \INTERRUPTABLE P 0 DD I 1 DISPLAYSTREAM I 0 SOURCETYPE) ŸAgh É0HÉ @²y@gð³@dgð¦l @@ -425,11 +452,11 @@ Q (145 ERASE 138 INVERT 121 INVERT 110 PAINT 99 ERASE 86 \DISPLAYDATA 77 \DISPLAYDATA 53 INVERT 43 INPUT 32 \DISPLAYDATA 23 \DISPLAYDATA 16 STREAM 5 OUTPUT) () DSPXOFFSET :D8 -(P 0 A0244 I 1 DISPLAYSTREAM I 0 XOFFSET) 'Agh bÉ.É\@AlH(11 \GETSTREAM) +(P 0 A0845 I 1 DISPLAYSTREAM I 0 XOFFSET) 'Agh bÉ.É\@AlH(11 \GETSTREAM) (25 IMAGEOPS 18 STREAM 5 OUTPUT) () DSPYOFFSET :D8 -(P 0 A0245 I 1 DISPLAYSTREAM I 0 YOFFSET) 'Agh bÉ.É^@AlH(11 \GETSTREAM) +(P 0 A0846 I 1 DISPLAYSTREAM I 0 YOFFSET) 'Agh bÉ.É^@AlH(11 \GETSTREAM) (25 IMAGEOPS 18 STREAM 5 OUTPUT) () DSPDESTINATION :D8 @@ -481,20 +508,20 @@ I@A (15 BITMAP 7 ScreenBitMap) () \COMMON.DSPCREATE :D8 -(P 2 DSTRM I 3 OLDDSP I 2 IMAGEOPS I 1 FDEV I 0 DESTINATION F 5 DisplayFDEV F 6 OLDSTREAM F 7 DEFAULTFONT) ÀCµ‚±nl djÏ0¿dg&¿`dj6¿dk.¿dk,¿`dkÏ +(P 2 DSTRM I 3 OLDDSP I 2 IMAGEOPS I 1 FDEV I 0 DESTINATION F 5 DisplayFDEV F 6 OLDSTREAM) ÃCµ‚±ql djÏ0¿dg&¿`dj6¿dk.¿dk,¿`dkÏ ¿HdI*¿dj¿d`¿odnÿdhHdI ¿d`¿dj¿dj¿dj¿dj¿HdI0¿Bµ`HdI.¿AµUHdI ¿dkÏ 0¿dnÿÿÍ5¿`HdIÍ4¿dh2¿dg*¿dg$¿`HdIÍ¿dj¿dj¿dkÏ ¿dkÏ ¿djÍ¿dlÏ¿dh¿djÏ¿HdÉ Éhµg ¿Hdg -¿!WJ +¿!`J @J `@ȼ[Ló²3K°1 ¦C ¿VAµU -¿VBµ`.¿C°¬LJ +¿VBµ`.¿C°©LJ gJ gJ -J(444 DSPOPERATION 433 DSPSOURCETYPE 422 DSPRIGHTMARGIN 381 \ILLEGAL.ARG 374 DISPLAYSTREAMP 347 DSPDESTINATION 340 DSPFONT 328 \SETACCESS 314 \EXTERNALFORMAT) -(438 REPLACE 427 INPUT 409 \DISPLAYIMAGEOPS 401 STREAM 388 STREAM 358 BITMAP 352 SCREENWIDTH 323 OUTPUT 309 :DEFAULT 300 FDEV 233 FILELINELENGTH 225 \STREAM.NOT.OPEN 216 \EOSERROR 195 \STREAM.DEFAULT.MAXBUFFERS 153 \DISPLAYIMAGEOPS 112 ScreenBitMap 78 SCREENWIDTH 50 |PILOTBBTTYPE#| 29 |\DISPLAYDATATYPE#| 21 \DSPPRINTCHAR) +J(447 DSPOPERATION 436 DSPSOURCETYPE 425 DSPRIGHTMARGIN 384 \ILLEGAL.ARG 377 DISPLAYSTREAMP 350 DSPDESTINATION 343 DSPFONT 328 \SETACCESS 314 \EXTERNALFORMAT) +(441 REPLACE 430 INPUT 412 \DISPLAYIMAGEOPS 404 STREAM 391 STREAM 361 BITMAP 355 SCREENWIDTH 337 DEFAULTFONT 323 OUTPUT 309 :DEFAULT 300 FDEV 233 FILELINELENGTH 225 \STREAM.NOT.OPEN 216 \EOSERROR 195 \STREAM.DEFAULT.MAXBUFFERS 153 \DISPLAYIMAGEOPS 112 ScreenBitMap 78 SCREENWIDTH 50 |PILOTBBTTYPE#| 29 |\DISPLAYDATATYPE#| 21 \DSPPRINTCHAR) ( 86 -16383) (MOVD? (QUOTE \SIMPLE.DSPCREATE) (QUOTE DSPCREATE)) \MEDW.XOFFSET :D8 @@ -514,13 +541,13 @@ A (23 \DISPLAYDATA 16 STREAM 5 OUTPUT) ( 63 " is not a REGION.") \DSPFONT.DISPLAY :D8 -(P 3 \INTERRUPTABLE P 2 DD P 1 OLDFONT P 0 XFONT I 1 FONT I 0 DISPLAYSTREAM) {0@É0ZdÉ YA²cA@i µJÉ giA -µ o XIð³7JH ¿JjHÈ -Ù¿JHÉɵ -jHh ÉÈ ÍA¿@J -(119 \SFFixFont 105 \CREATECHARSET 62 ERROR 50 FONTCOPY 31 \COERCEFONTDESC) -(83 FONTDESCRIPTOR 41 NOERROR 17 \DISPLAYDATA 8 STREAM) -( 57 "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER") +(P 4 \INTERRUPTABLE P 2 DD P 1 OLDFONT P 0 XFONT I 1 FONT I 0 DISPLAYSTREAM) †@@É0ZdÉ YA²nAhdd@i µJÉ giA +µ o XIð³>JH ¿JjHÈ +Ù¿JHÉɵHÉjH +[¿KÉÈ ÍA¿@J +(130 \SFFixFont 111 \CREATECHARSET 66 ERROR 54 FONTCOPY 35 FONTCREATE) +(87 FONTDESCRIPTOR 45 NOERROR 17 \DISPLAYDATA 8 STREAM) +( 61 "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER") \DISPLAY.PILOTBITBLT :D8 (I 1 N I 0 PILOTBBT) @AvNIL NIL @@ -563,14 +590,13 @@ Q (RPAQ? \SCREENBITMAPS) (MOVD? (QUOTE NILL) (QUOTE \TOTOPWDS)) TTYDISPLAYSTREAM :D8 -(P 3 DD P 2 WIN P 0 \INTERRUPTABLE I 0 DISPLAYSTREAM F 4 \TERM.OFD F 5 \LINEBUF.OFD F 6 *STANDARD-OUTPUT* F 7 *STANDARD-INPUT* F 8 \DISPLAYSTREAMTYPES F 9 TtyDisplayStream) T@¢± -@gh b ³g –@ ¦@ ¿ @dTð’±…¿Tµ VTð²8@c °4`ð³ð`–h ¿Ti +(P 3 DD P 2 WIN P 0 \INTERRUPTABLE I 0 DISPLAYSTREAM F 4 \TERM.OFD F 5 \LINEBUF.OFD F 6 *STANDARD-OUTPUT* F 7 *STANDARD-INPUT* F 8 TtyDisplayStream) T@¢± @gh b ³g –@ ¦@ ¿ @dTð’±…¿Tµ VTð²8@c °4`ð³ð`–h ¿Ti JœJgU ¿°Ç@c¿WU@i Z² Jg` ¿Jg µc -ð“Uc¿@c W²Cg@ -¿@É0[È%KÈ$ÙKɹjIñ¡I‚jIÙÛ (266 PAGEHEIGHT 213 DSPSCROLL 197 IMAGESTREAMTYPE 180 \CREATELINEBUFFER 173 GETWINDOWUSERPROP 161 PUTWINDOWPROP 142 WFROMDS 121 PUTWINDOWPROP 104 WFROMDS 96 \CARET.DOWN 50 \ILLEGAL.ARG 43 TEXTSTREAMP 36 \DEFINEDP 24 DISPLAYSTREAMP 17 \GETSTREAM) -(248 \DISPLAYDATA 239 \DISPLAYDATA 231 \DISPLAYDATA 223 STREAM 207 ON 168 \LINEBUF.OFD 156 \RUNNING.PROCESS 151 PROCESS 115 \LINEBUF.OFD 89 \CARET.UP 81 \DEFAULTTTYDISPLAYSTREAM 31 TEXTSTREAMP 11 OUTPUT) +ð“Uc¿@c `²Cg@ +¿@É0[È%KÈ$ÙKɹjIñ¡I‚jIÙÛ (269 PAGEHEIGHT 216 DSPSCROLL 197 IMAGESTREAMTYPE 180 \CREATELINEBUFFER 173 GETWINDOWUSERPROP 161 PUTWINDOWPROP 142 WFROMDS 121 PUTWINDOWPROP 104 WFROMDS 96 \CARET.DOWN 50 \ILLEGAL.ARG 43 TEXTSTREAMP 36 \DEFINEDP 24 DISPLAYSTREAMP 17 \GETSTREAM) +(251 \DISPLAYDATA 242 \DISPLAYDATA 234 \DISPLAYDATA 226 STREAM 210 ON 202 \DISPLAYSTREAMTYPES 168 \LINEBUF.OFD 156 \RUNNING.PROCESS 151 PROCESS 115 \LINEBUF.OFD 89 \CARET.UP 81 \DEFAULTTTYDISPLAYSTREAM 31 TEXTSTREAMP 11 OUTPUT) () optimize-TTYDISPLAYSTREAM :D8 (L (2 $$CTX 1 $$ENV 0 $$WHOLE)) @¥ggNIL @@ -594,7 +620,7 @@ NIL hI I HÉ -ZHÉ [dÈ\KÈ djð²%¿@HÉ +ZHÉ [d È\KÈ djð²%¿@HÉ ¿@JJØmÿØLÙkØ °UdlZð²¿@JLØ ¿@J @@ -602,8 +628,8 @@ ZH ¿@JJØmÿØ ‰o ¿hdd@JJJJggHÉ6 @i Md²" É.]d² @ð´Mo -h(297 PROCESS.EVAL 282 PROCESS.TTY 271 \INSUREWINDOW 259 WFROMDS 252 BKBITBLT 214 ERROR 203 \DSPYPOSITION.DISPLAY 184 \DSPXPOSITION.DISPLAY 158 \DSPYPOSITION.DISPLAY 148 \DSPXPOSITION.DISPLAY 129 \DSPYPOSITION.DISPLAY 106 \DSPXPOSITION.DISPLAY 61 WYOFFSET 55 WYOFFSET 48 WXOFFSET 42 WXOFFSET 32 WFROMDS 11 \GETSTREAM) -(243 REPLACE 238 TEXTURE 89 FONTDESCRIPTOR 80 FONTDESCRIPTOR 71 \DISPLAYDATA 25 \DISPLAYDATA 18 STREAM 5 OUTPUT) +h(297 PROCESS.EVAL 282 PROCESS.TTY 271 \INSUREWINDOW 259 WFROMDS 252 BKBITBLT 214 ERROR 203 \DSPYPOSITION.DISPLAY 184 \DSPXPOSITION.DISPLAY 158 \DSPYPOSITION.DISPLAY 148 \DSPXPOSITION.DISPLAY 129 \DSPYPOSITION.DISPLAY 106 \DSPXPOSITION.DISPLAY 80 \COERCEFONTDESC 61 WYOFFSET 55 WYOFFSET 48 WXOFFSET 42 WXOFFSET 32 WFROMDS 11 \GETSTREAM) +(243 REPLACE 238 TEXTURE 89 FONTDESCRIPTOR 71 \DISPLAYDATA 25 \DISPLAYDATA 18 STREAM 5 OUTPUT) ( 292 (SETQ \CURRENTDISPLAYLINE 0) 209 "only supported rotations are 0, 90 and 270") (RPAQ? *DRIBBLE-OUTPUT* NIL) expand-\MAYBE-DRIBBLE-CHAR :D8 @@ -655,14 +681,14 @@ expand-\MAYBE-DRIBBLE-CHAR :D8 DSPBACKUP :D8 (P 4 XPOS P 3 BLTWIDTH P 2 ROTATION P 1 FONT P 0 DD I 1 DISPLAYSTREAM I 0 WIDTH) fA ³Ag b ¢±Agh bÉ0q@HÉ\HÉÙ½dMñ‘¿M[HÉ YHɘIÈ €jZKjñ´‚±Ä`–A ¿Jdjð²0¿LKÙA -¿hjdAHÉHÉIÈ ÙKIÈ -°qlZð²0hjdAHÉIÈÙHHÉjKÙÔ^¿N°5Jnð²GhjdAHÉIÈ ÙHHÉKÔ_¿OIÈ +¿hjdAHÉHÉI È ÙKI È +°qlZð²0hjdAHÉI ÈÙHHÉjKÙÔ^¿N°5Jnð²GhjdAHÉI È ÙHHÉKÔ_¿OI È Kgg i@Mjñ²#Al ¿Al ¿Al -¾MkÙ]°ÝN(347 BOUT 338 BOUT 329 BOUT 310 BKBITBLT 147 DSPXPOSITION 130 \CARET.DOWN 41 \GETSTREAM 25 DISPLAYSTREAMP 18 GETSTREAM 5 DISPLAYSTREAMP) -(304 REPLACE 299 TEXTURE 291 FONTDESCRIPTOR 274 \DISPLAYDATA 268 \DISPLAYDATA 259 FONTDESCRIPTOR 251 \DISPLAYDATA 221 \DISPLAYDATA 215 \DISPLAYDATA 206 FONTDESCRIPTOR 198 \DISPLAYDATA 179 FONTDESCRIPTOR 169 FONTDESCRIPTOR 158 \DISPLAYDATA 123 \CARET.UP 104 FONTDESCRIPTOR 95 \DISPLAYDATA 86 \DISPLAYDATA 65 \DISPLAYDATA 55 \DISPLAYDATA 48 STREAM 35 OUTPUT 13 OUTPUT) +¾MkÙ]°ÝN(347 BOUT 338 BOUT 329 BOUT 310 BKBITBLT 291 \COERCEFONTDESC 259 \COERCEFONTDESC 206 \COERCEFONTDESC 179 \COERCEFONTDESC 169 \COERCEFONTDESC 147 DSPXPOSITION 130 \CARET.DOWN 41 \GETSTREAM 25 DISPLAYSTREAMP 18 GETSTREAM 5 DISPLAYSTREAMP) +(304 REPLACE 299 TEXTURE 274 \DISPLAYDATA 268 \DISPLAYDATA 251 \DISPLAYDATA 221 \DISPLAYDATA 215 \DISPLAYDATA 198 \DISPLAYDATA 158 \DISPLAYDATA 123 \CARET.UP 104 FONTDESCRIPTOR 95 \DISPLAYDATA 86 \DISPLAYDATA 65 \DISPLAYDATA 55 \DISPLAYDATA 48 STREAM 35 OUTPUT 13 OUTPUT) () (RPAQ? \CARET.UP) (RPAQQ BELLCNT 2) @@ -749,15 +775,15 @@ NIL () DISPLAYSTREAMINIT :D8 (P 2 TTYFONTHEIGHT P 1 TTYHEIGHT P 0 TTYFONT I 0 N F 3 TtyDisplayStream) «chS -!HÈ +!H È Z`S S `@3µLdJÚ¹`IÙS -¿HÈ S +¿H È S ¿jS ¿jd`IhS ¿`S -¿JÚ`ñš`JÛlÙ€@°(139 DSPRIGHTMARGIN 127 DSPCLIPPINGREGION 107 DSPXOFFSET 99 DSPYPOSITION 84 DSPYOFFSET 57 TERMINAL-OUTPUT 41 DSPDESTINATION 18 DSPFONT 9 DSPCREATE 4 \STARTDISPLAY) -(167 \LastTTYLines 155 SCREENHEIGHT 148 SCREENHEIGHT 133 SCREENWIDTH 115 SCREENWIDTH 91 FONTDESCRIPTOR 76 SCREENHEIGHT 62 \LastTTYLines 52 \TopLevelTtyWindow 47 \DEFAULTTTYDISPLAYSTREAM 35 ScreenBitMap 27 FONTDESCRIPTOR) +¿JÚ`ñš`JÛlÙ€@°(139 DSPRIGHTMARGIN 127 DSPCLIPPINGREGION 107 DSPXOFFSET 99 DSPYPOSITION 91 \COERCEFONTDESC 84 DSPYOFFSET 57 TERMINAL-OUTPUT 41 DSPDESTINATION 27 \COERCEFONTDESC 18 DSPFONT 9 DSPCREATE 4 \STARTDISPLAY) +(167 \LastTTYLines 155 SCREENHEIGHT 148 SCREENHEIGHT 133 SCREENWIDTH 115 SCREENWIDTH 76 SCREENHEIGHT 62 \LastTTYLines 52 \TopLevelTtyWindow 47 \DEFAULTTTYDISPLAYSTREAM 35 ScreenBitMap) () \STARTDISPLAY :D8 (P 2 \INTERRUPTABLE P 1 W P 0 OLDWINDOWS F 3 \MAINSCREEN F 4 \WINDOWWORLD F 5 \CURSORDESTINATION F 6 WINDOWBACKGROUNDSHADE F 7 \CURSORDESTWIDTH F 8 \CURSORDESTHEIGHT F 9 \CURSORDESTRASTERWIDTH) <``ðœ``ð³AT²> ¸``ó«``ó–H ¿HŒdI µò`` @@ -785,12 +811,12 @@ NIL (PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted)) (ADDTOVAR GLOBALVARS WHOLESCREEN) INITIALIZEDISPLAYSTREAMS :D8 -(F 0 \GUARANTEEDDISPLAYFONT F 1 DEFAULTFONT) Uodnÿdh`ld +NIL codnÿdh`ld gl -hdg cgkPh -c(80 FONTCLASS 63 FONTCREATE 38 BITMAPCREATE) -(70 DEFAULTFONT 57 DISPLAY 48 GACHA 43 \SYSBBTEXTURE 30 \SYSPILOTBBT 24 |PILOTBBTTYPE#| 19 WHOLEDISPLAY) -( 4 -16383) +ohg gk`h +(91 FONTCLASS 67 FONTCREATE 38 BITMAPCREATE) +(96 DEFAULTFONT 83 \GUARANTEEDDISPLAYFONT 77 DEFAULTFONT 72 \GUARANTEEDDISPLAYFONT 61 DISPLAY 48 GACHA 43 \SYSBBTEXTURE 30 \SYSPILOTBBT 24 |PILOTBBTTYPE#| 19 WHOLEDISPLAY) +( 55 (MEDIUM REGULAR REGULAR) 4 -16383) (RPAQQ \DisplayStarted NIL) (RPAQQ \LastTTYLines 12) (INITIALIZEDISPLAYSTREAMS) 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/MEDLEYFONTFORMAT b/sources/MEDLEYFONTFORMAT new file mode 100644 index 000000000..9515a2d53 --- /dev/null +++ b/sources/MEDLEYFONTFORMAT @@ -0,0 +1,897 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "15-Jul-2025 20:22:16" {WMEDLEY}MEDLEYFONTFORMAT.;215 56933 + + :EDIT-BY rmk + + :CHANGES-TO (FNS MEDLEYFONT.READ.FONT MEDLEYFONT.GETFILEPROP) + + :PREVIOUS-DATE "15-Jul-2025 18:05:27" {WMEDLEY}MEDLEYFONTFORMAT.;214) + + +(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS) + +(RPAQQ MEDLEYFONTFORMATCOMS + [ + (* ;; "Eventually, MEDLEYFONT should be a package") + + + (* ;; "Main public entries") + + (FNS MEDLEYFONT.WRITE.FONT MEDLEYFONT.GETCHARSET MEDLEYFONT.CHARSET? MEDLEYFONT.GETFILEPROP + MEDLEYFONT.FILEP) + + (* ;; "Reading") + + (FNS MEDLEYFONT.READ.FONT MEDLEYFONT.READ.CHARSET MEDLEYFONT.READ.ITEM MEDLEYFONT.PEEK.ITEM + MEDLEYFONT.READ.FONTPROPS MEDLEYFONT.READ.VERIFIEDFONT) + + (* ;; "Writing") + + (FNS MEDLEYFONT.WRITE.CHARSET MEDLEYFONT.WRITE.ITEM MEDLEYFONT.WRITE.FONTPROPS + MEDLEYFONT.WRITE.HEADER) + (FNS MEDLEYFONT.FILENAME) + (ADDVARS (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT) + (DISPLAYCHARSETFNS (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET)) + (INTERPRESSFONTEXTENSIONS MEDLEYINTERPRESSFONT)) + (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (PRINTDATA 0) + (SMALLPDATA 1) + (BITMAPDATA 2) + (WORDBLOCKDATA 3) + (CLARRAYDATA 4) + (FIXPDATA 5) + (ILARRAYDATA 6) + (HPRINTDATA 7) + (ALISTDATA 8) + (PLISTDATA 9) + (LISTDATA 10]) + + + +(* ;; "Eventually, MEDLEYFONT should be a package") + + + + +(* ;; "Main public entries") + +(DEFINEQ + +(MEDLEYFONT.WRITE.FONT + [LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 15-Jul-2025 16:43 by rmk") + (* ; "Edited 9-Jul-2025 09:32 by rmk") + (* ; "Edited 19-Jun-2025 10:59 by rmk") + (* ; "Edited 9-Jun-2025 12:17 by rmk") + (* ; "Edited 25-May-2025 20:48 by rmk") + (* ; "Edited 23-May-2025 14:59 by rmk") + (* ; "Edited 22-May-2025 09:58 by rmk") + (* ; "Edited 16-May-2025 20:17 by rmk") + (* ; "Edited 14-May-2025 17:45 by rmk") + (SETQ FONT (FONTCREATE FONT)) + (CL:UNLESS FILE + (SETQ FILE (MEDLEYFONT.FILENAME FONT CHARSETNOS))) + (SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS))) + (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) + (MEDLEYFONT.WRITE.HEADER STREAM OTHERFONTPROPS) + (LET ((CHARSETLOCS (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT 0)) + (FONTCHARENCODING (FONTPROP FONT 'CHARENCODING)) + (*READTABLE* (FIND-READTABLE "INTERLISP")) + CSVECTORPTRLOC CSVECTORLOC FILECHARSETS) + + (* ;; "Figure out the actual non empty/sluggish charsets that will be wrtitten.") + + (SETQ FILECHARSETS (for CSNO CSINFO from 0 to \MAXCHARSET + when (OR (NULL CHARSETNOS) + (MEMB CSNO CHARSETNOS)) + when (SETQ CSINFO (\XGETCHARSETINFO FONT CSNO)) + unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CSNO)) + (CL:UNLESS FILECHARSETS (ERROR "No character sets to write" FONT)) + + (* ;; "Right after the header, leave 4 bytes for the pointer to the charset dispatch vector. If writing a single charset, we store the negative of the byte location so we can still easily skip the font properties without writing the whole vector. The byte in front of the single charset holds its number.") + + (* ;; "") + + (SETQ CSVECTORPTRLOC (GETFILEPTR STREAM)) (* ; + "Ptr is before fontproperties, vector is after") + (\FIXPOUT STREAM 0) + (MEDLEYFONT.WRITE.FONTPROPS STREAM FONT) + (if (CDR FILECHARSETS) + then (PRINTOUT STREAM "CHARSET LOCATIONS" T) + (* ; + "Allocate the vector space if multiple") + (SETQ CSVECTORLOC (GETFILEPTR STREAM)) + (for I from 0 to \MAXCHARSET do (\FIXPOUT STREAM 0)) + (TERPRI STREAM) + (for CSNO in FILECHARSETS do + + (* ;; + "LOC remains zero for missing charsets, slug properties are determined by font-level properties.") + + (CL:SETF (CL:SVREF CHARSETLOCS CSNO) + (GETFILEPTR STREAM)) + (MEDLEYFONT.WRITE.CHARSET FONT CSNO STREAM + NOINDIRECTS)) + (SETFILEPTR STREAM CSVECTORLOC) + (for CSNO from 0 to \MAXCHARSET do (\FIXPOUT STREAM (CL:SVREF CHARSETLOCS + CSNO))) + else + (* ;; "Only one. The %"vector%" is the charset byte immediately before the charset, the sign bit tells the tale.") + + (SETQ CSVECTORLOC (IMINUS (GETFILEPTR STREAM))) + (BOUT STREAM (CAR FILECHARSETS)) + (MEDLEYFONT.WRITE.CHARSET FONT (CAR FILECHARSETS) + STREAM NOINDIRECTS)) + (SETFILEPTR STREAM CSVECTORPTRLOC) + (\FIXPOUT STREAM CSVECTORLOC) (* ; + "Pointer to the charset dispatch vector--or negative of actual location for a singleton") + (FULLNAME STREAM]) + +(MEDLEYFONT.GETCHARSET + [LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 17:09 by rmk") + (* ; "Edited 9-Jul-2025 15:45 by rmk") + (* ; "Edited 14-May-2025 17:46 by rmk") + + (* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information") + + (CL:UNLESS (<= 0 CHARSET \MAXCHARSET) + (\ILLEGAL.ARG CHARSET)) + (RESETLST + (CL:UNLESS (\GETSTREAM STREAM 'INPUT T) + [RESETSAVE (SETQ STREAM (OPENSTREAM STREAM 'INPUT)) + `(PROGN (CLOSEF? OLDVALUE] + (CL:UNLESS (MEDLEYFONT.FILEP STREAM) (* ; + "Checks and positions, if reopening.") + (ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM)))) + (LET ((CSVECTORLOC (\FIXPIN STREAM)) + CSLOC) + + (* ;; "We know now that this file has information about the requested charset, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.") + + (CL:WHEN (if (ILESSP CSVECTORLOC 0) + then + (* ;; "File contains only one charset. Is it the one we want? If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.") + + (SETFILEPTR STREAM (IMINUS CSVECTORLOC)) + (EQ CHARSET (BIN STREAM)) + else + (* ;; "The vector-entry points to the one we want. Is it there?") + + (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL))) + (CL:UNLESS (EQ 0 (SETQ CSLOC (\FIXPIN STREAM))) + (SETFILEPTR STREAM CSLOC))) + (MEDLEYFONT.READ.CHARSET STREAM CHARSET))))]) + +(MEDLEYFONT.CHARSET? + [LAMBDA (FILE CHARSET) (* ; "Edited 15-Jul-2025 15:21 by rmk") + (* ; "Edited 25-May-2025 20:53 by rmk") + (* ; "Edited 21-May-2025 11:35 by rmk") + (* ; "Edited 17-May-2025 11:29 by rmk") + (* ; "Edited 14-May-2025 17:46 by rmk") + + (* ;; "If CHARSET, returns CHARSET if FILE contains a non-slug entry for CHARSET. If not CHARSET, returns the list of non-slug charsets in FILE.") + + (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) + (CL:UNLESS (MEDLEYFONT.FILEP STREAM) + (ERROR "Not a MEDLEYFONT file" FILE)) + (LET ((CSVECTORLOC (\FIXPIN STREAM))) + (CL:WHEN (if (ILESSP CSVECTORLOC 0) + then + (* ;; "File contains only one charse, is it the one we want? ") + + (SETFILEPTR STREAM (IMINUS CSVECTORLOC)) + (EQ CHARSET (BIN STREAM)) + else (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL))) + (NEQ 0 (\FIXPIN STREAM))) + CHARSET]) + +(MEDLEYFONT.GETFILEPROP + [LAMBDA (FILE PROP) (* ; "Edited 15-Jul-2025 20:21 by rmk") + (* ; "Edited 10-Jul-2025 17:50 by rmk") + (* ; "Edited 25-May-2025 20:53 by rmk") + (* ; "Edited 21-May-2025 11:36 by rmk") + (* ; "Edited 17-May-2025 19:07 by rmk") + (* ; "Edited 14-May-2025 17:46 by rmk") + (CL:UNLESS (OR (LITATOM FILE) + (STRINGP FILE)) + [SETQ FILE (CAR (APPLY (FUNCTION FONTFILES) + (FONTPROP (FONTCREATE FILE) + 'SPEC]) + (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) + (LET (HEADERPROPS CSVECTORLOC) + (CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP STREAM)) + (ERROR "Not a MEDLEYFONT file" (FULLNAME STREAM))) + (SETQ CSVECTORLOC (\FIXPIN STREAM)) + (SELECTQ PROP + (OTHERPROPS (CDDR HEADERPROPS)) + (DATE (CADR HEADERPROPS)) + (FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)) + (CHARSETS (if (ILESSP CSVECTORLOC 0) + then + (* ;; "File contains only one charset ") + + (SETFILEPTR STREAM (IMINUS CSVECTORLOC)) + (CONS (BIN STREAM)) + else (SETFILEPTR STREAM CSVECTORLOC) + (for CS from 0 to \MAXCHARSET unless (EQ 0 (\FIXPIN STREAM)) + collect CS))) + (ERROR "Unknown MEDLEYFONT property"]) + +(MEDLEYFONT.FILEP + [LAMBDA (FILE) (* ; "Edited 6-Jul-2025 11:44 by rmk") + (* ; "Edited 10-Jun-2025 18:19 by rmk") + (* ; "Edited 8-Jun-2025 22:55 by rmk") + (* ; "Edited 25-May-2025 20:54 by rmk") + (* ; "Edited 21-May-2025 11:37 by rmk") + (* ; "Edited 16-May-2025 21:58 by rmk") + (* ; "Edited 14-May-2025 17:00 by rmk") + + (* ;; "Me in first 2 bytes distinguishes MEDLEYFONT format from others. This may be called after the first 2 bytes have been read to verify the %"Me%", if not we skip over it here.") + + (* ;; "For a valid file, returns (fullname date)") + + (* ;; "If FILE is an open stream, it is left open. Otherwise it is opened and closed.") + + (RESETLST + [LET (STREAM VERSION DATE) + [if (\GETSTREAM FILE 'INPUT T) + then (SETQ STREAM FILE) + else (RESETSAVE (SETQ STREAM (OPENSTREAM FILE 'INPUT)) + `(PROGN (CLOSEF? OLDVALUE] + (CL:UNLESS (ZEROP (GETFILEPTR STREAM)) + (SETFILEPTR STREAM 0)) + (CL:WHEN (for C in (CONSTANT (CHCON "Medley font")) always (EQ C (READCCODE STREAM))) + [CAR (NLSETQ [CL:WHEN (EQ 0 (SETQ VERSION (MEDLEYFONT.READ.ITEM STREAM 'VERSION] + `(,(FULLNAME STREAM) + ,(MEDLEYFONT.READ.ITEM STREAM 'DATE) + ,VERSION + ,@(MEDLEYFONT.READ.ITEM STREAM 'OTHERFONTPROPS])])]) +) + + + +(* ;; "Reading") + +(DEFINEQ + +(MEDLEYFONT.READ.FONT + [LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 15-Jul-2025 20:20 by rmk") + (* ; "Edited 9-Jul-2025 00:06 by rmk") + (* ; "Edited 6-Jul-2025 11:45 by rmk") + (CL:UNLESS FILE (SETQ FILE FONT)) + (CL:WHEN (OR (type? FONTDESCRIPTOR FILE) + (LISTP FILE)) + (SETQ FILE (MEDLEYFONT.FILENAME FILE))) + (SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS))) + (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) + (CL:UNLESS (MEDLEYFONT.FILEP STREAM) + (ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM))) + (LET ((*READTABLE* (FIND-READTABLE "INTERLISP")) + FONTCHARSETVECTOR CSVECTORLOC NOTFOUND SINGLECS) + (SETQ CSVECTORLOC (\FIXPIN STREAM)) (* ; + "Byte location of the charset dispatch vector") + + (* ;; "We know now that this file has information about all requested charsets, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.") + + (SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT)) + (SETQ FONTCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)) + (CL:UNLESS (EQ CSVECTORLOC 0) (* ; "Not empty") + [if (ILESSP CSVECTORLOC 0) + then + (* ;; + "File contains only one charset and it's the one we want. Its CHARSET number is in the first byte.") + + (* ;; "If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.") + + (SETFILEPTR STREAM (IMINUS CSVECTORLOC)) + (SETQ SINGLECS (BIN STREAM)) + (CL:WHEN CHARSETNOS + (CL:UNLESS (AND (EQ SINGLECS (CAR CHARSETNOS)) + (NULL (CDR CHARSETNOS))) + (ERROR (CONCAT FILE + " does not contain information for charsets ÿ4ÿ" + (REMOVE SINGLECS CHARSETNOS))))) + (\SETCHARSETINFO FONTCHARSETVECTOR SINGLECS (MEDLEYFONT.READ.CHARSET + STREAM SINGLECS)) + else + (* ;; + "Gather all of the CSLOCS before reading, so that we always move forward") + + (for CSNO CSLOC + in (OR CHARSETNOS (for I from 0 to \MAXCHARSET collect I)) + eachtime (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CSNO + BYTESPERCELL))) + (SETQ CSLOC (\FIXPIN STREAM)) + (CL:WHEN (ZEROP CSLOC) + (push NOTFOUND CSNO)) unless (ZEROP CSLOC) + collect (CONS CSNO CSLOC) + finally (CL:WHEN (AND CHARSETNOS NOTFOUND) + (ERROR FILE (CONCAT + " does not contain information for charsets " + (DREVERSE NOTFOUND)))) + (for X CS in $$VAL do (SETQ CSNO (CAR X)) + (SETFILEPTR STREAM (CDR X)) + (\SETCHARSETINFO FONTCHARSETVECTOR CSNO + (MEDLEYFONT.READ.CHARSET STREAM CSNO + ]) + FONT]) + +(MEDLEYFONT.READ.CHARSET + [LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 11:27 by rmk") + (* ; "Edited 9-Jul-2025 19:33 by rmk") + (* ; "Edited 6-Jul-2025 10:11 by rmk") + (* ; "Edited 25-May-2025 20:54 by rmk") + (* ; "Edited 23-May-2025 11:01 by rmk") + (* ; "Edited 21-May-2025 16:25 by rmk") + (* ; "Edited 16-May-2025 20:19 by rmk") + (* ; "Edited 14-May-2025 10:43 by rmk") + (* ; "Edited 12-May-2025 07:55 by rmk") + (MEDLEYFONT.READ.ITEM STREAM 'CHARSETSTRING) (* ; + "Throwaway for looking with text editor") + (LET (CSNO INDIRECT) + (CL:UNLESS [EQ CHARSET (SETQ CSNO (MEDLEYFONT.READ.ITEM STREAM 'CHARSET] + (ERROR "Charset mismatch" (LIST CHARSET CSNO))) + (if [EQ 'INDIRECTCHARSET (CAR (SETQ INDIRECT (MEDLEYFONT.PEEK.ITEM STREAM] + then (* ; + "Read a complete charset from another file (e.g. shared Kanji)") + (MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET) + (APPLY (FUNCTION \READCHARSET) + (CADR INDIRECT)) + else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO + WIDTHS _ NIL + OFFSETS _ NIL)) eachtime (SETQ PAIR + ( + MEDLEYFONT.READ.ITEM + STREAM)) + (SETQ LABEL (CAR PAIR)) + (SETQ ITEM (CADR PAIR)) + until (EQ LABEL 'STOP) do (SELECTQ LABEL + (WIDTHS (replace (CHARSETINFO WIDTHS) of CSINFO + with ITEM)) + (OFFSETS (replace (CHARSETINFO OFFSETS) of CSINFO + with ITEM)) + (IMAGEWIDTHS (replace (CHARSETINFO IMAGEWIDTHS) + of CSINFO with ITEM)) + (YWIDTHS (replace (CHARSETINFO YWIDTHS) of CSINFO + with ITEM)) + (ASCENT (replace (CHARSETINFO CHARSETASCENT) + of CSINFO with ITEM)) + (DESCENT (replace (CHARSETINFO CHARSETDESCENT) + of CSINFO with ITEM)) + (LEFTKERN (replace (CHARSETINFO LEFTKERN) + of CSINFO with ITEM)) + (BITMAP (replace (CHARSETINFO CHARSETBITMAP) + of CSINFO with ITEM)) + (CSINFOPROPS (replace (CHARSETINFO CSINFOPROPS) + of CSINFO with ITEM)) + (CSCOMPLETEP (replace (CHARSETINFO CSCOMPLETEP) + of CSINFO with ITEM)) + (HELP "Unrecognized charsetinfo label'" LABEL)) + finally (CL:UNLESS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) + (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO + with (fetch (CHARSETINFO WIDTHS) of CSINFO))) + (RETURN CSINFO]) + +(MEDLEYFONT.READ.ITEM + [LAMBDA (STREAM LABEL?) (* ; "Edited 14-Jul-2025 15:47 by rmk") + (* ; "Edited 9-Jul-2025 19:25 by rmk") + (* ; "Edited 6-Jul-2025 14:09 by rmk") + (* ; "Edited 20-Jun-2025 11:10 by rmk") + (* ; "Edited 10-Jun-2025 20:10 by rmk") + (* ; "Edited 25-May-2025 20:55 by rmk") + (* ; "Edited 23-May-2025 10:57 by rmk") + (* ; "Edited 21-May-2025 23:12 by rmk") + (* ; "Edited 17-May-2025 10:12 by rmk") + (* ; "Edited 13-May-2025 11:36 by rmk") + + (* ;; "Reads and returns the (label data) that starts at the current position in STREAM according to its storage type. If LABEL? is provided, error if the data read does not have that label. ") + + (LET + [(ITEM (GETSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM] + (if ITEM + then (PUTSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM NIL) + else (LET ((*READTABLE* (FIND-READTABLE 'INTERLISP)) + (*PACKAGE* (CL:FIND-PACKAGE 'INTERLISP)) + LABEL NELTS) + (SETQ LABEL (RATOM STREAM)) + (READCCODE STREAM) + [SETQ ITEM + (LIST LABEL (SELECTC (BIN STREAM) + (SMALLPDATA (\WIN STREAM)) + (FIXPDATA (\FIXPIN STREAM)) + (PRINTDATA (READ STREAM)) + (ALISTDATA (bind X until [EQ 'STOP (CAR (SETQ X ( + MEDLEYFONT.READ.ITEM + STREAM] + collect (CONS (CAR X) + (CADR X)))) + (PLISTDATA (bind X until [EQ 'STOP (CAR (SETQ X ( + MEDLEYFONT.READ.ITEM + STREAM] + join X)) + (LISTDATA (bind ELT until [EQ 'STOP (CAR (SETQ ELT ( + MEDLEYFONT.READ.ITEM + STREAM] + collect (CADR ELT) + finally (CL:WHEN (CADR ELT) + (NCONC $$VAL ELT)))) + (BITMAPDATA (\READBINARYBITMAP STREAM)) + (CLARRAYDATA (LET [[ARRAY (CL:MAKE-ARRAY (READ STREAM) + :ELEMENT-TYPE + (MEDLEYFONT.READ.ITEM STREAM + 'ELEMENT-TYPE] + (ALLFIXED (EQ 1 (BIN STREAM] + (for I from 0 to (\FIXPIN STREAM) + do [CL:SETF (XCL:ROW-MAJOR-AREF ARRAY I) + (CL:IF ALLFIXED + (\FIXPIN STREAM) + (CADR (MEDLEYFONT.READ.ITEM + STREAM)))] + finally (RETURN ARRAY)))) + (ILARRAYDATA (LET [(NELTS (\FIXPIN STREAM)) + (ORIG (BIN STREAM)) + (ALLFIXED (EQ 1 (BIN STREAM] + (for I (ARRAY _ (ARRAY NELTS NIL NIL ORIG)) + from ORIG to (CL:IF (EQ ORIG 1) + NELTS + (SUB1 NELTS)) + do (SETA ARRAY I (CL:IF ALLFIXED + (\FIXPIN STREAM) + (MEDLEYFONT.READ.ITEM + STREAM I))) + finally (RETURN ARRAY)))) + (WORDBLOCKDATA (LET* [(NWORDS (\FIXPIN STREAM)) + (BLOCK (\ALLOCBLOCK (FOLDHI NWORDS + WORDSPERCELL] + (\BINS STREAM BLOCK 0 (UNFOLD NWORDS + BYTESPERWORD)) + BLOCK)) + (HPRINTDATA (HREAD STREAM)) + (SHOULDNT "UNKNOWN MEDLEYFONT DATA TYPE"] + (* ; "Skip the EOL") + (READCCODE STREAM))) + (CL:WHEN (AND LABEL? (NEQ LABEL? (CAR ITEM))) + (ERROR (CONCAT LABEL? " item not found") + ITEM)) + (CL:IF LABEL? + (CADR ITEM) + ITEM)]) + +(MEDLEYFONT.PEEK.ITEM + [LAMBDA (STREAM LABEL?) (* ; "Edited 6-Jul-2025 14:10 by rmk") + + (* ;; "If previously peeked and not read, returns that item. Otherwise calls the reader to get the new item. We always record the (LABEL DATA pair)") + + (LET [(PEEKEDITEM (GETSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM] + (CL:UNLESS PEEKEDITEM + (PUTSTREAMPROP STREAM 'MEDLEYFONT.PEEKEDITEM (SETQ PEEKEDITEM (MEDLEYFONT.READ.ITEM + STREAM)))) + (CL:WHEN (AND LABEL? (NEQ LABEL? (CAR PEEKEDITEM))) + (ERROR (CONCAT "Peeked " (CAR PEEKEDITEM) + " instead of " LABEL?) + PEEKEDITEM)) + (CL:IF LABEL? + (CADR PEEKEDITEM) + PEEKEDITEM)]) + +(MEDLEYFONT.READ.FONTPROPS + [LAMBDA (STREAM) (* ; "Edited 25-May-2025 20:55 by rmk") + (* ; "Edited 16-May-2025 21:58 by rmk") + (* ; "Edited 14-May-2025 09:11 by rmk") + (bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR]) + +(MEDLEYFONT.READ.VERIFIEDFONT + [LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:57 by rmk") + (* ; "Edited 21-May-2025 22:55 by rmk") + (* ; "Edited 19-May-2025 17:42 by rmk") + (* ; "Edited 16-May-2025 10:28 by rmk") + (LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM))) + [if FONT + then (* ; "compare/verify") + (for P in FONTPROPS unless (EQUAL (CADR P) + (RECORDACCESS (CAR P) + FONT NIL 'FETCH)) + do (ERROR "Mismatching font property" P)) + else (SETQ FONT (create FONTDESCRIPTOR)) (* ; "Construct") + (for P VAL in FONTPROPS do (SETQ VAL (CADR P)) + (SELECTQ (CAR P) + (FONTDEVICE (replace (FONTDESCRIPTOR FONTDEVICE) + of FONT with VAL)) + (FONTCOMPLETEP (replace (FONTDESCRIPTOR FONTCOMPLETEP) + of FONT with VAL)) + (FONTFAMILY (replace (FONTDESCRIPTOR FONTFAMILY) + of FONT with VAL)) + (FONTSIZE (replace (FONTDESCRIPTOR FONTSIZE) + of FONT with VAL)) + (FONTFACE (replace (FONTDESCRIPTOR FONTFACE) + of FONT with VAL)) + (\SFAscent (replace (FONTDESCRIPTOR \SFAscent) + of FONT with VAL)) + (\SFDescent (replace (FONTDESCRIPTOR \SFDescent) + of FONT with VAL)) + (\SFHeight (replace (FONTDESCRIPTOR \SFHeight) + of FONT with VAL)) + (ROTATION (replace (FONTDESCRIPTOR ROTATION) + of FONT with VAL)) + (FONTDEVICESPEC + (replace (FONTDESCRIPTOR FONTDEVICESPEC) + of FONT with VAL)) + (OTHERDEVICEFONTPROPS + (replace (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) + of FONT with VAL)) + (FONTSCALE (replace (FONTDESCRIPTOR FONTSCALE) + of FONT with VAL)) + (\SFFACECODE (replace (FONTDESCRIPTOR \SFFACECODE) + of FONT with VAL)) + (FONTAVGCHARWIDTH + (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) + of FONT with VAL)) + (FONTCHARENCODING + (replace (FONTDESCRIPTOR FONTCHARENCODING) + of FONT with VAL)) + (FONTCHARSETVECTOR + (replace (FONTDESCRIPTOR FONTCHARSETVECTOR) + of FONT with VAL)) + (FONTHASLEFTKERNS + (replace (FONTDESCRIPTOR FONTHASLEFTKERNS) + of FONT with VAL)) + (FONTEXTRAFIELD2 + (replace (FONTDESCRIPTOR FONTEXTRAFIELD2) + of FONT with VAL)) + (HELP "UNKNOWN FONTDESCRIPTOR PROPERTY: P"] + FONT]) +) + + + +(* ;; "Writing") + +(DEFINEQ + +(MEDLEYFONT.WRITE.CHARSET + [LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 9-Jul-2025 19:14 by rmk") + (* ; "Edited 25-May-2025 20:49 by rmk") + (* ; "Edited 22-May-2025 09:58 by rmk") + (* ; "Edited 16-May-2025 20:18 by rmk") + (* ; "Edited 13-May-2025 23:26 by rmk") + + (* ;; "This outputs the characterset info for CHARSET in FONT.") + + (LET ((CSINFO (\INSURECHARSETINFO CHARSET FONT)) + CSCHARENCODING) + (MEDLEYFONT.WRITE.ITEM STREAM 'CHARSETSTRING (MKSTRING CHARSET)) + (* ; "For human file-scan") + (MEDLEYFONT.WRITE.ITEM STREAM 'CHARSET CHARSET) + (CL:UNLESS (OR (NULL CSINFO) + (fetch (CHARSETINFO CSSLUGP) of CSINFO)) + (* ; + "Slug info is determined by FONT properties") + + (* ;; "Copy the fonts charencoding down to each charset info so that it is available when the charsetinfo is read. The fontdescriptor isn't available at that point and coercion could lead to fonts of different encodings. At least this would make it possible to fix things up.") + + (if (CL:UNLESS NOINDIRECTS (INDIRECTCHARSETP CSINFO FONT CHARSET)) + then + (* ;; + "This charset is is taken entirely from on another file, no need to copy it to this file.") + + (MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (GETMULTI (fetch (CHARSETINFO + CSINFOPROPS) + of CSINFO) + 'SOURCE) + NIL + 'PRINT) + else (MEDLEYFONT.WRITE.ITEM STREAM 'CSINFOPROPS (fetch (CHARSETINFO CSINFOPROPS) + of CSINFO) + NIL + 'ALIST) + (MEDLEYFONT.WRITE.ITEM STREAM 'WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (CL:UNLESS [OR (EQ (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) + (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (for I (W _ (fetch (CHARSETINFO WIDTHS) of CSINFO)) + (IM _ (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) + from 0 to (SUB1 (IPLUS \MAXTHINCHAR 3)) + always (EQ (\GETBASE W I) + (\GETBASE IM I] + (MEDLEYFONT.WRITE.ITEM STREAM 'IMAGEWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) + of CSINFO))) + (MEDLEYFONT.WRITE.ITEM STREAM 'OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (MEDLEYFONT.WRITE.ITEM STREAM 'YWIDTHS (fetch (CHARSETINFO YWIDTHS) of CSINFO)) + (MEDLEYFONT.WRITE.ITEM STREAM 'ASCENT (fetch (CHARSETINFO CHARSETASCENT) + of CSINFO)) + (MEDLEYFONT.WRITE.ITEM STREAM 'DESCENT (fetch (CHARSETINFO CHARSETDESCENT) + of CSINFO)) + (MEDLEYFONT.WRITE.ITEM STREAM 'LEFTKERN (fetch (CHARSETINFO LEFTKERN) + of CSINFO)) + (MEDLEYFONT.WRITE.ITEM STREAM 'BITMAP (fetch (CHARSETINFO CHARSETBITMAP) + of CSINFO)) + (MEDLEYFONT.WRITE.ITEM STREAM 'CSCOMPLETEP (fetch (CHARSETINFO CSCOMPLETEP) + of CSINFO)) + (MEDLEYFONT.WRITE.ITEM STREAM 'STOP T)))]) + +(MEDLEYFONT.WRITE.ITEM + [LAMBDA (STREAM LABEL ITEM EVENIFNIL TYPE BLOCKNELTS) (* ; "Edited 15-Jul-2025 11:06 by rmk") + (* ; "Edited 8-Jul-2025 23:03 by rmk") + (* ; "Edited 20-Jun-2025 11:10 by rmk") + (* ; "Edited 8-Jun-2025 21:14 by rmk") + (* ; "Edited 25-May-2025 20:48 by rmk") + (* ; "Edited 23-May-2025 10:58 by rmk") + (* ; "Edited 22-May-2025 10:31 by rmk") + (* ; "Edited 17-May-2025 10:10 by rmk") + (* ; "Edited 14-May-2025 00:07 by rmk") + + (* ;; "Writes ITEM preceded by LABEL. BLOCKNELTS overrides the default for array blocks, because of the uncertainty/complexity in determining arrayblock length.") + + (LET [(*READTABLE* (FIND-READTABLE 'INTERLISP)) + (*PACKAGE* (CL:FIND-PACKAGE 'INTERLISP] + (CL:WHEN (OR ITEM EVENIFNIL) + (PRIN2 LABEL STREAM) + (PRIN1 " " STREAM) + (SELECTQ (OR TYPE (TYPENAME ITEM)) + (SMALLP (BOUT STREAM SMALLPDATA) + (\WOUT STREAM ITEM)) + (FIXP (* ; "Must come after SMALLP") + (BOUT STREAM FIXPDATA) + (\FIXPOUT STREAM ITEM)) + ((LITATOM STRINGP PRINT) + (BOUT STREAM PRINTDATA) (* ; + "A printable Lisp object, even some lists (below)") + (PRIN2 ITEM STREAM)) + (LISTP [if (for TAIL on ITEM always (ATOM (CAR TAIL)) + finally + + (* ;; "Check the final CDR.") + + (CL:UNLESS (ATOM TAIL) + (RETURN NIL))) + then (BOUT STREAM PRINTDATA) (* ; "More compact for simple lists.") + (PRIN2 ITEM STREAM) + else (BOUT STREAM LISTDATA) + (for TAIL on ITEM as I from 1 do (MEDLEYFONT.WRITE.ITEM STREAM I + (CAR TAIL) + T) + (CL:UNLESS (LISTP (CDR TAIL)) + (MEDLEYFONT.WRITE.ITEM + STREAM + 'STOP + (CDR TAIL) + T) + (RETURN))]) + (ALIST + (* ;; + " This could be done as LISTDATA, but this way it uses the alist keys as labels.") + + (BOUT STREAM ALISTDATA) + (for X KEY in ITEM do (SETQ KEY (CAR X)) + (CL:UNLESS (OR (LITATOM KEY) + (SMALLP KEY)) + (ERROR "NOT AN ALIST" ITEM)) + (MEDLEYFONT.WRITE.ITEM STREAM KEY (CDR X) + EVENIFNIL)) + (MEDLEYFONT.WRITE.ITEM STREAM 'STOP T)) + (PLIST (BOUT STREAM PLISTDATA) + (for DTAIL KEY on ITEM by (CDDR DTAIL) + do (SETQ KEY (CAR DTAIL)) + (CL:UNLESS (OR (LITATOM KEY) + (SMALLP KEY)) + (ERROR "NOT A PLIST" ITEM)) + (MEDLEYFONT.WRITE.ITEM STREAM KEY (CADR DTAIL) + EVENIFNIL)) + (MEDLEYFONT.WRITE.ITEM STREAM 'STOP T)) + (BITMAP (BOUT STREAM BITMAPDATA) + (\PRINTBINARYBITMAP ITEM STREAM)) + ((ONED-ARRAY TWOD-ARRAY GENERAL-ARRAY) + (BOUT STREAM CLARRAYDATA) + (PRIN2 (CL:ARRAY-DIMENSIONS ITEM) + STREAM) + (MEDLEYFONT.WRITE.ITEM STREAM 'ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ITEM)) + (for I ALLFIXED ELT from 0 to (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM)) + first [SETQ ALLFIXED (for I from 0 to (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM)) + always (FIXP (XCL:ROW-MAJOR-AREF ITEM I] + (BOUT STREAM (CL:IF ALLFIXED + 1 + 0)) + (\FIXPOUT STREAM (SUB1 (CL:ARRAY-TOTAL-SIZE ITEM))) + do (SETQ ELT (XCL:ROW-MAJOR-AREF ITEM I)) + (CL:IF ALLFIXED + (\FIXPOUT STREAM ELT) + (MEDLEYFONT.WRITE.ITEM STREAM I ELT T)))) + (ARRAYP (BOUT STREAM ILARRAYDATA) + (\FIXPOUT STREAM (ARRAYSIZE ITEM)) + (BOUT STREAM (ARRAYORIG ITEM)) + (for I ALLFIXED from (ARRAYORIG ITEM) + to (IPLUS (ARRAYORIG ITEM) + (SUB1 (ARRAYSIZE ITEM))) + first [SETQ ALLFIXED (for I from (ARRAYORIG ITEM) + to (IPLUS (ARRAYORIG ITEM) + (SUB1 (ARRAYSIZE ITEM))) + always (FIXP (ELT ITEM I] + (BOUT STREAM (CL:IF ALLFIXED + 1 + 0)) do (CL:IF ALLFIXED + (\FIXPOUT STREAM (ELT ITEM I)) + (MEDLEYFONT.WRITE.ITEM STREAM I + (ELT ITEM I) + T)))) + (if (\BLOCKDATAP ITEM) + then + (* ;; "This assumes word-element blocks. We can distinguish pointer blocks (from the DTD, see BLOCKEQUALP), caller would have to tell us (a different TYPE?) whether we are looking at full integer or word blocks--how to interpret NELTS") + + (BOUT STREAM WORDBLOCKDATA) + (CL:UNLESS BLOCKNELTS (* ; "Why 3 ?") + (SETQ BLOCKNELTS (IPLUS \MAXTHINCHAR 3))) + (\FIXPOUT STREAM BLOCKNELTS) + (\BOUTS STREAM ITEM 0 (UNFOLD BLOCKNELTS BYTESPERWORD)) + else (BOUT STREAM HPRINTDATA) (* ; "A datatype?") + (HPRINT ITEM STREAM T T))) + + (* ;; "Terpri to make sure ratom is OK, also looks better") + + (TERPRI STREAM))]) + +(MEDLEYFONT.WRITE.FONTPROPS + [LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:50 by rmk") + (* ; "Edited 25-May-2025 20:50 by rmk") + (* ; "Edited 22-May-2025 10:31 by rmk") + (* ; "Edited 19-May-2025 10:42 by rmk") + (* ; "Edited 14-May-2025 17:26 by rmk") + + (* ;; "RECORDFIELDACCESS would be more succinct but would depend on runtime availability of the record. If the record changes, this and the reader have to be updated.") + + (* ;; "HPRINT would be obvious, but it would get charsetvector etc.") + + (* ;; "Exclude FONTCHARSETVECTOR and \SFFACECODE") + + (* ;; "Write even NIL values for default overerides") + + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTDEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTCOMPLETEP (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTFAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTSIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTFACE (fetch (FONTDESCRIPTOR FONTFACE) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM '\SFAscent (fetch (FONTDESCRIPTOR \SFAscent) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM '\SFDescent (fetch (FONTDESCRIPTOR \SFDescent) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM '\SFHeight (fetch (FONTDESCRIPTOR \SFHeight) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTDEVICESPEC (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'OTHERDEVICEFONTPROPS (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) + of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTSCALE (fetch (FONTDESCRIPTOR FONTSCALE) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTAVGCHARWIDTH (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) + of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTCHARENCODING (fetch (FONTDESCRIPTOR FONTCHARENCODING) + of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTHASLEFTKERNS (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS) + of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTEXTRAFIELD2 (fetch (FONTDESCRIPTOR FONTEXTRAFIELD2) + of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'STOP T]) + +(MEDLEYFONT.WRITE.HEADER + [LAMBDA (STREAM OTHERFONTPROPS) (* ; "Edited 25-May-2025 20:51 by rmk") + (* ; "Edited 16-May-2025 20:20 by rmk") + (* ; "Edited 14-May-2025 17:01 by rmk") + + (* ;; "Me in first 2 bytes distinguishes MEDLEYFONT format from others") + + (PRINTOUT STREAM "Medley font" T) + (MEDLEYFONT.WRITE.ITEM STREAM 'VERSION 0) + (MEDLEYFONT.WRITE.ITEM STREAM 'DATE (DATE)) + (MEDLEYFONT.WRITE.ITEM STREAM 'OTHERFONTPROPS OTHERFONTPROPS T]) +) +(DEFINEQ + +(MEDLEYFONT.FILENAME + [LAMBDA (FONT CHARSET EXTENSION FILE) (* ; "Edited 10-Jun-2025 11:02 by rmk") + (* ; "Edited 25-May-2025 21:25 by rmk") + (* ; "Edited 19-May-2025 17:42 by rmk") + (* ; "Edited 16-May-2025 14:09 by rmk") + + (* ;; "If EXTENSION and FILE are NIL, puts the file in the MEDLEYDIR fonts/medley[device]fonts/ directory with extension MEDLEY[device]FONT. If CHARSET, goes in the CHARSET subdirectory.") + + (CL:WHEN (AND (LISTP CHARSET) + (NULL (CDR CHARSET))) + (SETQ CHARSET (CAR CHARSET))) (* ; "Edited 14-May-2025 12:02 by rmk") + (LET (FAMILY SIZE FACE DEVICE FILENAME) + [if (LISTP FONT) + then (SETQ FAMILY (CAR FONT)) + (SETQ SIZE (CADR FONT)) + (SETQ FACE (OR (CADDR FONT) + 'MRR)) + (SETQ DEVICE (OR (CADDDR FONT) + 'DISPLAY)) + elseif (type? FONTDESCRIPTOR FONT) + then (SETQ FAMILY (FONTPROP FONT 'FAMILY)) + (SETQ SIZE (FONTPROP FONT 'SIZE)) + (SETQ FACE (FONTPROP FONT 'FACE)) + (SETQ DEVICE (FONTPROP FONT 'DEVICE] + (CL:WHEN (LISTP FACE) + (SETQ FACE (CONCAT (NTHCHAR (CAR FACE) + 1) + (NTHCHAR (CADR FACE) + 1) + (NTHCHAR (CADDR FACE) + 1)))) + (CL:UNLESS EXTENSION + (SETQ EXTENSION (CONCAT "MEDLEY" (U-CASE DEVICE) + "FONT")) + (CL:UNLESS FILE + [SETQ FILE (PSEUDOFILENAME (MEDLEYDIR (CONCAT "fonts/" (L-CASE EXTENSION) + "s"])) + (SETQ FILENAME (PACK* FAMILY (CL:IF (ILEQ SIZE 9) + "0" + "") + SIZE "-" FACE (CL:IF (SMALLP CHARSET) + (CONCAT "-C" (OCTALSTRING CHARSET)) + "") + "." EXTENSION)) + (PACKFILENAME 'BODY FILE 'BODY FILENAME]) +) + +(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT) + +(ADDTOVAR DISPLAYCHARSETFNS (MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET)) + +(ADDTOVAR INTERPRESSFONTEXTENSIONS MEDLEYINTERPRESSFONT) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ PRINTDATA 0) + +(RPAQQ SMALLPDATA 1) + +(RPAQQ BITMAPDATA 2) + +(RPAQQ WORDBLOCKDATA 3) + +(RPAQQ CLARRAYDATA 4) + +(RPAQQ FIXPDATA 5) + +(RPAQQ ILARRAYDATA 6) + +(RPAQQ HPRINTDATA 7) + +(RPAQQ ALISTDATA 8) + +(RPAQQ PLISTDATA 9) + +(RPAQQ LISTDATA 10) + + +(CONSTANTS (PRINTDATA 0) + (SMALLPDATA 1) + (BITMAPDATA 2) + (WORDBLOCKDATA 3) + (CLARRAYDATA 4) + (FIXPDATA 5) + (ILARRAYDATA 6) + (HPRINTDATA 7) + (ALISTDATA 8) + (PLISTDATA 9) + (LISTDATA 10)) +) +) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2080 14725 (MEDLEYFONT.WRITE.FONT 2090 . 6948) (MEDLEYFONT.GETCHARSET 6950 . 9249) ( +MEDLEYFONT.CHARSET? 9251 . 10720) (MEDLEYFONT.GETFILEPROP 10722 . 12757) (MEDLEYFONT.FILEP 12759 . +14723)) (14751 36965 (MEDLEYFONT.READ.FONT 14761 . 19194) (MEDLEYFONT.READ.CHARSET 19196 . 24090) ( +MEDLEYFONT.READ.ITEM 24092 . 30564) (MEDLEYFONT.PEEK.ITEM 30566 . 31428) (MEDLEYFONT.READ.FONTPROPS +31430 . 31895) (MEDLEYFONT.READ.VERIFIEDFONT 31897 . 36963)) (36991 53540 (MEDLEYFONT.WRITE.CHARSET +37001 . 41606) (MEDLEYFONT.WRITE.ITEM 41608 . 49681) (MEDLEYFONT.WRITE.FONTPROPS 49683 . 52885) ( +MEDLEYFONT.WRITE.HEADER 52887 . 53538)) (53541 56110 (MEDLEYFONT.FILENAME 53551 . 56108))))) +STOP diff --git a/sources/MEDLEYFONTFORMAT.LCOM b/sources/MEDLEYFONTFORMAT.LCOM new file mode 100644 index 000000000..2c422034c Binary files /dev/null and b/sources/MEDLEYFONTFORMAT.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..2c2d480f0 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