(FILECREATED "29-SEP-83 20:43:49" {PHYLUM}<LISPCORE>SOURCES>NEWPRINTDEF.;3 31031
changes to: (VARS NEWPRINTDEFCOMS)
previous date: "31-AUG-83 16:46:08" {PHYLUM}<LISPCORE>SOURCES>NEWPRINTDEF.;2)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT NEWPRINTDEFCOMS)
(RPAQQ NEWPRINTDEFCOMS [(* A version of PRINTDEF abstracted so that it can be parametrized for
non-teletype devices. One example is <LISPUSERS>DSPRINTDEF which provides
one definition for the abstract fns such as WIDTH, ADJPOS, 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/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/COMMENT2 (ENTRIES NEWPRINTDEF SUPERPRINT)
(SPECVARS TAIL LEFT)
(LOCALFREEVARS TAILFLG FNSLST FIRSTPOS LASTPOS COMMENTCOL FORMFLG
FILEFLG CHANGEFLG CHANGEFLG0)))
(DECLARE: EVAL@COMPILEWHEN (NOT (BOUNDP (QUOTE NEWPRINTDEFDEFS)))
(FILES (LOADCOMP)
DSPRINTDEF])
(* A version of PRINTDEF abstracted so that it can be parametrized for non-teletype devices.
One example is <LISPUSERS>DSPRINTDEF which provides one definition for the abstract fns such as
WIDTH, ADJPOS, etc used here.)
(DEFINEQ
(NEWPRINTDEF
[LAMBDA (EXPR LEFT FORMFLG TAILFLG FNSLST FILE) (* rmk: "31-AUG-83 16:46")
(* 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 NEWLINE)
(QUOTE TTYNEWLINE)))
(RESETSAVE (RESETDEF (QUOTE OPENS)
(QUOTE TTYOPENS)))
(RESETSAVE (RESETDEF (QUOTE SHUTS)
(QUOTE TTYSHUTS)))
(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: "10-MAR-83 17:34")
(COND
((NLISTP E)
[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))
((AND CHANGESARRAY (GETHASH E CHANGESARRAY))
(SUPERPRINT/CHANGES E TAIL BRFLG))
((AND FORMFLG (SUPERPRINTEQ (CAR E)
COMMENTFLG))
(SUPERPRINT/COMMENT E))
(T (SUPERPRINT0 (COND
((OR PRETTYTRANFLG (EQ CLISPTRANFLG (CAR E)))
(SUPERPRINT/TRAN E))
(T E))
TAIL BRFLG])
(SUPERPRINT0
[LAMBDA (E TAIL BRFLG) (* bas: "21-MAR-83 16:46")
(* 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)
(OPENS 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)))
(SHUTS TAIL (if NEWBR
then (QUOTE %])
elseif BRFLG
then NIL
else (QUOTE %)]
E])
(SUBPRINT
[LAMBDA (TAIL BRFLG END) (* bas: "21-MAR-83 16:27")
(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 (DOT 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: "21-MAR-83 16:11")
(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 (DOT 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 (NEWLINE 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)
(NEWLINE 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: "25-MAR-83 16:14")
(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))
(NEWLINE KEYL)
(if (NLISTP TAIL)
then (RETURN (DOT TAIL))
elseif (CDR TAIL)
then (if (LISTP (CAR TAIL))
then (OPENS 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 (NEWLINE LEFT)
else (SETQ LEFT (XPOSITION)))
(SUBPRINT (CDAR TAIL]
(SHUTS 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: "15-NOV-82 16:16")
(AND FORMFLG (while (SUPERPRINTEQ [CAR (LISTP (CAR (LISTP TAIL]
COMMENTFLG)
do (SUPERPRINT (CAR TAIL)
TAIL) (* a comment)
(pop TAIL)))
(NEWLINE (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: "24-MAR-83 16:40")
(DECLARE (GLOBALVARS PRETTYLCOM))
(if **COMMENT**FLG
then (PRIN1S **COMMENT**FLG TAIL)
else (PROG (FC LC RIGHTFLG)
(if [SETQ RIGHTFLG (AND (NOT (SUPERPRINTEQ (CADR L)
COMMENTFLG))
(IGREATERP PRETTYLCOM (COUNT L]
then [SETQ FC (OR COMMENTCOL (SETQ COMMENTCOL
(IQUOTIENT (ITIMES (OR (CAR (LISTP FIRSTCOL))
(NUMBERP FIRSTCOL)
60)
LASTPOS)
80]
(SETQ LC LASTPOS)
else (SETQ FC (IQUOTIENT (ITIMES (OR (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 (NEWLINE FC)
else (XPOSITION FC))
(if RIGHTFLG
else (NEWLINE FC))
(SETFONT (PROG1 (SETFONT COMMENTFONT)
(SUPERPRINT/COMMENT2 L FC (IQUOTIENT (IPLUS FC LC)
2)
LC)))
(OR RIGHTFLG (NEWLINE 0))
(RETURN L])
(SUPERPRINT/COMMENT2
[LAMBDA (CMT FC MC LC) (* bas: "24-MAR-83 16:54")
(DECLARE (GLOBALVARS ABBREVLST))
(OPENS 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))
(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 ")"]
(NEWLINE FC))
(if (LISTP (SETQ LASTC (CAR TAIL)))
then (SUPERPRINT/COMMENT2 LASTC FC MC LC)
else (PRIN2S LASTC TAIL))
finally (AND TAIL (DOT TAIL)))
(SHUTS TAIL (QUOTE %)])
)
(MOVD? (QUOTE PRINTDEF)
(QUOTE OLDPRINTDEF))
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR 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/COMMENT2 (ENTRIES NEWPRINTDEF SUPERPRINT)
(SPECVARS TAIL LEFT)
(LOCALFREEVARS TAILFLG FNSLST FIRSTPOS LASTPOS COMMENTCOL FORMFLG FILEFLG CHANGEFLG
CHANGEFLG0))
]
(DECLARE: EVAL@COMPILEWHEN (NOT (BOUNDP (QUOTE NEWPRINTDEFDEFS)))
(FILESLOAD (LOADCOMP)
DSPRINTDEF)
)
)
(PUTPROPS NEWPRINTDEF COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1992 25602 (NEWPRINTDEF 2002 . 3321) (SUPERPRINT 3323 . 4007) (SUPERPRINT0 4009 . 5054)
(SUBPRINT 5056 . 15700) (SUBPRINT1 15702 . 16129) (SUBPRINT2 16131 . 16714) (PRINTPROG 16716 . 18587)
(PRINTSQ 18589 . 19941) (BACKARROWP 19943 . 20130) (ENDLINE 20132 . 20481) (RPARS 20483 . 20995) (
DSFITP 20997 . 22239) (DSFIT1 22241 . 23641) (DSFIT2 23643 . 25600)) (25603 29954 (SUPERPRINT/CHANGES
25613 . 26654) (SUPERPRINT/TRAN 26656 . 27369) (SUPERPRINT/COMMENT 27371 . 28754) (SUPERPRINT/COMMENT2
28756 . 29952)))))
STOP