(FILECREATED " 4-Jun-86 18:32:25" {ERIS}<LISPCORE>SOURCES>PRETTY.;28 76490
changes to: (VARS PRETTYCOMS)
previous date: " 4-Feb-86 16:27:13" {ERIS}<LISPCORE>SOURCES>PRETTY.;27)
(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved. The following program was
created in 1984 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 PRETTYCOMS)
(RPAQQ PRETTYCOMS
[(FNS PRETTYDEF PRETTYDEF0 PRETTYDEF1 PRINTDATE PRINTDATE1 PRINTFNS PRETTYCOM PRETTYCOMPRINT
PRETTYVAR PRETTYVAR1 PRETTYCOM1 ENDFILE MAKEDEFLIST PP PP* PPT PRETTYPRINT PRETTYPRINT1
PRETTYPRINT2 PRINTDEF1 SUPERPRINTEQ SUPERPRINTGETPROP CHANGEFONT READARRAY)
(COMS (DECLARE: DONTCOPY (MACROS CHANGFONT)))
(COMS (* COPYRIGHT)
(FNS PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT)
(BLOCKS (NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T)
(NOLINKFNS PRINTCOPYRIGHT1)))
(GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER
COPYRIGHTSRESERVED)
(INITVARS (COPYRIGHTFLG)
(DEFAULTCOPYRIGHTOWNER)
(COPYRIGHTPRETTYFLG T)
(COPYRIGHTOWNERS)
[DEFAULTCOPYRIGHTKEYLST (QUOTE ((NONE "
" EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN (QUOTE NONE))
[%[ "owner: " EXPLAINSTRING
"[ - new copyright owner -- type one line of text"
NOECHOFLG T KEYLST
(( "
" RETURN (SUBSTRING (CADR ANSWER)
2 -2]
(%] "No copyright notice now
" EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL]
(COPYRIGHTSRESERVED T))
(GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG))
(INITVARS (BRLST)
(COMMENTFLG (QUOTE *))
(**COMMENT**FLG (QUOTE " **COMMENT** "))
(PRETTYFLG T)
(#RPARS 4)
(CLISPIFYPRETTYFLG)
(PRETTYTRANFLG)
(FONTCHANGEFLG)
(CHANGECHARTABSTR)
(PRETTYTABFLG T)
(DECLARETAGSLST (QUOTE (COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD
DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE
EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)
))
(WIDEPAPERFLG)
(AVERAGEVARLENGTH 4)
(AVERAGEFNLENGTH 5)
(#CAREFULCOLUMNS 0)
(CHANGECHAR (QUOTE %|))
(LASTFONT)
(ENDLINEUSERFN))
[INITVARS (PRETTYDEFMACROS)
(PRETTYPRINTMACROS)
(PRETTYEQUIVLST)
(PRETTYPRINTYPEMACROS)
(FILEPKGCOMSPLST (QUOTE (DECLARE: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS
INITVARS ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL
ADVISE ADVICE BLOCKS *)))
(SYSPROPS (QUOTE (PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN
NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN
ACS ADVICE ADVISED ALIAS AMAC ARGNAMES BLKLIBRARYDEF BRKINFO
BROADSCOPE BROKEN BROKEN-IN CLISPCLASS CLISPCLASSDEF CLISPFORM
CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG
CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE
EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP
FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR
I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS
OLDVALUE OPD READVICE SETFN SUBR UBOX UNARYOP VALUE \DEF
CLISPBRACKET TRYHARDER]
(DECLARE: DONTCOPY EVAL@COMPILE (FILES (IMPORT)
FILEPKG))
(BLOCKS (PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT)
(SPECVARS FNSLST FILEFLG)))
(GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG
LAMBDAFONTLINELENGTH PRETTYCOMFONT PRETTYHEADER BUILDMAPFLG FILERDTBL
NORMALCOMMENTSFLG CHANGEFONT PRETTYEQUIVLST PRETTYPRINTMACROS PRETTYTRANFLG
**COMMENT**FLG FILEPKGFLG FONTCHANGEFLG DEFAULTFONT LAMBDAFONT CLISPIFYPRETTYFLG
LISPXHISTORY DWIMFLG USERWORDS ADDSPELLFLG COMMENTFLG)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP)
(NLAML PRETTYCOMPRINT)
(LAMA])
(DEFINEQ
(PRETTYDEF
[LAMBDA (PRTTYFNS PRTTYFILE PRTTYCOMS REPRINTFNS SOURCEFILE CHANGES)
(* lmm "27-Aug-84 23:06")
(RESETLST [RESETSAVE (RESETUNDO)
(QUOTE (AND RESETSTATE (RESETUNDO OLDVALUE]
(* Says undo everything if there is an error or control-D This is particularly
necessary if user is using the PRINT* prettyprintmacro which updates comments
to point to the newest version.)
(PROG ((PRTYX (OUTPUT))
FILEFLG FNSLST PRTYOPENFLG PRTTYTEM PRETTYCOMSLST PRTTYSPELLFLG OLDFILEMAP
(NEWFILEMAP (AND BUILDMAPFLG (LIST NIL)))
MAPADR NLAMALST NLAMLST LAMALST LAM?LST FILEDATES ORIGFLG ROOTNAME)
(* NEWFILEMAP corresponds to the map
being built for the file being
written. OLDFILEMAP corresponds to the
map that exists for SOURCEFILE, if
any.)
(COND
((LISTP PRTTYFILE)
(SETQ PRTTYFILE (CAR PRTTYFILE))
(SETQ PRTYOPENFLG T)))
(AND PRTTYFILE (NEQ PRTTYFILE T)
(LITATOM PRTTYFILE)
(SETQ ROOTNAME (ROOTFILENAME PRTTYFILE)))
(COND
((OR (EQ SOURCEFILE T)
(AND REPRINTFNS (NULL SOURCEFILE)))
(* SOURCEFILE plays the role of CFILE for recompiling.
It permits PRETTYPRINT to obtain the definitions from the file withou having to
reprettyprint them, or even having them loaded into core.
T (or NIL if REPRINTFNS is specified) is the same as PRETTYFILE.
-
REPRINTFNS specifies those functions to be printed anew.
REPRINTFNS=T means reprint all EXPRS, a la recompile.
For example, if you have an entire file loaded in, but only change a few
functions, using this option can speed up dumping the file by a factor of two.
If REPRINTFNS=ALL, all functions that contain in core exprs, whether on
function defiition cell or property lists, are reprinted.
REPRINTFNS can also be a list. MAKEFILE uses this for the REMAKE option by
specifying as REPRINTFNS the list CHANGES.
In any case, if the function does not contain an in core defnition, prettyprint
will try to find one on the file. i.e. act as though REPRINTFNS were NIL.)
(SETQ SOURCEFILE ROOTNAME)))
[COND
(SOURCEFILE (COND
((NULL (XNLSETQ (INFILE SOURCEFILE)
NOBREAK)) (* INFILE is called in order that
'correction' take place.)
(SETQ SOURCEFILE NIL)
(PRIN1 PRTTYFILE T)
(PRIN1 (QUOTE " not found, so it will be written anew.
")
T))
[(RANDACCESSP (SETQ SOURCEFILE (INPUT)))
(RESETSAVE NIL (LIST (QUOTE CLOSEF)
SOURCEFILE))
[COND
((EQ REPRINTFNS (QUOTE EXPRS))
(SETQ REPRINTFNS T))
((EQ REPRINTFNS (QUOTE CHANGES))
(SETQ REPRINTFNS (UNION (FILEPKG.CHANGEDFNS CHANGES)
(FILEPKG.CHANGEDFNS (fetch
FILECHANGES
of ROOTNAME]
(COND
[(NULL (SETQ OLDFILEMAP (GETFILEMAP SOURCEFILE (ROOTFILENAME
SOURCEFILE]
((NULL (CAR OLDFILEMAP))
(* complete map.)
)
((LISTP (CAR OLDFILEMAP))
(* only partial map built up. should only happen for files that were made with
BUILDMAPFLG=NIL, since otherwise there would be a coplete map on the file.)
(SETFILEPTR SOURCEFILE (CAAR OLDFILEMAP)))
(T
(* Redundancy check. Should only occur if there was a compiled function in the
file. and a partial map was formed that stopped after that function.)
(HELP]
(T (SETQ SOURCEFILE NIL]
(RESETSAVE (SETREADTABLE FILERDTBL))
[COND
[(NULL PRTTYFILE)
(SETQ PRTYOPENFLG T)
(SETQ NEWFILEMAP NIL)
(SETQ FILEFLG (NOT (DISPLAYP (SETQ PRTTYFILE (OUTPUT]
((OPENP PRTTYFILE (QUOTE OUTPUT))
(OUTPUT PRTTYFILE)
[SETQ FILEFLG (NOT (DISPLAYP (SETQ PRTTYFILE (OUTPUT]
(SETQ PRTYOPENFLG T) (* gets full name)
)
(T (OUTFILE PRTTYFILE)
[SETQ FILEFLG (NOT (DISPLAYP (SETQ PRTTYFILE (OUTPUT]
(SETQ FILEDATES (PRINTDATE PRTTYFILE CHANGES))
(AND (NEQ COPYRIGHTFLG (QUOTE NEVER))
ROOTNAME
(PRINTCOPYRIGHT ROOTNAME]
(SETQ CHANGES (FILEPKG.CHANGEDFNS CHANGES)) (* Used freely by PRETTYPRINT to
decide clispifying.)
(COND
((NULL (RANDACCESSP PRTTYFILE))
(SETQ NEWFILEMAP NIL)))
[COND
([AND FONTCHANGEFLG (OR FILEFLG (EQ FONTCHANGEFLG (QUOTE ALL]
(* this is expensive in thatit costs
as many conses as there are functions,
but you can afford it for a makefile.)
(SETQ FNSLST (OR (for FL in (GETPROP ROOTNAME (QUOTE FILEGROUP))
when (fetch FILEPROP of FL) join (FILEFNSLST FL))
(FILEFNSLST ROOTNAME]
(AND (NULL PRTYOPENFLG)
(RESETSAVE NIL (LIST (QUOTE PRETTYDEF0)
PRTTYFILE)))
(COND
((OR (LISTP PRTTYFNS)
(LISTP (GETTOPVAL PRTTYFNS)))
(PRINTFNS PRTTYFNS T)
(PRETTYCOM PRTTYFNS T)))
(COND
((AND (NLISTP PRTTYCOMS)
(NLISTP (GETTOPVAL PRTTYCOMS)))
(GO OUT)))
(RESETVARS ((NORMALCOMMENTSFLG (QUOTE DONTUPDATE)))
(PRETTYCOM PRTTYCOMS T)) (* PRTTYCOMS is just like the argument
to a COMS command. see comment in
prettycom1)
[MAP (SETQ PRETTYCOMSLST (COND
((LITATOM PRTTYCOMS)
(GETTOPVAL PRTTYCOMS))
(T PRTTYCOMS)))
(FUNCTION (LAMBDA (L)
(PRETTYCOM (CAR L)
NIL L]
(* The original value of PRTTYCOMS is saved so that it can be rewritten if a
spelling correction occurs. The list PRTTYCOMSLST is searched by PRETTYCOM1 for
* commands to see if the variable has be dumped out as well.)
OUT (COND
((PRETTYDEF1) (* The coms were reprinted by
PRETTYDEF1 due to a change to nlama
and or nlaml)
)
(PRTTYSPELLFLG (* A correction on prettycoms was
performed, so dump it out aain to get
the corrected version on the file.)
(PRETTYCOM PRTTYCOMS T)))
(AND (NEQ COPYRIGHTFLG (QUOTE NEVER))
(SAVECOPYRIGHT ROOTNAME))
(COND
(NEWFILEMAP (PRIN1 (QUOTE "(DECLARE: DONTCOPY
"))
(for ADR in MAPADR do (SETQ PRTTYTEM (GETFILEPTR PRTTYFILE))
(SETFILEPTR PRTTYFILE ADR)
(PRIN2 PRTTYTEM)
(SETFILEPTR PRTTYFILE PRTTYTEM))
(* This expresion writes the current
file positon into the filecreated
expression, and then restores the file
pointer.)
(PRIN2 (LIST (QUOTE FILEMAP)
NEWFILEMAP)) (* printed instead of prettyprinted,
so wont take up two pages of listing.)
(PRIN1 (QUOTE ")
"))
[PUTFILEMAP PRTTYFILE NEWFILEMAP (AND FILEDATES
(LIST (LIST (fetch FILEDATE
of (CAR FILEDATES))
(fetch DATEFILENAME
of (CAR FILEDATES]
(* Also stores MAP on property list,
so can be used for subsequent
makefiles.)
))
(OUTPUT PRTYX) (* Output done before ENDFILE in case
output was, in fact, PRTTYFILE before
the call to PRETTYDEF, and PRTTYFILE
is now being left closed)
(COND
((AND (NULL PRTYOPENFLG)
(NEQ PRTTYFILE T))
(ENDFILE PRTTYFILE)))
(AND FILEDATES ROOTNAME (/replace FILEDATES of ROOTNAME with FILEDATES))
(RETURN PRTTYFILE])
(PRETTYDEF0
[LAMBDA (PRTTYFILE) (* Cleans up after prettydef in case
of control-d.)
(COND
((SETQ PRTTYFILE (OPENP PRTTYFILE (QUOTE OUTPUT)))
(CLOSEF PRTTYFILE)
(DELFILE PRTTYFILE])
(PRETTYDEF1
[LAMBDA NIL (* wt: " 9-SEP-78 16:05")
(* Updates the DECLARE: for
NLAMA/NLAML)
(PROG (PRTTYCOM PRTTYTEM PRTTYNEW)
(COND
[[NULL (SOME PRETTYCOMSLST (FUNCTION (LAMBDA (X)
(AND (EQ (CAR X)
(QUOTE DECLARE:))
(SETQ PRTTYTEM (MEMB (QUOTE COMPILERVARS)
(SETQ PRTTYCOM X)))
(EQ (CAAR (SETQ PRTTYTEM (CDR PRTTYTEM)))
(QUOTE ADDVARS]
(AND (NULL NLAMALST)
(NULL NLAMLST)
(NULL LAMALST)
(RETURN NIL))
(* If thee is no DECLARE: and no nlambdas, dont bother to add any.
note tha if thee is IS a DECLARE:, then we must check even if there are no
nlambdas, because consider what happens when user changes the only nlambda to a
lambda -
must replace the declare: by a nop addvars.)
[SETQ PRTTYCOM (SUBPAIR (QUOTE (NLAMALST NLAMLST LAMALST))
(LIST NLAMALST NLAMLST LAMALST)
(QUOTE (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
COMPILERVARS (ADDVARS (NLAMA . NLAMALST)
(NLAML . NLAMLST)
(LAMA . LAMALST]
(COND
((AND (LISTP PRETTYCOMSLST)
(NLISTP PRTTYCOMS))
(/NCONC1 PRETTYCOMSLST PRTTYCOM)
(PRETTYCOM PRTTYCOMS T]
([NOT (EQUAL (CAR PRTTYTEM)
(SETQ PRTTYNEW (LIST (QUOTE ADDVARS)
[CONS (QUOTE NLAMA)
(UNION NLAMALST (INTERSECTION LAM?LST
(CDADAR PRTTYTEM]
[CONS (QUOTE NLAML)
(UNION NLAMLST (INTERSECTION LAM?LST
(CDR (CADDAR PRTTYTEM]
(CONS (QUOTE LAMA)
(UNION LAMALST (INTERSECTION
LAM?LST
(CDR (CADDDR (CAR PRTTYTEM]
(* The reason for the unions and intersections is that prettydef simply may not
know the fntyps of some of the functions in the file, namely those on lam?lst,
and theefore tese should not be removed from NLAMA and NLAML if they are there
from a previous makefile.)
(/RPLACA PRTTYTEM PRTTYNEW)
(AND (NLISTP PRTTYCOMS)
(PRETTYCOM PRTTYCOMS T)))
(T (RETURN NIL)))
(PRETTYCOM PRTTYCOM)
(RETURN T])
(PRINTDATE
[LAMBDA (FILE CHANGES) (* rmk: "19-FEB-83 22:09")
(* Returns new FILEDATES property,
without installing it)
(* assumes that FILE is the name of a
file open for output, and prints the
date information for that file on it)
(PROG (PREVPAIR FILEDATES (DAT (DATE))
(ROOTNAME (ROOTFILENAME FILE)))
(COND
(FILEPKGFLG [AND ROOTNAME (/replace FILECHANGES of ROOTNAME
with (SETQ CHANGES (FILEPKG.MERGECHANGES CHANGES
(fetch FILECHANGES of ROOTNAME]
(* The reason for the order of
arguments in UNION is so that the
changes will be listed in roughly the
order made.)
[SETQ FILEDATES (CONS (create FILEDATEPAIR
FILEDATE ← DAT
DATEFILENAME ← FILE)
(SETQ PREVPAIR (LAST (fetch FILEDATES of ROOTNAME]
(* Right now, FILEDATES simply keeps latest version and date, and original
version and date. Latter for integrity checks on makefile remake, as described
in filepackage. Note that don't want to change FILEDATES property until
PRETTDEF completes. In case of control-d, the file will be deleted
automatically.)
))
(PRINTDATE1 FILE CHANGES DAT (fetch FILEDATE of (CAR PREVPAIR))
(fetch DATEFILENAME of (CAR PREVPAIR))) (* PRINTDATE1 does the actual
printing. It is a separate function so
that it can be advised.)
(RETURN FILEDATES])
(PRINTDATE1
[LAMBDA (FILE CHANGES DAT PREVDATE PREVERS STR) (* rmk: "20-MAY-82 16:55")
(* does the printing for PRINTDATE)
(RESETLST (RESETSAVE (OUTPUT FILE)) (* note that CHANGEFONT checks for
FONTCHANGEFLG explicitly so that it
won't do anything if FONTCHANGEFLG is
NIL)
(printout NIL .FONT DEFAULTFONT "(FILECREATED " .P2 DAT , .FONT LAMBDAFONT .P2 FILE .FONT
DEFAULTFONT)
(COND
((AND BUILDMAPFLG FILE (NEQ FILE T))
(SETQ MAPADR (CONS (ADD1 (GETFILEPTR FILE))
MAPADR))
(PRIN3 " ")
(* The address of where the map begins will be stored in this slot 8 spaces
left because when radix is 8, can overflow seven spaces by a file of 300000
characters (Alice did it) The CONS is because of a feature no longer used where
there could be two FILECREATED expressions at the head of a file font)
))
[COND
(FILEPKGFLG (COND
(CHANGES (printout NIL T T 6 "changes to: " .PPVTL CHANGES)))
(COND
(PREVDATE (printout NIL T T 6 "previous date: " .P2 PREVDATE)
(COND
(PREVERS (printout NIL , .P2 PREVERS]
(PRIN1 (OR STR (QUOTE ")
"])
(PRINTFNS
[LAMBDA (X PRETTYDEFLG) (* lmm "13-OCT-82 16:44")
(* prettydeflg=T when called from
prettydef.)
(AND X (PROG (FNADRLST)
[COND
((AND PRETTYDEFLG NEWFILEMAP)
(SETQ FNADRLST (TCONC NIL (GETFILEPTR PRTTYFILE)))
(TCONC FNADRLST NIL)
(NCONC1 NEWFILEMAP (CAR FNADRLST]
(PRIN1 (QUOTE %())
(PRINT (QUOTE DEFINEQ))
(PRETTYPRINT X (AND PRETTYDEFLG (OR FNADRLST T))
FNSLST) (* FNSLST bound in prettydef to list
of functions on this file.
used for font stuff.)
(PRIN1 (QUOTE %)))
(AND FNADRLST (RPLACA (CDAR FNADRLST)
(GETFILEPTR PRTTYFILE)))
(TERPRI])
(PRETTYCOM
[LAMBDA (PRTTYCOM PRTTYFLG PRETTYCOMSTAIL) (* lmm " 3-Jul-85 18:19")
(PROG (PRTTYTEM)
[COND
((NULL PRTTYCOM) (* So that RECOMPILE and BRECOMPILE do
not have to check before calling
PRETTYCOM.)
(RETURN))
((AND PRTTYFLG (NEQ PRTTYFILE T))
(PRINT (COND
(LISPXPRINTFLG (* PRETTYCOMPRINT is an nlambda that
does a lispxprint, except when
prettyheader is NIL, in hich case it
does nothing.)
(LIST (QUOTE PRETTYCOMPRINT)
PRTTYCOM))
(T (LIST (QUOTE PRINT)
(LIST (QUOTE QUOTE)
PRTTYCOM)
T T]
(COND
((LITATOM PRTTYCOM)
(COND
((AND (NULL PRTTYFLG)
(NOT (BOUNDP PRTTYCOM))
DWIMFLG
(SETQ PRTTYTEM (FIXSPELL PRTTYCOM 70 USERWORDS T PRETTYCOMSTAIL
(FUNCTION BOUNDP)))
(SETQ PRTTYSPELLFLG T))
(SETQ PRTTYCOM PRTTYTEM)))
(PRETTYVAR PRTTYCOM PRTTYFLG) (* FNS and VARS are printed as
(RPAQQ atom value T) so that LOAD
ALLPROP will still stre them in the
value cell.)
(RETURN PRTTYCOM))
(PRTTYFLG (* PRETTYDEF called with a list for
FNS or VARS,)
(RETURN PRTTYCOM)))
TOP [COND
[[AND (NULL ORIGFLG)
(SETQ PRTTYTEM (fetch (FILEPKGCOM MACRO) of (CAR PRTTYCOM]
(for X on (SUBPAIR (CAR PRTTYTEM)
(PRETTYCOM1 PRTTYCOM T T)
(CDR PRTTYTEM)) do (PRETTYCOM (CAR X)
NIL
(AND PRETTYCOMSTAIL X]
(T
(SELECTQ (CAR PRTTYCOM)
(FNS (PROG (PRTTYSPELLFLG)
(PRINTFNS (PRETTYCOM1 PRTTYCOM T T)
(NOT (NULL PRETTYCOMSTAIL)))
(AND PRTTYSPELLFLG (EQ (CADR PRTTYCOM)
(QUOTE *))
(LITATOM (SETQ PRTTYTEM (CADDR PRTTYCOM)))
(PRETTYCOM PRTTYTEM)) (* The FNSlst had an error in it that
was corrected.)
))
((VARS ARRAY)
(for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR X)))
(DECLARE:
(* Normally, expressions appearing in a symbolic file are
(1) evaluated upon loading the file, (2) not evaluated when compiling the file,
and (3) copied to the compile file. DECLARE: can be used to change state around
any PRETTYCOM. The atomic symbols DONTCOPY, DOCOPY, DONTEVAL@COMPILE,
DOEVAL@COMPILE, DONTEVAL@LOAD, and DOEVAL@LOAD have the obvious meaning.
DECLARE: eliminates the pretty commands DECLARE, COMPROP, COMPROP*, PD, PC, and
PC*. DECLARE: is defined as a functionthat evaluates all list expressions
except when under a DONTEVAL@LOAD state.)
(PRIN1 (QUOTE "(DECLARE: "))
(for LST on (PRETTYCOM1 PRTTYCOM T T)
do (COND
((NLISTP (CAR LST))
[COND
((NOT (MEMB (CAR LST)
DECLARETAGSLST))
(COND
((AND DWIMFLG (FIXSPELL (CAR LST)
70 DECLARETAGSLST T LST))
(SETQ PRTTYSPELLFLG T))
(T (GO ERROR]
(PRIN1 (CAR LST))
(SPACES 1))
(T (TERPRI)
(PRETTYCOM (CAR LST)
NIL LST)))
(SELECTQ (CAR LST)
((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN)
(COND
((SETQ LST (CDR LST))
(PRINTDEF (CAR LST))
(SPACES 1))))
NIL))
(PRIN1 (QUOTE ")
")))
((SPECVARS LOCALVARS GLOBALVARS)
(SETQ PRTTYTEM (CONS (CAR PRTTYCOM)
(PRETTYCOM1 PRTTYCOM T T)))
(PRIN1 "(DECLARE: DOEVAL@COMPILE DONTCOPY
")
(PRINTDEF1 PRTTYTEM)
(PRIN1 ")
"))
((PROP IFPROP)
[PROG ((PRTTYFLG (EQ (CAR PRTTYCOM)
(QUOTE IFPROP)))
(PRTTYTEM (CADR PRTTYCOM))
(PRTTYX (PRETTYCOM1 (CDR PRTTYCOM)
T T))) (* IFPROP only dumps those property
values that are non-NIL.)
(COND
((LISTP PRTTYTEM)
(for X in PRTTYTEM do (MAKEDEFLIST PRTTYX X PRTTYFLG)))
((NEQ PRTTYTEM (QUOTE ALL))
(MAKEDEFLIST PRTTYX PRTTYTEM PRTTYFLG PRTTYCOM))
[(ASSOC (QUOTE PUTPROPS)
PRETTYPRINTMACROS)
(for ATM in PRTTYX
do (PRINTDEF1
(CONS (QUOTE PUTPROPS)
(CONS ATM (CONS (for X on (GETPROPLIST ATM)
by (CDDR X)
unless (MEMB (CAR X)
SYSPROPS)
join (LIST (CAR X)
(CADR X]
(T (for ATM in PRTTYX
do (printout NIL " (PUTPROPS " .P2 ATM)
(SETQ PRTTYTEM (ADD1 (POSITION)))
(for X on (GETPROPLIST ATM) by (CDDR X)
unless (MEMB (CAR X)
SYSPROPS)
do (printout NIL .TAB PRTTYTEM .PPV (CAR X)
, .PPV (CADR X)))
(PRIN1 (QUOTE ")
"])
(P (for X in (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T)) do (PRINTDEF1 X)))
(INITVARS [for X in (PRETTYCOM1 PRTTYCOM T T)
do (COND
((LISTP X)
(OR (EQ (CAR X)
COMMENTFLG)
(PRETTYVAR1 (QUOTE RPAQ?)
(CAR X)
(CDR X)
NIL T)))
(T (PRETTYVAR1 (QUOTE RPAQ?)
X NIL])
(ADDVARS (for X in (PRETTYCOM1 PRTTYCOM T T)
do (PRETTYVAR1 (QUOTE ADDTOVAR)
[CAR (OR (LISTP X)
(ERRORX (LIST 4 X]
(CDR X)
NIL T)))
(APPENDVARS (for X in (PRETTYCOM1 PRTTYCOM T T)
do (PRETTYVAR1 (QUOTE APPENDTOVAR)
[CAR (OR (LISTP X)
(ERRORX (LIST 4 X]
(CDR X)
NIL T)))
(E (for X in (PRETTYCOM1 PRTTYCOM T) do (EVAL X)))
(COMS (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T))
[PROG ((PRETTYCOMSLST (APPEND PRTTYTEM PRETTYCOMSLST)))
(for X on PRTTYTEM do (PRETTYCOM (CAR X)
NIL
(AND PRETTYCOMSTAIL X])
(ORIGINAL (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T))
[PROG ((PRETTYCOMSLST (APPEND PRTTYTEM PRETTYCOMSLST))
(ORIGFLG T))
(for X on PRTTYTEM do (PRETTYCOM (CAR X)
NIL
(AND PRETTYCOMSTAIL X])
((ADVISE ADVICE)
(MAKEDEFLIST (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T T))
(QUOTE ARGNAMES)
T)
(ADVISEDUMP PRTTYTEM (EQ (CAR PRTTYCOM)
(QUOTE ADVISE))))
(BLOCKS (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T T))
(PRIN1 (QUOTE "[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
"))
(for X in PRTTYTEM do (PRINTDEF1 (CONS (QUOTE BLOCK:)
X)))
(PRIN1 (QUOTE "]
")))
(* [COND
((EQ (CADR PRTTYCOM)
(QUOTE *)) (* Form-feed if super-comment
indicated. Use * no matter what
current COMMENTFLG is.)
(printout NIL .PAGE))
(T (RPTQ 3 (TERPRI]
(COND
((AND [COND
(FILEFLG FONTCHANGEFLG)
(T (EQ FONTCHANGEFLG (QUOTE ALL]
LAMBDAFONT)
(CHANGEFONT LAMBDAFONT)
(RESETFORM (LINELENGTH LAMBDAFONTLINELENGTH)
(PRIN2 PRTTYCOM))
(CHANGEFONT DEFAULTFONT))
(T (PRIN2 PRTTYCOM)))
(RPTQ 2 (TERPRI)))
(COND
((AND (LITATOM (CAR PRTTYCOM))
(fetch (FILEPKGTYPE GETDEF) of (CAR PRTTYCOM)))
(* If its the name of a type with a
GETDEF, put out PUTDEF expressions.)
(for X in (PRETTYCOM1 PRTTYCOM T T)
do (printout NIL "(PUTDEF " .P2 (KWOTE X)
, .P2 (KWOTE (CAR PRTTYCOM))
, .PPV (KWOTE (GETDEF X (CAR PRTTYCOM)))
")" T)))
((FIXSPELL (CAR PRTTYCOM)
70 FILEPKGCOMSPLST T PRTTYCOM)
(SETQ PRTTYSPELLFLG T)
(GO TOP))
(T (GO ERROR]
(RETURN PRTTYCOM)
ERROR
(ERROR "bad file package command" PRTTYCOM T])
(PRETTYCOMPRINT
[NLAMBDA (X)
(AND PRETTYHEADER (LISPXPRINT X T T])
(PRETTYVAR
[LAMBDA (VAR FLG) (* lmm "27-Aug-84 20:15")
(* I don't see what FLG is used
for--rmk)
(PROG (VAL TEM)
(* Dumps value of VAR for reloading. If VAR is non-atomic, of form
(var form) where VAR is to be dumped so as to be set to value of form, computed
at LOAD time.)
(COND
((LITATOM VAR)
(AND (EQ (SETQ VAL (GETTOPVAL VAR))
(QUOTE NOBIND))
(printout T T "****WARNING: " .P2 VAR " is unbound" T T))
(PRETTYVAR1 (QUOTE RPAQQ)
VAR VAL))
[(LISTP VAR)
(SETQ VAL (CDR VAR))
(SETQ VAR (CAR VAR))
(COND
((AND (EQ [CAR (SETQ TEM (LISTP (CAR (LISTP VAL]
(QUOTE QUOTE))
(LISTP (CDR TEM)))
(PRETTYVAR1 (QUOTE RPAQQ)
VAR
(CADR TEM)))
((EQ VAR COMMENTFLG) (* don't print out comments)
)
([OR (NULL VAL)
(AND (LISTP VAL)
(OR (NUMBERP (CAR VAL))
(EQ T (CAR VAL))
(NULL (CAR VAL)))
(NULL (CDR VAL] (* A minor optimization for RPAQQ's to
suppresses unnecessary load-time
eval's.)
(PRETTYVAR1 (QUOTE RPAQQ)
VAR
(CAR VAL)))
(T (PRETTYVAR1 (QUOTE RPAQ)
VAR VAL NIL T]
(T (ERROR "Bad variable specification" VAR])
(PRETTYVAR1
[LAMBDA (OP VAR E DEF TAILFLG) (* rrb "20-JUL-83 11:51")
(* does printing for VAR, ADDVAR, and PROP commands.
OP is the name of the function, VAR the operand, and E the rest of the
expression to be printed, either as an element, or as a tail if TAILFLG=T.
VAR is printed in LAMBDAFONT. If VAR is a list, each element is printed in
LAMBDAFONT. This option is used to print both the name of the atm and it s
property for PROP commands.)
(PROG (TEM (LASTCOL (LINELENGTH)))
(TERPRI) (* because if you have a really bold
font, it lines up the bottoms, but you
can get crowded into the line above.)
[COND
([AND (MEMB OP (QUOTE (RPAQQ RPAQ RPAQ?)))
(MEMB [TYPENAME (SETQ TEM (COND
(TAILFLG (CAR E))
(T E]
(QUOTE (ARRAYP BITMAP]
(COND
((EQ OP (QUOTE RPAQQ))
(SETQQ OP RPAQ)))
(printout NIL "(" .P2 OP , .P2 VAR ,)
(SELECTQ (TYPENAME TEM)
(ARRAYP (printout NIL "(READARRAY " (ARRAYSIZE TEM)
, "(QUOTE " (ARRAYTYP TEM)
") "
(ARRAYORIG TEM)
"))" T)
(PRINTARRAY TEM))
(BITMAP (printout NIL "(READBITMAP))" T)
(PRINTBITMAP TEM))
(SHOULDNT)))
((ASSOC OP PRETTYPRINTMACROS)
(OR TAILFLG (SETQ E (CONS E)))
(PRINTDEF [CONS OP (COND
((LISTP VAR)
(APPEND VAR E))
(T (CONS VAR E]
0 DEF))
(T (PRIN1 (QUOTE %())
(PRIN1 OP)
(SPACES 1)
(SETQ TEM (POSITION))
(COND
((AND FONTCHANGEFLG PRETTYCOMFONT)
(CHANGEFONT PRETTYCOMFONT)))
(COND
((LISTP VAR)
(MAPRINT VAR NIL NIL NIL NIL (FUNCTION PRIN2)))
(T (PRIN2 VAR)))
(COND
((AND FONTCHANGEFLG PRETTYCOMFONT)
(CHANGEFONT DEFAULTFONT)))
(SPACES 1)
(PRINTDEF E (COND
((OR (NLISTP E)
(FITP E NIL NIL LASTCOL))
(POSITION))
(T TEM))
DEF TAILFLG)
(PRIN1 (QUOTE %)]
(TERPRI])
(PRETTYCOM1
[LAMBDA (PRTYCOM PRTYFLG REMOVECOMMENTS) (* rmk: "13-Feb-85 22:54")
(PROG (PRTYX)
[COND
((AND (EQ [CAR (LISTP (SETQ PRTYX (CDR PRTYCOM]
(QUOTE *))
(CDR PRTYX))
(COND
((AND (LITATOM (SETQ PRTYX (CADR PRTYX)))
PRTYFLG) (* Checks to see if the variable is
already being dumped and dumps it if
not.)
(PRETTYCOM PRTYX)))
(SETQ PRTYX (COND
(PRTYFLG (EVAL PRTYX))
((LITATOM PRTYX)
(AND (NEQ (SETQ PRTYX (GETTOPVAL PRTYX))
(QUOTE NOBIND))
PRTYX))
(T (RESETVARS (DWIMLOADFNSFLG)
(RETURN (AND (ERSETQ (SETQ PRTYX (EVAL PRTYX)))
PRTYX]
(RETURN (if (AND REMOVECOMMENTS (LISTP PRTYX))
then [SUBSET PRTYX (FUNCTION (LAMBDA (X)
(OR (NLISTP X)
(NEQ (CAR X)
COMMENTFLG]
else PRTYX])
(ENDFILE
[LAMBDA (FILE) (* wt: "10-SEP-78 13:54")
(PRINT (QUOTE STOP)
FILE)
(CLOSEF FILE])
(MAKEDEFLIST
[LAMBDA (X PROP FLG) (* rmk: "19-FEB-83 22:17")
(PROG (TEM)
(for Z in X do (COND
[[AND (LITATOM Z)
(SETQ TEM (SOME (GETPROPLIST Z)
[FUNCTION (LAMBDA (X)
(EQ X PROP]
(QUOTE CDDR]
(PRETTYVAR1 (QUOTE PUTPROPS)
(LIST Z PROP)
(CADR TEM)
(MEMB PROP (QUOTE (MACRO EXPR]
((NULL FLG) (* PROP command)
(PRINT (LIST (QUOTE no)
PROP
(QUOTE property)
(QUOTE for)
Z)
T])
(PP
[NLAMBDA X (* lmm "14-Aug-84 19:09")
(DECLARE (LOCALVARS . T))
(RESETLST (RESETSAVE (OUTPUT T))
(RESETSAVE (SETREADTABLE T))
(PRETTYPRINT (NLAMBDA.ARGS X])
(PP*
[NLAMBDA X (* lmm "14-Aug-84 19:11")
(DECLARE (LOCALVARS . T))
(RESETLST (RESETSAVE (OUTPUT T))
(RESETSAVE (SETREADTABLE T))
(RESETVARS (**COMMENT**FLG)
(RETURN (PRETTYPRINT (NLAMBDA.ARGS X])
(PPT
[NLAMBDA X (* lmm "14-Aug-84 19:12")
(DECLARE (LOCALVARS . T))
(RESETLST (RESETSAVE (OUTPUT T))
(RESETSAVE (SETREADTABLE T))
(RESETVARS ((PRETTYTRANFLG T))
(RETURN (PRETTYPRINT (NLAMBDA.ARGS X])
(PRETTYPRINT
[LAMBDA (FNS PRETTYDEFLG FNSLST) (* AJB "26-Sep-85 10:52")
(* PRETTYDEFLG is supplied when called from PRINTFNS.
it is either a paatial file map or T, so that it is also used as a flag for
whether you are being called from prettydef.)
(* Note that prettyprint does all of its printing to standard output file and
using current readtable. it assumes that higher functions have set these
appropriately, as is the case when called from prettydef, pp, pp*,)
(RESETLST [RESETSAVE NIL (LIST (FUNCTION DSPFONT)
(DSPFONT)
(GETSTREAM NIL (QUOTE OUTPUT]
(PROG [LST (CLK (CLOCK 0))
TEM FN DEF ADR (NEWADRLST (LISTP PRETTYDEFLG))
SKIPPEDLST
(FILEFLG (NOT (DISPLAYP (OUTPUT] (* NEWADRLST Corresponds to the
current entry on NEWFILEMAP.
Is in TCONC format.)
[COND
((ATOM (SETQ LST FNS))
(SETQ LST (EVALV FNS]
LP (COND
((NLISTP LST)
(RETURN FNS))
((AND FILEFLG (IGREATERP (IDIFFERENCE (SETQ TEM (CLOCK 0))
CLK)
30000))
(SETQ CLK TEM)
(PRIN2 (CAR LST)
T T)
(PRIN1 (QUOTE ", ")
T)))
(SETQ FN (CAR LST))
(TERPRI) (* The initial TERPRI is not in map)
[AND NEWADRLST (TCONC NEWADRLST (LIST FN (GETFILEPTR PRTTYFILE]
(* Address of start.)
LP1 (SETQ DEF (VIRGINFN FN))
(AND PRETTYDEFLG (SELECTQ (ARGTYPE DEF)
(1 (SETQ NLAMLST (CONS FN NLAMLST)))
(2 (SETQ LAMALST (CONS FN LAMALST)))
(3 (SETQ NLAMALST (CONS FN NLAMALST)))
(NIL (SETQ LAM?LST (CONS FN LAM?LST)))
NIL)) (* So prettydef can add the
appropriate DECLARE:)
[COND
[(NULL DEF)
(COND
((AND (NULL PRETTYDEFLG)
FN
(BOUNDP FN)) (* i.e. only make this check when
called via PP or PP*)
(PRINTDEF (EVALV FN)
2))
(T (GO NOPRINT]
((NULL (EXPRP DEF))
(GO NOPRINT))
(T (AND ADDSPELLFLG (ADDSPELL FN))
(COND
((AND PRETTYDEFLG SOURCEFILE [NULL (SELECTQ REPRINTFNS
(ALL T)
((T EXPRS)
(EXPRP FN))
(AND (LISTP REPRINTFNS)
(FMEMB FN REPRINTFNS]
(PRETTYPRINT1 FN)) (* See comment in PRETTYDEF.)
(GO DEFPRINTED)))
[AND (OR (SELECTQ CLISPIFYPRETTYFLG
((T EXPRS)
(EXPRP FN))
(ALL T)
(CHANGES (AND PRETTYDEFLG (MEMB FN CHANGES)))
(MEMB FN CLISPIFYPRETTYFLG))
(AND (SUPERPRINTEQ (CAR (SETQ TEM (CADDR DEF)))
COMMENTFLG)
(EQ (CADR TEM)
(QUOTE DECLARATIONS:))
(MEMB (QUOTE CLISPIFY)
TEM)))
(RESETVARS (FILEPKGFLG)
(SETQ DEF (CLISPIFY DEF]
(* If the function is stored on property list, only clispify if user
specifically said MAKEFILE (file CLISPIFY), otherwise, assume that functions on
property list have already been clispified)
(COND
((AND LAMBDAFONT FONTCHANGEFLG)
(PRIN1 (QUOTE %()) (* The font change is after the paren
because of problems with updating
filemaps when moving back and forth
between -10 and -D systems--rmk)
(CHANGEFONT LAMBDAFONT)
(PRIN2 FN)
(CHANGEFONT DEFAULTFONT)
(TERPRI))
(T (PRIN1 (QUOTE %())
(PRINT FN)))
(PRINTDEF DEF 2 (QUOTE FNS)
NIL FNSLST)
(PRIN1 (QUOTE %)]
DEFPRINTED
(AND NEWADRLST (RPLACD (CDADR NEWADRLST)
(GETFILEPTR PRTTYFILE)))
(* Store end address)
(TERPRI) (* TERPRI is not included in map
address)
(SETQ LST (CDR LST))
(GO LP)
NOPRINT
(COND
((AND FILEFLG SOURCEFILE (PRETTYPRINT1 FN))
(GO DEFPRINTED))
((AND (NULL PRETTYDEFLG)
(SETQ TEM (EDITLOADFNS? FN))) (* only make this check when called
from PP or PP*)
(LOADFNS FN TEM (QUOTE PROP))
(COND
((GETPROP FN (QUOTE EXPR))
(GO LP1)))
(PRINT (CONS FN (QUOTE (not found)))
T T))
((AND DWIMFLG (NULL DEF)
(SETQ TEM (MISSPELLED? FN 70 USERWORDS (AND PRETTYDEFLG T)
LST))
(NEQ TEM FN))
(/RPLACA LST (SETQ FN TEM))
(AND NEWADRLST (FRPLACA (CADR NEWADRLST)
FN)) (* Fixes filemap.)
(AND PRETTYDEFLG (SETQ PRTTYSPELLFLG T))
(GO LP1)))
(LISPXPRINT (CONS FN (QUOTE (not printable)))
T)
(AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*)
FN NIL (CAAR LISPXHISTORY)))
(COND
(NEWADRLST (SETQ TEM (NLEFT (CAR NEWADRLST)
2))
(RPLACD TEM)
(RPLACD NEWADRLST TEM)))
LP3 (SETQ LST (CDR LST))
(GO LP])
(PRETTYPRINT1
[LAMBDA (FN) (* rmk: " 5-MAY-81 15:24")
(* Like BRECOMPILE1.
Obtains FN from SOURCEFILE.
works whether the file has previously
been mapped by PRETTYDEF, LOAD, or
LOADFNS (or patially mapped))
(PROG (ADR TEM)
(COND
((NULL OLDFILEMAP)
(GO DEFQLP))
((PRETTYPRINT2 FN)
(RETURN FN))
((NULL (CAR OLDFILEMAP))
(RETURN NIL) (* The entire file has been scanned.)
)
(T (GO FNLP) (* Already inside of DEFINEQ.)
))
DEFQLP
(* Find DEFINEQ)
(SELECTQ (SETQ TEM (RATOM SOURCEFILE))
((STOP NIL) (* End of file reached.)
(SETQ OLDFILEMAP (CONS NIL OLDFILEMAP)) (* Just to inform future calls to
PRETTYPRINT1 not to bother scanning.)
(RETURN NIL))
(%( [COND
((EQ (SETQ TEM (RATOM SOURCEFILE))
(QUOTE DEFINEQ))
(COND
((NULL OLDFILEMAP)
(SETQ OLDFILEMAP (LIST T))
(* In case functionis found right off, OLDFILEMAP must not be left as NIL or
else next call to PRETTYPRINT1 will not realize are alredy inside of DEFINEQ.)
))
(GO FNLP))
(T (SKREAD SOURCEFILE (QUOTE %(])
(SKREAD SOURCEFILE TEM))
(GO DEFQLP)
FNLP
(SELECTQ (SETQ TEM (RATOM SOURCEFILE))
(%) (* End of DEFINEQ.)
(GO DEFQLP))
((%( %[)
NIL)
(SCANFILEHELP))
(SETQ ADR (SUB1 (GETFILEPTR SOURCEFILE)))
(SETQ TEM (RATOM SOURCEFILE))
(SETFILEPTR SOURCEFILE ADR)
(SKREAD SOURCEFILE)
(COND
((EQ TEM FN)
(PRETTYPRINT2 FN ADR (GETFILEPTR SOURCEFILE)) (* copies the bytes.)
(RETURN FN))
(T (SETQ OLDFILEMAP (CONS (CONS TEM (CONS ADR (GETFILEPTR SOURCEFILE)))
OLDFILEMAP))
(* Note that this situation only occurs when
(a) the entire file was not peviously scanned, e.g.
if loaded with buildmapflg off, and (b) user is doing a remake, and
(c) this functio was either dumped directly because it was changed, or else it
has been deleted from the FNS. The function is added to OLDFILEMAP just in case
it is out of order.)
(GO FNLP])
(PRETTYPRINT2
[LAMBDA (FN FROM TO) (* lmm "27-Aug-84 23:35")
(* Copies function from sourcefile to
prettyfile. looking it up on the map
when not already given address.
returns nil if not there)
(PROG (TEM)
(COND
(FROM)
([SOME OLDFILEMAP (FUNCTION (LAMBDA (X)
(COND
((NLISTP X)
NIL)
((EQ (CAR X)
FN) (* occurs when remaking a file without
a map, and a function is previously
skipped that later is needed.)
(SETQ TEM X))
((LISTP (CDDR X))
(SETQ TEM (FASSOC FN (CDDR X]
(SETQ FROM (CADR TEM))
(SETQ TO (CDDR TEM)))
(T (RETURN NIL)))
(SETFILEPTR SOURCEFILE FROM)
(RATOM SOURCEFILE)
(* The RATOM skips the paren. the reason for the raom instead of simply doing
an sfptr (ADD1 FROM) is that there may be font info there.)
(COND
((NEQ FN (SETQ TEM (READ SOURCEFILE))) (* Consistency check.)
(LISPXPRINT (CONS FN TEM)
T)
(ERROR (QUOTE "filemap does not agree with contents of")
SOURCEFILE T)))
(COPYCHARS SOURCEFILE PRTTYFILE FROM TO) (* Initial and final TERPRI's are done
by callers; they are not in map.)
(RETURN FN])
(PRINTDEF1
[LAMBDA (EXPR)
(PRINTDEF EXPR)
(TERPRI])
(SUPERPRINTEQ
[LAMBDA (X Y)
(OR (EQ X Y)
(AND Y (EQ (CDR (FASSOC X PRETTYEQUIVLST))
Y])
(SUPERPRINTGETPROP
[LAMBDA (ATM PROP) (* wt: "17-SEP-79 15:57")
(OR (GETPROP (CDR (FASSOC ATM PRETTYEQUIVLST))
PROP)
(GETPROP ATM PROP])
(CHANGEFONT
[LAMBDA (FONTCLASS FILE) (* lmm "17-Jan-86 20:59")
(* for calls to changefont when not
under prettyprin prettydef.
This is only for non-D systems.
For D, DSPFONT is moved'ed in.)
(* Don't bother testing for FONTCHANGEFLG=ALL, because presumably the FONTCLASS
will have a NULL entry if display printing isn't wanted.
FONTCHANGEFLG=ALL tests are really only needed if something expensive can be
avoided by advance knowledge. -)
(AND FONTCHANGEFLG FONTCLASS (DSPFONT FONTCLASS FILE])
(READARRAY
[LAMBDA (SIZE TYPE ORIG) (* rrb " 4-JUL-80 17:07")
(* type is one of: POINTER, FIXP , SMALLPOSP BYTE DOUBLEPOINTER or a number
which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.)
(PROG (X (A (ARRAY SIZE TYPE NIL ORIG))
M DELTA)
LP (COND
((NEQ (READC)
(QUOTE %())
(GO LP)))
(SETQ M 1)
(SETQ DELTA (SUB1 (OR ORIG 1)))
LP1 (COND
((NOT (IGREATERP M SIZE))
(SETA A (IPLUS M DELTA)
(READ))
(SETQ M (ADD1 M))
(GO LP1))
((NULL (READ))
(* PRINTARRAY writes a NIL if there are no elements in the array for which the
left half must be set using SETD, otherwise it writes a T.)
(GO OUT)))
[SETQ M (COND
((NUMBERP TYPE)
(ADD1 TYPE))
((EQ TYPE (QUOTE DOUBLEPOINTER))
1)
(T (SHOULDNT]
LP2 (COND
((NOT (IGREATERP M SIZE))
(SETD A (IPLUS M DELTA)
(READ))
(SETQ M (ADD1 M))
(GO LP2)))
OUT (READ) (* Reads the final right parentheses
surrounding the elements of the array.)
(RETURN A])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS CHANGFONT MACRO (= . DSPFONT))
)
)
(* COPYRIGHT)
(DEFINEQ
(PRINTCOPYRIGHT
[LAMBDA (FILENAME) (* edited: " 1-Jan-85 20:16")
(* * CALLED BY PRETTYDEF TO PUT a copyright notice on a file.
The globalvar COPYRIGHTOWNERS is used to determine the possible copyright
owners when it is determined the file doesn't have a copyright yet and has
never been asked if the programmer wanted one.
The whole copyright mechanism can be turned off by setting COPYRIGHTFLG to
NEVER -- originaly NIL. If the file is copyrighted, any year the file is
editted the new year is tacked on to the list of copyright years.
The copyright notice comes immediately after the FILECREATED expression * *)
(PROG [(OWNER (GETPROP FILENAME (QUOTE COPYRIGHT]
(AND [OR OWNER
(AND COPYRIGHTFLG
(SETQ OWNER
(ASKUSER (if (EQ COPYRIGHTFLG (QUOTE DEFAULT))
then 0
else DWIMWAIT)
(CONSTANT (CHARACTER (CHARCODE LF)))
(CONCAT "Copyright owner for file " FILENAME ": ")
(NCONC [MAPCAR COPYRIGHTOWNERS (FUNCTION (LAMBDA (X)
(LIST (CAR X)
""
(QUOTE EXPLAINSTRING
)
(CONCAT (CAR X)
" - "
(CADR X))
(QUOTE RETURN)
(CADR X)
(QUOTE CONFIRMFLG)
T]
(CONS (if (SETQ OWNER (ASSOC DEFAULTCOPYRIGHTOWNER
COPYRIGHTOWNERS))
then (LIST (CONSTANT (CHARACTER (CHARCODE LF)))
(CONCAT DEFAULTCOPYRIGHTOWNER "
")
(QUOTE EXPLAINSTRING)
(CONCAT "<LF> - " (CADR OWNER)
" [Default]")
(QUOTE NOECHOFLG)
T
(QUOTE RETURN)
(CADR OWNER))
else (QUOTE (%
"No copyright notice now
" EXPLAINSTRING "<LF> - no copyright notice now [Default]" NOECHOFLG T RETURN NIL)))
DEFAULTCOPYRIGHTKEYLST))
T T))
(/PUTPROP FILENAME (QUOTE COPYRIGHT)
(SETQ OWNER (LIST OWNER]
(COND
((NEQ (CAR OWNER)
(QUOTE NONE))
(PROG [(CURRENTYEAR (PACK* "19" (SUBSTRING (DATE)
8 9]
(OR (MEMBER CURRENTYEAR (CDR OWNER))
(NCONC1 OWNER CURRENTYEAR)))
(PRINTCOPYRIGHT1 OWNER])
(PRINTCOPYRIGHT1
[LAMBDA (OWNER) (* lmm "31-May-84 12:32")
(PROG ((DATES (CDR OWNER))
PRIVATE)
(COND
((EQ (CAR DATES)
T)
(SETQ PRIVATE T)
(pop DATES)))
[MAPRINT DATES NIL "(* Copyright (c) " " by " ", " (FUNCTION (LAMBDA (YEAR)
(PRINTNUM
(QUOTE (FIX 4))
YEAR]
(PRIN1 (CAR OWNER))
(AND COPYRIGHTSRESERVED (PRIN1 ". All rights reserved."))
(COND
(PRIVATE (MAPRINT (QUOTE ("" The following program was created in))
NIL NIL NIL " ")
(PRINTNUM (QUOTE (FIX 5))
(CAR DATES))
(MAPRINT (QUOTE (" " 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.))
NIL NIL NIL " ")))
(PRIN1 ")")
(TERPRI)
(TERPRI])
(SAVECOPYRIGHT
[LAMBDA (FILENAME) (* lmm "25-DEC-82 16:48")
(* CALLED FROM PRETTYDEF TO SAVE
COPYRIGHT INFO ON END OF FILE)
(AND (NEQ COPYRIGHTFLG (QUOTE NEVER))
(PROG (X)
(COND
((SETQ X (GETPROP FILENAME (QUOTE COPYRIGHT)))
(PRINT (LIST (QUOTE PUTPROPS)
FILENAME
(QUOTE COPYRIGHT)
X])
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T)
(NOLINKFNS PRINTCOPYRIGHT1))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER
COPYRIGHTSRESERVED)
)
(RPAQ? COPYRIGHTFLG )
(RPAQ? DEFAULTCOPYRIGHTOWNER )
(RPAQ? COPYRIGHTPRETTYFLG T)
(RPAQ? COPYRIGHTOWNERS )
(RPAQ? DEFAULTCOPYRIGHTKEYLST (QUOTE ((NONE "
" EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN (QUOTE NONE))
[%[ "owner: " EXPLAINSTRING
"[ - new copyright owner -- type one line of text"
NOECHOFLG T KEYLST (( "
" RETURN (SUBSTRING (CADR ANSWER)
2 -2]
(%] "No copyright notice now
" EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL))))
(RPAQ? COPYRIGHTSRESERVED T)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG)
)
(RPAQ? BRLST )
(RPAQ? COMMENTFLG (QUOTE *))
(RPAQ? **COMMENT**FLG (QUOTE " **COMMENT** "))
(RPAQ? PRETTYFLG T)
(RPAQ? #RPARS 4)
(RPAQ? CLISPIFYPRETTYFLG )
(RPAQ? PRETTYTRANFLG )
(RPAQ? FONTCHANGEFLG )
(RPAQ? CHANGECHARTABSTR )
(RPAQ? PRETTYTABFLG T)
(RPAQ? DECLARETAGSLST
(QUOTE (COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY DONTEVAL@COMPILE
DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST
NOTFIRST)))
(RPAQ? WIDEPAPERFLG )
(RPAQ? AVERAGEVARLENGTH 4)
(RPAQ? AVERAGEFNLENGTH 5)
(RPAQ? #CAREFULCOLUMNS 0)
(RPAQ? CHANGECHAR (QUOTE %|))
(RPAQ? LASTFONT )
(RPAQ? ENDLINEUSERFN )
(RPAQ? PRETTYDEFMACROS )
(RPAQ? PRETTYPRINTMACROS )
(RPAQ? PRETTYEQUIVLST )
(RPAQ? PRETTYPRINTYPEMACROS )
(RPAQ? FILEPKGCOMSPLST
(QUOTE (DECLARE: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS APPENDVARS
FNS ARRAY E COMS ORIGINAL ADVISE ADVICE BLOCKS *)))
(RPAQ? SYSPROPS
(QUOTE (PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN
PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS ADVICE ADVISED ALIAS
AMAC ARGNAMES BLKLIBRARYDEF BRKINFO BROADSCOPE BROKEN BROKEN-IN CLISPCLASS
CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP
CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE
EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE
GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED
NARGS OLDVALUE OPD READVICE SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET
TRYHARDER)))
(DECLARE: DONTCOPY EVAL@COMPILE
(FILESLOAD (IMPORT)
FILEPKG)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT)
(SPECVARS FNSLST FILEFLG))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG LAMBDAFONTLINELENGTH
PRETTYCOMFONT PRETTYHEADER BUILDMAPFLG FILERDTBL NORMALCOMMENTSFLG CHANGEFONT PRETTYEQUIVLST
PRETTYPRINTMACROS PRETTYTRANFLG **COMMENT**FLG FILEPKGFLG FONTCHANGEFLG DEFAULTFONT LAMBDAFONT
CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS ADDSPELLFLG COMMENTFLG)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA PPT PP* PP)
(ADDTOVAR NLAML PRETTYCOMPRINT)
(ADDTOVAR LAMA )
)
(PUTPROPS PRETTY COPYRIGHT ("Xerox Corporation" T 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5654 66188 (PRETTYDEF 5664 . 17978) (PRETTYDEF0 17980 . 18302) (PRETTYDEF1 18304 .
21910) (PRINTDATE 21912 . 24427) (PRINTDATE1 24429 . 26152) (PRINTFNS 26154 . 27319) (PRETTYCOM 27321
. 40875) (PRETTYCOMPRINT 40877 . 40953) (PRETTYVAR 40955 . 43016) (PRETTYVAR1 43018 . 46064) (
PRETTYCOM1 46066 . 47630) (ENDFILE 47632 . 47799) (MAKEDEFLIST 47801 . 48899) (PP 48901 . 49160) (PP*
49162 . 49480) (PPT 49482 . 49803) (PRETTYPRINT 49805 . 57843) (PRETTYPRINT1 57845 . 61141) (
PRETTYPRINT2 61143 . 63336) (PRINTDEF1 63338 . 63403) (SUPERPRINTEQ 63405 . 63529) (SUPERPRINTGETPROP
63531 . 63748) (CHANGEFONT 63750 . 64625) (READARRAY 64627 . 66186)) (66300 72484 (PRINTCOPYRIGHT
66310 . 70415) (PRINTCOPYRIGHT1 70417 . 71849) (SAVECOPYRIGHT 71851 . 72482)))))
STOP