; 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.
; 11. 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")
(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)
syntax highlighted by Code2HTML, v. 0.9.1