(FILECREATED "14-Sep-84 11:49:42" {ERIS}<LISPCORE>DIG>NEWPRINTDEF.;1 32594
changes to: (FNS SUPERPRINT/COMMENT1)
previous date: "20-Apr-84 18:12:59" {ERIS}<LISPCORE>SOURCES>NEWPRINTDEF.;2)
(* Copyright (c) 1982, 1983, 1984 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/CHANGES SUPERPRINT/TRAN 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/CHANGES SUPERPRINT/TRAN 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) (* bas: "18-Mar-84 17:10")
(* Provided as a plug compatible defn of PRINTDEF)
(SETQ FILE (\OUTSTREAMARG FILE))
(COND
[(IMAGESTREAMP FILE)
(PROG ((FIRSTPOS (DSPLEFTMARGIN NIL FILE))
(LASTPOS (DSPRIGHTMARGIN NIL FILE))
(TAIL (LIST EXPR))
COMMENTCOL CHANGEFLG FILEFLG)
(RESETLST (RESETSAVE PPDSP (IMAGESTREAMP FILE))
[SETQ LEFT (COND
((NOT LEFT)
0)
((NUMBERP LEFT)
(FIX LEFT))
(T (XPOSITION]
(RESETSAVE (SETFONT DEFAULTFONT))
(RESETSAVE (RESETDEF (QUOTE PRINENDLINE)
(QUOTE TTYENDLINE)))
(RESETSAVE (RESETDEF (QUOTE PRINOPEN)
(QUOTE TTYPRINOPEN)))
(RESETSAVE (RESETDEF (QUOTE PRINSHUT)
(QUOTE TTYPRINSHUT)))
(RESETSAVE (RESETDEF (QUOTE PRIN1S)
(QUOTE TTYPRIN1S)))
(RESETSAVE (RESETDEF (QUOTE PRIN2S)
(QUOTE TTYPRIN2S)))
(COND
[PRETTYFLG (XPOSITION LEFT)
(COND
(TAILFLG (SUBPRINT EXPR))
(T (SUPERPRINT EXPR TAIL]
(T (COND
(TAILFLG (MAPRINT EXPR NIL NIL NIL NIL (FUNCTION PRIN2S)))
(T (PRIN2S EXPR TAIL]
(T (OLDPRINTDEF EXPR LEFT FORMFLG TAILFLG FNSLST FILE])
(SUPERPRINT
[LAMBDA (E TAIL BRFLG) (* bas: "18-Mar-84 16:24")
(if (NLISTP E)
then [PROG [(TEM (IDIFFERENCE LASTPOS (WIDTH E NIL T]
(* TEM is the last position at which E will fit)
(AND (ILESSP TEM (XPOSITION))
(IGREATERP TEM FIRSTPOS)
(ENDLINE (IMIN LEFT TEM]
(PRIN2S E TAIL)
elseif (AND CHANGESARRAY (GETHASH E CHANGESARRAY))
then (SUPERPRINT/CHANGES E TAIL BRFLG)
elseif (AND FORMFLG (SUPERPRINTEQ (CAR E)
COMMENTFLG))
then (SUPERPRINT/COMMENT E)
else (SUPERPRINT0 (COND
((OR PRETTYTRANFLG (EQ CLISPTRANFLG (CAR E)))
(SUPERPRINT/TRAN E))
(T E))
TAIL BRFLG])
(SUPERPRINT0
[LAMBDA (E TAIL BRFLG) (* bas: "18-Mar-84 17:00")
(* BRFLG says do not print a %) as expression will be
terminated by a %].)
[PROG [(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 (if NEWBR
then (QUOTE %[)
else (QUOTE %()))
(SUBPRINT E (OR BRFLG NEWBR))
(if (ILESSP LASTPOS (IPLUS (XPOSITION)
(WIDTH ")")))
then (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)))
(PRINSHUT TAIL (if NEWBR
then (QUOTE %])
elseif BRFLG
then NIL
else (QUOTE %)]
E])
(SUBPRINT
[LAMBDA (TAIL BRFLG END) (* bas: "18-Mar-84 16:57")
(PROG [CURRENT DOCRFLG NEXT TEM OLDY CLISPWORD (FORMFLG FORMFLG)
(FORMFLG0 FORMFLG)
(TAIL0 TAIL)
(LEFT0 (XPOSITION))
(CLW0 (CAR (SUPERPRINTGETPROP (CAR TAIL)
(QUOTE CLISPWORD]
(SETQ LEFT LEFT0) (* LEFT is set from SUBPRINT.
Start where we are)
LP (if (EQ TAIL END)
then (RETURN TAIL)
elseif (NULL TAIL)
then (RETURN)
elseif (NLISTP TAIL)
then (RETURN (PRINDOTP TAIL)))
(SETQ OLDY (YPOSITION))
(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 (if (LISTP CLISPWORD)
then CLISPFONT
elseif (FMEMB CURRENT FONTWORDS)
then USERFONT
elseif (AND (EQ TAIL0 TAIL)
(NULL END))
then (if (OR (FMEMB CURRENT FNSLST)
(FMEMB CURRENT (LISTP FONTFNS)))
then USERFONT
elseif (FGETD CURRENT)
then SYSTEMFONT)
elseif (AND (SUPERPRINTGETPROP CURRENT (QUOTE CLISPTYPE))
(NOT (FMEMB CURRENT CLISPCHARS)))
then (* Infix operators like GT AND etc.)
CLISPFONT)))
(* 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]
(* 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 (if (OR (EQ TAIL END)
(NLISTP TAIL))
then (GO LP)
elseif (OR (NULL CLISPFLG)
(NULL FORMFLG)
(NULL FORMFLG0))
then (GO LP1)
elseif [NOT (LITATOM (SETQ NEXT (CAR TAIL]
elseif [AND (SETQ TEM (SUPERPRINTGETPROP NEXT (QUOTE CLISPWORD)))
(OR (NLISTP TEM)
(EQ CLW0 (CAR TEM]
then
(* 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)
elseif (EQ (NTHCHARCODE NEXT 1)
(CHARCODE <))
then [if (EQ (SETQ TEM (SUBPRINT2 TAIL END))
(CDR TAIL))
then (if (AND (LITATOM CURRENT)
(BACKARROWP CURRENT))
then (GO CR)
else (GO LP1))
elseif (OR (LISTP CURRENT)
(BACKARROWP CURRENT)
(NOT (DSFITP TAIL NIL TEM)))
then (ENDLINE)
else (ADJXPOS SPACESIZE)
(if (EQ TAIL (CDR TAIL0))
then (SETQ LEFT (XPOSITION]
(SETQ OLDY (YPOSITION))
(PROG [(LEFT (IPLUS (XPOSITION)
(BLANKS 2]
(SETQ TAIL (SUBPRINT TAIL BRFLG TEM)))
(SETQQ CURRENT >)
(GO LP0)
elseif [AND (EQ (CADR (LISTP TAIL))
(QUOTE ←))
(OR (SUPERPRINTEQ (CAR TAIL0)
(QUOTE CREATE))
(SUPERPRINTEQ (CAR TAIL0)
(QUOTE create]
then (GO CR))
(if (LISTP CURRENT)
then (if [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]
then (GO LP)) (* E.g. ((FOO) *FIE))
elseif (NOT (LITATOM CURRENT))
then (GO LP1)
elseif (SELECTQ (CAR CLISPWORD)
((IFWORD FORWORD)
T)
NIL)
then (SETQ DOCRFLG NIL)
(if (NULL END)
then (SETQ END T)) (* See use of END below)
elseif [NOT (OR (ATOM NEXT)
(if (EQ TAIL (CDR TAIL0))
then (OR (FGETD CURRENT)
(SUPERPRINTGETPROP CURRENT (QUOTE EXPR)))
else (BOUNDP CURRENT))
(FMEMB CURRENT FUNNYATOMLST)
(NOT (FMEMB (SETQ TEM (NTHCHAR CURRENT -1))
CLISPCHARS))
(EQ TEM (QUOTE >]
then (* E.g. X* (FOO) Don't space)
(GO LP)
elseif (BACKARROWP CURRENT)
then (* E.G. IF -- THEN FOO←X FIE←Y is more readable if the
assignments are on separate lines.)
(GO CR))
LP1 (if (EQ TAIL (CDR TAIL0))
then (* First time through i.e. just superprinted HEAD of
list.)
(if (LISTP CURRENT)
then (GO CR)
elseif (AND FORMFLG0 (SELECTQ (OR (CDR (FASSOC CURRENT PRETTYEQUIVLST))
CURRENT)
(COND (SETQ LEFT (IPLUS LEFT0 (WIDTH "CO")))
(GO CR))
((PROG RESETVARS)
(RETURN (PRINTPROG TAIL BRFLG)))
(SELECTQ (RETURN (PRINTSQ TAIL BRFLG)))
((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)
(GO LP))
NIL))
elseif [NOT (DSFITP TAIL T (OR (LISTP END)
(AND CLISPWORD (SUBPRINT1 TAIL (CAR CLISPWORD]
then (GO CR) (* Don't reset I.)
elseif (EQ (NTHCHARCODE CURRENT 1)
(CHARCODE <))
then (GO SP)
else (ADJXPOS SPACESIZE) (* Default head of form handling)
[SETQ LEFT (IMIN (XPOSITION)
(IPLUS LEFT0 (BLANKS 6]
(* Dont indent too far)
(GO LP)))
(if [AND (NEQ OLDY (YPOSITION))
(OR (NOT (ATOM CURRENT))
(EQ CURRENT (QUOTE >]
then (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))
(if (LISTP CURRENT)
then (if (OR (NULL END)
(SUPERPRINTEQ (CAR CURRENT)
COMMENTFLG))
then (GO CR)
elseif (AND (LISTP NEXT)
(SUPERPRINTEQ (CAR NEXT)
COMMENTFLG))
then (GO SP)
elseif [AND (LITATOM NEXT)
(OR (SUPERPRINTGETPROP NEXT (QUOTE CLISPWORD))
(SUPERPRINTGETPROP NEXT (QUOTE CLISPTYPE]
then (GO SP)
else (GO CR))
elseif (NLISTP NEXT)
then (GO SP)
elseif DOCRFLG
then
(* 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)
elseif (DSFITP NEXT)
then (GO SP)
else (GO CR))
SP (SETQ DOCRFLG NIL)
(ADJXPOS SPACESIZE)
(GO LP)
CR (SETQ DOCRFLG T)
(ENDLINE)
(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]
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)))
(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 [if (AND (EQ OLDY (YPOSITION))
(DSFITP TAIL NIL CEND))
then (ADJXPOS SPACESIZE)
(XPOSITION)
else
(* 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]
SPACESIZE))
(SETQ OLDY (YPOSITION))
(SETQ CURRENT (CAR (NLEFT TAIL 1 CEND)))
(SETQ TAIL (SUBPRINT TAIL BRFLG CEND)))
(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) (* bas: "18-Mar-84 17:05")
(PROG (CLISPTEM (LABELL (IDIFFERENCE (XPOSITION)
(WIDTH "ROG")))
(LEFT (IPLUS (XPOSITION)
SPACESIZE))) (* LABELL is the position PROG labels start in;
LEFT that for forms)
(XPOSITION LEFT) (* Print PROG variables.)
(SUPERPRINT (CAR TAIL)
TAIL
(AND (NULL (SETQ TAIL (CDR TAIL)))
BRFLG))
LP1 (if (LISTP TAIL)
then (ENDLINE LABELL)) (* ENDLINE resets TAIL when it sees a comment.)
LP2 (if (NLISTP TAIL)
then (AND TAIL (PRINDOTP TAIL))
(RETURN)
elseif (LISTP (CAR TAIL))
then (if CLISPTEM
then (* Dont space if sucking up assignments)
(SETQ CLISPTEM NIL)
else (if (ILEQ LEFT (XPOSITION))
then (PRINENDLINE LEFT)
else (XPOSITION LEFT)))
(SUPERPRINT (CAR TAIL)
TAIL
(AND (NULL (SETQ TAIL (CDR TAIL)))
BRFLG))
(GO LP1)
else (if (ILESSP LABELL (XPOSITION))
then (* Two labels in a row)
(PRINENDLINE LABELL))
[if [SETQ CLISPTEM (AND CLISPFLG (STRPOS (QUOTE "←")
(CAR TAIL]
then (* 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.)
(XPOSITION LEFT) (* Remember trailing ←)
(SETQ CLISPTEM (EQ CLISPTEM (NCHARS (CAR TAIL]
(SUPERPRINT (CAR TAIL)
TAIL) (* Print the label.)
(pop TAIL)
(GO LP2])
(PRINTSQ
[LAMBDA (TAIL BRFLG) (* bas: "18-Mar-84 17:05")
(PROG (LEFT FOLD (KEYL (IQUOTIENT (IPLUS LEFT (XPOSITION))
2))) (* KEYL is the position keys start in;
LEFT that for forms)
(* Print select expression FORMFLG=T)
(ADJXPOS SPACESIZE)
[SETQ FOLD (IPLUS (SETQ LEFT (XPOSITION))
(ITIMES 2 (IDIFFERENCE LEFT KEYL]
(SUPERPRINT (CAR TAIL)
TAIL NIL)
LP (OR (SETQ TAIL (CDR TAIL))
(RETURN))
(PRINENDLINE KEYL)
(if (NLISTP TAIL)
then (RETURN (PRINDOTP TAIL))
elseif (CDR TAIL)
then (if (LISTP (CAR TAIL))
then (PRINOPEN TAIL (QUOTE %())
(PROG (FORMFLG)
(SUPERPRINT (CAAR TAIL)
(CAR TAIL)
NIL))
[AND (CDAR TAIL)
(PROG ((LEFT LEFT))
(ADJXPOS SPACESIZE)
(if (OR (LISTP (CAAR TAIL))
(ILEQ FOLD (XPOSITION)))
then (PRINENDLINE LEFT)
else (SETQ LEFT (XPOSITION)))
(SUBPRINT (CDAR TAIL]
(PRINSHUT TAIL (QUOTE %)))
else (PRIN2S (CAR TAIL)
TAIL))
else (SUPERPRINT (CAR TAIL)
TAIL BRFLG))
(GO LP])
(BACKARROWP
[LAMBDA (X) (* bas: "17-NOV-82 15:19")
(AND (STRPOS (QUOTE ←)
X)
(NEQ (NTHCHARCODE X -1)
(CHARCODE ←])
(ENDLINE
[LAMBDA (N) (* bas: "18-Mar-84 17:05")
(AND FORMFLG (while (SUPERPRINTEQ [CAR (LISTP (CAR (LISTP TAIL]
COMMENTFLG)
do (SUPERPRINT (CAR TAIL)
TAIL) (* a comment)
(pop TAIL)))
(PRINENDLINE (OR N LEFT))
N])
(RPARS
[LAMBDA (E NP) (* bas: "11-MAR-83 11:45")
(if (ILEQ NP 0)
elseif (NLISTP E)
then NIL
else (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) (* bas: "16-NOV-82 11:33")
(* 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 LASTPOS)
(IPLUS SPACESIZE (XPOSITION]
(CAREFUL (BLANKS #CAREFULCOLUMNS)))
(DECLARE (SPECVARS CAREFUL))
(RETURN (if TAILFLG
then (AND (IGREATERP N (BLANKS (IPLUS AVERAGEVARLENGTH 2)))
(DSFIT1 X N))
else (DSFIT2 X N])
(DSFIT1
[LAMBDA (LST N N1) (* bas: "16-NOV-82 11:35")
(DECLARE (USEDFREE CAREFUL ENDTAIL)) (* Checks to see if LST could fit in N spaces.)
(bind (M ←(if TAILFLG
then NIL
else N))
for L on LST until (EQ L ENDTAIL)
do (if (NLISTP (CAR L))
then (if M
then (SETQ M (IDIFFERENCE M (IPLUS (if (ILESSP M CAREFUL)
then
(* When getting near right margin actually perform the
WIDTH check.)
(WIDTH (CAR L)
NIL T)
else (BLANKS AVERAGEVARLENGTH))
SPACESIZE)))
(if (ILESSP M 0)
then (RETURN NIL)))
elseif (DSFIT2 (CAR L)
(OR N1 N))
then
(* 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)
else (RETURN NIL))
finally (RETURN T])
(DSFIT2
[LAMBDA (X N NC) (* bas: "16-NOV-82 11:32")
(DECLARE (USEDFREE CAREFUL)) (* NC is local to DSFIT2)
(if (SUPERPRINTEQ (CAR X)
COMMENTFLG)
then T
elseif (LISTP (CAR X))
then (* Non-atomic CAR of form e.g. COND clause open lambda
etc.)
(AND [ILESSP 0 (SETQ N (IDIFFERENCE N (WIDTH "()"]
(DSFIT2 (CAR X)
N)
(OR (NULL (CDR X))
(DSFIT1 (CDR X)
N)))
elseif [ILESSP N (IPLUS (WIDTH "()")
(SETQ NC (if (ILESSP N CAREFUL)
then (WIDTH (CAR X)
NIL T)
else (BLANKS AVERAGEFNLENGTH]
then
(* 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
elseif (NULL (CDR X))
then T
elseif [ILEQ [SELECTQ (CAR X)
(COND 0)
(FUNCTION (WIDTH "(FUNCTION LAMBDA ABC)"))
([LAMBDA NLAMBDA]
(WIDTH "(LAMBDA ABC"))
(SETQ (IPLUS (WIDTH "(SETQ ")
(BLANKS AVERAGEVARLENGTH)))
(PROGN (SETQ N (IDIFFERENCE N NC))
(BLANKS (ADD1 AVERAGEFNLENGTH]
(SETQ N (IDIFFERENCE N (BLANKS 2]
then
(* 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])
)
(DEFINEQ
(SUPERPRINT/CHANGES
[LAMBDA (E TAIL BRFLG) (* bas: "21-MAR-83 14:41")
(PROG ((CHANGEFLG CHANGEFLG)
CHANGEFLG0)
(if (AND CHANGECHAR (NULL CHANGEFLG)
(OR FILEFLG DISPLAYTERMFLG))
then
(* 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))
[RESETVARS (CHANGESARRAY) (* Resetting CHANGESARRAY disables check within this
scope)
(SETFONT (PROG1 (SETFONT CHANGEFONT)
(SETQ E (SUPERPRINT E TAIL BRFLG]
(RETURN E])
(SUPERPRINT/TRAN
[LAMBDA (E) (* bas: "11-MAR-83 12:34")
(if (AND CLISPTRANFLG (EQ CLISPTRANFLG (CAR E)))
then (SELECTQ PRETTYTRANFLG
(NIL (CDDR E))
(T (CADR E))
E)
elseif [AND CLISPARRAY PRETTYTRANFLG (GETHASH E CLISPARRAY)
(NOT (if (LITATOM (CAR E))
then (FGETD (CAR E))
elseif (LISTP (CAR E))
then (OR (SUPERPRINTEQ (CAAR E)
(QUOTE LAMBDA))
(SUPERPRINTEQ (CAAR E)
(QUOTE NLAMBDA]
then [SELECTQ PRETTYTRANFLG
(T (GETHASH E CLISPARRAY))
(CONS CLISPTRANFLG (CONS (GETHASH E CLISPARRAY)
(COPYCONS E]
else E])
(SUPERPRINT/COMMENT
[LAMBDA (L) (* bas: "20-Apr-84 18:05")
(DECLARE (GLOBALVARS PRETTYLCOM))
(if **COMMENT**FLG
then (PRIN1S **COMMENT**FLG TAIL)
else (PROG (FC LC RIGHTFLG)
(if [SETQ RIGHTFLG (NOT (OR (SUPERPRINTEQ (CADR L)
COMMENTFLG)
(ILESSP PRETTYLCOM (COUNT L]
then [SETQ FC
(OR COMMENTCOL
(SETQ COMMENTCOL
(IMAX (IQUOTIENT LASTPOS 2)
(IMIN (SUPERPRINT/COMMENT1 L LASTPOS)
(IQUOTIENT (ITIMES (OR (NUMBERP (CAR (LISTP FIRSTCOL)))
(NUMBERP FIRSTCOL)
60)
LASTPOS)
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 LASTPOS)
else (SETQ FC (IQUOTIENT (ITIMES (OR (NUMBERP (CDR (LISTP FIRSTCOL)))
10)
LASTPOS)
80))
(SETQ LC (IDIFFERENCE LASTPOS FC))
(if (EQ FC (XPOSITION))
then (* 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)))
(if (ILESSP FC (XPOSITION))
then (PRINENDLINE FC)
else (XPOSITION FC))
(if RIGHTFLG
else (PRINENDLINE FC))
(SETFONT (PROG1 (SETFONT COMMENTFONT)
(SUPERPRINT/COMMENT2 L FC (IQUOTIENT (IPLUS FC LC)
2)
LC)))
(OR RIGHTFLG (PRINENDLINE 0))
(RETURN L])
(SUPERPRINT/COMMENT1
[LAMBDA (CF LP) (* rmk: "14-Sep-84 11:44")
(PROG (P1 P0 (CP (XPOSITION)))
[SETQ P1 (IDIFFERENCE LP (if (EDITDATE? CF)
then (* Min space is size of this edit date comment)
(WIDTH CF COMMENTFONT T)
else (* 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 (if (OVERLAP CP CP P0 P1)
then CP
else P0])
(SUPERPRINT/COMMENT2
[LAMBDA (CMT FC MC LC) (* bas: "18-Mar-84 17:05")
(DECLARE (GLOBALVARS ABBREVLST))
(PRINOPEN TAIL (QUOTE %())
(bind LASTC for TAIL on CMT
do (AND [OR (EQ LASTC (QUOTE -))
[AND (ILESSP MC (XPOSITION))
(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))
(AND (NLISTP (CAR TAIL))
(ILESSP LC (IPLUS (XPOSITION)
(WIDTH (CAR TAIL)
NIL T)
(if (CDR TAIL)
then 0
else (* leave space for the paren i.e. dont print last atom
on one line and the paren on the next)
(WIDTH ")"]
(PRINENDLINE FC))
(if (LISTP (SETQ LASTC (CAR TAIL)))
then (SUPERPRINT/COMMENT2 LASTC FC MC LC)
else (PRIN2S LASTC TAIL))
finally (AND TAIL (PRINDOTP TAIL)))
(PRINSHUT TAIL (QUOTE %)])
)
(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/CHANGES SUPERPRINT/TRAN
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))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2126 25925 (NEWPRINTDEF 2136 . 3471) (SUPERPRINT 3473 . 4265) (SUPERPRINT0 4267 . 5336)
(SUBPRINT 5338 . 15987) (SUBPRINT1 15989 . 16416) (SUBPRINT2 16418 . 17001) (PRINTPROG 17003 . 18887)
(PRINTSQ 18889 . 20260) (BACKARROWP 20262 . 20449) (ENDLINE 20451 . 20804) (RPARS 20806 . 21318) (
DSFITP 21320 . 22562) (DSFIT1 22564 . 23964) (DSFIT2 23966 . 25923)) (25926 31463 (SUPERPRINT/CHANGES
25936 . 26977) (SUPERPRINT/TRAN 26979 . 27692) (SUPERPRINT/COMMENT 27694 . 29468) (SUPERPRINT/COMMENT1
29470 . 30235) (SUPERPRINT/COMMENT2 30237 . 31461)))))
STOP