(FILECREATED "20-Sep-84 11:24:51" {ERIS}<LISPCORE>SOURCES>COMMENT.;8 19377
changes to: (FNS FONTPROFILE)
previous date: "14-Sep-84 23:59:54" {ERIS}<LISPCORE>SOURCES>COMMENT.;7)
(* Copyright (c) 1983, 1984 by Xerox Corporation. All rights reserved. The following program was
created in 1983 but has not been published within the meaning of the copyright law, is furnished
under license, and may not be used, copied and/or disclosed except in accordance with the terms of
said license.)
(PRETTYCOMPRINT COMMENTCOMS)
(RPAQQ COMMENTCOMS [(VARS LCASELST UCASELST ABBREVLST)
[COMS (* * PRINTFN)
(FNS PF PF* PMORE PRINTFN PRINTFNDEF FINDFNDEF SEARCHFILEMAP)
(E (* currently PFDEFAULT has 3 possible settings: COPYBYTES means always
use COPYBYTES to print the functions. - NIL means use the PFCOPYBYTES
function, which prints comments as **COMMENT**FLG, and reduces the
spacing from the left margin by 1/2 and gets rid of the changechar
indicators. - PFDEFAULT=T uses PFCOPYBYTES, but leaves the spacing
as-is))
(INITVARS PFDEFAULT (LASTFNDEF))
(P (MOVD? (QUOTE COPYBYTES)
(QUOTE PFCOPYBYTES)))
(USERMACROS PF)
(PROP MAC SUBR)
(BLOCKS (NIL PRINTFN PF PF* PMORE PRINTFNDEF (LOCALVARS . T)
(GLOBALVARS **COMMENT**FLG LASTFNDEF LASTWORD PFDEFAULT
FILERDTBL))
(NIL FINDFNDEF FINDSUBRDEF FINDBCPLDEF SEARCHFILEMAP
(GLOBALVARS FILERDTBL BUILDMAPFLG USEMAPFLG)
(NOLINKFNS . T]
[COMS (* * FONT)
(FNS FONTSET FONTNAME FONTPROFILE FONTPROFILE1)
(INITVARS (FONTESCAPECHAR (CHARACTER 6))
(FONTFNS)
(FONTWORDS))
(VARS FONTDEFSVARS)
[ADDVARS (FONTSETUPFNS)
(FONTDEFS (STANDARD (FONTCHANGEFLG)
(FILELINELENGTH . 72)
(COMMENTLINELENGTH . 72)
(LAMBDAFONTLINELENGTH . 72)
(FIRSTCOL . 48)
(PRETTYLCOM . 14)
(LISTFILESTR . "
")
(FONTPROFILE (DEFAULTFONT)
(USERFONT)
(COMMENTFONT)
(LAMBDAFONT)
(SYSTEMFONT)
(CLISPFONT)
(CHANGEFONT)
(PRETTYCOMFONT)
(BIGFONT)
(LITTLEFONT)
(BOLDFONT)))
(SMALL (FONTCHANGEFLG)
(FILELINELENGTH . 96)
(COMMENTLINELENGTH . 96)
(LAMBDAFONTLINELENGTH . 96)
(FIRSTCOL . 60)
(PRETTYLCOM . 14)
(LISTFILESTR . "
")
(FONTPROFILE (DEFAULTFONT)
(USERFONT)
(COMMENTFONT)
(LAMBDAFONT)
(SYSTEMFONT)
(CLISPFONT)
(CHANGEFONT)
(PRETTYCOMFONT)
(BIGFONT)
(LITTLEFONT)
(BOLDFONT]
[DECLARE: DONTEVAL@LOAD DOCOPY (P (FONTSET (QUOTE STANDARD]
(BLOCKS (NIL FONTSET FONTNAME FONTPROFILE FONTPROFILE1 (LOCALVARS . T)
(GLOBALVARS FONTPROFILE FONTCHANGEFLG FONTESCAPECHAR FONTDEFS
FONTDEFSVARS]
(COMS (* Some prettyprint macros)
(FNS LONGLAMBDA.PPMACRO LONGPROGN.PPMACRO))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA PF* PF)
(NLAML)
(LAMA])
(RPAQQ LCASELST (A ADD AN AND ARRAY ARRAYS AS ATOM ATOMIC ATOMS ATTACH BETWEEN BY CALLS CHARACTER
CHART COLLECT COMMENT CONTROL COPY COUNT CREATE DEFINE DIFFERENCE DISPLAY DIVIDE
DO E EDIT EITHER ELSE EQ EQUAL EQUALS ERROR EVERY FINALLY FIRST FIX FIXED FLOATING
FOR FROM FUNCTION GET GO GREATER HELP IF IN INPUT INTEGER INTEGERS IS JOIN LAST
LENGTH LESS LIST LISTS LITATOM LITATOMS LITERAL MARK MEMB MEMBER MEMBERS MINUS
MIXED MOVE MOVES NEGATIVE NOT NTH NULL NUMBER NUMBERS OF OLD ON OR OUTPUT PLUS
POINT POSITION PRETTY PRINT PUSH PUT QUIT READ REMOVE RESET RESTORE RESULTS RETURN
REVERSE SAVED SET SIDE SKIP SMALL SOME SORT START STRING STRINGS TAIL THAN THE
THEN THRU TIME TIMES TO UNLESS UNTIL USED VARIABLES WHEN WHERE WHILE))
(RPAQQ UCASELST NIL)
(RPAQQ ABBREVLST (ETC. I.E. E.G. etc. i.e. e.g.))
(* * PRINTFN)
(DEFINEQ
(PF
[NLAMBDA FN (* lmm "14-Aug-84 19:13")
(RESETLST
(* Print from files known to masterscope database before looking at whereis database. Note, however, that it also
prefers the masterscope database to incore files)
(PROG (OUT OTHERARGS)
(SETQ FN (NLAMBDA.ARGS FN))
[COND
((LISTP FN)
(SETQ OTHERARGS (CDR FN))
(SETQ FN (CAR FN]
(COND
(FN (SETQ LASTWORD FN))
(T (SETQ FN LASTWORD)))
[RESETSAVE (OUTPUT (COND
((CADR OTHERARGS)
(OR (OPENP (CADR OTHERARGS)
(QUOTE OUTPUT))
(PROGN [RESETSAVE (SETQ OUT (OPENFILE (CADR OTHERARGS)
(QUOTE OUTPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
OUT)))
(T T]
(COND
((CAR OTHERARGS)
(for FILE inside (CAR OTHERARGS) do (PRINTFN FN FILE)))
(T (WHEREIS FN (QUOTE FNS)
T
(FUNCTION PRINTFN])
(PF*
[NLAMBDA FN (* lmm "30-MAR-78 23:40")
(RESETVARS (**COMMENT**FLG)
(APPLY (FUNCTION PF)
FN])
(PMORE
(LAMBDA NIL (* lmm " 9-AUG-78 17:21")
(* lmm "17-MAY-78 15:38")
(PRINTFNDEF (CAR LASTFNDEF)
T
(CADDR LASTFNDEF)
-1
(CADDDR LASTFNDEF))))
(PRINTFN
[LAMBDA (FN FROMFILE TOFILE) (* lmm "14-Aug-84 14:16")
(PROG ((LOC (FINDFNDEF FN FROMFILE)))
(COND
((LISTP LOC)
(SETQ LASTFNDEF LOC)
(PRINTFNDEF (CAR LOC)
TOFILE
(CADR LOC)
(CADDR LOC)
(CADDDR LOC))
(RETURN FN))
((EQ LOC (QUOTE FILE.NOT.FOUND))
(printout TOFILE "file " FROMFILE " not found." T))
(T (printout TOFILE FN " not found on " LOC "." T])
(PRINTFNDEF
[LAMBDA (SRCFIL DSTFIL START END TYPE) (* lmm "27-Aug-84 23:33")
(RESETLST (PROG (TEM)
[COND
((NULL DSTFIL)
(SETQ DSTFIL (OUTPUT)))
((SETQ TEM (OPENP DSTFIL))
(SETQ DSTFIL TEM))
(T (RESETSAVE (SETQ DSTFIL (OPENFILE DSTFIL (QUOTE OUTPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
[COND
((SETQ TEM (OPENP SRCFIL (QUOTE INPUT)))
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
TEM
(GETFILEPTR TEM)))
(SETQ SRCFIL TEM))
(T (RESETSAVE (SETQ SRCFIL (OPENFILE SRCFIL (QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(PRIN1 "{from " DSTFIL)
(PRIN2 SRCFIL DSTFIL T)
(PRIN1 "}
" DSTFIL))
(COND
((OR (NEQ DSTFIL T)
(EQ PFDEFAULT (QUOTE COPYBYTES))
(EQ TYPE (QUOTE MAC)))
(COPYBYTES SRCFIL DSTFIL START END))
(T (PFCOPYBYTES SRCFIL DSTFIL START END PFDEFAULT)))
(TERPRI DSTFIL])
(FINDFNDEF
[LAMBDA (FN FROMFILE) (* lmm "14-Aug-84 14:16")
(PROG (FULL ST TEM MAP)
[COND
((NOT (SETQ FULL (FINDFILE FROMFILE T)))
(RETURN (QUOTE FILE.NOT.FOUND]
(RETURN (OR [if (AND USEMAPFLG (SETQ MAP (GETPROP (ROOTFILENAME FULL)
(QUOTE FILEMAP)))
(EQ FULL (CAR MAP)))
then (* quick check when the file already has a map)
(SEARCHFILEMAP FN MAP)
else (RESETLST [RESETSAVE NIL (LIST (QUOTE CLOSEF?)
(SETQ FULL (OPENFILE FULL (QUOTE INPUT)
(QUOTE OLD]
(RESETSAVE (SETREADTABLE FILERDTBL))
(COND
((SETQ ST (LISPSOURCEFILEP FULL))
(COND
([AND USEMAPFLG [PROG ([ERRORTYPELST
(QUOTE ((16 (ERROR!]
TEM)
(DECLARE (SPECVARS ERRORTYPELST))
(SETFILEPTR FULL ST)
(* next expression checks to make sure FILEMAP is valid, e.g. file may have been ftped reason for the errorset is
if file map is not valid, may read off of end of file.)
[NLSETQ (PROGN (READC FULL
FILERDTBL)
(SETQ TEM
(RATOM FULL
FILERDTBL]
(RETURN (EQ TEM (QUOTE FILEMAP]
(SETQ ST (FFILEPOS (CONCAT " (" FN " ")
FULL ST NIL NIL NIL (SEPRCASE)))
(OR (EQ (RATOM FULL FILERDTBL)
FN)
(EQ (RATOM FULL FILERDTBL)
FN))
(FIXP (SETQ ST (RATOM FULL FILERDTBL)))
(EQ (RATOM FULL FILERDTBL)
(QUOTE %.))
(FIXP (SETQ TEM (RATOM FULL FILERDTBL]
(LIST FULL ST TEM (QUOTE SCAN)))
((AND BUILDMAPFLG (SETQ MAP (LOADFILEMAP FULL)))
(* will rebuild filemap. rewrite it on file if
updatemapflg is T.)
(SEARCHFILEMAP FN (LIST FULL MAP]
FULL])
(SEARCHFILEMAP
(LAMBDA (FN MAP) (* lmm " 9-AUG-78 17:20")
(PROG (VALUE)
(AND (SOME (CDADR MAP)
(FUNCTION (LAMBDA (X)
(SETQ VALUE (FASSOC FN X)))))
(RETURN (LIST (CAR MAP)
(CADR VALUE)
(CDDR VALUE)
(QUOTE MAP)))))))
)
(RPAQ? PFDEFAULT NIL)
(RPAQ? LASTFNDEF )
(MOVD? (QUOTE COPYBYTES)
(QUOTE PFCOPYBYTES))
(ADDTOVAR EDITMACROS [PF NIL (ORR [(E (APPLY* (QUOTE PF)
(FIRSTATOM (##]
((E (QUOTE PF?])
(ADDTOVAR EDITCOMSA PF)
(PUTPROPS SUBR MAC ((ATHASH LISP GC SWAP BYTE)
(NEWLISP LISP NETLISP)
(LISP "ATM <" ">," 250000 LISP)))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL PRINTFN PF PF* PMORE PRINTFNDEF (LOCALVARS . T)
(GLOBALVARS **COMMENT**FLG LASTFNDEF LASTWORD PFDEFAULT FILERDTBL))
(BLOCK: NIL FINDFNDEF FINDSUBRDEF FINDBCPLDEF SEARCHFILEMAP (GLOBALVARS FILERDTBL BUILDMAPFLG
USEMAPFLG)
(NOLINKFNS . T))
]
(* * FONT)
(DEFINEQ
(FONTSET
[LAMBDA (NAME) (* rmk: "22-NOV-81 14:36")
(PROG (TEM)
(RETURN (COND
((SETQ TEM (FASSOC NAME FONTDEFS)) (* Looks up NAME on FONTSLST and sets
apropriate parameters.
entries are added to fontslst by
FONTNAME.)
[MAPC (CDR TEM)
(FUNCTION (LAMBDA (X)
(/SETATOMVAL (CAR X)
(CDR X]
(FONTPROFILE FONTPROFILE)
(SETQ FONTNAME NAME))
(T (ERROR NAME "not a defined font configuration"])
(FONTNAME
[LAMBDA (NAME) (* lmm "28-MAR-83 12:00")
(* Defines NAME to correspond to current setting of various parameters, and adds
to FONTDEFS)
(PROG [TEM (L (CONS NAME (MAPCAR FONTDEFSVARS (FUNCTION (LAMBDA (X)
(CONS X (GETATOMVAL X]
(RETURN (COND
[(SETQ TEM (FASSOC NAME FONTDEFS))
(/RPLACD TEM (CDR L))
(RETURN (LIST NAME (QUOTE redefined]
(T (/SETATOMVAL (QUOTE FONTDEFS)
(CONS L FONTDEFS))
NAME])
(FONTPROFILE
[LAMBDA (PROFILE) (* rmk: "19-Sep-84 15:19")
(* The user defines a font configurationby setting the variables DEFAULTFONT, CLISPFONT, SYSTEMFONT, USERFONT,
LAMBDAFONT, COMMENTFONT. If non-NIL they define the font to be used on corresonding class of WORDS as follows:
(1 words) CLISPFONT is font to be used on cispwords, USERFONT all members of the list FONTFNS, or if FONTFNS=T, all
members of FILEFNS. USERFONT also applies to all members of FONTWORDS, initially NIL. SYSTEMFONT used for other
functions. COMMENTFONT for printing comments, and LAMBDAFONT for printing the function name before its definition.
The same font name can be given to more than one of th above, although there is a limit on the xgp of 3 fonts.
The psuedo-font UNDERLINE is also avaiaable, e.g. CLISPFONT=UNDERLINE means underline all clispwords.)
(DECLARE (GLOBALVARS FONTSETUPFNS))
[PROG (BASICCLASSES)
(for X in PROFILE
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)))
(* 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 (QUOTE DEFAULTFONT)
SEEN))
(QUOTE DEFAULTFONT)))
(CAR FONTS))
PROFILE))
(GO LP)))
(T [SELECTQ (SYSTEMTYPE)
[D (AND NAME (pushnew GLOBALVARS NAME))
(* Can't apply GLOBALVARS, cause it doesn't exist at
this point in loadup)
(push BASICCLASSES (SETQ FONTS (FONTCLASS NAME FONTS
(QUOTE DISPLAY]
(PROGN (push BASICCLASSES (CONS NAME FONTS))
(SETQ FONTS (FONTPROFILE1 NAME FONTS]
(* Now we have a font class datastructure)
))
(AND NAME (/SETATOMVAL NAME FONTS)) (* NIL for the class-name means just establish the
font-correspondences but don't connect them up with a
pretty class name.)
(RETURN)))
(SELECTQ (SYSTEMTYPE)
[D (AND BASICCLASSES (FONTMAPARRAY BASICCLASSES (QUOTE DISPLAY]
(for SETUP in FONTSETUPFNS
do
(* FONTSETUPFNS supplies device-dependent fontsetup functions. CADDR of the elements on FONTSETUPFNS are executed
after all fonts have been processed. This is used typically to set up inverse mappings between font numbers and
device-dependent fonts The CADR is executed in FONTPROFILE1 on each element to produce individual descriptors.)
(AND (CADDR SETUP)
(APPLY* (CADDR SETUP)
BASICCLASSES]
T])
(FONTPROFILE1
[LAMBDA (NAME FONTLIST) (* rmk: "12-Sep-84 16:08")
(* Internalizes a FONTLIST of user-readable font specifications for various devices. The device-dependent setup
information is obtained from the alist FONTSETUPFNS, which can be initialized to NIL when only symbolic file
escape sequences are specified. Otherwise, the elements of FONTSETUPFNS are of the form (eltnum eltfn inversefn),
where eltnum is the number of the element in FONTLIST for that device, eltfn is applied to that element to produce
the corresponding element in the fontclass, and inversefn is applied to build the inverse mapping from numbers to
fonts, for use by functions that interpret a symbolic file, e.g. PFCOPYBYTES, MAKEINTERPRESS.
The results are ordered in the fontclass according to the eltnums.)
(DECLARE (GLOBALVARS FONTSETUPFNS FONTESCAPECHAR))
(CONS [AND (FIXP (CAR FONTLIST))
(PACK* FONTESCAPECHAR (CHARACTER (CAR FONTLIST]
(for SETUP FONT in (SORT FONTSETUPFNS T) collect (COND
([NULL (SETQ FONT
(CAR (NTH FONTLIST
(CAR SETUP]
(* No spec for this device)
NIL)
((CADR SETUP)
(* NAME enables, e.g., global var declarations.)
(APPLY* (CADR SETUP)
NAME FONT))
(T (ERROR "illegal font specification"
FONT])
)
(RPAQ? FONTESCAPECHAR (CHARACTER 6))
(RPAQ? FONTFNS )
(RPAQ? FONTWORDS )
(RPAQQ FONTDEFSVARS (FONTCHANGEFLG FILELINELENGTH COMMENTLINELENGTH FIRSTCOL PRETTYLCOM LISTFILESTR
FONTPROFILE FONTESCAPECHAR))
(ADDTOVAR FONTSETUPFNS )
(ADDTOVAR FONTDEFS (STANDARD (FONTCHANGEFLG)
(FILELINELENGTH . 72)
(COMMENTLINELENGTH . 72)
(LAMBDAFONTLINELENGTH . 72)
(FIRSTCOL . 48)
(PRETTYLCOM . 14)
(LISTFILESTR . "
")
(FONTPROFILE (DEFAULTFONT)
(USERFONT)
(COMMENTFONT)
(LAMBDAFONT)
(SYSTEMFONT)
(CLISPFONT)
(CHANGEFONT)
(PRETTYCOMFONT)
(BIGFONT)
(LITTLEFONT)
(BOLDFONT)))
(SMALL (FONTCHANGEFLG)
(FILELINELENGTH . 96)
(COMMENTLINELENGTH . 96)
(LAMBDAFONTLINELENGTH . 96)
(FIRSTCOL . 60)
(PRETTYLCOM . 14)
(LISTFILESTR . "
")
(FONTPROFILE (DEFAULTFONT)
(USERFONT)
(COMMENTFONT)
(LAMBDAFONT)
(SYSTEMFONT)
(CLISPFONT)
(CHANGEFONT)
(PRETTYCOMFONT)
(BIGFONT)
(LITTLEFONT)
(BOLDFONT))))
(DECLARE: DONTEVAL@LOAD DOCOPY
(FONTSET (QUOTE STANDARD))
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL FONTSET FONTNAME FONTPROFILE FONTPROFILE1 (LOCALVARS . T)
(GLOBALVARS FONTPROFILE FONTCHANGEFLG FONTESCAPECHAR FONTDEFS FONTDEFSVARS))
]
(* Some prettyprint macros)
(DEFINEQ
(LONGLAMBDA.PPMACRO
[LAMBDA (FORM) (* bvm: " 2-MAR-83 15:35")
(* Prettyprintmacro for forms whose CAR is a long word and look like a lambda--first arg wants to be on first
line, others after it)
(COND
((AND (LISTP FORM)
(LISTP (CDR FORM))
(LISTP (CDDR FORM)))
(PROG [(POS (IPLUS 4 (POSITION]
(PRIN1 "(")
(PRIN2 (CAR FORM))
(SPACES 1)
(PRINTDEF (CADR FORM)
(POSITION))
(OR [EQ COMMENTFLG (CAAR (SETQ FORM (CDDR FORM]
(TAB POS 0))
(PRINTDEF FORM POS T T FNSLST)
(PRIN1 ")")
(RETURN NIL)))
(T FORM])
(LONGPROGN.PPMACRO
[LAMBDA (FORM) (* bvm: " 2-MAR-83 15:37")
(* Prettyprintmacro for forms whose CAR is a long word
and look like a progn--all args equal weight, one below
another)
(COND
((AND (LISTP FORM)
(LISTP (CDR FORM)))
(PROG [(POS (IPLUS 4 (POSITION]
(PRIN1 "(")
(PRIN2 (CAR FORM))
(OR [EQ COMMENTFLG (CAAR (SETQ FORM (CDR FORM]
(TAB POS 0))
(PRINTDEF FORM POS T T FNSLST)
(PRIN1 ")")
(RETURN NIL)))
(T FORM])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA PF* PF)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS COMMENT COPYRIGHT ("Xerox Corporation" T 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (4100 9336 (PF 4110 . 5105) (PF* 5107 . 5265) (PMORE 5267 . 5544) (PRINTFN 5546 . 6036)
(PRINTFNDEF 6038 . 6989) (FINDFNDEF 6991 . 9012) (SEARCHFILEMAP 9014 . 9334)) (10032 16364 (FONTSET
10042 . 10581) (FONTNAME 10583 . 11129) (FONTPROFILE 11131 . 14767) (FONTPROFILE1 14769 . 16362)) (
17838 19154 (LONGLAMBDA.PPMACRO 17848 . 18513) (LONGPROGN.PPMACRO 18515 . 19152)))))
STOP