FONTPROFILE: specvars declaration for cleanliness (#1351)
This commit is contained in:
rmkaplan
GitHub
@@ -1,19 +1,12 @@
|
|||||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
(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)
|
:CHANGES-TO (FNS FONTSET)
|
||||||
(FONTDEFS BIG)
|
|
||||||
(FONTDEFS MEDIUM)
|
|
||||||
(FONTDEFS STANDARD)
|
|
||||||
(FONTDEFS BIGGER)
|
|
||||||
(FONTDEFS NS)
|
|
||||||
(FONTDEFS BIGGERNS))
|
|
||||||
(VARS FONTPROFILECOMS)
|
|
||||||
|
|
||||||
: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)
|
(PRETTYCOMPRINT FONTPROFILECOMS)
|
||||||
@@ -459,7 +452,9 @@
|
|||||||
(DEFINEQ
|
(DEFINEQ
|
||||||
|
|
||||||
(FONTSET
|
(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
|
(COND
|
||||||
[NAME
|
[NAME
|
||||||
(LET
|
(LET
|
||||||
@@ -470,10 +465,10 @@
|
|||||||
(* ;; "Looks up NAME on FONTSLST and sets apropriate parameters. entries are added to fontslst by FONTNAME.")
|
(* ;; "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))
|
(for X in FONTVARS when (AND (CL:SYMBOLP (CAR X))
|
||||||
(NEQ (CAR X)
|
(NEQ (CAR X)
|
||||||
'*)
|
'*)
|
||||||
(NEQ (CAR X)
|
(NEQ (CAR X)
|
||||||
(CADR X))) do (SETTOPVAL (CAR X)))
|
(CADR X))) do (SETTOPVAL (CAR X)))
|
||||||
[MAPC (CDR TEM)
|
[MAPC (CDR TEM)
|
||||||
(FUNCTION (LAMBDA (X)
|
(FUNCTION (LAMBDA (X)
|
||||||
(/SETTOPVAL (CAR X)
|
(/SETTOPVAL (CAR X)
|
||||||
@@ -481,60 +476,57 @@
|
|||||||
[PROG (BASICCLASSES)
|
[PROG (BASICCLASSES)
|
||||||
(for X in FONTPROFILE
|
(for X in FONTPROFILE
|
||||||
do (PROG (SEEN (NAME (CAR X))
|
do (PROG (SEEN (NAME (CAR X))
|
||||||
(FONTS X))
|
(FONTS X))
|
||||||
LP [COND
|
LP [COND
|
||||||
((MEMB (CAR FONTS)
|
((MEMB (CAR FONTS)
|
||||||
SEEN)
|
SEEN)
|
||||||
(ERROR "Circular font profile specification" X))
|
(ERROR "Circular font profile specification" X))
|
||||||
(T (push SEEN (CAR FONTS]
|
(T (push SEEN (CAR FONTS]
|
||||||
[SETQ FONTS (CDR (COND
|
[SETQ FONTS (CDR (COND
|
||||||
((OR (NULL (CADR FONTS))
|
((OR (NULL (CADR FONTS))
|
||||||
(LISTP (CADR FONTS)))
|
(LISTP (CADR FONTS)))
|
||||||
(*)
|
(*)
|
||||||
(* ;
|
(* ;
|
||||||
"This skips over the now-defunct NIL or list-of-escape sequence")
|
"This skips over the now-defunct NIL or list-of-escape sequence")
|
||||||
(CDR FONTS))
|
(CDR FONTS))
|
||||||
(T FONTS]
|
(T FONTS]
|
||||||
(COND
|
(COND
|
||||||
((OR (NLISTP FONTS)
|
((OR (NLISTP FONTS)
|
||||||
(LITATOM (CAR FONTS)))(* ;
|
(LITATOM (CAR FONTS))) (* ; "Indirect thru another's font spec")
|
||||||
"Indirect thru another's font spec")
|
(AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS))
|
||||||
(AND (SETQ FONTS (ASSOC (SELECTQ (CAR (LISTP FONTS))
|
((NIL DEFAULTFONT)
|
||||||
((NIL DEFAULTFONT)
|
|
||||||
(* ;
|
(* ;
|
||||||
"Don't let DEFAULTFONT loop thru itself")
|
"Don't let DEFAULTFONT loop thru itself")
|
||||||
(AND (NOT (MEMB 'DEFAULTFONT SEEN
|
(AND (NOT (MEMB 'DEFAULTFONT SEEN))
|
||||||
))
|
'DEFAULTFONT))
|
||||||
'DEFAULTFONT))
|
(CAR FONTS))
|
||||||
(CAR FONTS))
|
FONTPROFILE))
|
||||||
FONTPROFILE))
|
(GO LP)))
|
||||||
(GO LP)))
|
(T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS 'DISPLAY]
|
||||||
(T [push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS
|
|
||||||
'DISPLAY]
|
|
||||||
(* ;
|
(* ;
|
||||||
"Now we have a font class datastructure")
|
"Now we have a font class datastructure")
|
||||||
))
|
))
|
||||||
(AND NAME (/SETTOPVAL NAME FONTS))
|
(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]
|
(AND BASICCLASSES (FONTMAPARRAY BASICCLASSES 'DISPLAY]
|
||||||
[for X in FONTVARS when (NEQ (CAR X)
|
[for X in FONTVARS when (NEQ (CAR X)
|
||||||
'*)
|
'*)
|
||||||
do (COND
|
do (COND
|
||||||
((LISTP (CAR X))
|
((LISTP (CAR X))
|
||||||
(EVAL (CAR X)))
|
(EVAL (CAR X)))
|
||||||
[(CADDR X)
|
[(CADDR X)
|
||||||
(SET (CAR X)
|
(SET (CAR X)
|
||||||
(FONTCREATE (OR (GETTOPVAL (CAR X))
|
(FONTCREATE (OR (GETTOPVAL (CAR X))
|
||||||
(EVAL (CADR X))
|
(EVAL (CADR X))
|
||||||
DEFAULTFONT)
|
DEFAULTFONT)
|
||||||
NIL NIL NIL 'DISPLAY]
|
NIL NIL NIL 'DISPLAY]
|
||||||
(T (OR (GETTOPVAL (CAR X))
|
(T (OR (GETTOPVAL (CAR X))
|
||||||
(AND (CADR X)
|
(AND (CADR X)
|
||||||
(SET (CAR X)
|
(SET (CAR X)
|
||||||
(EVAL (CADR X]
|
(EVAL (CADR X]
|
||||||
(CL:WHEN CHANGE-WINDOWS?
|
(CL:WHEN CHANGE-WINDOWS?
|
||||||
(CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY))
|
(CL:WHEN (NEQ OLDDEFAULT (FONTCREATE DEFAULTFONT NIL NIL NIL 'DISPLAY))
|
||||||
(for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X))
|
(for X in (OPENWINDOWS) when (EQ OLDDEFAULT (DSPFONT NIL X))
|
||||||
@@ -543,25 +535,25 @@
|
|||||||
(SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT)))
|
(SETQ MaxValueLeftMargin (ITIMES 35 (STRINGWIDTH 'A DEFAULTFONT)))
|
||||||
(MAPC CACHEDMENUS 'SET)
|
(MAPC CACHEDMENUS 'SET)
|
||||||
[for W in (OPENWINDOWS) do [COND
|
[for W in (OPENWINDOWS) do [COND
|
||||||
[(OR (EQ (WINDOWPROP W 'RESHAPEFN)
|
[(OR (EQ (WINDOWPROP W 'RESHAPEFN)
|
||||||
'DONT)
|
'DONT)
|
||||||
(WINDOWPROP W 'MAINWINDOW]
|
(WINDOWPROP W 'MAINWINDOW]
|
||||||
(T
|
(T
|
||||||
(* ;;
|
(* ;;
|
||||||
"don't reshape if can't or if this window is attached to another.")
|
"don't reshape if can't or if this window is attached to another.")
|
||||||
|
|
||||||
(SHAPEW W (WINDOWREGION W]
|
(SHAPEW W (WINDOWREGION W]
|
||||||
(COND
|
(COND
|
||||||
((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN)
|
((AND (NEQ (WINDOWPROP W 'WINDOWENTRYFN)
|
||||||
(FUNCTION \TEDIT.PROCIDLEFN))
|
(FUNCTION \TEDIT.PROCIDLEFN))
|
||||||
(WINDOWPROP W 'REPAINTFN))
|
(WINDOWPROP W 'REPAINTFN))
|
||||||
(REDISPLAYW W])
|
(REDISPLAYW W])
|
||||||
|
|
||||||
(* ;; "Set the new font profile name, and return the old one, so he can restore later.")
|
(* ;; "Set the new font profile name, and return the old one, so he can restore later.")
|
||||||
|
|
||||||
(PROG1 FONTNAME (SETQ FONTNAME NAME]
|
(PROG1 FONTNAME (SETQ FONTNAME NAME]
|
||||||
(T (* ;
|
(T (* ;
|
||||||
"He passed in NIL, so return font profile name in effect.")
|
"He passed in NIL, so return font profile name in effect.")
|
||||||
FONTNAME])
|
FONTNAME])
|
||||||
|
|
||||||
(FONTPROFILE
|
(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)
|
(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)
|
1 FILERDTBL)
|
||||||
(DECLARE%: DONTCOPY
|
(DECLARE%: DONTCOPY
|
||||||
(FILEMAP (NIL (21780 33364 (FONTSET 21790 . 28131) (FONTPROFILE 28133 . 30482) (FONTPROFILE.ADDDEVICE
|
(FILEMAP (NIL (21437 32615 (FONTSET 21447 . 27382) (FONTPROFILE 27384 . 29733) (FONTPROFILE.ADDDEVICE
|
||||||
30484 . 33362)) (33600 35499 (FONTMAPARRAY 33610 . 35497)))))
|
29735 . 32613)) (32851 34750 (FONTMAPARRAY 32861 . 34748)))))
|
||||||
STOP
|
STOP
|
||||||
|
|||||||
Binary file not shown.
Reference in New Issue
Block a user