(FILECREATED " 4-Jul-85 14:41:11" {ERIS}<LISPCORE>SOURCES>PRETTY.;18 101821
changes to: (FNS PRETTYCOM)
previous date: "15-Feb-85 08:01:03" {ERIS}<LISPCORE>SOURCES>PRETTY.;17)
(* Copyright (c) 1984, 1985 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 PRINTDEF SUPERPRINT
SUPERPRINT0 SUPERPRINTEQ SUPERPRINTGETPROP RPARS SUBPRINT SUBPRINT1 SUBPRINT2
CHANGEFONT CHANGFONT PRINTPROG ENDLINE ENDLINE1 TABTO READARRAY FITP FITP1
FITP2 WIDEPAPER ISTTYP)
[COMS (DECLARE: DONTCOPY EVAL@COMPILEWHEN (EQ (COMPILEMODE)
(QUOTE D))
(ADDVARS (DONTCOMPILEFNS CHANGEFONT))
(MACROS CHANGFONT))
[DECLARE: DONTCOPY EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE D))
(BLOCKS (NIL CHANGEFONT (LINKFNS . T]
(DECLARE: DOCOPY (DECLARE: EVAL@LOADWHEN (EQ (SYSTEMTYPE)
(QUOTE D))
(P (MOVD (QUOTE DSPFONT)
(QUOTE CHANGEFONT]
(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))
(FNS COMMENT1 COMMENT2 COMMENT3 COMMENT4 COMMENT5)
(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))
[DECLARE: DONTEVAL@LOAD DOCOPY (P (WIDEPAPER)
(SETLINELENGTH)
(MOVD? (QUOTE ISTTYP)
(QUOTE DISPLAYP))
(MOVD? (QUOTE NILL)
(QUOTE COMPUTEPRETTYPARMS]
(BLOCKS (PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT)
(SPECVARS FNSLST FILEFLG))
(PRETTYBLOCK PRINTDEF SUPERPRINT SUPERPRINT0 SUPERPRINTEQ SUPERPRINTGETPROP SUBPRINT
SUBPRINT1 SUBPRINT2 CHANGFONT PRINTPROG RPARS ENDLINE ENDLINE1 TABTO
FITP FITP1 FITP2 COMMENT1 COMMENT2
(ENTRIES PRINTDEF CHANGFONT ENDLINE1 COMMENT1 FITP SUPERPRINTEQ
SUPERPRINTGETPROP)
(LOCALFREEVARS I LASTCOL FORMFLG E TAIL TAILFLG EXPR CRCNT FILEFLG
FNSLST CHANGEFLG DEF)
(BLKLIBRARY GETPROP)
(SPECVARS CHANGEFLG LASTCOL FILEFLG E TAIL EXPR TYPE))
(NIL COMMENT3 COMMENT4 COMMENT5 ENDFILE ISTTYP MAKEDEFLIST PP PP* PPT PRETTYCOM
PRETTYCOM1 PRETTYCOMPRINT PRETTYDEF PRETTYDEF0 PRETTYDEF1 PRETTYVAR PRETTYVAR1
PRINTDATE PRINTDATE1 PRINTDEF1 PRINTFNS READARRAY WIDEPAPER (LINKFNS . T)))
(GLOBALVARS UCASELST LCASELST DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST
DWIMLOADFNSFLG LAMBDAFONTLINELENGTH PRETTYCOMFONT WIDEPAPERFLG PRETTYHEADER
BUILDMAPFLG FILERDTBL NORMALCOMMENTSFLG FILELINELENGTH FONTFNS FONTWORDS USERFONT
CLISPFONT SYSTEMFONT COMMENTFONT CHANGEFONT PRETTYTABFLG AVERAGEFNLENGTH
AVERAGEVARLENGTH #CAREFULCOLUMNS CHANGECHAR LASTFONT CHANGEFLG0 DISPLAYTERMFLG
PRETTYEQUIVLST COMMENTLINELENGTH CHANGEFLG0 ENDLINEUSERFN FONTPROFILE PRETTYFLG
CHANGESARRAY PRETTYPRINTYPEMACROS PRETTYPRINTMACROS CLISPTRANFLG PRETTYTRANFLG
CLISPARRAY #RPARS CLISPCHARS FUNNYATOMLST CHCONLST CLISPFLG PRETTYLCOM FIRSTCOL
**COMMENT**FLG ABBREVLST CHANGECHARTABSTR FILEPKGFLG FONTCHANGEFLG DEFAULTFONT
LAMBDAFONT CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS ADDSPELLFLG
COMMENTFLG CLISPIFYPACKFLG)
(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])
)
(DEFINEQ
(PRETTYDEF0
[LAMBDA (PRTTYFILE) (* Cleans up after prettydef in case of control-d.)
(COND
((SETQ PRTTYFILE (OPENP PRTTYFILE (QUOTE OUTPUT)))
(CLOSEF PRTTYFILE)
(DELFILE PRTTYFILE])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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 ")
"])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(PRETTYCOMPRINT
[NLAMBDA (X)
(AND PRETTYHEADER (LISPXPRINT X T T])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(ENDFILE
[LAMBDA (FILE) (* wt: "10-SEP-78 13:54")
(PRINT (QUOTE STOP)
FILE)
(CLOSEF FILE])
)
(DEFINEQ
(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])
)
(DEFINEQ
(PP
[NLAMBDA X (* lmm "14-Aug-84 19:09")
(DECLARE (LOCALVARS . T))
(RESETLST (RESETSAVE (OUTPUT T))
(RESETSAVE (SETREADTABLE T))
(PRETTYPRINT (NLAMBDA.ARGS X])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(PRETTYPRINT
[LAMBDA (FNS PRETTYDEFLG FNSLST) (* rmk: "23-NOV-81 14:56")
(* 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*,)
(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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(PRINTDEF1
[LAMBDA (EXPR)
(PRINTDEF EXPR)
(TERPRI])
)
(DEFINEQ
(PRINTDEF
[LAMBDA (EXPR LEFT DEF TAILFLG FNSLST FILE) (* rmk: " 8-AUG-82 22:28")
(RESETLST (* RESETLST is here so stuff under here can save things,
e.g. change RADIX or prettyprint parameters)
(AND FILE (RESETSAVE (OUTPUT FILE)))
(AND LEFT (NOT (NUMBERP LEFT))
(SETQ LEFT (POSITION)))
(RESETVARS ((FONTCHANGEFLG FONTCHANGEFLG)
(COMMENTLINELENGTH COMMENTLINELENGTH)
(FIRSTCOL FIRSTCOL))
(RETURN (PROG [(I (OR LEFT 0))
(LASTCOL (LINELENGTH))
(FORMFLG DEF)
HELPCLOCK
(CRCNT 0)
CHANGEFLG
(FILEFLG (NOT (DISPLAYP (OUTPUT]
(SETQ FONTCHANGEFLG (COND
((OR FILEFLG (EQ FONTCHANGEFLG (QUOTE ALL)))
(* if FILEFLG is NIL and fontchangeflg is T, this resets
it to NIL.)
FONTCHANGEFLG)))
(COMPUTEPRETTYPARMS)
(* adjust anything the font people care about)
(SETQ CHANGEFLG0 NIL)
(AND FONTCHANGEFLG (CHANGFONT DEFAULTFONT))
(COND
[(NULL PRETTYFLG)
(COND
(TAILFLG (MAPRINT EXPR NIL NIL NIL NIL
(FUNCTION PRIN2)))
(T (PRIN2 EXPR]
(T (TAB I T)
(COND
(TAILFLG (SUBPRINT EXPR))
(T (SUPERPRINT EXPR])
)
(DEFINEQ
(SUPERPRINT
[LAMBDA (E BRFLG) (* wt: "25-FEB-80 19:10")
(COND
[(AND (LISTP E)
CHANGESARRAY
(GETHASH E CHANGESARRAY))
(PROG ((CHANGEFLG CHANGEFLG)
TEM)
(COND
((AND (OR FILEFLG DISPLAYTERMFLG)
(NULL CHANGEFLG)
CHANGECHAR)
(* Causes ENDLINE to print CHANGECHAR in right margin. The reason for the two flags is that the endline may occur
outside of the scope of CHANGEFLG, and yet there needs to be a flag true for all of E because subepxressions may not
and usually are not also marked as changed. Thus ENDLINE prints changechar whenever either CHANGEFLG or CHANGEFLG0
is T, and in addition, if CHANGEFLG is T, it resets CHANGEFLG0 to T (for the next time))
(SETQ CHANGEFLG0 T)
(SETQ CHANGEFLG T)))
(AND FONTCHANGEFLG CHANGEFONT (SETQ TEM (CHANGFONT CHANGEFONT)))
(* print E in different font)
(RETURN (PROG1 (SUPERPRINT0 E BRFLG)
(AND TEM (CHANGFONT TEM]
(T (SUPERPRINT0 E BRFLG])
)
(DEFINEQ
(SUPERPRINT0
[LAMBDA (E BRFLG) (* lmm "25-Sep-84 10:36")
(* BRFLG says do not print a %), expression will be terminated by a %]. Value is T if a carraiger return was
printed, NIL otherwise.)
(PROG (TEM1 TEM2 (TYP (TYPENAME E)))
[COND
((AND CLISPTRANFLG (NULL PRETTYTRANFLG)
(EQ TYP (QUOTE LISTP))
(EQ (CAR E)
CLISPTRANFLG)) (* PRETTYTRANFLG=NIL means print the CLISP.
Done here instead of inside LAMBDA below because CDDR E
might be an atom.)
(SETQ E (CDDR E))
(SETQ TYP (TYPENAME E]
MACROLP
[COND
((AND (EQ TYP (QUOTE LISTP))
(SETQ TEM1 (FASSOC (CAR E)
PRETTYPRINTMACROS)))
(* Gives user a hook in which to format selected expressions himself. he can either do the printing himself, or
return the expression to be prited. e.g. CLISP% things could have been handled this way. or printing comments on
the teletype could also have been handled this way.)
(COND
((NULL (SETQ TEM1 (APPLY* (CDR TEM1)
E)))
(RETURN E))
((PROG1 (NEQ E TEM1)
(SETQ E TEM1)
(SETQ TYP (TYPENAME E)))
(GO MACROLP]
[COND
([AND (NEQ TYP (QUOTE LISTP))
[NOT (IGREATERP I (SETQ TEM1 (POSITION]
(IGREATERP (ADD1 TEM1)
(SETQ TEM2 (IDIFFERENCE LASTCOL (NCHARS E T]
(* TEM2 is the first column at which the ATOM will fit
on a line.)
(ENDLINE (COND
((IGREATERP (SETQ TEM2 (IPLUS TEM2 -5))
I) (* This is (MIN P-5 I))
I)
(T TEM2]
(COND
[(EQ TYP (QUOTE LISTP))
(PROG [(I (IPLUS I (COND
((NLISTP (CAR E))
2)
((NULL DEF)
1)
((OR (NULL FORMFLG)
(SUPERPRINTEQ (CAAR E)
(QUOTE LAMBDA)))
(* In function definition, the sublists in a list of
lists are aligned except for the indicatd cases.)
2)
(T 1]
[COND
((AND DEF FORMFLG (SUPERPRINTEQ (CAR E)
COMMENTFLG))
(RETURN (PROG ((TAIL))
(RETURN (COMMENT1 E T]
(COND
((AND #RPARS (NULL BRFLG)
(RPARS E))
(PRIN1 (QUOTE %[))
(SETQ BRFLG T)
(SETQQ TEM1 %]))
(T (PRIN1 (QUOTE %())
(SETQ TEM1 NIL)))
[COND
([AND PRETTYTRANFLG (OR (AND CLISPARRAY [COND
[(LITATOM (CAR E))
(NULL (OR (FGETD (CAR E))
(GETLIS (CAR X)
MACROPROPS]
((LISTP (CAR E))
(NULL (OR (SUPERPRINTEQ (CAAR E)
(QUOTE LAMBDA))
(SUPERPRINTEQ (CAAR E)
(QUOTE NLAMBDA]
(SETQ TEM2 (GETHASH E CLISPARRAY)))
(AND CLISPTRANFLG (EQ (CAR E)
CLISPTRANFLG)
(SETQ TEM2 (CADR E))
(SETQ E (CDDR E]
(* If (CAR E) is an atom, and it is the name of a function, a translation wouldnt be invoked, so dont bother to
check for one.)
(COND
((EQ PRETTYTRANFLG T) (* PRETTYTRANFLG=T means print the translation.)
(SETQ E TEM2))
(T
(* For other values, e.g. BOTH, an xpression of the form (CLISP% translation . expression) is printed,
(even when the translation was originaly in the hash array). This saves both, and when reloaded, and dwiified or
run, CLISP% rehashes and removes the CLISP% (assuming CLISPARRAY is set up that way))
(PRIN2 CLISPTRANFLG)
(SUPERPRINT TEM2 BRFLG)
(ENDLINE]
(SUBPRINT E BRFLG)
[COND
((NOT (ILESSP (POSITION)
LASTCOL))
(PROG (TAIL)
(* need to rebind tail, because if next expressionis a comment, dont want to print it now, because we still have the
right paren to print.)
(ENDLINE]
(COND
(TEM1 (PRIN1 TEM1))
((NULL BRFLG)
(PRIN1 (QUOTE %)]
([AND (NEQ TYP (QUOTE LITATOM))
(SETQ TEM1 (CDR (FASSOC TYP PRETTYPRINTYPEMACROS]
(* Gives user a hook to specify how data types other
than lists or atoms are to be printed.)
(APPLY* TEM1 E))
(T (PRIN2 E)))
(RETURN E])
)
(DEFINEQ
(SUPERPRINTEQ
[LAMBDA (X Y)
(OR (EQ X Y)
(AND Y (EQ (CDR (FASSOC X PRETTYEQUIVLST))
Y])
)
(DEFINEQ
(SUPERPRINTGETPROP
[LAMBDA (ATM PROP) (* wt: "17-SEP-79 15:57")
(OR (GETPROP (CDR (FASSOC ATM PRETTYEQUIVLST))
PROP)
(GETPROP ATM PROP])
)
(DEFINEQ
(RPARS
[LAMBDA (E)
(SELECTQ (CAR E)
([LAMBDA NLAMBDA]
T)
(DEFINEQ (* Dont want square brakcets around DEFINEQ's
expressions, because this means last function pair is
special with respect to LOaDFNS.)
NIL)
(PROG ((N 1)
(X E)
Y
(Z E))
LP (COND
([LISTP (SETQ X (CDR (SETQ Y X]
(GO LP))
((LISTP (SETQ X (CAR Y)))
(ADD1VAR N)
(SETQ Z X)
(GO LP))
(T (RETURN (NOT (ILESSP N #RPARS])
)
(DEFINEQ
(SUBPRINT
[LAMBDA (TAIL BRFLG END) (* lmm "25-Sep-84 10:38")
(PROG (CURRENT DOCRFLG (TAIL0 TAIL)
(I0 (POSITION))
NEXT TEM CRCNT0 CLISPWORD (FORMFLG0 FORMFLG)
FORMFLG)
LP (COND
((OR (NULL TAIL)
(EQ TAIL END))
(RETURN TAIL))
((NLISTP TAIL)
(PRIN1 (QUOTE " . "))
(SUPERPRINT TAIL)
(RETURN)))
(SETQ CRCNT0 CRCNT)
(SETQ CURRENT (CAR TAIL))
(AND CLISPFLG DEF FORMFLG0 (SETQ CLISPWORD (AND (SETQ TEM (SUPERPRINTGETPROP CURRENT
(QUOTE
CLISPWORD)))
(ATOM (CAR TEM))
[EQ (CAR TEM)
(CAR (SUPERPRINTGETPROP (CAR TAIL0)
(QUOTE
CLISPWORD]
TEM)))
(SETQ TEM NIL)
(AND DEF FONTCHANGEFLG (LITATOM CURRENT)
(SETQ TEM (COND
((LISTP CLISPWORD)
CLISPFONT)
((AND FONTWORDS (FMEMB CURRENT FONTWORDS))
USERFONT)
((AND (EQ TAIL0 TAIL)
(NULL END))
(COND
((OR (FMEMB CURRENT FNSLST)
(FMEMB CURRENT (LISTP FONTFNS)))
USERFONT)
((FGETD CURRENT)
SYSTEMFONT)))
((AND (SUPERPRINTGETPROP CURRENT (QUOTE CLISPTYPE))
(NOT (FMEMB CURRENT CLISPCHARS))) (* Infix operators like GT, AND, etc.)
CLISPFONT)))
(SETQ TEM (CHANGFONT TEM)))
(* When printing a function, via a caal to prettydef, and fontflg is turned on, and the function is either on FNS or
on FONTFLG, do a fontchange.)
(SETQ FORMFLG (COND
[(SUPERPRINTEQ (CAR TAIL0)
(QUOTE SELECTQ))
(OR (EQ CURRENT (CADR TAIL0))
(NULL (CDR TAIL]
((OR (SUPERPRINTEQ (CAR TAIL0)
(QUOTE COND))
(SUPERPRINTEQ (CAR TAIL0)
(QUOTE QUOTE)))
NIL)
(T T)))
(* says whether next expression is to be treated as a form. used to be an argument to superprint, but this value of
formflg shuld also affect the call to endline from subprint.)
(SETQ CURRENT (SUPERPRINT CURRENT (AND (NULL (CDR TAIL))
BRFLG))) (* Reason for the SETQ is in case user prints a list as
an atom via prtttyprintmacros, e.g.
(QUOTE X) as 'X.)
(SETQ TAIL (CDR TAIL))
(* the setq tail used to be in the call to superprint, i.e. buried in he AND. thi meant that if the call to endline
in superprint thatoccurs before the expression is printed, i.e. cause wont fit, occurred, and the next thing was a
comment, that the comment wold be (mistakenly) printed before this expression, via endline.)
(AND TEM (CHANGFONT TEM)) (* CURRENT is always the element just printed, NEXT the
one about to be printed, i.e. CAR of E.)
(* BRFLG only affects last expression in list.)
LP0 (COND
((EQ TAIL END)
(RETURN TAIL))
((NLISTP TAIL)
(GO LP))
((OR (NULL CLISPFLG)
(NULL DEF)
(NULL FORMFLG0))
(GO LP1))
[(NOT (LITATOM (SETQ NEXT (CAR TAIL]
([AND (SETQ TEM (SUPERPRINTGETPROP NEXT (QUOTE CLISPWORD)))
(OR (NLISTP TEM)
(EQ (CAR TEM)
(CAR (SUPERPRINTGETPROP (CAR TAIL0)
(QUOTE CLISPWORD]
(* AND and OR are treated like prettywords because they are broadscope operators, i.e. they permit segments, and
therefore the standard FITP test can't be ued.)
(GO CLISPWORD))
((EQ (CHCON1 NEXT)
(CHARCODE <))
[COND
[(EQ (SETQ TEM (SUBPRINT2 TAIL END))
(CDR TAIL))
(COND
((AND (LITATOM CURRENT)
(STRPOS (QUOTE "←")
CURRENT)
(NEQ (NTHCHARCODE CURRENT -1)
(CHARCODE ←)))
(GO CR))
(T (GO LP1]
((OR (LISTP CURRENT)
(AND (STRPOS (QUOTE "←")
CURRENT)
(NEQ (NTHCHARCODE CURRENT -1)
(CHARCODE ←)))
(NOT (FITP TAIL NIL TEM)))
(ENDLINE))
(T (SPACES 1)
(AND (EQ (CDR TAIL0)
TAIL)
(SETQ I (POSITION]
(SETQ CRCNT0 CRCNT)
(PROG (I)
(SETQ I (IPLUS (POSITION)
2))
(SETQ TAIL (SUBPRINT TAIL BRFLG TEM)))
(SETQQ CURRENT >)
(GO LP0))
([AND (EQ [CAR (LISTP (CDR (LISTP TAIL]
(QUOTE ←))
(OR (SUPERPRINTEQ (CAR TAIL0)
(QUOTE CREATE))
(SUPERPRINTEQ (CAR TAIL0)
(QUOTE create]
(GO CR)))
(COND
((LISTP CURRENT)
(AND (LITATOM NEXT)
(NOT (BOUNDP NEXT))
(NOT (FMEMB NEXT FUNNYATOMLST))
(FMEMB (SETQ TEM (NTHCHAR NEXT 1))
CLISPCHARS)
(NEQ TEM (QUOTE <))
(NOT (SUPERPRINTGETPROP TEM (QUOTE UNARYOP)))
(GO LP)) (* E.g. ((FOO) *FIE))
)
((NOT (LITATOM CURRENT))
(GO LP1))
((OR (EQ (CAR CLISPWORD)
(QUOTE IFWORD))
(EQ (CAR CLISPWORD)
(QUOTE FORWORD)))
(SETQ DOCRFLG NIL)
(AND (NULL END)
(SETQ END T)) (* See use of END at LP2 beloow)
)
((AND (LISTP NEXT)
CLISPIFYPACKFLG
[COND
[(EQ (CDR TAIL0)
TAIL)
(AND (NULL (FGETD CURRENT))
(NOT (GETLIS CURRENT MACROPROPS))
(NULL (SUPERPRINTGETPROP CURRENT (QUOTE EXPR]
(T (NOT (BOUNDP CURRENT]
(NOT (FMEMB CURRENT FUNNYATOMLST))
(FMEMB (SETQ TEM (NTHCHAR CURRENT -1))
CLISPCHARS)
(NEQ TEM (QUOTE >))
(NOT (FASSOC (CAR NEXT)
PRETTYPRINTMACROS)))
(* E.g. X* (FOO): Don't space unless CLISPIFYPACKFLG is NIL or FOO has a macro (which might make it turn into a
non-list))
(GO LP))
((AND (STRPOS (QUOTE "←")
CURRENT)
(NEQ (NTHCHARCODE CURRENT -1)
(CHARCODE ←))) (* E.G. IF -- THEN FOO←X FIE←Y is more readable if the
assignments are on separate lines.)
(GO CR)))
LP1 [COND
((EQ (CDR TAIL0)
TAIL) (* First time through, i.e. just superprinted HEAD of
list.)
(AND DEF FORMFLG0 (SELECTQ (OR (CDR (FASSOC CURRENT PRETTYEQUIVLST))
CURRENT)
(COND (GO CR))
((PROG RESETVARS)
(PRINTPROG TAIL BRFLG)
(RETURN))
((ASSEMBLE ASSEM)
(RESETFORM (RADIX 8)
(PRINTPROG TAIL BRFLG))
(RETURN))
(SELECTQ (SETQ DOCRFLG T)
(* To insure carriage return after select-expression)
)
((SETQ RESETVAR)
(GO SP))
(FUNCTION (AND (NULL (CDR TAIL))
(GO SP))
(* Normally, I is not reset for FUNCTION, and the margin for the body of the lambda definition is directly under
FUNCTION to conserve space. However, when FUNCTION is given a second argument, this would cause confusion, so I is
reset in this case.)
)
([LAMBDA NLAMBDA]
(SETQ DOCRFLG T)
(SPACES 1)
(GO LP))
NIL))
(COND
([OR (LISTP CURRENT)
(NULL (FITP TAIL T (OR (LISTP END)
(AND CLISPWORD (SUBPRINT1 TAIL (CAR CLISPWORD]
(* Don't reset I.)
(GO CR))
((EQ (CHCON1 CURRENT)
(CHARCODE <))
(GO SP))
(T
(* Don't go to SP to space because don't want DOCRFLG changed, i.e. if U=SELECTQ, then DOCRFLG has been set to
insure carriage return after selector.)
(SPACES 1)
(SETQ I (POSITION))
(GO LP]
LP2 (AND (NEQ CRCNT0 CRCNT)
(OR (NOT (ATOM CURRENT))
(EQ CURRENT (QUOTE >)))
(GO CR))
(* Printing last "thing" (usually a list) caused a c.r. Also occurs if printing angle brackets which contain a list
inside, e.g. < (FOO (FIE) X) > and c.r. will occur after >.)
(* I disabled the listp check because henry wanted to be able to force a c.r. via a prettyprintype macro.
if this doesnt work, rethink.)
(SETQ NEXT (CAR TAIL))
(COND
[(LISTP CURRENT)
(COND
((OR (NULL END)
(SUPERPRINTEQ (CAR CURRENT)
COMMENTFLG))
(GO CR))
((AND (LISTP NEXT)
(SUPERPRINTEQ (CAR NEXT)
COMMENTFLG))
(GO SP))
([AND (LITATOM NEXT)
(OR (SUPERPRINTGETPROP NEXT (QUOTE CLISPWORD))
(SUPERPRINTGETPROP NEXT (QUOTE CLISPTYPE]
(GO SP))
(T (GO CR]
((NLISTP NEXT)
(GO SP))
(DOCRFLG
(* DOCRFLG is set to T whenever a carriage return is performed. It is reset to NIL whenever a carriage return is NOT
performed, e.g. when two atoms are adjacent. while it is T, carriage returns are performed FOLLOWING all
expressions. For example, in -
(A B (C) D (E) F G (H)) (C) D (E) and F would be on separate lines, but F, G, and (H) would all be ont he same
line.)
(GO CR))
((FITP NEXT)
(GO SP))
(T (GO CR)))
SP (SETQ DOCRFLG NIL)
(SPACES 1)
(GO LP)
CR (SETQ DOCRFLG T)
(ENDLINE)
(GO LP)
CLISPWORD
(PROG ((I I)
(I0 I0))
(SETQ TEM (SELECTQ (OR (CDR (FASSOC NEXT PRETTYEQUIVLST))
NEXT)
((THEN
ELSE
ELSEIF
then
else
elseif) (* THEN, ELSE, and ELSEIF always start a new line.)
[SETQ I (ADD1 (ENDLINE (IPLUS I0 (COND
((OR (EQ NEXT (QUOTE THEN))
(EQ NEXT (QUOTE then)))
3)
(T 1]
(* Note that in most cases, I will be reset again in subprint after printing the CLISPWORD. It will remain this
value only if the nexxt expression wont fit.)
(SETQ TAIL (SUBPRINT TAIL BRFLG (SUBPRINT1 (CDR TAIL)
(QUOTE IFWORD)
END)))
(RETURN))
((AND OR and or) (* So when new left margin is coputed in next cond, it
will be based on inner expression.)
(SETQ I0 I)
(SUBPRINT1 (CDR TAIL)
NIL END))
((! !!)
(CDDR TAIL))
(SUBPRINT1 (CDR TAIL)
(CAR (GETP (CAR TAIL0)
(QUOTE CLISPWORD)))
END)))
[SETQ I (ADD1 (COND
((OR (PROG1 (NEQ CRCNT0 CRCNT)
(* Last expression involved a carriage return, so start
on new line, e.g. for X in (FOO
(FIE) (FUM)) do --)
)
(PROG1 [AND [LISTP (CAR (LISTP (CDR TAIL]
(for TL on (CDDR TAIL) until (EQ TL TEM)
thereis (LISTP (CAR TL]
(* There is more than one LISTP expression between here and next CLISPWORD, if any, so this segment will be on
several lines. Break now to avoid having a large segment squashed up on the right)
)
(PROG1 (NOT (FITP TAIL NIL TEM))
(* If the segment of the list between here and the next
CLISPFORWORD will not fit, carriage return now.)
))
(ENDLINE (IPLUS I0 2)))
(T (SPACES 1)
(POSITION]
(SETQ CRCNT0 CRCNT)
(SETQ CURRENT (CAR (NLEFT TAIL 1 TEM)))
(SETQ TAIL (SUBPRINT TAIL BRFLG TEM)))
(GO LP0)
(* We are now in the position of just having printed the element bbefore E, and are ready to look ahead at the next
one, so go to LP0.)
])
)
(DEFINEQ
(SUBPRINT1
[LAMBDA ($TAIL X END) (* wt: "30-JUL-78 13:01")
(* Searches E to END for an element that is a ember of
L.)
(PROG (TEM)
LP (COND
((OR (EQ $TAIL END)
(NLISTP $TAIL))
(RETURN $TAIL))
((AND (LITATOM (CAR $TAIL))
(SETQ TEM (GETPROP (CAR $TAIL)
(QUOTE CLISPWORD)))
(OR (NULL X)
(EQ (CAR TEM)
X)))
(RETURN $TAIL))
((AND (EQ X (QUOTE RECORDWORD))
(EQ (CADR $TAIL)
(QUOTE ←)))
(RETURN $TAIL)))
(SETQ $TAIL (CDR $TAIL))
(GO LP])
)
(DEFINEQ
(SUBPRINT2
[LAMBDA ($TAIL END)
(PROG ((N 0)
L)
LP (COND
((OR (EQ $TAIL END)
(NLISTP $TAIL))
(RETURN $TAIL))
((NOT (LITATOM (CAR $TAIL)))
(SETQ $TAIL (CDR $TAIL))
(GO LP)))
(SETQ L (DUNPACK (CAR $TAIL)
CHCONLST))
(SETQ $TAIL (CDR $TAIL))
LP1 [COND
((NULL L)
(COND
((ZEROP N)
(RETURN $TAIL)))
(GO LP))
((EQ (CAR L)
(QUOTE <))
(SETQ N (ADD1 N)))
((EQ (CAR L)
(QUOTE >))
(SETQ N (SUB1 N]
(SETQ L (CDR L))
(GO LP1])
)
(DEFINEQ
(CHANGEFONT
[LAMBDA (FONTCLASS FILE) (* rmk: "12-Sep-84 22:50")
(* 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 (PROG [(FILEFLG (NOT (DISPLAYP FILE]
(RETURN (CHANGFONT FONTCLASS FILE])
)
(DEFINEQ
(CHANGFONT
[LAMBDA (FONTCLASS FILE) (* rmk: " 8-AUG-82 22:26")
(* This is less general than the FONTSETUP interface,
since we only know about symbolic files and displays.)
(PROG (FSPEC)
(COND
((EQ FONTCLASS LASTFONT)
(RETURN LASTFONT))
[(LISTP FONTCLASS)
(COND
(FILEFLG (AND [OR (NULL (SETQ FSPEC (CAR FONTCLASS)))
(EQ FSPEC (CAR (LISTP LASTFONT]
(RETURN LASTFONT)) (* NULL check cause font may not exist for all devices)
(PRIN3 FSPEC FILE))
(T (AND [OR (NULL (SETQ FSPEC (CADR FONTCLASS)))
(EQ FSPEC (CADR (LISTP LASTFONT]
(RETURN LASTFONT)) (* We require all display-changing implementations to
provide DSPFONT and OUTPUTDSP functions)
(DSPFONT FSPEC (OUTPUTDSP FILE]
(T (ERROR "undefined font" FONTCLASS)))
(RETURN (PROG1 LASTFONT (SETQ LASTFONT FONTCLASS])
)
(DEFINEQ
(PRINTPROG
[LAMBDA (TAIL BRFLG) (* rmk: "23-MAY-82 23:56")
(PROG (V (I (IPLUS (POSITION)
-3))
CLISPTEM
(FORMFLG T)) (* Resets I to column corresponding to to the 'R' in
'PROG'. This is the column PROG labels start in.)
(SPACES 1)
(PROG ((I (IPLUS I 4)))
(SUPERPRINT (CAR TAIL)
(AND (NULL (SETQ TAIL (CDR TAIL)))
BRFLG))) (* Prints PROG variables.)
LP (COND
((NLISTP TAIL)
(GO OUT)))
LP1 (ENDLINE)
(COND
((NLISTP TAIL) (* ENDLINE resets E when it sees a comment.)
(GO OUT))
((NLISTP (CAR TAIL))
(GO ATM)))
(SPACES 4)
IN (PROG ((I (IPLUS I 4)))
(SUPERPRINT (CAR TAIL)
(AND (NULL (SETQ TAIL (CDR TAIL)))
BRFLG)))
(GO LP)
ATM (SETQ V (POSITION))
(SETQ CLISPTEM NIL)
(AND CLISPFLG (STRPOS (QUOTE "←")
(CAR TAIL))
(SETQ CLISPTEM (CAR TAIL))
(SPACES 4)) (* This atom is not a prog label but an CLISP form, e.g.
FOO←NIL. Space it over to line up with the prog
clauses.)
(PRIN2 (CAR TAIL)) (* Print the label.)
(COND
((NLISTP (SETQ TAIL (CDR TAIL)))
(GO OUT))
((NLISTP (CAR TAIL)) (* Two labels in a row.)
(ENDLINE)
(GO ATM))
[CLISPTEM (COND
((EQ (NTHCHARCODE CLISPTEM -1)
(CHARCODE ←)) (* The next element is part of this CLISP expression and
should be printed on the same line, e.g. FOO←
(FIE))
)
(T (ENDLINE)
(SPACES 4]
((ILESSP (SETQ V (IDIFFERENCE (IPLUS 4 V)
(POSITION)))
0) (* Long label.)
(GO LP1)
(* Necessary to go back to LP1 rather than just do the ENDLINE follwwed by 4 spaces because ENDLINE may reset E if a
comment is next.)
)
(T (SPACES V)))
(GO IN)
OUT (COND
(TAIL (PRIN1 " . ")
(SUPERPRINT TAIL)))
(RETURN])
)
(DEFINEQ
(ENDLINE
[LAMBDA (N) (* wt: "25-FEB-80 19:12")
(COND
((AND DEF FORMFLG (LISTP TAIL)
(LISTP (CAR TAIL))
(SUPERPRINTEQ (CAAR TAIL)
COMMENTFLG)) (* a comment)
(SUPERPRINT (CAR TAIL))
(SETQ TAIL (CDR TAIL))
(ENDLINE N))
(T (ENDLINE1 (OR N I)
T)))
N])
)
(DEFINEQ
(ENDLINE1
[LAMBDA (N INBLOCKFLG NOTABSFLG) (* rmk: "12-OCT-81 14:58")
(* handles end of line: prints changechar if appropriate, does font changes, terpri, and if N is given, spaces over
to that column before restoring font.)
(COND
((NULL INBLOCKFLG) (* called from outside the block, e.g. from get*)
(EVQ CHANGEFLG)
(EVQ FILEFLG)
(EVQ LASTCOL)))
(LINELENGTH (PROG1 (LINELENGTH) (* LINELENGTH is preserved b/c font changes can cause
some systems to reset it)
(PROG (FLG TEM (POS (POSITION)))
(SETQ TEM (AND FONTCHANGEFLG (CHANGFONT DEFAULTFONT)))
(* Wont get right effect if do spaces in variable pitch
font.)
(COND
(CHANGEFLG0 (COND
((AND FILEFLG CHANGECHARTABSTR)
(* ↑F↑Tn sequence for positioning to right hand margin.)
(PRIN3 CHANGECHARTABSTR)
(PRIN1 CHANGECHAR))
((OR FONTCHANGEFLG (EQ DISPLAYTERMFLG (QUOTE CHAT)))
(* prints a c.r. no line feed and then spaces to right margin. reason for doing this is that in most cases can take
advantage of tab characters, so in fact will usually result in fewer characters to be printed.
also handles the problem of font changes in the line, with the resulting position confusion.)
(POSITION NIL 0)
(PRIN1 (CONSTANT (CHARACTER 13)))
(TABTO (SUB1 LASTCOL)
0 NOTABSFLG)
(PRIN1 CHANGECHAR))
((IGREATERP LASTCOL POS)
(* e.g. printing to terminal or printing to file, no
font changes, outside of parc)
(TABTO (SUB1 LASTCOL)
POS NOTABSFLG)
(PRIN1 CHANGECHAR)))
(SETQ CHANGEFLG0 CHANGEFLG)))
(TERPRI)
(SETQ CRCNT (ADD1 CRCNT)) (* Used to tell SUBPRINT that a carraiger return was
performed, i.e. no longer are on same line as before.)
(AND ENDLINEUSERFN (APPLY* ENDLINEUSERFN POS I TAIL))
(* hook for w.t. keeps a list of the tails of the pexpressions being prettyprinted aater each c.r.
so that you can make a correspondence between lines on the display and s-expressions.)
(AND N (TABTO N 0 NOTABSFLG))
(AND TEM (CHANGFONT TEM])
)
(DEFINEQ
(TABTO
[LAMBDA (TO FROM NOTABSFLG) (* wt: 9-SEP-76 3 21)
(PROG (TABFROM TABTO)
(COND
([AND FILEFLG PRETTYTABFLG (NULL NOTABSFLG)
(NEQ (SETQ TABFROM (IQUOTIENT FROM 8))
(SETQ TABTO (IQUOTIENT TO 8] (* NOTABSFLG is T for printing comments see comment in
comment1)
(RPTQ (IDIFFERENCE TABTO TABFROM)
(PRIN1 (QUOTE % )))
(SPACES (IREMAINDER TO 8))
(POSITION NIL TO))
(T (SPACES (IDIFFERENCE TO FROM])
)
(DEFINEQ
(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])
)
(DEFINEQ
(FITP
[LAMBDA (X TAILFLG ENDTAIL LSTCOL) (* wt: "17-JUN-80 16:29")
(* Value is T indicates do not perform carriage return before continuing printing, NIL means do.
i.e. doesnt fit. There are two cases, one where X is a tail (only called for the first tail, i.e. CDR of an
exprssion) and the second where it is an element. They differ in their treatment of linear lists of atoms.
If one is about to print (FOO A B C D E F) and it wont fit on a line, then do a carriage return and staat printing.
However, if A B C D E F doesnt fit, doesnt mean to do a carriage return (and then line all the atoms up in a column)
. The idea is that long lists are given as much room as possible (the first carriage return) but not at the expense of making
them be vertical.)
(PROG [(N (SUB1 (IDIFFERENCE (OR LSTCOL LASTCOL)
(POSITION]
(RETURN (COND
(TAILFLG (* igreaterp used to compare with 6 kept it consistent
for sourrce compare.)
(AND (IGREATERP N (IPLUS AVERAGEVARLENGTH 2))
(FITP1 X N ENDTAIL)))
(T (FITP2 X N ENDTAIL])
)
(DEFINEQ
(FITP1
[LAMBDA ($TAIL N ENDTAIL N1)
(* ENDTAIL specifies the end of TAIL. This option is used when printing CLISP eexpressions where it is necessary to
know if a certain portion of a lst will fit , i.e. between two clispwords.)
(* Checks to see if $TAIL could fit in N spaces.)
(PROG ((M 0)
(FLG T))
LP (COND
[(OR (NLISTP $TAIL)
(EQ $TAIL ENDTAIL))
(* M is number of characters (plus spaces) in atomic arguments encountered before first non-atomic form or end of
TAIL. see COMMENT in FITP)
(RETURN (OR TAILFLG (ILESSP M N]
[(NLISTP (CAR $TAIL)) (* We have already checked to see if AN average length
variable could fit before calling FITP1.)
(AND FLG (SETQ M (IPLUS M (ADD1 (COND
((ILESSP N #CAREFULCOLUMNS)
(* When getting near right margin, actually perform the nchars check. #CAREFULCOLUMNS is initially set to 20
(it can be set to 100 meaning always perform the nchars check, but this slows down the prettyprinting))
(NCHARS (CAR $TAIL)
T))
(T (* Initially 4)
AVERAGEVARLENGTH]
((NULL (FITP2 (CAR $TAIL)
(OR N1 N)))
(* The extra argument to FITP1 is for use in connectionwith CLISPPRETTYWORDS, e.g. FOR, IF, etc. Normally, we figure
that any lists can be printed at the position corresponding to the first argument, ut with FOR's and IF's et al,
they would always be preceded by the corresponding CLISP word.)
(RETURN NIL))
(T (* Non-atomic form reached, stop counting variables
since after this will be in vertical format anyway.)
(SETQ FLG NIL)))
(SETQ $TAIL (CDR $TAIL))
(GO LP])
)
(DEFINEQ
(FITP2
[LAMBDA (X N ENDTAIL) (* wt: "17-JUN-80 16:30")
(PROG (NC)
(RETURN (COND
((SUPERPRINTEQ (CAR X)
COMMENTFLG)
T)
[(LISTP (CAR X)) (* Non-atomic CAR of form, e.g. COND clause, open
lambda, etc.)
(COND
((FITP2 (CAR X)
(SETQ N (SUB1 N))) (* SUB1 for the extra left parentheses.)
(OR (NULL (CDR X))
(FITP1 (CDR X)
(SUB1 N)
ENDTAIL]
([ILESSP N (IPLUS 2 (COND
((ILESSP N #CAREFULCOLUMNS)
(SETQ NC (NCHARS (CAR X)
T)))
(T (IPLUS (SETQ NC AVERAGEFNLENGTH)
3]
(* Checks to see if there is space for function name and two parentheses. when there are more than #CAREFULCOLUMNS
columns left, approximate using value of AVERAGEFNLENGTH. We add 3 to it here just to guarad against a long name at
the last minute, i.e. right margin)
NIL)
((NULL (CDR X))
T)
((SELECTQ (CAR X)
(COND (* The (IPLUS N -2)
corresponds to what I would be decremented on the recursive
call to superprint.)
(SETQ N (IPLUS N -2)))
(FUNCTION (SETQ N (IPLUS N -2))
(* 21= the 8 characters in 'FUNCTION' plus the 6 characters in 'LAMBDA' plus 3 characters (minimum) for LAMBDA
arglist, plus two parens, and two spaces)
(IGREATERP N 21))
([LAMBDA NLAMBDA]
(SETQ N (IPLUS N -2)) (* 11 = 6 characters for LAMBDA plus paren, plus space,
plus three characters for arglist.)
(IGREATERP N 11))
(SETQ (SETQ N (IPLUS N -2)) (* 6 = 4 characters in SETQ plus paren, plus space)
(IGREATERP N (IPLUS 6 AVERAGEVARLENGTH)))
(IGREATERP (SETQ N (IDIFFERENCE N (IPLUS NC 2)))
(ADD1 AVERAGEFNLENGTH)))
(* the default clause in the selectq checks to see if function and at least one atomic argument
(we know there is at least one) will fit. The -2 corresponds to the left paren and the space.
i dont think the add1 should be there, but in old algorithm, it was a 6, and i wanted files to look exactly the same
with new algorithm when #CAREFULCOLUMNS was set to 0)
(* The call to FITP1 checks to see if using normal
alignment algorithm, the expression can fit.)
(FITP1 (CDR X)
N ENDTAIL (AND (OR (EQ [CAR (SETQ X (GETPROP X (QUOTE CLISPWORD]
(QUOTE IFWORD))
(EQ (CAR X)
(QUOTE FORWORD)))
(IDIFFERENCE N (IPLUS NC 1])
)
(DEFINEQ
(WIDEPAPER
[LAMBDA (FLG) (* wt: 20-APR-76 0 38)
(PROG1 WIDEPAPERFLG (COND
((SETQ WIDEPAPERFLG FLG)
(SETQ FILELINELENGTH 120)
(SETQ FIRSTCOL 80)
(SETQ PRETTYLCOM 28))
(T (SETQ FILELINELENGTH 72)
(SETQ FIRSTCOL 48)
(SETQ PRETTYLCOM 14])
)
(DEFINEQ
(ISTTYP
[LAMBDA (FILE) (* lmm "24-JUL-83 22:53")
(* Default definition of DISPLAYP)
(EQ (OR FILE (OUTPUT))
T])
)
(DECLARE: DONTCOPY EVAL@COMPILEWHEN (EQ (COMPILEMODE)
(QUOTE D))
(ADDTOVAR DONTCOMPILEFNS CHANGEFONT)
(DECLARE: EVAL@COMPILE
(PUTPROPS CHANGFONT DMACRO (= . DSPFONT))
)
)
(DECLARE: DONTCOPY EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE D))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: NIL CHANGEFONT (LINKFNS . T))
]
)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN (EQ (SYSTEMTYPE)
(QUOTE D))
(MOVD (QUOTE DSPFONT)
(QUOTE CHANGEFONT))
)
)
(* 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])
)
(DEFINEQ
(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])
)
(DEFINEQ
(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)
)
(DEFINEQ
(COMMENT1
[LAMBDA (L INBLOCKFLG) (* lmm " 1-Sep-84 14:32")
(* INBLOCKFLG is NIL for entries fro outside the block, e.g. for users who want to reset some variables or
linelength, etc., and then call comment1.)
(RESETVARS [(FONTCHANGEFLG (COND
(FILEFLG FONTCHANGEFLG)
(T (EQ FONTCHANGEFLG (QUOTE ALL]
(RETURN (PROG (X FC LC MC STR TEM (LASTCOL (AND INBLOCKFLG LASTCOL))
NEWLASTCOL
(TAIL (AND INBLOCKFLG TAIL))
MIDFLG)
(SETQ NEWLASTCOL (AND FONTCHANGEFLG COMMENTFONT COMMENTLINELENGTH))
(COND
((AND (EQ (CADR L)
(QUOTE E))
(LISTP (SETQ X (CADDR L)))
(NULL (CDDDR L)))
(EVAL X)))
[COND
((AND **COMMENT**FLG (NULL FILEFLG))
(* for editing purposes.)
(RETURN (PRIN1 **COMMENT**FLG]
(SETQ X L)
[COND
((AND (NOT (SUPERPRINTEQ (CADR L)
COMMENTFLG))
(ILESSP (COUNT L)
PRETTYLCOM))
(SETQ FC (OR (CAR (LISTP FIRSTCOL))
FIRSTCOL))
(SETQ LC (OR (CAR NEWLASTCOL)
LASTCOL
(LINELENGTH)))
(* If NEWLASTCOL is non-nil, means users is using a smaller font for comments and wants a larger linelength.
CAR is the linelength to be used for comments in right margin, CDR for those to be centered.
LASTCOL would be NIL at this point for calls from outside of he block, so recompute linelength, rather than
calling evq, since user might have reset linelength before calling comment1.)
(SETQ MC (IQUOTIENT (IPLUS FC LC)
2)))
(T (SETQ MIDFLG T)
(SETQ FC (OR (CDR (LISTP FIRSTCOL))
10))
(SETQ LC (OR (CDR NEWLASTCOL)
(IPLUS (OR LASTCOL (LINELENGTH))
-10)))
(ENDLINE1 NIL T)
(ENDLINE1 NIL T)
(SETQ MC (IPLUS LC -25]
(AND (NULL LASTCOL)
(SETQ LASTCOL LC)) (* in case user has called COMMENT1 when not under
printdef at all (not supposed to))
[COND
((EQ (CADR X)
(QUOTE %%))
(/RPLACD X (COMMENT3 (CDDR X)
EXPR T]
(SETQ STR (AND FONTCHANGEFLG (CHANGFONT DEFAULTFONT)))
(* Want to be in defaultfont before we space over.)
(SETQ TAIL (CDR TAIL)) (* because the coment is already printed.
TAIL is used in ENDLINE1 and is the tail of the
expression yet to be prited.)
[COND
((IGREATERP (IPLUS (SETQ TEM (POSITION))
3)
FC) (* If justcaaled TAB, it would do terpri, and the
changechar wouldnt get printed.)
(ENDLINE1 FC T T)
(* the extra argument to endline1 supresses the use of tabs. dont want it to use tabs as this will screw up the
value rturned by position, and this would make the normalcommentsflg=NIL feature not work.)
)
(T (SPACES (IDIFFERENCE FC TEM]
(COND
((AND STR COMMENTFONT)
(CHANGFONT COMMENTFONT)
(RESETFORM (LINELENGTH LC)
(COMMENT2 L FC MC LC))
(* permits user to specify different linelength for comments. useful when comments are printed in smaller fonts.
most users using font package will use this facility.)
(CHANGFONT STR))
(T (COMMENT2 L FC MC LC)))
(COND
(MIDFLG (* comment in middle of line.)
(ENDLINE1 NIL T)
(ENDLINE1 NIL T)))
(RETURN L])
)
(DEFINEQ
(COMMENT2
[LAMBDA (TAIL FC MC LC) (* rmk: "23-MAY-82 23:56")
(PROG (LAST POS)
(PRIN1 (QUOTE %())
(COND
((NLISTP (CAR TAIL))
(PRIN2 (CAR TAIL)))
(T (COMMENT2 (CAR TAIL)
FC MC LC)))
LP (SETQ POS (POSITION))
[COND
((NULL (SETQ TAIL (CDR TAIL)))
(GO EXIT))
((NLISTP TAIL)
(PRIN1 (QUOTE " . "))
(PRIN2 TAIL)
(GO EXIT))
((OR (EQ LAST (QUOTE -))
(AND (NOT (NUMBERP LAST))
(SELCHARQ (NTHCHARCODE LAST -1)
(; (IGREATERP POS MC))
[%. (AND (IGREATERP POS MC)
(NULL (FMEMB LAST ABBREVLST]
NIL)))
(ENDLINE1 (SETQ POS FC)
T))
((AND (NOT (ATOM LAST))
(SELECTQ (CAR TAIL)
((, ; : %.) (* Don't space)
(PRIN1 (CAR TAIL))
(GO LP))
NIL)))
((EQ POS LC)
(ENDLINE1 (SETQ POS FC)
T))
(T (SPACES 1)
(SETQ POS (ADD1 POS]
(COND
((LISTP (SETQ LAST (CAR TAIL))) (* new line before printing the list.)
(COND
((IGREATERP POS MC)
(ENDLINE1 (SETQ POS FC)
T)))
(COMMENT2 LAST FC MC LC)
(GO LP))
((IGREATERP [SETQ POS (IPLUS POS (NCHARS LAST)
(COND
((CDR TAIL)
0)
(T (* leave space for the paren, i.e. dont print last atom
on one line and the paren on the next)
1]
LC) (* LC is the last column that can be printed in.)
(ENDLINE1 (SETQ POS FC)
T)))
(PRIN2 LAST)
(GO LP)
EXIT(PRIN1 (QUOTE %)])
)
(DEFINEQ
(COMMENT3
[LAMBDA (X FORM FLG)
(PROG (Y Z VARS) (* FLG = T means first letter in word is capitalized.)
[AND (FNTYP FORM)
(SETQ VARS (APPEND (CAR (SETQ Y (COMMENT5 FORM)))
(CADR Y] (* Gets Free And Bound Variables.)
(SETQ Y X)
LP (FRPLACA Y (COMMENT4 (CAR Y)))
[COND
((LISTP (SETQ Z (CDR Y)))
(SETQ Y Z)
(GO LP))
(Z (FRPLACD Y (COMMENT4 Z]
(RETURN X])
)
(DEFINEQ
(COMMENT4
[LAMBDA (X) (* lmm "23-Aug-84 18:10")
(PROG (Y TEM)
(COND
[(LISTP X)
(COND
((NOT (AND (GETD (CAR X))
(ILESSP (LENGTH X)
5))) (* If it looks like a FORM, don't lowercase.)
(SETQ X (COMMENT3 X FORM]
((EQ X (QUOTE -))
(SETQ FLG T)
(RETURN X))
((OR (EQ X (QUOTE ↑))
(EQ X (QUOTE %%))
(EQ X (QUOTE 'S))
(NOT (LITATOM X))) (* Note that strings are left in upper case.
However, the editor's LOWER and RAISE commands do work
on strings.)
)
((EQ (SETQ TEM (CHCON1 X))
(CHARCODE ↑)) (* Leave in uppercase)
(SETQ X (SUBATOM X 2)))
((EQ TEM (CHARCODE %%)) (* Make lowercase regardless)
(SETQ X (L-CASE X FLG)))
((STRPOS (QUOTE =)
X))
(T (SETQ Y X)
(GO LP)))
OUT [SETQ FLG (AND (LITATOM X)
(EQ (NTHCHARCODE X -1)
(CHARCODE %.))
(NOT (FMEMB X ABBREVLST] (* FLG=T means capitalize next word.)
(RETURN X)
LP (SELCHARQ (NTHCHARCODE Y -1)
((%. ; : ,)
(SETQ Y (SUBATOM Y 1 -2)) (* Remove punctuation and loop so that 'FOO', and FOO's,
will be handled correctly.)
(GO LP))
[S (COND
((EQ (NTHCHARCODE Y -2)
(CHARCODE '))
(SETQ Y (SUBATOM Y 1 -3))
(SETQ X (MKATOM (RPLSTRING X (STRPOS (QUOTE "'S")
X)
(QUOTE "'s"]
[' (COND
((EQ (CHCON1 Y)
(CHARCODE ')) (* X is TO be left in uppercase.
THE check is made here instead of earlier TO allow FOR '
TO be handled properly.)
(GO OUT]
NIL)
[COND
([NOT (AND (NOT (FMEMB Y LCASELST))
(OR (FMEMB Y UCASELST)
(GETD Y)
(BOUNDP Y)
(GETPROPLIST Y)
(FMEMB Y VARS]
(* Words on LCASELST are always lower-cased, words on UCASELST always uppercased, otherwise, if word is a function
or variable with top level binding or local binding or has a property list, leave it in uppercase)
(SETQ X (L-CASE X FLG]
(GO OUT])
)
(DEFINEQ
(COMMENT5
[LAMBDA (FORM)
(PROG (TEM)
(RETURN (LIST (COND
((ATOM (SETQ TEM (CADR FORM)))
(LIST TEM))
(T TEM))
(AND (EQ [CAR (SETQ TEM (CAR (LAST FORM]
(QUOTE PROG))
(MAPCAR (CADR TEM)
(FUNCTION (LAMBDA (X)
(COND
((ATOM X)
X)
(T (CAR X])
)
(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 DOCOPY
(WIDEPAPER)
(SETLINELENGTH)
(MOVD? (QUOTE ISTTYP)
(QUOTE DISPLAYP))
(MOVD? (QUOTE NILL)
(QUOTE COMPUTEPRETTYPARMS))
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT)
(SPECVARS FNSLST FILEFLG))
(BLOCK: PRETTYBLOCK PRINTDEF SUPERPRINT SUPERPRINT0 SUPERPRINTEQ SUPERPRINTGETPROP SUBPRINT SUBPRINT1
SUBPRINT2 CHANGFONT PRINTPROG RPARS ENDLINE ENDLINE1 TABTO FITP FITP1 FITP2 COMMENT1 COMMENT2
(ENTRIES PRINTDEF CHANGFONT ENDLINE1 COMMENT1 FITP SUPERPRINTEQ SUPERPRINTGETPROP)
(LOCALFREEVARS I LASTCOL FORMFLG E TAIL TAILFLG EXPR CRCNT FILEFLG FNSLST CHANGEFLG DEF)
(BLKLIBRARY GETPROP)
(SPECVARS CHANGEFLG LASTCOL FILEFLG E TAIL EXPR TYPE))
(BLOCK: NIL COMMENT3 COMMENT4 COMMENT5 ENDFILE ISTTYP MAKEDEFLIST PP PP* PPT PRETTYCOM PRETTYCOM1
PRETTYCOMPRINT PRETTYDEF PRETTYDEF0 PRETTYDEF1 PRETTYVAR PRETTYVAR1 PRINTDATE PRINTDATE1
PRINTDEF1 PRINTFNS READARRAY WIDEPAPER (LINKFNS . T))
]
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS UCASELST LCASELST DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG
LAMBDAFONTLINELENGTH PRETTYCOMFONT WIDEPAPERFLG PRETTYHEADER BUILDMAPFLG FILERDTBL
NORMALCOMMENTSFLG FILELINELENGTH FONTFNS FONTWORDS USERFONT CLISPFONT SYSTEMFONT
COMMENTFONT CHANGEFONT PRETTYTABFLG AVERAGEFNLENGTH AVERAGEVARLENGTH #CAREFULCOLUMNS
CHANGECHAR LASTFONT CHANGEFLG0 DISPLAYTERMFLG PRETTYEQUIVLST COMMENTLINELENGTH CHANGEFLG0
ENDLINEUSERFN FONTPROFILE PRETTYFLG CHANGESARRAY PRETTYPRINTYPEMACROS PRETTYPRINTMACROS
CLISPTRANFLG PRETTYTRANFLG CLISPARRAY #RPARS CLISPCHARS FUNNYATOMLST CHCONLST CLISPFLG
PRETTYLCOM FIRSTCOL **COMMENT**FLG ABBREVLST CHANGECHARTABSTR FILEPKGFLG FONTCHANGEFLG
DEFAULTFONT LAMBDAFONT CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS ADDSPELLFLG
COMMENTFLG CLISPIFYPACKFLG)
)
(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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (6292 14411 (PRETTYDEF 6302 . 14409)) (14412 14664 (PRETTYDEF0 14422 . 14662)) (14665
16945 (PRETTYDEF1 14675 . 16943)) (16946 18789 (PRINTDATE 16956 . 18787)) (18790 20114 (PRINTDATE1
18800 . 20112)) (20115 20950 (PRINTFNS 20125 . 20948)) (20951 29957 (PRETTYCOM 20961 . 29955)) (29958
30046 (PRETTYCOMPRINT 29968 . 30044)) (30047 31485 (PRETTYVAR 30057 . 31483)) (31486 33615 (PRETTYVAR1
31496 . 33613)) (33616 34716 (PRETTYCOM1 33626 . 34714)) (34717 34884 (ENDFILE 34727 . 34882)) (34885
35481 (MAKEDEFLIST 34895 . 35479)) (35482 35741 (PP 35492 . 35739)) (35742 36049 (PP* 35752 . 36047))
(36050 36360 (PPT 36060 . 36358)) (36361 41265 (PRETTYPRINT 36371 . 41263)) (41266 43924 (
PRETTYPRINT1 41276 . 43922)) (43925 45383 (PRETTYPRINT2 43935 . 45381)) (45384 45465 (PRINTDEF1 45394
. 45463)) (45466 46939 (PRINTDEF 45476 . 46937)) (46940 48090 (SUPERPRINT 46950 . 48088)) (48091
53087 (SUPERPRINT0 48101 . 53085)) (53088 53203 (SUPERPRINTEQ 53098 . 53201)) (53204 53409 (
SUPERPRINTGETPROP 53214 . 53407)) (53410 53999 (RPARS 53420 . 53997)) (54000 67086 (SUBPRINT 54010 .
67084)) (67087 67766 (SUBPRINT1 67097 . 67764)) (67767 68351 (SUBPRINT2 67777 . 68349)) (68352 69085 (
CHANGEFONT 68362 . 69083)) (69086 70124 (CHANGFONT 69096 . 70122)) (70125 72461 (PRINTPROG 70135 .
72459)) (72462 72860 (ENDLINE 72472 . 72858)) (72861 75457 (ENDLINE1 72871 . 75455)) (75458 76005 (
TABTO 75468 . 76003)) (76006 77269 (READARRAY 76016 . 77267)) (77270 78481 (FITP 77280 . 78479)) (
78482 80414 (FITP1 78492 . 80412)) (80415 83120 (FITP2 80425 . 83118)) (83121 83465 (WIDEPAPER 83131
. 83463)) (83466 83710 (ISTTYP 83476 . 83708)) (84210 86701 (PRINTCOPYRIGHT 84220 . 86699)) (86702
87711 (PRINTCOPYRIGHT1 86712 . 87709)) (87712 88172 (SAVECOPYRIGHT 87722 . 88170)) (89181 92927 (
COMMENT1 89191 . 92925)) (92928 94624 (COMMENT2 92938 . 94622)) (94625 95158 (COMMENT3 94635 . 95156))
(95159 97484 (COMMENT4 95169 . 97482)) (97485 97826 (COMMENT5 97495 . 97824)))))
STOP