(FILECREATED " 9-Sep-86 15:56:00" {ERIS}<LISPCORE>BVM>COMMENT.;2 22707
changes to: (FNS PRINTFNDEF FINDFNDEF)
(VARS COMMENTCOMS)
previous date: "19-Jun-86 14:54:58" {ERIS}<LISPCORE>SOURCES>COMMENT.;4)
(* Copyright (c) 1983, 1984, 1986 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 [[COMS (* * PRINTFN)
(FNS PF PF* PMORE PRINTFN PRINTFNDEF FINDFNDEF)
(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 (GLOBALVARS FILERDTBL 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]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA PF* PF)
(NLAML)
(LAMA])
(* * 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) (* bvm: " 9-Sep-86 15:54")
(RESETLST (PROG (TEM)
[COND
((SETQ TEM (GETSTREAM DSTFIL (QUOTE OUTPUT)
T))
(SETQ DSTFIL TEM))
(T (RESETSAVE (SETQ DSTFIL (OPENSTREAM DSTFIL (QUOTE OUTPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
[COND
((SETQ TEM (GETSTREAM SRCFIL (QUOTE INPUT)
T))
(RESETSAVE NIL (LIST (QUOTE SETFILEPTR)
TEM
(GETFILEPTR TEM)))
(SETQ SRCFIL TEM))
(T (RESETSAVE (SETQ SRCFIL (OPENSTREAM SRCFIL (QUOTE INPUT)))
(QUOTE (PROGN (CLOSEF? OLDVALUE]
(PRIN1 "{from " DSTFIL)
(PRIN2 (FULLNAME SRCFIL)
DSTFIL T)
(PRIN1 "}
" DSTFIL))
(COND
((OR (NOT (DISPLAYP DSTFIL))
(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) (* bvm: "27-Aug-86 16:27")
(* * "Locates FNS definition of FN on FROMFILE. If found, returns a list (file start end type); if file not found, returns symbol FILE.NOT.FOUND; if file found but not fn, returns full name of file that was found")
(LET (FULL MAP VALUE)
(COND
((NOT (SETQ FULL (FINDFILE FROMFILE T)))
(QUOTE FILE.NOT.FOUND))
[(COND
((SETQ MAP (OR (GETFILEMAP FULL)
(LOADFILEMAP FULL)))
(* First clause is quick check when the file already has a map.
LOADFILEMAP will find file map, rebuild if necessary and rewrite it on file if
updatemapflg is T.)
(AND (for GROUP in (CDR MAP) thereis (SETQ VALUE (FASSOC FN GROUP)))
(LIST FULL (CADR VALUE)
(CDDR VALUE)
(QUOTE MAP]
(T FULL])
)
(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 (GLOBALVARS FILERDTBL 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))
]
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA PF* PF)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS COMMENT COPYRIGHT ("Xerox Corporation" T 1983 1984 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5318 10807 (PF 5328 . 7158) (PF* 7160 . 7358) (PMORE 7360 . 7683) (PRINTFN 7685 . 8287)
(PRINTFNDEF 8289 . 9735) (FINDFNDEF 9737 . 10805)) (11545 20249 (FONTSET 11555 . 12443) (FONTNAME
12445 . 13319) (FONTPROFILE 13321 . 18461) (FONTPROFILE1 18463 . 20247)))))
STOP