4.3BSD/usr/lib/lisp/pp.l
(setq rcs-pp-
"$Header: /usr/lib/lisp/RCS/pp.l,v 1.2 83/08/15 22:27:54 jkf Exp $")
;;
;; pp.l -[Mon Aug 15 10:52:13 1983 by jkf]-
;;
;; pretty printer for franz lisp
;;
(declare (macros t))
(declare (special poport pparm1 pparm2 lpar rpar form linel))
; (declare (localf $patom1 $prd1 $prdf charcnt condclosefile))
; =======================================
; pretty printer top level routine pp
;
;
; calling form- (pp arg1 arg2 ... argn)
; the args may be names of functions, atoms with associated values
; or output descriptors.
; if argi is:
; an atom - it is assumed to be a function name, if there is no
; function property associated with it,then it is assumed
; to be an atom with a value
; (P port)- port is the output port where the results of the
; pretty printing will be sent.
; poport is the default if no (P port) is given.
; (F fname)- fname is a file name to write the results in
; (A atmname) - means, treat this as an atom with a value, dont
; check if it is the name of a function.
; (E exp)- evaluate exp without printing anything
; other - pretty-print the expression as is - no longer an error
;
; Also, rather than printing only a function defn or only a value, we will
; let prettyprops decide which props to print. Finally, prettyprops will
; follow the CMULisp format where each element is either a property
; or a dotted pair of the form (prop . fn) where in order to print the
; given property we call (fn id val prop). The special properties
; function and value are used to denote those "properties" which
; do not actually appear on the plist.
;
; [history of this code: originally came from Harvard Lisp, hacked to
; work under franz at ucb, hacked to work at cmu and finally rehacked
; to work without special cmu macros]
(declare (special $outport$ $fileopen$ prettyprops))
(setq prettyprops '((comment . pp-comment)
(function . pp-function)
(value . pp-value)))
; printret is like print yet it returns the value printed, this is used
; by pp
(def printret
(macro ($l$)
`(progn (print ,@(cdr $l$)) ,(cadr $l$))))
(def pp
(nlambda ($xlist$)
(prog ($gcprint $outport$ $cur$ $fileopen$ $prl$ $atm$)
(setq $gcprint nil) ; don't print
; gc messages in pp.
(setq $outport$ poport) ; default port
; check if more to do, if not close output file if it is
; open and leave
toploop (cond ((null (setq $cur$ (car $xlist$)))
(condclosefile)
(terpr)
(return t)))
(cond ((dtpr $cur$)
(cond ((equal 'P (car $cur$)) ; specifying a port
(condclosefile) ; close file if open
(setq $outport$ (eval (cadr $cur$))))
((equal 'F (car $cur$)) ; specifying a file
(condclosefile) ; close file if open
(setq $outport$ (outfile (cadr $cur$))
$fileopen$ t))
((equal 'E (car $cur$))
(eval (cadr $cur$)))
(t (pp-form $cur$ $outport$))) ;-DNC inserted
(go botloop)))
(mapc (function
(lambda (prop)
(prog (printer)
(cond ((dtpr prop)
(setq printer (cdr prop))
(setq prop (car prop)))
(t (setq printer 'pp-prop)))
(cond ((eq 'value prop)
(and (boundp $cur$)
(apply printer
(list $cur$
(eval $cur$)
'value))
(terpr $outport$)))
((eq 'function prop)
(and (getd $cur$)
(cond ((not (bcdp (getd $cur$)))
(apply printer
(list $cur$
(getd $cur$)
'function)))
; restore message about
; bcd since otherwise you
; just get nothing and
; people were complaining.
; - dhl.
#-cmu
(t
(msg N
"pp: function "
(or $cur$)
" is machine coded (bcd) "))
)
(terpri $outport$)))
((get $cur$ prop)
(apply printer
(list $cur$
(get $cur$ prop)
prop))
(terpri $outport$))))))
prettyprops)
botloop (setq $xlist$ (cdr $xlist$))
(go toploop))))
(setq pparm1 50 pparm2 100)
; -DNC These "prettyprinter parameters" are used to decide when we should
; quit printing down the right margin and move back to the left -
; Do it when the leftmargin > pparm1 and there are more than pparm2
; more chars to print in the expression
; cmu prefers dv instead of setq
#+cmu
(def pp-value (lambda (i v p)
(terpri $outport$)
(pp-form (list 'dv i v) $outport$)))
#-cmu
(def pp-value (lambda (i v p)
;;(terpr $outport$) ;; pp-form does an initial terpr.
;; we don't need two.
(pp-form `(setq ,i ',v) $outport$)))
(def pp-function (lambda (i v p)
#+cmu (terpri $outport$)
;;
;; add test for traced functions and don't
;; print the trace mess, just the original
;; function. - dhl.
;;
;; this test might belong in the main pp
;; loop but fits in easily here. - dhl
;;
(cond ((and (dtpr v)
(dtpr (cadr v))
(memq (caadr v)
'(T-nargs T-arglist))
(cond ((bcdp (get i 'trace-orig-fcn))
#-cmu
(msg N
"pp: function "
(or i)
" is machine coded (bcd) ")
t)
(t (pp-form
(list 'def i
(get i 'trace-orig-fcn))
$outport$)
t))))
; this function need to return t, but
; pp-form returns nil sometimes.
(t (pp-form (list 'def i v) $outport$)
t))))
(def pp-prop (lambda (i v p)
#+cmu (terpri $outport$)
(pp-form (list 'defprop i v p) $outport$)))
(def condclosefile
(lambda nil
(cond ($fileopen$
(terpr $outport$)
(close $outport$)
(setq $fileopen$ nil)))))
;
; these routines are meant to be used by pp but since
; some people insist on using them we will set $outport$ to nil
; as the default
(setq $outport$ nil)
(defun pp-form (value &optional ($outport$ poport oport-p) (lmar 0))
($prdf value lmar 0))
; this is for compatability with old code, will remove soon -- jkf
(def $prpr (lambda (x) (pp-form x $outport$)))
(declare (special rmar)) ; -DNC this used to be m - I've tried to
; to fix up the pretty printer a bit. It
; used to mess up regularly on (a b .c) types
; of lists. Also printmacros have been added.
(def $prdf
(lambda (l lmar rmar)
(prog nil
;
; - DNC - Here we try to fix the tendency to print a
; thin column down the right margin by allowing it
; to move back to the left if necessary.
;
(cond ((and (>& lmar pparm1) (>& (flatc l (1+ pparm2)) pparm2))
(terpri $outport$)
(patom "; <<<<< start back on the left <<<<<" $outport$)
($prdf l 5 0)
(terpri $outport$)
(patom "; >>>>> continue on the right >>>>>" $outport$)
(terpri $outport$)
(return nil)))
(tab lmar $outport$)
a (cond ((and (dtpr l)
(atom (car l))
(or (and (get (car l) 'printmacro)
(funcall (get (car l) 'printmacro)
l lmar rmar))
(and (get (car l) 'printmacrochar)
(printmacrochar (get (car l) 'printmacrochar)
l lmar rmar))))
(return nil))
;
; -DNC - a printmacro is a lambda (l lmar rmar)
; attached to the atom. If it returns nil then
; we assume it did not apply and we continue.
; Otherwise we assume it did the job.
;
((or (not (dtpr l))
; (*** at the moment we just punt hunks etc)
(and (atom (car l)) (atom (cdr l))))
(return (printret l $outport$)))
((<& (+ rmar (flatc l (charcnt $outport$)))
(charcnt $outport$))
;
; This is just a heuristic - if print can fit it in then figure that
; the printmacros won't hurt. Note that despite the pretentions there
; is no guarantee that everything will fit in before rmar - for example
; atoms (and now even hunks) are just blindly printed. - DNC
;
(printaccross l lmar rmar))
((and ($patom1 lpar)
(atom (car l))
(not (atom (cdr l)))
(not (atom (cddr l))))
(prog (c)
(printret (car l) $outport$)
($patom1 '" ")
(setq c (nwritn $outport$))
a ($prd1 (cdr l) c)
(cond
((not (atom (cdr (setq l (cdr l)))))
(terpr $outport$)
(go a)))))
(t
(prog (c)
(setq c (nwritn $outport$))
a ($prd1 l c)
(cond
((not (atom (setq l (cdr l))))
(terpr $outport$)
(go a))))))
b ($patom1 rpar))))
(def $prd1
(lambda (l n)
(prog nil
($prdf (car l)
n
(cond ((null (setq l (cdr l))) (|1+| rmar))
((atom l) (setq n nil) (plus 4 rmar (pntlen l)))
(t rmar)))
(cond
((null n) ($patom1 '" . ") (return (printret l $outport$))))
; (*** setting n is pretty disgusting)
; (*** the last arg to $prdf is the space needed for the suffix)
; ;Note that this is still not really right - if the prefix
; takes several lines one would like to use the old rmar
; until the last line where the " . mumble)" goes.
)))
; -DNC here's the printmacro for progs - it replaces some hackery that
; used to be in the guts of $prdf.
(def printprog
(lambda (l lmar rmar)
(prog (col)
(cond ((cdr (last l)) (return nil)))
(setq col (add1 lmar))
(princ '|(| $outport$)
(princ (car l) $outport$)
(princ '| | $outport$)
(print (cadr l) $outport$)
(mapc '(lambda (x)
(cond ((atom x)
(tab col $outport$)
(print x $outport$))
(t ($prdf x (+ lmar 6) rmar))))
(cddr l))
(princ '|)| $outport$)
(return t))))
(putprop 'prog 'printprog 'printmacro)
;;
;; simpler version which
;; should look nice for lambda's also.(inside mapcar's) -dhl
;;
(defun print-lambda (l lmar rmar)
(prog (col)
(cond ((cdr (last l)) (return nil)))
(setq col (add1 lmar))
(princ '|(| $outport$)
(princ (car l) $outport$)
(princ '| | $outport$)
(print (cadr l) $outport$)
(let ((c (cond ((eq (car l) 'lambda)
8)
(t 9))))
(mapc '(lambda (x)
($prdf x (+ lmar c) rmar))
(cddr l)))
(princ '|)| $outport$)
(terpr $outport$)
(tab lmar $outport$)
(return t)))
(putprop 'lambda 'print-lambda 'printmacro)
(putprop 'nlambda 'print-lambda 'printmacro)
; Here's the printmacro for def. The original $prdf had some special code
; for lambda and nlambda.
(def printdef
(lambda (l lmar rmar)
(cond ((and (zerop lmar) ; only if we're really printing a defn
(zerop rmar)
(cadr l)
(atom (cadr l))
(dtpr (caddr l))
(null (cdddr l))
(memq (caaddr l) '(lambda nlambda macro lexpr))
(null (cdr (last (caddr l)))))
(princ '|(| $outport$)
(princ 'def $outport$)
(princ '| | $outport$)
(princ (cadr l) $outport$)
(terpri $outport$)
(princ '| (| $outport$)
(princ (caaddr l) $outport$)
(princ '| | $outport$)
(princ (cadaddr l) $outport$)
(terpri $outport$)
(mapc '(lambda (x) ($prdf x 4 0)) (cddaddr l))
(princ '|))| $outport$)
t))))
(putprop 'def 'printdef 'printmacro)
; There's a version of this hacked into the printer (where it don't belong!)
; Note that it must NOT apply to things like (quote a b).
;
; adding printmacrochar so that it can be used by other read macros
; which create things of the form (tag lisp-expr) like quote does,
; I know this is restrictive but it is helpful in the frl source. - dhl.
;
;
(def printmacrochar
(lambda (macrochar l lmar rmar)
(cond ((or (null (cdr l)) (cddr l)) nil)
(t (princ macrochar $outport$)
($prdf (cadr l) (add1 lmar) rmar)
t))))
(putprop 'quote '|'| 'printmacrochar)
(def printaccross
(lambda (l lmar rmar)
(prog nil
; (*** this is needed to make sure the printmacros are executed)
(princ '|(| $outport$)
l: (cond ((null l))
((atom l) (princ '|. | $outport$) (princ l $outport$))
(t ($prdf (car l) (nwritn $outport$) rmar)
(setq l (cdr l))
(cond (l (princ '| | $outport$)))
(go l:))))))