(FILECREATED "31-Aug-86 16:45:25" {ERIS}<LISPCORE>SOURCES>PRETTY.;32 78247
changes to: (VARS PRETTYCOMS)
(FNS PRETTYDEF PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 PRETTYPRINT3)
previous date: " 2-Aug-86 16:31:35" {ERIS}<LISPCORE>SOURCES>PRETTY.;31)
(* 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 PRETTYPRINT3 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)
(*DEFAULT-FILE-ENVIRONMENT*))
(GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG
*DEFAULT-FILE-ENVIRONMENT*))
(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 FILERDTBL NORMALCOMMENTSFLG CHANGEFONT
PRETTYEQUIVLST PRETTYPRINTMACROS PRETTYTRANFLG **COMMENT**FLG FONTCHANGEFLG
DEFAULTFONT LAMBDAFONT CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS 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)
(* bvm: "30-Aug-86 18:43")
(DECLARE (SPECVARS PRTTYFILE REPRINTFNS SOURCEFILE CHANGES))
(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 ((NEWFILEMAP (AND BUILDMAPFLG (LIST NIL)))
(#RPARS #RPARS)
FILEFLG FNSLST PRTYOPENFLG PRTTYTEM PRETTYCOMSLST PRTTYSPELLFLG OLDFILEMAP MAPADR
NLAMALST NLAMLST LAMALST LAM?LST FILEDATES ORIGFLG ROOTNAME DESTINATIONENV
HEADERENV SOURCEFILENV FCLOCATION)
(DECLARE (SPECVARS *PACKAGE* *READTABLE* NEWFILEMAP ORIGFLG FILEFLG NLAMALST
PRTTYSPELLFLG PRETTYCOMSLST PRTTYCOMS LAM?LST FNSLST OLDFILEMAP
LAMALST MAPADR ORIGFLG NLAMLST DESTINATIONENV SOURCEFILENV #RPARS))
(* ; "NEWFILEMAP corresponds to the map being built for the file being written. OLDFILEMAP corresponds to the map that exists for SOURCEFILE, if any.")
(if (OR (NULL (\DTEST PRTTYFILE (QUOTE LITATOM)))
(EQ PRTTYFILE T))
then (* ;
"we no longer support any of the crufty alternatives to writing a brand new file")
(\ILLEGAL.ARG PRTTYFILE))
(SETQ ROOTNAME (ROOTFILENAME PRTTYFILE))
(SETQ DESTINATIONENV (if (SETQ DESTINATIONENV (OR (GET ROOTNAME (QUOTE
READER-ENVIRONMENT
))
*DEFAULT-FILE-ENVIRONMENT*))
then (SETQ HEADERENV (\DO-DEFINE-FILE-INFO NIL
DESTINATIONENV))
else (* ; "old style, not env info in header")
*OLD-INTERLISP-READ-ENVIRONMENT*))
(if (OR (EQ SOURCEFILE T)
(AND REPRINTFNS (NULL SOURCEFILE)))
then
(* * "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 definition 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))
(if SOURCEFILE
then (if [NULL (NLSETQ (SETQ SOURCEFILE (OPENSTREAM SOURCEFILE (QUOTE INPUT]
then (* ;
"OPENSTREAM 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)
elseif (RANDACCESSP SOURCEFILE)
then (RESETSAVE NIL (LIST (QUOTE CLOSEF)
SOURCEFILE))
(RESETSAVE (INPUT SOURCEFILE))
[if (EQ REPRINTFNS (QUOTE EXPRS))
then (SETQ REPRINTFNS T)
elseif (EQ REPRINTFNS (QUOTE CHANGES))
then (SETQ REPRINTFNS (UNION (FILEPKG.CHANGEDFNS CHANGES)
(FILEPKG.CHANGEDFNS (fetch
FILECHANGES
of
ROOTNAME
]
(MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP FCLOC)
(GET-ENVIRONMENT-AND-FILEMAP SOURCEFILE))
(if (NULL OLDFILEMAP)
then (* ;
"no map on file, so we will build one as needed")
(SETFILEPTR SOURCEFILE (OR FCLOC 0))
elseif (NULL (CAR OLDFILEMAP))
then (* ; "complete map.")
elseif (LISTP (CAR OLDFILEMAP))
then (* ; "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))
else (* ; "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))
(if (AND SOURCEFILENV (EQUAL-READER-ENVIRONMENT SOURCEFILENV
DESTINATIONENV))
then (* ;
"source and destination compatible, so we won't need to worry about it in PRETTYPRINT1/2")
(SETQ SOURCEFILENV NIL))
else (* ; "Can't copy from non-randaccessp source")
(SETQ SOURCEFILE NIL)))
[RESETSAVE NIL (LIST (FUNCTION PRETTYDEF0)
(SETQ PRTTYFILE (OPENSTREAM PRTTYFILE (QUOTE OUTPUT]
(* ;
"Cleans up by closing and deleting file if aborted.")
(RESETSAVE (OUTPUT PRTTYFILE))
(if HEADERENV
then (PRINT-READER-ENVIRONMENT HEADERENV))
(SETQ FCLOCATION (GETFILEPTR PRTTYFILE))
(WITH-READER-ENVIRONMENT DESTINATIONENV (if (NOT (SYNTAXP (CHARCODE "[")
(QUOTE LEFTBRACKET)
*READTABLE*))
then
(* ; "can't use brackets on this read table")
(SETQ #RPARS NIL))
(SETQ FILEDATES (PRINTDATE PRTTYFILE CHANGES))
(AND (NEQ COPYRIGHTFLG (QUOTE NEVER))
ROOTNAME
(PRINTCOPYRIGHT ROOTNAME))
(SETQ FILEFLG T)
(SETQ CHANGES (FILEPKG.CHANGEDFNS CHANGES))
(* ;
"Used freely by PRETTYPRINT to decide clispifying.")
(if (NOT (RANDACCESSP PRTTYFILE))
then (* ;
"No point building a map, since we won't be able to go back to the start to point at it")
(SETQ NEWFILEMAP NIL))
[if FONTCHANGEFLG
then (* ; "this is expensive in that it 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]
(if (OR (LISTP PRTTYFNS)
(LISTP (GETTOPVAL PRTTYFNS)))
then (* ;
"Ancient cruft from before the days of MAKEFILE.")
(PRINTFNS PRTTYFNS T)
(PRETTYCOM PRTTYFNS T))
(if [SETQ PRETTYCOMSLST (OR (LISTP PRTTYCOMS)
(AND (LITATOM PRTTYCOMS)
(LISTP (GETTOPVAL PRTTYCOMS]
then (PRETTYCOM PRTTYCOMS T)
(* ;
"PRTTYCOMS is just like the argument to a COMS command. see comment in prettycom1")
(for L on PRETTYCOMSLST do (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.")
)
(if (PRETTYDEF1)
then (* ;
"The coms were reprinted by PRETTYDEF1 due to a change to nlama and or nlaml")
elseif PRTTYSPELLFLG
then (* ; "A correction on prettycoms was performed, so dump it out aain to get the corrected version on the file.")
(PRETTYCOM PRTTYCOMS T))
(if (NEQ COPYRIGHTFLG (QUOTE NEVER))
then (SAVECOPYRIGHT ROOTNAME))
(if NEWFILEMAP
then (PRIN1 "(")
(PRIN2 (QUOTE DECLARE:))
(SPACES 1)
(PRIN2 (QUOTE DONTCOPY))
(TERPRI)
(SPACES 2)
(for ADR in MAPADR do (SETQ PRTTYTEM (GETFILEPTR PRTTYFILE))
(SETFILEPTR PRTTYFILE ADR)
(* ; "Write the current file positon into the filecreated expression, and then restores the file pointer.")
(PRIN2 PRTTYTEM)
(SETFILEPTR PRTTYFILE PRTTYTEM))
(PRIN2 (LIST (QUOTE FILEMAP)
NEWFILEMAP))
(* ;
"printed instead of prettyprinted, so wont take up two pages of listing.")
(PRIN1 (QUOTE ")
"))
(PUTFILEMAP (FULLNAME PRTTYFILE)
NEWFILEMAP NIL DESTINATIONENV NIL FCLOCATION)
(* ;
"Also save map, so can be used for subsequent makefiles.")
)
(ENDFILE PRTTYFILE)
(if (AND FILEDATES ROOTNAME)
then (/replace FILEDATES of ROOTNAME with FILEDATES)))
(RETURN (FULLNAME PRTTYFILE])
(PRETTYDEF0
[LAMBDA (MADEFILE) (* bvm: " 2-Aug-86 16:24")
(* Cleans up after prettydef in case
of control-d.)
(COND
((OPENP MADEFILE (QUOTE OUTPUT))
(DELFILE (CLOSEF MADEFILE])
(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 (OUTSTREAM CHANGES) (* bvm: " 1-Aug-86 15:51")
(* * "assumes that OUTSTREAM is a file open for output, and prints the date information for that file on it")
(PROG ((DAT (DATE))
(ROOTNAME (ROOTFILENAME OUTSTREAM))
PREVPAIR FILEDATES)
(if FILEPKGFLG
then [if ROOTNAME
then (/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 ← (FULLNAME OUTSTREAM))
(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 OUTSTREAM 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 (OUTSTREAM CHANGES DAT PREVDATE PREVERS TERMINATING.STRING)
(* bvm: " 1-Aug-86 15:55")
(* * "does the printing for PRINTDATE")
(printout OUTSTREAM .FONT DEFAULTFONT "(FILECREATED " .P2 DAT , .FONT LAMBDAFONT .P2 (FULLNAME
OUTSTREAM)
.FONT DEFAULTFONT) (* "note that CHANGEFONT checks for FONTCHANGEFLG explicitly so that it won't do anything if FONTCHANGEFLG is NIL")
(if (AND BUILDMAPFLG (NOT (DISPLAYP OUTSTREAM)))
then (push MAPADR (ADD1 (GETFILEPTR OUTSTREAM)))
(PRIN3 " " OUTSTREAM) (* "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 push is because of a feature no longer used where there could be two FILECREATED expressions at the head of a file font")
)
[if FILEPKGFLG
then (if CHANGES
then (printout OUTSTREAM T T 6 "changes to: " .PPVTL CHANGES))
(if PREVDATE
then (printout OUTSTREAM T T 6 "previous date: " .P2 PREVDATE)
(if PREVERS
then (printout OUTSTREAM , .P2 PREVERS]
(PRIN1 (OR TERMINATING.STRING ")
")
OUTSTREAM])
(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) (* bvm: "30-Aug-86 18:26")
(* 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 ((CLK (CLOCK 0))
(NEWADRLST (LISTP PRETTYDEFLG))
[FILEFLG (NOT (DISPLAYP (OUTPUT]
FN DEF ADR LST SKIPPEDLST TEM) (* 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 (CLOCKDIFFERENCE CLK)
30000)) (* Every 30 seconds say what function
we're working on)
(SETQ CLK (CLOCK 0))
(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)) (* No fn definition, but is a
variable. 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 SOURCEFILENV)
[NULL (SELECTQ REPRINTFNS
(ALL T)
((T EXPRS)
(EXPRP FN))
(AND (LISTP REPRINTFNS)
(FMEMB FN REPRINTFNS]
(PRETTYPRINT1 FN)) (* Was a fn to be copied from old
file, and we succeeded)
)
(T (* Prettyprint afresh)
(PRETTYPRINT3 FN DEF PRETTYDEFLG]
DEFPRINTED
(* * At this point we have prettyprinted FN one way or another)
(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) (* bvm: "30-Aug-86 17:25")
(* * Like BRECOMPILE1. Obtains FN from SOURCEFILE.
works whether the file has previously been mapped by PRETTYDEF, LOAD, or
LOADFNS (or patially mapped))
(WITH-READER-ENVIRONMENT (OR SOURCEFILENV DESTINATIONENV)
(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) (* bvm: "30-Aug-86 18:13")
(* 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)
([for X in OLDFILEMAP thereis (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 RATOM instead of simply
setting file ptr to (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)))
(if (NULL SOURCEFILENV)
then (* ;
"compatible environments, just copy characters")
(COPYCHARS SOURCEFILE PRTTYFILE FROM TO)
else (* ;
"incompatible, have to read old def and reprettyprint")
(SETQ TEM (READ SOURCEFILE)) (* ; "old definition")
(WITH-READER-ENVIRONMENT DESTINATIONENV (PRETTYPRINT3 FN TEM T)))
(* Initial and final TERPRI's are done
by callers; they are not in map.)
(RETURN FN])
(PRETTYPRINT3
[LAMBDA (FN DEF PRETTYDEFLG) (* bvm: "30-Aug-86 17:18")
(LET (TEM)
(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)))
(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 %)))
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)
(RPAQ? *DEFAULT-FILE-ENVIRONMENT* )
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG
*DEFAULT-FILE-ENVIRONMENT*)
)
(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 FILERDTBL NORMALCOMMENTSFLG CHANGEFONT PRETTYEQUIVLST
PRETTYPRINTMACROS PRETTYTRANFLG **COMMENT**FLG FONTCHANGEFLG DEFAULTFONT LAMBDAFONT
CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS 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 (5801 67903 (PRETTYDEF 5811 . 19379) (PRETTYDEF0 19381 . 19761) (PRETTYDEF1 19763 .
23369) (PRINTDATE 23371 . 25308) (PRINTDATE1 25310 . 26871) (PRINTFNS 26873 . 28038) (PRETTYCOM 28040
. 41594) (PRETTYCOMPRINT 41596 . 41672) (PRETTYVAR 41674 . 43735) (PRETTYVAR1 43737 . 46783) (
PRETTYCOM1 46785 . 48349) (ENDFILE 48351 . 48518) (MAKEDEFLIST 48520 . 49618) (PP 49620 . 49879) (PP*
49881 . 50199) (PPT 50201 . 50522) (PRETTYPRINT 50524 . 57026) (PRETTYPRINT1 57028 . 60522) (
PRETTYPRINT2 60524 . 63320) (PRETTYPRINT3 63322 . 65051) (PRINTDEF1 65053 . 65118) (SUPERPRINTEQ 65120
. 65244) (SUPERPRINTGETPROP 65246 . 65463) (CHANGEFONT 65465 . 66340) (READARRAY 66342 . 67901)) (
68016 74200 (PRINTCOPYRIGHT 68026 . 72131) (PRINTCOPYRIGHT1 72133 . 73565) (SAVECOPYRIGHT 73567 .
74198)))))
STOP