From 44e54088104897cfa0225347346814f41d2766ca Mon Sep 17 00:00:00 2001 From: rmkaplan Date: Sat, 14 Oct 2023 15:10:16 -0700 Subject: [PATCH] FONTPROFILE: specvars declaration for cleanliness --- sources/FONTPROFILE | 146 ++++++++++++++++++--------------------- sources/FONTPROFILE.LCOM | Bin 13480 -> 13263 bytes 2 files changed, 69 insertions(+), 77 deletions(-) diff --git a/sources/FONTPROFILE b/sources/FONTPROFILE index 5c73f0822..91fba1266 100644 --- a/sources/FONTPROFILE +++ b/sources/FONTPROFILE @@ -1,19 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "13-Apr-2023 08:40:30" {DSK}larry>il>medley>sources>FONTPROFILE.;2 35652 +(FILECREATED "23-Jul-2023 20:42:48" {WMEDLEY}FONTPROFILE.;4 34903 - :EDIT-BY "lmm" + :EDIT-BY rmk - :CHANGES-TO (ALISTS (FONTDEFS HUGE) - (FONTDEFS BIG) - (FONTDEFS MEDIUM) - (FONTDEFS STANDARD) - (FONTDEFS BIGGER) - (FONTDEFS NS) - (FONTDEFS BIGGERNS)) - (VARS FONTPROFILECOMS) + :CHANGES-TO (FNS FONTSET) - :PREVIOUS-DATE " 6-Sep-2021 19:11:32" {DSK}larry>il>medley>sources>FONTPROFILE.;1) + :PREVIOUS-DATE "13-Apr-2023 08:40:30" {WMEDLEY}FONTPROFILE.;3) (PRETTYCOMPRINT FONTPROFILECOMS) @@ -459,7 +452,9 @@ (DEFINEQ (FONTSET - [LAMBDA (NAME CHANGE-WINDOWS?) (* ; "Edited 23-Jun-88 10:46 by jds") + [LAMBDA (NAME CHANGE-WINDOWS?) (* ; "Edited 23-Jul-2023 20:42 by rmk") + (* ; "Edited 23-Jun-88 10:46 by jds") + (DECLARE (SPECVARS NAME)) (COND [NAME (LET @@ -470,10 +465,10 @@ (* ;; "Looks up NAME on FONTSLST and sets apropriate parameters. entries are added to fontslst by FONTNAME.") (for X in FONTVARS when (AND (CL:SYMBOLP (CAR X)) - (NEQ (CAR X) - '*) - (NEQ (CAR X) - (CADR X))) do (SETTOPVAL (CAR X))) + (NEQ (CAR X) + '*) + (NEQ (CAR X) + (CADR X))) do (SETTOPVAL (CAR X))) [MAPC (CDR TEM) (FUNCTION (LAMBDA (X) (/SETTOPVAL (CAR X) @@ -481,60 +476,57 @@ [PROG (BASICCLASSES) (for X in FONTPROFILE do (PROG (SEEN (NAME (CAR X)) - (FONTS X)) - LP [COND - ((MEMB (CAR FONTS) - SEEN) - (ERROR "Circular font profile specification" X)) - (T (push SEEN (CAR FONTS] - [SETQ FONTS (CDR (COND - ((OR (NULL (CADR FONTS)) - (LISTP (CADR FONTS))) + (FONTS X)) + LP [COND + ((MEMB (CAR FONTS) + SEEN) + (ERROR "Circular font profile specification" X)) + (T (push SEEN (CAR FONTS] + [SETQ FONTS (CDR (COND + ((OR (NULL (CADR FONTS)) + (LISTP (CADR FONTS))) (*) (* ; - "This skips over the now-defunct NIL or list-of-escape sequence") - (CDR FONTS)) - (T FONTS] - (COND - ((OR (NLISTP FONTS) - (LITATOM (CAR FONTS)))(* ; - "Indirect thru another's font spec") - (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) - ((NIL DEFAULTFONT) + "This skips over the now-defunct NIL or list-of-escape sequence") + (CDR FONTS)) + (T FONTS] + (COND + ((OR (NLISTP FONTS) + (LITATOM (CAR FONTS))) (* ; "Indirect thru another's font spec") + (AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS)) + ((NIL DEFAULTFONT) (* ; - "Don't let DEFAULTFONT loop thru itself") - (AND (NOT (MEMB 'DEFAULTFONT SEEN - )) - 'DEFAULTFONT)) - (CAR FONTS)) - FONTPROFILE)) - (GO LP))) - (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS - 'DISPLAY] + "Don't let DEFAULTFONT loop thru itself") + (AND (NOT (MEMB 'DEFAULTFONT SEEN)) + 'DEFAULTFONT)) + (CAR FONTS)) + FONTPROFILE)) + (GO LP))) + (T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY] (* ; - "Now we have a font class datastructure") - )) - (AND NAME (/SETTOPVAL NAME FONTS)) + "Now we have a font class datastructure") + )) + (AND NAME (/SETTOPVAL NAME FONTS)) - (* ;; "NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.") + (* ;; "NIL for the class-name means just establish the font-correspondences but don't connect them up with a pretty class name.") - )) + )) (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY] [for X in FONTVARS when (NEQ (CAR X) - '*) + '*) do (COND - ((LISTP (CAR X)) - (EVAL (CAR X))) - [(CADDR X) - (SET (CAR X) - (FONTCREATE (OR (GETTOPVAL (CAR X)) - (EVAL (CADR X)) - DEFAULTFONT) - NIL NIL NIL 'DISPLAY] - (T (OR (GETTOPVAL (CAR X)) - (AND (CADR X) - (SET (CAR X) - (EVAL (CADR X] + ((LISTP (CAR X)) + (EVAL (CAR X))) + [(CADDR X) + (SET (CAR X) + (FONTCREATE (OR (GETTOPVAL (CAR X)) + (EVAL (CADR X)) + DEFAULTFONT) + NIL NIL NIL 'DISPLAY] + (T (OR (GETTOPVAL (CAR X)) + (AND (CADR X) + (SET (CAR X) + (EVAL (CADR X] (CL:WHEN CHANGE-WINDOWS? (CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY)) (for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X)) @@ -543,25 +535,25 @@ (SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT))) (MAPC CACHEDMENUS 'SET) [for W in (OPENWINDOWS) do [COND - [(OR (EQ (WINDOWPROP W 'RESHAPEFN) - 'DONT) - (WINDOWPROP W 'MAINWINDOW] - (T - (* ;; - "don't reshape if can't or if this window is attached to another.") - - (SHAPEW W (WINDOWREGION W] - (COND - ((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN) - (FUNCTION \TEDIT.PROCIDLEFN)) - (WINDOWPROP W 'REPAINTFN)) - (REDISPLAYW W]) + [(OR (EQ (WINDOWPROP W 'RESHAPEFN) + 'DONT) + (WINDOWPROP W 'MAINWINDOW] + (T + (* ;; + "don't reshape if can't or if this window is attached to another.") + + (SHAPEW W (WINDOWREGION W] + (COND + ((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN) + (FUNCTION \TEDIT.PROCIDLEFN)) + (WINDOWPROP W 'REPAINTFN)) + (REDISPLAYW W]) (* ;; "Set the new font profile name, and return the old one, so he can restore later.") (PROG1 FONTNAME (SETQ FONTNAME NAME] (T (* ; - "He passed in NIL, so return font profile name in effect.") + "He passed in NIL, so return font profile name in effect.") FONTNAME]) (FONTPROFILE @@ -700,6 +692,6 @@ (SETSEPR '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26) 1 FILERDTBL) (DECLARE%: DONTCOPY - (FILEMAP (NIL (21780 33364 (FONTSET 21790 . 28131) (FONTPROFILE 28133 . 30482) (FONTPROFILE.ADDDEVICE -30484 . 33362)) (33600 35499 (FONTMAPARRAY 33610 . 35497))))) + (FILEMAP (NIL (21437 32615 (FONTSET 21447 . 27382) (FONTPROFILE 27384 . 29733) (FONTPROFILE.ADDDEVICE +29735 . 32613)) (32851 34750 (FONTMAPARRAY 32861 . 34748))))) STOP diff --git a/sources/FONTPROFILE.LCOM b/sources/FONTPROFILE.LCOM index 5281a5228656fcfba79843c01269e26ff7d77302..c9d4f666ef8ef587d7b93ef9126e6df7c158c5e4 100644 GIT binary patch delta 378 zcmZ3Hc|LtYc)gLau2*S}u91O}v4W9-m5Gs+iKUW)hEj5VZb4>FYKlUBo`RA>b-1sq zi;rt$txa)$X;E@&v7MX0Ur0cZzniCztDd!qrUI7|vPp)fR>l@q24+eMNkyq}qf#ph zii%aO6hL}|T|*Qy^AzfpeB9g>khSXR=_x6sB$fcJMl}=YIwNx{BMT)>E)9^i&Oxq@ zA+9b8C>BG#U_sc)3dSau2FB(JR<16dA-YbH3Priu3Rcb@j(+a0!MY*-3L0E)e!(!e zYARR-1i6NJ`iBPVx&W=6Y|khuk3Ue1H_v6#U}fZ*e2o1%ketU6#K^VzBgb}a0172( AfB*mh delta 604 zcmb7B%TB^T6b%b}G-0p1n@J2Mrlb!*98Hr#htdd?bPB{J!UUSMloVJHWB36VCj5kn zOBVisdzXHNiJ#!0hE#Vh&$(yLJ#)|N=+S@ZtrSf%rm>{Tss?fy7i6p{2t+i9!l@sy zAw&~EaBI@5yUTGDGCk9^^BHjxF+X>oeh6x5jQDo(IonwbB>c; z!=;dDpz1Wa7Pno}wVe)?Onw0#-hz@u*>u~s0?Ij76s)QLZ&%s8q{MV8vwq)uOJ_t- UitDGt?D}Iro62mC4xUdx0p1s{1poj5