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)))))
\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:))))))