The 'pp' function produces a pretty looking version of the 'expr' and
prints it to the specified 'destination'. If 'expr' is an atom, like a
string, a symbol, a number, etc., 'pp' will print it like
print. If 'expr' is a list, it will perform
indenting. T is always returned
as the result of 'pp'. The 'destination' may be a file pointer or a stream.
If there is no 'destination' or it is
Note: This function is not included in the standard Nyquist distribution. If you want to use it, copy the code to your 'init.lsp' file. The 'pp' code can be found below at the end of this page.
(pp 'a) ; prints A returns T (pp "abcd") ; prints "abcd" returns T (pp '(a (b c))) ; prints (A (B C)) returns T
Common Lisp: In Common Lisp, the 'pp' functionality is provided with the pprint function. The 'pp' function was available in previous XLISP releases and is still accessible. It does allow you to specify the length through 'break-size', which is not available in pprint.
Note: I have never tested this code with Nyquist.
;;; PP.LSP -- a pretty-printer for XLISP.
;;
;; Adapted by Jim Chapman (Bix: jchapman) from a program written originally
;; for IQLISP by Don Cohen. Copyright (c) 1984, Don Cohen; (c) 1987, Jim
;; Chapman. Permission for non-commercial use and distribution is hereby
;; granted. Modified for XLISP 2.0 by David Betz.
;;
;; In addition to the pretty-printer itself, this file contains a few functions
;; that illustrate some simple but useful applications.
;;
;; The basic function accepts two arguments:
;;
;; (PP OBJECT STREAM)
;;
;; where OBJECT is any Lisp expression, and STREAM optionally specifies the
;; output (default is *standard-output*).
;;
;; PP-FILE pretty-prints an entire file. It is what I used to produce this
;; file (before adding the comments manually). The syntax is:
;;
;; (PP-FILE "filename" STREAM)
;;
;; where the file name must be a string or quoted, and STREAM, again, is the
;; optional output destination.
;;
;; PP-DEF works just like PP, except its first argument is assumed to be the
;; name of a function or macro, which is translated back into the original
;; DEFUN or DEFMACRO form before printing.
;;
;;; MISCELLANEOUS USAGE AND CUSTOMIZATION NOTES:
;;
;; 1. The program uses tabs whenever possible for indentation.
;; This greatly reduces the cost of the blank space. If your output
;; device doesn't support tabs, set TABSIZE to NIL -- which is what I
;; did when I pretty-printed this file, because of uncertainty
;; about the result after uploading.
;;
;; 2. Printmacros are used to handle special forms. A printmacro is not
;; really a macro, just an ordinary lambda form that is stored on the
;; target symbol's property list. The default printer handles the form
;; if there is no printmacro or if the printmacro returns NIL.
;;
;; 3. Note that all the pretty-printer subfunctions, including the
;; the printmacros, return the current column position.
;;
;; 4. Miser mode is not fully implemented in this version, mainly because
;; lookahead was too slow. The idea is, if the "normal" way of
;; printing the current expression would exceed the right margin, then
;; use a mode that conserves horizontal space.
;;
;; 5. When PP gets to the last 8th of the line and has more to print than
;; fits on the line, it starts near the left margin. This is not
;; wonderful, but neither are the alternatives. If you have a better
;; idea, go for it.
;;
;; 6. Storage requirements are about 1450 cells to load.
;;
;; 7. I tested this with XLISP 1.7 on an Amiga.
;;
;; 8. TAA modified to support prettyprinting arrays. Fixed bug printing
;; (NIL ...).
;;
;; 9. TAA modified to support prettyprinting of structures, and some code
;; cleanup. Also added PP-PAIR-FORM to handle setq like structures
;; more nicely.
;;
;; 10. TAA: It should be noted that you can't pretty print circular lists,
;; nor can you successfully read back the following:
;; * uninterned symbols, for instance those generated with gensym
;; as part of automatically generated code
;; * closures, since their environment cannot be reconstructed. These
;; are not even expanded.
;; * subrs, fsubrs, and streams cannot be represented
;;
;; 11. TAA modified so that non-class objects are shown by sending the
;; message :storeon (see classes.lsp), printing #. before the expression
;; making it an object literal.
;;
;; 12. TAA modified so that *print-level* and *print-length* are bound to NIL
;; during the course of execution.
#+:packages
(unless (find-package "TOOLS")
(make-package "TOOLS" :use '("XLISP")))
(in-package "TOOLS")
; Part of modified classes.lsp. Repeated here in case classes.lsp not used
#+:packages (shadow 'classp)
(defun classp (name)
(when (objectp name)
(eq (send name :class) class)))
(export '(tabsize maxsize miser-size pp-file pp-def pp))
;(DEFUN SYM-FUNCTION (X) ;for Xlisp 1.7
; (CAR (SYMBOL-VALUE X)))
(defun sym-function (x) ;for Xlisp 2.0
(get-lambda-expression (symbol-function x)))
(defvar tabsize 8) ;set this to NIL for no tabs
(defvar maxsize 60) ;for readability, PP tries not to print more
;than this many characters on a line
(defvar miser-size 2) ;the indentation in miser mode
(defvar min-miser-car 4) ;used for deciding when to use miser mode
(defvar max-normal-car 9) ;ditto
(defconstant pp-lpar "(") ; self evident
(defconstant pp-rpar ")")
(defconstant pp-space " ")
(defconstant pp-immed "#.")
;; The following function prints a file
(defun pp-file (filename &optional streamout)
(or streamout (setq streamout *standard-output*))
(princ "; Listing of " streamout)
(princ filename streamout)
(terpri streamout)
(terpri streamout)
(do* ((fp (open filename)) (expr (read fp nil) (read fp nil)))
((null expr) (close fp))
(pp expr streamout)
(terpri streamout)))
;; Print a lambda or macro form as a DEFUN or DEFMACRO:
(defmacro pp-def (who &optional stream)
`(pp (make-def ,who) ,stream))
(defmacro make-def (name &aux expr type)
(setq expr (sym-function name))
(setq type
(cadr (assoc (car expr)
'((lambda defun) (macro defmacro)))))
(list 'quote
(append (list type name) (cdr expr))))
;; The pretty-printer high level function:
(defun pp (x &optional stream)
(let (*print-level* *print-length*) ; set special vars to NIL
(or stream (setq stream *standard-output*))
(pp1 x stream 1 80)
(terpri stream)
t))
;; print X on STREAM, current cursor is CURPOS, and right margin is RMARGIN
(defun pp1 (x stream curpos rmargin
&aux (anarray (arrayp x))
(astruct (typep x '(and struct (not random-state))))
size position width)
(cond (anarray (setq x (coerce x 'cons)))
((and (objectp x) (not (classp x)))
(princ pp-immed stream) ; immediate execute literal
(setq curpos (+ curpos 2))
(setq x (send x :storeon))))
(cond (astruct (pp-astruct x stream curpos rmargin))
((not (consp x))(prin1 x stream) (+ curpos (flatsize x)))
((printmacrop x stream curpos rmargin))
((and (> (flatsize x) (- rmargin curpos))
(< (* 8 (- rmargin curpos)) rmargin))
(setq size (+ (/ rmargin 8) (- curpos rmargin)))
(pp-moveto stream curpos size)
(setq position (pp1 x stream size rmargin))
(pp-moveto stream position size))
(t (when anarray (princ "#" stream) (setq curpos (1+ curpos)))
(princ pp-lpar stream)
(setq position
(pp1 (car x) stream (1+ curpos) rmargin))
(cond ((and (>= (setq width (- rmargin position))
(setq size (flatsize (cdr x))))
(<= size maxsize))
(pp-rest-across (cdr x) stream position rmargin))
((consp (car x))
(pp-moveto stream position curpos)
(pp-rest (cdr x) stream curpos rmargin))
((> (- position curpos) max-normal-car)
(pp-moveto stream position (+ curpos miser-size))
(pp-rest (cdr x) stream (+ curpos miser-size) rmargin))
(t (pp-rest (cdr x) stream position rmargin))))))
;; PP-MOVETO controls indentating and tabbing.
;; If CUR > GOAL then goes to new line first.
;; will space to GOAL
(defun pp-moveto (stream curpos goalpos &aux i)
(cond ((> curpos goalpos)
(terpri stream)
(setq curpos 1)
(if tabsize
(do nil
((< (- goalpos curpos) tabsize))
(princ "\t" stream)
(setq curpos (+ curpos tabsize))))))
(dotimes (i (- goalpos curpos)) (princ pp-space stream))
goalpos)
;; can print the rest of the list without new lines
(defun pp-rest-across (x stream curpos rmargin &aux position)
(setq position curpos)
(prog nil
lp
(cond ((null x) (princ pp-rpar stream) (return (1+ position)))
((not (consp x))
(princ " . " stream)
(prin1 x stream)
(princ pp-rpar stream)
(return (+ 4 position (flatsize x))))
(t (princ pp-space stream)
(setq position
(pp1 (car x) stream (1+ position) rmargin))
(setq x (cdr x))
(go lp)))))
;; Can print the rest of the list, but must use new lines for each element
(defun pp-rest (x stream curpos rmargin &aux position pos2)
(setq position curpos)
(prog nil
lp
(cond ((null x) (princ pp-rpar stream) (return (1+ position)))
((not (consp x))
(and (> (flatsize x) (- (- rmargin position) 3))
(setq position (pp-moveto stream position curpos)))
(princ " . " stream)
(prin1 x stream)
(princ pp-rpar stream)
(return (+ position 4 (flatsize x))))
((and
(not (typep (car x) '(or list array struct)))
(<= (setq pos2 (+ 1 position (flatsize (car x))))
rmargin)
(<= pos2 (+ curpos maxsize)))
(princ pp-space stream)
(prin1 (car x) stream)
(setq position pos2))
(t (pp-moveto stream position (1+ curpos))
(setq position
(pp1 (car x) stream (1+ curpos) rmargin))))
(cond ((and (consp (car x)) (cdr x))
(setq position (pp-moveto stream position curpos))))
(setq x (cdr x))
(go lp)))
;; Handles structures by printing in form:
;; #S(structtype :slot val
;; ...
;; :slot val)
;;
;; code does not check for defaults.
(defun pp-astruct (x stream pos rmar &aux cur snames args)
(setq cur pos
snames (mapcar #'car (get (type-of x) '*struct-slots*))
args
(mapcan #'(lambda (p)
(list p
(apply
(intern
(strcat (string (type-of x))
"-"
(string p)))
(list x))))
snames))
(princ "#s" stream)
(if (and (>= (- rmar pos) (+ 2 (flatsize x)))
(<= (flatsize x) maxsize))
(pp1 (cons (type-of x) args) stream (+ 2 pos) rmar)
(prog ()
(princ pp-lpar stream)
(prin1 (type-of x) stream)
(princ pp-space stream)
(setq pos (setq cur (+ pos 4 (flatsize (type-of x)))))
lp
(prin1 (first args) stream)
(princ pp-space stream)
(setq cur
(pp1 (second args)
stream
(+ pos 1 (flatsize (first args)))
rmar))
(setq args (cddr args))
(when (null args)
(princ pp-rpar stream)
(return-from pp-astruct (1+ cur)))
(pp-moveto stream cur pos)
(go lp))))
;; PRINTMACROP is the printmacro interface routine. Note that the
;; called function has the same argument list as PP1. It may either
;; decide not to handle the form, by returning NIL (and not printing)
;; or it may print the form and return the resulting position.
(defun printmacrop (x stream curpos rmargin &aux macro)
(and (symbolp (car x))
(car x) ; must not be NIL (TAA fix)
(setq macro (get (car x) 'printmacro))
(apply macro (list x stream curpos rmargin))))
;;; The remaining forms define various printmacros.
;;
;; Printing format (xxx xxx
;; <pp-rest>)
(defun pp-binding-form (x stream pos rmar &aux cur)
(setq cur pos)
(cond ((and (>= (- rmar pos) (flatsize x))
(<= (flatsize x) maxsize)) nil)
((> (length x) 2)
(princ pp-lpar stream)
(prin1 (car x) stream)
(princ pp-space stream)
(setq cur
(pp1 (cadr x)
stream
(+ 2 pos (flatsize (car x)))
rmar))
(pp-moveto stream cur (+ pos 1))
(pp-rest (cddr x) stream (+ pos 1) rmar))))
;; Format (xxxx xxx xxx
;; ...
;; xxx xxx)
(defun pp-pair-form (x stream pos rmar &aux cur)
(setq cur pos)
(cond ((and (>= (- rmar pos) (flatsize x))
(<= (flatsize x) maxsize)) nil)
((> (length x) 1)
(princ pp-lpar stream)
(prin1 (first x) stream)
(princ pp-space stream)
(setq pos (setq cur (+ pos 2 (flatsize (first x)))))
(setq x (rest x))
(loop
(pp-moveto stream cur pos)
(setq cur (pp1 (first x) stream pos rmar))
(princ pp-space stream)
(setq x (rest x))
(setq cur (pp1 (first x) stream (1+ cur) rmar))
(when (null (setq x (rest x)))
(princ pp-rpar stream)
(return-from pp-pair-form (1+ cur)))))))
;; format (xxx xxx
;; xxx
;; <pprest>)
(defun pp-do-form (x stream pos rmar &aux cur pos2)
(setq cur pos)
(cond ((and (>= (- rmar pos) (flatsize x))
(<= (flatsize x) maxsize)) nil)
((> (length x) 2)
(princ pp-lpar stream)
(prin1 (car x) stream)
(princ pp-space stream)
(setq pos2 (+ 2 pos (flatsize (car x))))
(setq cur (pp1 (cadr x) stream pos2 rmar))
(pp-moveto stream cur pos2)
(setq cur (pp1 (caddr x) stream pos2 rmar))
(pp-moveto stream cur (+ pos 1))
(pp-rest (cdddr x) stream (+ pos 1) rmar))))
;; format (xxx xxx xxx
;; <pprest>)
(defun pp-defining-form (x stream pos rmar &aux cur)
(setq cur pos)
(cond ((and (>= (- rmar pos) (flatsize x))
(<= (flatsize x) maxsize)) nil)
((> (length x) 3)
(princ pp-lpar stream)
(prin1 (car x) stream)
(princ pp-space stream)
(prin1 (cadr x) stream)
(princ pp-space stream)
(setq cur
(pp1 (caddr x)
stream
(+ 3 pos (flatsize (car x)) (flatsize (cadr x)))
rmar))
(pp-moveto stream cur (+ 3 pos))
(pp-rest (cdddr x) stream (+ 3 pos) rmar))))
(putprop 'quote
'(lambda (x stream pos rmargin)
(cond ((and (cdr x) (null (cddr x)))
(princ "'" stream)
(pp1 (cadr x) stream (1+ pos) rmargin))))
'printmacro)
(putprop 'backquote
'(lambda (x stream pos rmargin)
(cond ((and (cdr x) (null (cddr x)))
(princ "`" stream)
(pp1 (cadr x) stream (1+ pos) rmargin))))
'printmacro)
(putprop 'comma
'(lambda (x stream pos rmargin)
(cond ((and (cdr x) (null (cddr x)))
(princ "," stream)
(pp1 (cadr x) stream (1+ pos) rmargin))))
'printmacro)
(putprop 'comma-at
'(lambda (x stream pos rmargin)
(cond ((and (cdr x) (null (cddr x)))
(princ ",@" stream)
(pp1 (cadr x) stream (+ pos 2) rmargin))))
'printmacro)
(putprop 'function
'(lambda (x stream pos rmargin)
(cond ((and (cdr x) (null (cddr x)))
(princ "#'" stream)
(pp1 (cadr x) stream (+ pos 2) rmargin))))
'printmacro)
(putprop 'prog
'pp-binding-form
'printmacro)
(putprop 'prog*
'pp-binding-form
'printmacro)
(putprop 'let
'pp-binding-form
'printmacro)
(putprop 'let*
'pp-binding-form
'printmacro)
(putprop 'lambda
'pp-binding-form
'printmacro)
(putprop 'macro
'pp-binding-form
'printmacro)
(putprop 'do 'pp-do-form 'printmacro)
(putprop 'do*
'pp-do-form
'printmacro)
(putprop 'defun
'pp-defining-form
'printmacro)
(putprop 'defmacro
'pp-defining-form
'printmacro)
(putprop 'setq
'pp-pair-form
'printmacro)
(putprop 'setf
'pp-pair-form
'printmacro)
(putprop 'psetq
'pp-pair-form
'printmacro)
(putprop 'send
'pp-defining-form
'printmacro)