(FILECREATED " 3-Aug-85 15:42:00" {ERIS}<LISPCORE>SOURCES>NEWPRINTDEF.;16 34045
changes to: (FNS PRINTPROG)
previous date: "30-Jul-85 03:31:34" {ERIS}<LISPCORE>SOURCES>NEWPRINTDEF.;15)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NEWPRINTDEFCOMS)
(RPAQQ NEWPRINTDEFCOMS [(* A version of PRINTDEF abstracted so that it can be parametrized for
non-teletype devices. One example is <LISP>SOURCES>DSPRINTDEF which
provides one definition for the abstract fns such as WIDTH, XPOSITION etc
used here.)
(FNS NEWPRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 SUBPRINT2 PRINTPROG PRINTSQ
BACKARROWP ENDLINE RPARS DSFITP DSFIT1 DSFIT2)
(FNS SUPERPRINT/COMMENT SUPERPRINT/COMMENT1 SUPERPRINT/COMMENT2)
(P (MOVD? (QUOTE PRINTDEF)
(QUOTE OLDPRINTDEF)))
(DECLARE: EVAL@COMPILE DONTCOPY
(GLOBALVARS **COMMENT**FLG CLISPARRAY CHANGESARRAY DISPLAYTERMFLG CHANGECHAR
AVERAGEFNLENGTH #CAREFULCOLUMNS AVERAGEVARLENGTH #RPARS FONTWORDS
FONTFNS DEFAULTFONT BOLDFONT USERFONT SYSTEMFONT CLISPFONT CHANGEFONT
BIGFONT CLISPCHARS FUNNYATOMLST PRETTYPRINTMACROS PRETTYEQUIVLST
SPACESIZE COMMENTFLG)
(BLOCKS (DSPRETTY NEWPRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 SUBPRINT2
PRINTPROG PRINTSQ BACKARROWP ENDLINE RPARS DSFITP DSFIT1 DSFIT2
SUPERPRINT/COMMENT SUPERPRINT/COMMENT1 SUPERPRINT/COMMENT2
(ENTRIES NEWPRINTDEF SUPERPRINT)
(SPECVARS TAIL LEFT)
(LOCALFREEVARS TAILFLG FNSLST FIRSTPOS LASTPOS COMMENTCOL FORMFLG
FILEFLG CHANGEFLG CHANGEFLG0)))
(DECLARE: DONTEVAL@LOAD EVAL@COMPILEWHEN (NOT (HASDEF (QUOTE ADJXPOS)
(QUOTE MACRO)))
(FILES (LOADCOMP)
DSPRINTDEF])
(* A version of PRINTDEF abstracted so that it can be parametrized for non-teletype devices.
One example is <LISP>SOURCES>DSPRINTDEF which provides one definition for the abstract fns such
as WIDTH, XPOSITION etc used here.)
(DEFINEQ
(NEWPRINTDEF
[LAMBDA (EXPR LEFT FORMFLG TAILFLG FNSLST FILE) (* lmm "30-Jul-85 03:11")
(* Provided as a plug compatible defn of PRINTDEF)
(LET ((FILE (GETSTREAM FILE (QUOTE OUTPUT)))
(MAKEMAP NIL))
(DECLARE (SPECVARS MAKEMAP))
(COND
[(IMAGESTREAMP FILE)
(PROG ((FIRSTPOS (DSPLEFTMARGIN NIL FILE))
(RMARGIN (DSPRIGHTMARGIN NIL FILE))
(TAIL (LIST EXPR))
COMMENTCOL CHANGEFLG FILEFLG)
(DECLARE (SPECVARS RMARGIN))
(RESETLST (RESETSAVE (OUTPUT FILE))
[RESETSAVE NIL (LIST (FUNCTION DSPFONT)
(DSPFONT NIL FILE)
(GETSTREAM NIL (QUOTE OUTPUT]
(SETFONT DEFAULTFONT FILE)
[SETQ LEFT (COND
((NOT LEFT)
FIRSTPOS)
((NUMBERP LEFT)
(PLUS FIRSTPOS (TIMES LEFT SPACESIZE)))
(T (DSPXPOSITION NIL FILE]
(COND
[PRETTYFLG (DSPXPOSITION LEFT FILE)
(COND
(TAILFLG (SUBPRINT EXPR NIL NIL FILE))
(T (SUPERPRINT EXPR TAIL NIL FILE]
(T (COND
(TAILFLG (MAPRINT EXPR FILE NIL NIL NIL (FUNCTION PRIN2S)))
(T (PRIN2S EXPR TAIL FILE]
(T (OLDPRINTDEF EXPR LEFT FORMFLG TAILFLG FNSLST FILE])
(SUPERPRINT
[LAMBDA (E TAIL BRFLG FILE) (* lmm "30-Jul-85 03:26")
(COND
[(NLISTP E)
(OR [AND (NOT MAKEMAP)
(NOT (ATOM E))
(LET ((MACRO (ASSOC (TYPENAME E)
PRETTYPRINTYPEMACROS)))
(AND MACRO (NEQ (APPLY* (CDR MACRO)
E)
E]
(PROGN (PROG [(TEM (IDIFFERENCE RMARGIN (WIDTH E FILE T]
(* TEM is the last position at which E will fit)
(AND (ILESSP TEM (DSPXPOSITION NIL FILE))
(IGREATERP TEM FIRSTPOS)
(ENDLINE (IMIN LEFT TEM)
FILE)))
(PRIN2S E TAIL FILE]
((AND FORMFLG (SUPERPRINTEQ (CAR E)
COMMENTFLG))
(SUPERPRINT/COMMENT E FILE))
((AND PRETTYTRANFLG (NOT (ARGTYPE (CAR E)))
(GETHASH E CLISPARRAY))
(SUPERPRINT0 (GETHASH E CLISPARRAY)
TAIL BRFLG FILE))
(T (SUPERPRINT0 E TAIL BRFLG FILE])
(SUPERPRINT0
[LAMBDA (E TAIL BRFLG FILE) (* lmm "30-Jul-85 03:23")
(* BRFLG says do not print a %) as expression will be
terminated by a %].)
(PROG [(MACRO (AND (NOT MAKEMAP)
(ASSOC (CAR E)
PRETTYPRINTMACROS]
[COND
(MACRO (COND
((NOT (SETQ MACRO (APPLY* (CDR MACRO)
E))) (* macro printed the thing)
(RETURN E))
((NEQ E MACRO) (* macro returns something else to print
(!))
(RETURN (SUPERPRINT MACRO TAIL BRFLG FILE)))
(T (SETQ E MACRO]
(LET [(LEFT NIL)
(NEWBR (AND (NULL BRFLG)
(FIXP #RPARS)
(RPARS E #RPARS] (* LEFT is set from within SUBPRINT.
Only appears here for call to ENDLINE)
(PRINOPEN TAIL (COND
(NEWBR (QUOTE %[))
(T (QUOTE %()))
FILE)
(SUBPRINT E (OR BRFLG NEWBR)
NIL FILE)
[COND
((ILESSP RMARGIN (IPLUS (DSPXPOSITION NIL FILE)
(WIDTH ")" FILE)))
(PROG (TAIL)
(* need to rebind tail because if next expression is a comment dont want to print it yet because we still have the
right paren to print.)
(ENDLINE LEFT FILE]
(PRINSHUT TAIL (COND
(NEWBR (QUOTE %]))
(BRFLG NIL)
(T (QUOTE %))))
FILE))
(RETURN E])
(SUBPRINT
[LAMBDA (TAIL BRFLG END FILE) (* lmm "30-Jul-85 03:27")
(PROG [CURRENT DOCRFLG NEXT TEM OLDY CLISPWORD (FORMFLG FORMFLG)
(FORMFLG0 FORMFLG)
(TAIL0 TAIL)
(LEFT0 (DSPXPOSITION NIL FILE))
(CLW0 (CAR (SUPERPRINTGETPROP (CAR TAIL)
(QUOTE CLISPWORD]
(SETQ LEFT LEFT0) (* LEFT is set from SUBPRINT.
Start where we are)
LP [COND
((EQ TAIL END)
(RETURN TAIL))
((NULL TAIL)
(RETURN))
((NLISTP TAIL)
(RETURN (PRINDOTP TAIL FILE]
(SETQ OLDY (DSPYPOSITION NIL FILE))
(SETQ CURRENT (CAR TAIL))
(AND CLISPFLG FORMFLG0 (SETQ CLISPWORD (SUPERPRINTGETPROP CURRENT (QUOTE CLISPWORD)))
(OR (EQ CLW0 (CAR CLISPWORD))
(SETQ CLISPWORD NIL)))
[SETQ FORMFLG (AND FORMFLG0 (NOT (SUPERPRINTEQ (CAR TAIL0)
(QUOTE QUOTE]
(* says whether next expression is to be treated as a form. used to be an argument to superprint but this value of
formflg should also affect the call to endline from subprint.)
(SETFONT (PROG1 (AND FORMFLG0 (LITATOM CURRENT)
(SETFONT (COND
((LISTP CLISPWORD)
CLISPFONT)
((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))
FILE))
(* When printing a function via a call to prettydef and fontflg is turned on and the function is either on FNS or on
FONTFLG do a fontchange.)
(SETQ CURRENT (SUPERPRINT CURRENT TAIL (AND (NULL (CDR TAIL))
BRFLG)
FILE)))
FILE) (* Reason for (SETQ CURRENT --) is in case CURRENT is
printed as something else)
(* Popping TAIL used to be done in the call to SUPERPRINT. But this can cause subsequent comments to be printed
first if ENDLINE is called because of no space. BRFLG only affects last expression in list.)
(SETQ TAIL (CDR TAIL))
(* * CURRENT is always the element just printed; NEXT the one about to be i.e. CAR of TAIL)
LP0 (COND
((OR (EQ TAIL END)
(NLISTP TAIL))
(GO LP))
((OR (NULL CLISPFLG)
(NULL FORMFLG)
(NULL FORMFLG0))
(GO LP1))
[(NOT (LITATOM (SETQ NEXT (CAR TAIL]
([AND (SETQ TEM (SUPERPRINTGETPROP NEXT (QUOTE CLISPWORD)))
(OR (NLISTP TEM)
(EQ CLW0 (CAR TEM]
(* 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 used.)
(GO CLISPWORD))
((EQ (NTHCHARCODE NEXT 1)
(CHARCODE <))
[COND
[(EQ (SETQ TEM (SUBPRINT2 TAIL END))
(CDR TAIL))
(COND
((AND (LITATOM CURRENT)
(BACKARROWP CURRENT))
(GO CR))
(T (GO LP1]
((OR (LISTP CURRENT)
(BACKARROWP CURRENT)
(NOT (DSFITP TAIL NIL TEM NIL FILE)))
(ENDLINE NIL FILE))
(T (ADJXPOS SPACESIZE FILE)
(COND
((EQ TAIL (CDR TAIL0))
(SETQ LEFT (DSPXPOSITION NIL FILE]
(SETQ OLDY (DSPYPOSITION NIL FILE))
(PROG [(LEFT (IPLUS (DSPXPOSITION NIL FILE)
(BLANKS 2]
(SETQ TAIL (SUBPRINT TAIL BRFLG TEM FILE)))
(SETQQ CURRENT >)
(GO LP0))
([AND (EQ (CADR (LISTP TAIL))
(QUOTE ←))
(OR (SUPERPRINTEQ (CAR TAIL0)
(QUOTE CREATE))
(SUPERPRINTEQ (CAR TAIL0)
(QUOTE create]
(GO CR)))
(COND
((LISTP CURRENT)
(COND
([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))
((SELECTQ (CAR CLISPWORD)
((IFWORD FORWORD)
T)
NIL)
(SETQ DOCRFLG NIL)
(COND
((NULL END)
(SETQ END T))) (* See use of END below)
)
([NOT (OR (ATOM NEXT)
(COND
[(EQ TAIL (CDR TAIL0))
(OR (FGETD CURRENT)
(SUPERPRINTGETPROP CURRENT (QUOTE EXPR]
(T (BOUNDP CURRENT)))
(FMEMB CURRENT FUNNYATOMLST)
(NOT (FMEMB (SETQ TEM (NTHCHAR CURRENT -1))
CLISPCHARS))
(EQ TEM (QUOTE >] (* E.g. X* (FOO) Don't space)
(GO LP))
((BACKARROWP CURRENT) (* E.G. IF -- THEN FOO←X FIE←Y is more readable if the
assignments are on separate lines.)
(GO CR)))
LP1 [COND
((EQ TAIL (CDR TAIL0)) (* First time through i.e. just superprinted HEAD of
list.)
(COND
((LISTP CURRENT)
(GO CR))
((AND FORMFLG0 (SELECTQ (OR (CDR (FASSOC CURRENT PRETTYEQUIVLST))
CURRENT)
(COND (SETQ LEFT (IPLUS LEFT0 (WIDTH "CO" FILE)))
(GO CR))
((PROG RESETVARS)
(RETURN (PRINTPROG TAIL BRFLG FILE)))
(SELECTQ (RETURN (PRINTSQ TAIL BRFLG FILE)))
((SETQ RESETVAR)
(GO SP))
(FUNCTION (* If FUNCTION has a second arg, fall thru and reset
margin. Else leave it for compactness)
(OR (CDR TAIL)
(GO SP)))
([LAMBDA NLAMBDA]
(SETQ DOCRFLG T)
(SETQ LEFT (IPLUS LEFT0 SPACESIZE))
(ADJXPOS SPACESIZE FILE)
(GO LP))
NIL)))
((NOT (DSFITP TAIL T [OR (LISTP END)
(AND CLISPWORD (SUBPRINT1 TAIL (CAR CLISPWORD]
NIL FILE))
(GO CR) (* Don't reset I.)
)
((EQ (NTHCHARCODE CURRENT 1)
(CHARCODE <))
(GO SP))
(T (ADJXPOS SPACESIZE FILE) (* Default head of form handling)
[SETQ LEFT (IMIN (DSPXPOSITION NIL FILE)
(IPLUS LEFT0 (BLANKS 6]
(* Dont indent too far)
(GO LP]
(COND
([AND (NEQ OLDY (DSPYPOSITION NIL FILE))
(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 >.)
(* WT disabled the listp check because HT 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 on the same line.)
(GO CR))
((DSFITP NEXT NIL NIL NIL FILE)
(GO SP))
(T (GO CR)))
SP (SETQ DOCRFLG NIL)
(ADJXPOS SPACESIZE FILE)
(GO LP)
CR (SETQ DOCRFLG T)
(ENDLINE NIL FILE)
(GO LP)
CLISPWORD
(PROG ((LEFT LEFT)
(LEFT0 LEFT0)
(CEND))
(SELECTQ (OR (CDR (FASSOC NEXT PRETTYEQUIVLST))
NEXT)
((THEN
ELSE
ELSEIF
then
else
elseif) (* THEN ELSE and ELSEIF always start a new line.)
(SETQ LEFT (IPLUS (ENDLINE (IPLUS LEFT0 (BLANKS (SELECTQ NEXT
((THEN
then)
3)
1)))
FILE)
SPACESIZE))
(* Note that in most cases LEFT will be reset again in subprint after printing the CLISPWORD.
It will remain this value only if the next expression wont fit.)
(SETQ TAIL (SUBPRINT TAIL BRFLG (SUBPRINT1 (CDR TAIL)
(QUOTE IFWORD)
END)
FILE))
(RETURN))
((AND OR and or) (* So when new left margin is coputed in next cond it
will be based on inner expression.)
(SETQ LEFT0 LEFT)
(SETQ CEND (SUBPRINT1 (CDR TAIL)
NIL END)))
((! !!)
(SETQ CEND (CDDR TAIL)))
(SETQ CEND (SUBPRINT1 (CDR TAIL)
(CAR (GETP (CAR TAIL0)
(QUOTE CLISPWORD)))
END)))
(SETQ LEFT (IPLUS (COND
((AND (EQ OLDY (DSPYPOSITION NIL FILE))
(DSFITP TAIL NIL CEND NIL FILE))
(ADJXPOS SPACESIZE FILE)
(DSPXPOSITION NIL FILE))
(T
(* Either last expression involved a CR e.g. FOR X IN (FOO (FIE) (FUM)) DO -- OR the segment of the list between
here and the next CLISPFORWORD will not fit.)
(ENDLINE (IPLUS LEFT0 (BLANKS 2))
FILE)))
SPACESIZE))
(SETQ OLDY (DSPYPOSITION NIL FILE))
(SETQ CURRENT (CAR (NLEFT TAIL 1 CEND)))
(SETQ TAIL (SUBPRINT TAIL BRFLG CEND FILE)))
(GO LP0)
(* We are now in the position of just having printed the element before E and are ready to look ahead at the next
one so go to LP0.)
])
(SUBPRINT1
[LAMBDA (LST X END) (* bas: "24-NOV-81 15:28")
(bind TMP for L on LST until [OR (EQ L END)
[AND (LITATOM (CAR L))
(SETQ TMP (GETPROP (CAR L)
(QUOTE CLISPWORD)))
(OR (NULL X)
(EQ X (CAR TMP]
(AND (EQ X (QUOTE RECORDWORD))
(EQ (CADR L)
(QUOTE ←]
finally (RETURN L])
(SUBPRINT2
[LAMBDA (LST END) (* bas: " 8-DEC-81 21:23")
(* Finds the next atom in LST that does not have nested
<>s)
(until [OR (EQ LST END)
(NLISTP LST)
(AND (LITATOM (CAR LST))
(ZEROP (for I to (NCHARS (CAR LST)) sum (SELECTQ (NTHCHAR (CAR LST)
I)
(< 1)
(> -1)
0)))
(SETQ LST (CDR LST]
do (SETQ LST (CDR LST)) finally (RETURN LST])
(PRINTPROG
[LAMBDA (TAIL BRFLG FILE) (* lmm " 3-Aug-85 15:41")
(PROG (CLISPTEM (LABELL (IDIFFERENCE (DSPXPOSITION NIL FILE)
(STRINGWIDTH "ROG" FILE)))
(LEFT (IPLUS (DSPXPOSITION NIL FILE)
SPACESIZE))) (* LABELL is the position PROG labels start in;
LEFT that for forms)
(DSPXPOSITION LEFT FILE)
(if (AND (CAR TAIL)
(LITATOM (CAR TAIL)))
then (SUPERPRINT (CAR TAIL)
TAIL
(PROGN (SETQ TAIL (CDR TAIL))
T)
FILE)
(SPACES 1 FILE)) (* Print PROG variables.)
(SUPERPRINT (CAR TAIL)
TAIL
(AND (NULL (SETQ TAIL (CDR TAIL)))
BRFLG)
FILE)
LP1 (COND
((LISTP TAIL)
(ENDLINE LABELL FILE))) (* ENDLINE resets TAIL when it sees a comment.)
LP2 (COND
((NLISTP TAIL)
(AND TAIL (PRINDOTP TAIL FILE))
(RETURN))
((LISTP (CAR TAIL))
[COND
(CLISPTEM (* Dont space if sucking up assignments)
(SETQ CLISPTEM NIL))
(T (COND
((ILEQ LEFT (DSPXPOSITION NIL FILE))
(PRINENDLINE LEFT FILE))
(T (DSPXPOSITION LEFT FILE]
(SUPERPRINT (CAR TAIL)
TAIL
(AND (NULL (SETQ TAIL (CDR TAIL)))
BRFLG)
FILE)
(GO LP1))
(T (COND
((ILESSP LABELL (DSPXPOSITION NIL FILE)) (* Two labels in a row)
(PRINENDLINE LABELL FILE)))
[COND
([SETQ CLISPTEM (AND CLISPFLG (STRPOS (QUOTE "←")
(CAR TAIL]
(* 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.)
(DSPXPOSITION LEFT FILE) (* Remember trailing ←)
(SETQ CLISPTEM (EQ CLISPTEM (NCHARS (CAR TAIL]
(SUPERPRINT (CAR TAIL)
TAIL NIL FILE) (* Print the label.)
(pop TAIL)
(GO LP2])
(PRINTSQ
[LAMBDA (TAIL BRFLG FILE) (* lmm "30-Jul-85 03:26")
(PROG (LEFT FOLD (KEYL (QUOTIENT (PLUS LEFT (DSPXPOSITION NIL FILE))
2))) (* KEYL is the position keys start in;
LEFT that for forms)
(* Print select expression FORMFLG=T)
(ADJXPOS SPACESIZE FILE)
[SETQ FOLD (IPLUS (SETQ LEFT (DSPXPOSITION NIL FILE))
(TIMES 2 (DIFFERENCE LEFT KEYL]
(SUPERPRINT (CAR TAIL)
TAIL NIL FILE)
LP (OR (SETQ TAIL (CDR TAIL))
(RETURN))
(PRINENDLINE KEYL FILE)
(COND
((NLISTP TAIL)
(RETURN (PRINDOTP TAIL FILE)))
[(CDR TAIL)
(COND
((LISTP (CAR TAIL))
(PRINOPEN TAIL (QUOTE %()
FILE)
(PROG (FORMFLG)
(SUPERPRINT (CAAR TAIL)
(CAR TAIL)
NIL FILE))
(AND (CDAR TAIL)
(PROG ((LEFT LEFT))
(ADJXPOS SPACESIZE FILE)
[COND
((OR (LISTP (CAAR TAIL))
(ILEQ FOLD (DSPXPOSITION NIL FILE)))
(PRINENDLINE LEFT FILE))
(T (SETQ LEFT (DSPXPOSITION NIL FILE]
(SUBPRINT (CDAR TAIL)
NIL NIL FILE)))
(PRINSHUT TAIL (QUOTE %))
FILE))
(T (PRIN2S (CAR TAIL)
TAIL FILE]
(T (SUPERPRINT (CAR TAIL)
TAIL BRFLG FILE)))
(GO LP])
(BACKARROWP
[LAMBDA (X) (* bas: "17-NOV-82 15:19")
(AND (STRPOS (QUOTE ←)
X)
(NEQ (NTHCHARCODE X -1)
(CHARCODE ←])
(ENDLINE
[LAMBDA (N FILE) (* lmm "30-Jul-85 03:20")
(AND FORMFLG (while (SUPERPRINTEQ [CAR (LISTP (CAR (LISTP TAIL]
COMMENTFLG)
do (SUPERPRINT (CAR TAIL)
TAIL NIL FILE) (* a comment)
(pop TAIL)))
(PRINENDLINE (OR N LEFT)
FILE)
N])
(RPARS
[LAMBDA (E NP) (* bas: "11-MAR-83 11:45")
(COND
((ILEQ NP 0))
((NLISTP E)
NIL)
(T (SELECTQ (CAR E)
([LAMBDA NLAMBDA]
T)
(DEFINEQ (* Dont want square brakcets around DEFINEQ
expressions, because this means last function pair is
special with respect to LOADFNS)
NIL)
(RPARS (CAR (LAST E))
(SUB1 NP])
(DSFITP
[LAMBDA (X TAILFLG ENDTAIL LSTCOL FILE) (* lmm "30-Jul-85 03:09")
(* Value is T unless X doesnt fit. There are two cases: one where X is a tail (only called for the first tail i.e.
CDR of an expression) 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 start
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.)
(DECLARE (SPECVARS ENDTAIL)) (* ENDTAIL is the end of TAIL e.g. when printing CLISP
segments)
(PROG ([N (IDIFFERENCE (OR LSTCOL RMARGIN)
(IPLUS SPACESIZE (DSPXPOSITION NIL FILE]
(CAREFUL (BLANKS #CAREFULCOLUMNS)))
(DECLARE (SPECVARS CAREFUL))
(RETURN (COND
(TAILFLG (AND (IGREATERP N (BLANKS (IPLUS AVERAGEVARLENGTH 2)))
(DSFIT1 X N NIL FILE)))
(T (DSFIT2 X N NIL FILE])
(DSFIT1
[LAMBDA (LST N N1 FILE) (* lmm "30-Jul-85 03:08")
(DECLARE (USEDFREE CAREFUL ENDTAIL)) (* Checks to see if LST could fit in N spaces.)
(bind (M ← (COND
(TAILFLG NIL)
(T N)))
for L on LST until (EQ L ENDTAIL) do (COND
[(NLISTP (CAR L))
(COND
(M (SETQ M (IDIFFERENCE
M
(IPLUS (COND
((ILESSP M CAREFUL)
(* When getting near right margin actually perform the
WIDTH check.)
(WIDTH (CAR L)
FILE T))
(T (BLANKS AVERAGEVARLENGTH)))
SPACESIZE)))
(COND
((ILESSP M 0)
(RETURN NIL]
((DSFIT2 (CAR L)
(OR N1 N)
NIL FILE)
(* The extra argument to DSFIT1 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.)
(AND M (SETQ M N))
(* Reset count when LISTP reached as margin will be
reset)
)
(T (RETURN NIL)))
finally (RETURN T])
(DSFIT2
[LAMBDA (X N NC FILE) (* lmm "30-Jul-85 03:09")
(DECLARE (USEDFREE CAREFUL)) (* NC is local to DSFIT2)
(COND
((SUPERPRINTEQ (CAR X)
COMMENTFLG)
T)
[(LISTP (CAR X)) (* Non-atomic CAR of form e.g. COND clause open lambda
etc.)
(AND [ILESSP 0 (SETQ N (IDIFFERENCE N (WIDTH "()" FILE]
(DSFIT2 (CAR X)
N NIL FILE)
(OR (NULL (CDR X))
(DSFIT1 (CDR X)
N NIL FILE]
([ILESSP N (IPLUS (WIDTH "()" FILE)
(SETQ NC (COND
((ILESSP N CAREFUL)
(WIDTH (CAR X)
FILE T))
(T (BLANKS AVERAGEFNLENGTH]
(* Checks to see if there is space for function name and two parentheses. when there are more than CAREFUL columns
left approximate using AVERAGEFNLENGTH.)
NIL)
((NULL (CDR X))
T)
([ILEQ [SELECTQ (CAR X)
(COND 0)
(FUNCTION (WIDTH "(FUNCTION LAMBDA ABC)" FILE))
([LAMBDA NLAMBDA]
(WIDTH "(LAMBDA ABC" FILE))
(SETQ (IPLUS (WIDTH "(SETQ " FILE)
(BLANKS AVERAGEVARLENGTH)))
(PROGN (SETQ N (IDIFFERENCE N NC))
(BLANKS (ADD1 AVERAGEFNLENGTH]
(SETQ N (IDIFFERENCE N (BLANKS 2]
(* The two spaces correspond to the amount LEFT would be decremented on the recursive call to superprint.
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 call to DSFIT1 checks to see if using normal alignment algorithm the
expression can fit.)
(DSFIT1 (CDR X)
N
(SELECTQ (CAR (SUPERPRINTGETPROP (CAR X)
(QUOTE CLISPWORD)))
((IFWORD FORWORD)
(IDIFFERENCE N (IPLUS NC SPACESIZE)))
NIL)
FILE])
)
(DEFINEQ
(SUPERPRINT/COMMENT
[LAMBDA (L FILE) (* lmm "30-Jul-85 03:26")
(DECLARE (GLOBALVARS PRETTYLCOM))
(COND
(**COMMENT**FLG (PRIN1S **COMMENT**FLG TAIL FILE))
(T (PROG (FC LC RIGHTFLG)
[COND
([SETQ RIGHTFLG (NOT (OR (SUPERPRINTEQ (CADR L)
COMMENTFLG)
(ILESSP PRETTYLCOM (COUNT L]
[SETQ FC (OR COMMENTCOL
(SETQ COMMENTCOL
(IMAX (IQUOTIENT RMARGIN 2)
(IMIN (SUPERPRINT/COMMENT1 L RMARGIN FILE)
(IQUOTIENT (ITIMES (OR (NUMBERP (CAR (LISTP FIRSTCOL)))
(NUMBERP FIRSTCOL)
60)
RMARGIN)
80]
(* We interpret a FIRSTCOL entry as relative to an 80 column terminal and adjust proportionately.
SUPERPRINT/COMMENT1 ensures enough space if the first comment we see is a date comment and we use no more than half
the window)
(SETQ LC RMARGIN))
(T (SETQ FC (IQUOTIENT (ITIMES (OR (NUMBERP (CDR (LISTP FIRSTCOL)))
10)
RMARGIN)
80))
(SETQ LC (IDIFFERENCE RMARGIN FC))
(COND
((EQ FC (DSPXPOSITION NIL FILE)) (* HACK: Almost certainly called from REPP, so we must
supress the normal leading and trailing blank lines as
they have already been done)
(SETQ RIGHTFLG T]
(COND
((ILESSP FC (DSPXPOSITION NIL FILE))
(PRINENDLINE FC FILE))
(T (DSPXPOSITION FC FILE)))
(COND
(RIGHTFLG)
(T (PRINENDLINE FC FILE)))
(SETFONT (PROG1 (SETFONT COMMENTFONT FILE)
(SUPERPRINT/COMMENT2 L FC (IQUOTIENT (IPLUS FC LC)
2)
LC FILE))
FILE)
(OR RIGHTFLG (PRINENDLINE 0 FILE))
(RETURN L])
(SUPERPRINT/COMMENT1
[LAMBDA (CF LP FILE) (* lmm "30-Jul-85 03:04")
(PROG (P1 P0 (CP (DSPXPOSITION NIL FILE)))
[SETQ P1 (IDIFFERENCE LP (COND
((EDITDATE? CF) (* Min space is size of this edit date comment)
(WIDTH CF COMMENTFONT T))
(T (* Else an arbitrary space)
(BLANKS 15]
(SETQ P0 (IDIFFERENCE P1 SPACESIZE))
(* If you can, allow space for this comment plus a one space slop margin. If there is no space for the slop margin,
forget it, that's what the slop is for!)
(RETURN (COND
((OVERLAP CP CP P0 P1)
CP)
(T P0])
(SUPERPRINT/COMMENT2
[LAMBDA (CMT FC MC LC FILE) (* lmm "30-Jul-85 03:20")
(DECLARE (GLOBALVARS ABBREVLST))
(PRINOPEN TAIL (QUOTE %()
FILE)
(bind LASTC for TAIL on CMT
do (AND [OR (EQ LASTC (QUOTE -))
[AND (ILESSP MC (DSPXPOSITION NIL FILE))
(OR (LISTP (CAR TAIL))
(AND (LITATOM LASTC)
(SELECTQ (NTHCHAR LASTC -1)
(; T)
(%. (NOT (FMEMB LASTC ABBREVLST)))
NIL]
(PROGN (AND (NEQ TAIL CMT)
(OR (NLISTP LASTC)
(SELECTQ (CAR TAIL)
((%. , ; :) (* Punctuation after a list)
NIL)
T))
(ADJXPOS SPACESIZE FILE))
(AND (NLISTP (CAR TAIL))
(ILESSP LC (IPLUS (DSPXPOSITION NIL FILE)
(WIDTH (CAR TAIL)
FILE T)
(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)
(WIDTH ")" FILE]
(PRINENDLINE FC FILE))
(COND
((LISTP (SETQ LASTC (CAR TAIL)))
(SUPERPRINT/COMMENT2 LASTC FC MC LC FILE))
(T (PRIN2S LASTC TAIL FILE)))
finally (AND TAIL (PRINDOTP TAIL FILE)))
(PRINSHUT TAIL (QUOTE %))
FILE])
)
(MOVD? (QUOTE PRINTDEF)
(QUOTE OLDPRINTDEF))
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS **COMMENT**FLG CLISPARRAY CHANGESARRAY DISPLAYTERMFLG CHANGECHAR AVERAGEFNLENGTH
#CAREFULCOLUMNS AVERAGEVARLENGTH #RPARS FONTWORDS FONTFNS DEFAULTFONT BOLDFONT USERFONT
SYSTEMFONT CLISPFONT CHANGEFONT BIGFONT CLISPCHARS FUNNYATOMLST PRETTYPRINTMACROS
PRETTYEQUIVLST SPACESIZE COMMENTFLG)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DSPRETTY NEWPRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 SUBPRINT2 PRINTPROG PRINTSQ
BACKARROWP ENDLINE RPARS DSFITP DSFIT1 DSFIT2 SUPERPRINT/COMMENT SUPERPRINT/COMMENT1
SUPERPRINT/COMMENT2 (ENTRIES NEWPRINTDEF SUPERPRINT)
(SPECVARS TAIL LEFT)
(LOCALFREEVARS TAILFLG FNSLST FIRSTPOS LASTPOS COMMENTCOL FORMFLG FILEFLG CHANGEFLG
CHANGEFLG0))
]
(DECLARE: DONTEVAL@LOAD EVAL@COMPILEWHEN (NOT (HASDEF (QUOTE ADJXPOS)
(QUOTE MACRO)))
(FILESLOAD (LOADCOMP)
DSPRINTDEF)
)
)
(PUTPROPS NEWPRINTDEF COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2034 28723 (NEWPRINTDEF 2044 . 3463) (SUPERPRINT 3465 . 4537) (SUPERPRINT0 4539 . 6168)
(SUBPRINT 6170 . 17564) (SUBPRINT1 17566 . 18073) (SUBPRINT2 18075 . 18725) (PRINTPROG 18727 . 21094)
(PRINTSQ 21096 . 22711) (BACKARROWP 22713 . 22924) (ENDLINE 22926 . 23322) (RPARS 23324 . 23845) (
DSFITP 23847 . 25152) (DSFIT1 25154 . 26684) (DSFIT2 26686 . 28721)) (28724 32944 (SUPERPRINT/COMMENT
28734 . 30691) (SUPERPRINT/COMMENT1 30693 . 31449) (SUPERPRINT/COMMENT2 31451 . 32942)))))
STOP