+(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)))))
+\f
+;
+; 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$)))
+
+
+\f
+(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:))))))
+
projects / unix-history / commitdiff