(FILECREATED "26-Mar-86 22:44:05" {ERIS}<LISPCORE>SOURCES>NEWPRINTDEF.;30 46052
changes to: (VARS NEWPRINTDEFCOMS)
(FNS SUPERPRINT/COMMENT SUPERPRINT/COMMENT1 SUPERPRINT/COMMENT2)
previous date: " 4-Feb-86 19:35:12" {ERIS}<LISPCORE>SOURCES>NEWPRINTDEF.;28)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NEWPRINTDEFCOMS)
(RPAQQ NEWPRINTDEFCOMS
[(COMS (* * "A version of PRINTDEF abstracted so that it can be parameterized for non-teletype devices.
One example is file DSPRINTDEF which provides one definition for the abstract fns such as WIDTH, XPOSITION etc used here."
)
(FNS PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 SUBPRINT2 PRINTPROG PRINTSQ
BACKARROWP ENDLINE RPARS FITP DSFIT1 DSFIT2 SUPERPRINT/SPACE))
[COMS (FNS SUPERPRINT/COMMENT SUPERPRINT/COMMENT1 SUPERPRINT/COMMENT2)
(INITVARS (COMMENTCOLUMN (QUOTE (.6 . .1]
(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 COMMENTFLG)
(BLOCKS (DSPRETTY PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 SUBPRINT2
PRINTPROG PRINTSQ BACKARROWP ENDLINE RPARS FITP DSFIT1 DSFIT2
(ENTRIES PRINTDEF SUPERPRINT FITP)
(SPECVARS TAIL LEFT)
(LOCALFREEVARS TAILFLG FNSLST FIRSTPOS LASTPOS COMMENTCOL FORMFLG
FILEFLG CHANGEFLG CHANGEFLG0)))
(DECLARE: DONTEVAL@LOAD (FILES (LOADCOMP)
DSPRINTDEF])
(* *
"A version of PRINTDEF abstracted so that it can be parameterized for non-teletype devices.
One example is file DSPRINTDEF which provides one definition for the abstract fns such as WIDTH, XPOSITION etc used here."
)
(DEFINEQ
(PRINTDEF
[LAMBDA (EXPR LEFT FORMFLG TAILFLG FNSLST FILE) (* lmm " 4-Feb-86 19:31")
(* Provided as a plug compatible defn
of PRINTDEF)
(LET ((FILE (GETSTREAM FILE (QUOTE OUTPUT)))
(MAKEMAP NIL)
SPACEWIDTH)
(DECLARE (SPECVARS MAKEMAP SPACEWIDTH))
(PROG [(FIRSTPOS (DSPLEFTMARGIN NIL FILE))
(RMARGIN (SUB1 (DSPRIGHTMARGIN NIL FILE)))
(TAIL (LIST EXPR))
COMMENTCOL CHANGEFLG (FILEFLG (NEQ FILE (GETSTREAM T (QUOTE OUTPUT]
(COND
((AND (NOT (IMAGESTREAMP FILE))
(NOT FONTCHANGEFLG))
(DSPFONT 0 FILE)))
(DECLARE (SPECVARS RMARGIN FILEFLG SPACEWIDTH))
(RESETLST (RESETSAVE (OUTPUT FILE))
(RESETSAVE NIL (LIST (FUNCTION DSPFONT)
(DSPFONT NIL FILE)
FILE))
(SETFONT DEFAULTFONT FILE)
[SETQ LEFT (COND
((NOT LEFT)
FIRSTPOS)
((NUMBERP LEFT)
(PLUS FIRSTPOS (BLANKS LEFT)))
(T (DSPXPOSITION NIL FILE]
(COND
[PRETTYFLG (COND
((GREATERP (DSPXPOSITION NIL FILE)
LEFT)
(TERPRI FILE)))
(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])
(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 "18-Jan-86 02:37")
(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 (FITP TAIL NIL TEM NIL FILE)))
(ENDLINE NIL FILE))
(T (SUPERPRINT/SPACE 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 (BLANKS 1)))
(SUPERPRINT/SPACE FILE)
(GO LP))
NIL)))
((NOT (FITP 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 (SUPERPRINT/SPACE 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 >.)
(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))
((FITP NEXT NIL NIL NIL FILE)
(GO SP))
(T (GO CR)))
SP (SETQ DOCRFLG NIL)
(SUPERPRINT/SPACE 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)
(BLANKS 1)))
(* 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))
(FITP TAIL NIL CEND NIL FILE))
(SUPERPRINT/SPACE 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)))
(BLANKS 1)))
(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)
(STRINGWIDTH " " FILE] (* LABELL is the position PROG labels
start in; LEFT that for forms)
(DSPXPOSITION LEFT FILE)
(COND
((AND (CAR TAIL)
(LITATOM (CAR TAIL)))
(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 "18-Jan-86 02:37")
(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)
(SUPERPRINT/SPACE 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))
(SUPERPRINT/SPACE 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])
(FITP
[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)
(LET ((SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
FILE)))
(DECLARE (SPECVARS SPACEWIDTH))
(PROG ((N (IDIFFERENCE (OR LSTCOL RMARGIN)
(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)))
(BLANKS 1]
(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 (BLANKS 1))))
NIL)
FILE])
(SUPERPRINT/SPACE
[LAMBDA (FILE) (* lmm " 4-Feb-86 17:06")
(PRIN3 " " FILE])
)
(DEFINEQ
(SUPERPRINT/COMMENT
[LAMBDA (L FILE) (* bvm: "26-Mar-86 12:23")
(DECLARE (GLOBALVARS PRETTYLCOM))
(COND
((AND **COMMENT**FLG (NOT FILEFLG)
(NOT MAKEMAP))
(COND
((GREATERP (PLUS (DSPXPOSITION NIL FILE)
(STRINGWIDTH **COMMENT**FLG FILE))
(DSPRIGHTMARGIN NIL FILE))
(PRINENDLINE 0 FILE)))
(PRIN1S **COMMENT**FLG NIL FILE))
(T (PROG (COMMENT-LMARGIN COMMENT-RMARGIN RIGHTFLG)
[COND
([SETQ RIGHTFLG (NOT (OR (SUPERPRINTEQ (CADR L)
COMMENTFLG)
(ILESSP PRETTYLCOM (COUNT L]
(* Print comment in the righthand
margin)
(SETQ COMMENT-LMARGIN (OR COMMENTCOL (SUPERPRINT/COMMENT1 L RMARGIN FILE)))
(SETQ COMMENT-RMARGIN RMARGIN))
(T (SETQ COMMENT-LMARGIN (FIXR (TIMES (OR (FLOATP (CDR (LISTP COMMENTCOLUMN)))
.1)
RMARGIN)))
(SETQ COMMENT-RMARGIN (IDIFFERENCE RMARGIN COMMENT-LMARGIN))
(COND
((EQ COMMENT-LMARGIN (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 COMMENT-LMARGIN (DSPXPOSITION NIL FILE))
(PRINENDLINE COMMENT-LMARGIN FILE))
(T (DSPXPOSITION COMMENT-LMARGIN FILE)))
(COND
(RIGHTFLG)
(T (PRINENDLINE COMMENT-LMARGIN FILE)))
(SETFONT (PROG1 (SETFONT COMMENTFONT FILE)
(SUPERPRINT/COMMENT2 L COMMENT-LMARGIN (IQUOTIENT (IPLUS
COMMENT-LMARGIN
COMMENT-RMARGIN
)
2)
COMMENT-RMARGIN FILE))
FILE)
(OR RIGHTFLG (PRINENDLINE 0 FILE))
(RETURN L])
(SUPERPRINT/COMMENT1
[LAMBDA (CF RMARGIN FILE) (* bvm: "26-Mar-86 14:03")
(* * Computes the left margin for comments printed on the right)
(LET ((EDITDATEP (EDITDATE? CF))
LM MINLEFT DEFAULT)
(SETQ MINLEFT (IDIFFERENCE [IDIFFERENCE RMARGIN (COND
[EDITDATEP
(* Min space is size of this edit date
comment)
(LET ((FONT (DSPFONT COMMENTFONT
FILE)))
(PROG1 (WIDTH CF FILE T)
(DSPFONT FONT FILE]
(T
(* Else an arbitrary space)
(BLANKS 15]
(BLANKS 1)))
(SETQ DEFAULT (FIXR (TIMES (OR (FLOATP (CAR (LISTP COMMENTCOLUMN)))
.6)
RMARGIN)))
(SETQ LM (IMAX (IQUOTIENT RMARGIN 2)
(IMIN MINLEFT DEFAULT))) (* use at least enough space, but no
more than half the line)
(COND
((NOT EDITDATEP) (* Don't have the editdate dictate
margin for rest of function!)
(SETQ COMMENTCOL LM)))
LM])
(SUPERPRINT/COMMENT2
[LAMBDA (CMT COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE)
(* bvm: "26-Mar-86 11:33")
(PRINOPEN TAIL (QUOTE %()
FILE)
(bind LASTC for TAIL on CMT
do (AND [OR (EQ LASTC (QUOTE -))
[AND (IGEQ (DSPXPOSITION NIL FILE)
COMMENT-MIDPOINT)
(OR (LISTP (CAR TAIL))
(AND (LITATOM LASTC)
(SELCHARQ (NTHCHARCODE LASTC -1)
((; %. -)
T)
NIL]
(PROGN (AND (NEQ TAIL CMT)
(OR (NLISTP LASTC)
(SELECTQ (CAR TAIL)
((%. , ; :)
(* Punctuation after a list)
NIL)
T))
(SUPERPRINT/SPACE FILE))
(AND (NLISTP (CAR TAIL))
(IGEQ (IPLUS (DSPXPOSITION NIL FILE)
(WIDTH (CAR TAIL)
FILE T)
(WIDTH (COND
((CDR TAIL)
" ")
(T (* leave space for the paren i.e.
dont print last atom on one line and
the paren on the next)
")"))
FILE))
COMMENT-RMARGIN]
(PRINENDLINE COMMENT-LMARGIN FILE))
(COND
((LISTP (SETQ LASTC (CAR TAIL)))
(SUPERPRINT/COMMENT2 LASTC COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE))
(T (PRIN2S LASTC TAIL FILE))) finally (AND TAIL (PRINDOTP TAIL FILE)))
(PRINSHUT TAIL (QUOTE %))
FILE])
)
(RPAQ? COMMENTCOLUMN (QUOTE (.6 . .1)))
(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 COMMENTFLG)
)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: DSPRETTY PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 SUBPRINT2 PRINTPROG PRINTSQ
BACKARROWP ENDLINE RPARS FITP DSFIT1 DSFIT2 (ENTRIES PRINTDEF SUPERPRINT FITP)
(SPECVARS TAIL LEFT)
(LOCALFREEVARS TAILFLG FNSLST FIRSTPOS LASTPOS COMMENTCOL FORMFLG FILEFLG CHANGEFLG CHANGEFLG0
))
]
(DECLARE: DONTEVAL@LOAD
(FILESLOAD (LOADCOMP)
DSPRINTDEF)
)
)
(PUTPROPS NEWPRINTDEF COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2326 37681 (PRINTDEF 2336 . 4500) (SUPERPRINT 4502 . 5818) (SUPERPRINT0 5820 . 7990) (
SUBPRINT 7992 . 23061) (SUBPRINT1 23063 . 23765) (SUBPRINT2 23767 . 24652) (PRINTPROG 24654 . 27734) (
PRINTSQ 27736 . 29744) (BACKARROWP 29746 . 29964) (ENDLINE 29966 . 30487) (RPARS 30489 . 31234) (FITP
31236 . 32853) (DSFIT1 32855 . 34771) (DSFIT2 34773 . 37539) (SUPERPRINT/SPACE 37541 . 37679)) (37682
45017 (SUPERPRINT/COMMENT 37692 . 40675) (SUPERPRINT/COMMENT1 40677 . 42599) (SUPERPRINT/COMMENT2
42601 . 45015)))))
STOP