FONTPROFILE: specvars declaration for cleanliness (#1351)
This commit is contained in:
rmkaplan
GitHub
parent
adc27d9684
commit
f6c91ee11c
@ -1,19 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "13-Apr-2023 08:40:30" {DSK}<home>larry>il>medley>sources>FONTPROFILE.;2 35652
|
||||
(FILECREATED "23-Jul-2023 20:42:48" {WMEDLEY}<sources>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}<home>larry>il>medley>sources>FONTPROFILE.;1)
|
||||
:PREVIOUS-DATE "13-Apr-2023 08:40:30" {WMEDLEY}<sources>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.")
|
||||
[(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])
|
||||
(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
|
||||
|
||||
Binary file not shown.
Loading…
x
Reference in New Issue
Block a user