From 32145e2b6ff6049327493e63e84f3c3df5c5f0b1 Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Thu, 11 Sep 2025 23:41:42 -0700 Subject: [PATCH] Basic font files--see documentation For the most part as described in docs/internal/FONTCODECHANGES and docs/internal/MEDLEYFONTFORMAT --- internal/FONT-DEBUG | 147 +- internal/FONT-DEBUG.LCOM | Bin 8702 -> 11748 bytes sources/AFONT | 236 +- sources/AFONT.DFASL | Bin 8597 -> 6642 bytes sources/FONT | 3839 +++++++++++++++++++-------------- sources/FONT.LCOM | Bin 65336 -> 68727 bytes sources/MEDLEYFONTFORMAT | 259 ++- sources/MEDLEYFONTFORMAT.LCOM | Bin 20840 -> 21044 bytes 8 files changed, 2468 insertions(+), 2013 deletions(-) diff --git a/internal/FONT-DEBUG b/internal/FONT-DEBUG index 52587e8a..8bf7b959 100644 --- a/internal/FONT-DEBUG +++ b/internal/FONT-DEBUG @@ -1,23 +1,25 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Jul-2025 16:43:34" {WMEDLEY}FONT-DEBUG.;46 19345 +(FILECREATED " 2-Sep-2025 13:47:42" {WMEDLEY}FONT-DEBUG.;66 23502 :EDIT-BY rmk - :CHANGES-TO (FNS CSBMSIZE FONTSIZE CSSIZE EQCHARBM) - (VARS FONT-DEBUGCOMS) + :CHANGES-TO (FNS TRUEFONTCREATE) - :PREVIOUS-DATE "19-Jul-2025 12:36:48" {WMEDLEY}FONT-DEBUG.;41) + :PREVIOUS-DATE "29-Aug-2025 22:39:54" {WMEDLEY}FONT-DEBUG.;65) (PRETTYCOMPRINT FONT-DEBUGCOMS) -(RPAQQ FONT-DEBUGCOMS ( - (* ;; "Little tools to help in debugging display fonts") +(RPAQQ FONT-DEBUGCOMS + ( + (* ;; "Little tools to help in debugging display fonts") - (FNS DEBUGCHARSET IBM ICS SHOWCACHE SHOWCSBITMAP EQCSBM EQCHARBM CHARSETCHARS - CHARBMDIFFS SHOWCSCHAR CSCOMPARE SHOWBMS SHOWCHARBITMAPS CANDS) - (FNS FONTSIZE CSSIZE CSBMSIZE))) + (FNS DEBUGCHARSET IBM ICS SHOWCACHE SHOWCSBITMAP EQCSBM EQCHARBM CHARSETCHARS CHARBMDIFFS + SHOWCSCHAR CSCOMPARE SHOWBMS SHOWCHARBITMAPS CANDS TRUEFONTCREATE) + (FNS FONTSIZE CSSIZE CSBMSIZE) + (FNS FONTCOMPARE) + (MACROS TRUEFONT))) @@ -26,7 +28,8 @@ (DEFINEQ (DEBUGCHARSET - [LAMBDA (FONTSPEC CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 9-Jul-2025 16:26 by rmk") + [LAMBDA (FONTSPEC CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 27-Aug-2025 17:19 by rmk") + (* ; "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") @@ -43,46 +46,41 @@ (CL:UNLESS INCLUDEMEDLEYFONT (RESETSAVE DISPLAYFONTEXTENSIONS (REMOVE 'MEDLEYDISPLAYFONT DISPLAYFONTEXTENSIONS) )) - [if (OR (LITATOM FONTSPEC) + (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)) + (for FNS CSINFO (FI _ (FONTSPECFROMFILENAME 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)) + STRM 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])]) + else (\READCHARSET (\FONT.CHECKARGS FONTSPEC) + CHARSET)))]) (IBM - [LAMBDA (FONT CHARSET) (* ; "Edited 29-Jun-2025 17:05 by rmk") + [LAMBDA (FONT CHARSET) (* ; "Edited 27-Aug-2025 17:29 by rmk") + (* ; "Edited 25-Aug-2025 08:58 by rmk") + (* ; "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).") + (SETQ CHARSET (CHARSET.DECODE CHARSET)) (SHOWCSBITMAP (if (type? CHARSETINFO FONT) then FONT - else (\XGETCHARSETINFO (SETQ FONT (FONTCREATE FONT)) - (OR CHARSET 0]) + elseif FONT + then (\XGETCHARSETINFO (FONTCREATE FONT) + (OR CHARSET 0]) (ICS [LAMBDA (FONT CHARSET INCLUDEMEDLEYFONT) (* ; "Edited 7-Jul-2025 23:12 by rmk") @@ -114,7 +112,8 @@ (DV \FONTEXISTS?-CACHE]) (SHOWCSBITMAP - [LAMBDA (CSINFO) (* ; "Edited 29-Jun-2025 17:07 by rmk") + [LAMBDA (CSINFO) (* ; "Edited 17-Aug-2025 12:36 by rmk") + (* ; "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.") @@ -129,7 +128,7 @@ (IGREATERP (BITMAPHEIGHT BM) 0)) then (EVAL.AS.PROCESS (LIST 'EDITBM BM)) - else "EMPTY BITMAP") + else (PRINTOUT T "EMPTY BITMAP" T)) CSINFO]) (EQCSBM @@ -277,11 +276,27 @@ (LET ((CINFOS (CSCOMPARE CS1 CS2 CHARSET INCLUDEMEDLEYFONT))) (SHOWCHARBITMAPS NIL CINFOS CHARSET INCLUDEMEDLEYFONT T) CINFOS]) + +(TRUEFONTCREATE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) + (* ; "Edited 2-Sep-2025 13:46 by rmk") + (* ; "Edited 29-Aug-2025 22:38 by rmk") + (* ; "Edited 17-Aug-2025 15:47 by rmk") + (* ; "Edited 31-Jul-2025 10:10 by rmk") + (* ; "Edited 25-Jul-2025 13:43 by rmk") + + (* ;; "New font, no coercions, no MEDLEYFORMAT") + + (LEGACYFONT (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET]) ) (DEFINEQ (FONTSIZE - [LAMBDA (FONT CHARSETS FILETOO NOERROR) (* ; "Edited 19-Jul-2025 16:42 by rmk") + [LAMBDA (FONT CHARSETS FILETOO NOERROR) (* ; "Edited 16-Aug-2025 23:34 by rmk") + (* ; "Edited 19-Jul-2025 16:42 by rmk") + + (* ;; "Estimates the amount of storage occupied by FONT") + (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'DISPLAY NOERROR)) (CL:UNLESS CHARSETS (SETQ CHARSETS (for CS CSINFO BM from 0 to 255 when (SETQ CSINFO (\XGETCHARSETINFO FONT CS)) @@ -343,10 +358,72 @@ 8) finally (PRINTOUT T T)) else 0]) ) +(DEFINEQ + +(FONTCOMPARE + [LAMBDA (ARGS VIRGIN SHOWFONT) (* ; "Edited 5-Aug-2025 13:14 by rmk") + + (* ;; "Prints a line of characters in different fonts, for shape/size comparison. Each argument is a list of the form (FONT CHAR1 CHAR2...) or (FONT CHAR1 - CHARN) (hyphen). Characters can be codes or names.") + + (* ;; "If CHARS are not specfied, uses the chars from the previous arg.") + + (RESETLST + (RESETSAVE (DSPFONT NIL T)) + (CL:WHEN VIRGIN + (RESETSAVE \FONTSINCORE NIL) + (RESETSAVE \DISPLAYCHARSETCOERCIONS NIL) + (RESETSAVE \DISPLAYFONTCOERCIONS NIL) + (RESETSAVE \FONTEXISTS?-CACHE NIL) + (RESETSAVE DISPLAYFONTEXTENSIONS '(DISPLAYFONT))) + (TERPRI T) + (for A CHARS FONT SIZEPOS in ARGS + do (CL:WHEN (CADR A) + (SETQ CHARS (CDR A)) + [SETQ CHARS (if (EQ '- (CADR CHARS)) + then (for C from (CL:IF (CHARCODEP (CAR CHARS)) + (CAR CHARS) + (CHARCODE.DECODE (CAR CHARS))) + to (CL:IF (CHARCODEP (CADDR CHARS)) + (CADDR CHARS) + (CHARCODE.DECODE (CADDR CHARS))) collect C) + else (for C in CHARS collect (CL:IF (CHARCODEP C) + C + (CHARCODE.DECODE C))]) + (SETQ FONT (FONTCREATE (CAR A))) + (if SHOWFONT + then (SETQ SIZEPOS (IDIFFERENCE (STRPOS "-" FONT) + 2)) + (PRINTOUT T .FONT '(GACHA 8) + " [" + (SUBSTRING FONT 2 3) + (SUBSTRING FONT SIZEPOS (ADD1 SIZEPOS)) + "]") + else (PRINTOUT T .FONT '(GACHA 8) + "/")) + (DSPFONT FONT T) + (for C in CHARS do (PRIN1 (CHARACTER C) + T))) + (TERPRI T))]) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS TRUEFONT MACRO ((FORM) (* ; + "Execute FORM in a non-medleyfont displayfont environment") + (RESETVARS (\FONTSINCORE \FONTEXISTS?-CACHE DISPLAYFONTCOERCIONS + DISPLAYCHARCOERCIONS (DISPLAYFONTEXTENSIONS '(DISPLAYFONT + )) + (DISPLAYFONTDIRECTORIES (MEDLEYDIR "fonts>displayfonts>") + ) + (DISPLAYCHARSETFNS (REMOVE (ASSOC 'MEDLEYFONT + DISPLAYCHARSETFNS) + DISPLAYCHARSETFNS))) + (RETURN FORM)))) +) (DECLARE%: DONTCOPY - (FILEMAP (NIL (818 15839 (DEBUGCHARSET 828 . 4007) (IBM 4009 . 4717) (ICS 4719 . 6013) (SHOWCACHE 6015 - . 6362) (SHOWCSBITMAP 6364 . 7478) (EQCSBM 7480 . 8366) (EQCHARBM 8368 . 9129) (CHARSETCHARS 9131 . -9797) (CHARBMDIFFS 9799 . 10675) (SHOWCSCHAR 10677 . 11112) (CSCOMPARE 11114 . 13706) (SHOWBMS 13708 - . 13886) (SHOWCHARBITMAPS 13888 . 15479) (CANDS 15481 . 15837)) (15840 19322 (FONTSIZE 15850 . 16535) - (CSSIZE 16537 . 17946) (CSBMSIZE 17948 . 19320))))) + (FILEMAP (NIL (774 16422 (DEBUGCHARSET 784 . 3405) (IBM 3407 . 4405) (ICS 4407 . 5701) (SHOWCACHE 5703 + . 6050) (SHOWCSBITMAP 6052 . 7290) (EQCSBM 7292 . 8178) (EQCHARBM 8180 . 8941) (CHARSETCHARS 8943 . +9609) (CHARBMDIFFS 9611 . 10487) (SHOWCSCHAR 10489 . 10924) (CSCOMPARE 10926 . 13518) (SHOWBMS 13520 + . 13698) (SHOWCHARBITMAPS 13700 . 15291) (CANDS 15293 . 15649) (TRUEFONTCREATE 15651 . 16420)) (16423 + 20082 (FONTSIZE 16433 . 17295) (CSSIZE 17297 . 18706) (CSBMSIZE 18708 . 20080)) (20083 22490 ( +FONTCOMPARE 20093 . 22488))))) STOP diff --git a/internal/FONT-DEBUG.LCOM b/internal/FONT-DEBUG.LCOM index 301a5ac247c2e07af6fda92cb7951e5fe3334f7b..985e79c72e9a3df32a6d11aa8639f03bbc83deba 100644 GIT binary patch delta 4239 zcmb_fPjDM&71yqe|0szg$xa&NjQg_CMsl&y{?Y0W(0ILCNoz}5Wp`!Sse_wZqITlg znIvV(41;Evf#FE9aNq!R=y2hJlHfxdW;6^8Gr9FZr*H#?6T=~$!huW6`@UUCD_7wH zK6t0|Y8uYA8T3&Nt+y0s`Ig%t2&PDqgyL%#+J-LUvJk z<8}9uf{+ulxs-E>;aEB4gxJ5F;zdw|w2*-s@PhNL;01*JJ5~P#tsRoasGAk36XyryRle$1ORMJ%l44b*qJeBC(l~CWxQeIPyyoR;Gi_YJt z%#|D)2n3gvl@r87B*K)ACTV=aRI%%~lIP%eXc%}0>pm) zk>@$T5B-I_oE5#oLWI-wmoK~sXo1P5!=-kQQoSq(T4$kk`7w(V6+DRxV6}`MkY7VRNiiQgT zX)0M@()24*0@JV+TQ{o6NI@PO3q2!4)zD1SFbm~k0s>b869H!TITDfPr~Xr)P%2%a zSFQvCbWgqaDv>%%|5LwFPVKU3*VnC66NHH#%wT63^jA3xrdBc5H9(J4w0v3H%8ZNtyxiQob8G+FH{1>O z_zc8-n%jv)XgFw)%V$FI8eqL(^BwA+m{9#->1cEi6wpEHg-gef_QR<60`WImW&c7$;s(dm{UqXSPUTx^rJn%^Ywkqpo^dV%^$M951 zCX+n+Fe`jYE}fzQPbbMomhs7>V~f@CEDnkKbF7phpSC3Q&J9Oj>_`6?o$sBe>DkW~ zL4F23IVxKa8fm&{FAXJ8b|{H3o55|&zx}0R%(i=VR2uKV?H4MO0=kJ2Ek&H zRt_!%H&t-OgW`M=oNMzVQVKf)59_*F)Je(n0#GQyl}Ot)v6le$L})C)(A3yvG%wo&A5}(x&4#?)K%zxky_XD+P~2GcF;_ zY&Kbj+?~C`x^H{>aAOs5onGVzWc9uNcGaccUuC}QEhEBIwORS-hh1Yj+F9R@c8%~+ z#E9<3w!=71RB!y@tDV0Z(HFPF-OfKF$*I-O7uroG!i-m``g_&yxQi$rM#(8-8YQFO zHl~RL8$5a+2aR`i*XrX&?4e2DwMHMd&;IGxbn79Hf4#QP?guGWdd#(Q^Tr=3q3u83 znej{c*K6Lf)y^5;g$$+E>@paBdLRH-a8}7 zZ8~aHi*$4bDbk%;C{mSn$}cC+6b zDnu+}w|?^)&J}GkSb*qFIAnuGA`cy*Cxn#SWxW%UJ0X#sH=N)w?!MPMkraD)&m(Yo z(9fswRhn%ZHN<_KhBMGE4z^?(8tm{&J{~F4J}>KMW&9l3&p~GnWDtA&>UzOAi9J;i z1X#o=Tq5l+$fpF_26=ps+mVJE5|4*Rkafcqi`5)Q)gA_B7lnFJ=94BSEj=ETA!UB_+^fZ-~-?O0GQLqz|#5P0<n)@v}#(;06f!4v- zn|rqp4{o*&?sBLhM4!2iL5BEH=tgAH$RzTJ!@wI4Ih~2K?fB)ofxmJ60~Ee%Xzw5K z;{9Q9^e~nP4P?E%B#w-G(`H<;EJFp)DC#QW7%Q6!xy;G;vhN4sJwDl|D>qZ7XrTzj0O-@p?VZZnEofcb&Keiw#X8k`QQA zKtifeZaowB3KyzMz$yLl0T5atPPuX73=)WIbIYkPGwX`9swMBdpLyT+=Dj!b*E>&* zFS=P_es<~8-C40BDj=wuENPN_@PTkeR*R6#3(Egqv7(8RCX0Evd3$sH)`xrByPF%Z z`Pts>kKfdSv6-nJY<~p#=8A2@>9}&aoQI9~J|UZ52B?VnVzSV*Y-G4d@1O?cUz*dM z*GFU(gn3C;0-u95!>c=<^)`YgZgrSocx*w}3{!XOP7w;Ly6Z9jYy;I-77grpMbO$V zTD9WezVE7|G4lK7LF}Zf-P>8$!pvIY7BzL%_vw zT$hHeQSG!RlOJux`$Jo4&QFJ#bTZmd%WX#(Z{;%avv`tmOfbABkN1agc7l6&2d8CNh?FchMtlmB6sEhnfpy3g*B;P93=*&do#H zLn{qT?`lhT5SjV8U@37q*gH2F+)XSjNb@Q*EU#_rH$YV7XQRTVO;iYKG&+$kRi4*H z>Cs8T=9k_ewdQNT(vp8!JIvNtX>P`jruBY&=a1ixV$6_^709@GChn4V!0I?U8G41y zZ}f_gCq)Uq9dT<_E*6W|^!gYD%y2QYKf)#?&0wO2u)>+AyUd$p@Cb)o4X%zV=Y;1{ zl?V|jL2!5U{yrk`TqYf>^(PtZHfwpf&Cm}^5$5o9rtTa+oQeo{j=zpL2@7-82$!k= zTGj2c?v>fy^*oTP5FO4$)}l$;^-S+tjgCp`Uxp5H+pb053$nBXdTtd^!|K!>(#g|# e6W62TAFONT.;13 43176 +(FILECREATED "22-Jul-2025 23:20:06"  +{DSK}kaplan>Local>medley3.5>working-medley>sources>AFONT.;15 27510 :EDIT-BY rmk - :CHANGES-TO (FNS ACFONT.GETCHARSET \READACFONTFILE) + :CHANGES-TO (VARS AFONTCOMS) - :PREVIOUS-DATE " 8-Jul-2025 22:09:41" {WMEDLEY}AFONT.;12) + :PREVIOUS-DATE "21-Jul-2025 00:14:04" +{DSK}kaplan>Local>medley3.5>working-medley>sources>AFONT.;14) (PRETTYCOMPRINT AFONTCOMS) (RPAQQ AFONTCOMS - ( - (* ;; "AC and Interpress font file support. ACFILEP is on FONT") + [ + (* ;; "AC font file support. ACFONT.FILEP is on FONT") (XCL:FILE-ENVIRONMENTS "AFONT") - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX) - (CONSTANTS noInfoCode)) - (FNS ACFONT.FILEP ACFONT.GETCHARSET \CREATESTARFONT \READACFONTBOXES \READACFONTFILE - \ACCHARIMAGELIST \ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \READFONTWDFILE - \FACECODE \FAMILYCODE \FINDFONT) - (ADDVARS (DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET))) - (INITVARS (INTERPRESSFONTDIRECTORIES)) - (MACROS \POSITIONFONTFILE))) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX)) + (FNS ACFONT.FILEP ACFONT.GETCHARSET \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST + \ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \FACECODE \FAMILYCODE) + (ADDVARS (DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET]) -(* ;; "AC and Interpress font file support. ACFILEP is on FONT") +(* ;; "AC font file support. ACFONT.FILEP is on FONT") (XCL:DEFINE-FILE-ENVIRONMENT "AFONT" :PACKAGE "IL" @@ -58,14 +56,6 @@ (RECORD FONTBOUNDINGBOX (FBBBDX FBBBDY FBBBOX FBBBOY)) ) - -(DECLARE%: EVAL@COMPILE - -(RPAQQ noInfoCode 32768) - - -(CONSTANTS noInfoCode) -) ) (DEFINEQ @@ -96,35 +86,6 @@ (\READACFONTFILE STRM]) -(\CREATESTARFONT - [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 22-May-2025 09:59 by rmk") - (* ; "Edited 18-May-2025 21:37 by rmk") - (* gbn " 1-Oct-85 18:29") - - (* ;; "the Build font descriptor for an Interpress NS font. If we can't find widths info for that font, return NIL") - - (* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS") - - (DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES \ASCIITONS)) - (RESETLST (* ; - "RESETLST to make sure the fontfiles get closed") - (LET [(FD (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ PSIZE - FONTFACE _ FACE - \SFFACECODE _ (\FACECODE FACE) - ROTATION _ ROTATION - OTHERDEVICEFONTPROPS _ \ASCIITONS - FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72] - (CL:UNLESS (fetch (CHARSETINFO CSSLUGP) of (\INSURECHARSETINFO (OR CHARSET - \DEFAULTCHARSET) - FD)) - - (* ;; "return NIL for slug, let FONTCREATE decide whether or not to cause an error") - - FD)))]) - (\READACFONTBOXES [LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "15-Jun-85 11:48") (* ; @@ -448,93 +409,6 @@ (ROTATE-BITMAP-LEFT BITMAP]) -(\READFONTWDFILE - [LAMBDA (FILE FD WIDTHS SCALE) (* jds " 2-Jan-86 12:34") - - (* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS") - - (DECLARE (GLOBALVARS FONTWIDTHSFILES)) (* (RESETLST (* ; - "RESETLST to make sure the fontfiles get closed") - (PROG (FIXEDFLAGS FIRSTCHAR LASTCHAR - TEM WIDTHSY) (SETFILEPTR FILE - (LLSH (\FIXPIN FILE) 1)) - (* ; "Locate the segment") - (replace (FONTDESCRIPTOR FBBOX) of FD - with (SIGNED (\WIN FILE) BITSPERWORD)) - (replace \SFDescent of FD with - (IMINUS (SIGNED (\WIN FILE) - BITSPERWORD))) (* ; "Descent is -FBBOY") - (replace (FONTDESCRIPTOR FBBDX) of FD - with (SIGNED (\WIN FILE) BITSPERWORD)) - (replace \SFHeight of FD with - (SIGNED (\WIN FILE) BITSPERWORD)) - (* ; "Height is FBBDY") - (replace \SFWidths of FD with WIDTHS) - (SETQ FIRSTCHAR (fetch FIRSTCHAR of FD)) - (* ; - "First and last 'real' characters in the font") - (SETQ LASTCHAR (fetch LASTCHAR of FD)) - (COND (SCALE (* ; - "Dimensions are relative, must be scaled") - (replace (FONTDESCRIPTOR FBBOX) of FD - with (IQUOTIENT (ITIMES - (fetch (FONTDESCRIPTOR FBBOX) of FD) - SCALE) 1000)) (replace \SFDescent of - FD with (IQUOTIENT (ITIMES - (fetch \SFDescent of FD) SCALE) 1000)) - (replace (FONTDESCRIPTOR FBBDX) of FD - with (IQUOTIENT (ITIMES - (fetch (FONTDESCRIPTOR FBBDX) of FD) - SCALE) 1000)) (replace \SFHeight of FD - with (IQUOTIENT (ITIMES - (fetch \SFHeight of FD) SCALE) 1000)))) - (replace \SFAscent of FD with - (IDIFFERENCE (fetch \SFHeight of FD) - (fetch \SFDescent of FD))) - (SETQ FIXEDFLAGS (LRSH - (\BIN FILE) 6)) (* ; - "The fixed flags") (\BIN FILE) - (* ; "Skip the spares") - (COND ((EQ 2 (LOGAND FIXEDFLAGS 2)) - (SETQ TEM (\WIN FILE)) - (* ; "The fixed width for this font") - (COND ((AND SCALE (NOT - (ZEROP TEM))) (SETQ TEM - (IQUOTIENT (ITIMES TEM SCALE) 1000)))) - (for I from FIRSTCHAR to LASTCHAR do - (SETA WIDTHS I TEM))) - (T (AIN WIDTHS FIRSTCHAR - (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) - FILE) (for I from FIRSTCHAR to - LASTCHAR when (EQ noInfoCode - (ELT WIDTHS I)) do (SETA WIDTHS I 0)) - (COND (SCALE (for I from FIRSTCHAR to - LASTCHAR do (SETA WIDTHS I - (IQUOTIENT (ITIMES (ELT WIDTHS I) - SCALE) 1000))))))) (COND - ((EQ 1 (LOGAND FIXEDFLAGS 1)) - (SETQ WIDTHSY (\WIN FILE)) - (* ; - "The fixed width-Y for this font; the width-Y field is a single integer in the FD") - (replace \SFWidthsY of FD with - (COND ((AND SCALE (NOT - (ZEROP WIDTHSY))) (IQUOTIENT - (ITIMES WIDTHSY SCALE) 1000)) - (T WIDTHSY)))) (T (replace \SFWidthsY - of FD with (SETQ WIDTHSY - (ARRAY (ADD1 \MAXCHAR) - (QUOTE SMALLPOSP) 0 0))) - (AIN WIDTHSY FIRSTCHAR - (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) - FILE) (for I from FIRSTCHAR to - LASTCHAR when (EQ noInfoCode - (ELT WIDTHSY I)) do (SETA WIDTHSY I 0)) - (COND (SCALE (for I from FIRSTCHAR to - LASTCHAR do (SETA WIDTHSY I - (IQUOTIENT (ITIMES (ELT WIDTHSY I) - SCALE) 1000)))))))))) - (HELP]) - (\FACECODE [LAMBDA (FACE) (* rmk%: "27-FEB-81 12:16") (IPLUS (SELECTQ (fetch (FONTFACE EXPANSION) of FACE) @@ -578,90 +452,12 @@ (RETURN CODE)))) (0 (RETURN NIL)) NIL]) - -(\FINDFONT - [LAMBDA (FD WSTRM PRESSMICASIZE NSMICASIZE DONTCHECK) (* ; "Edited 2-Apr-87 14:39 by bvm:") - - (* ;; "Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. The FIRSTCHAR and LASTCHAR of the font are filled in, since we have to read past those to check the size. If successful, returns the size found in the widths file, with zero indicating that dimensions in the widths file are relative, leaving the file pointing just after the Rotation word of the font. --- If DONTCHECK, then assumes that this file contains exactly the right face and family, without checking --- Returns NIL if the font is not found") - (* (bind TYPE LENGTH SIZE FAMILYCODE - (ROTATION _ (fetch ROTATION of FD)) - (FACECODE _ (\FACECODE - (fetch FONTFACE of FD))) - (NEXT _ 0) (FUZZ _ (PROG1 0.02 - (* ; - "percentile difference acceptable as the same font size"))) - first (OR (SETQ FAMILYCODE - (\FAMILYCODE (OR DONTCHECK - (fetch FONTFAMILY of FD)) WSTRM)) - (RETURN NIL)) do (SETQ TYPE - (\BIN WSTRM)) (SETQ LENGTH - (\BIN WSTRM)) (add NEXT - (LLSH (IPLUS LENGTH (LLSH - (LOGAND TYPE 15) 8)) 1)) - (SELECTQ (LRSH TYPE 4) - (4 (COND ((OR (AND (EQ FAMILYCODE - (\BIN WSTRM)) (EQ FACECODE - (\BIN WSTRM))) DONTCHECK) - (* ; - "This is the right family/face (DONTCHECK must come last, so the file reads get done.)") - (replace FIRSTCHAR of FD with - (\BIN WSTRM)) (replace LASTCHAR of FD - with (\BIN WSTRM)) (COND - ((AND (OR (ZEROP (SETQ SIZE - (\WIN WSTRM))) (LESSP - (ABS (FQUOTIENT (IDIFFERENCE - (OR PRESSMICASIZE NSMICASIZE) SIZE) - PRESSMICASIZE)) FUZZ)) - (EQ ROTATION (\WIN WSTRM))) - (replace \SFFACECODE of FD with - FACECODE) (RETURN SIZE)))))) - (0 (RETURN NIL)) NIL) - (SETFILEPTR WSTRM NEXT))) - (HELP]) ) (ADDTOVAR DISPLAYCHARSETFNS (AC ACFONT.FILEP ACFONT.GETCHARSET)) - -(RPAQ? INTERPRESSFONTDIRECTORIES ) -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \POSITIONFONTFILE MACRO - ((WSTRM NSMICASIZE FIRSTCHAR LASTCHAR FAMILY FACECODE) - (* gbn "25-Jul-85 02:15") - (bind TYPE LENGTH SIZE FAMCODE FILEFAM FILEFACE (NEXT _ 0) - first (OR (SETQ FAMCODE (\FAMILYCODE (OR FAMILY T) - WSTRM)) - (RETURN NIL)) - do (SETQ TYPE (\BIN WSTRM)) - (SETQ LENGTH (\BIN WSTRM)) - (add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15) - 8)) - 1)) - (SELECTQ (LRSH TYPE 4) - (4 (SETQ FILEFAM (\BIN WSTRM)) - (SETQ FILEFACE (\BIN WSTRM)) - [COND - ((OR (EQ FAMILY T) - (EQ FAMILY NIL) - (AND (IEQP FILEFAM FAMCODE) - (IEQP FILEFACE FACECODE))) - (SETQ FIRSTCHAR (\BIN WSTRM)) - (SETQ LASTCHAR (\BIN WSTRM)) - (COND - ((AND (OR (ZEROP (SETQ SIZE (\WIN WSTRM))) - (LESSP (ABS (FQUOTIENT (IDIFFERENCE NSMICASIZE SIZE) - NSMICASIZE)) - 0.02)) - (ZEROP (\WIN WSTRM))) - (RETURN SIZE]) - (0 (RETURN NIL)) - NIL) - (SETFILEPTR WSTRM NEXT)))) -) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2849 41269 (ACFONT.FILEP 2859 . 3743) (ACFONT.GETCHARSET 3745 . 4137) (\CREATESTARFONT -4139 . 5862) (\READACFONTBOXES 5864 . 8091) (\READACFONTFILE 8093 . 20934) (\ACCHARIMAGELIST 20936 . -21293) (\ACCHARWIDTHLIST 21295 . 22561) (\GETFBB 22563 . 25843) (\ACCHARPOSLIST 25845 . 26895) ( -\ACROTATECHAR 26897 . 27461) (\READFONTWDFILE 27463 . 35496) (\FACECODE 35498 . 36092) (\FAMILYCODE -36094 . 37398) (\FINDFONT 37400 . 41267))))) + (FILEMAP (NIL (2626 27417 (ACFONT.FILEP 2636 . 3520) (ACFONT.GETCHARSET 3522 . 3914) (\READACFONTBOXES + 3916 . 6143) (\READACFONTFILE 6145 . 18986) (\ACCHARIMAGELIST 18988 . 19345) (\ACCHARWIDTHLIST 19347 + . 20613) (\GETFBB 20615 . 23895) (\ACCHARPOSLIST 23897 . 24947) (\ACROTATECHAR 24949 . 25513) ( +\FACECODE 25515 . 26109) (\FAMILYCODE 26111 . 27415))))) STOP diff --git a/sources/AFONT.DFASL b/sources/AFONT.DFASL index 3a69ea17500842f4c4123d32e9cca07a9639baa0..9338e3cfce097131782c19f74ddb8b3f509788bd 100644 GIT binary patch delta 1726 zcmbtUO>7%g5ZicH`7` z8buJr^b&;JALWr~2c?xbKq*w9iXJ%?q^N=m2ihA4IQ5E(#I4L*2TExZkxOQCL#f&2^z71*nwgtT51mcUr;}@azW$-rOg6Q+blO|8 z4COK_*|}tHNDAwk=^O0ruQY6nxUiT`igVfIY(6VZI=&@c^rCa2Ee2fz;Rpz<49Z)Vixr*vm>JPENd=7_a1~lKL4c^WRjlzOw387n zo##=pMj?sSDyLK{Sd z7hqKo(P*?fuq7rt3H%j>*ZX@rE^wTy1|}HrxVLLKVh*b&s?M9R&R_w0saAXJ#R4jh z&mqsC90CZ!_ppJ$KLGr41$w(SGS9q-1wICs!OLJ1{0s`v&0xunK;~`E1!g%3T@3Wn zLKu^%koB?2;Ym|5*uraYia}Ees$qsM*7YdN#@)7~Y%-A|&pjonsxA-XKbp0d-XBME z?UWo>BvXkhaZOQ`n4+04msaVIb=_}$fOO}_FwNljehXsK7^=d37E~UQ;&>tvEvz%! zmQB6L#N1=?#NQ&n@mP$NM4G67se1+)q}JYs`yH6Z{an)aV2WvXO4^q&O|RD*{x@)J zVFuphDy$u@4CjU8YB-o@XdhvL5LiHkIN{7LcxhKdoQ%?U8xA&(@&w1ax}&`v%kah( zBcYl&(_b{S_;7%+q_SasLX8+Ec%8`q>yF?UvNW#Y7_v=v!ABo9>=B^fG)DTbfv@_> z$u9Y_?+s+|Q#QFEmB8lv=|Iz+3gD}4+g0jpzVyl`Ja22C;v_Tfb)05~pJ7#{i2moE znG^k?xtj#&AI)EFWblS9W8UYGqe0+5t`gq^`D)19ne4TX!RI+IKq;wK#)8g<{>_SUYZreIvNt%uEerg9?(U#JK32$;VR zL3H^ z;4+*dU?xpxzm~CGCc<#NnRJXyI%C*2hKQLNLw8ac(*Ql1t38^YNg)bN9W#|g zL!7A`L%b@v#qg(Pb*@zY!J+eD2=li8t&svl*d63t$*OXfE0Q;Fzs5>Cbyx+Z8 z3~lX8W?=~p=}gK2P+NJH^{VTomK|(T?G}%+MYVg~L4Z&YMKCXiB^Zw90+x0DIV|-O9sqC}CPlz(`QjSLF|SJ6HU|wsaPwdv*LqBA0M<3g zx67iSmeBYC%_}frf#>;Y{xW}wkOA5%cV0!sABN#0Z0f&~$gU0xOC~a*u;ek-VIML3 z!|IZ`xW5cduOzM}%sjY`uYF~FJYRcs&*~*Y7ZPMhp{(-LvY)>s2fW40WjrqjVfn*~Du^6+6#t6y z-j)s@X5j`OMX~@{U0tewJpl!5IEO)0KBQSzN{_;ScRk-hd3zJ(C7Zkn^@{$lfv|EY zX2i8V%PA>Qex6`_<7*z-3s%7)&DKrRfwPEPxyC2c(J*X1W2WJ7I0I?pNzpzNt=KRv zl)3YQKLBxrkifr!l$HQR$!B07stP}Oi8rzr{r~AWz#G9*E^WULw*LUldXc^tuq?5@ zg0M6^Uuh=;5iap2_Ps!)Y^4s_jlh;Ir>L5mpqd^GcZveJ^!*lp?kB;rr_{_Tc_Z(a zH+d>KQc?~-?)yZxJGVeO)DUG`rL!M3ov7u2RJlxE-$izex3jNS?tXd!2EI2)K8I|8 zw*irVN0RRYE4@$b0{e5NIf>Sy%Uh6~V1T-iRc(5=k5(_H~qIc|DTUePtXH z1Z^@s5FLO%h{`YWBS>mIQo$$LY^Z)0%7mYi-w%*w#Gak@NH0XGE)`R^kx3es(PJc? z4o}NI3T+#B1H6<4eiX?bFjpZPJz5%u@+~s^I;tGvXTUiv3kqq z&49ZB`Xdy6gQJ-i^v7RRhxcVA0rcULK5k}gr@`)vTBhyrEVQn==p1Czes-rEg0!_IAC7H*2+)C#BQ(ICbqH9t$j0(cITn_BfS9l zkzNG<1HA1s&Y@IK#&aH`IqS#cF=t?GneUtaamhU?f5h9yl=Tb z(2b$kx@H-4U8q?z<|J&oFr;{lkUazOe5Fh)D;?rJg7Xjh{vD&^mFG(sR+?`ha64G4 z=2RsSAc>+4{L*1hkQYk_x^Ke~wp z^0*5D70l#W8qSSF?DC|Oz?Q0~Vn&T8UPa`8vNs}(o$kD{k_v2eWifb3=m|sbrpyGB zc2C~aHM%*m0aehuq-R;=ZQ$Kf>fhs?5LGFqN-Y(om#DiqD_rsTB`;B+q!E~Zfg8Nv zgspTH(ta)tgG@LA|Fy!0^W!x*TDq?e32w2fm3<)A=B3S;%51u9wSqOB#LlZf#ecq-BAEONO3DghI5DJ7WTrV&L zX~1K3ijUiR2ZZ96@boKV6Vo#%5cIjCl*%9juNfcQPQ4ghT!WB0@Pnf|5ArOLyZCxM zS5!0bB+Ddm9n#3uvgHOcx$QkLeM69}Wgjn+r~eo`9tPgLqIKu;Mfu=}x4=7y2jEzi zo$y%2Oj~_6S%b3|Yb&Y%h?Ux_C1a$!T^WEEh628R8~VQP^e#ur*a^?V=Q1DsKLAHu zOK|cJ;Xz}O(26yWpvCq3;5{FMSnx--bsieYpacqq+2uL9Xx>7>)5`!AIar-(^rp#m zEq(KpbDZ{B8q;ADS1*V0u&jCn%YzH4ctq=^xfA5eads~=02mLVGH5`#gOJ)oX~|(v z=Np1oI>CocN6d-^KPJE!6Ci6*_#uJPvUqP_$}!=R^~U99%#6p4jFHq0T8ej0!ybQT z*Xy@}5Q0W~mze~|>sP?yA_cu=M8qMih$x4s73Szm2TiyGJ1+5EFg4%J;kS_RZOq~L Hy?g%$)NDh_ diff --git a/sources/FONT b/sources/FONT index 39591da8..4d819826 100644 --- a/sources/FONT +++ b/sources/FONT @@ -1,14 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "27-Jul-2025 13:39:57"  -{DSK}kaplan>Local>medley3.5>working-medley>sources>FONT.;375 239724 +(FILECREATED "10-Sep-2025 23:28:04" {WMEDLEY}FONT.;602 281058 :EDIT-BY rmk - :CHANGES-TO (FNS \FONT.CHECKARGS \FONT.CHECKARGS1 \COERCEFONTDESC) - (MACROS FONTASCENT FONTDESCENT FONTHEIGHT) + :CHANGES-TO (FNS \STRINGWIDTH.GENERIC) - :PREVIOUS-DATE "25-Jul-2025 21:38:56" {WMEDLEY}FONT.;372) + :PREVIOUS-DATE " 9-Sep-2025 23:55:03" {WMEDLEY}FONT.;600) (PRETTYCOMPRINT FONTCOMS) @@ -31,38 +29,74 @@ (* ;; "Creation: ") (FNS FONTCREATE FONTCREATE1 FONTCREATE.SLUGFD \FONT.CHECKARGS \FONT.CHECKARGS1 - \FONTCREATE1.NOFN FONTFILEP \READCHARSET \COERCEFONTSPEC) - (FNS \COERCEFONTDESC) + \FONTCREATE1.NOFN FONTFILEP \READCHARSET) + (FNS \FONT.CHECKARGS \CHARSET.CHECK) + (FNS COERCEFONTSPEC) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS COERCEFONTSPEC.MATCH COERCEFONTSPEC.TARGET)) (MACROS SPREADFONTSPEC) - (FNS COMPLETE.FONT COMPLETEFONTP COMPLETE.CHARSET PRUNEFONTSLUGS)) + (FNS MAKEFONTSPEC) + (FNS COMPLETE.FONT COMPLETEFONTP COMPLETE.CHARSET PRUNESLUGCSINFOS)) (COMS (* ;; "Property extraction:") - (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH)) - (COMS - (* ;; "Moving character information") - + (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH) + (EXPORT (OPTIMIZERS FONTPROP)) + (FNS FONTDEVICEPROP)) + (COMS (* ; "Moving character information") (FNS EDITCHAR) (* ; "Should this be on EDITFONT ?") (FNS GETCHARBITMAP PUTCHARBITMAP \GETCHARBITMAP.CSINFO \PUTCHARBITMAP.CSINFO) - (FNS MOVECHARBITMAP MOVEFONTCHARS \MOVEFONTCHAR SLUGCHARP.DISPLAY \GETCHARINFO) + (FNS MOVECHARBITMAP MOVEFONTCHARS \MOVEFONTCHAR \MOVEFONTCHARS.SOURCEDATA \MAKESLUGCHAR + SLUGCHARP.DISPLAY) (MACROS UPDATEINFOELEMENT)) (COMS (* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories. That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places. ") (FNS FONTFILES \FINDFONTFILE \FONTFILENAMES \FONTFILENAME \FONTFILENAME.OLD - \FONTFILENAME.NEW \FONTINFOFROMFILENAME \FONTINFOFROMFILENAME.OLD) + \FONTFILENAME.NEW FONTSPECFROMFILENAME \FONTINFOFROMFILENAME.OLD) (* (* ; "Do we still want old fonts?") (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE))) (INITVARS (*OLD-FONT-EXTENSIONS* NIL)) (INITVARS (*USEOLDFONTDIRECTORIES* NIL)) (GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)) - (FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \UNITWIDTHSVECTOR - \COERCECHARSET \BUILDSLUGCSINFO \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR - SETFONTCHARENCODING) - (FNS FONTSAVAILABLE FONTEXISTS? \FONTSAVAILABLE.INCORE \SEARCHFONTFILES FLUSHFONTSINCORE - MATCHFONTFACE FINDFONTFILES) - (INITVARS \FONTEXISTS?-CACHE) + (FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \COERCECHARSET + \BUILDSLUGCSINFO \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR SETFONTCHARENCODING + ) + (FNS FONTSAVAILABLE FONTEXISTS? \SEARCHFONTFILES FLUSHFONTSINCORE FINDFONTFILES SORTFONTSPECS + ) + (FNS MATCHFONTFACE MAKEFONTFACE FONTFACETOATOM) + (INITVARS \FONTSINCORE \FONTEXISTS?-CACHE \DEFAULTDEVICEFONTS) + [COMS (GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) + (INITVARS \UNITWIDTHSVECTOR) + (FNS \UNITWIDTHSVECTOR) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR] + (DECLARE%: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO FONTSPEC) + (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET + \FGETWIDTH \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH + \FGETIMAGEWIDTH \FSETIMAGEWIDTH) + (MACROS \GETCHARSETINFO \SETCHARSETINFO \INSURECHARSETINFO + \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR CHARSETPROP) + (PROP ARGNAMES CHARSETPROP) + (CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR)) + (SLUGCHARSET (ADD1 \MAXCHARSET))) + (MACROS LEGACYFONT)) + (MACROS INDIRECTCHARSETP)) + (FNS FONTDESCRIPTOR.DEFPRINT FONTCLASS.DEFPRINT) + (INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO) + (SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO) + (FNS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN) + (FNS \CREATEFONT \CREATECHARSET \INSTALLCHARSETINFO \INSTALLCHARSETINFO.CHARENCODING) + (DECLARE%: DONTCOPY (MACROS FIRSTCHARSETCODE LASTCHARSETCODE)) + (FNS \FONTRESETCHARWIDTHS) + (MACROS \FGETCHARIMAGEWIDTH) + (LOCALVARS . T) + (PROP FILETYPE FONT) + + (* ;; "") + + + (* ;; "DISPLAY") + (COMS (* ;  "Functions for DISPLAY IMAGESTREAMTYPES ") (FNS \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY \FONTEXISTS?.DISPLAY)) @@ -72,111 +106,94 @@ \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 \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR))) - (EXPORT (OPTIMIZERS FONTPROP)) - (DECLARE%: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO) - (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET - \FGETWIDTH \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH - \FGETIMAGEWIDTH \FSETIMAGEWIDTH) - (MACROS \XGETCHARSETINFO \GETCHARSETINFO \INSURECHARSETINFO - \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR CHARSETPROP) - (CONSTANTS (\MAXNSCHAR 65535))) - (MACROS INDIRECTCHARSETP MAKECSSOURCE)) - (FNS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN) - [COMS (FNS \CREATEFONT \CREATECHARSET \INSTALLCHARSETINFO \INSTALLCHARSETINFO.CHARENCODING) - (EXPORT (GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYGLYPHCOERCIONS - DISPLAYFONTCOERCIONS)) - - (* ;; "Removed ((CLASSIC 36) (CLASSIC 24)) so that TIMESROMAN 36 BOLD boldifies rather than coercing to CLASSIC 24 BOLD.") - - (INITVARS [DISPLAYFONTCOERCIONS '(((HELVETICA 1) - (HELVETICA 4)) - ((HELVETICA 2) - (HELVETICA 4)) - ((MODERN 60) - (MODERN 48)) - ((MODERN 96) - (MODERN 72)) - ((MODERN 120) - (MODERN 72)) - ((PALATINO 9) - (PALATINO 12)) - ((PALATINO 8) - (PALATINO 10)) - ((PALATINO 6) - (PALATINO 10)) - ((TITAN 6) - (TITAN 10)) - ((TITAN 9 (TITAN 10))) - ((LPT) - (AMTEX] - [DISPLAYGLYPHCOERCIONS '(((GACHA) - (TERMINAL)) - ((MODERN) - (CLASSIC)) - ((TIMESROMAN) - (CLASSIC)) - ((HELVETICA) - (MODERN)) - ((TERMINAL) - (MODERN] - [ADOBEDISPLAYFONTCOERCIONS '(((HELVETICABLACK 16) - (HELVETICABLACK 18)) - ((SYMBOL) - (ADOBESYMBOL)) - ((SYMBOL 11) - (ADOBESYMBOL 10)) - ((AVANTGARDE-DEMI) - (AVANTGARDE)) - ((AVANTGARDE-BOOK) - (AVANTGARDE)) - ((NEWCENTURYSCHLBK) - (CENTURYSCHOOLBOOK)) - ((BOOKMAN-LIGHT) - (BOOKMAN)) - ((BOOKMAN-DEMI) - (BOOKMAN)) - ((HELVETICA-NARROW) - (HELVETICANARROW)) - ((HELVETICA 24) - (ADOBEHELVETICA 24] - (\DEFAULTCHARSET 0)) - (COMS (* ; "MAPPING FOR DOS FILENAMES ") - (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) - (HELVETICA . HV) - (TIMESROMAND . TD) - (HELVETICAD . HD) - (MODERN . MD) - (CLASSIC . CL) - (GACHA . GC) - (TITAN . TI) - (LETTERGOTHIC . LG) - (BOLDPS . BP) - (TERMINAL . TM) - (CLASSICTHIN . CT) - (HIPPO . HP) - (LOGO . LG) - (MATH . MA) - (OLDENGLISH . OE) - (SYMBOL . SY] - (FNS \FONTRESETCHARWIDTHS) - (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") + (EXPORT (GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYCHARCOERCIONS + DISPLAYFONTCOERCIONS DISPLAYCHARSETFNS)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DISPLAYFONTDIRECTORIES NIL)) + (ADDVARS (DISPLAYCHARSETFNS (STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET))) + (* ; "The loadup might have fewer") (ADDVARS (DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT DISPLAYFONT))) - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MAXCODE 255) - (DUMMYINDEX 256))) - (MACROS \FGETCHARIMAGEWIDTH \SETCHARSETINFO) - (LOCALVARS . T) - (PROP FILETYPE FONT) + (INITVARS [DISPLAYFONTCOERCIONS '(((HELVETICA (<= * 2)) + (HELVETICA 4)) + ((MODERN (<= 15 * 16)) + (* 14)) + ((MODERN (<= 17 * 21)) + (* 18)) + ((MODERN (<= 22 * 28)) + (* 24)) + ((MODERN (<= 29 * 33)) + (* 30)) + ((MODERN (<= 34 * 40)) + (* 36)) + ((MODERN (<= 41 * 65)) + (* 48)) + ((MODERN (<= 66 *)) + (* 72)) + ((PALATINO 9) + (PALATINO 12)) + ((PALATINO (<= * 8)) + (PALATINO 10)) + ((TITAN (<= * 9)) + (TITAN 10)) + (LPT AMTEX] + [DISPLAYCHARCOERCIONS '((GACHA TERMINAL) + (MODERN CLASSIC) + (TIMESROMAN CLASSIC) + (HELVETICA MODERN) + (TERMINAL MODERN) + (HIPPO CLASSIC) + (CYRILLIC CLASSIC) + (MATH CLASSIC) + (SIGMA MODERN) + (SYMBOL MODERN) + (TITAN CLASSIC) + (OPTIMA MODERN) + (BOLDPS CLASSIC) + (PCTERMINAL) + (TITANLEGAL CLASSIC] + (\DEFAULTCHARSET 0)) + + (* ;; "") + + + (* ;; "Defunct coercions? Mapping for DOS filenames, Adobe equivalences") + + [COMS (INITVARS [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] + (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) + (HELVETICA . HV) + (TIMESROMAND . TD) + (HELVETICAD . HD) + (MODERN . MD) + (CLASSIC . CL) + (GACHA . GC) + (TITAN . TI) + (LETTERGOTHIC . LG) + (BOLDPS . BP) + (TERMINAL . TM) + (CLASSICTHIN . CT) + (HIPPO . HP) + (LOGO . LG) + (MATH . MA) + (OLDENGLISH . OE) + (SYMBOL . SY] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FONTCOPY]) @@ -209,7 +226,8 @@ CHARCODE]) (CHARWIDTHY - [LAMBDA (CHARCODE FONT) (* ; "Edited 22-May-2025 09:47 by rmk") + [LAMBDA (CHARCODE FONT) (* ; "Edited 2-Sep-2025 13:25 by rmk") + (* ; "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.") @@ -218,8 +236,7 @@ (LET (TEMP WY) (COND ((type? FONTDESCRIPTOR FONT) - (SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\INSURECHARSETINFO (\CHARSET CHARCODE) - FONT))) + [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\INSURECHARSETINFO FONT (\CHARSET CHARCODE] (COND ((FIXP WY)) (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE))) @@ -228,8 +245,8 @@ (* ;  "NIL font goes thru here--primary output file") (IMAGEOP 'IMCHARWIDTHY TEMP TEMP CHARCODE)) - (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\INSURECHARSETINFO (\CHARSET CHARCODE) - (FONTCREATE FONT] + (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\INSURECHARSETINFO (FONTCREATE FONT) + (\CHARSET CHARCODE] (COND ((FIXP WY)) (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE))) @@ -274,7 +291,10 @@ (ffetch DDSPACEWIDTH of DD]) (\STRINGWIDTH.GENERIC - [LAMBDA (STR FONT RDTBL SPACEWIDTH) (* ; "Edited 22-May-2025 09:51 by rmk") + [LAMBDA (STR FONT RDTBL SPACEWIDTH) (* ; "Edited 10-Sep-2025 23:25 by rmk") + (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 30-Aug-2025 23:19 by rmk") + (* ; "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 ") @@ -289,45 +309,39 @@ (if RDTBL then (GO SLOW) else (RETURN (for C WIDTHSBASE CSET inatom STR - sum [COND - ((NEQ CSET (\CHARSET C)) + sum (CL:UNLESS (EQ 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] + of (\INSURECHARSETINFO FONT CSET)))) + (CL:IF (EQ C (CHARCODE SPACE)) + SPACEWIDTH + (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C)))] ((STRINGP STR) - (RETURN - (LET ((TOTAL 0) - ESC ESCWIDTH WIDTHSBASE CSET) - [COND - (RDTBL (* ; + (RETURN (LET ((TOTAL 0) + ESC ESCWIDTH WIDTHSBASE CSET) + (CL:WHEN RDTBL (* ;  "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) (* ; + (SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %")) + 2)) + (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL)) + (SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC))) + [for C instring STR + do (CL:UNLESS (EQ (\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))) + (SETQ CSET (\CHARSET C)) + (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) + of (\INSURECHARSETINFO FONT CSET)))) + (add TOTAL (CL:IF (EQ C (CHARCODE SPACE)) + SPACEWIDTH + (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C)) + (COND + ((AND RDTBL (OR (EQ C (CHARCODE %")) + (EQ C ESC))) (* ; "String char must be escaped") - ESCWIDTH) - (T 0] - TOTAL] + ESCWIDTH) + (T 0))))] + TOTAL] SLOW (* ; "Do the general case here") (RETURN (LET ((TOTALWIDTH 0) @@ -344,8 +358,8 @@ (T (SETQ CSET (\CHARSET CC)) (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) - of (\INSURECHARSETINFO CSET - FONT))) + of (\INSURECHARSETINFO FONT + CSET))) (\FGETWIDTH WIDTHSBASE (\CHAR8CODE CC] STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*) @@ -463,7 +477,6 @@ (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)))) @@ -481,7 +494,7 @@ (RPAQQ NSFONTFAMILIES (CLASSIC MODERN TERMINAL OPTIMA TITAN BOLDPS PCTERMINAL)) -(RPAQQ ALTOFONTFAMILIES (GACHA TIMESROMAN TIMESROMAND HELVETICA OLDENGLISH SNAIL TONTO)) +(RPAQQ ALTOFONTFAMILIES (TIMESROMAN TIMESROMAND HELVETICA)) @@ -491,6 +504,9 @@ (FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) + (* ; "Edited 28-Aug-2025 14:39 by rmk") + (* ; "Edited 15-Aug-2025 23:48 by rmk") + (* ; "Edited 12-Aug-2025 21:02 by rmk") (* ; "Edited 21-Jul-2025 09:11 by rmk") (* ; "Edited 11-Jul-2025 10:23 by rmk") (* ; "Edited 4-Jul-2025 12:10 by rmk") @@ -501,7 +517,7 @@ (* ; "Edited 28-Jul-88 14:43 by rmk:") (* ; "Edited 10-Nov-87 18:08 by FS") - (* ;; "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.") + (* ;; "Returns the requested font descriptor. If NOERRORFLG, return NIL if the requested font doesn't exist; otherwise cause an error. And always cause an error if any argument is bogus.") (* ;; "A font exists if it has at least one charset, even if the optionally desired CHARSET doesn't exist. There is no difference between all the characters in a missing charset and particular missing characters in an existing charset: they will show up as slugs. ") @@ -510,22 +526,35 @@ (PROG (FONTSPEC) RETRY (* ; "Back to here if ERROR returns") - (SETQ FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE CHARSET)) + (SETQ CHARSET (\CHARSET.CHECK CHARSET)) + (SETQ FONTSPEC (if (AND (type? FONTDESCRIPTOR FAMILY) + (NULL SIZE) + (NULL FACE) + (NULL ROTATION) + (NULL DEVICE)) + then + (* ;; "Pretest for a fontdescriptor with no modification--makes it possible to break/trace/change \FONT.CHECKARGS") + + FAMILY + else (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE))) (* ;; "If FONTSPEC is a fontdescriptor, it's what we want") (RETURN (if (type? FONTDESCRIPTOR FONTSPEC) then FONTSPEC - else (SPREADFONTSPEC FONTSPEC) - (if (FONTCREATE1 FAMILY SIZE FACE ROTATION DEVICE (OR CHARSET - \DEFAULTCHARSET)) - elseif NOERRORFLG - then NIL - else (ERROR "FONT NOT FOUND" FONTSPEC) - (GO RETRY]) + elseif (FONTCREATE1 FONTSPEC CHARSET) + elseif NOERRORFLG + then NIL + else (ERROR "FONT NOT FOUND" FONTSPEC) + (GO RETRY]) (FONTCREATE1 - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 24-Jul-2025 19:52 by rmk") + [LAMBDA (FONTSPEC CHARSET) (* ; "Edited 30-Aug-2025 23:13 by rmk") + (* ; "Edited 28-Aug-2025 14:32 by rmk") + (* ; "Edited 26-Aug-2025 23:45 by rmk") + (* ; "Edited 16-Aug-2025 18:55 by rmk") + (* ; "Edited 8-Aug-2025 10:05 by rmk") + (* ; "Edited 24-Jul-2025 19:52 by rmk") (* ; "Edited 23-Jul-2025 10:01 by rmk") (* ; "Edited 17-Jul-2025 23:48 by rmk") (* ; "Edited 10-Jul-2025 12:38 by rmk") @@ -536,21 +565,28 @@ (* ; "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") + (* ;; "Returns NIL if font not found. Error happens at FONTCREATE. ") - (DECLARE (GLOBALVARS IMAGESTREAMTYPES \FONTSINCORE)) - (LET (FONTX) - (CL:WHEN (if (SETQ FONTX (GETMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE)) - then (\INSURECHARSETINFO CHARSET FONTX) - elseif (AND (FONTEXISTS? FAMILY SIZE FACE ROTATION DEVICE CHARSET) - (SETQ FONTX (\CREATEFONT FAMILY SIZE FACE ROTATION DEVICE CHARSET)) - (\INSURECHARSETINFO CHARSET FONTX)) - then (PUTMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE FONTX)) - (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTX with (\AVGCHARWIDTH FONTX)) - FONTX)]) + (DECLARE (GLOBALVARS \FONTSINCORE)) + (CL:UNLESS CHARSET (SETQ CHARSET \DEFAULTCHARSET)) + (LET (FONT) + (CL:WHEN (if (SETQ FONT (FETCHMULTI \FONTSINCORE FONTSPEC)) + elseif (AND (FONTEXISTS? FONTSPEC) + (SETQ FONT (\CREATEFONT FONTSPEC))) + then + (* ;; "Storing stops internal charset recursions") + + (STOREMULTI \FONTSINCORE FONTSPEC FONT)) + + (* ;; "Even the cached font may not have had the requested charset.") + + (\INSURECHARSETINFO FONT CHARSET) + (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT)) + FONT)]) (FONTCREATE.SLUGFD - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 14-Jun-2025 23:25 by rmk") + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 14-Jun-2025 23:25 by rmk") (* ; "Edited 13-Jun-2025 09:44 by rmk") (* ; "Edited 11-Jun-2025 10:59 by rmk") @@ -570,15 +606,18 @@ 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))) + then (\SETCHARSETINFO FONTDESC CHARSET SLUGCSINFO) + else (for CS from 0 to (ADD1 \MAXCHARSET) do (\SETCHARSETINFO FONTDESC CS SLUGCSINFO))) FONTDESC]) (\FONT.CHECKARGS - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 27-Jul-2025 13:30 by rmk") + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Aug-2025 14:46 by rmk") + (* ; "Edited 23-Aug-2025 11:54 by rmk") + (* ; "Edited 17-Aug-2025 19:15 by rmk") + (* ; "Edited 12-Aug-2025 22:36 by rmk") + (* ; "Edited 10-Aug-2025 12:06 by rmk") + (* ; "Edited 8-Aug-2025 09:57 by rmk") + (* ; "Edited 27-Jul-2025 13:30 by rmk") (* ; "Edited 22-Jul-2025 23:07 by rmk") (* ; "Edited 21-Jul-2025 09:22 by rmk") (* ; "Edited 14-Jul-2025 20:09 by rmk") @@ -588,23 +627,14 @@ (* ; "Edited 27-Jun-2025 10:42 by rmk") (* ; "Edited 15-Jun-2025 00:25 by rmk") + (* ;; "DON'T BREAK, TRACE, OR UNSAVE THIS UNLESS ALL SYSTEM FONTS HAVE ALREADY BEEN INSTANTIATED") + (* ;; "Decodes and checks the various ways of specifying the arguments to font lookup functions.") - (* ;; "If FAMILY can be coerced to a font descriptor and none of its properties are overwritten by the other aguments, then that font descriptor is returned. Otherwise the value is the coerce fontspec (family size face rotation device). CHARSET is checked for validity but not coerced.") + (* ;; "If FAMILY can be coerced to a font descriptor and none of its properties are overwritten by the other aguments, then that font descriptor is returned. Otherwise the value is the coerced fontspec (family size face rotation device).") (LET (FONTX) - (SETQ DEVICE (if (NULL DEVICE) - then (CL:IF (type? FONTDESCRIPTOR FAMILY) - (fetch (FONTDESCRIPTOR FONTDEVICE) of FAMILY) - 'DISPLAY) - elseif (OR (AND (LITATOM DEVICE) - (NEQ DEVICE T)) - (STRINGP DEVICE)) - then (\DEVICESYMBOL DEVICE) - elseif [AND (SETQ DEVICE (\GETSTREAM DEVICE 'OUTPUT T)) - (CAR (MKLIST (IMAGESTREAMTYPE DEVICE] - else (\ILLEGAL.ARG DEVICE))) - (CL:WHEN (AND (EQ 'CLASS (CAR FAMILY)) + (CL:WHEN (AND (EQ 'CLASS (CAR (LISTP 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.") @@ -618,19 +648,17 @@ (* ;; "FAMILY T or NIL produces an error below") [if (LISTP FAMILY) - then (SETQ FONTX (CL:IF (EQ 'FONT (CAR FAMILY)) + then + (* ;; "Presumably a FONTSPEC. The variables here override the FONTX properties, as with the fontdescriptor below ") + + (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 FAMILY (fetch (FONTSPEC FSFAMILY) of FONTX)) + (SETQ SIZE (OR SIZE (fetch (FONTSPEC FSSIZE) of FONTX))) + (SETQ FACE (OR FACE (fetch (FONTSPEC FSFACE) of FONTX))) + (SETQ ROTATION (OR ROTATION (fetch (FONTSPEC FSROTATION) of FONTX))) + (SETQ DEVICE (OR DEVICE (fetch (FONTSPEC FSDEVICE) of FONTX))) (SETQ FONTX NIL) elseif (SETQ FONTX (CL:IF (type? FONTDESCRIPTOR FAMILY) FAMILY @@ -649,8 +677,17 @@ (CL:UNLESS DEVICE (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX)))]) - (* ;; "The arguments are now coerced, validate them.") + (* ;; "We have decoded the arguments, fill in defaults and validate") + (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:UNLESS (AND FAMILY (LITATOM FAMILY) (NEQ FAMILY T)) (ERROR "Illegal font family" FAMILY)) @@ -667,9 +704,6 @@ (IGEQ ROTATION 0)) elseif (EQ ROTATION '*) else (\ILLEGAL.ARG ROTATION)) - (CL:WHEN CHARSET - (CL:UNLESS (<= 0 CHARSET \MAXCHARSET) - (\ILLEGAL.ARG CHARSET))) (CL:WHEN FONTX (* ;; "Return FONTX only if no fields were overwritten") @@ -679,7 +713,7 @@ (EQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONTX)) (EQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX))) (SETQ FONTX NIL))) - (OR FONTX (LIST FAMILY SIZE FACE ROTATION DEVICE]) + (OR FONTX (MAKEFONTSPEC FAMILY SIZE FACE ROTATION DEVICE]) (\FONT.CHECKARGS1 [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 22-Jul-2025 18:47 by rmk") @@ -761,13 +795,14 @@ (ERROR (CONCAT "FONTCREATE function is not specified for image-type " DEVICE]) (FONTFILEP - [LAMBDA (FILE DEVICE) (* ; "Edited 13-Jul-2025 13:41 by rmk") + [LAMBDA (FILE DEVICE) (* ; "Edited 25-Aug-2025 10:22 by rmk") + (* ; "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)) + then (for FNS STRM in (FONTDEVICEPROP DEVICE 'CHARSETFNS) first [RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT)) `(PROGN (CLOSEF? OLDVALUE] do (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS) @@ -776,7 +811,11 @@ (CLOSEF? STRM))))]) (\READCHARSET - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 21-Jul-2025 18:35 by rmk") + [LAMBDA (FONTSPEC CHARSET FONT) (* ; "Edited 2-Sep-2025 23:57 by rmk") + (* ; "Edited 28-Aug-2025 23:17 by rmk") + (* ; "Edited 25-Aug-2025 12:03 by rmk") + (* ; "Edited 16-Aug-2025 18:00 by rmk") + (* ; "Edited 21-Jul-2025 18:35 by rmk") (* ; "Edited 14-Jul-2025 19:51 by rmk") (* ; "Edited 12-Jul-2025 13:20 by rmk") (* ; "Edited 10-Jul-2025 12:38 by rmk") @@ -784,13 +823,13 @@ (* ;; "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) + (CL:WHEN (EQ 0 (fetch (FONTSPEC FSROTATION) of FONTSPEC)) (RESETLST - (for FILE STRM CSINFO in (FONTFILES FAMILY SIZE FACE ROTATION DEVICE CHARSET) + (for FILE STRM CSINFO in (FONTFILES FONTSPEC 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)) + (for FNS FAMILY in (FONTDEVICEPROP FONTSPEC 'CHARSETFNS) do [RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT)) `(PROGN (CLOSEF? OLDVALUE] (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS) @@ -799,12 +838,13 @@ (* ;; "Assume that predicate leaves stream (open or closed) in proper state for its retrieval function. The FILE may be of the right type, but it may not contain this CHARSET (e.g. a complete MEDLEYFONTFILE but CHARSET doesn't exist anywhere).") (SETQ CSINFO (APPLY* (CADDR FNS) - STRM CHARSET FAMILY SIZE FACE ROTATION DEVICE)) + STRM CHARSET FONT)) (CL:WHEN (type? CHARSETINFO CSINFO) (CL:UNLESS (CHARSETPROP CSINFO 'CSCHARENCODING) (* ;; "The file didn't know its own encoding") + (SETQ FAMILY (fetch (FONTSPEC FSFAMILY) of FONTSPEC)) (CHARSETPROP CSINFO 'CSCHARENCODING (if (NEQ CHARSET 0) then 'MCCS elseif (MEMB FAMILY @@ -821,81 +861,244 @@ (CHARSETPROP CSINFO 'FILE (MKSTRING (PSEUDOFILENAME FILE))) (CL:UNLESS (CHARSETPROP CSINFO 'SOURCE) - (CHARSETPROP CSINFO 'SOURCE (MAKECSSOURCE FAMILY SIZE FACE - ROTATION DEVICE CHARSET))) + (CHARSETPROP CSINFO 'SOURCE (create FONTSPEC using FONTSPEC))) + (replace (CHARSETINFO CHARSETNO) of CSINFO with CHARSET) (RETURN))) (* ;; "Prepare for next format-type") (CLOSEF? STRM)) (CL:WHEN CSINFO (RETURN CSINFO)))))]) - -(\COERCEFONTSPEC - [LAMBDA (COERCIONS FAMILY SIZE FACE ROTATION DEVICE CHARSET) - (* ; "Edited 23-Jul-2025 15:39 by rmk") - - (* ;; "Produces a list of coerced fontspecs, one for each coercion whose right side matches the given parameters.") - - (* ;; "If MFAMILY is NIL, use FAMILY--default when nothing else matches.") - - (for C MATCH TARGET MFAMILY MSIZE TFAMILY TSIZE COERCED in COERCIONS - eachtime (SETQ MATCH (CAR C)) - (if (LISTP MATCH) - then (SETQ MFAMILY (OR (CAR MATCH) - FAMILY)) - (SETQ MSIZE (OR (CADR MATCH) - SIZE)) - else (SETQ MFAMILY (OR MATCH FAMILY)) - (SETQ MSIZE SIZE)) when [AND (EQ FAMILY MFAMILY) - (EQ SIZE MSIZE) - (PROGN (SETQ TARGET (CADR C)) - (* ; - "Don't include the input in the output, if the coercions have a loop") - (if (LISTP TARGET) - then (SETQ TFAMILY (OR (CAR TARGET) - FAMILY)) - (SETQ TSIZE (OR (CADR TARGET) - SIZE)) - else (SETQ TFAMILY TARGET) - (SETQ TSIZE SIZE)) - (NOT (AND (EQ FAMILY TFAMILY) - (EQ SIZE TSIZE] - unless (MEMBER (SETQ COERCED (LIST TFAMILY TSIZE FACE ROTATION DEVICE CHARSET)) - $$VAL) collect COERCED]) ) (DEFINEQ -(\COERCEFONTDESC - [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 27-Jul-2025 13:38 by rmk") - (* ; "Edited 22-Jul-2025 18:47 by rmk") - (* ; "Edited 14-Jul-2025 19:40 by rmk") - (* ; "Edited 5-Jul-2025 14:16 by rmk") - (* ; "Edited 29-Aug-91 12:19 by jds") +(\FONT.CHECKARGS + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Aug-2025 14:46 by rmk") + (* ; "Edited 23-Aug-2025 11:54 by rmk") + (* ; "Edited 17-Aug-2025 19:15 by rmk") + (* ; "Edited 12-Aug-2025 22:36 by rmk") + (* ; "Edited 10-Aug-2025 12:06 by rmk") + (* ; "Edited 8-Aug-2025 09:57 by rmk") + (* ; "Edited 27-Jul-2025 13:30 by rmk") + (* ; "Edited 22-Jul-2025 23:07 by rmk") + (* ; "Edited 21-Jul-2025 09:22 by rmk") + (* ; "Edited 14-Jul-2025 20:09 by rmk") + (* ; "Edited 11-Jul-2025 10:15 by rmk") + (* ; "Edited 5-Jul-2025 13:37 by rmk") + (* ; "Edited 2-Jul-2025 16:50 by rmk") + (* ; "Edited 27-Jun-2025 10:42 by rmk") + (* ; "Edited 15-Jun-2025 00:25 by rmk") - (* ;; "It was intended to remove this function in favor of FONTCREATE as FONT was cleaned up to avoid stack overflows in certain situations. The calls in system code have been replaced, but the macros for FONTASCENT, FONTDESCENT, and FONTHEIGHT were putting out calls. So there may be calls in user code that still has compiled references.") + (* ;; "DON'T BREAK, TRACE, OR UNSAVE THIS UNLESS ALL SYSTEM FONTS HAVE ALREADY BEEN INSTANTIATED") - (* ;; "Those macro calls all had NIL for STREAM and NOERRORFLG. So here we give a dummy definition that just calls FONTCREATE") + (* ;; "Decodes and checks the various ways of specifying the arguments to font lookup functions.") - (* ;; "We probably should put out a macro to compile \COERCEFONTDESC away.") + (* ;; "If FAMILY can be coerced to a font descriptor and none of its properties are overwritten by the other aguments, then that font descriptor is returned. Otherwise the value is the coerced fontspec (family size face rotation device).") - (FONTCREATE SPEC]) + (LET (FONTX) + (CL:WHEN (AND (EQ 'CLASS (CAR (LISTP FAMILY))) + (LITATOM (CADR FAMILY))) + + (* ;; "This used to be at the entry to FONTCREATE, and it returned the FONTCLASS. That seemed wrong--FONTCREATE should always return a fontdescriptor. So here we build a throwaway fontclass, coerce it to its device font, and fall through.") + + (SETQ FAMILY (\FONT.CHECKARGS1 (FONTCLASS (CADR FAMILY) + (CDDR FAMILY)) + DEVICE))) + (CL:UNLESS (AND FAMILY (LITATOM FAMILY) + (NEQ FAMILY T)) + + (* ;; "FAMILY T or NIL produces an error below") + + [if (LISTP FAMILY) + then + (* ;; "Presumably a FONTSPEC. The variables here override the FONTX properties, as with the fontdescriptor below ") + + (SETQ FONTX (CL:IF (EQ 'FONT (CAR FAMILY)) + (CDR FAMILY) + FAMILY)) + (SETQ FAMILY (fetch (FONTSPEC FSFAMILY) of FONTX)) + (SETQ SIZE (OR SIZE (fetch (FONTSPEC FSSIZE) of FONTX))) + (SETQ FACE (OR FACE (fetch (FONTSPEC FSFACE) of FONTX))) + (SETQ ROTATION (OR ROTATION (fetch (FONTSPEC FSROTATION) of FONTX))) + (SETQ DEVICE (OR DEVICE (fetch (FONTSPEC FSDEVICE) of FONTX))) + (SETQ FONTX NIL) + elseif (SETQ FONTX (CL:IF (type? FONTDESCRIPTOR FAMILY) + FAMILY + (\FONT.CHECKARGS1 FAMILY DEVICE T))) + then + (* ;; + "FAMILY was a spec for a font descriptor. 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)))]) + + (* ;; "We have decoded the arguments, fill in defaults and validate") + + (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:UNLESS (AND FAMILY (LITATOM FAMILY) + (NEQ FAMILY T)) + (ERROR "Illegal font family" FAMILY)) + (SETQ FAMILY (U-CASE FAMILY)) + (CL:UNLESS (OR (AND (FIXP SIZE) + (IGREATERP SIZE 0)) + (EQ SIZE '*)) + (ERROR "Illegal font size" SIZE)) + (CL:UNLESS (EQ FACE '*) + (SETQ FACE (\FONTFACE FACE NIL DEVICE))) + (if (NULL ROTATION) + then (SETQ ROTATION 0) + elseif (AND (FIXP ROTATION) + (IGEQ ROTATION 0)) + elseif (EQ ROTATION '*) + else (\ILLEGAL.ARG ROTATION)) + (CL:WHEN FONTX + + (* ;; "Return FONTX only if no fields were overwritten") + + (CL:UNLESS (AND (EQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of FONTX)) + (EQUAL FACE (fetch (FONTDESCRIPTOR FONTFACE) of FONTX)) + (EQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONTX)) + (EQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONTX))) + (SETQ FONTX NIL))) + (OR FONTX (MAKEFONTSPEC FAMILY SIZE FACE ROTATION DEVICE]) + +(\CHARSET.CHECK + [LAMBDA (CHARSET) (* ; "Edited 28-Aug-2025 14:35 by rmk") + (if CHARSET + then (CHARSET.DECODE (CL:IF (LISTP CHARSET) + (CAR CHARSET) + CHARSET)) + else 0]) +) +(DEFINEQ + +(COERCEFONTSPEC + [LAMBDA (FONTSPEC COERCIONS) (* ; "Edited 28-Aug-2025 14:41 by rmk") + (* ; "Edited 25-Aug-2025 10:22 by rmk") + (* ; "Edited 17-Aug-2025 19:15 by rmk") + (* ; "Edited 16-Aug-2025 17:47 by rmk") + (* ; "Edited 12-Aug-2025 12:30 by rmk") + (* ; "Edited 10-Aug-2025 12:03 by rmk") + (* ; "Edited 5-Aug-2025 17:27 by rmk") + (* ; "Edited 23-Jul-2025 15:39 by rmk") + + (* ;; "Produces a list of coerced fontspecs, one for each coercion whose right side matches the given FONTSPEC parameters.") + + (* ;; "Doesn't make sense to coerce the device, DEVICE and also CHARSET are just carried along.") + + (* ;; "A NIL match component matches everything, and a NIL target component denotes the corresponding argument.") + + (for C MATCH TARGET MFAMILY MSIZE MFACE MROTATION TFAMILY TSIZE TFACE TROTATION COERCED FAMILY + SIZE FACE ROTATION DEVICE in (OR COERCIONS (FONTDEVICEPROP FONTSPEC 'FONTCOERCIONS)) + first (SPREADFONTSPEC FONTSPEC) eachtime (SETQ MATCH (MKLIST (CAR C))) + when [AND (COERCEFONTSPEC.MATCH (pop MATCH) + FAMILY) + (COERCEFONTSPEC.MATCH (pop MATCH) + SIZE) + (COERCEFONTSPEC.MATCH (pop MATCH) + FACE) + (COERCEFONTSPEC.MATCH (CAR MATCH) + ROTATION) + (PROGN (SETQ TARGET (MKLIST (CADR C))) + (SETQ TFAMILY (COERCEFONTSPEC.TARGET (pop TARGET) + FAMILY)) + (SETQ TSIZE (COERCEFONTSPEC.TARGET (pop TARGET) + SIZE)) + (SETQ TFACE (COERCEFONTSPEC.TARGET (pop TARGET) + FACE)) + (SETQ TROTATION (COERCEFONTSPEC.TARGET ROTATION (pop TARGET))) + + (* ;; "Don't include the input in the output, if the coercions have a loop") + + (NOT (AND (EQ FAMILY TFAMILY) + (EQ SIZE TSIZE) + (EQUAL FACE TFACE) + (EQ ROTATION TROTATION] + unless (MEMBER (SETQ COERCED (MAKEFONTSPEC TFAMILY TSIZE TFACE TROTATION DEVICE)) + $$VAL) collect COERCED]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS COERCEFONTSPEC.MATCH MACRO [(M F) (* ; "* can't be car--comment") + (LET ((MM M) + *) + (DECLARE (LOCALVARS MM) + (SPECVARS *)) + (SETQ * F) + (OR (EQ * MM) + (MEMB MM '(NIL *)) + (AND (LISTP MM) + (EVAL MM]) + +(PUTPROPS COERCEFONTSPEC.TARGET MACRO + (OPENLAMBDA (TG F) + (if (MEMB TG '(NIL *)) + then F + elseif (AND (LISTP TG) + (LET (VAL *) + (DECLARE (LOCALVARS VAL) + (SPECVARS *)) (* ; "* Can't be car--comment") + (SETQ * F) + (SETQ VAL (EVAL TG)) + (CL:IF (MEMB VAL '(NIL *)) + F + VAL))) + else TG))) +) ) (DECLARE%: EVAL@COMPILE -(PUTPROPS SPREADFONTSPEC MACRO (OPENLAMBDA (FONTSPEC) - (CL:WHEN (type? FONTDESCRIPTOR FONTSPEC) - (SETQ FONTSPEC (FONTPROP FONTSPEC 'SPEC))) - (SETQ SIZE (CADR FONTSPEC)) - (SETQ FACE (CADDR FONTSPEC)) - (SETQ ROTATION (CADDDR FONTSPEC)) - (SETQ DEVICE (CAR (CDDDDR FONTSPEC))) - (SETQ CHARSET (CADR (CDDDDR FONTSPEC))) - (SETQ FAMILY (CAR FONTSPEC)))) +(PUTPROPS SPREADFONTSPEC MACRO [(FONTSPEC) + (LET ((FS FONTSPEC)) + + (* ;; "Unwrap a FONTSPEC sequentially") + + (CL:WHEN (type? FONTDESCRIPTOR FS) + (SETQ FS (FONTPROP FS 'SPEC))) + (SETQ FAMILY (pop FS)) + (SETQ SIZE (pop FS)) + (SETQ FACE (pop FS)) + (SETQ ROTATION (pop FS)) + (SETQ DEVICE (pop FS]) +) +(DEFINEQ + +(MAKEFONTSPEC + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Aug-2025 14:32 by rmk") + (* ; "Edited 17-Aug-2025 20:44 by rmk") + + (* ;; "This is a function, not a macro, so that it can be used in the loadup sequence to create the FONTSPEC for the \GUARANTEEDDISPLAYFONT. That font is created by \CREATEFONT and therefore is not dependent on \FONT.CHECKARGS or on the multi-alist multi-key indexing functions. The strategy might change if MULTI-ALIST is moved earlier in the loadup sequence.") + + (create FONTSPEC + FSFAMILY _ FAMILY + FSSIZE _ SIZE + FSFACE _ FACE + FSROTATION _ ROTATION + FSDEVICE _ DEVICE]) ) (DEFINEQ (COMPLETE.FONT - [LAMBDA (FONTSPEC EVENIFCOMPLETE) (* ; "Edited 21-Jun-2025 11:37 by rmk") + [LAMBDA (FONTSPEC EVENIFCOMPLETE) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 29-Aug-2025 23:51 by rmk") + (* ; "Edited 27-Aug-2025 10:51 by rmk") + (* ; "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") @@ -906,29 +1109,35 @@ (* ;; "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") + (LET ((FONT (FONTCREATE FONTSPEC))) + (SETQ FONTSPEC (FONTPROP FONT 'SPEC)) (* ; "Normalized version") (CL:WHEN (OR EVENIFCOMPLETE (NOT (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT))) - (for CS from 0 to \MAXCHARSET do - (* ;; - "Skips existing charsets--they already have as much information as they are ever going to get") - - (\INSURECHARSETINFO CS FONT)) + (for CHARSET CSINFO from 0 to \MAXCHARSET + do (if (SETQ CSINFO (\GETCHARSETINFO FONT CHARSET)) + then (CL:WHEN EVENIFCOMPLETE + (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with NIL)) + else (SETQ CSINFO (\CREATECHARSET CHARSET FONT))) + (COMPLETE.CHARSET CSINFO FONTSPEC CHARSET FONT)) (replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with T)) - (PRUNEFONTSLUGS FONT) + (PRUNESLUGCSINFOS FONT) FONT]) (COMPLETEFONTP - [LAMBDA (FONT) (* ; "Edited 24-May-2025 20:55 by rmk") + [LAMBDA (FONT) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "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]) + (for CS from 0 to \MAXCHARSET always (\GETCHARSETINFO FONT CS]) (COMPLETE.CHARSET - [LAMBDA (CSINFO FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS FONTDESC) + [LAMBDA (CSINFO FONTSPEC CHARSET FONT) (* ; "Edited 7-Sep-2025 11:23 by rmk") + (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 28-Aug-2025 20:46 by rmk") + (* ; "Edited 27-Aug-2025 12:37 by rmk") + (* ; "Edited 17-Aug-2025 11:47 by rmk") (* ; "Edited 12-Jul-2025 13:15 by rmk") (* ; "Edited 10-Jul-2025 12:38 by rmk") (* ; "Edited 9-Jul-2025 09:12 by rmk") @@ -937,29 +1146,35 @@ (* ; "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.") + (* ;; "CSINFO has some characters for this charset in FONT, but others may fill in from the FONTSPEC of later fonts in the coercion chain. We assume that CSINFO is or will be the charsetinfo for the charset/font described by FONTSPEC. 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.") + (\SETCHARSETINFO FONT CHARSET 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)) + (for CODE SOURCEFONT from (FIRSTCHARSETCODE CHARSET) to (LASTCHARSETCODE CHARSET) + when [AND (SLUGCHARP.DISPLAY CODE FONT) + (SETQ SOURCEFONT (CAR (\COERCECHARSET FONTSPEC CHARSET CODE] + collect (LIST (LIST CODE SOURCEFONT) + CODE) finally (CL:WHEN $$VAL (* ; "The source is now here") + (MOVEFONTCHARS $$VAL FONT) + (CHARSETPROP CSINFO 'SOURCE FONTSPEC))) + (CL:WHEN (FONTDEVICEPROP FONT 'CHARCOERCIONS) (* ; + "Maybe coercions are just being delayed") + (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with T))) CSINFO]) -(PRUNEFONTSLUGS - [LAMBDA (FONT) (* ; "Edited 9-Jun-2025 15:02 by rmk") +(PRUNESLUGCSINFOS + [LAMBDA (FONT) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 17-Aug-2025 19:44 by rmk") + (* ; "Edited 9-Jun-2025 15:02 by rmk") (* ; "Edited 24-May-2025 21:11 by rmk") + + (* ;; "Replaces slug csinfos in FONT with NIL") + (SETQ FONT (FONTCREATE FONT)) - (for CS CSINFO from 0 to \MAXCHARSET when (AND (SETQ CSINFO (\XGETCHARSETINFO FONT CS)) + (for CS CSINFO from 0 to \MAXCHARSET when (AND (SETQ CSINFO (\GETCHARSETINFO FONT CS)) (fetch (CHARSETINFO CSSLUGP) of CSINFO)) - do (\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT) - CS NIL)) + do (\SETCHARSETINFO FONT CS NIL)) FONT]) ) @@ -989,7 +1204,10 @@ (fetch (FONTDESCRIPTOR \SFHeight) of (FONTCREATE FONTSPEC]) (FONTPROP - [LAMBDA (FONT PROP) (* ; "Edited 23-Jul-2025 17:01 by rmk") + [LAMBDA (FONT PROP) (* ; "Edited 2-Sep-2025 22:21 by rmk") + (* ; "Edited 12-Aug-2025 21:10 by rmk") + (* ; "Edited 10-Aug-2025 13:28 by rmk") + (* ; "Edited 23-Jul-2025 17:01 by rmk") (* ; "Edited 13-Jul-2025 22:44 by rmk") (* ; "Edited 8-Jun-2025 20:42 by rmk") (* ; "Edited 24-May-2025 07:40 by rmk") @@ -1015,56 +1233,51 @@ (DEVICE (ffetch FONTDEVICE of FONT)) (CHARENCODING [OR (ffetch FONTCHARENCODING of FONT) (freplace FONTCHARENCODING of FONT - with (if (NEQ CHARSET 0) - then 'MCCS - elseif (MEMB (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) - NSFONTFAMILIES) + with (if (MEMB (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) + NSFONTFAMILIES) then 'XCCS$ elseif (MEMB (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) ALTOFONTFAMILIES) then 'ALTOTEXT else (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT]) - (SPEC (LIST (ffetch FONTFAMILY of FONT) - (ffetch FONTSIZE of FONT) - (COPY (ffetch FONTFACE of FONT)) - (ffetch ROTATION of FONT) - (ffetch FONTDEVICE of FONT))) + (SPEC (create FONTSPEC + FSFAMILY _ (ffetch FONTFAMILY of FONT) + FSSIZE _ (ffetch FONTSIZE of FONT) + FSFACE _ (COPY (ffetch FONTFACE of FONT)) + FSROTATION _ (ffetch ROTATION of FONT) + FSDEVICE _ (ffetch FONTDEVICE of FONT))) (DEVICESPEC (* ;  "DEVICE fields are for communicating coercions to the particular printing device") - [COND - ((ffetch FONTDEVICESPEC of FONT) - (COPY (ffetch FONTDEVICESPEC of FONT))) - (T (FONTPROP FONT 'SPEC]) - (DEVICEFACE [COPY (COND - ((ffetch FONTDEVICESPEC of FONT) - (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]) - (DEVICEWEIGHT [fetch WEIGHT of (COND - ((ffetch FONTDEVICESPEC of FONT) - (CADDR (ffetch FONTDEVICESPEC of FONT))) - (T (ffetch FONTFACE of FONT]) + (CL:IF (ffetch FONTDEVICESPEC of FONT) + (COPY (ffetch FONTDEVICESPEC of FONT)) + (FONTPROP FONT 'SPEC))) + (DEVICEFAMILY (CL:IF (ffetch FONTDEVICESPEC of FONT) + (fetch (FONTSPEC FSFAMILY) of (ffetch FONTDEVICESPEC of FONT)) + (ffetch FONTFAMILY of FONT))) + (DEVICESIZE (CL:IF (ffetch FONTDEVICESPEC of FONT) + (fetch (FONTSPEC FSSIZE) of (ffetch FONTDEVICESPEC of FONT)) + (ffetch FONTSIZE of FONT))) + (DEVICEFACE (COPY (CL:IF (ffetch FONTDEVICESPEC of FONT) + (fetch (FONTSPEC FSFACE) of (ffetch FONTDEVICESPEC of FONT)) + (ffetch FONTFACE of FONT)))) + (DEVICESLOPE (fetch SLOPE of (CL:IF (ffetch FONTDEVICESPEC of FONT) + (fetch (FONTSPEC FSFACE) of (ffetch FONTDEVICESPEC + of FONT)) + (ffetch FONTFACE of FONT)))) + (DEVICEWEIGHT (fetch WEIGHT of (CL:IF (ffetch FONTDEVICESPEC of FONT) + (fetch (FONTSPEC FSFACE) of (ffetch FONTDEVICESPEC + of FONT)) + (ffetch FONTFACE of FONT)))) (DEVICEEXPANSION - [fetch EXPANSION of (COND - ((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))) - (T (ffetch FONTSIZE of FONT)))) - (DEVICEFAMILY (COND - ((ffetch FONTDEVICESPEC of FONT) - (CAR (ffetch FONTDEVICESPEC of FONT))) - (T (ffetch FONTFAMILY of FONT)))) + (fetch EXPANSION of (CL:IF (ffetch FONTDEVICESPEC of FONT) + (fetch (FONTSPEC FSFACE) of (ffetch FONTDEVICESPEC of FONT)) + (ffetch FONTFACE 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)) + (FONTTOMCCSFN (ffetch FONTTOMCCSFN of FONT)) (\ILLEGAL.ARG PROP]) (\AVGCHARWIDTH @@ -1082,19 +1295,55 @@ then W else 1]) ) +(* "FOLLOWING DEFINITIONS EXPORTED") +(DEFOPTIMIZER FONTPROP (&REST ARGS) + (SELECTQ (AND (EQ (CAADR ARGS) + 'QUOTE) + (CADADR ARGS)) + (ASCENT `(FONTASCENT ,(CAR ARGS))) + (DESCENT `(FONTDESCENT ,(CAR ARGS))) + (HEIGHT `(FONTHEIGHT ,(CAR ARGS))) + (FONTTOMCCSFN `(fetch (FONTDESCRIPTOR FONTTOMCCSFN) + of ,(CAR ARGS))) + 'IGNOREMACRO)) + +(* "END EXPORTED DEFINITIONS") + +(DEFINEQ + +(FONTDEVICEPROP + [LAMBDA (FONTDEVICE PROP) (* ; "Edited 25-Aug-2025 21:23 by rmk") + + (* ;; "Returns the value of the PROP property of the FONTDEVICE. E.g. if FONTDEVICE is DISPLAY and PROP is %"FONTCOERCIONS%", returns the value of DISPLAYFONTCOERCIONS ((HELVETICA 1)(HELVETICA 4)...)") + + [if (LITATOM FONTDEVICE) + then (SETQ FONTDEVICE (\FONTSYMBOL FONTDEVICE)) + else (SETQ FONTDEVICE (\FONT.CHECKARGS FONTDEVICE)) + (SETQ FONTDEVICE (CL:IF (type? FONTDESCRIPTOR FONTDEVICE) + (FONTPROP FONTDEVICE 'DEVICE) + (fetch (FONTSPEC FSDEVICE) of FONTDEVICE))] + (CL:UNLESS FONTDEVICE + (SETQ FONTDEVICE 'DISPLAY)) + (LET ((VAR (PACK* FONTDEVICE PROP))) + (CL:WHEN (BOUNDP VAR) + (GETATOMVAL VAR]) +) -(* ;; "Moving character information") +(* ; "Moving character information") (DEFINEQ (EDITCHAR - [LAMBDA (CHARCODE FONT) (* ; "Edited 14-Jul-2025 22:54 by rmk") + [LAMBDA (CHARCODE FONT) (* ; "Edited 28-Aug-2025 23:50 by rmk") + (* ; "Edited 14-Jul-2025 22:54 by rmk") (* ; "Edited 5-Jul-2025 18:47 by rmk") (* rrb "24-MAR-82 12:22") (* ;  "calls the bitmap editor on a character of a font") + (SETQ CHARCODE (OR (CHARCODEP CHARCODE) + (CHARCODE.DECODE CHARCODE))) (LET ((FONTDESC (FONTCREATE FONT))) (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC]) ) @@ -1106,19 +1355,24 @@ (DEFINEQ (GETCHARBITMAP - [LAMBDA (CHARCODE FONT) (* ; "Edited 7-Jun-2025 09:55 by rmk") + [LAMBDA (CHARCODE FONT) (* ; "Edited 30-Aug-2025 23:19 by rmk") + (* ; "Edited 3-Aug-2025 13:28 by rmk") + (* ; "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)) + (SETQ CHARCODE (CL:IF (CHARCODEP CHARCODE) + CHARCODE + (CHARCODE.DECODE CHARCODE))) (\GETCHARBITMAP.CSINFO (\CHAR8CODE CHARCODE) - (\INSURECHARSETINFO (\CHARSET CHARCODE) - (FONTCREATE FONT]) + (\INSURECHARSETINFO (FONTCREATE FONT) + (\CHARSET CHARCODE]) (PUTCHARBITMAP - [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 7-Jun-2025 10:16 by rmk") + [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 30-Aug-2025 23:20 by rmk") + (* ; "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") @@ -1131,8 +1385,7 @@ (\ILLEGAL.ARG NEWCHARBITMAP)) (SETQ CHARCODE (CHARCODE.DECODE CHARCODE)) (SETQ FONT (FONTCREATE FONT)) - (LET ((CSINFO (\INSURECHARSETINFO (\CHARSET CHARCODE) - FONT))) + (LET [(CSINFO (\INSURECHARSETINFO FONT (\CHARSET CHARCODE] (UNINTERRUPTABLY (CL:WHEN (\PUTCHARBITMAP.CSINFO (\CHAR8CODE CHARCODE) CSINFO NEWCHARBITMAP NEWCHARDESCENT) @@ -1149,7 +1402,8 @@ NIL NEWCHARBITMAP]) (\GETCHARBITMAP.CSINFO - [LAMBDA (CODE CSINFO) (* ; "Edited 7-Jun-2025 09:56 by rmk") + [LAMBDA (CODE CSINFO) (* ; "Edited 3-Aug-2025 20:59 by rmk") + (* ; "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") @@ -1177,7 +1431,8 @@ CBM]) (\PUTCHARBITMAP.CSINFO - [LAMBDA (CODE CSINFO NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 7-Jun-2025 10:15 by rmk") + [LAMBDA (THINCODE CSINFO NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 24-Aug-2025 09:56 by rmk") + (* ; "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") @@ -1192,8 +1447,8 @@ (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))) + (CIMWIDTH (AND IMWIDTHS (\FGETIMAGEWIDTH IMWIDTHS THINCODE))) + (CWIDTH (OR CIMWIDTH (\FGETWIDTH WIDTHS THINCODE))) (FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) (OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP)) TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET @@ -1208,11 +1463,11 @@ (SETQ NDESCENT (IMAX BDESCENT CDESCENT)) (SETQ NASCENT (IMAX BASCENT CASCENT)) (SETQ NHEIGHT (IPLUS NDESCENT NASCENT)) - (SETQ CHAROFFSET (\FGETOFFSET OFFSETS CODE)) + (SETQ CHAROFFSET (\FGETOFFSET OFFSETS THINCODE)) (* ;; "set up a new target bitmap if any of the parameters have changed.") - (if (EQ CHAROFFSET (\FGETOFFSET OFFSETS \MAXTHINCHAR)) + (if (EQ CHAROFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX)) then (* ;; "changing the bitmap for a character which formerly pointed at the slug character. Allocate a new bitmap character bitmap for this.") @@ -1262,14 +1517,14 @@ (UNINTERRUPTABLY (* ;  "update the parameters for this character set.") - (\FSETWIDTH WIDTHS CODE BWIDTH) (* ; "The new character's correct width") + (\FSETWIDTH WIDTHS THINCODE BWIDTH) (* ; "The new character's correct width") (* ;  "Make sure that we update imagewidths also") - (CL:WHEN IMWIDTHS (\FSETIMAGEWIDTH IMWIDTHS CODE BWIDTH)) - (\FSETOFFSET OFFSETS CODE CHAROFFSET) + (CL:WHEN IMWIDTHS (\FSETIMAGEWIDTH IMWIDTHS THINCODE BWIDTH)) + (\FSETOFFSET OFFSETS THINCODE CHAROFFSET) (CL:WHEN DW - (for I from 0 to \MAXTHINCHAR when (IGREATERP (\FGETOFFSET OFFSETS I) - CHAROFFSET) + (for I from 0 to SLUGCHARINDEX when (IGREATERP (\FGETOFFSET OFFSETS I) + CHAROFFSET) do (* ;;  "If the imagewidth has changed, offsets after the modified character have to be adjusted. ") @@ -1318,7 +1573,11 @@ NEWDESCENT]) (MOVEFONTCHARS - [LAMBDA (PAIRS DESTFONT DEFAULTSOURCEFONT) (* ; "Edited 24-Jul-2025 21:05 by rmk") + [LAMBDA (PAIRS DESTFONT DEFAULTSOURCEFONT) (* ; "Edited 4-Sep-2025 11:07 by rmk") + (* ; "Edited 30-Aug-2025 23:20 by rmk") + (* ; "Edited 26-Aug-2025 23:10 by rmk") + (* ; "Edited 25-Aug-2025 09:12 by rmk") + (* ; "Edited 24-Jul-2025 21:05 by rmk") (* ; "Edited 9-Jul-2025 09:13 by rmk") (* ; "Edited 17-Jun-2025 19:53 by rmk") (* ; "Edited 7-Jun-2025 00:06 by rmk") @@ -1337,83 +1596,57 @@ (CL:WHEN PAIRS (SETQ DESTFONT (FONTCREATE DESTFONT)) - (LET ((DEVICE (FONTPROP DESTFONT 'DEVICE)) - PAIRINFO) - (SETQ DEFAULTSOURCEFONT (CL:IF DEFAULTSOURCEFONT - (FONTCREATE DEFAULTSOURCEFONT NIL NIL NIL DEVICE) - DESTFONT)) + (SETQ DEFAULTSOURCEFONT (CL:IF DEFAULTSOURCEFONT + (FONTCREATE DEFAULTSOURCEFONT NIL NIL NIL (FONTPROP DESTFONT + 'DEVICE)) + DESTFONT)) + (LET (PAIRINFO) (* ;; "Fix/check arguments, and expand out the information for all the source characters, so there is no toe-stepping if there are overlaps.") - (SETQ PAIRINFO (for P S SCODE SFONT DCODE SCSINFO DCSINFO in PAIRS - collect (CL:WHEN (SMALLP P) - (SETQ P (LIST P P))) - (SETQ S (CAR P)) - (SETQ DCODE (CADR P)) - (CL:UNLESS (CHARCODEP DCODE) - (SETQ DCODE (CHARCODE.DECODE DCODE))) - (CL:UNLESS (\INSURECHARSETINFO (\CHARSET DCODE) - DESTFONT)) - (SETQ SCODE (CL:IF (LISTP S) - (CAR S) - S)) - (CL:UNLESS (CHARCODEP SCODE) - (SETQ SCODE (CHARCODE.DECODE SCODE))) - (SETQ SFONT (CL:IF (LISTP S) - (FONTCREATE (CADR S) - NIL NIL NIL DEVICE) - DEFAULTSOURCEFONT)) - (CL:UNLESS (SETQ SCSINFO (\INSURECHARSETINFO (\CHARSET SCODE) - SFONT))) - (CL:UNLESS (SETQ DCSINFO (\INSURECHARSETINFO (\CHARSET DCODE) - DESTFONT)) - - (* ;; - "If the destination csinfo doesn't exist, initialize with a copy of the source character's csinfo") - - (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of DESTFONT) - (\CHARSET DCODE) - (COPYALL SCSINFO))) - (LIST (LIST SCODE (\GETCHARINFO SCSINFO (\CHAR8CODE SCODE))) - DCODE))) + (SETQ PAIRINFO (for P S DCODE in PAIRS collect (CL:WHEN (SMALLP P) + (SETQ P (LIST P P))) + (SETQ DCODE (CADR P)) + (CL:UNLESS (CHARCODEP DCODE) + (SETQ DCODE (CHARCODE.DECODE DCODE))) + (\INSURECHARSETINFO DESTFONT (\CHARSET + DCODE)) + (LIST (\MOVEFONTCHARS.SOURCEDATA + (CAR P) + DEFAULTSOURCEFONT) + DCODE))) (* ;; "Install source character information into the destination font. ") - (for P DCHARCODE DCSINFO ASCENT DESCENT in PAIRINFO - do (SETQ DCHARCODE (CADR P)) - (SETQ DCSINFO (\XGETCHARSETINFO DESTFONT (\CHARSET DCHARCODE))) - (CL:WHEN (fetch (CHARSETINFO CSSLUGP) of DCSINFO) - (* ; "Break the slug-sharing") - (SETQ DCSINFO (create CHARSETINFO copying DCSINFO CSSLUGP _ NIL)) - (\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR)) - (\CHARSET DCHARCODE) - DCSINFO)) - (\MOVEFONTCHAR (CADAR P) - DCSINFO - (\CHAR8CODE (CAAR P)) - (\CHAR8CODE DCHARCODE) - DESTFONT)))) + (for P in PAIRINFO do (\MOVEFONTCHAR (CAR P) + (CADR P) + DESTFONT)))) DESTFONT]) (\MOVEFONTCHAR - [LAMBDA (SCHARINFO DCSINFO SCODE DCODE DFONT) (* ; "Edited 24-Jul-2025 10:47 by rmk") + [LAMBDA (SOURCEDATA DCODE DFONT) (* ; "Edited 4-Sep-2025 12:37 by rmk") + (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 28-Aug-2025 20:50 by rmk") + (* ; "Edited 26-Aug-2025 22:25 by rmk") + (* ; "Edited 25-Aug-2025 09:13 by rmk") + (* ; "Edited 24-Jul-2025 10:47 by rmk") (* ; "Edited 22-Jul-2025 13:18 by rmk") (* ; "Edited 8-Jul-2025 22:23 by rmk") (* ; "Edited 17-Jun-2025 19:53 by rmk") (* ; "Edited 7-Jun-2025 14:43 by rmk") - (* ;; "Internal CSINFO-level function to move the information for (thinchar) SCODE in the source CSINFO to (thinchar) DCODE) in the destination CSINFO.") + (* ;; "Internal CSINFO-level function to move the information for STHINCODE in the source CSINFO to DTHINCODE) 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.") + (* ;; "The caller (MOVEFONTCHARS) may have provided the source character information as an alist structure to avoid stepping on toes. If SOURCEDATA is a CSINFO, the alist is extracted here.") - (* ;; "If DFONT is provided, its ascent and descent may be adjusted to reflect SCHARINFO.") + (* ;; "If DFONT is provided, its ascent and descent may be adjusted to reflect SOURCEDATA.") - (CL:WHEN (type? CHARSETINFO SCHARINFO) - (SETQ SCHARINFO (\GETCHARINFO SCHARINFO SCODE))) - (LET (DESCENT ASCENT TEMP) - (CL:WHEN [AND (FGETMULTI SCHARINFO 'IMAGEWIDTHS) - (NEQ (FGETMULTI SCHARINFO 'WIDTHS) - (FGETMULTI SCHARINFO 'IMAGEWIDTHS)) + (LET ((DCSINFO (\INSURECHARSETINFO DFONT (\CHARSET DCODE))) + (DTHINCODE (\CHAR8CODE DCODE)) + DESCENT ASCENT TEMP) + (CL:WHEN [AND (FGETMULTI SOURCEDATA 'IMAGEWIDTHS) + (NEQ (FGETMULTI SOURCEDATA 'WIDTHS) + (FGETMULTI SOURCEDATA 'IMAGEWIDTHS)) (OR (EQ (ffetch (CHARSETINFO WIDTHS) of DCSINFO) (ffetch (CHARSETINFO IMAGEWIDTHS) of DCSINFO)) (NULL (ffetch (CHARSETINFO IMAGEWIDTHS) of DCSINFO] @@ -1423,20 +1656,29 @@ (replace (CHARSETINFO IMAGEWIDTHS) of DCSINFO with (\COPYARRAYBLOCK (ffetch (CHARSETINFO WIDTHS) of DCSINFO)))) - (CL:WHEN (SETQ TEMP (FGETMULTI SCHARINFO 'BITMAP)) - (\PUTCHARBITMAP.CSINFO DCODE DCSINFO TEMP (FGETMULTI SCHARINFO 'DESCENT))) - (UPDATEINFOELEMENT WIDTHS) - (UPDATEINFOELEMENT IMAGEWIDTHS) - (UPDATEINFOELEMENT YWIDTHS) - (CL:WHEN (FGETMULTI SCHARINFO 'LEFTKERN) - (\FSETLEFTKERN DCSINFO DCODE (FGETMULTI SCHARINFO 'LEFTKERN))) - (SETQ DESCENT (IMAX (FGETMULTI SCHARINFO 'DESCENT) + [if (FGETMULTI SOURCEDATA 'SLUG) + then (\MAKESLUGCHAR DTHINCODE DCSINFO) + else (CL:WHEN (fetch (CHARSETINFO CSSLUGP) of DCSINFO) + (* ; "No longer a slug csinfo") + (SETQ DCSINFO (create CHARSETINFO copying DCSINFO CSSLUGP _ NIL CSCOMPLETEP _ NIL + )) + (\SETCHARSETINFO DFONT (\CHARSET DCODE) + DCSINFO)) + (CL:WHEN (SETQ TEMP (FGETMULTI SOURCEDATA 'BITMAP)) + (\PUTCHARBITMAP.CSINFO DTHINCODE DCSINFO TEMP (FGETMULTI SOURCEDATA 'DESCENT)) + (UPDATEINFOELEMENT WIDTHS) + (UPDATEINFOELEMENT IMAGEWIDTHS) + (UPDATEINFOELEMENT YWIDTHS) + (CL:WHEN (FGETMULTI SOURCEDATA 'LEFTKERN) + (\FSETLEFTKERN DCSINFO DTHINCODE (FGETMULTI SOURCEDATA 'LEFTKERN))) + (replace (CHARSETINFO CSSLUGP) of DCSINFO with NIL) + (CHARSETPROP DCSINFO 'SOURCE (FONTPROP DFONT 'SPEC)))] + (SETQ DESCENT (IMAX (FGETMULTI SOURCEDATA 'DESCENT) (fetch (CHARSETINFO CHARSETDESCENT) of DCSINFO))) - (SETQ ASCENT (IMAX (FGETMULTI SCHARINFO 'ASCENT) + (SETQ ASCENT (IMAX (FGETMULTI SOURCEDATA '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))) @@ -1445,29 +1687,74 @@ (replace (FONTDESCRIPTOR \SFHeight) of DFONT with (IPLUS DESCENT ASCENT))) DCSINFO]) -(SLUGCHARP.DISPLAY - [LAMBDA (CODE FONT/CHARSETINFO) (* ; "Edited 6-Jun-2025 10:24 by rmk") - (* ; "Edited 31-May-2025 23:44 by rmk") - - (* ;; "True if CODE is currently a slug in FONT or the particular CHARSETINFO. If we are given a CSINFO, CODE is alread charset-relative.") - - (LET [(CSINFO (CL:IF (type? CHARSETINFO FONT/CHARSETINFO) - FONT/CHARSETINFO - (\XGETCHARSETINFO FONT/CHARSETINFO (\CHARSET CODE)))] - (OR (NULL CSINFO) - (fetch (CHARSETINFO CSSLUGP) of CSINFO) - (EQ (\GETBASE (fetch (CHARSETINFO OFFSETS) of CSINFO) - (\CHAR8CODE CODE)) - (\GETBASE (fetch (CHARSETINFO OFFSETS) of CSINFO) - (ADD1 \MAXTHINCHAR]) - -(\GETCHARINFO - [LAMBDA (CSINFO CHAR8CODE) (* ; "Edited 23-Jul-2025 15:59 by rmk") +(\MOVEFONTCHARS.SOURCEDATA + [LAMBDA (SOURCE DEFAULTSOURCEFONT) (* ; "Edited 6-Sep-2025 12:59 by rmk") + (* ; "Edited 4-Sep-2025 11:01 by rmk") + (* ; "Edited 2-Sep-2025 13:28 by rmk") + (* ; "Edited 30-Aug-2025 23:20 by rmk") + (* ; "Edited 26-Aug-2025 20:23 by rmk") + (* ; "Edited 25-Aug-2025 09:12 by rmk") + (* ; "Edited 23-Aug-2025 23:45 by rmk") + (* ; "Edited 23-Jul-2025 15:59 by rmk") (* ; "Edited 22-Jul-2025 12:48 by rmk") (* ; "Edited 8-Jul-2025 22:50 by rmk") (* ; "Edited 7-Jun-2025 14:35 by rmk") - (LET (TEMP) - `((ASCENT \, (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) + + (* ;; "This decodes the source size of a MOVEFONTCHARS pair. SOURCE can be") + + (* ;; " a character name or character code: The source font is the DEFAULTSOURCEFONT") + + (* ;; " a list of the form (sourcechar sourcefont) where sourcechar is a name or code and sourcefont is a full or partial font specification with defaults taken from the DEFAULTSOURCE FONT. E.g. if the defaultsource font is GACHA 10 then the pair (94 TERMINAL) is interpreted as (TERMINAL 10).") + + (LET (SCODE CHAR8CODE SFONT CSINFO TEMP) + (if (LISTP SOURCE) + then (SETQ SFONT (CADR SOURCE)) + (SETQ SCODE (CAR SOURCE)) + else (SETQ SFONT DEFAULTSOURCEFONT) + (SETQ SCODE SOURCE)) + (CL:UNLESS (type? FONTDESCRIPTOR SFONT) + (if SFONT + then (SETQ SFONT (MKLIST SFONT)) (* ; + "Make it look like a fontspec, then fill in defaults") + [SETQ SFONT (FONTCREATE (create FONTSPEC + FSFAMILY _ (OR (fetch (FONTSPEC FSFAMILY) + of SFONT) + (FONTPROP DEFAULTSOURCEFONT + 'FAMILY)) + FSSIZE _ (OR (fetch (FONTSPEC FSSIZE) + of SFONT) + (FONTPROP DEFAULTSOURCEFONT + 'SIZE)) + FSFACE _ (OR (fetch (FONTSPEC FSFACE) + of SFONT) + (FONTPROP DEFAULTSOURCEFONT + 'FACE)) + FSROTATION _ (OR (fetch (FONTSPEC FSROTATION) + of SFONT) + (FONTPROP DEFAULTSOURCEFONT + 'ROTATION)) + FSDEVICE _ (OR (fetch (FONTSPEC FSDEVICE) + of SFONT) + (FONTPROP DEFAULTSOURCEFONT + 'DEVICE] + else (SETQ SFONT DEFAULTSOURCEFONT))) + (CL:UNLESS (CHARCODEP SCODE) + (SETQ SCODE (CHARCODE.DECODE SCODE))) + (CL:WHEN (AND SCODE (SLUGCHARP.DISPLAY SCODE SFONT)) + (SETQ SCODE NIL)) + (if SCODE + then (SETQ CSINFO (\INSURECHARSETINFO SFONT (\CHARSET SCODE))) + (SETQ CHAR8CODE (\CHAR8CODE SCODE)) + else + (* ;; "NIL SCODE means replace with slug. We calculate the source-slug information, but that should be ignored later in favor of the slug information from the destination's character set. ") + + (SETQ CSINFO (\INSURECHARSETINFO SFONT 0)) + (SETQ CHAR8CODE SLUGCHARINDEX)) + + (* ;; "Use (plural) vector field names for UPDATEINFOELEMENT. Don't know if the CHAR8CODE is useful, but...") + + `((CHAR8CODE \, CHAR8CODE) + (ASCENT \, (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) (DESCENT \, (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (WIDTHS \, (CL:WHEN (SETQ TEMP (ffetch (CHARSETINFO WIDTHS) of CSINFO)) (\FGETWIDTH TEMP CHAR8CODE))) @@ -1479,18 +1766,79 @@ (ELT (fetch (CHARSETINFO LEFTKERN) of CSINFO) CHAR8CODE))) (BITMAP \, (CL:WHEN (SETQ TEMP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) - (\GETCHARBITMAP.CSINFO CHAR8CODE CSINFO]) + (\GETCHARBITMAP.CSINFO CHAR8CODE CSINFO))) + (SLUG \, (NOT SCODE]) + +(\MAKESLUGCHAR + [LAMBDA (CODE FONT/CSINFO) (* ; "Edited 30-Aug-2025 23:20 by rmk") + (* ; "Edited 24-Aug-2025 09:55 by rmk") + + (* ;; "Makes CODE be a slug character in FONT/CSINFO. If give a FONT, CODE is a true character code, otherwise it is a thincode in the given character set.") + + (LET (CSINFO THINCODE OFFSETS WIDTHS) + (if (type? FONTDESCRIPTOR FONT/CSINFO) + then (SETQ CSINFO (\INSURECHARSETINFO FONT/CSINFO (\CHARSET CODE))) + (SETQ THINCODE (\CHAR8CODE CODE)) + else (SETQ CSINFO FONT/CSINFO) + (SETQ THINCODE CODE)) + (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) + (CL:UNLESS (AND OFFSETS (EQ (\FGETOFFSET OFFSETS THINCODE) + (\FGETOFFSET OFFSETS SLUGCHARINDEX))) + (if OFFSETS + then + (* ;; "Must be a display. W e remove the character's current bitmap, then change the vectors to point to the existing slug. Otherwise we might end up with multiple slug bitmaps interspersed.") + + (\PUTCHARBITMAP.CSINFO THINCODE CSINFO (BITMAPCREATE 0 0)) + (\FSETOFFSET OFFSETS THINCODE (\FGETOFFSET OFFSETS SLUGCHARINDEX)) + else (HELP "NONDISPLAY SLUG ?")) + (\FSETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO) + THINCODE + (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO) + SLUGCHARINDEX)) + (\FSETIMAGEWIDTH (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) + THINCODE + (\FGETIMAGEWIDTH (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) + SLUGCHARINDEX)) + (CL:WHEN (fetch (CHARSETINFO YWIDTHS) of CSINFO) + (\FSETWIDTH (fetch (CHARSETINFO YWIDTHS) of CSINFO) + THINCODE + (\FGETWIDTH (fetch (CHARSETINFO YWIDTHS) of CSINFO) + SLUGCHARINDEX))) + (CL:WHEN (fetch (CHARSETINFO LEFTKERN) of CSINFO) + (SETA (fetch (CHARSETINFO LEFTKERN) of CSINFO) + THINCODE + (ELT (fetch (CHARSETINFO LEFTKERN) of CSINFO) + SLUGCHARINDEX)))) + CSINFO]) + +(SLUGCHARP.DISPLAY + [LAMBDA (CODE FONT/CHARSETINFO) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 28-Aug-2025 22:56 by rmk") + (* ; "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 + (\GETCHARSETINFO FONT/CHARSETINFO (\CHARSET CODE)))] + (OR (NULL CSINFO) + (fetch (CHARSETINFO CSSLUGP) of CSINFO) + (EQ (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO) + (\CHAR8CODE CODE)) + (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO) + (ADD1 \MAXTHINCHAR]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS UPDATEINFOELEMENT MACRO [(FIELD) (LET [(DBLOCK (ffetch (CHARSETINFO FIELD) of DCSINFO)) - (NEWVAL (FGETMULTI SCHARINFO 'FIELD] + (NEWVAL (FGETMULTI SOURCEDATA 'FIELD] (CL:WHEN NEWVAL (CL:UNLESS DBLOCK (SETQ DBLOCK (\CREATECSINFOELEMENT)) (freplace (CHARSETINFO FIELD) of DCSINFO with DBLOCK)) - (\FSETWIDTH DBLOCK DCODE NEWVAL))]) + (\FSETWIDTH DBLOCK DTHINCODE NEWVAL))]) ) @@ -1502,7 +1850,9 @@ (DEFINEQ (FONTFILES - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST) + [LAMBDA (FONTSPEC CHARSET DIRLST EXTLST) (* ; "Edited 28-Aug-2025 14:42 by rmk") + (* ; "Edited 25-Aug-2025 10:22 by rmk") + (* ; "Edited 16-Aug-2025 21:03 by rmk") (* ; "Edited 11-Jul-2025 09:42 by rmk") (* ; "Edited 6-Jul-2025 10:40 by rmk") (* ; "Edited 19-Jun-2025 17:09 by rmk") @@ -1513,11 +1863,13 @@ (* ;; "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.") - [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]) + (LET (FAMILY SIZE FACE ROTATION DEVICE) + (SPREADFONTSPEC FONTSPEC) + [SETQ DIRLST (MKLIST (OR DIRLST (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES] + [SETQ EXTLST (MKLIST (OR EXTLST (FONTDEVICEPROP 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]) (\FINDFONTFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST) @@ -1700,8 +2052,13 @@ (T "-C0"))) 'EXTENSION EXTENSION]) -(\FONTINFOFROMFILENAME - [LAMBDA (FONTFILE DEVICE NOCHARSET) (* ; "Edited 10-Jul-2025 09:42 by rmk") +(FONTSPECFROMFILENAME + [LAMBDA (FONTFILE DEVICE) (* ; "Edited 30-Aug-2025 10:05 by rmk") + (* ; "Edited 28-Aug-2025 14:28 by rmk") + (* ; "Edited 25-Aug-2025 10:16 by rmk") + (* ; "Edited 23-Aug-2025 10:42 by rmk") + (* ; "Edited 17-Aug-2025 00:05 by rmk") + (* ; "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") @@ -1709,7 +2066,7 @@ (* ;; "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) + CH SIZEBEG SIZEEND NAME FAMILY SIZE FACE 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#))) @@ -1721,50 +2078,50 @@ (* ;; "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) + [SETQ SIZEEND (find CH# from SIZEBEG suchthat (NOT (NUMBERP (NTHCHAR NAME CH#] + [SETQ SIZE (SMALLP (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEEND] + (if (EQ (NTHCHAR NAME SIZEEND) '-) - then (SETQ SIZEND (ADD1 SIZEND))) + then (SETQ SIZEEND (ADD1 SIZEEND))) (* ;; "Get Face") - (SETQ NAME (U-CASE NAME)) (* ; + (SETQ NAME (U-CASE NAME)) + (SETQ FACE (SUBSTRING NAME SIZEEND)) (* ;  "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] + [SETQ FACE (LIST (SELCHARQ (NTHCHARCODE FACE 1) + (B 'BOLD) + (L 'LIGHT) + 'MEDIUM) + (SELCHARQ (NTHCHARCODE FACE 2) + (I 'ITALIC) + 'REGULAR) + (SELCHARQ (NTHCHARCODE FACE 3) + (C 'COMPRESSED) + (E 'EXPANDED) + '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]) + (SETQ DEVICE (COND + ((STREAMP DEVICE) + (IMAGESTREAMTYPE DEVICE)) + [(NULL DEVICE) + (CAR (find I DEXTS (EXT _ (LISTGET FILENAMELIST 'EXTENSION)) in + IMAGESTREAMTYPES + suchthat (thereis E inside (FONTDEVICEPROP (CAR I) + 'FONTEXTENSIONS) + suchthat (STRING.EQUAL EXT E] + ((LITATOM DEVICE) + (\FONTSYMBOL DEVICE)) + (T DEVICE))) + (CL:WHEN (AND FAMILY SIZE FACE DEVICE) + (create FONTSPEC + FSFAMILY _ FAMILY + FSSIZE _ SIZE + FSFACE _ FACE + FSROTATION _ 0 + FSDEVICE _ DEVICE]) (\FONTINFOFROMFILENAME.OLD [LAMBDA (FONTFILE DEVICE) (* ; "Edited 1-Jan-87 01:29 by FS") @@ -1905,54 +2262,37 @@ X]) (FONTUNPARSE - [LAMBDA (FONT) (* kbr%: "25-Feb-86 19:40") + [LAMBDA (FONT) (* ; "Edited 7-Sep-2025 09:19 by rmk") + (* ; "Edited 21-Aug-2025 18:15 by rmk") + (* ; "Edited 18-Aug-2025 00:52 by rmk") + (* 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.") + (if (type? FONTCLASS FONT) + then (CONS 'CLASS (FONTCLASSUNPARSE FONT)) + elseif (type? FONTDESCRIPTOR FONT) + then (LET ((SPEC (FONTPROP FONT 'SPEC)) + FACE) + (SETQ FACE (FONTFACETOATOM (fetch (FONTSPEC FSFACE) of SPEC) + T)) - 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]) + (* ;; "Original: Don't return device, or any trailing defaults. ") + + (* ;; "We still honor that even though it is more attractive to return the whole fontspec, perhaps with device NIL.") + + (* ;; "Seems harmless to include a 0 rotation--any caller would have expected that something might appear there.") + (* (create FONTSPEC using SPEC FSFACE + _ FACE FSDEVICE _ NIL)) + (LIST (fetch (FONTSPEC FSFAMILY) of SPEC) + (fetch (FONTSPEC FSSIZE) of SPEC) + FACE + (fetch (FONTSPEC FSROTATION) of SPEC]) (SETFONTDESCRIPTOR - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* ; "Edited 21-Jul-2025 08:55 by rmk") + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* ; "Edited 28-Aug-2025 14:43 by rmk") + (* ; "Edited 12-Aug-2025 21:07 by rmk") + (* ; "Edited 21-Jul-2025 08:55 by rmk") (* ; "Edited 14-Jul-2025 22:37 by rmk") (* ; "Edited 10-Jul-2025 12:38 by rmk") (* ; "Edited 19-Jun-2025 21:21 by rmk") @@ -2030,32 +2370,37 @@ (IGNORE.CCE 0) (SHOULDNT]) -(\UNITWIDTHSVECTOR - [LAMBDA NIL (* JonL " 7-NOV-83 19:23") - (SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3) - WORDSPERCELL))) - (for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1)) - \UNITWIDTHSVECTOR]) - (\COERCECHARSET - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS THINCODE) + [LAMBDA (FONTSPEC CHARSET CODE COERCIONS) (* ; "Edited 31-Aug-2025 00:00 by rmk") + (* ; "Edited 28-Aug-2025 23:07 by rmk") + (* ; "Edited 27-Aug-2025 17:08 by rmk") + (* ; "Edited 16-Aug-2025 17:48 by rmk") + (* ; "Edited 5-Aug-2025 17:55 by rmk") (* ; "Edited 24-Jul-2025 00:19 by rmk") (* ; "Edited 8-Jul-2025 08:14 by rmk") (* ; "Edited 11-Jun-2025 09:13 by rmk") (* ; "Edited 7-Jun-2025 13:39 by rmk") (* ; "Edited 21-May-2025 10:50 by rmk") - (* ;; "COERCIONS is a set of (oldspec newspec) pairs, where a spec is either just a font name or a font name with a size. If oldspec matches the current requested characteristics, then that csinfo is returned.") - (* ; "") - (for C CSINFO FONT in (\COERCEFONTSPEC COERCIONS FAMILY SIZE FACE ROTATION DEVICE CHARSET) - eachtime (SPREADFONTSPEC C) when [AND (SETQ FONT (FONTCREATE1 FAMILY SIZE FACE ROTATION DEVICE - CHARSET)) - (SETQ CSINFO (\INSURECHARSETINFO CHARSET FONT)) - (NOT (AND THINCODE (SLUGCHARP.DISPLAY THINCODE CSINFO] - do (RETURN CSINFO]) + (* ;; "Returns the CHARSET's CSINFO from the first font that the requested font coerces to and that has a non-slug entry for THINCODE (if given). ") + + (if (NULL COERCIONS) + then [SETQ COERCIONS (FONTDEVICEPROP FONTSPEC (CL:IF CODE + 'CHARCOERCIONS + 'FONTCOERCIONS)] + elseif (LITATOM COERCIONS) + then (SETQ COERCIONS (FONTDEVICEPROP FONTSPEC COERCIONS))) + (for CFS CFONT CSINFO in (COERCEFONTSPEC FONTSPEC COERCIONS) + when (AND (SETQ CFONT (FONTCREATE1 CFS CHARSET)) + (SETQ CSINFO (\INSURECHARSETINFO CFONT CHARSET))) + unless (AND CODE (SLUGCHARP.DISPLAY CODE CFONT)) do (RETURN (LIST CFONT CSINFO]) (\BUILDSLUGCSINFO - [LAMBDA (WIDTH HEIGHT DESCENT DEVICE SCALE) (* ; "Edited 15-Jun-2025 12:42 by rmk") + [LAMBDA (FONT SLUGWIDTH) (* ; "Edited 17-Aug-2025 12:46 by rmk") + (* ; "Edited 10-Aug-2025 12:43 by rmk") + (* ; "Edited 6-Aug-2025 22:42 by rmk") + (* ; "Edited 3-Aug-2025 16:11 by rmk") + (* ; "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") @@ -2063,36 +2408,43 @@ (* ; "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") + (* ;; "\SF... values are scaled") - (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))) + (LET ((SLUGHEIGHT (fetch (FONTDESCRIPTOR \SFHeight) of FONT)) + (DESCENT (fetch (FONTDESCRIPTOR \SFDescent) of FONT)) + (DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT)) + CSINFO WIDTHS OFFSETS BITMAP) + (CL:WHEN (EQ SLUGHEIGHT 0) - (* ;; "SCALE is only used for the display bitmap") + (* ;; "First character set hasn't been read, so height isn't known. But usually it is a bit bigger than the request fontsize.") - (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) + (* ;; "This could also be adjusted later.") + + [SETQ SLUGHEIGHT (FIXR (FTIMES 1.2 (OR (fetch (FONTDESCRIPTOR FONTSCALE) of FONT) + 1) + (fetch (FONTDESCRIPTOR FONTSIZE) of FONT]) + (CL:UNLESS SLUGWIDTH + (SETQ SLUGWIDTH (fetch (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT))) + (CL:WHEN (ZEROP SLUGWIDTH) + (SETQ SLUGWIDTH (CL:IF (EQ 0 (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT)) + (FIXR (FTIMES SLUGHEIGHT 0.6)) + (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT))) + (replace (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT with SLUGWIDTH)) + (SETQ CSINFO (create CHARSETINFO + CHARSETASCENT _ (IDIFFERENCE SLUGHEIGHT DESCENT) + CHARSETDESCENT _ DESCENT + CSSLUGP _ T + CSCOMPLETEP _ T)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) + (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I SLUGWIDTH)) (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] + (SETQ OFFSETS (\CREATECSINFOELEMENT)) + (replace (CHARSETINFO OFFSETS) of CSINFO with OFFSETS) + (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) + (* ; "Slug is at offset 0 in the bitmap") + (SETQ BITMAP (BITMAPCREATE SLUGWIDTH SLUGHEIGHT 1)) + (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 SLUGWIDTH)) (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP)) CSINFO]) @@ -2378,7 +2730,8 @@ (T (\ILLEGAL.ARG FACE]) (SETFONTCHARENCODING - [LAMBDA (FONT CHARENCODING) (* ; "Edited 19-Jul-2025 23:28 by rmk") + [LAMBDA (FONT CHARENCODING) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 19-Jul-2025 23:28 by rmk") (* ; "Edited 12-Jul-2025 13:15 by rmk") (* ; "Edited 10-Jul-2025 12:38 by rmk") (* ; "Edited 6-Jul-2025 21:41 by rmk") @@ -2389,140 +2742,212 @@ (* ;; "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) - (CHARSETPROP (\XGETCHARSETINFO FONT 0) + (CHARSETPROP (\GETCHARSETINFO FONT 0) 'CSCHARENCODING CHARENCODING]) ) (DEFINEQ (FONTSAVAILABLE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) (* ; "Edited 21-Jul-2025 08:55 by rmk") + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) (* ; "Edited 30-Aug-2025 13:55 by rmk") + (* ; "Edited 28-Aug-2025 14:43 by rmk") + (* ; "Edited 23-Aug-2025 10:51 by rmk") + (* ; "Edited 15-Aug-2025 12:18 by rmk") + (* ; "Edited 12-Aug-2025 12:27 by rmk") + (* ; "Edited 30-Jul-2025 14:30 by rmk") + (* ; "Edited 21-Jul-2025 08:55 by rmk") (* ; "Edited 21-Jun-2025 15:41 by rmk") (* ; "Edited 14-Jun-2025 11:06 by rmk") (* ; "Edited 12-Jun-2025 10:48 by rmk") (* rrb " 7-Nov-84 15:41") -(* ;;; "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.") +(* ;;; "returns a list of the fonts fitting a description that are available. FAMILY SIZE FACE or ROTATION can be * which means get them all. if CHECKFILESTOO? is NIL, only fonts in core will be considered. If ONLY, fonts in memory will be ignored. ") - (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) - (UNION (CL:UNLESS (EQ 'ONLY CHECKFILESTOO?) - (\FONTSAVAILABLE.INCORE FAMILY SIZE FACE ROTATION DEVICE)) - (CL:WHEN CHECKFILESTOO? - (if (EQ DEVICE '*) - then (* ; - "map thru all the imagestream devices") - (for I in IMAGESTREAMTYPES - join (APPLY* (OR (CADR (ASSOC 'FONTSAVAILABLE (CDR I))) - (FUNCTION NILL)) - FAMILY SIZE FACE ROTATION (CAR I))) - else (* ; + (DECLARE (GLOBALVARS \FONTSINCORE)) + (LET ((FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE))) + (if (EQ '* (fetch (FONTSPEC FSDEVICE) of FONTSPEC)) + then + (* ;; + "The results for each device will be grouped together, because the sort happens in the clause below") + + (for I in IMAGESTREAMTYPES join (FONTSAVAILABLE FONTSPEC NIL NIL NIL (CAR I) + CHECKFILESTOO?)) + else (SPREADFONTSPEC FONTSPEC) (* ; "For easier matching code") + (SORTFONTSPECS (UNION (CL:UNLESS (EQ 'ONLY CHECKFILESTOO?) + [COLLECTMULTI \FONTSINCORE + (FUNCTION (LAMBDA (FM S FC R D FONT) + (DECLARE (USEDFREE $$COLLECT)) + (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 + (create FONTSPEC + FSFAMILY _ FM + FSSIZE _ S + FSFACE _ FC + FSROTATION _ R + FSDEVICE _ D)))]) + (CL:WHEN CHECKFILESTOO?(* ;  "apply the device font lookup function.") - (APPLY* (OR [CADR (ASSOC 'FONTSAVAILABLE (CDR (ASSOC DEVICE IMAGESTREAMTYPES] - (FUNCTION NILL)) - FAMILY SIZE FACE ROTATION DEVICE)))]) + (LET [(FN (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE + 'FONTSAVAILABLE)) + (FUNCTION \SEARCHFONTFILES] + + (* ;; "Until all the device functions take a FONTSPEC") + + (CL:IF (EQ 1 (NARGS FN)) + (APPLY* FN FONTSPEC) + (APPLY* FN FAMILY SIZE FACE ROTATION DEVICE))))]) (FONTEXISTS? - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET NOCOERCIONS) - (* ; "Edited 25-Jul-2025 21:21 by rmk") - (* ; "Edited 23-Jul-2025 13:02 by rmk") - (* ; "Edited 21-Jul-2025 09:05 by rmk") - (* ; "Edited 10-Jul-2025 12:38 by rmk") - (* ; "Edited 27-Jun-2025 10:27 by rmk") - (* ; "Edited 22-Jun-2025 09:02 by rmk") - (* ; "Edited 20-Jun-2025 00:37 by rmk") - (* ; "Edited 17-Jun-2025 23:06 by rmk") - (* ; "Edited 16-Jun-2025 10:08 by rmk") + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOCOERCIONS) (* ; "Edited 28-Aug-2025 22:16 by rmk") + (* ; "Edited 23-Aug-2025 12:45 by rmk") + (* ; "Edited 16-Aug-2025 17:49 by rmk") + (* ; "Edited 12-Aug-2025 21:04 by rmk") + (* ; "Edited 9-Aug-2025 00:08 by rmk") + (* ; "Edited 5-Aug-2025 17:54 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.") + (* ;; "Do we have any way of finding or creating the font, even by coercion from other fonts? The DEVICE can have a FONTEXISTS? function for the case where we can't find a file--presumably returns the file for a coercion to a different font specification.") (* ;;  "Tries device specific coercions if the original request can't be satisfied and NOCOERCIONS is NIL.") (DECLARE (GLOBALVARS \FONTSINCORE \FONTEXISTS?-CACHE IMAGESTREAMTYPES)) - (LET ((FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE CHARSET)) - VAL) + (LET ((FONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + VAL DEVICE) (if (type? FONTDESCRIPTOR FONTSPEC) then (* ;;  "FAMILY was a font descriptor, unmodified by other args: record that it exists") - (SPREADFONTSPEC (FONTPROP FONTSPEC 'SPEC)) - (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTSPEC) - else (SPREADFONTSPEC FONTSPEC) - (if (GETMULTI \FONTSINCORE FAMILY SIZE FACE ROTATION DEVICE CHARSET) - elseif (SETQ VAL (GETMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE - CHARSET)) + (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC) + else (if (FETCHMULTI \FONTSINCORE FONTSPEC) + elseif (SETQ VAL (FETCHMULTI \FONTEXISTS?-CACHE FONTSPEC)) 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)))) + else (* ; + "Only 0 really exists. Cache just the first file") + (SETQ DEVICE (fetch (FONTSPEC FSDEVICE) of FONTSPEC)) + (SETQ VAL (OR (CAR (FONTFILES (CL:IF (MEMB (fetch (FONTSPEC FSROTATION) + of FONTSPEC) + '(90 270)) + (create FONTSPEC using FONTSPEC FSROTATION _ + 0) + FONTSPEC))) + (APPLY* (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE 'FONTEXISTS?) + ) + (CAR (GETMULTI IMAGESTREAMTYPES DEVICE + 'FONTSAVAILABLE)) + (FUNCTION TRUE)) + FONTSPEC))) (if VAL - then (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET - VAL) + then (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL) elseif [AND (NOT NOCOERCIONS) - (find FS in (\COERCEFONTSPEC (GETATOMVAL (PACK* DEVICE - "FONTCOERCIONS") - ) - FAMILY SIZE FACE ROTATION DEVICE CHARSET) - suchthat (SETQ VAL (FONTEXISTS? FS NIL NIL NIL DEVICE CHARSET - T] - then (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET - VAL) - else (PUTMULTI \FONTEXISTS?-CACHE FAMILY SIZE FACE ROTATION DEVICE CHARSET - 'NO) + (find FS in (COERCEFONTSPEC FONTSPEC (FONTDEVICEPROP + DEVICE + 'FONTCOERCIONS)) + suchthat (SETQ VAL (FONTEXISTS? FS NIL NIL NIL NIL T] + then + (* ;; "It's coerceable...but not yet coerced.") + + (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL) + else (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC 'NO) NIL]) -(\FONTSAVAILABLE.INCORE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 21-Jul-2025 09:27 by rmk") - (* ; "Edited 21-Jun-2025 11:17 by rmk") - (* ; "Edited 25-Apr-93 13:07 by rmk:") - (* rrb "25-Sep-84 12:10") - - (* ;; "Returns a list of the fonts that are available in core. * matches anything. * can appear as a component of FACE") - - (DECLARE (GLOBALVARS \FONTSINCORE)) - (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) - (COLLECTMULTI \FONTSINCORE (FUNCTION (LAMBDA (FM S FC R D FONT) - (CL:WHEN [AND (OR (EQ FAMILY FM) - (EQ FAMILY '*)) - (OR (EQ SIZE S) - (EQ SIZE '*)) - (MATCHFONTFACE FACE FC) - (OR (EQ ROTATION R) - (EQ ROTATION '*)) - (OR (EQ DEVICE D) - (EQ DEVICE '*] - (push $$COLLECT (LIST FM S FC R D)))]) - (\SEARCHFONTFILES - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 21-Jul-2025 08:57 by rmk") - (* ; "Edited 10-Jul-2025 11:19 by rmk") + [LAMBDA (FONTSPEC) (* ; "Edited 28-Aug-2025 14:47 by rmk") + (* ; "Edited 25-Aug-2025 10:23 by rmk") + (* ; "Edited 23-Aug-2025 12:36 by rmk") + (* ; "Edited 21-Jul-2025 08:57 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.") + (* ;; "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. The caller must do any desired coercions.") - (* ;; "Just in case the caller hasn't check the arguments:") + (LET (FAMILY SIZE FACE ROTATION DEVICE) + (SPREADFONTSPEC FONTSPEC) + (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH _ 1) + in [\FONTFILENAMES FAMILY SIZE FACE DEVICE (MKLIST (FONTDEVICEPROP DEVICE + 'FONTEXTENSIONS] + do (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY)) + (SETQ FILEDIR (CL:IF FILEDIR + (CONCAT ">" FILEDIR ">") + "")) + (for DIR inside (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES) + 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 + (FONTSPECFROMFILENAME + FONTFILE DEVICE)) + + (* ;; + "make sure the face, size, and family really match.") + when (AND (OR (EQ FAMILY '*) + (EQ FAMILY (fetch (FONTSPEC FSFAMILY) of THISFONT))) + (OR (EQ SIZE '*) + (EQ SIZE (fetch (FONTSPEC FSSIZE) of THISFONT))) + (MATCHFONTFACE FACE (fetch (FONTSPEC FSFACE) of THISFONT))) unless (MEMBER THISFONT + FONTSFOUND) + do (push FONTSFOUND THISFONT))) finally (RETURN (DREVERSE FONTSFOUND]) + +(FLUSHFONTSINCORE + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 4-Sep-2025 10:14 by rmk") + (* ; "Edited 28-Aug-2025 14:44 by rmk") + (* ; "Edited 18-Aug-2025 00:33 by rmk") + (* ; "Edited 12-Aug-2025 21:07 by rmk") + (* ; "Edited 21-Jul-2025 08:59 by rmk") + (* ; "Edited 21-Jun-2025 11:19 by rmk") + (DECLARE (SPECVARS . T) + (GLOBALVARS \FONTSINCORE)) + (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) + (LET ((NFLUSHED 0)) + (DECLARE (SPECVARS NFLUSHED)) + [MAPMULTI \FONTSINCORE (FUNCTION (LAMBDA (FM S FC R DPAIR) + (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 DPAIR)) + (EQ DEVICE '*] + (ADD NFLUSHED 1) + (RPLACD DPAIR))] + (LIST NFLUSHED 'flushed]) + +(FINDFONTFILES + [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 28-Aug-2025 14:45 by rmk") + (* ; "Edited 25-Aug-2025 10:23 by rmk") + (* ; "Edited 21-Aug-2025 18:19 by rmk") + (* ; "Edited 12-Aug-2025 21:06 by rmk") + (* ; "Edited 21-Jul-2025 09:00 by rmk") + (* ; "Edited 29-Jun-2025 09:08 by rmk") + + (* ;; "GENERIC FUNCTION") + + (* ;; "returns a list of the fontfiles that can be read in for a device. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") + + (* ;; "The same algorithm as \SEARCHFONTFILES except returns the file names. This may return several files for the same specification") (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) (CL:UNLESS DIRLST - [SETQ DIRLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTDIRECTORIES"]) + [SETQ DIRLST (MKLIST (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES]) (CL:UNLESS EXTLST - [SETQ EXTLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTEXTENSIONS"]) + [SETQ EXTLST (MKLIST (FONTDEVICEPROP DEVICE 'FONTEXTENSIONS]) (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH _ 1) IN (\FONTFILENAMES FAMILY SIZE FACE DEVICE EXTLST) do (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY)) @@ -2534,36 +2959,58 @@ (* ;; "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)) + when (DIRECTORYNAMEP DIR) + do (for FONTFILE FONTSPEC THISFACE in (DIRECTORY DIR) eachtime (SETQ FONTSPEC + (FONTSPECFROMFILENAME + FONTFILE DEVICE)) + (SETQ THISFACE (CADDR + FONTSPEC + )) - (* ;; + (* ;;  "make sure the face, size, and family really match.") - when (AND (OR (EQ FAMILY '*) - (EQ FAMILY (CAR THISFONT))) + when (AND (NOT (MEMBER FONTFILE FONTSFOUND)) + (OR (EQ FAMILY '*) + (EQ FAMILY (fetch (FONTSPEC FSFAMILY) of FONTSPEC))) (OR (EQ SIZE '*) - (EQ SIZE (CADR THISFONT))) - (MATCHFONTFACE FACE (CADDR THISFONT))) unless (MEMBER THISFONT FONTSFOUND) - do (push FONTSFOUND THISFONT))) - finally (RETURN (DREVERSE FONTSFOUND]) + (EQ SIZE (fetch (FONTSPEC FSSIZE) of FONTSPEC))) + (MATCHFONTFACE FACE (fetch (FONTSPEC FSFACE) of FONTSPEC))) do (push FONTSFOUND FONTFILE)) + ) finally (RETURN (DREVERSE FONTSFOUND]) -(FLUSHFONTSINCORE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 21-Jul-2025 08:59 by rmk") - (* ; "Edited 21-Jun-2025 11:19 by rmk") - (DECLARE (GLOBALVARS \FONTSINCORE)) - (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) - (MAPMULTI \FONTSINCORE (FUNCTION (LAMBDA (FM S FC R TAIL) - (CL:WHEN [AND (OR (EQ FAMILY FM) - (EQ FAMILY '*)) - (OR (EQ SIZE S) - (EQ SIZE '*)) - (MATCHFONTFACE FACE FC) - (OR (EQ ROTATION R) - (EQ ROTATION '*)) - (OR (EQ DEVICE (CAR TAIL)) - (EQ DEVICE '*] - (RPLACD TAIL]) +(SORTFONTSPECS + [LAMBDA (FONTSPECS) (* ; "Edited 30-Aug-2025 15:12 by rmk") + + (* ;; + "Sort FONTSPECS by alphabetically by family, then by smaller sizes, then by medium/regular faces") + + (SORT + FONTSPECS + (FUNCTION (LAMBDA (FS1 FS2) + (SELECTQ (ALPHORDER (fetch (FONTSPEC FSDEVICE) of FS1) + (fetch (FONTSPEC FSDEVICE) of FS2)) + (EQUAL (SELECTQ (ALPHORDER (fetch (FONTSPEC FSFAMILY) of FS1) + (fetch (FONTSPEC FSFAMILY) of FS2)) + (EQUAL [OR (ILESSP (fetch (FONTSPEC FSSIZE) of FS1) + (fetch (FONTSPEC FSSIZE) of FS2)) + (CL:WHEN (EQ (fetch (FONTSPEC FSSIZE) of FS1) + (fetch (FONTSPEC FSSIZE) of FS2)) + [LET ((FACE1 (fetch (FONTSPEC FSFACE) of FS1)) + (FACE2 (fetch (FONTSPEC FSFACE) of FS2))) + (OR (EQUAL FACE1 FACE2) + (AND (EQ 'MEDIUM (fetch (FONTFACE WEIGHT) + of FACE1)) + (NEQ 'MEDIUM (fetch (FONTFACE WEIGHT) + of FACE2))) + (AND (EQ 'REGULAR (fetch (FONTFACE SLOPE) + of FACE1)) + (NEQ 'REGULAR (fetch (FONTFACE SLOPE) + of FACE2])]) + (LESSP T) + NIL)) + (LESSP T) + NIL]) +) +(DEFINEQ (MATCHFONTFACE [LAMBDA (PATTERN FACE) (* ; "Edited 21-Jun-2025 11:57 by rmk") @@ -2582,50 +3029,730 @@ (OR (EQ PEXPANSION (fetch (FONTFACE EXPANSION) of FACE)) (EQ PEXPANSION '*]) -(FINDFONTFILES - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 21-Jul-2025 09:00 by rmk") - (* ; "Edited 29-Jun-2025 09:08 by rmk") +(MAKEFONTFACE + [LAMBDA (WEIGHT SLOPE EXPANSION BASE COLOR) (* ; "Edited 30-Aug-2025 10:22 by rmk") + (CL:UNLESS WEIGHT + (SETQ WEIGHT (CL:IF BASE + (fetch (FONTFACE WEIGHT) of BASE) + 'MEDIUM))) + (CL:UNLESS SLOPE + (SETQ SLOPE (CL:IF BASE + (fetch (FONTFACE SLOPE) of BASE) + 'REGULAR))) + (CL:UNLESS EXPANSION + (SETQ EXPANSION (CL:IF BASE + (fetch (FONTFACE EXPANSION) of BASE) + 'REGULAR))) + (CL:UNLESS COLOR + (SETQ COLOR (COPY (fetch (FONTFACE COLOR) of BASE)))) + (create FONTFACE + WEIGHT _ WEIGHT + SLOPE _ SLOPE + EXPANSION _ EXPANSION + COLOR _ COLOR]) - (* ;; "GENERIC FUNCTION") - - (* ;; "returns a list of the fontfiles that can be read in for a device. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") - - (* ;; "The same algorithm as \SEARCHFONTFILES except returns the file names. This may return several files for the same specification") - - (SPREADFONTSPEC (\FONT.CHECKARGS FAMILY SIZE FACE ROTATION DEVICE)) - (CL:UNLESS DIRLST - [SETQ DIRLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTDIRECTORIES"]) - (CL:UNLESS EXTLST - [SETQ EXTLST (MKLIST (GETATOMVAL (PACK* DEVICE "FONTEXTENSIONS"]) - (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH _ 1) - IN (\FONTFILENAMES FAMILY SIZE FACE DEVICE EXTLST) - do (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY)) - (SETQ FILEDIR (CL:IF FILEDIR - (CONCAT ">" FILEDIR ">") - "")) - (for DIR inside DIRLST eachtime - - (* ;; "The file pattern might have an extending subdirectory (C41>) that might not exist, but DIRECTORYNAMEP makes sure that it does.") - - (SETQ DIR (CONCAT DIR ">" (OR FILEDIR ""))) - when (DIRECTORYNAMEP DIR) do (for FONTFILE FONTSPEC THISFACE in (DIRECTORY DIR) - eachtime (SETQ FONTSPEC (\FONTINFOFROMFILENAME FONTFILE - DEVICE)) - (SETQ THISFACE (CADDR FONTSPEC)) - - (* ;; - "make sure the face, size, and family really match.") - when (AND (NOT (MEMBER FONTFILE FONTSFOUND)) - (OR (EQ FAMILY '*) - (EQ FAMILY (CAR FONTSPEC))) - (OR (EQ SIZE '*) - (EQ SIZE (CADR FONTSPEC))) - (MATCHFONTFACE FACE THISFACE)) do (push FONTSFOUND FONTFILE))) - finally (RETURN (DREVERSE FONTSFOUND]) +(FONTFACETOATOM + [LAMBDA (FACE NOERROR) (* ; "Edited 7-Sep-2025 09:19 by rmk") + (* ; "Edited 4-Sep-2025 08:45 by rmk") + (if (type? FONTFACE FACE) + then [PACK (LIST* (SELECTQ (fetch (FONTFACE WEIGHT) of FACE) + (MEDIUM 'M) + (BOLD 'B) + (LIGHT 'L) + (fetch (FONTFACE WEIGHT) of FACE)) + (SELECTQ (fetch (FONTFACE SLOPE) of FACE) + (ITALIC 'I) + (REGULAR 'R) + (fetch (FONTFACE SLOPE) of FACE)) + (SELECTQ (fetch (FONTFACE EXPANSION) of FACE) + (REGULAR 'R) + (COMPRESSED 'C) + (EXPANDED 'E) + (fetch (FONTFACE EXPANSION) of FACE)) + (CL:WHEN (fetch (FONTFACE COLOR) of FACE) + (LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE) + "-" + (fetch (FONTFACE FORECOLOR) of FACE)))] + elseif (AND FACE (LITATOM FACE) + (MEMB (NTHCHARCODE FACE 1) + (CHARCODE M B L)) + (MEMB (NTHCHARCODE FACE 2) + (CHARCODE I R)) + (MEMB (NTHCHARCODE FACE 3) + (CHARCODE R C E))) + then FACE + elseif (NOT NOERROR) + then (\ILLEGAL.ARG FACE]) ) +(RPAQ? \FONTSINCORE NIL) + (RPAQ? \FONTEXISTS?-CACHE NIL) +(RPAQ? \DEFAULTDEVICEFONTS NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) +) + +(RPAQ? \UNITWIDTHSVECTOR NIL) +(DEFINEQ + +(\UNITWIDTHSVECTOR + [LAMBDA NIL (* ; "Edited 24-Aug-2025 12:39 by rmk") + (* JonL " 7-NOV-83 19:23") + (SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXTHINCHAR 3) + WORDSPERCELL))) + (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1)) + \UNITWIDTHSVECTOR]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\UNITWIDTHSVECTOR) +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(DATATYPE FONTCLASS ((PRETTYFONT# BYTE) + DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME) + (INIT (DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)))) + +(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) + (FONTCOMPLETEP FLAG) + (FONTFAMILY POINTER) + (FONTSIZE POINTER) + (FONTFACE POINTER) + (\SFAscent WORD) + (\SFDescent WORD) + (\SFHeight WORD) + (ROTATION WORD) + (FONTSLUGWIDTH WORD) (* ; "Was FBBOX. The width of the slug character in the font, used by the generic \BUILDSLUGCSINFO to create the slug charsetinfo") + (NIL SIGNEDWORD) (* ; + "Was FBBOY. Can be removed if all references are recompiled.") + (NIL SIGNEDWORD) (* ; "Was FBBDX") + (NIL SIGNEDWORD) (* ; "Was FBBDY") + (FONTTOMCCSFN POINTER) (* ; "Was \SFLKerns. Function that translates codes in the font's pre-MCCS encoding into MCCS (e.g. Hippo A to Greek,Alpha) ") + (NIL POINTER) (* ; "Was \SFRWidths") + (FONTDEVICESPEC POINTER) (* ; + "Holds the spec by which the font is known to the printing device, if coercion has been done") + (OTHERDEVICEFONTPROPS POINTER) (* ; + "For individual devices to hang special information") + (FONTSCALE POINTER) + (\SFFACECODE BITS 8) + (FONTAVGCHARWIDTH WORD) (* ; + "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called") + (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)) + FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR) + (INIT (DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)))) + +(RECORD FONTFACE (WEIGHT SLOPE EXPANSION) + [ACCESSFNS ((COLOR (CDDDR DATUM) + (RPLACD (CDDR DATUM) + NEWVALUE)) + (BACKCOLOR [COND + ((CDDDR DATUM) + (CAR (CDDDR DATUM] + (PROGN [COND + ((NULL (CDDDR DATUM)) + (RPLACD (CDDR DATUM) + (LIST NIL NIL] + (RPLACA (CDDDR DATUM) + NEWVALUE))) + (FORECOLOR [COND + ((CDDDR DATUM) + (CADR (CDDDR DATUM] + (PROGN [COND + ((NULL (CDDDR DATUM)) + (RPLACD (CDDR DATUM) + (LIST NIL NIL] + (RPLACA (CDR (CDDDR DATUM)) + NEWVALUE] + 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. 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 + (CHARSETASCENT WORD) (* ; + "Max ascent for all characters in this CHARSET") + (CHARSETDESCENT WORD) (* ; + "Max descent for all characters in this CHARSET") + LEFTKERN CSINFOPROPS (* ; "Alist of extra properties") + (CHARSETNO WORD)) (* ; + "The number of this CSINFO in its font--MAX.SMALLP if not initialized") + WIDTHS _ (\CREATECSINFOELEMENT) + OFFSETS _ (\CREATECSINFOELEMENT) + CHARSETNO _ MAX.SMALLP) + +(RECORD FONTSPEC (FSFAMILY FSSIZE FSFACE FSROTATION FSDEVICE)) +) + +(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER) + '((FONTCLASS 0 (BITS . 7)) + (FONTCLASS 2 POINTER) + (FONTCLASS 4 POINTER) + (FONTCLASS 6 POINTER) + (FONTCLASS 8 POINTER) + (FONTCLASS 10 POINTER)) + '12) + +(DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)) + +(/DECLAREDATATYPE 'FONTDESCRIPTOR + '(POINTER FLAG POINTER POINTER POINTER WORD WORD WORD WORD WORD 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) + (FONTDESCRIPTOR 8 (BITS . 15)) + (FONTDESCRIPTOR 9 (BITS . 15)) + (FONTDESCRIPTOR 10 (BITS . 15)) + (FONTDESCRIPTOR 11 (BITS . 15)) + (FONTDESCRIPTOR 12 (BITS . 15)) + (FONTDESCRIPTOR 13 (SIGNEDBITS . 15)) + (FONTDESCRIPTOR 14 (SIGNEDBITS . 15)) + (FONTDESCRIPTOR 15 (SIGNEDBITS . 15)) + (FONTDESCRIPTOR 16 POINTER) + (FONTDESCRIPTOR 18 POINTER) + (FONTDESCRIPTOR 20 POINTER) + (FONTDESCRIPTOR 22 POINTER) + (FONTDESCRIPTOR 24 POINTER) + (FONTDESCRIPTOR 26 (BITS . 7)) + (FONTDESCRIPTOR 27 (BITS . 15)) + (FONTDESCRIPTOR 28 POINTER) + (FONTDESCRIPTOR 30 POINTER) + (FONTDESCRIPTOR 30 (FLAGBITS . 0)) + (FONTDESCRIPTOR 32 POINTER)) + '34) + +(DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)) + +(/DECLAREDATATYPE 'CHARSETINFO '(POINTER FLAG FLAG POINTER POINTER POINTER POINTER WORD WORD POINTER + POINTER WORD) + '((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) + (CHARSETINFO 14 POINTER) + (CHARSETINFO 16 (BITS . 15))) + '18) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS FONTASCENT MACRO ((FONTSPEC) + (ffetch \SFAscent of (FONTCREATE FONTSPEC)))) + +(PUTPROPS FONTDESCENT MACRO ((FONTSPEC) + (ffetch \SFDescent of (FONTCREATE FONTSPEC)))) + +(PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) + (ffetch \SFHeight of (FONTCREATE FONTSPEC)))) + +(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) + (\GETBASE OFFSETSBLOCK CHAR8CODE))) + +(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) + (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET))) + +(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) + (\GETBASE WIDTHSBLOCK CHAR8CODE))) + +(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE VAL) + (\PUTBASE WIDTHSBLOCK CHAR8CODE VAL))) + +(PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) + (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\INSURECHARSETINFO + FONTDESC + (\CHARSET CHARCODE))) + (\CHAR8CODE CHARCODE)))) + +(PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) + (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\INSURECHARSETINFO + FONTDESC + (\CHARSET CHARCODE))) + (\CHAR8CODE CHARCODE) + WIDTH))) + +(PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) + (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE))) + +(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) + (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \GETCHARSETINFO MACRO ((FONTDESC CHARSET) + + (* ;; + "Temporary until other callers of \GETCHARSETINFO are changes to \INSURECHARSETINFO") + + (* ;; + "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 \SETCHARSETINFO MACRO ((FONTDESC CHARSET CSINFO) + (\RPLPTR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONTDESC) + (UNFOLD CHARSET 2) + CSINFO))) + +(PUTPROPS \INSURECHARSETINFO MACRO [OPENLAMBDA (FONTDESC CHARSET) + + (* ;; "fetches the charsetinfo for charset CHARSET in fontdescriptor FONTDESC. If NIL, then creates and installs the required charset, maybe a slug (with CSSLUGP T).") + + (OR (\GETCHARSETINFO FONTDESC CHARSET) + (\SETCHARSETINFO 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, including one extra slot to hold the common slug charsetinfo") + + (\ALLOCBLOCK (IPLUS 2 \MAXCHARSET) + T))) + +(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]) +) + +(PUTPROPS CHARSETPROP ARGNAMES (CSINFO PROP NEWVALUE)) +(DECLARE%: EVAL@COMPILE + +(RPAQ SLUGCHARINDEX (ADD1 \MAXTHINCHAR)) + +(RPAQ SLUGCHARSET (ADD1 \MAXCHARSET)) + + +(CONSTANTS (SLUGCHARINDEX (ADD1 \MAXTHINCHAR)) + (SLUGCHARSET (ADD1 \MAXCHARSET))) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS LEGACYFONT MACRO ((FORM) (* ; + "Execute FORM in a non-medleyfont displayfont environment") + (RESETVARS (\FONTSINCORE \FONTEXISTS?-CACHE DISPLAYFONTCOERCIONS + DISPLAYCHARCOERCIONS (DISPLAYFONTEXTENSIONS + '(DISPLAYFONT)) + (DISPLAYFONTDIRECTORIES (MEDLEYDIR + "fonts>displayfonts>")) + (DISPLAYCHARSETFNS (REMOVE (ASSOC 'MEDLEYFONT + DISPLAYCHARSETFNS) + DISPLAYCHARSETFNS))) + (RETURN FORM)))) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS INDIRECTCHARSETP MACRO [(CSINFO FONT) + + (* ;; "An indirect points somewhere else") + + (LET [(SOURCE (CL:UNLESS (fetch (CHARSETINFO CSSLUGP) of CSINFO) + (CHARSETPROP CSINFO 'SOURCE))] + (CL:WHEN SOURCE + [NOT (EQUAL SOURCE (FONTPROP FONT 'DEVICESPEC])]) +) +) +(DEFINEQ + +(FONTDESCRIPTOR.DEFPRINT + [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))) + + (* ;; "Could lowercase the family, but maybe too dangerous if a BREAK on L-CASE.") + + (* ;; "Somehow flag the device too?") + + (CONS (CONCAT "{" (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) + (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) + "-" + (SELECTQ (fetch (FONTFACE WEIGHT) of FACE) + (MEDIUM 'M) + (BOLD 'B) + (LIGHT 'L) + (fetch (FONTFACE WEIGHT) of FACE)) + (SELECTQ (fetch (FONTFACE SLOPE) of FACE) + (ITALIC 'I) + (REGULAR 'R) + (fetch (FONTFACE SLOPE) of FACE)) + (SELECTQ (fetch (FONTFACE EXPANSION) of FACE) + (REGULAR 'R) + (COMPRESSED 'C) + (EXPANDED 'E) + (fetch (FONTFACE EXPANSION) of FACE)) + "/" + (OCTALSTRING (CAR LOC)) + "," + (OCTALSTRING (CDR LOC)) + "}"]) + +(FONTCLASS.DEFPRINT + [LAMBDA (FONTCLASS STREAM) (* ; "Edited 14-Dec-2024 16:51 by rmk") + (LET ((LOC (LOC FONTCLASS))) + (CONS (CONCAT "{" (OR (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS) + 'FONTCLASS) + "/" + (OCTALSTRING (CAR LOC)) + "," + (OCTALSTRING (CDR LOC)) + "}"]) +) + +(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER) + '((FONTCLASS 0 (BITS . 7)) + (FONTCLASS 2 POINTER) + (FONTCLASS 4 POINTER) + (FONTCLASS 6 POINTER) + (FONTCLASS 8 POINTER) + (FONTCLASS 10 POINTER)) + '12) + +(DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)) + +(/DECLAREDATATYPE 'FONTDESCRIPTOR + '(POINTER FLAG POINTER POINTER POINTER WORD WORD WORD WORD WORD 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) + (FONTDESCRIPTOR 8 (BITS . 15)) + (FONTDESCRIPTOR 9 (BITS . 15)) + (FONTDESCRIPTOR 10 (BITS . 15)) + (FONTDESCRIPTOR 11 (BITS . 15)) + (FONTDESCRIPTOR 12 (BITS . 15)) + (FONTDESCRIPTOR 13 (SIGNEDBITS . 15)) + (FONTDESCRIPTOR 14 (SIGNEDBITS . 15)) + (FONTDESCRIPTOR 15 (SIGNEDBITS . 15)) + (FONTDESCRIPTOR 16 POINTER) + (FONTDESCRIPTOR 18 POINTER) + (FONTDESCRIPTOR 20 POINTER) + (FONTDESCRIPTOR 22 POINTER) + (FONTDESCRIPTOR 24 POINTER) + (FONTDESCRIPTOR 26 (BITS . 7)) + (FONTDESCRIPTOR 27 (BITS . 15)) + (FONTDESCRIPTOR 28 POINTER) + (FONTDESCRIPTOR 30 POINTER) + (FONTDESCRIPTOR 30 (FLAGBITS . 0)) + (FONTDESCRIPTOR 32 POINTER)) + '34) + +(DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)) + +(/DECLAREDATATYPE 'CHARSETINFO '(POINTER FLAG FLAG POINTER POINTER POINTER POINTER WORD WORD POINTER + POINTER WORD) + '((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) + (CHARSETINFO 14 POINTER) + (CHARSETINFO 16 (BITS . 15))) + '18) +(ADDTOVAR SYSTEMRECLST + +(DATATYPE FONTCLASS ((PRETTYFONT# BYTE) + DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME)) + +(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) + (FONTCOMPLETEP FLAG) + (FONTFAMILY POINTER) + (FONTSIZE POINTER) + (FONTFACE POINTER) + (\SFAscent WORD) + (\SFDescent WORD) + (\SFHeight WORD) + (ROTATION WORD) + (FONTSLUGWIDTH WORD) + (NIL SIGNEDWORD) + (NIL SIGNEDWORD) + (NIL SIGNEDWORD) + (FONTTOMCCSFN POINTER) + (NIL POINTER) + (FONTDEVICESPEC POINTER) + (OTHERDEVICEFONTPROPS POINTER) + (FONTSCALE POINTER) + (\SFFACECODE BITS 8) + (FONTAVGCHARWIDTH WORD) + (FONTCHARENCODING POINTER) + (FONTCHARSETVECTOR POINTER) + (FONTHASLEFTKERNS FLAG) + (FONTEXTRAFIELD2 POINTER))) + +(DATATYPE CHARSETINFO (WIDTHS (CSSLUGP FLAG) + (CSCOMPLETEP FLAG) + OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD) + (CHARSETDESCENT WORD) + LEFTKERN CSINFOPROPS (CHARSETNO WORD))) +) +(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 30-Aug-2025 23:29 by rmk") + (* ; "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.") + + (* ;; "ACFONTFILES STORE A SINGLE NUMBER. LOGIC OF CODES IS UNCLEAR") + + (LET [(KERN (AND (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS) of FONT) + (ELT (fetch (CHARSETINFO LEFTKERN) of (\INSURECHARSETINFO FONT (\CHARSET + PREVCHARCODE + ))) + (\CHAR8CODE PREVCHARCODE] + (OR (FIXP KERN) + (FGETMULTI (LISTP KERN) + CHARCODE) + 0]) +) +(DEFINEQ + +(\CREATEFONT + [LAMBDA (FONTSPEC) (* ; "Edited 28-Aug-2025 14:30 by rmk") + (* ; "Edited 18-Aug-2025 00:17 by rmk") + (* ; "Edited 16-Aug-2025 20:52 by rmk") + (* ; "Edited 12-Aug-2025 23:36 by rmk") + (* ; "Edited 24-Jul-2025 19:51 by rmk") + (* ; "Edited 20-May-2025 21:10 by rmk") + + (* ;; "Generic font creation. Uses fontcreate method from device to build the font fontdescriptor but doesn't call SETFONTDESCRIPTOR to install it and doesn't instantiate a charset. That's deferred to FONTCREATE1. ") + + (* ;; "") + + (LET [(FN (CAR (FGETMULTI IMAGESTREAMTYPES (fetch (FONTSPEC FSDEVICE) of FONTSPEC) + 'FONTCREATE] + (CL:WHEN FN + (if (EQ (NARGS FN) + 1) + then (APPLY* FN FONTSPEC) + else (* ; "Old form: spreading FONTSPEC") + (APPLY FN FONTSPEC)))]) + +(\CREATECHARSET + [LAMBDA (CHARSET FONT) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 28-Aug-2025 14:31 by rmk") + (* ; "Edited 27-Aug-2025 12:55 by rmk") + (* ; "Edited 25-Aug-2025 22:51 by rmk") + (* ; "Edited 16-Aug-2025 21:06 by rmk") + (* ; "Edited 12-Aug-2025 23:36 by rmk") + (* ; "Edited 5-Aug-2025 22:29 by rmk") + (* ; "Edited 3-Aug-2025 17:41 by rmk") + (* ; "Edited 29-Jul-2025 12:10 by rmk") + (* ; "Edited 22-Jul-2025 22:48 by rmk") + (* ; "Edited 9-Jul-2025 11:12 by rmk") + (* ; "Edited 15-Jun-2025 14:50 by rmk") + (* ; "Edited 13-Jun-2025 20:00 by rmk") + (* ; "Edited 10-Jun-2025 13:55 by rmk") + (* ; "Edited 7-Jun-2025 15:10 by rmk") + (* ; "Edited 18-May-2025 21:40 by rmk") + (* ; "Edited 16-May-2025 21:37 by rmk") + (* ; "Edited 12-Jul-2022 14:37 by rmk") + (* ; "Edited 8-May-93 23:42 by rmk:") + (* ; "Edited 4-Dec-92 11:43 by jds") + + (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") + + (CL:UNLESS (<= 0 CHARSET \MAXCHARSET) + (\ILLEGAL.ARG CHARSET)) + (LET [(CSINFO (if (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT) + then (\GETCHARSETINFO FONT CHARSET) + else (APPLY* (OR (CAR (FGETMULTI IMAGESTREAMTYPES (fetch (FONTDESCRIPTOR + FONTDEVICE) + of FONT) + 'CREATECHARSET)) + (FUNCTION \READCHARSET)) + (create FONTSPEC using (FONTPROP FONT 'DEVICESPEC)) + FONT CHARSET] + + (* ;; "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. ") + + (if (AND CSINFO (NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO))) + then (\INSTALLCHARSETINFO FONT CSINFO CHARSET) + elseif (SETQ CSINFO (\GETCHARSETINFO FONT SLUGCHARSET)) + else (SETQ CSINFO (\BUILDSLUGCSINFO FONT)) + (\SETCHARSETINFO FONT SLUGCHARSET CSINFO) + (\SETCHARSETINFO FONT CHARSET CSINFO)) + CSINFO]) + +(\INSTALLCHARSETINFO + [LAMBDA (FONT CSINFO CHARSET) (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 25-Aug-2025 14:32 by rmk") + (* ; "Edited 24-Aug-2025 11:29 by rmk") + (* ; "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))) + (replace (FONTDESCRIPTOR \SFDescent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFDescent) + of FONT) + (SIGNED (fetch (CHARSETINFO + CHARSETDESCENT) + of CSINFO) + 16))) + (* ; + "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)") + (replace (FONTDESCRIPTOR \SFHeight) of FONT with (IPLUS (fetch (FONTDESCRIPTOR \SFAscent) + of FONT) + (ffetch (FONTDESCRIPTOR \SFDescent) + of FONT))) + (replace (CHARSETINFO CHARSETNO) of CSINFO with CHARSET) (* ; "In case the device didn't do it") + (\INSTALLCHARSETINFO.CHARENCODING FONT CSINFO CHARSET) + (\SETCHARSETINFO FONT CHARSET CSINFO) + + (* ;; "\AVGCHARWIDTH has to be confused after the CSINFO is stuck in.") + + (CL:WHEN (EQ 0 (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT)) + (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT))) + (CL:WHEN (EQ 0 (fetch (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT)) + (* ; "CSINFO is presumably charset 0") + (replace (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT with (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) + of CSINFO) + SLUGCHARINDEX))) + (CL:WHEN (EQ 0 (fetch (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT)) + (* ; "Still 0: try for the average") + (replace (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT with (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) + of FONT))) + 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%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS FIRSTCHARSETCODE MACRO ((CHARSET) + (LLSH CHARSET 8))) + +(PUTPROPS LASTCHARSETCODE MACRO ((CHARSET) + (LOGOR (LLSH CHARSET 8) + \MAXTHINCHAR))) +) +) +(DEFINEQ + +(\FONTRESETCHARWIDTHS + [LAMBDA (CSINFO FIRSTCHAR LASTCHAR) (* ; "Edited 3-Aug-2025 20:59 by rmk") + (* ; "Edited 1-Aug-2025 23:50 by rmk") + (* AJB " 6-Dec-85 14:42") + (for CHARCODE LEFT RIGHT SLUGCHAROFFSET SLUGCHARWIDTH (OFFSETS _ (fetch (CHARSETINFO OFFSETS) + of CSINFO)) + (WIDTHS _ (fetch (CHARSETINFO WIDTHS) of CSINFO)) from 0 to SLUGCHARINDEX + first (SETQ SLUGCHAROFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX)) + (SETQ SLUGCHARWIDTH (IDIFFERENCE (\FGETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)) + SLUGCHAROFFSET)) + do (SETQ LEFT (\FGETWIDTH OFFSETS CHARCODE)) + (if (EQ SLUGCHAROFFSET LEFT) + then (\FSETWIDTH WIDTHS CHARCODE SLUGCHARWIDTH) + else (SETQ RIGHT (\FGETWIDTH OFFSETS (ADD1 CHARCODE))) + (if (EQ LEFT RIGHT) + then (\FSETOFFSET OFFSETS CHARCODE SLUGCHAROFFSET) + (\FSETWIDTH WIDTHS CHARCODE SLUGCHARWIDTH) + else (\FSETWIDTH WIDTHS CHARCODE (IDIFFERENCE RIGHT LEFT]) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE) + (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) + of (\INSURECHARSETINFO FONT (\CHARSET CHARCODE)) + ) + (\CHAR8CODE CHARCODE)))) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) + +(PUTPROPS FONT FILETYPE :FAKE-COMPILE-FILE) + + + +(* ;; "") + + + + +(* ;; "DISPLAY") + + (* ; "Functions for DISPLAY IMAGESTREAMTYPES ") @@ -2633,43 +3760,45 @@ (DEFINEQ (\CREATEDISPLAYFONT - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 13-Jun-2025 22:58 by rmk") + [LAMBDA (FONTSPEC) (* ; "Edited 28-Aug-2025 16:00 by rmk") + (* ; "Edited 18-Aug-2025 11:32 by rmk") + (* ; "Edited 16-Aug-2025 18:46 by rmk") + (* ; "Edited 10-Aug-2025 13:24 by rmk") + (* ; "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") + (* ; "gbn: 25-Jan-86 18:02") - (* ;; "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.") + (* ;; "FONTEXISTS? has determined that there is at least one source file for this font, so the font exists in at least some character sets, d FONTCREATED1 tells us that the font descriptor is not yet availabe.") - (* ;; "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]) + (create FONTDESCRIPTOR + FONTFAMILY _ (fetch (FONTSPEC FSFAMILY) of FONTSPEC) + FONTSIZE _ (fetch (FONTSPEC FSSIZE) of FONTSPEC) + FONTFACE _ (fetch (FONTSPEC FSFACE) of FONTSPEC) + ROTATION _ (fetch (FONTSPEC FSROTATION) of FONTSPEC) + FONTDEVICE _ (fetch (FONTSPEC FSDEVICE) of FONTSPEC) + \SFAscent _ 0 + \SFDescent _ 0 + \SFHeight _ 0 + FONTDEVICESPEC _ (create FONTSPEC using FONTSPEC]) (\CREATECHARSET.DISPLAY - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC)(* ; "Edited 22-Jul-2025 22:04 by rmk") + [LAMBDA (FONTSPEC FONT CHARSET) (* ; "Edited 2-Sep-2025 23:42 by rmk") + (* ; "Edited 30-Aug-2025 19:42 by rmk") + (* ; "Edited 28-Aug-2025 23:08 by rmk") + (* ; "Edited 26-Aug-2025 23:29 by rmk") + (* ; "Edited 18-Aug-2025 09:12 by rmk") + (* ; "Edited 31-Jul-2025 10:14 by rmk") (* ; "Edited 13-Jul-2025 11:44 by rmk") - (* ; "Edited 11-Jul-2025 11:00 by rmk") - (* ; "Edited 8-Jul-2025 08:14 by rmk") - (* ; "Edited 6-Jul-2025 22:55 by rmk") - (* ; "Edited 8-Jun-2025 19:57 by rmk") (* ; "Edited 20-May-2025 15:00 by rmk") (* ; "Edited 18-May-2025 23:31 by rmk") (* ; "Edited 14-Jan-88 23:42 by FS") (* ;; "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. ") - (* ;; "After that, it uses requested source files and/or DISPLAYGLYPHCOERCIONS to produce and complete the CHARSETINFO:") + (* ;; "After that, it uses requested source files and/or DISPLAYCHARCOERCIONS to produce and complete the CHARSETINFO:") (* ;; "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.") @@ -2683,63 +3812,78 @@ (* ;; "") - (* ;; "Maybe nobody cares about Classic 36...let's remove that coercion and see what happens.") + (LET ((ROTATION (fetch (FONTSPEC FSROTATION) of FONTSPEC)) + (FACE (fetch (FONTSPEC FSFACE) of FONTSPEC)) + CSINFO) - (* ;; "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. ") + (* ;; + "If no COERCIONS, skip that first \COERCECHARSET call--easier debugging of the other cases.") - (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS DISPLAYGLYPHCOERCIONS)) - (LET (CSINFO) - - (* ;; "If no DISPLAYFONTCOERCIONS, skip that first \COERCECHARSET call--easier debugging of the other case.") - - (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))) + (SETQ CSINFO (if (AND (FONTDEVICEPROP 'DISPLAY 'FONTCOERCIONS) + (CADR (\COERCECHARSET FONTSPEC CHARSET))) + elseif [SETQ CSINFO (OR (\READCHARSET FONTSPEC CHARSET FONT) + (CADR (\COERCECHARSET FONTSPEC CHARSET NIL + 'CHARCOERCIONS] 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.") - (COMPLETE.CHARSET CSINFO FAMILY SIZE FACE ROTATION DEVICE CHARSET - DISPLAYGLYPHCOERCIONS FONTDESC) + (COMPLETE.CHARSET CSINFO FONTSPEC CHARSET FONT) elseif (NEQ ROTATION 0) then (CL:UNLESS (MEMB ROTATION '(90 270)) - (ERROR "only implemented rotations are 0, 90 and 270." ROTATION + (ERROR "Only implemented rotations are 0, 90 and 270." ROTATION )) - (CL:WHEN (SETQ CSINFO (\CREATECHARSET.DISPLAY FAMILY SIZE FACE 0 - DEVICE CHARSET FONTDESC)) + (CL:WHEN (SETQ CSINFO (\CREATECHARSET.DISPLAY (create FONTSPEC + using FONTSPEC + FSROTATION _ 0) + FONT CHARSET)) (\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)) + (\CREATECHARSET.DISPLAY (create FONTSPEC + using FONTSPEC FSFACE _ + '(MEDIUM REGULAR REGULAR)) + FONT CHARSET)) elseif (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) - then (MAKEBOLD.CHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET - DISPLAYGLYPHCOERCIONS) + then (MAKEBOLD.CHARSET FONTSPEC CHARSET FONT) elseif (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE)) - then (MAKEITALIC.CHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET - DISPLAYGLYPHCOERCIONS))) + then (MAKEITALIC.CHARSET FONTSPEC CHARSET FONT) + elseif (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE)) + then (\CREATECHARSET.DISPLAY (create FONTSPEC + using FONTSPEC FSFACE _ + '(MEDIUM REGULAR REGULAR)) + FONT CHARSET))) CSINFO]) (\FONTEXISTS?.DISPLAY - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 25-Jul-2025 21:38 by rmk") + [LAMBDA (FONTSPEC) (* ; "Edited 28-Aug-2025 22:12 by rmk") + (* ; "Edited 25-Aug-2025 15:04 by rmk") + (* ; "Edited 17-Aug-2025 09:56 by rmk") + (* ; "Edited 8-Aug-2025 10:03 by rmk") + (* ; "Edited 5-Aug-2025 17:55 by rmk") + (* ; "Edited 29-Jul-2025 22:56 by rmk") + (* ; "Edited 25-Jul-2025 21:38 by rmk") (* ; "Edited 13-Jul-2025 11:45 by rmk") (* ; "Edited 22-Jun-2025 08:53 by rmk") (* ;; "Order doesn't matter here, only need one to work") - (OR (AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) - (FONTEXISTS? FAMILY SIZE (create FONTFACE using FACE WEIGHT _ 'MEDIUM) - ROTATION DEVICE CHARSET)) - (AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE)) - (FONTEXISTS? FAMILY SIZE (create FONTFACE using FACE SLOPE _ 'REGULAR) - ROTATION DEVICE CHARSET)) - (for C VAL in (\COERCEFONTSPEC (APPEND DISPLAYFONTCOERCIONS DISPLAYGLYPHCOERCIONS) - FAMILY SIZE FACE ROTATION DEVICE CHARSET) when (SETQ VAL (FONTEXISTS? - C)) - do (RETURN VAL]) + (LET ((FACE (fetch (FONTSPEC FSFACE) of FONTSPEC))) + (OR [AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) + (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE _ + (create FONTFACE using FACE WEIGHT _ + 'MEDIUM] + [AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE)) + (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE _ + (create FONTFACE using FACE SLOPE _ + 'REGULAR] + [AND (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE)) + (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE _ + (create FONTFACE using FACE EXPANSION _ + 'REGULAR] + (for FS VAL in [COERCEFONTSPEC FONTSPEC (APPEND (FONTDEVICEPROP 'DISPLAY 'FONTCOERCIONS) + (FONTDEVICEPROP 'DISPLAY 'CHARCOERCIONS] + when (SETQ VAL (FONTEXISTS? FS)) do (RETURN VAL]) ) (DEFINEQ @@ -2761,7 +3905,9 @@ T))]) (STRIKEFONT.GETCHARSET - [LAMBDA (STRM) (* ; "Edited 14-Jul-2025 19:52 by rmk") + [LAMBDA (STRM) (* ; "Edited 3-Aug-2025 22:27 by rmk") + (* ; "Edited 1-Aug-2025 23:50 by rmk") + (* ; "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") @@ -2808,80 +3954,103 @@ (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 NUMBCODES (IDIFFERENCE (ADD1 LASTCHAR) + FIRSTCHAR)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (* ; "initialise the offsets to 0") + + (* ;; + "Initialize the offsets to 0, all but FIRSTCHAR to be replaced with the slug offset") + (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))) + (for I from FIRSTCHAR as J from 1 to NUMBCODES do + (* ;; + "J starts at 1 because we know that the offset of J=0 is 0 ?") + + (\FSETOFFSET OFFSETS I (\WIN STRM))) + (for I (SLUGOFFSET _ (\WIN STRM)) from 0 to \MAXTHINCHAR + when (EQ 0 (\FGETOFFSET OFFSETS I)) unless (EQ I FIRSTCHAR) + do (\FSETOFFSET OFFSETS I SLUGOFFSET) finally (\FSETOFFSET OFFSETS SLUGCHARINDEX + SLUGOFFSET) + + (* ;; + "There's one more so that \FONTRESETCHARWIDTHS can get the slug width, otherwise not necessary") + + (\FSETOFFSET OFFSETS (ADD1 SLUGCHARINDEX) + (\WIN STRM))) + + (* ;; "Initialize the widths to 0") + (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) + (\FONTRESETCHARWIDTHS CSINFO 0 SLUGCHARINDEX) (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO)) CSINFO))]) (WRITESTRIKEFONTFILE - [LAMBDA (FONT CHARSET FILE) (* ; "Edited 22-May-2025 09:53 by rmk") + [LAMBDA (FONT CHARSET FILE) (* ; "Edited 30-Aug-2025 23:21 by rmk") + (* ; "Edited 28-Aug-2025 15:09 by rmk") + (* ; "Edited 24-Aug-2025 11:39 by rmk") + (* ; "Edited 3-Aug-2025 22:33 by rmk") + (* ; "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") (* ; - "Write strike FILE using info in FONT. *") + "Write strike FILE using info in FONT. ") (CL:UNLESS (FONTP FONT) (LISPERROR "ILLEGAL ARG" FONT)) (CL:UNLESS CHARSET (SETQ CHARSET 0)) (CL:UNLESS (AND (IGEQ CHARSET 0) (ILEQ CHARSET \MAXCHARSET)) (LISPERROR "ILLEGAL ARG" CHARSET)) - (LET (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS MAXWIDTH LENGTH RASTERWIDTH DUMMYCHAR DUMMYOFFSET - PREVIOUSOFFSET OFFSETS) - (SETQ CSINFO (\INSURECHARSETINFO CHARSET FONT T)) + (LET (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS MAXWIDTH LENGTH RASTERWIDTH SLUGOFFSET OFFSETS) + (SETQ CSINFO (\INSURECHARSETINFO FONT CHARSET)) (CL:UNLESS CSINFO (ERROR "Couldn't find charset " CHARSET)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX)) - [SETQ FIRSTCHAR (for I from 0 to MAXCODE thereis (NOT (EQ (\FGETOFFSET OFFSETS I) - DUMMYOFFSET] - [SETQ LASTCHAR (for I from MAXCODE to 0 by -1 thereis (NOT (EQ (\FGETOFFSET OFFSETS I) - DUMMYOFFSET] - (SETQ DUMMYCHAR (ADD1 LASTCHAR)) + (SETQ SLUGOFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX)) + + (* ;; "Find the first and last non-slug characters") + + [SETQ FIRSTCHAR (for I from 0 to \MAXTHINCHAR thereis (NEQ SLUGOFFSET (\FGETOFFSET OFFSETS I + ] + [SETQ LASTCHAR (for I from \MAXTHINCHAR to 0 by -1 thereis (NEQ SLUGOFFSET (\FGETOFFSET + OFFSETS I] [SETQ STREAM (OPENSTREAM FILE 'OUTPUT 'NEW '((TYPE BINARY] - (\WOUT STREAM 32768) (* ; "STRIKE HEADER. *") + (\WOUT STREAM 32768) (* ; "STRIKE HEADER. ") (\WOUT STREAM FIRSTCHAR) (\WOUT STREAM LASTCHAR) (SETQ MAXWIDTH 0) - [for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I] - (\WOUT STREAM MAXWIDTH) (* ; "STRIKE BODY. *") - (* ; "Length. *") + [for I from 0 to SLUGCHARINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I] + (\WOUT STREAM MAXWIDTH) (* ; "STRIKE BODY. ") + (* ; "Length. ") (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR) (ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT) RASTERWIDTH))) (\WOUT STREAM LENGTH) (* ; - "Ascent, Descent, Xoffset (no longer used) and Rasterwidth. *") + "Ascent, Descent, Xoffset (no longer used) and Rasterwidth. ") (\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) (\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (\WOUT STREAM 0) - (\WOUT STREAM RASTERWIDTH) (* ; "Bitmap. *") + (\WOUT STREAM RASTERWIDTH) (* ; "Bitmap. ") [\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) 0 (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO] - (* ; "Offsets. *") - (for I WIDTH OFFSET (CODE _ 0) from FIRSTCHAR to DUMMYCHAR first (\WOUT STREAM CODE) - do (SETQ OFFSET (\FGETOFFSET OFFSETS I)) - (SETQ WIDTH (\FGETWIDTH WIDTHS I)) - (CL:UNLESS (AND (IEQP OFFSET DUMMYOFFSET) - (NOT (IEQP I DUMMYCHAR))) - (ADD CODE WIDTH)) - (\WOUT STREAM CODE)) + (* ; "Offsets. ") + [for I (OFFSET _ 0) from FIRSTCHAR to LASTCHAR first (\WOUT STREAM OFFSET) + (* ; "Offset of the first char") + do (CL:UNLESS (EQ SLUGOFFSET (\FGETOFFSET OFFSETS I)) + (* ; + "The slug isn't really here in the bitmap") + (ADD OFFSET (\FGETWIDTH WIDTHS I))) + (\WOUT STREAM OFFSET) finally (* ; + "Offset for the after-slug, for width") + (\WOUT STREAM (IPLUS OFFSET (\FGETWIDTH WIDTHS + SLUGCHARINDEX] (CLOSEF STREAM]) (STRIKECSINFO @@ -2963,38 +4132,62 @@ (DEFINEQ (MAKEBOLD.CHARSET - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS) + [LAMBDA (FONTSPEC CHARSET FONT) (* ; "Edited 7-Sep-2025 12:02 by rmk") + (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 26-Aug-2025 22:35 by rmk") + (* ; "Edited 18-Aug-2025 09:08 by rmk") + (* ; "Edited 16-Aug-2025 12:53 by rmk") (* ; "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.") + (LET ([MFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSFACE _ (create FONTFACE + using (fetch (FONTSPEC + FSFACE) + of FONTSPEC) + WEIGHT _ 'MEDIUM] + CSINFO) - (CL:WHEN (SETQ SOURCECSINFO - (\COERCECHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET - COERCIONS THINCODE)) - (\MOVEFONTCHAR SOURCECSINFO CSINFO THINCODE THINCODE)) - else (MAKEBOLD.CHAR THINCODE CSINFO))) + (* ;; "MFONT is the corresponding Medium font.") + + (CL:WHEN (AND MFONT (SETQ CSINFO (\GETCHARSETINFO MFONT CHARSET)) + (NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO))) + (replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT with (fetch (FONTDESCRIPTOR + FONTCHARENCODING) + of MFONT)) + (replace (FONTDESCRIPTOR FONTTOMCCSFN) of FONT with (fetch (FONTDESCRIPTOR FONTTOMCCSFN) + of MFONT)) + (SETQ CSINFO (COPYALL CSINFO)) (* ; "CSINFO is now the CS to be bolded") + (\SETCHARSETINFO FONT CHARSET CSINFO) + (for CODE SOURCEFONT (CHARCOERCIONS _ (FONTDEVICEPROP FONT 'CHARCOERCIONS)) + from (FIRSTCHARSETCODE CHARSET) to (LASTCHARSETCODE CHARSET) + do (if (SLUGCHARP.DISPLAY CODE FONT) + then + (* ;; "The Medium font doesn't have a glyph for THINCODE. Look for a bold glyph for THINCODE lurking somewhere down the chain, copy it up. There may be different sources for different codes. We're starting from FONT and FONTSPEC, still hoping for BOLD.") + + (CL:WHEN (SETQ SOURCEFONT (CAR (\COERCECHARSET FONTSPEC CHARSET CODE))) + (\MOVEFONTCHAR (\MOVEFONTCHARS.SOURCEDATA CODE SOURCEFONT) + CODE FONT)) + else + (* ;; "There is Medium glyph, bold it") + + (MAKEBOLD.CHAR CODE FONT))) (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with T) CSINFO)]) (MAKEBOLD.CHAR - [LAMBDA (THINCODE CSINFO) (* ; "Edited 17-Jun-2025 08:22 by rmk") + [LAMBDA (CODE FONT) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 27-Aug-2025 23:55 by rmk") + (* ; "Edited 26-Aug-2025 22:36 by rmk") + (* ; "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.") + (* ;; "Replaces the bitmap for CODE in FONT 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)) + (CL:UNLESS (SLUGCHARP.DISPLAY CODE FONT) + (LET* [(THINCODE (\CHAR8CODE CODE)) + (CSINFO (\GETCHARSETINFO FONT (\CHARSET CODE))) + (OLDCHARBITMAP (\GETCHARBITMAP.CSINFO THINCODE CSINFO)) (NEWCHARBITMAP (BITMAPCREATE (ADD1 (fetch BITMAPWIDTH of OLDCHARBITMAP)) (fetch BITMAPHEIGHT of OLDCHARBITMAP))) (CWIDTH (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO) @@ -3010,39 +4203,63 @@ (\PUTCHARBITMAP.CSINFO THINCODE CSINFO NEWCHARBITMAP)))]) (MAKEITALIC.CHARSET - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET COERCIONS) + [LAMBDA (FONTSPEC CHARSET FONT) (* ; "Edited 7-Sep-2025 12:03 by rmk") + (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 31-Aug-2025 14:36 by rmk") + (* ; "Edited 26-Aug-2025 22:35 by rmk") + (* ; "Edited 18-Aug-2025 09:10 by rmk") + (* ; "Edited 16-Aug-2025 12:53 by rmk") (* ; "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.") + (LET ([RFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSFACE _ (create FONTFACE + using (fetch (FONTSPEC + FSFACE) + of FONTSPEC) + SLOPE _ 'REGULAR] + CSINFO) - (CL:WHEN (SETQ SOURCECSINFO - (\COERCECHARSET FAMILY SIZE FACE ROTATION DEVICE CHARSET - COERCIONS THINCODE)) - (\MOVEFONTCHAR SOURCECSINFO CSINFO THINCODE THINCODE)) - else (MAKEITALIC.CHAR THINCODE CSINFO))) + (* ;; "RFONT is the corresponding Regular font.") + + (CL:WHEN (AND RFONT (SETQ CSINFO (\GETCHARSETINFO RFONT CHARSET)) + (NOT (fetch (CHARSETINFO CSSLUGP) of CSINFO))) + (replace (FONTDESCRIPTOR FONTCHARENCODING) of FONT with (fetch (FONTDESCRIPTOR + FONTCHARENCODING) + of RFONT)) + (replace (FONTDESCRIPTOR FONTTOMCCSFN) of FONT with (fetch (FONTDESCRIPTOR FONTTOMCCSFN) + of RFONT)) + (SETQ CSINFO (COPYALL CSINFO)) (* ; + "CSINFO is now the CS to be italicized") + (\SETCHARSETINFO FONT CHARSET CSINFO) + (for CODE SOURCEFONT (CHARCOERCIONS _ (FONTDEVICEPROP FONT 'CHARCOERCIONS)) + from (FIRSTCHARSETCODE CHARSET) to (LASTCHARSETCODE CHARSET) + do (if (SLUGCHARP.DISPLAY CODE FONT) + then + (* ;; "The regular font doesn't have a glyph for THINCODE. 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 SOURCEFONT (CAR (\COERCECHARSET FONTSPEC CHARSET CODE))) + (\MOVEFONTCHAR (\MOVEFONTCHARS.SOURCEDATA CODE SOURCEFONT) + CODE FONT)) + else + (* ;; "There is a Regular glyph, Italicize it.") + + (MAKEITALIC.CHAR CODE FONT))) (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with T) CSINFO)]) (MAKEITALIC.CHAR - [LAMBDA (THINCODE CSINFO) (* ; "Edited 18-Jun-2025 14:12 by rmk") + [LAMBDA (CODE FONT) (* ; "Edited 2-Sep-2025 22:59 by rmk") + (* ; "Edited 26-Aug-2025 22:36 by rmk") + (* ; "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. ") + (* ;; "Replaces the bitmap for CODE in FONT 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)) + (CL:UNLESS (SLUGCHARP.DISPLAY CODE FONT) + (LET* ((THINCODE (\CHAR8CODE CODE)) + (CSINFO (\GETCHARSETINFO FONT (\CHARSET CODE))) + (OLDBITMAP (\GETCHARBITMAP.CSINFO THINCODE CSINFO)) (NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP) (fetch BITMAPHEIGHT of OLDBITMAP))) (WIDTH (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO) @@ -3068,7 +4285,9 @@ (\PUTCHARBITMAP.CSINFO THINCODE CSINFO NEWBITMAP)))]) (\SFMAKEBOLD - [LAMBDA (CSINFO) (* ; "Edited 16-Jun-2025 23:22 by rmk") + [LAMBDA (CSINFO) (* ; "Edited 28-Aug-2025 15:10 by rmk") + (* ; "Edited 24-Aug-2025 11:41 by rmk") + (* ; "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)) @@ -3078,9 +4297,9 @@ 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))) + (SETQ SLUGOFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX)) + (SETQ SLUGWIDTH (\FGETWIDTH WIDTHS SLUGCHARINDEX)) + (for I from 0 to \MAXTHINCHAR 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) @@ -3184,9 +4403,11 @@ (270 (ROTATE-BITMAP CHARBITMAP)))]) (\SFROTATECSINFOOFFSETS - [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:36") + [LAMBDA (CSINFO ROTATION) (* ; "Edited 28-Aug-2025 15:10 by rmk") + (* ; "Edited 24-Aug-2025 11:42 by rmk") + (* gbn "15-Sep-85 14:36") (* ; - "adjusts offsets in case where rotation turned things around.") + "adjusts offsets in case where rotation turned things around.") (COND ((EQ ROTATION 270) (PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) @@ -3194,12 +4415,14 @@ (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] + [for CHARCODE from 0 to \MAXTHINCHAR do (\FSETOFFSET NEWOFFSETS CHARCODE + (IDIFFERENCE BITMAPHEIGHT + (IPLUS (\FGETOFFSET OFFSETS + CHARCODE) + (\FGETWIDTH WIDTHS + CHARCODE] (* ; - "may be some problem with dummy character representation.") + "may be some problem with dummy character representation.") (RETURN NEWOFFSETS))) (T (fetch (CHARSETINFO OFFSETS) of CSINFO]) ) @@ -3230,636 +4453,78 @@ CHARACTERBITMAP)) (RETURN COLORCSINFO]) ) -(DEFINEQ - -(FONTDESCRIPTOR.DEFPRINT - [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))) - - (* ;; "Could lowercase the family, but maybe too dangerous if a BREAK on L-CASE.") - - (* ;; "Somehow flag the device too?") - - (CONS (CONCAT "{" (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT) - (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) - "-" - (SELECTQ (fetch (FONTFACE WEIGHT) of FACE) - (MEDIUM 'M) - (BOLD 'B) - (LIGHT 'L) - (fetch (FONTFACE WEIGHT) of FACE)) - (SELECTQ (fetch (FONTFACE SLOPE) of FACE) - (ITALIC 'I) - (REGULAR 'R) - (fetch (FONTFACE SLOPE) of FACE)) - (SELECTQ (fetch (FONTFACE EXPANSION) of FACE) - (REGULAR 'R) - (COMPRESSED 'C) - (EXPANDED 'E) - (fetch (FONTFACE EXPANSION) of FACE)) - "/" - (OCTALSTRING (CAR LOC)) - "," - (OCTALSTRING (CDR LOC)) - "}"]) - -(FONTCLASS.DEFPRINT - [LAMBDA (FONTCLASS STREAM) (* ; "Edited 14-Dec-2024 16:51 by rmk") - (LET ((LOC (LOC FONTCLASS))) - (CONS (CONCAT "{" (OR (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS) - 'FONTCLASS) - "/" - (OCTALSTRING (CAR LOC)) - "," - (OCTALSTRING (CDR LOC)) - "}"]) -) - -(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER) - '((FONTCLASS 0 (BITS . 7)) - (FONTCLASS 2 POINTER) - (FONTCLASS 4 POINTER) - (FONTCLASS 6 POINTER) - (FONTCLASS 8 POINTER) - (FONTCLASS 10 POINTER)) - '12) - -(DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)) - -(/DECLAREDATATYPE 'FONTDESCRIPTOR - '(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) - (FONTDESCRIPTOR 8 (BITS . 15)) - (FONTDESCRIPTOR 9 (BITS . 15)) - (FONTDESCRIPTOR 10 (BITS . 15)) - (FONTDESCRIPTOR 11 (BITS . 15)) - (FONTDESCRIPTOR 12 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 13 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 14 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 15 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 16 POINTER) - (FONTDESCRIPTOR 18 POINTER) - (FONTDESCRIPTOR 20 POINTER) - (FONTDESCRIPTOR 22 POINTER) - (FONTDESCRIPTOR 24 POINTER) - (FONTDESCRIPTOR 26 (BITS . 7)) - (FONTDESCRIPTOR 27 (BITS . 15)) - (FONTDESCRIPTOR 28 POINTER) - (FONTDESCRIPTOR 30 POINTER) - (FONTDESCRIPTOR 30 (FLAGBITS . 0)) - (FONTDESCRIPTOR 32 POINTER)) - '34) - -(DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)) - -(/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) - (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) - (\SFAscent WORD) - (\SFDescent WORD) - (\SFHeight WORD) - (ROTATION WORD) - (NIL SIGNEDWORD) - (NIL SIGNEDWORD) - (NIL SIGNEDWORD) - (NIL SIGNEDWORD) - (NIL POINTER) - (NIL POINTER) - (FONTDEVICESPEC POINTER) - (OTHERDEVICEFONTPROPS POINTER) - (FONTSCALE POINTER) - (\SFFACECODE BITS 8) - (FONTAVGCHARWIDTH WORD) - (FONTCHARENCODING POINTER) - (FONTCHARSETVECTOR POINTER) - (FONTHASLEFTKERNS FLAG) - (FONTEXTRAFIELD2 POINTER))) - -(DATATYPE CHARSETINFO (WIDTHS (CSSLUGP FLAG) - (CSCOMPLETEP FLAG) - OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD) - (CHARSETDESCENT WORD) - LEFTKERN CSINFOPROPS)) -) - -(RPAQ? \FONTSINCORE ) - -(RPAQ? \DEFAULTDEVICEFONTS ) - -(RPAQ? \UNITWIDTHSVECTOR ) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(\UNITWIDTHSVECTOR) -) -(* "FOLLOWING DEFINITIONS EXPORTED") -(DEFOPTIMIZER FONTPROP (&REST ARGS) - (SELECTQ (AND (EQ (CAADR ARGS) - 'QUOTE) - (CADADR ARGS)) - (ASCENT (LIST 'FONTASCENT (CAR ARGS))) - (DESCENT (LIST 'FONTDESCENT (CAR ARGS))) - (HEIGHT (LIST 'FONTHEIGHT (CAR ARGS))) - 'IGNOREMACRO)) - -(* "END EXPORTED DEFINITIONS") - -(DECLARE%: DONTCOPY -(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE - -(DATATYPE FONTCLASS ((PRETTYFONT# BYTE) - DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME) - (INIT (DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)))) - -(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) - (FONTCOMPLETEP FLAG) - (FONTFAMILY POINTER) - (FONTSIZE POINTER) - (FONTFACE POINTER) - (\SFAscent WORD) - (\SFDescent WORD) - (\SFHeight WORD) - (ROTATION WORD) - (NIL SIGNEDWORD) - - (* ;; "Was FBBOX. The fields are NIL'ed out now because they became irrelevant when multiple charsets were introduced. They remain as a place-holder in the layout pending a recompile of all referring functions.") - - (NIL SIGNEDWORD) (* ; "Was FBBOY") - (NIL SIGNEDWORD) (* ; "Was FBBDX") - (NIL SIGNEDWORD) (* ; "Was FBBDY") - (NIL POINTER) (* ; "Was \SFLKerns") - (NIL POINTER) (* ; "Was \SFRWidths") - (FONTDEVICESPEC POINTER) (* ; - "Holds the spec by which the font is known to the printing device, if coercion has been done") - (OTHERDEVICEFONTPROPS POINTER) (* ; - "For individual devices to hang special information") - (FONTSCALE POINTER) - (\SFFACECODE BITS 8) - (FONTAVGCHARWIDTH WORD) (* ; - "Set in FONTCREATE, used to fix up the linelength when DSPFONT is called") - (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)) - FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR) - (INIT (DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)))) - -(RECORD FONTFACE (WEIGHT SLOPE EXPANSION) - [ACCESSFNS ((COLOR (CDDDR DATUM) - (RPLACD (CDDR DATUM) - NEWVALUE)) - (BACKCOLOR [COND - ((CDDDR DATUM) - (CAR (CDDDR DATUM] - (PROGN [COND - ((NULL (CDDDR DATUM)) - (RPLACD (CDDR DATUM) - (LIST NIL NIL] - (RPLACA (CDDDR DATUM) - NEWVALUE))) - (FORECOLOR [COND - ((CDDDR DATUM) - (CADR (CDDDR DATUM] - (PROGN [COND - ((NULL (CDDDR DATUM)) - (RPLACD (CDDR DATUM) - (LIST NIL NIL] - (RPLACA (CDR (CDDDR DATUM)) - NEWVALUE] - 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. 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 - (CHARSETASCENT WORD) (* ; - "Max ascent for all characters in this CHARSET") - (CHARSETDESCENT WORD) (* ; - "Max descent for all characters in this CHARSET") - LEFTKERN CSINFOPROPS (* ; "Alist of extra properties")) - WIDTHS _ (\CREATECSINFOELEMENT) - OFFSETS _ (\CREATECSINFOELEMENT)) -) - -(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER) - '((FONTCLASS 0 (BITS . 7)) - (FONTCLASS 2 POINTER) - (FONTCLASS 4 POINTER) - (FONTCLASS 6 POINTER) - (FONTCLASS 8 POINTER) - (FONTCLASS 10 POINTER)) - '12) - -(DEFPRINT 'FONTCLASS (FUNCTION FONTCLASS.DEFPRINT)) - -(/DECLAREDATATYPE 'FONTDESCRIPTOR - '(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) - (FONTDESCRIPTOR 8 (BITS . 15)) - (FONTDESCRIPTOR 9 (BITS . 15)) - (FONTDESCRIPTOR 10 (BITS . 15)) - (FONTDESCRIPTOR 11 (BITS . 15)) - (FONTDESCRIPTOR 12 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 13 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 14 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 15 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 16 POINTER) - (FONTDESCRIPTOR 18 POINTER) - (FONTDESCRIPTOR 20 POINTER) - (FONTDESCRIPTOR 22 POINTER) - (FONTDESCRIPTOR 24 POINTER) - (FONTDESCRIPTOR 26 (BITS . 7)) - (FONTDESCRIPTOR 27 (BITS . 15)) - (FONTDESCRIPTOR 28 POINTER) - (FONTDESCRIPTOR 30 POINTER) - (FONTDESCRIPTOR 30 (FLAGBITS . 0)) - (FONTDESCRIPTOR 32 POINTER)) - '34) - -(DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)) - -(/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) - (CHARSETINFO 14 POINTER)) - '16) -(DECLARE%: EVAL@COMPILE - -(PUTPROPS FONTASCENT MACRO ((FONTSPEC) - (ffetch \SFAscent of (FONTCREATE FONTSPEC)))) - -(PUTPROPS FONTDESCENT MACRO ((FONTSPEC) - (ffetch \SFDescent of (FONTCREATE FONTSPEC)))) - -(PUTPROPS FONTHEIGHT MACRO ((FONTSPEC) - (ffetch \SFHeight of (FONTCREATE FONTSPEC)))) - -(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) - (\GETBASE OFFSETSBLOCK CHAR8CODE))) - -(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) - (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET))) - -(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) - (\GETBASE WIDTHSBLOCK CHAR8CODE))) - -(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE VAL) - (\PUTBASE WIDTHSBLOCK CHAR8CODE VAL))) - -(PUTPROPS \FGETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE) - (\FGETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\INSURECHARSETINFO - (\CHARSET CHARCODE) - FONTDESC)) - (\CHAR8CODE CHARCODE)))) - -(PUTPROPS \FSETCHARWIDTH MACRO (OPENLAMBDA (FONTDESC CHARCODE WIDTH) - (\FSETWIDTH (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO - (\CHARSET CHARCODE) - FONTDESC)) - (\CHAR8CODE CHARCODE) - WIDTH))) - -(PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) - (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE))) - -(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) - (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) -) -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \XGETCHARSETINFO MACRO ((FONTDESC CHARSET) - - (* ;; - "Temporary until other callers of \GETCHARSETINFO are changes to \INSURECHARSETINFO") - - (* ;; - "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)) - (\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, including one extra slot to hold the common slug charsetinfo") - - (\ALLOCBLOCK (IPLUS 2 \MAXCHARSET) - T))) - -(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) - - -(CONSTANTS (\MAXNSCHAR 65535)) -) - -(* "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 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.") - - (* ;; "ACFONTFILES STORE A SINGLE NUMBER. LOGIC OF CODES IS UNCLEAR") - - (LET [(KERN (AND (fetch (FONTDESCRIPTOR FONTHASLEFTKERNS) of FONT) - (ELT (fetch (CHARSETINFO LEFTKERN) of (\INSURECHARSETINFO (\CHARSET PREVCHARCODE - ) - FONT)) - (\CHAR8CODE PREVCHARCODE] - (OR (FIXP KERN) - (FGETMULTI (LISTP KERN) - CHARCODE) - 0]) -) -(DEFINEQ - -(\CREATEFONT - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 24-Jul-2025 19:51 by rmk") - (* ; "Edited 20-May-2025 21:10 by rmk") - - (* ;; "Generic font creation. Uses fontcreate method from device, build a fontdescriptor but doesn't call SETFONTDESCRIPTOR to install it.") - - (* ;; "\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...).") - - (LET (FN FONT) - (CL:WHEN (AND [SETQ FN (CADR (ASSOC 'FONTCREATE (CDR (ASSOC DEVICE IMAGESTREAMTYPES] - (SETQ FONT (APPLY* FN FAMILY SIZE FACE ROTATION DEVICE CHARSET))) - (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT with (\AVGCHARWIDTH FONT)) - FONT)]) - -(\CREATECHARSET - [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 22-Jul-2025 22:48 by rmk") - (* ; "Edited 9-Jul-2025 11:12 by rmk") - (* ; "Edited 15-Jun-2025 14:50 by rmk") - (* ; "Edited 13-Jun-2025 20:00 by rmk") - (* ; "Edited 10-Jun-2025 13:55 by rmk") - (* ; "Edited 7-Jun-2025 15:10 by rmk") - (* ; "Edited 18-May-2025 21:40 by rmk") - (* ; "Edited 16-May-2025 21:37 by rmk") - (* ; "Edited 12-Jul-2022 14:37 by rmk") - (* ; "Edited 8-May-93 23:42 by rmk:") - (* ; "Edited 4-Dec-92 11:43 by jds") - - (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") - (* ; - "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") - (CL:UNLESS (<= 0 CHARSET \MAXCHARSET) - (\ILLEGAL.ARG CHARSET)) - (LET [(CSINFO (if (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT) - then (\XGETCHARSETINFO FONT CHARSET) - else (APPLY [CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (fetch (FONTDESCRIPTOR - FONTDEVICE) - of FONT) - IMAGESTREAMTYPES] - (APPEND (FONTPROP FONT 'DEVICESPEC) - (LIST CHARSET FONT NOSLUG?] - - (* ;; "Create a descriptor of info for that charset. If we got one, the subfunction may have ignored NOSLUG?. But if not, we store it in the vector so that we don't search later. But we don't return a slug: higher ups recognize NIL as a doesn't-exist error. ") - - (CL:WHEN CSINFO (\INSTALLCHARSETINFO FONT CSINFO CHARSET)) - CSINFO]) - -(\INSTALLCHARSETINFO - [LAMBDA (FONT CSINFO CHARSET) (* ; "Edited 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))) - (replace (FONTDESCRIPTOR \SFDescent) of FONT with (IMAX (fetch (FONTDESCRIPTOR \SFDescent) - of FONT) - (SIGNED (fetch (CHARSETINFO - CHARSETDESCENT) - of CSINFO) - 16))) - (* ; - "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)") - (replace (FONTDESCRIPTOR \SFHeight) of FONT with (IPLUS (fetch (FONTDESCRIPTOR \SFAscent) - of FONT) - (ffetch (FONTDESCRIPTOR \SFDescent) - of FONT))) - (\SETCHARSETINFO (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT) - CHARSET CSINFO) - - (* ;; "\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))) - ]) -) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY -(GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYGLYPHCOERCIONS DISPLAYFONTCOERCIONS) +(GLOBALVARS DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS DISPLAYCHARCOERCIONS DISPLAYFONTCOERCIONS + DISPLAYCHARSETFNS) ) (* "END EXPORTED DEFINITIONS") +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQ? DISPLAYFONTDIRECTORIES NIL) +(ADDTOVAR DISPLAYCHARSETFNS (STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET)) -(* ;; -"Removed ((CLASSIC 36) (CLASSIC 24)) so that TIMESROMAN 36 BOLD boldifies rather than coercing to CLASSIC 24 BOLD." -) +(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT DISPLAYFONT) +) (RPAQ? DISPLAYFONTCOERCIONS - '(((HELVETICA 1) + '(((HELVETICA (<= * 2)) (HELVETICA 4)) - ((HELVETICA 2) - (HELVETICA 4)) - ((MODERN 60) - (MODERN 48)) - ((MODERN 96) - (MODERN 72)) - ((MODERN 120) - (MODERN 72)) + ((MODERN (<= 15 * 16)) + (* 14)) + ((MODERN (<= 17 * 21)) + (* 18)) + ((MODERN (<= 22 * 28)) + (* 24)) + ((MODERN (<= 29 * 33)) + (* 30)) + ((MODERN (<= 34 * 40)) + (* 36)) + ((MODERN (<= 41 * 65)) + (* 48)) + ((MODERN (<= 66 *)) + (* 72)) ((PALATINO 9) (PALATINO 12)) - ((PALATINO 8) + ((PALATINO (<= * 8)) (PALATINO 10)) - ((PALATINO 6) - (PALATINO 10)) - ((TITAN 6) + ((TITAN (<= * 9)) (TITAN 10)) - ((TITAN 9 (TITAN 10))) - ((LPT) - (AMTEX)))) + (LPT AMTEX))) + +(RPAQ? DISPLAYCHARCOERCIONS + '((GACHA TERMINAL) + (MODERN CLASSIC) + (TIMESROMAN CLASSIC) + (HELVETICA MODERN) + (TERMINAL MODERN) + (HIPPO CLASSIC) + (CYRILLIC CLASSIC) + (MATH CLASSIC) + (SIGMA MODERN) + (SYMBOL MODERN) + (TITAN CLASSIC) + (OPTIMA MODERN) + (BOLDPS CLASSIC) + (PCTERMINAL) + (TITANLEGAL CLASSIC))) + +(RPAQ? \DEFAULTCHARSET 0) + + + +(* ;; "") + + + + +(* ;; "Defunct coercions? Mapping for DOS filenames, Adobe equivalences") -(RPAQ? DISPLAYGLYPHCOERCIONS '(((GACHA) - (TERMINAL)) - ((MODERN) - (CLASSIC)) - ((TIMESROMAN) - (CLASSIC)) - ((HELVETICA) - (MODERN)) - ((TERMINAL) - (MODERN)))) (RPAQ? ADOBEDISPLAYFONTCOERCIONS '(((HELVETICABLACK 16) @@ -3883,13 +4548,6 @@ ((HELVETICA 24) (ADOBEHELVETICA 24)))) -(RPAQ? \DEFAULTCHARSET 0) - - - -(* ; "MAPPING FOR DOS FILENAMES ") - - (RPAQ? *DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) (HELVETICA . HV) @@ -3908,83 +4566,6 @@ (MATH . MA) (OLDENGLISH . OE) (SYMBOL . SY))) -(DEFINEQ - -(\FONTRESETCHARWIDTHS - [LAMBDA (CSINFO FIRSTCHAR LASTCHAR) (* AJB " 6-Dec-85 14:42") - (* ; - "sets the widths array from the offsets array") - (PROG ((mincharcode FIRSTCHAR) - (maxcharcode LASTCHAR) - (offsets (fetch (CHARSETINFO OFFSETS) of CSINFO)) - (widths (fetch (CHARSETINFO WIDTHS) of CSINFO)) - left right charoffset dummycharoffset dummycharwidth) - (SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode))) - (SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2)) - dummycharoffset)) - [for charcode from 0 to \MAXCHAR - do (COND - ((OR (ILESSP charcode mincharcode) - (IGREATERP charcode maxcharcode)) - (\FSETOFFSET offsets charcode dummycharoffset) - (\FSETWIDTH widths charcode dummycharwidth)) - (T (SETQ left (\FGETWIDTH offsets charcode)) - (SETQ right (\FGETWIDTH offsets (ADD1 charcode))) - (COND - ((EQ left right) - (\FSETOFFSET offsets charcode dummycharoffset) - (\FSETWIDTH widths charcode dummycharwidth)) - (T (\FSETWIDTH widths charcode (IDIFFERENCE right left] - (\FSETWIDTH widths (ADD1 \MAXCHAR) - dummycharwidth) - (\FSETOFFSET offsets (ADD1 \MAXCHAR) - dummycharoffset]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DISPLAYCHARSETFNS) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(RPAQ? DISPLAYFONTDIRECTORIES NIL) - - -(ADDTOVAR DISPLAYCHARSETFNS (STRIKE STRIKEFONT.FILEP STRIKEFONT.GETCHARSET)) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT DISPLAYFONT) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ MAXCODE 255) - -(RPAQQ DUMMYINDEX 256) - - -(CONSTANTS (MAXCODE 255) - (DUMMYINDEX 256)) -) -) -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE) - (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) - of (\INSURECHARSETINFO (\CHARSET CHARCODE) - FONT)) - (\CHAR8CODE CHARCODE)))) - -(PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO) - (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2) - CSINFO))) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) - -(PUTPROPS FONT FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) @@ -3994,41 +4575,43 @@ (ADDTOVAR LAMA FONTCOPY) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (11262 20708 (CHARWIDTH 11272 . 12057) (CHARWIDTHY 12059 . 13532) (STRINGWIDTH 13534 . -14627) (\CHARWIDTH.DISPLAY 14629 . 15042) (\STRINGWIDTH.DISPLAY 15044 . 15468) (\STRINGWIDTH.GENERIC -15470 . 20706)) (20709 27229 (DEFAULTFONT 20719 . 22004) (FONTCLASS 22006 . 24168) (FONTCLASSUNPARSE -24170 . 25069) (FONTCLASSCOMPONENT 25071 . 25659) (SETFONTCLASSCOMPONENT 25661 . 26103) ( -GETFONTCLASSCOMPONENT 26105 . 27227)) (28959 53120 (FONTCREATE 28969 . 31552) (FONTCREATE1 31554 . -33547) (FONTCREATE.SLUGFD 33549 . 35165) (\FONT.CHECKARGS 35167 . 41194) (\FONT.CHECKARGS1 41196 . -45719) (\FONTCREATE1.NOFN 45721 . 45935) (FONTFILEP 45937 . 46716) (\READCHARSET 46718 . 50970) ( -\COERCEFONTSPEC 50972 . 53118)) (53121 54300 (\COERCEFONTDESC 53131 . 54298)) (54951 60242 ( -COMPLETE.FONT 54961 . 56942) (COMPLETEFONTP 56944 . 57459) (COMPLETE.CHARSET 57461 . 59628) ( -PRUNEFONTSLUGS 59630 . 60240)) (60281 67749 (FONTASCENT 60291 . 60675) (FONTDESCENT 60677 . 61162) ( -FONTHEIGHT 61164 . 61566) (FONTPROP 61568 . 67026) (\AVGCHARWIDTH 67028 . 67747)) (67796 68445 ( -EDITCHAR 67806 . 68443)) (68491 80057 (GETCHARBITMAP 68501 . 69323) (PUTCHARBITMAP 69325 . 71402) ( -\GETCHARBITMAP.CSINFO 71404 . 73311) (\PUTCHARBITMAP.CSINFO 73313 . 80055)) (80058 93233 ( -MOVECHARBITMAP 80068 . 81962) (MOVEFONTCHARS 81964 . 87336) (\MOVEFONTCHAR 87338 . 90845) ( -SLUGCHARP.DISPLAY 90847 . 91745) (\GETCHARINFO 91747 . 93231)) (94162 113415 (FONTFILES 94172 . 95641) - (\FINDFONTFILE 95643 . 97360) (\FONTFILENAMES 97362 . 98236) (\FONTFILENAME 98238 . 102221) ( -\FONTFILENAME.OLD 102223 . 105172) (\FONTFILENAME.NEW 105174 . 107431) (\FONTINFOFROMFILENAME 107433 - . 111134) (\FONTINFOFROMFILENAME.OLD 111136 . 113413)) (113682 148361 (FONTCOPY 113692 . 118755) ( -FONTP 118757 . 119056) (FONTUNPARSE 119058 . 121622) (SETFONTDESCRIPTOR 121624 . 122870) ( -\STREAMCHARWIDTH 122872 . 127036) (\UNITWIDTHSVECTOR 127038 . 127401) (\COERCECHARSET 127403 . 128857) - (\BUILDSLUGCSINFO 128859 . 131615) (\FONTSYMBOL 131617 . 132267) (\DEVICESYMBOL 132269 . 133138) ( -\FONTFACE 133140 . 140330) (\FONTFACE.COLOR 140332 . 147252) (SETFONTCHARENCODING 147254 . 148359)) ( -148362 163750 (FONTSAVAILABLE 148372 . 150317) (FONTEXISTS? 150319 . 154810) (\FONTSAVAILABLE.INCORE -154812 . 156360) (\SEARCHFONTFILES 156362 . 159390) (FLUSHFONTSINCORE 159392 . 160540) (MATCHFONTFACE -160542 . 161357) (FINDFONTFILES 161359 . 163748)) (163843 172559 (\CREATEDISPLAYFONT 163853 . 165449) -(\CREATECHARSET.DISPLAY 165451 . 171385) (\FONTEXISTS?.DISPLAY 171387 . 172557)) (172560 185761 ( -STRIKEFONT.FILEP 172570 . 173458) (STRIKEFONT.GETCHARSET 173460 . 178295) (WRITESTRIKEFONTFILE 178297 - . 182301) (STRIKECSINFO 182303 . 185759)) (185792 197502 (MAKEBOLD.CHARSET 185802 . 187633) ( -MAKEBOLD.CHAR 187635 . 188965) (MAKEITALIC.CHARSET 188967 . 190804) (MAKEITALIC.CHAR 190806 . 192839) -(\SFMAKEBOLD 192841 . 194847) (\SFMAKEITALIC 194849 . 197500)) (197503 201208 (\SFMAKEROTATEDFONT -197513 . 198914) (\SFROTATECSINFO 198916 . 199553) (\SFROTATEFONTCHARACTERS 199555 . 199935) ( -\SFROTATECSINFOOFFSETS 199937 . 201206)) (201209 202590 (\SFMAKECOLOR 201219 . 202588)) (202591 204658 - (FONTDESCRIPTOR.DEFPRINT 202601 . 204180) (FONTCLASS.DEFPRINT 204182 . 204656)) (225140 227684 ( -\CREATEKERNELEMENT 225150 . 225508) (\FSETLEFTKERN 225510 . 226001) (\FGETLEFTKERN 226003 . 227682)) ( -227685 234183 (\CREATEFONT 227695 . 228604) (\CREATECHARSET 228606 . 231242) (\INSTALLCHARSETINFO -231244 . 233270) (\INSTALLCHARSETINFO.CHARENCODING 233272 . 234181)) (236577 238329 ( -\FONTRESETCHARWIDTHS 236587 . 238327))))) + (FILEMAP (NIL (11678 21391 (CHARWIDTH 11688 . 12473) (CHARWIDTHY 12475 . 13992) (STRINGWIDTH 13994 . +15087) (\CHARWIDTH.DISPLAY 15089 . 15502) (\STRINGWIDTH.DISPLAY 15504 . 15928) (\STRINGWIDTH.GENERIC +15930 . 21389)) (21392 27912 (DEFAULTFONT 21402 . 22687) (FONTCLASS 22689 . 24851) (FONTCLASSUNPARSE +24853 . 25752) (FONTCLASSCOMPONENT 25754 . 26342) (SETFONTCLASSCOMPONENT 26344 . 26786) ( +GETFONTCLASSCOMPONENT 26788 . 27910)) (29510 53778 (FONTCREATE 29520 . 32765) (FONTCREATE1 32767 . +35269) (FONTCREATE.SLUGFD 35271 . 36753) (\FONT.CHECKARGS 36755 . 43345) (\FONT.CHECKARGS1 43347 . +47870) (\FONTCREATE1.NOFN 47872 . 48086) (FONTFILEP 48088 . 48976) (\READCHARSET 48978 . 53776)) ( +53779 60696 (\FONT.CHECKARGS 53789 . 60379) (\CHARSET.CHECK 60381 . 60694)) (60697 63603 ( +COERCEFONTSPEC 60707 . 63601)) (65673 66463 (MAKEFONTSPEC 65683 . 66461)) (66464 73129 (COMPLETE.FONT +66474 . 68888) (COMPLETEFONTP 68890 . 69513) (COMPLETE.CHARSET 69515 . 72200) (PRUNESLUGCSINFOS 72202 + . 73127)) (73168 81089 (FONTASCENT 73178 . 73562) (FONTDESCENT 73564 . 74049) (FONTHEIGHT 74051 . +74453) (FONTPROP 74455 . 80366) (\AVGCHARWIDTH 80368 . 81087)) (81746 82654 (FONTDEVICEPROP 81756 . +82652)) (82700 83554 (EDITCHAR 82710 . 83552)) (83600 95790 (GETCHARBITMAP 83610 . 84734) ( +PUTCHARBITMAP 84736 . 86894) (\GETCHARBITMAP.CSINFO 86896 . 88912) (\PUTCHARBITMAP.CSINFO 88914 . +95788)) (95791 116172 (MOVECHARBITMAP 95801 . 97695) (MOVEFONTCHARS 97697 . 101657) (\MOVEFONTCHAR +101659 . 106403) (\MOVEFONTCHARS.SOURCEDATA 106405 . 112510) (\MAKESLUGCHAR 112512 . 115047) ( +SLUGCHARP.DISPLAY 115049 . 116170)) (117106 137123 (FONTFILES 117116 . 118949) (\FINDFONTFILE 118951 + . 120668) (\FONTFILENAMES 120670 . 121544) (\FONTFILENAME 121546 . 125529) (\FONTFILENAME.OLD 125531 + . 128480) (\FONTFILENAME.NEW 128482 . 130739) (FONTSPECFROMFILENAME 130741 . 134842) ( +\FONTINFOFROMFILENAME.OLD 134844 . 137121)) (137390 172537 (FONTCOPY 137400 . 142463) (FONTP 142465 . +142764) (FONTUNPARSE 142766 . 144485) (SETFONTDESCRIPTOR 144487 . 145951) (\STREAMCHARWIDTH 145953 . +150117) (\COERCECHARSET 150119 . 152058) (\BUILDSLUGCSINFO 152060 . 155683) (\FONTSYMBOL 155685 . +156335) (\DEVICESYMBOL 156337 . 157206) (\FONTFACE 157208 . 164398) (\FONTFACE.COLOR 164400 . 171320) +(SETFONTCHARENCODING 171322 . 172535)) (172538 191523 (FONTSAVAILABLE 172548 . 177294) (FONTEXISTS? +177296 . 181153) (\SEARCHFONTFILES 181155 . 184240) (FLUSHFONTSINCORE 184242 . 186079) (FINDFONTFILES +186081 . 189295) (SORTFONTSPECS 189297 . 191521)) (191524 194947 (MATCHFONTFACE 191534 . 192349) ( +MAKEFONTFACE 192351 . 193191) (FONTFACETOATOM 193193 . 194945)) (195175 195667 (\UNITWIDTHSVECTOR +195185 . 195665)) (211267 213334 (FONTDESCRIPTOR.DEFPRINT 211277 . 212856) (FONTCLASS.DEFPRINT 212858 + . 213332)) (217163 219845 (\CREATEKERNELEMENT 217173 . 217531) (\FSETLEFTKERN 217533 . 218024) ( +\FGETLEFTKERN 218026 . 219843)) (219846 229268 (\CREATEFONT 219856 . 221187) (\CREATECHARSET 221189 . +225019) (\INSTALLCHARSETINFO 225021 . 228355) (\INSTALLCHARSETINFO.CHARENCODING 228357 . 229266)) ( +229590 230954 (\FONTRESETCHARWIDTHS 229600 . 230952)) (231584 241498 (\CREATEDISPLAYFONT 231594 . +233443) (\CREATECHARSET.DISPLAY 233445 . 239021) (\FONTEXISTS?.DISPLAY 239023 . 241496)) (241499 +256364 (STRIKEFONT.FILEP 241509 . 242397) (STRIKEFONT.GETCHARSET 242399 . 247991) (WRITESTRIKEFONTFILE + 247993 . 252904) (STRIKECSINFO 252906 . 256362)) (256395 272712 (MAKEBOLD.CHARSET 256405 . 260054) ( +MAKEBOLD.CHAR 260056 . 261808) (MAKEITALIC.CHARSET 261810 . 265483) (MAKEITALIC.CHAR 265485 . 267831) +(\SFMAKEBOLD 267833 . 270057) (\SFMAKEITALIC 270059 . 272710)) (272713 276862 (\SFMAKEROTATEDFONT +272723 . 274124) (\SFROTATECSINFO 274126 . 274763) (\SFROTATEFONTCHARACTERS 274765 . 275145) ( +\SFROTATECSINFOOFFSETS 275147 . 276860)) (276863 278244 (\SFMAKECOLOR 276873 . 278242))))) STOP diff --git a/sources/FONT.LCOM b/sources/FONT.LCOM index 30747eeb5fe7414ba457eae5c397afa710888970..88e8a0e44ea33ba054c6a9e1ea091f347c7d2a41 100644 GIT binary patch literal 68727 zcmeFa3vgW5c_!H107(#%pauv*6huK+5KVy$iJ-dy5TqTeZ=)OR2D-1Se`3dr%zek)-N5-rIOjy%s>6mhKLZXhnx2eFH<*!BjFcxi2weoq2T0IyjuR^M_J}eUpyWGm!D%_^JEOS|{eL<PvJniNdZ1W$$dJp3JR=z+T7_oDiYzDK}Y-cAO zGX>>jNV3GkXXcL6>K^3PrD1aadG8sI5#zbHkexa-k_0?b(ca;73VVFw5IXFCk4S>- z<4AAb8Od`iw5;RSF~S10HW&{2L|?9|j}NGP`GzVr?4%}!Q}n6Acna|U?jWh=(_gVS zXHO2NEv&EET<;`Cf)1fsRjYvQWhaf#QBQOBnArnLqSel(CR4ps)P19uar%hLR0Fcc zC#Lc#n#bV+A<6=M&|H@BGp8S$J9G9^*4!_iJ#(D*-$C9IYJu#+FaZ`dpG?VfGrgo! znL}wwAD?hA%l3nZ+zo(lq^8H6iAk%+8K2DLGDlJX815ppGZps*=b|=IrriYkbOh<(=T=_R5@D$9#oUsv1Pjc`)VGu;`V(M@fW8&3DW9R_HA_ zQ-CkvQX4r~XI>@Lv-HEbMkM%_0+Ok5!o9STscb5Tm7!@diwFR)@ihJ#(He|I7l%%(cP?8#vJ5zXGGxwcjP=D`mGl|@lRlHK6Th)_$QR$ zo3pwzNiCo|dlY;oPg|eF6r5dH#%vx3$vX{bCEE8mgQuNLGG^^*-h+DkXaM_C)03%u zA>-r=dzjjcrFPSj6H$}0^^0P5{KcBDGqW_0RPs>PN!VF#vVM!#sZVujGxMYjJ0Q%| z?Q#CA36-KFgg+)S<5*HAj43-uyF_T}F~N?!ZBmogvBXp+oAl6@A_0Y&T*Ap(#{_HW zH(qFaSi?G=dWW4XzM|DZG_4i((BWDwFH;TP4XeZw}0 zAB~$C0~tPl6V(NqHyaCBr<`?c3J}9{T>!$u8u&h3CzBSnwoynSZ9N8BkEQdtI87(8*PV%^h9j5ZFqkX0^eb`X1D=LtUe4DiKXH zE?4DU27tGnx5B*u?{W0QV0zso1+5xNcFbj0*xoqOkSE zR>_l+Zz#cKFu})-xKbV1H%kja{5eQZAOh58!4(SB%&Bs;&Q+7Cc_Kv;6o%BPde|hG z3Fq8P{T^4eliGtot0&4jJdv49d1a}nDk*yoWAT_Pt2?o9_R-^yS&tlF0t=%VNC-GsC_DMiNF+7}1qLe)w7P@qGqJNt|3@Iq6PSYv%F(#KZbs8HR#Kc$$gCnz=jdYJk(d$bP#T1`94jFP@z1@X1S#if-!#`n#BDR#zXrBpHRGeBkx8&4u zZ%y^+0c6KwQa#qk)s5P*eq{G^GKz60+`cuVbNvzI4-QE6e)+mleQ?m)BYFFIm_6fm z)&})=tOFR1`x2?jl!@Win!Q5Oxk>CUnV3Cj1g%H{RDyWUj!#;^N~vkA30@5Vsjx~Ic3g^z8Bt75#R_^#?kC8OUqyd_!N1$dsb^Ot}$M;%x z@ie5oxsQE(;S47YfpFCtwBvbp6sa%E%xhd5J5{@%gTc8=DC8=7bCT0r5 z>1=|Ec<+vrduTxq2}E*+UaU0 zd}*>T_NYl0F_oCieNd?E0W+l0lmYl)BS_%zn(4LD4Z`a(nFo$!LIi!6zT~quf0TY{2I!TgN|L|$Tg|i)MIJer9BS^#T0Npywfa~{Ache= z3cR#65D3MKn}SbQ7UNf+iQ_d8sI-1$lU@8ndMtmiV#nXUFtgq@`qt(3z*=`^GbPjO zXr`GSTN|44PRnH{+#aYn;kNZaeEHhnT)q?tf0S|;Zlb@_YxmpSa{TRAj;(j)q^YcG zD)&|{d*i00V6Xi2UrfiBLt`!BKu;t#P{kW!Hx9^5F#ByC7-Wqe2tD{rYp}1TI2r&# zC4|-sNeT9e$o{Csyr}~$7#SQOZjkCmqW#>kC#_fq`YdN^5~@L~|3GzKbg(J~P4D(r zWyZSUvaG+`vi!pPU6!U|%v$R!t}ZS57Dg8Njax#&%qSi?E zkmYVH6y0r&SYUQAC^0+k!5;g=#$ceaHQwNDskogu7ao3kxVW(KWMz`)-d^v*_Uf=@ zA-WcA-Vrm{RGIa_CF^F|M&Ym7zDFQZw}BYz?eu(T!=M$39jIR41N+V89fE-dLYLl#`|CGD&HKb=+Kxj* zmOGo{*pP$95)T~E>l%smRqZz`64`Io#LAmiwfzGwAk@H7EaIzJ)i7`5I;K8vLlf?0 ziM&sBk1*{oY$8m%-nV|U{dQ|8h?U7O8oXOCPUfwQEKh4gZJ9 z0hv|L4-D0`jXbO*-7}z83&t+=Miul%sCS?TvMSWa+k$~W1Nzt+4A|-Qn-l3vwg4Ws zFgB>!s5Vx=ZepN&|*c*C?x$RwU99^QMn_ZG$i>F`o~vGwFF`9Ek{56pJF z7T7Yoy^{Zf&}$9W;>P^OY-c6sY`?mC#_4><>Bxb~e-=MKo()%=7N^|_zrC^gLHwO< zuK=An?YsmZ&?pV>PP?GB)`qaN!|A&0SXc+g!a~fpfqB4MJ~{jarwvccLcB5CQpqh{ zd8qVTPD_|^+&5OP9a?Pt*v*OZ89|uab?XXY&bCvF?LcnbZ@rS>F}=3w^RL?Zw=s~} z4)kg}_v${ULt$DZINO~L1su0Joz9NSP8YS(g?{CwC+JAL^?^30v-nylytwgg?#!nz zHOyL-sx%Cx8$){Z+7+jBxshAFGTT*E>NBr}KEIsYnB9qzPS@3^Rsz4~?0nYgb}UTk z=jivxvpe2)+Gsj=yp6e`>1?Z-&bGIlHa(rUIlG*m%g!F^_8ywfFcxYD=JToHQkR3t zmSH5mil^?4Z#g^i8&5ecPb^+};}yqRx-x66T>B?E+5kX{{vBY&z(RfC0}vPNnSG?F z+n1lpB~lYsY`>6f+MOerX}~tTN_0WqvN3EOouKsVQDEV!_M^buRY?&L55YCq6a6*W zF^~@k8sj8!0NeEsf(-jmpcO^ms*|v{4LTBy%4YNMCKx;+Sw<3AzU$&O#xPf}5ZMoy zB(Qn_2KvfFM>pY2c+3qUF<=%L4PZ@&@@^meh2Q}-u`fZI{rn-ACK;R2z@*b7S^E$r zLbC(i@o*}Y#5fBu-AO#t>-NcX<|01S&j3%-yaI z^K*G`YdFA9lbs8v1Nd*Mv$dfi!&|wHt8JWXNVf$~gev^T8Mjlxiv5+3&~MykX(r4s znEiM{W}hSxFdGDMGV72+u*&s(XRIN$I&8Wa7%&%vAqcAy=^HeYtphRN>yWRKg&k`^ zp*08?RI3ek!2lw2MlDDuW+m{=+Ed&#eA_5|IxwbU@Danpg0!d$(AD zxgpIEMJ<^Xz`8QqDiTKCRakf4$5_EXYXSGsT57guc!KXP#@m}KnP4V#9->Rb(uLya zp9Ho@Lh-AZeqNnzFRV-kz#PRrQt=VCHU|c z^RcF9oR(s6^|lJbLEN72>|{(0G8S}NLJh&r*^Y{{eQm4LG2c1c`5C8U7syAbVeO*R z*#_KNgtXgKnNASZYFleeha0}*w1Mi)|1+m8h+n5Igse3B=(I}*OINTlF|#I&0K3RU zg75XxG0pw^^_*kJ{&Hi3yEcS>@BL+3hzQ#1h7-ZuN8vlczH=v+k3asn_4s3RCl?-B zIH{auyw%W_c)chw%h=?CK(Q)n3mPy=Y~jhq02m0Nm(B7E&LF-X;w=(iZ&bgV`4^Lk z{~+(E8cn6Uiov77F)5AQmojTx((|21KAqlm9&`HFqisC-*hM6*1F@&_$*8qoI-&aw zGCN5kohnPbH<0gfhK$hEu1Ud_&T=2cqfEAo`XmdOQ+ z#nC$|AzEuNzfdtd!yvqV@Q=V&VJx0j=rB$J^7FC=O|%8X2lqL6Ne-wv9+KCiiS_r%|BVqhKz9~rx&vPOFKso4U#_Ul5Gw5yQuDk@*j(DC z_sMx%G-{#gqA1_M7k-Vg2vl~hQr_Le^d!jpY3WkscxQ3$%XdTHW4-XyaRowA- zIE>Bv1*O2!DSaRIIk!;=r_L2Emg)$_>Q*^~1ydAQB$VT?fi4!1pN z2$TViOYYv%wY*ARW=%cxnLVuW5%n>z8npGPiIF4>)ZV95A4#=s4!u4ie7B)nu(QzT zZZrkWXXeA(*)<-xDx;lHN8B$ zaM|)kaf9h~Cx)k49QCVwytRQu85k|sexmG%VqR1>7Q=FgWs~-*eZ)-*5R5k3P@1${ zE0E?X1yg7$2b>~)1CR_1PKJ0_7NMY`CFcmpDx{?)uRD^-j-1fspzAwjEANFrvbzeaL}=8aa*Lq;fN4G!V-2vRY2XwICed=f~3 z7n!F?38HNE(eoq>lsK|OQRMm(s(ccmLcu`D{^kTEpjJy{%=kQG{Lu7TRBS`%4$JTK zxqSRQ^XY51WP|b({r?&#op(IiE3ZXP}6nS>#dkgeXO@_T?mLn7n|CRWDx4zALCN3-S%=#vW?UI$!weSaXj2Htx!&-2~IB<2l5QK(Y1A>tGh5N?Y0 z>rIv7;_F-Ksku@de*LBjL#*P$p=d5<+S@B_!ico*s0bbZk38|Dhc0Gbzq8V|99q71 zWr3ku65G2fZLN_8S)lW&7qyl;_15J~dms%B-O`oCix>X=<&H``6pV*LJatL_dm``^ z(Y8KQi7#xFXW|Xzc)X};{&r|O2=#=$wkaJVRYPKJb2@~l#>z0Hq7Xf9t|Zr*=n>CN zmHC%Sw=1;tR3-lFNo`TRCAm7vommNdRyJ6O+WmoAj7Dl(zig)F)yt)u_yf19a)A>~ zrI(Vd9DcfzghA>VhKy&E{8PFw$={HVo@gq*$jQZqZx)}N?+mUrNwE`6@fYGW9Z$#6 z!dI18&680Pba5hJ!vOiE#jC3wiY@)2aFtRhA=CPU#C($RjZDYliOr?kW7ZcJhp&EZ zSW0|nm^)BOmj`S;(v9-&gnHimlk#1|@_gy0jTe)8kQ-m0eEucp=M(h5*8Y~zC zR}7ym7+cA~i~dFjTpMasN!CWI5g_fVZ)+CbECoTJx)hA_)k*l0W}xdB_>}kuU5NN1 zVdPc}Q`Vg^^&*ci{FAwED+Uv=KmC#8k1i~K3RJTSM|h+&YBCmVEF(VvDE8Rfd<3>g ztex=p-U@?lZP*+RLJr($X${{RUu_p6*~Z{5z-zBHmG+(pl>QrSneW*}PJON-*7nlv z{Q8W%eI6!WhWr_Y1HQ2mI#to)`g;;9FJ{JgleuCg_!r2g&yjj6qlC&MNcg;N^+i#h zGE!khfNZ_5@jz56Q~{Yf$o|bY(`C;q~ntprybpQ+R=Y*f^-|6SnP?+yryBT1fZE$y5ngK@6&pC zhCrXzsuowEPwPRrGCmZKap)y8vz)}RkY(zu1D{m2>wLE~!lfcpX@w7=Ff zWk1mGVVFvs!`6PKe=xA&piiqYsMWzNbPoD73WJJq6@hdRRtBZ>8ZuR31K@u=LDL%0 zOTY~dU{o5Z4uIJ3Y)B65SH})b!Eqc?eJZKNU0SMspBAQHVQ=Y0zYe?@%?&!{qW%2X2}_SIBmU*%$LeYw~zGHFqt zxreM0zH;CJ4B#PKthW-8DleJ{W>OC%qTtp5>xQd~Q|bI^ z^JAK65G10Gn`_bHXBG6?0ub~V{fZPJ_!m-?LM*T;Djc_4d~P5Du?j$;G95dCCg9ZR zv)U4bbGPJLz3}MqkIwBo`>Ds~NP9?Y!iQqmW)eu$y~^-@0rRIPTdDRC=S6) zl4ThO1#WDkmVQ;)sB7)bWbLjVfLOR`cx2V4@siP+O6?iWrtJLGI9c;^uyB*Fl2SvB zSVK~T4`8|Zz}9ro2s~upjeCp|H5PPeYCf@LQy_S_ML4i?5%t9UO6xr#hN8n_)8@1z z&;}e1cb*Ja(hX~k^Wot6)^G#!D~CIjG5l~ltl^up40WzGe5@__R3;c6<%(UIC}%9mj~Hm4j(W7q+>pzB&10+YnZbHDF+%d9RuV4>$|?DukXI`!G68V&Ij?~ zz3O*Q5r4TV{}do010oqvX!B!f0etM|LRjGXyIwXQp*zZ_I?u7|WNIhWH z=*8h63EW_A2gWR5ByTuSR1*#t9|IWq)%S1)40kpGbMzk`6l8Jr*4Dl@jT8>|GfXNp z0-v&mwVSq$t^Lom@&7|`wny|jBKLWCWvKJyP^C58A^7A&8lQX^_~Z_!*N0FVoxN?r zZ>$7A`Ew6A_a{QUl>e<8n!Pz~PF-T~fJ_{c~ zk!xDG#M-?O(pp4FQvzm-Az-#Zz&t#-xbYpXT-xdEDIQL6#b>0we|h*Izdp?cKJDze z1K--NzSXIPEA_4Wob4nKLglRm!WO?kh>o-e#j%KokH%DIA%pQ3oE>Ul3uAB>lp*bO zx_v{s&*>)j!kzexr7}86sFN4CDB?3+SW5gqME~TE`m29J?2Ms1aCq?baAoDEy$Yc_ zyF#iRz;)m zaZ+;EfO>$~qB0{ekLX8`wwkRj%m`R;gMcV5(jy=ssu}|pfcyqXS`=##pR4bOoalQ8 zE9`rR$ARx1^(7Pwj0xx-M`eK=0JmMERZ{=?-q9`Jd*6YocSQ@L5T0mz<3QmgutC(C zh5~yh^k^|rWs}O!Y$!?wbK}EN$Ytg`G2z2FA?BSF2Yno>P4Z7dq-s*gV@;D_h)M>+ zGjWbZ{`O3QfumF>fCVw>7P##j`-0JNn;Q{cbL}6MQHH?5D){ zff6@BVIK-EZk+3SH$p6wz$B|=)X;<&Mzm_OO0-xQ8lw^tYxImVVp!<@(H8NKwupbU zMbuag{{Lx=nKeyyRcxbouS?sr--J@}2Lg{IBMM)R`UcsqjP=W??aoJ{-)4UY+eO zdVT*AYzC#ChVs3wVIEw?>E=-wMV>+tI242PBbJpK*lFaVf$eSs7%iB?It^^626lo| zmIikD8|ZW!!0;>1t~w2LQUkllw|R#&v8OWI<8Nh;+sYnlrKe6Sd#IHjHk3Fm8|B+@ z$R@n;6&$Z=`^hsn{L{X%x)Xox478lpk8^{P;+8>s zoE6iB$@I%*V!FYYE=(F)E*u?#0htX9a72_8uyT?DmXcE<;H@|%0_%aKKs&-IN?i+f z3rYr&={*(~ECbqN4n|o3485wbzwYiOZfpQ!>VXQ4HtqmqUH#mT@4L@1Ot{ZR8B&$& z^qA33%qSDxzh9SW27ZX@7mHNDx-$7|sAu#EiW?eR0iz%;$;Cg)KaYLV1mn;_eZ(CY zfeKNvZRA`iL4~GHee%rl$E@RS76J%6U?yy;RD&veG>dF=FKs6oliT${bej8tioJj<#RUC*=X z45cMUb ze|}WlzK&ML;-hJ{E>=dD-Z)ZveVZ5#m;MB*FL5;zPq0ClD*RDPEr_DJv!IR~GKdb- z)Eph-aqtS89>xGi9T~s?4U(D+K})%g83kY$VCW$JU4NbCY1|;q^iFj7z7Wx6p0g7H znv_s5lYVD)TU?#={rY@3v-HMH=|3%iSo`}{y;OR9dbI>OKryK^M5D^s0lWdnb)_!+ zYtYEXVNn)zCEmImZ->v4S}Yt}Ebpr%{&M-+Unl;u^)p-1xAG&SYjU46s4axGdNLl?fOMpM z*QmDxe_uHj&~fs4I0!O~{b@CX)$uC@t~R>My(3UokrVy>5)^3#2qYAYUuwD@7*i{> zhbU_ByEn7-M$M>rjrCi()$0sT$0a(#?cZ3~^z~MOw=j`i-7uXU!K+#XHsJU*r$`#A z(b0lMKE5TS5hYNgI9YCdsZvB=+?P0}iZSTM7vq<hKl1{!)I0kzbUSSs(iWK$bO8nyt-ei#4p|C z^(f#qnnt5L)@-;n3UUb@7G3DGqPr~Jt&_uyG(?U1c?Fpv@+i%;@5tyb+=YST)EGL# z*b*O&uLs0o)%)a~aK>J5e|Ei{%ScsjT(ts+!}a!Wto-!V^>%LrU*$?jU0rW?r|3mh z^7oJy3aT!bd7(ml7FqX#&4>uU)L+UzTNBlhlwa+yW(WkC`WmC zl_vsY8Uq{452R%jJ`@LX_yLwW&Z*iT1K@Y59mJu9QW8M>cHvQYRdU=f#+$ku zQETVU;mK*JVt4LLC8pjDb zHTrzlG^tv?gMWFP{KSo*8GcdD1*G!M9D><7B_c=!PN6t~gO!m(NXp5{-3vHcO*5j1 z5bV_INgW2$OGU?Z)v75+T(xq>8pbS^HL!$qs)3~t1MtipXq<4;0t#i*JVO)_iG^5E z3JZ47jjc~NSZ~l5yhTbKFs^7($51DB|xY zevy!DUN#;6TE?NTR)D^tN`~_zBBj=(+0_FSibN^oN>X!Tir30NoqE79h$F@#=2CB1 z_;^c#n%vqMfx#aRfb6L@F*VM22?4gtV0ao6Y_DtZ8;u!btV46ve_JPD>fqFnL~)E2?|`nM8}HPj|4 zrvn%KCPMvQRZT1u{b(*OB2MGK&A8} zUX;WbI-1B%TA(u0WwpP7!sOlM0YH_^c>&^+0^q-V89*UsIiNK2)%PaT*S1#zuQUJXkcv+=1KJ-kE zW^ipwmVRDU$(v`z=i^c%bQSZnZDf8>DVt_@RU`})GTYTt!|e9qwTATU4(OzJyg7@A zPsKELP{FO!M%Xd--=xcjXZZFF1rLR%$n@d+p{Z41*>bIR8>8s@kQm@m|UR3Qx)n2os z2^t8r_V^NpkD2L1sXmnIL#cLWyNt(aJC|<_--#7)+FuV;a%(mw$=QiVr=z?L^RzhI zUzv?ooPHP^@6(R3fPYxH3t0ep<3P~R9_C>wU%#=3vc$YaAcR7j){ zbRLv1g7xxYI7FiuG9UozJXszIKNx{Oy1Xky>_Uj-D;Yp#0`(GYQg1Na7;lP~)c8D7 z#m)g%jKY5LTrqEcou*z<*ZE)6lhgVygMy_tq32Zy z(v{#-!oa*nnyS@3va^Nffkg+$(8;b-c}WN=4*I|S*5x!-Iu3d$pKj|29fNf~n@MNm z*vpdG-VqY(556DAc9ztRjt~M%Vh=l=020G^VK@RUSliz_$9wacZ`jmoq6Q`cJnBF zJ9|||C&;;aarTmL=iZ>4isoH(2fp2}KGok5QrzWDvx7i_HSbNCgfal}e+p-y{!XpuOd>QNeuzqb=)#yvY?}Qr5S!PA0f-sY+xbHzFPGL%fj6*4868!;KfW{{xnG}TvlUgS0$^e)l)`S{b zS}6oIhgpf#wZ3tHdymQ4NcB!<(exv5wC-RO zLYrcGB8Zk=HFp$h-Ru>eAoIQB>$H+M1LH3UMI9f^R9{5D)DsrN%y3Vh_|!PpCm@=% zy2lL-(y9?Rkaq9|?8#8;W1Hg*Ywh-h_)DX#2w43jXq#Pn3}>6-!P4I;KcFMQwOb6b zItmq+|GhS$PD)jh7)uyGUPz0o=DW&(KK+$+ag=e!mn!qqPo&F3qiG}R{=Idg?r$YW zoXcR*fn?j-E~Y_WO81OP=y0(#u6Hd;n-8N*{vw$C^NiRso%|!F{!7iix0}@4dZ75l z4A^@8+T?$2^t}o)ym`~+b7AE(f3r9RnN6>6KDSjJYM12n{06-7^?yJ_6t$qfxKDG4aaJ6=$yG$a3{XSDR=5WrS)&3hBy5IaEX3r( zFG}Ui&q{g1&x$XhXJ9AtO5%+WgZ9(hA!IXA`ztn3l?7bvD+&ziZDlA|%#9MmKGj=0 zN|p+`_qhNys2}%`XTQ6(t2S>GcuMQNq4S|n4>89RRZ4LK9a2#DYFq%*l~TT98C**X z_&1-egp_^apQBC)d#$qc(IUb6s8Sa^wGt>7%UzlD zVv)C`un40FKrRJd4}5`57QB-c>#!ckTviPRbSa(H=w>x~SxObvRK8mmYjTS{}pBHcrmVZXw4m1muFB8Y%ti)8T4?2|8{6Zo&dZAvT#n z8LiS;Mg2|*&~^LiBGD7GK3U~_?*LHWI|kx=uck2Qq?um@)1W_9U|Ow%#F!wIAm&J( zLLD3E-rVt;$CmM(ACU3UC`5@E;>CEVuR7wns_D|L03`EBBC2|i) zZpSWjJtBb?Kwaq-z$=E=<)biLqf+D*%XZCrMqn_`eqKqTRzyrU+?Qf#?#3!%0; zcsEGHQB`>5`Yu8KJG1pZMZhOnDLPEcE9K%ZoOM_9>OF-ToP<@a=}-&IJn6NjOfmF3 z!EmwR8!yj)Hu!Qn^iuXCWDMBx0-QLrDbc)8;6eSoFv5gmt+Dh+(4TB&{YmLODNoLk zTQuzVm|i+i4)iMVs`RluLc)6D>6{*4M-7GoM@w-AT5j(0rfm=JbzcP!Y7y4Zy@{Ij zh_o~SVW!W}AZDt9D?W!2Z%Xojw`JPoA)8ULo@>YcB8`{fQ^x-EJh-XgH+5=V$(f7v%-Co|I&B7uV) zPzv4A0B7;QRWJsd#D;kSoDeU;#_F92*Y;v%x!Hc_S#`C>uiIh@MpVG$(@D6GJS*pc zOLxVruPisUwr)x?8`Jh1N!7@cmHG3DASWh5`d2*=yME+oF}S>EMz;&=1HX;dfjN2K|J}65$jt5q3o#PV*y_ALz#D;hafPR=2L_&(=F;v4Bv8q0!LETI}i7GBF4p3A%)$`2+~7vxYiSJ#fNdx zIS)C)e~9+AL>ERRVX#o$`-ZzA?hN7qztA;w;|JRC?hn&1Vy2wLFYpSIp}Fbq(*aN1 zxx&|fW{~7l?JfX<$l*l0Vx0sZ(Gd71K>+9f5DaSIEb0)7<@QPu;THu^pBA0hiAH{n zKftRF?n!cQ0LBSbM7uB!sRj|YUAL{^u8ZNRbi14WG$#mXC1Y0kHb8$cFwdzHzpza* zS=m_yb`-Oz4%pEuXn-OiFME)Jg&<}&j#v1=1o19ZImkjvzvc&+2n09}H;`Z|R|$i8 zA95dwTc=fou!S2?u>|n^!yl-wRDpX1mloO)dL_< zKmdn=3wY28G|q#ae{i#$LAmeP5-bc^N4SWYSoph{r=7N?H%kAj({?1gG`jRAFBUHi z|9NN>#)qua&g&EluTD7aYYhuWv!i2X(M`dJvqh2c1#di!AhuU7N;DkYZosu?TZ#f1 z#pMKIoN~d^?M^$s{?+B|hWI>xj+331o_ zSy<#2m;&Cig@9=`T<*#`;$qDOxGf%M%!2EKEt)_#lH@O~E^%!&cdc!>-Kt@2%Y0j~ z^bwrA6okiZ%)`n;UI`t=@0I&tMfr<`(w{ec2PZJM)14+AK{C$3R)P}nncy1bf9q^t z{dWtcf8%t*dQ^XG1JTF$i=&$Z-mL+B#ivV#9WddV-C;Z0qU z+D}fh9P_j{^}rNFKnkqJ)Qw|#vqCHeT5JU4<6x>WATfzC1V0lH+}xNA-%UJ{EX@}V zkix1kmC&Re=Y8-vj%$V~>Y3UWEU=Mw+V>6t+4qhvdkv8pQpJB|K}7Ak2zH?A18A#P z94K3FL3kvq5*VUt0@9LK7KQ>{cEFxp zGgG)86>dp<9Wkf^%<4p1$lZ1y@Pl0NLmUW#*>yhv76itE?tLdUfgp>8i5Qrp))H8K z^$I6E^R<`;IQXIwnTvSom9c?92a>pBY=qm^=Mg2FB4bN6c`*2aeNnWGv&u z8xLi3sy)p_Y*P>4Q@`bd!ugJk&M%0x@d9_?H=GuH^mq7~_a_R7E8hW5EA6kYXCe(> z4Ksu5(&jO?P?V%u0cCP*(2pK~N9gpZ6u_)2nDgxhfT9a&2-qTf2PDFPMTFK@pj{1% z%$IsFL6^8`_=pnh;TlI=xlCZA;R8@3Pys;E-~%F}vq41^&wB3&oiO0q4sc2=w;d`-mk0H{ZQ40Z`-n2kx&ga9MD)@Jd{VyXG>~3qD7o z;nUOCkgG+*FK!Ej0(0O7TQ_c9Iu883bewHN=k}$G%b^XhuFIk04PV9|Ue)_bx22au zAW`H;)(-Ehcgi!Bd4Z|fuu|-Xj_P1XjSuOk&BxT!rJEksX@S`mG}hYI=5!Yw>z(q? zZOb59@P8P^pEu{j>5U)Z3-Z~GXO^xUFMZi*Uk<%7+g|!YdgI$pH{^P6L0fbL-4$;E#1??VJXFsPm$=Gt*f+ zGo5;3N*~h|>nz5O+KM~eDJ|_+HJ_##E$vosG{3VgC9&Xbd=c~co0+E;j(i?-#Vk!F z1V11gVEgGSza{D2$0eQS{EgY}mA~IHmdk>($hf!g4e4m9Vs;y%D;&&->_b3`zJvh? zy)Neq3TVD5bDZk{Gz65ZZW_VCV^{mPADn}0uG-HQ1AP=|5U9>OCNv0^!aEp55e(#D z&;X2K>SWLW@HeZ|D2joc4MLZc!K0`DkN3>4k_K5pJ~H7Fm+9miX7`%=sZ2ITaC^_ z0i_ycz>z4uDrSh$Ed?hAc9!EO-kHrlYZ@3g&<@5psDh(^zoOz(H^jpdPZTu5Z3EhL z|F_&m^)+&Sq)x4;`B1kg+7-_)B1vah@cPdgCsRg7Kx3 zUKlM+@ub7NDvYv}!YnRqU2b2!o9rM2%3-(a-jif5(Q=IlxjZD;J^TZ8MJ;hJe4nc8 z{|gNNW@uyeH8^C4(xwODlvpB|#^7JV6%;h?m&kU&zm4j5Gk#ArZEO9Vt?`*6OC?-s ztrbVW`Bm&jlcLQyG$i=vHog6UxdQ-Rq>zx&*hw;M73Y z#S?+nzL3pG_<4K1Z~9B=^{~2uep>V}YYh*InK^JC6|R==%E;>zFUIwgEc=$l&t&31 zUf%vU#pUfA<)5p>FDyS1zxuuS@~{5Qh4iI+pIBVBMz20Mx*UH4uMgv*;`AttnODNa zzqR}6i#=-LYx}WSrMpd zkTMN{lyB9w&=hQ+X}gd{^g+H`i`M{VclVH*EE+k5DAP8VpyO|}it++*b=MCr-vG9$ zd}dO7Ivzx%WQVTXfp$*fLQy?n3>Qa`VjD6dZq9*M&TGm$2h6VRd0ZY>g*G zUinStjeea@{5>C+s1LYoMm-_qtqL?MD>6g(-AtGMv$`f~?QR7jxF^aMpP$x-O=H>1 zIXGM7+K!apNIaL2^wssuC{QXUKSFe>#ye2pA&C>Aa=;+Q4=QfnwZLDliV#iQKWYswjBB@yHO^Rb{y8W?lmI8-)IR2 zLUM-wlDc;F(pGh*KG3>)3y$`dyIE>fiQ92Y?tfIzjdIHOC422=)x^ywLW>)4Nco@a zP0UvX-eA0YcRKSXkY&+nq5GpUIGa)Aa4hr}H{G7Pb`3E@{T{h;0dA-&wGC~M3)xX6 zwgish5Ij^ykZzm~r~MuHpMOOhYH&gC=wXR~TF&~Kenkr8+NtqH?G@~7f2aI0JH5oZ zy;sqr{L;L=^rnbODz<9Aee;-mNBnLT_2kl>i_p}G!dK=)4ryJw6ZA=@#eV%}L`3~> zS*PQ&O$SXnaL}Y<<=RBf>Abv137tsjT)Flu6qOmw1f7(Qk@M=vkraiDh=O~=xvfIl z#y+8A_r5~|6x!40#tK8BM1umSXJ$m;2xGppQJ1g9ib3^CU}}J2toGGjTSki9uSGX-RecFZXsc3SbErzGam6I|rK*fxbCl7(%AR^eSFuTW1y`%TxM!^u^vMGyo*>-*q1tFLE@sYHE19;|Ek;p3;yTE|aW zh{W~yryf0VdYQCb!qC3QUiWgZ8I#JjTWdGP*KX%`74ulRjPDH#A_X4QW`6YvtgLs* z6lM{C%i2H+#svzc2tSrYyDSY@4uW+}O$z>^WnnQuPcWZz0LNflv7v+lnK@YPFhWcVVR<5bew5dU z3w%9&Va$BHsIDSfy-jXJ+xWqlbO(a?k8S+p_`-NVW z3{vcWtGIjumTj(IiWHY~8^2#%estse#pMagJLBfvR)o?YDa%@s|LIB^Opmax^-5=` zH11cEwo&>5Vqf!k+|tiU-paK;G7zBnNt~SLuB=?Us|Z5@lIFam=E};oO>reotAaD7 z56ak|<)0&^y}H2Hq$P3OJyL3yV&H7#;hD<9Q!77xNxgEvo|hUkD?j}Pm*K?c`0>KZ zPk+lS`l8u5G9UBS2d$pqH;GB%UV|Nudu6`Njm{i7y7JTgY5wUG*U zT(QFHOOeXkuam8Y_cPZYh35$K8UxT^Rw)m3%t2slSBuaqVL(`d7yau1WOzpU1K5{> zJd~Y-g7f(kM1h;hAJUc(;B}>gWloGdGtGB0;wwJ`a!JTDx@HTli=|wW11pOT1>^fD zv=p2Ug|KIlP*0#4@&wGVA7?4Fl6OD+uap*-?rLJy?I1>@^9LcUsQf{giy0%iv{5lRO48QKNa#sHMqut$1I<^kvlxbgsOq4c1>OXpAYBS@QmB%KUd zCn#EtJQyA6M@Mk)1AH|mPy+a0*FwLfFgj&^1O3uPVAxlWF`OLX(iBZx9U9CE^84d}E zlmavI9x^0Dc?L@|&g-EucZGBvsOGJFKEInyPCdrl>H_ZEqbZ6P*P}C3XJOOE?PIE& zY8*1*d*H!Yy|>>JS&VO?gMCb7PBhY4kz&JBE5Q#D9Rfv~7mD*e`GMBNz>qUvj=M&y zC*tC@u<`x0i|4uMO5pFxcZv38W3^p9)E4?0_kLT>0Y4lH&EJs^Uyw;0UAn@O!psjq`vai;l}hQq%1T^} zBU2j$#jO8w<^m-?dX4Ky+AFGAvM_ufZHs+@zM0)#$=9Zaa@#?QXA{!Fa-55-9;_|6 zSiib-j$vhcKAaB=RM4sA0dU)Xq63|F&YsTXrgEClkdturHI#{Qc=|yPz_u!~w{zkA z6h+TP4)z_)e5`@&$F}!p0KXUDrh8-zhjew_Oz^!fKA`Jc4SYdoUo>indWOm< zdg>-)RuwMBEHXBvQwkb~66(jL)Fez%p29D5KSN>y$?!{7I2&k}$`NZW#!~Xm0ulp$ zGH6f)R3(RsAg92CBzv*@4W0WTbV#=N`WQJv_agD9bjQ^%5FqG}#=6zWIs!>Y=T%p1 zwm{&uXAguVbO2`@MAuAwhZ{Cc<42J%-DIWmfZoXQ!ppLL&~D#>Xn8o{5NTi(0X?ng z4b^ekyF?MJ(x49Jr%{}e9figgQASBi3+YR#T1{mSKn06uNU=OnM>jBs_xd1 ze*45yu|*W@2klIj+_d>dC0Bzc-zP0QymaAMVU56&Z57DBDMuO~lASolF!?^RnT76S zN9Z&sn}vD~B@CBxx>QXWMCe*Imb$D!KCn5kc^tRLj`M_VoUD z_y*Rv8Ik`Feb_4}yMs@KaE7vPkj~4=Bh)r*jI4yMJs}MBSxx(3#XTrYO(X7I;eG=I z;rQ&TuU+6X_7ip^SvVEg>8%JwM)0@btK);Zm7CIRkZP$GH{xtNux}kQXp?2L+aJCJMQ&HV8J@bsyw)*-) z>5>x;m0n3hFRUwf7?nGCXwnm6f5@KA4nIi->U|W_1dj3o*?R3sMOaga^s?1Dey}G5 ze}YYUU(k8P+Nu!3^sa)1MnA%jUq6Be(~rtD$T$z;hf?oiUye}FKBL#9(XC2?t8dN6 z>+Z)Gf>7rjTu!Ans~S0Opa;T*YE&5ttCGQ$u;fye%*ty_gFl)40cdi(%@f5a@liUW zS*IB~l~6AkTHVQsDeNzD9PnWQJ~L6Xn~5``a;i6APU@f(IznL-Qsc(jaVm@~Y%c`^ zP^T1tqfV-_wfl%V`!MtX2|>w1QeQO!)NGCL1B9^%YupDU5N!SJruZ>UTZ~h7$Aa0= z%P)~%)63`i?*;w~&zp;Mf=)y_-d5^do!B&5@43loYglV`I)pR?J&H5iUT$YG$B`e# zI^uDT4Jk5{>{EmgX<6F}1NUrOX${W2EfgH>pJCIJy}Km@Jm84l8!pjXxJhmcZfE?_ z@{jpv{?&(YKTGLf1%;x$s>H%?r}M#$@?NEQ{Z1wy!s}h55RroX^%wI+r-Prq<#cpn zx938omq6j*!$P_yT;ahXicNL{#7?XRG_$5ZC`_oZs;Yx7GkAj^ihiTR3NXUBr*mLU z(}oaj$%7A|;Ufw6LJ4TygO1Z7 z3OeXWK&tzeA({#HUBAzekyfC15_hAreHAP}Q$7rdt0Jz41S&?`*h0{GfX4?WYC5%1oEsl16v+Y8r?~MHPu1&2zi( z{e2JI=qR|+O(r+`3nn+(r@7JlOm4JuG8y#P(VHih-Z`zF3vBDI6J~r&)d$jfy9^% z=_+TB3-<=umjFWig6gqoP;Nf5{PD-g`Ey>huZb=E_Lj^qVXAY;r_l zR7emFYg^@nVA#N?Gv(`?DLkLTbtU4WaH-*&V>oL%7JPXubTP}QGGn65V+v#bDPzpm zd$!~n);4V`{bBH7IS>R?o0sq@t9{}ww(*@f5b;L&9-GIr@f{l&Ik@p+0zV3aelb7V zc_9~isI&$)h}7SHTnV98BT{94twoy@&sZZ$xTesZ^Keas`^Stzn=lRN!$TC4P|i$5 zs68K!q$6Z5lH{XE1e>}HVL74U2AU+8BwT15;P4RVb%YKuIl!f);s7o+I*a0(;d2ou zK%3iF10q~|BX=k!AwZsd_>m7e%9%$nAB;=EoG~u-NnZvcMN|T8$U>BGWg!BxANUgR zLWr)BMASO|%ZNZ5n?6>F2W_E*I%%>3tEU|b{{7XpWAe0du0ZxrR1fkE2|rmIPU|y{ zU#(;WNGZg_UI+*RC+F_T=*RgD#j2lcSTLRdECV=PJf3zC;~4rSx_VT-fTj?Qq7Vsm z;gtIXDA1}Nid?Cm!N4h{76_1fLUlQzgF5_xHlYLZ$*i?(5(goqONxSqvn0?ws2){C z8*r#I+u)h!ru|T_o5os@3`Zv^C*kRorv*tj(1OS`t=%8Df3kKk9>he`6t^~n(l)4# zVqVT!87#!c_Z0VXu62~wU<2qus)xmQ6u`j;-}aF60iKlDsV{8eF6bUXiNw+WVN=54 z8jw%V(-t(9Z$Ic$UbfWPaZJXh_z#BHq{GlY*mx1kEk$R<%Wm!qVl*ayI1B(|)B;5W za2hFXpbbfaR0d1`8a*%lkNEc*G+^Y`G(Llg0}SY8G*(w@DS2jj3ww^JdLYE}ixr62 z0=Doo9K(+Se(ix*wI91Sky{GB^=USlK`|nHnis%d;9r^rKBLx0713?pTlK!ptn*n~ zP}+FsdPLn%k6S1~glf)eqQ4;smhvA@Uby_BI9XrH1Im`MEE04119A7X9&h4uyEe=( zPjCVpMC|W~PCiUhDM>~?rF;|tq1c2Pg=lJOxJiE_8KAws3~WrvAia(pvJqE1D3IyU z7uG0(RfHhL(k<@TpkrBlR}sWaLe}o#EQ(BtBcGnNlni|q^uHPeVA;x0fN!PjMQ0Iv zfNsTwmm)bDCg=ikrOCE%luKI#(FY(9F}#t|m=(V29F32$FptmF5w?8UDxQf@1_Hu@ z@AOTLtD@xACKJGt-7hczOdMb@vbT7hZ^tXWhpwnAxSsw9rHGm)b9o6)U3^E<|H25! zaJr&>1CFWMSCS&|*CygPVof6NtDZW^LJBpvg+Qbu6cE63xde*PzPMDBFvOcoUwA;` zsD?{@G=z&DT)76WHwr`YzBXni2s(13jfw0GHc-_@yz$1Q3fz~p`1HuLU@m^Xh4p3g zZKP z;hzG|AO&#krjXs9&c3TH0oEf+x5>$tfVv?;7hm(1z$bDR?{7Zmh&}0FO>(HJN&yk| zr_e@%epTe7A+(VqbwlvATbWq&ciVd-cC7lyE5mm85s!1YGlZ zrWMFEtJ^egyeeC0d+@5T4mm%Jr~|OanQH>S0`pZb2~d;UUkuE9p#j5oK;wmijE0L% zM5DzT@GyIR9(UB@)M*M)F>F4}tL`gt+e3&YxuK*dF*BL6#&M?!Nd3G0Vm@@W9&awe zDfGZEvtadF`>BNc5fEzCurIa0ZYnM%lur1{4mHk4)u< zCrRJ$cF~0cs(PbYGjv(*9Ozja$=Zi>e`Iz4=Y@X1c)w0lRtMt!^8qD!j}pNJCx?G*%b! z#^eEftbcd&b?}4NZ9+aKlJIig6Q(e1-DpW+STz!;k$@)5&8Wv%^UF9vFomwHe<{lw zQ%{faMc)qgr`Jqa^Y!y1gVes6@6Dz^-GmOaya%Su{tD)jn-yv{t1r{rsj^XhnNdsQ zyQ)q@f$M>guZjn^)Sfq)ks%@ib}~8XJcx)5g_*)+DhHJgspWcHN=l$62LpS05Wrz_ za)wgwwTO=Hh7O3MRE{KZOfqsWhpr#T*+ zHzMwax_o$?p$ctKqH=yPW`$DO3&3BSC2TM0SYgC|{3LFEW-5ZlkdU0KPD#%#e01I| z((E3MWw4YEc&BhwBFPaRfkVshowV)jM4eLLCa1xS4>Ov>0W=*cxL__E zjFl5Mn@zm^<^v29hL4`9yvEiYj&)J7ks+wvF$rZMY>4G>!r>5euy zPb^}9&|FZ2Zg~9qPw}De5dMt8kX}x9n9CwoOJ_1(Im1sy-OJ_r#?Of%?; z=#J7Ip_h2gsbhRYNwK_L6#Yx^dW|ooZ*2+7kp}b`j_vmNIDAN4$ zRNKDIzNt~U-4h9tKm==o<)%(vCY8Wq{GD&%Xze@Ch(1bPr1TmE1OC2^NWl~+xOD6z z1U(pvx*#jyAB>U;aa>)@54;dFq!J(z9{=Qz`YWy|HgsYbaT^*tSe}dBr4qo$i*m-Mi)Klw}!LDf8AAuzVf2 zH}mVIo9Q66JS&jULCrO8qarV=%2Maf*KfA5r|6bl|8=)~{ZH*2!gtLhbhPo5_0-@| zD4vynL9j&HM&)7;vbg&I2<|^swIbT`ky}*+Dypg! z=%vg$%Gu5sstPh;q*Q;VW>D3iy&kaoCfdbSLO6h=K-p>__aH%TVsYc#fGj_wfO9=Q zh-d*)5md{VsLi`D95xLdYXN;EeKa`<&z_J=?e>35!-4(rfcG2!;XU`YxOj}?o*8mh-H0b_M)+$F#}o5hjCJ?O&LQl;>H~77o~!;) zw9EYL&B~%oAOBSxgpiOTtcXv_706+HMOb6rtiHV#{5g-GDw0oUZ#Pb`peLS(CkBJC~olS5D(UGjRW$4~s=_?f=MxN*mzWA?_G+$CoKpJ6n?}6(Uh8pNzsm zQgcWe(7=6Z&c;iEA<%3!g5wb8y9&sr7K}huk$(^FDE6erjGDhQaiwlaLfa877HTx0tC4h;5T`$CD1fgQ?2(UWxwsge7sE-N~Sv{%oM(5rFS-FRq_ z`pC9dXShftb1b4GrE$W8r;H{TQ$vmmDj9Rq)esB>3$6Erc>KJ<_z##gTvNGoa}Wc@ zKxj7ki?SBLI=CqCK{N!W6}k0R5yORduD@ROnuB3dSp6Tk@YoIL1bO4a5>mVLp%dG% z^oMuxASEiu>b<KJ z>qbj!_*UVX>W2Q2AV1Zie-M!0X@}51eR!Akm-u((A^q^Me$c;iuus3?+DI1p-1nRG zlm0y-1^jZZO7jV`S7uvA-@<U2|`d#MgChTnJ*p<8nsKSadxZgr(L*Dn2e76OH& z&=cea-Nx$y)$etL2Uk7qs^EH5y21OM)oo7L>5@Q3UFbkp>F?5uXn^sA3{VX-(B4Ql ze+_^*vIkGKfE0x!D#}>lNB9(}!N0;ai4cAkz8Z4z6CwhDO=6@tiSw&5ifpFeaI#jI z7id?i_a2>5Gb%!AHjxx~X0(Gk2yKVWI7p8FhV(JO;V@WZ#tal)kZI=Axmn*k2$}Dl zjvzoAgs?;Ch4|#e;N7a!&=h^cEKZD#?;Y6C_YR6?zLTSD-Iz*HSTM##s5r*B>X$Gs zxv1t(Bc_m=DeIBbuz)2RKKkaolc(=>>YdoCZ3sh#JKMhPbgbR7fWZ6MvK^(ro?M~-At9NnHPAS^CcI(1# zIGvAPL!7co>8<&ra&0hE1nvrpSkuMjCuFQ?Aqwfyx7GWo*2SmCbkdkkT6_q-UDP)$ zJ6-s8F6&s-{~bX3JLqcQ9j`bRI%<{vDxK2}<S*+xV&LHwrj9h8uiS_-|(dEah-7~7v zp!?KMdTex|fk`jWU7<8^9`wuiI8A9CBTiECp$s$Yy)qbpxnI8lFB}`?gFzMQ5)mjWfi&>f!-E^x?6oR}2aD$hl zzi$*s->ic9_P0+ohOXW0>0zB)A_Mc)3=kz9J{vy$@#W&F`-t2?gg!Zc{LJHXXDy2Q zz-U)#DKyf>hgfZa%0a@iL4`eK&jh9w@@zbk9^HUTwR#QBsE5r*GYT`dk1=|F2&__( zb{+4WL8sqo&+vwM6LBmTOLvU&OPc@Uf|8=Mov_h%+D=ZCH_kdRGO=&QZSoz8N7_*V zw#02Fz^2;}o^prqNIOt%N9pezlmd^HeLaxPNz}=Q7lFADk+Qo2TqsQ2a)y~Uj@<9G zp-<1Foo=dBO7jyUY9gut7fMUfE_AYsI@yIYm}5@cBBGZsN(s5c@fIF9j%PYy@Ux0{ zEPYXS_B3^XP+i68ady44+VlT(cQvtX6j3+{202u2?D1ACu#*nf&&LGaNz_8B#v-E;?|g65EM(C3MUSgaNtx_&NPa+aG-qO zdo#PUYgZt_i9_O@H?uRlJ8#~+dB1*G_8HU58y8$!V zEkMg$t^-RE3KJ(7#z3Lo-m;2xA$C|paD7_uS80L{3_OzJ!x)Fl#o8m#rMhJ%L>|sa z(H6ei3g{k^igyXiUAGIIv)tkkHTi&a&my|&b#Z7l9T@JyDwFSslAIzL*@G!H64CG| zE~M~x(ixF4b>B8z2fX%QlUewlO5SU0Whof8ec#l+L^(T^tqBgTC|LTaO^uXpZQQ+G zx}~gv?)$lX24S^#x{pli9w+f$*O^ncmQ`VJ_t9gex*QcopYQIiYs7)NigDkoYa1j= zx_SQUmpo)MFp(n<1y#ac(Fo6oc!Zw{LLVT43prJEQoJ&*c1l1wk4;7b>EdoD|F&_Y zRkf`ugCV4~$OsZk5~s*F5A2%9=8>3d95GmqB||n}w?lTBy(UR1L0i+r6Rv3kAUtyF zK3ICY!zbKulAp|Cn089_KUFgjb9{tJA3LT@C1NwY4-Y9y+>v z5h_zQGbEl91IQri6qCZ7fvG<_s5gb@`oU--P!)6*8x9+3<}#HBBsRZW4)jq zPWMfPNDNt#$BD5SPH$v>>LXG`C!E^;G@N>eXUlK`@O6xZn%(GUH=FOK&}<*rrS2U0 zt?lm2QYZB45Nmk^ZxOg9q{^XJQMm5&;-?3uKcYCy1T~yWVK?|Uw1@{1OLyoQXy{Io zvOwbH&N{7%fOC*@iI@rjJcrU9=mYKk5MhGDWsm#!;RVZo3#Xg!F-}N6%`Co<-_);f4Ypuj$JPAi-FLuSV3ouZi4$2|z{b(k#eEoi zfwRMaw7atkI(`_^H{CR7b7nRT9Iou-%|pRtpwNH}WiQDTM9pz1*5=V>=0TBUCX!lI zXNJ>;Dk&n6JOn0iMK&OV2u2lU_Z|loM&Fx`QQ@8_U{NLa`(*CLy-W4}g~0F&=2sD7 zb)qKc9|(E!zP+02)D0b2-Myq&t9y7NIow-4q|%MQzBLCqAl)7;eu_DIVKF?ogSyX}JP%Db!=j}sdeQ-z*iTXSG|ncrW(EXgh6H2= zgs2Yj2&qZ|^rirMQxJO7Q1C{k-`A55o6nNoKxV$(Eh@cv0=cC;yv#oQ2mD?HrwA-9 zZr)wdBj@Iyf8b;UM2ayKXZ9FFan6ZqAWTkS=mH$@EP64jrol!KmEqV3e#JH?6Q<44 zhrz*!u+ho)zsE*3Rgg5)5p_cN02(mRgDu_*$-vV6e@w)Yay%hwKvmy>%~{sHriJppGX^0 z*cFp_yhvIhF2rLFe%f`S{I;>$p@mQaFh(;T$eU7wS!;Gm&#XNMc>qp8sRAEH2F!?1 zg3N4^AsK$MwPZlQQL4Y;uZQsz5%~QV`29;rYXiwkd*d8}_^J#%yK(JKG9ALD(TO|P z9yGOhL4=AHo0K_A*+4N90MNE10Ls+_V2-xtW}XM;#(u8h?_dQ=BQNs+RN}LBmy3s-O39x}hAo364UZ>0Xhco>1Y}3j zH-|knuH!F(otn-fDv+g|7UIgGG&0F<%M6$Z2F4OZ*mEb045$%WMLt%hm6`HqL4Oc_ zoI0mL#ihd8UoqBUB^a39pyTY@aY?V$tHC#-0N_!eRkwsNjVnEpYfkm>qGXW4IkS9;WIg7!O0;AmT6m&XUzQ z&0!1y<9DEUkOV|cS%%RBwbBoRD7U;z0a_chmc0^EqCE$T zmh^lOF^0^?A|f-EBnubh=>hsPFE4(1wTcYTsGdSPbPO8<<5@Iciw%*Ajh%Sf1t5N{ z)e4=vDk~?EfP2zGG267vKh{zq*G39d-XaWFJmSJq2d5CehE<%hssAo=wXK`x;G7xqj z!MG;P%O+qh2G5#L5A(C;GWu;)=ODA6jl6=f1|k$KBC4l5CL$^LX8?$s90zFmI6&jk zfCTvj8RRc|4VDa!pt8c1p-ZLcE$XV^Iz&&L2H3{}%NF4)3EVDv!6IM=6N}z>xrL&| zLf(Sd+O}`p!CorM0O@MMldyddE{3)%StEF+65zn^YI70lKp(Xst>G1E#!);4br{w? H+0?%PRpL~! delta 26658 zcmchA3w&HhdGDUp!?tY8D|szTvMe939cTTJqkT(G;_TUnw5xp_Su0tRqhw=yoyd|B zQzxXo5V9c`0+)9(fJq1m2`LbAFX&<2kod81TiPhppwg5&rO-gyTMDJfH7$jf`2N3{ zIlE_9=Fyhl^)K)$Ev^hM%9Og^X@=L-hkRKbno*8 z9IDfC^u(QSIzDwQr=GY=b*Oc3jbsvUyJ6_=V<+$4KY92~Q-|-`pFDB&@YMc0kL9M0 z{Ws5E-~Qh{adPtbU3YYdn*Dd5c=O4l$L`+Wqo)V=UhfI`cB+oD!Cd=1zI}PG8@)Ti zda6I3jCS(nIo5{t=s-A19~_BhSi_n<*X~s7_Vo`$561PO zOh*LM!mNCy1$Sc&y7u|}tW9aH@&w#-&npjFuT{rN9cB8X;hn0JhNv@DqyI4bYV{WO zi|V#5w0OzrV03RdrVV7GgKAy>z)+gcBa>YnddjHIUF!AMtL*g}uTsZ0*1B0=?KLQU=%*XlJ8HM@9ZTs4dEfM=N&`@# ze{Uq7=}&5->R4}dkZR)T9(`vWyHwjgXIpVXSv5xEQsvycRwfnqP&z)y$ITp!h6nWl zBc&hE6SczVAr#1?sJ$#y;4)3AF*o!C0|`9ErAudRJ+v^bDcOjb-0 zV~jAMLH&(e!v`fss+QZ(qx*a2ae02+Zs%9&De)RxrT(f8GSPxcT z@9E(y$P#P%JI1ISPiehTvCHT*rG*D{eCvqZDFUDc9_wX)yyn)Pu%6BgYFK5=Dy5C2 zGkl}{KA*?8lZKbCV+rE}*gCmkK&O`m$+EyK+iDROtF4Za<@-!`u zwRMhxV|Sjo7c9c*3@5crCLUHjezY17ZZBZ(KB3+-e)t|0>k`cj=qW7?AT^{XBkGY8 zQ@P`}A3t`tdh+l+6_OK3{caQ#|R z!+z>&H=c}#I@KlKG%D0CQ>*IgU`7~WZj2TZ}(sA5x?!xz^Y z^26p5d-hPkQ^yi+1}_O*9yJazMG zh4|=~H-=9A!D_{U;*RFXsa^-AfTO* zp;T%VlpP&Gg@5NxcGJ3cn>r@vA{hm{Wt|iJr^|%;!76W9n^GuHT^v@AJA4& z;ZUiIK3)vI-uElIsEyG}3wvw%kN1UGaLO95w^^Jnx69x>a<$ZMKNlK;9jRRbF0e9K za4n_!yzI42+qd{s&M@`K7ldU&dzg$D#eZ8s}-|hWX-(B68 zSWM!(lZ^{2a~^fRGdDNI_HEjpH>N5+yZF^ROwU+7z9#bfE4%um-0a74##-Ww{hgIx z?DF}{pX~Cwi;oV_qRU;rBHhbYWZN!Rr)fz#J;suB`;1bTr?fa5*+g5Y;e~3&Qr!@& zGS&b75#8#MNvwriCztKEF9wIRm5n?qGzkIEk2V)tMs7+Y*iakoly#Z&`+^W6My z{@zg)dsO}!G(lIOOU0f>21!lmS6x28=?lEw#=KoFw;2rRAO$fORDn+8tH#<74t7;r zEY{#c=fau>#S&X+*CdjQqV{@B?od^{Z!v+*P5{X@iR2ci$GvQl>3EWD+VTO#%|5qf z=@co#dcwL`g+<+rx3_v^OTvvxvo-Oi_>YHVifjct$U^)`;1PtROQPBa{- z3(aN$1j=8pv2~8E`GxkhSR@tID5i^?V6EPyH!td~SSP&|3zZfNm8~xX8xGj?rrgU` z+r-lE^WNY7QdPFCP*JyF$+j2twmYv})SITN`O;s^ww6QXEf2nIeb-cEDXRihZ@n~k zzpkFr+x0duo_Emi|H(GLt~V~t`Ss@4vyJ=<8|4?`V;f)78x7XAUU%r*7xf)9;T@Q8 z)>cUA&DgC+!qe@#4Mon*LZ3j%vGk1IoL+h)uh%~?aq*RNdfVj1Y}@qPQ(#G6Z{_Bx z(EQbFu7Rl0Mmq*a`=cG{p;Rb3pn7}&g_0K1GSQy+NWbdwc#D8ksd`+c3aR$F{UvJH zDV1rrdpT3+b`uRidVx4RKK2jWwlu=1F%yH^OZ3&OxaS_+{>9o24`Yq1f?8-im($kP z5T|Xpdll1n@7He0B?RYP$+uyCYXaMt8gJF>Wp(R$Sxnnk7ShUC-z`Zjb_z?VH|n;Q z6f5lBvaVZjCDPiUZFI38?fy(&X<3Ou8y;8@YNxjf zppQwI>JMnLB&KK`$q8}w$c*K=LJXfIq|jR4<;d)PVwAjP>2Wzs%x;~rJRpY_eZ}mx z(|2kWRn^mng7|vv*5b#DHEGxDUrdj;_8BYkf+)qYAaUhf?0o8M`b;v>QkdQpnrl8m ztE-)`us3&X8v-MXLJJvC-F}x*0!N1o4{L*}s~g-HOQwfam&;XT>|mCVSE2#j(CrGC zR@dDbVBhK3l=M_M0LwbJVjXeOO-N!)(ou6vG7 z9lrZ+XyBL>f?z#s}UN5`6_fOV}9-X%zyXWY59s6--J3Dh-J!983%zf*+C8d_@ zo+|sQOWmkK>yM^;lkrSU&7@&gs)P7;o&C@?0;#D&eUJh{N~E2t$SmYhNErUna6%jC&0woNP*~tJP(7XOsi(HG*Iul# zx;)J4xt2W^3gnd!G*~RP4X>>Y-bOgaant&O7MF#PQ3xA_h%AiES3NkRY~kM=72kZC zYQpB4k=)ZWiff@gN-T74I|O6&wWuK$ZQ#K9_C;MK4yrctw`+sh*3v}g8}-(4@!YzR zrl(|^3tF~SZ?*~|vg^%f2qa-`eKC>iYbjU>B2*4>jv!Lj*0ZTxQbL3ch`hxz->f%- zKnX~%w-RT{r6pLz00Yz}Ks5@eMr$kQR5`FJF=C7aO>?#h?GTHQWcC&mr>`}>TwVU< z;=_0IFK>u(E)e6w?ZT!Qq=E+?`ZBz3zmig5g1QK$ZI;M9 zgG~gkRdVe2{5$eb2%YF-g&;s@j}?MdvwgvwB3S%~tRqUy`o$v_kS%`at2CljoZ}D?C&|`@ub99w_=!*mQNOLvVpX$#4feMx__s5pap)xS&0F zDk}3C)S_R46jB62s%+FiKxpH_v?85HCA9^*j$w&mAR$dMqbYc1R7eM@t^o7A-9plt zFwcwm(s)#rmr}=zK8-q~3gV`+3cPlg>giqv>**4#*EEVp(v7)ld5>cr$)(L;kiffC zcQ^kVYFx!6TzjO&_?#zeS`UD3-L+?3ObcQF@uz9 zr?(kEj~a?s_4}``Q$YwqQTr5WRq^9OR2)LZBSr^L7C6i2Jh0DhWs}!?Z$1zWJWZT*`ey~EqXKi_ziC5VfM8fZWwl;{~bBqQPIC6y9?F=`rlRT-&v3k zx|8~MD%tI^><)c8YM{GYjb!=>fz$x( zZtklPJKPToIUs2@0Q`|Uq8}=xua+zY&y;2v;mM=F{MsqQY5 z%#n(tm=9Py>)St&?{bN*O-LVrCO8atl0K{kFj5812RhA)rr&VPaIMfEkh-jR@|8V- zx`cw~hf&SH22eL-KrvpkuIh&rG+NQv=_^u^PcjR^oP6#sc4x5p2A})@S=(vWbiD!T zL*euBLK8Rp3A{cw6>O>UdU;2?y^{PzM_y=TWx&`@sqwl!G;o#I<)`0Huc5$;K|1|q z?-7SGY2wfr@KTG?g`r#XWgmoKTlt%i%7&UwHl=ws9ymZsi{$AvFSHwYQ)(l_()^~| zS8B~?pp|>do4tl&@AjD2&W+D6>&6WfE*Ti^vQ2PzR*Z>FF}}oQ;>Eipdv{?Hr5U?` zy{0Ej1MALaw4*l$d;ypc$L~g@@!rEz#}RT20L2_7Qvyu&B%Xa>%jIxBUtsP)==0XL zx2~wMD8u!FO`i745@#%{SX1)#~xi?d|!V z!hRN0uY-pG>RWu@zFp}goV5pfl3MRBwI5=Kd_a0Q8jWy~p5c{UEF0UP1lXHn&MXm< zmWn4wVe>$qXX1wtTT>yYq)CS|zDK$f@Bk@Fku;P7>VQ6oh=ZP{Comcsp1ZH%6;EL# z)ONFfi>Z02mgx-b2Oo*zIz1|^%gULd(yeMqgt1JZa9U;5)mZT0aA-I-+&3H8FPSC8A27ltEzL&P?a3DMB7N%vOGuU?G+Ah{wQ+VoJkWZaLk*`}8>+VG`?#vrD7U*>?`l+F>pZXfp?;q28}2DhY-&Yv zUH#3{U!i=2zd`;H*d7b@d^GFa{RtQkyd`Vbn}lo-ZS!07rt`XeyfrOrThED7$_}53 z0-I#GXJYBo{N3s8!@=BeKkxISqPq_c5AsJb?AwQfWS=yW`C`wL)nn7^TMCKnb~!j) zT4jS@3poS<=zzp(HO7a9B_H%=%t3EfAO_=nIrv{$2jn3MMF$B}_|#fN=h7!6KlzcF z{2LD@vTiwWr|zy8*qw!B?8Ly%;=nr~9{B^jZWwrn0vS0hRQ%bdVX1uBhePA7{F|pY zlr~|wN9e$<*-l7Q604nglEr)UT`h%~U;M03XwJIVn)S~7;_oa@UzfK?uZVQQ80!aZ zMuQvP>m}Mhg7)s{NVhP((KZK%kr=s2k)@B6K_SxGr8&-R`1UsZ zwn7R9bMlHW(~=FmYdnpx4>30hOd+>ACme2W&VmD8wzp?9`@>Yvs^YAe>#T1R z@jexC2kB!NGuwdM$8;?UGVo#sCh_Jq2M`UrIv>f zcv}%{c&d&#XxyfZDYxXR9#>%9k`LFa%-6kBltW-5nqI#&tA}*k(ri3w%`3MWppAtz zKvz5n_7tK(0bJ@I3F-EwxovRp+QX3dk{olwo%Go=ee-J*~E#(j) zmg^i1Ji(SU!e=qdS z=6@#$gcf4jrZ<)etSx%uS=~0?nlz-<8Bt0=QY93M0LXYas6l|(4LS8*xQ&YhL87_- zyly*}PPG))3z>#xwFPa#I%o_Cs5{6(9PR0?kFO<6x6D_)KN!#T+C&VdaQwyiCH#<#V&YJ?>zqe%^4fLR`SB zFMH*J!B@^qA*!U9DDD@5q060hWoR<@$73H?e8&8G)UM@fqL3DZD2DC`h4Ao-D)!!6 zKdF3-?a8((_p#or(?3`UF0{?3g2VMiC8D#yLfqM<&o$xOd zA4EzI)H9VpLn+d-pnI8`*q07%V4ZjDPWP4=DPlN?{hBg1DD~x6WN=tx@x?ykq>UUM zX_ML3w=@sH0xe^fgJdDn7fELgmfQ4XMD&CcM(7=s$+I^Sr5`Rp+2--1%Cqe4IN;DpOfi zp|rWAi^a5^2!oWd6g4!rYvOK&JvG^;bh7i4bJmxx%>C}v3Z*UCVB3@oF6#CRNGF=V zDS_g46!oSjr>?Na@9a{}vOmA`nmi@;C9todBosKHSLp%%F|prrdEM}@6kFXe{L5S2 zrdA5Nnp?rsd~jx&XYNIBcwR%vtU_(>3e3IpuFpVgdfra@%B)9V%n>VR4ICAaR}z}v ztRa{XYw%3x+*d=&I=M_uWJ;cTb4s+DcavQrf!&nh zA@ENkkBZ=YWfh5RYBrHKPiQjgkikJwobrC)PBq#kOHjKACG(=6epN;s4D1&K%%zIi zy$jU7YG|ZPro$gpVQU%EgiHIf#bTd4xhfC860H%eqX>Nz87cf1Zq=~J_J;XM)8`t) zPE{$awODG5=w67U0|Idki)%RX1e>h09;0OZF3qW04jEVr)l1JTRL`v!YM8cQSw*fG zi@jQ?0eJV&?E0|QXS}zDlq}GW#i%%YCONw$G2b+GWvc4pq9X0Orf=UdALAQe)trw~DXcu}|EMdPI> zH4*>A%z4&iu|a&{ORGWpIlb}H)A0O^7%$1TI*?^f&)ccdJ}N3>7gmcx{6d{5aI%=l zEsZZlW)rapCy$p_!DW@xo9NA^FUDo%N_dBIdNWlvzaZ-37giQTDRyC%QHozg-;i`} zO5y9-52l!m_6#N{^VtnA;}|GM4~Ou70(LKKVDmFHma^wg_JN-^=b;Kfvjxpj+LU|~ zFG_JOHBIupR|p|57ro0x`@K%KAIh`47-c#xFfMQLETx>^# zRm+5S|ONGr3WySQIQo4CeW?sOUeDn-9gAhwn5ezonb+R zv{Ea`6pmK&+t>*CG6hnKX9l1rn&-($x@1AHFWmp-ym{G+Cc5~#E>76sk45Y2J)kck z^n|(dQeCUSQh{fy<W8ILQ=AFEA|nngMT*VNRWwi#ui;F$Yfs6D+(3v%v( z^bhd|NQn$scI&@y%v0<&njFLjx|V4w-Nq8a#xidj*4F$894YP;6b$ns!lPyE8@%nM zg)Y8+4bETy6OCO1q7<9Z;+1H_CiC~Lqy|E9wv>OSmb1`0_QV5Q*c}h{=HYaLe3Bs+ z*#m6edo7A(WzT$LgnPC58VEsH^{L#$I&y7@B&4-~C#(EabOIqeJ^AQ|MRV%N+TA6&FZo}tk_JqP_FhV3SE7H30rMuvm zgR{^<1P$*Z;w$9pa=@zORiy)M+ObJ++N5shD=_M@eJ1`9-9Gus^bd9Wq2y%W@tc!N^>y~O_c`;8v+YS;ST-D}glQfX zf+>~O>nAiL2S=#D)01;I%VpzB!T-vNg8@sQ(``9E<0ZpxzfnBSZPg{n+(x7HoSrwJ zXEzGD_lJID{ zyU0b6;t_A0%5=kNR0$37#=Qy=YDbDuc{}^S!!3D4smp7T_!^*D#)n{~Ly#u<*+y5O zdl?+^bNJCNiUwEq0k+hE#5t7??SSpWjpA1w2OJ2aBJSI9loD!?01@s$5SXIajwpT+ zxpl-H$ZYFY9ZCFRIUS+7Km6b`EAtnv$XRSq6`AWbYcB*jt_miQ%gwdeq*w4KQfcF; z-fDxxX(V^LJ(uGo^OHvk;~%8Fu!m#shFktR&QV9=O5BS706Kdo|A94=i_Nd#Bk&5! z``FfcD6t`h9HryDe7iC1gT~#tFJ}Qvz@q#JhJ<8VvXhSK=9D9(rNWZ8+N;(x# zszY-65es)fi$t!Q=YcdM)6dFG*ZI~2&+$#{=Q!6;RhvvLreQ*-8xPIC+FSo#D6#+v58Ob6_3W`HHetzx z1JiIt!jvp3P^vufOi4&|!Wrn%#V$OtF@I>KVpx;2hqd`SLk|U(go;nAurOic2??0B zg~q-Xi1O%ur8M7}=${D4!s@7<%P4{t=gy{*m;YxxwHSnvn3{a$ zmg#>I&2f9RD3tYc$ey?2E!daHeNJEgLZ4p0IDt3y`pH+a_0vBNOE>v!cQEo7{A)D% zJIQsHGk0CNl9(Jf8Yf?s?h!Fm!d}bsnW5ss<(7$QKvoY#&450H@TLc%B^1w-msQdY zaaz&lhGs2G5Prgk4Y68g`ayVp5qKfZ14l)(bM-vMEz{6p}(4A_H;*1Im;`P z)+UMp^YR&bFR4t`B-YiBRDCo)UmrVk=V-xNHUCOq!^*xv;l_lb8~tthl!0Pkc*TwGIEnPo^|!OX}LxofF5)ew9i}dhgOHHJSYjg z7mLH!#)`ZqO?MQ_AyYYQDo0G^s8J?=ef6dwUs~D2cJ#KrSk8w`4`EX|Vk$?C^631{ zVJ=6%K=)}_h;U8Z%wp`2aiNRoAGfY6;1Pd4dJ%3TJKz8CvL8O%APFw;pHXQ&d; zEdbqlKq52Cozpu7WVjO2FChH@^cHk~PWKAHNG0Gt0k{u2H#N(F(wO1>n5^ zyr-bwo73-+fSkgz_ZRg0vTp%Q_V)^U{w@0NwTzQWOovnq6M;_W7-bLHPsX7u7{$dh zsl0|sK>>B647US`EaOO*i)5tHh!eiWawlaR=H*+RNSHQ&I-zpQayR)W1V}eOT~ESG z+$coqcQ?%Bl7FrnUJj9z*yS${(?#wD(E}Y)FpALdc`=WS9^{(KYCmjgS@g+c06eh~ z`9ngHl216J%Jo8DX+3%%6T-30evRlQAuF|0jN>blrR8t0qfRO3zygO+x3q#1o zzVw)VwGWCiZgp|FySmxZ^Y&^KJhFg8Kd7nd?lyj1;yK{szy2=2{OzP)tKZLl{QQP4 zKfV`U)_faI`PQ)Cd2|~>>sL`AtoUQnACA&dKzI*0yXW-InHvb4 z>4<{?*w}x0Y%e?Z#f|Lvxf^L>#po*B&3!9y{Fo;8 zn<@15QlXz~s}yF^M-SDf=a)CGA$0+#oW+6v!?kcJtP;u7Hn#u#j{Gf1zThr_m#RLM zIzRr76y+kEOLJ`{KEHzhaCRrqf?hFZ}FJOmQ>}4)~ zB2*(B0OcJqhvF0Y1Ca-Wtd`<2`=V3V1*U6+33_ln6>g29Q?3zQ^A;t)mJ1#6-8Fz< zYLp%Bpi5~4zXWSCu~8Z3V6a>quw-#s5YZ%LdV^CHCswjC*y4-!Ja!FOfpapZCH*I2r*^~IF+mgzaVr3PO0vdi))T}2X?8<@{Ao0C%B z94`B9(9(a9l(x}9sb5P=k2$sxPoSf>zF$pD`fr(-*u!7h%6|6kO*o|9Wj$tPKlHY@ zOdvNRH-WSW{8d-Th2aL|CdD{={5#vWHNx#7uS*~w8u>QLb9w>+_Lc7>SC@`33*YaL zVI!>Il4rI>SSb8K=-*_DTD~C-7w(pvPb>%O!l8t@9+Q#z9Ov9&jv(A(L_k?|h&vuE z4~hmG?bMT{=_E5 z%db&fK@l+A;DB(-CMzx_o&IiX4P0A}6KvJ@uCoR_Y~S~sgv|MO(}fGAt=o>R;~N#S zDj{$n{BK3T2pcUt6!SV7#7@p`#ZHRyRUxn8n8g3$m?!pKpaWgH#ZUR=6^>!^Kch&* z5~Xj5tl^U7vn+Ig!#vm=<470mkusgO%y7aYfKyz3A+hCXIQ7r9N+YGu86i%1q2)e7 z-=5eJ!omyo*$^`^^nn~)XSj0T)C`hC55 ze(mvh>&=K=G*AD{_@RlZD>#NoUP2t|zdW}Ypmf<62W^{Qcl;w{0T$}SPf(op@0`%xQ`P#O`t`c4Z=zw_rkL)Q zucB1!UGLQQUY<+fdpc=ye&mYq0y)R@##bknP65Kkf8DzG6`ZuJ=qD<&XmJt}-_kjK zdc8Qf15O%11YDd|R{cm@9t+{#2^>yC>_wEIy~>iy%WnDc%c}t-SRX7;&(ilR&Vjga zmcWD)#8rq_;~G!8=Ocv6J_kmTH-q!*xl1=F-<*5u(nWdA|;RK=I#1(6AgYdV2#FN%kkWP0dJt1q63P2}PexxNJ72maSu z{vPVDiBC=}ZwP8}ZU;i@6U*+#F@xq^u!M>!_fU6=WeCo4_UA)_UPqq9aleMF6eKzt zr!rwF4McJCG|ra*W5r2LT1*pD!fg%aN3IT(RugjH;BH0kvB(&b|9{|k;<^1lX0aiWrxB(6vB4-pskl-=Sju1V!Sz7m$gpR*iGp-CBe?jlwn z_V5EJ97~H{3L%QhxB%{lC}L?B`|8iHy(*R}t88>WQ6T3dxb4rt(}!0Xc={V)=^2Tx ztIsBq7tbXicc-eqHIWp*uQr6%Q4&Y~@}p2IB~JF?a>|b7bVy66V@(VT6g%3=CyPUr66e}G|xTs z#{XV1_xV4Xt7f-I(Po7eG1brY@560!kewE`Q%**NvEJHM$83um*_#$`+}p47v^Kgk*$fUDXtaP`%6qC^{<(i$)D)KehJ(H78x8XR z>U9RB>V)eQ*DHVG8wVT4GCgz@n5XA}p=9b<^`8wkl6Du zawMJ&P#u0QWMAWyR)yJ%uQMbbdwi^ob$rv#%@8lL?P`&2$GR$~6Q4{)WJjMH$oeqIna*-FSb|7QxX_(-}*6%a?r(1REgY+W#&_R=(R=7F7xfhLGlZmFk?P7I^luqL)p(>-MSBAhK>}MuQJ^gS1}}= zJT9+dul(ho=Y81Rsu1+IPO(-mb7gLun1y)_<^3X*G!?hE@!d57H`pLD>P?yeGBhf# zfVj#jMPit&e%(d>&!1hTyjwZ- z+$yE@`N(SJI)z>TSHb)fAeAaDB+=9=e=QBURefn~XPcnJr!#%(biqC&cO{L+(sdLuu(mB6oFKfQ;ZU$UIV5AXV1GS$8G zL^;qy1e;2}N||+y5a^B5j|zTUakM0GYIm*jWoG~OJDZ(j5?49Sk|06KA_$bte0#?o z6_@ZstHZzIfo+qo$bUtp*nv20gMY$fpdbG>!+=2r63jUSX8{5i61+~uKTRRz4O{qj JXEn)%{|CP~Aie+q diff --git a/sources/MEDLEYFONTFORMAT b/sources/MEDLEYFONTFORMAT index d7acd0bb..c4ff4d8e 100644 --- a/sources/MEDLEYFONTFORMAT +++ b/sources/MEDLEYFONTFORMAT @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "27-Jul-2025 22:22:23" {WMEDLEY}MEDLEYFONTFORMAT.;218 57699 +(FILECREATED " 4-Sep-2025 11:43:26" {WMEDLEY}MEDLEYFONTFORMAT.;240 58467 :EDIT-BY rmk - :CHANGES-TO (FNS MEDLEYFONT.READ.ITEM) + :CHANGES-TO (FNS MEDLEYFONT.WRITE.CHARSET MEDLEYFONT.READ.CHARSET MEDLEYFONT.FILENAME) - :PREVIOUS-DATE "24-Jul-2025 22:07:35" {WMEDLEY}MEDLEYFONTFORMAT.;217) + :PREVIOUS-DATE " 3-Sep-2025 11:32:20" {WMEDLEY}MEDLEYFONTFORMAT.;235) (PRETTYCOMPRINT MEDLEYFONTFORMATCOMS) @@ -59,7 +59,8 @@ (DEFINEQ (MEDLEYFONT.WRITE.FONT - [LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 15-Jul-2025 16:43 by rmk") + [LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 2-Sep-2025 23:01 by rmk") + (* ; "Edited 15-Jul-2025 16:43 by rmk") (* ; "Edited 9-Jul-2025 09:32 by rmk") (* ; "Edited 19-Jun-2025 10:59 by rmk") (* ; "Edited 9-Jun-2025 12:17 by rmk") @@ -84,7 +85,7 @@ (SETQ FILECHARSETS (for CSNO CSINFO from 0 to \MAXCHARSET when (OR (NULL CHARSETNOS) (MEMB CSNO CHARSETNOS)) - when (SETQ CSINFO (\XGETCHARSETINFO FONT CSNO)) + when (SETQ CSINFO (\GETCHARSETINFO FONT CSNO)) unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CSNO)) (CL:UNLESS FILECHARSETS (ERROR "No character sets to write" FONT)) @@ -128,11 +129,12 @@ (FULLNAME STREAM]) (MEDLEYFONT.GETCHARSET - [LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 17:09 by rmk") + [LAMBDA (STREAM CHARSET FONT) (* ; "Edited 3-Sep-2025 11:32 by rmk") + (* ; "Edited 15-Jul-2025 17:09 by rmk") (* ; "Edited 9-Jul-2025 15:45 by rmk") (* ; "Edited 14-May-2025 17:46 by rmk") - (* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information") + (* ;; "If open, assume its a medleyfont stream, that the initial Me etc. has been checked, and we are positioned after the header information. FONT is provided so that properties of the fontdescriptor can be read through this interface--ottherwise the fontcreate function of each device might have to also have a list of functions to try.") (CL:UNLESS (<= 0 CHARSET \MAXCHARSET) (\ILLEGAL.ARG CHARSET)) @@ -145,6 +147,12 @@ (ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM)))) (LET ((CSVECTORLOC (\FIXPIN STREAM)) CSLOC) + (MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT) (* ; + "Maybe only for the first character set?") + (replace (FONTDESCRIPTOR FONTCOMPLETEP) of FONT with NIL) + + (* ;; + "One charset doesn't %"complete%" a complete font--maybe that's only an incore property? ") (* ;; "We know now that this file has information about the requested charset, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.") @@ -186,7 +194,8 @@ CHARSET]) (MEDLEYFONT.GETFILEPROP - [LAMBDA (FILE PROP) (* ; "Edited 15-Jul-2025 20:21 by rmk") + [LAMBDA (FILE PROP) (* ; "Edited 27-Aug-2025 17:12 by rmk") + (* ; "Edited 15-Jul-2025 20:21 by rmk") (* ; "Edited 10-Jul-2025 17:50 by rmk") (* ; "Edited 25-May-2025 20:53 by rmk") (* ; "Edited 21-May-2025 11:36 by rmk") @@ -194,9 +203,8 @@ (* ; "Edited 14-May-2025 17:46 by rmk") (CL:UNLESS (OR (LITATOM FILE) (STRINGP FILE)) - [SETQ FILE (CAR (APPLY (FUNCTION FONTFILES) - (FONTPROP (FONTCREATE FILE) - 'SPEC]) + [SETQ FILE (CAR (FONTFILES (FONTPROP (FONTCREATE FILE) + 'SPEC]) (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT) (LET (HEADERPROPS CSVECTORLOC) (CL:UNLESS (SETQ HEADERPROPS (MEDLEYFONT.FILEP STREAM)) @@ -255,7 +263,8 @@ (DEFINEQ (MEDLEYFONT.READ.FONT - [LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 15-Jul-2025 20:20 by rmk") + [LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 31-Aug-2025 14:42 by rmk") + (* ; "Edited 15-Jul-2025 20:20 by rmk") (* ; "Edited 9-Jul-2025 00:06 by rmk") (* ; "Edited 6-Jul-2025 11:45 by rmk") (CL:UNLESS FILE (SETQ FILE FONT)) @@ -267,14 +276,13 @@ (CL:UNLESS (MEDLEYFONT.FILEP STREAM) (ERROR "NOT A MEDLEYFONT FILE" (FULLNAME STREAM))) (LET ((*READTABLE* (FIND-READTABLE "INTERLISP")) - FONTCHARSETVECTOR CSVECTORLOC NOTFOUND SINGLECS) + CSVECTORLOC NOTFOUND SINGLECSNO) (SETQ CSVECTORLOC (\FIXPIN STREAM)) (* ;  "Byte location of the charset dispatch vector") (* ;; "We know now that this file has information about all requested charsets, including NIL entries for empty/slugglish ones in the middle of populated ones. A file that would have contain a single empty/sluggish charset cannot be created--the caller would recognize the case of a missing file and provide either NIL or a slug-vector.") (SETQ FONT (MEDLEYFONT.READ.VERIFIEDFONT STREAM FONT)) - (SETQ FONTCHARSETVECTOR (fetch (FONTDESCRIPTOR FONTCHARSETVECTOR) of FONT)) (CL:UNLESS (EQ CSVECTORLOC 0) (* ; "Not empty") [if (ILESSP CSVECTORLOC 0) then @@ -284,15 +292,15 @@ (* ;; "If the intended charset is empty/sluggish, the file would not have been constructed and we wouldn't be here.") (SETFILEPTR STREAM (IMINUS CSVECTORLOC)) - (SETQ SINGLECS (BIN STREAM)) + (SETQ SINGLECSNO (BIN STREAM)) (CL:WHEN CHARSETNOS - (CL:UNLESS (AND (EQ SINGLECS (CAR CHARSETNOS)) + (CL:UNLESS (AND (EQ SINGLECSNO (CAR CHARSETNOS)) (NULL (CDR CHARSETNOS))) (ERROR (CONCAT FILE - " does not contain information for charsets ÿ4ÿ" - (REMOVE SINGLECS CHARSETNOS))))) - (\SETCHARSETINFO FONTCHARSETVECTOR SINGLECS (MEDLEYFONT.READ.CHARSET - STREAM SINGLECS)) + " does not contain information for charsets " + (REMOVE SINGLECSNO CHARSETNOS))))) + (\SETCHARSETINFO FONT SINGLECSNO (MEDLEYFONT.READ.CHARSET STREAM + SINGLECSNO)) else (* ;;  "Gather all of the CSLOCS before reading, so that we always move forward") @@ -311,13 +319,17 @@ (DREVERSE NOTFOUND)))) (for X CS in $$VAL do (SETQ CSNO (CAR X)) (SETFILEPTR STREAM (CDR X)) - (\SETCHARSETINFO FONTCHARSETVECTOR CSNO - (MEDLEYFONT.READ.CHARSET STREAM CSNO - ]) + (\SETCHARSETINFO FONT CSNO ( + MEDLEYFONT.READ.CHARSET + STREAM CSNO]) FONT]) (MEDLEYFONT.READ.CHARSET - [LAMBDA (STREAM CHARSET) (* ; "Edited 15-Jul-2025 11:27 by rmk") + [LAMBDA (STREAM CHARSET) (* ; "Edited 4-Sep-2025 10:39 by rmk") + (* ; "Edited 28-Aug-2025 15:27 by rmk") + (* ; "Edited 26-Aug-2025 23:36 by rmk") + (* ; "Edited 17-Aug-2025 13:01 by rmk") + (* ; "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") @@ -331,12 +343,12 @@ (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)) + (if (EQ 'INDIRECTCHARSET (CAR (MEDLEYFONT.PEEK.ITEM STREAM))) + then + (* ;; "Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). ") + + (SETQ INDIRECT (MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET)) + (\READCHARSET INDIRECT CHARSET) else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO WIDTHS _ NIL OFFSETS _ NIL)) eachtime (SETQ PAIR @@ -366,10 +378,11 @@ of CSINFO with ITEM)) (CSCOMPLETEP (replace (CHARSETINFO CSCOMPLETEP) of CSINFO with ITEM)) - (HELP "Unrecognized charsetinfo label'" LABEL)) + (HELP "Unrecognized charsetinfo label" LABEL)) finally (CL:UNLESS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO))) + (replace (CHARSETINFO CHARSETNO) of CSINFO with CHARSET) (RETURN CSINFO]) (MEDLEYFONT.READ.ITEM @@ -481,64 +494,65 @@ (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") + [LAMBDA (STREAM FONT) (* ; "Edited 2-Sep-2025 23:52 by rmk") + (* ; "Edited 12-Aug-2025 17:57 by rmk") + (* ; "Edited 10-Jun-2025 20:57 by rmk") (* ; "Edited 21-May-2025 22:55 by rmk") (* ; "Edited 19-May-2025 17:42 by rmk") (* ; "Edited 16-May-2025 10:28 by rmk") + (CL:UNLESS FONT + (SETQ FONT (create FONTDESCRIPTOR))) (LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM))) - [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"] + (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)) + (FONTSLUGWIDTH (replace (FONTDESCRIPTOR FONTSLUGWIDTH) + of FONT with VAL)) + (FONTTOMCCSFN (replace (FONTDESCRIPTOR FONTTOMCCSFN) + 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]) ) @@ -549,15 +563,15 @@ (DEFINEQ (MEDLEYFONT.WRITE.CHARSET - [LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 9-Jul-2025 19:14 by rmk") + [LAMBDA (FONT CHARSET STREAM NOINDIRECTS) (* ; "Edited 4-Sep-2025 11:41 by rmk") + (* ; "Edited 30-Aug-2025 23:44 by rmk") + (* ; "Edited 28-Aug-2025 21:00 by rmk") + (* ; "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)) + (LET ((CSINFO (\INSURECHARSETINFO FONT CHARSET)) CSCHARENCODING) (MEDLEYFONT.WRITE.ITEM STREAM 'CHARSETSTRING (MKSTRING CHARSET)) (* ; "For human file-scan") @@ -569,15 +583,12 @@ (* ;; "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)) + (if (CL:UNLESS NOINDIRECTS (INDIRECTCHARSETP CSINFO FONT)) 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) + (MEDLEYFONT.WRITE.ITEM STREAM 'INDIRECTCHARSET (CHARSETPROP CSINFO 'SOURCE) NIL 'PRINT) else (MEDLEYFONT.WRITE.ITEM STREAM 'CSINFOPROPS (fetch (CHARSETINFO CSINFOPROPS) @@ -742,7 +753,8 @@ (TERPRI STREAM))]) (MEDLEYFONT.WRITE.FONTPROPS - [LAMBDA (STREAM FONT) (* ; "Edited 10-Jun-2025 20:50 by rmk") + [LAMBDA (STREAM FONT) (* ; "Edited 12-Aug-2025 17:55 by rmk") + (* ; "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") @@ -774,6 +786,10 @@ T) (MEDLEYFONT.WRITE.ITEM STREAM 'ROTATION (fetch (FONTDESCRIPTOR ROTATION) of FONT) T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTSLUGWIDTH (fetch (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT) + T) + (MEDLEYFONT.WRITE.ITEM STREAM 'FONTTOMCCSFN (fetch (FONTDESCRIPTOR FONTTOMCCSFN) of FONT) + T) (MEDLEYFONT.WRITE.ITEM STREAM 'FONTDEVICESPEC (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FONT) T) (MEDLEYFONT.WRITE.ITEM STREAM 'OTHERDEVICEFONTPROPS (fetch (FONTDESCRIPTOR OTHERDEVICEFONTPROPS) @@ -810,36 +826,18 @@ (DEFINEQ (MEDLEYFONT.FILENAME - [LAMBDA (FONT CHARSET EXTENSION FILE) (* ; "Edited 10-Jun-2025 11:02 by rmk") + [LAMBDA (FONT CHARSET EXTENSION FILE) (* ; "Edited 4-Sep-2025 08:48 by rmk") + (* ; "Edited 10-Jun-2025 11:02 by rmk") (* ; "Edited 25-May-2025 21:25 by rmk") (* ; "Edited 19-May-2025 17:42 by rmk") (* ; "Edited 16-May-2025 14:09 by rmk") (* ;; "If EXTENSION and FILE are NIL, puts the file in the MEDLEYDIR fonts/medley[device]fonts/ directory with extension MEDLEY[device]FONT. If CHARSET, goes in the CHARSET subdirectory.") - (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)))) + (LET (FAMILY SIZE FACE DEVICE ROTATION FILENAME) + (SPREADFONTSPEC (CL:IF (type? FONTDESCRIPTOR FONT) + (FONTPROP FONT 'SPEC) + (\FONT.CHECKARGS FONT))) (CL:UNLESS EXTENSION (SETQ EXTENSION (CONCAT "MEDLEY" (U-CASE DEVICE) "FONT")) @@ -849,9 +847,10 @@ (SETQ FILENAME (PACK* FAMILY (CL:IF (ILEQ SIZE 9) "0" "") - SIZE "-" FACE (CL:IF (SMALLP CHARSET) - (CONCAT "-C" (OCTALSTRING CHARSET)) - "") + SIZE "-" (FONTFACETOATOM FACE) + (CL:IF (SMALLP CHARSET) + (CONCAT "-C" (OCTALSTRING CHARSET)) + "") "." EXTENSION)) (PACKFILENAME 'BODY FILE 'BODY FILENAME]) ) @@ -904,11 +903,11 @@ ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2127 14772 (MEDLEYFONT.WRITE.FONT 2137 . 6995) (MEDLEYFONT.GETCHARSET 6997 . 9296) ( -MEDLEYFONT.CHARSET? 9298 . 10767) (MEDLEYFONT.GETFILEPROP 10769 . 12804) (MEDLEYFONT.FILEP 12806 . -14770)) (14798 36689 (MEDLEYFONT.READ.FONT 14808 . 19241) (MEDLEYFONT.READ.CHARSET 19243 . 24137) ( -MEDLEYFONT.READ.ITEM 24139 . 30288) (MEDLEYFONT.PEEK.ITEM 30290 . 31152) (MEDLEYFONT.READ.FONTPROPS -31154 . 31619) (MEDLEYFONT.READ.VERIFIEDFONT 31621 . 36687)) (36715 54244 (MEDLEYFONT.WRITE.CHARSET -36725 . 41330) (MEDLEYFONT.WRITE.ITEM 41332 . 50385) (MEDLEYFONT.WRITE.FONTPROPS 50387 . 53589) ( -MEDLEYFONT.WRITE.HEADER 53591 . 54242)) (54245 56814 (MEDLEYFONT.FILENAME 54255 . 56812))))) + (FILEMAP (NIL (2175 15697 (MEDLEYFONT.WRITE.FONT 2185 . 7151) (MEDLEYFONT.GETCHARSET 7153 . 10156) ( +MEDLEYFONT.CHARSET? 10158 . 11627) (MEDLEYFONT.GETFILEPROP 11629 . 13729) (MEDLEYFONT.FILEP 13731 . +15695)) (15723 37913 (MEDLEYFONT.READ.FONT 15733 . 20165) (MEDLEYFONT.READ.CHARSET 20167 . 25525) ( +MEDLEYFONT.READ.ITEM 25527 . 31676) (MEDLEYFONT.PEEK.ITEM 31678 . 32540) (MEDLEYFONT.READ.FONTPROPS +32542 . 33007) (MEDLEYFONT.READ.VERIFIEDFONT 33009 . 37911)) (37939 55776 (MEDLEYFONT.WRITE.CHARSET +37949 . 42511) (MEDLEYFONT.WRITE.ITEM 42513 . 51566) (MEDLEYFONT.WRITE.FONTPROPS 51568 . 55121) ( +MEDLEYFONT.WRITE.HEADER 55123 . 55774)) (55777 57582 (MEDLEYFONT.FILENAME 55787 . 57580))))) STOP diff --git a/sources/MEDLEYFONTFORMAT.LCOM b/sources/MEDLEYFONTFORMAT.LCOM index c6da3118131bbb9ccf0f088f21d5d4f0fbf82aab..f933c5043d3f28bfd7129a2dc79fff3b82d1c917 100644 GIT binary patch delta 5493 zcmZu#Z){sv6@TwJNz){xcIvsQle)KVyEWTV{Qmgw2ITemIdN>i=lVJEvbD=t9G0Y6 zTh=0tG2w!kv>`z2?u0gV8{IU-5JHOM1=wJ-(7r5)&?5F>`v5ARKw=Xa8xj)GaPGa& z$+JzQ_}+KUx##{n=XcJze|?32{Z;;__FICh&I+|LMiED43ecW|4E~@#DvX zsHgnJi!kE<=v2bNk)C6zbXM02x?0qe%|fD>P~?OJ6XW0UN4u2}3dfX46n~k&13z!< z$H?f!W>5FsIX#)xXHuq7JWg~OYEBf&=uRk^e~`O`^ZgM&%&KJ*TGq656oqByrn70Qh$3->mp%TBh{9oH=5+(f>}1Fu zEhLBNTJr@nk0jP-h5-9TR{kNJjbb97~tQDpl^4rS!+E zRw=NQ{(ucE1<)@`X!W*C3GtiHmXNSITslIv0fmb6lF6v*dMQYaaXpZ^alI7CP_~z= zuYl;9XL)PMBX#G>*-ut8bz{JDve$5}od(?pCRhDbXNBV?sUkX%&2RR54)vRZt~J*; ztK4&Y_m+YKRAgc9*7}hy-aYHCoBeBhO!tC+w*T$infFewTs7Ud&i2<=KILb<^->^h zdT-o#pJ}sqKI>cB{E6u+ce-An%APg7lm0i&3Xp3DOkbyK?WpNBeg4^jy6Il?m;<2P z4Jr-c{_2)#4%`Z}u6#;|uD-wWH-6U7rZWA4Jx}8xU~V`G(@V*46y~5XJ6PRPxMK}C<$1mgLwfOMV;%wzYTmQC`u7~lqi9f+M~cE3wq9+)=^Bv9}Hc%Q;svE zbRYvk7=lwfB=8)VP{Q9I9_vD9yV8fV>>u8Q&#D5x*s5xcd)zw=L$bUy?l0SYr~CSI_NKt)F+uKcGUK= zp8d^vJ8YJ^;huCe^;Z}(M{Kp4Ei>W^wp%TsW3FOjbc=_1csN@Q^ky40AwWy5A#;QbQw1q zMZ|7&qllykSgT`E5}>_mvy>JVnA}V$oh(jRNFwIy90mxT&Z*;igCByuIrw5+MrX}b z3YK62umX5HnNbPZ<3w^MPFA>i9ujAp_z;wuzDXDfwb+&!NtYYpp|d^QQ#o%2`)-?`TPqfHa zz#FRk`4(!<+fn83Ya@15`BW=$qr1wBZN%MGez=X;Q{{KH5-S_MRqh|H)Q!F>_s3SE z*Inh_Z6kWCT&<1ht8y>35eKW>Q?0~n75}c43pVvi5*0V_ovK*E+?Ep1Wz=+An3Ds&isfCm_Kt~D~Gm#^fOPrVG zFi3&Cwsqprj-+mAW)gBCM3AXPPL44-b$XmArA~+BsN5z8+1e>9l~OewlxUmFxr7pn;#1;L zd{sO=ECRTbL^^~@(8OuR4ONXfRnT<&2QlyCH~ToQV{AR3-nhQbtsNYrpobOd?)g_~ z_cu^FZN3hg^|}SYy!J z^vl4#^24at95CIV)P^CY9Ju~2XZmQf`SQY(=D?ZvW(V+da?Pd0W&HBkK9>Ty6>Y;& z*2*!~igD5kN(i3}54vP3HYh|SpbiQOY4!<{0?hq_L{$hd;*jn?BqB?-ET~RMrbkYd z7Du8KYtV5X#)RoKm9UI*8CEBOU87U1c(P*@L6;buF9~D{6k;}+25*G~Y)96hKta{S zSCmFppny*{u>enOz^NDjBh8^!fgGZd703{-og-yfjhz+9P$M?6z$qJ90l-8v4>FoY z(3hJcbp_HNNN1W-hFJ4zB`{y-L=yN<)3?%+^ML;}@uBW+WFzEJfL66qC`yHPav^{s zXObnx;1L0;S4iH$qnU+6jmSnd5-2eO4$+cU5RXp6vxSXkq6B3y^$$o4n-?y^lyT=u zTQ&|pYI7l=G`hB_z}v-70|#sF*uQ)DOSn&4_r2S<2(HI*%u`rUTX*Akv>yo#(Fi>{F66p2>0>e9HD?KvO)Ep^9l$XGa3E zyX`22Po{?Yobd=hni}q;K?Pq;4Pt)$7QCJsvK(hCwX2qF)!VUxAa=|2Vw}a3?O0K} zYkW=!fE;;ZfSuY8Q1GE_hYS2#dU}fc%Pv4S&jX!f?~tRu;y|S*8W~`hL3uA26p$#0 z-G9m84dLxy(BC)c@0;}ZR|bFIUi_6weej1g_xKk5P19dinB$KpZ>yZ9sxc-*ycN4r^*fHQTTos6EJWkl<4^RX8SiQ;DOzrB5ZzZB?YG zWTi5s%%~!gf}>HB#!+@uQ%N05QhP>)`KB0AVUd|V2SG3;a~;^a%`Hm$F(zKM7H!)DFTkC8@K6(10TaM>Xg`+8-Q+ z7P13E2e1vogP|xXD0l%{C{}`BI(PQsh0g{Nl-5DA+8}~5DadwDo;LG^+V$*n9sdL3 C-fuhr delta 5414 zcmZu#Ym6J!750q1o5ULyuh(ogo89Eb3CV6CiRb09S3GuNkF$P`v7I;}X&1-_HV;Ue zO&_RGqqaXlMOBkarAmZW(25_WRqb`QA|c??{vk*aL866LLdwq~wW@hk6`HJwfazNI1roMf0ryP*c{-m|9xHFEq zn5uT1CZta*T9A0pJ$3~dS4o~o8YdM-s+^SRb7Ir2>QenF z_rKkYpueBEm;Nf!PiI8W?PNM0@lHaUD@*l1uOedq6mdN(y6LBDGPLBK5fz2jg!Q^4 z%cN+Q*x~Y}0+A$%98M$;-VhvkJ}T{6}7(G zCyH)R^mh~Y(Eee+3|?za)~qZ%1pC9IkU!v|LWv1_OSCRr>IT*`U>*j|Z*L&VCPIiiM$k-?K&m4`U1Hsr7ePaQ`LvUzQ|@q?4E}&sjw_j_^5*!cMVE zP%U!QmKY8=`kh~^0pZ$C(+pq@xLl3OA2HneZusV@m8e`Tfu#n~^_*8pk%Qv+7 zc5BSN?EWG4H9TD2>gOs8MezhU{7hb;fX*qm=}u#r3Q!8fZHEdRDSU!(ek zFgMaDlaw`bbo!X#_PGv+}SIJ@YZ!fioGQJh(l9Jw`1R!G6jTKi2BiO}5m z;%Hdm4j4C!u|hHrS4Nb;xI#Bg>~>3%hVM@AO;Nq+3VN}5`oP3NH+&OWtH8c>apNBa z;m7pSCcSb{;Ax<_v|(l?A8;xu3jDHs4>51rG{1mb!;jb)lKSifa!9z67KJx6^Nxv) zjTHCYtDZmDgfnynJSm^8^PMVRZ3qbBbBFZ!3D>} zHE*MK^H^)~ms%#S4S-$fR1K^J@4g<@KtI^qyHp3k8_w9wrGT^6xf9PE55DK}HELgd zX-AsvR<*A_aZM@_nar9QBq93#=5=dH1XY9QN7M-vLHdi$rHU49rI2JUVIgydkcMJb zHlHy|CLBz;m11nU41HvB^VCke61LN!is@^haAlq8_HpTZpi|{?{%4T7A1p_8S>qH}d!m(d&0_ zuKcf$)l!~ehK2-VNuC`Va;MzOeZ$qHa7Yx=g0aAzW-asRFJ9wblD54hB|cdF@FB+E zbW%Kd^P^*&eQ7=!*w}bPY|IXA_P~dKv%e;ccQdc8t_iC;nH5*&+M1f{vraCU-kR&<9_B#J^-ec4 z5U9E8Jz6&u(VFYIE@mpeP`!cuX@VGBSV)d+>jnXs!GV5Cqs_72-xLW)_Qt-aoWq z25DH0gt~GwQFWQK%mbx@kw}`ExJ*<{?@?2A`q1vcz2P2#Z0kBcYhx6mO1+99oz`{- z09{x`S*Z?0iP#p5{d<`a9&kj_ZOGQHhX^@bOeBmLjutnOrqmu&sy(Y1Gk|*()T{2b zduH9<@%0a_$6hb}EBSq~w>~eqrd+u1$?J31% z2;jy>@hdGr)6#5N+cwy-GWg=+#LA#~(dP`B z7yGm0g3(-PKC`eixrZ;*u^Rn>@;LEYK5Ovv`nct{eAnM`SpoiOzP#|PzHx$Nqy`bZFR18Px+llq`fz+s5+DjZrM3PmyG)MTRwIUeM^D)UgW5rtNl#K;f|6Lpjlox6>5Xi=fbHXgnM? zFW4GyfL6Rk1-xvRt5Kze5?EU55CIt6LJ1WW0n{NyhsL6Zp#)V$$JAD_RqVz=2`YeT zhX~%yb(ux&AxFgnJ_ z;w|)ofH8PqDn8&ojt-Vu?k z)9*a8geZ0_M8lof4ts6i`wDU-D=%St3q6+{p{KOI`fnpmuW*3A7`sZJkN;d$xl7V~ zYP|?2g|pUQF;57)kPf&TDR8o`?J4-92V=FBDEgDV%!(WMmy))d1;vokd