home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast2.iso / xlisp / xl21freq.zip / PP.LSP < prev    next >
Lisp/Scheme  |  1993-12-17  |  16KB  |  495 lines
  1. ; PP.LSP -- a pretty-printer for XLISP.
  2.  
  3. ; Adapted by Jim Chapman (Bix: jchapman) from a program written originally
  4. ; for IQLISP by Don Cohen.  Copyright (c) 1984, Don Cohen; (c) 1987, Jim
  5. ; Chapman.  Permission for non-commercial use and distribution is hereby 
  6. ; granted.  Modified for XLISP 2.0 by David Betz.
  7.  
  8. ; In addition to the pretty-printer itself, this file contains a few functions
  9. ; that illustrate some simple but useful applications.
  10.  
  11. ; The basic function accepts two arguments:
  12.  
  13. ;      (PP OBJECT STREAM)
  14.  
  15. ; where OBJECT is any Lisp expression, and STREAM optionally specifies the
  16. ; output (default is *standard-output*).
  17.  
  18. ; PP-FILE pretty-prints an entire file.  It is what I used to produce this
  19. ; file (before adding the comments manually).  The syntax is:
  20.  
  21. ;       (PP-FILE "filename" STREAM)
  22.  
  23. ; where the file name must be a string or quoted, and STREAM, again, is the
  24. ; optional output destination.
  25.  
  26. ; PP-DEF works just like PP, except its first argument is assumed to be the
  27. ; name of a function or macro, which is translated back into the original
  28. ; DEFUN or DEFMACRO form before printing.
  29.  
  30.  
  31. ; MISCELLANEOUS USAGE AND CUSTOMIZATION NOTES:
  32.  
  33. ; 1.  The program uses tabs whenever possible for indentation.
  34. ;     This greatly reduces the cost of the blank space.  If your output
  35. ;     device doesn't support tabs, set TABSIZE to NIL -- which is what I
  36. ;     did when I pretty-printed this file, because of uncertainty 
  37. ;     about the result after uploading.
  38.  
  39. ; 2.  Printmacros are used to handle special forms.  A printmacro is not
  40. ;     really a macro, just an ordinary lambda form that is stored on the
  41. ;     target symbol's property list.  The default printer handles the form
  42. ;     if there is no printmacro or if the printmacro returns NIL.
  43.  
  44. ; 3.  Note that all the pretty-printer subfunctions, including the
  45. ;     the printmacros, return the current column position.
  46.  
  47. ; 4.  Miser mode is not fully implemented in this version, mainly because  
  48. ;     lookahead was too slow.  The idea is, if the "normal" way of
  49. ;     printing the current expression would exceed the right margin, then
  50. ;     use a mode that conserves horizontal space.
  51.  
  52. ; 5.  When PP gets to the last 8th of the line and has more to print than
  53. ;     fits on the line, it starts near the left margin.  This is not 
  54. ;     wonderful, but neither are the alternatives.  If you have a better
  55. ;     idea, go for it.
  56.  
  57. ;  6. Storage requirements are about 1450 cells to load.  
  58.  
  59. ;  7. I tested this with XLISP 1.7 on an Amiga.
  60.  
  61. ;  8. TAA modified to support prettyprinting arrays.  Fixed bug printing
  62. ;     (NIL ...).
  63.  
  64. ;  9. TAA modified to support prettyprinting of structures, and some code
  65. ;     cleanup. Also added PP-PAIR-FORM to handle setq like structures
  66. ;     more nicely. 
  67.  
  68. ; 10. TAA: It should be noted that you can't pretty print circular lists,
  69. ;     nor can you successfully read back the following:
  70. ;    * uninterned symbols, for instance those generated with gensym
  71. ;         as part of automatically generated code
  72. ;       * closures, since their environment cannot be reconstructed. These
  73. ;         are not even expanded.
  74. ;       * subrs, fsubrs, and streams cannot be represented
  75.  
  76. ; 11. TAA modified so that non-class objects are shown by sending the
  77. ;    message :storeon (see classes.lsp), printing #. before the expression
  78. ;    making it an object literal.
  79.  
  80. ; 11. TAA modified so that *print-level* and *print-length* are bound to  NIL
  81. ;    during the course of execution.
  82.  
  83. #+:packages
  84. (unless (find-package "TOOLS")
  85.     (make-package "TOOLS" :use '("XLISP")))
  86.  
  87. (in-package "TOOLS")
  88.  
  89. ; Part of modified classes.lsp. Repeated here in case classes.lsp not used
  90. #+:packages (shadow 'classp)
  91. (defun classp (name)
  92.        (when (objectp name)
  93.          (eq (send name :class) class)))
  94.  
  95. (export '(tabsize maxsize miser-size pp-file pp-def pp))
  96.  
  97. ;(DEFUN SYM-FUNCTION (X)    ;for Xlisp 1.7
  98. ;    (CAR (SYMBOL-VALUE X)))
  99. (defun sym-function (x)        ;for Xlisp 2.0
  100.     (get-lambda-expression (symbol-function x)))
  101.  
  102. (defvar tabsize 8)    ;set this to NIL for no tabs
  103.  
  104. (defvar maxsize 60)    ;for readability, PP tries not to print more
  105.             ;than this many characters on a line
  106.  
  107. (defvar miser-size 2)    ;the indentation in miser mode
  108.  
  109. (defvar min-miser-car 4)    ;used for deciding when to use miser mode
  110.  
  111. (defvar max-normal-car 9)    ;ditto
  112.  
  113. (defconstant pp-lpar "(")    ; self evident
  114. (defconstant pp-rpar ")")
  115. (defconstant pp-space " ")
  116. (defconstant pp-immed "#.")
  117.  
  118. ; The following function prints a file
  119.  
  120. (defun pp-file (filename &optional streamout)
  121.     (or streamout (setq streamout *standard-output*))
  122.     (princ "; Listing of " streamout)
  123.     (princ filename streamout)
  124.     (terpri streamout)
  125.     (terpri streamout)
  126.     (do* ((fp (open filename)) (expr (read fp) (read fp)))
  127.          ((null expr) (close fp))
  128.       (pp expr streamout)
  129.       (terpri streamout)))
  130.  
  131.  
  132. ; Print a lambda or macro form as a DEFUN or DEFMACRO:
  133.  
  134. (defmacro pp-def (who &optional stream)
  135.     `(pp (make-def ,who) ,stream))
  136.  
  137. (defmacro make-def (name &aux expr type)
  138.     (setq expr (sym-function name))
  139.     (setq type
  140.           (cadr (assoc (car expr)
  141.                        '((lambda defun) (macro defmacro)))))
  142.     (list 'quote
  143.           (append (list type name) (cdr expr))))
  144.  
  145.  
  146.  
  147. ; The pretty-printer high level function:
  148.  
  149.  
  150. (defun pp (x &optional stream)
  151.        (let (*print-level* *print-length*)    ; set special vars to NIL
  152.         (or stream (setq stream *standard-output*))
  153.         (pp1 x stream 1 80)
  154.         (terpri stream)
  155.         t))
  156.  
  157. ; print X on STREAM, current cursor is CURPOS, and right margin is RMARGIN
  158.  
  159. (defun pp1 (x stream curpos rmargin 
  160.           &aux (anarray (arrayp x))
  161.            (astruct (typep x '(and struct (not random-state))))
  162.            size position width)
  163.     (cond (anarray (setq x (coerce x 'cons)))
  164.       ((and (objectp x) (not (classp x)))
  165.        (princ pp-immed stream)        ; immediate execute literal
  166.        (setq curpos (+ curpos 2))
  167.        (setq x (send x :storeon))))
  168.     (cond (astruct (pp-astruct x stream curpos rmargin))
  169.       ((not (consp x))(prin1 x stream) (+ curpos (flatsize x)))
  170.           ((printmacrop x stream curpos rmargin))
  171.           ((and (> (flatsize x) (- rmargin curpos))
  172.                 (< (* 8 (- rmargin curpos)) rmargin))
  173.            (setq size (+ (/ rmargin 8) (- curpos rmargin)))
  174.            (pp-moveto stream curpos size)
  175.            (setq position (pp1 x stream size rmargin))
  176.            (pp-moveto stream position size))
  177.           (t (when anarray (princ "#" stream) (setq curpos (1+ curpos)))
  178.          (princ pp-lpar stream)
  179.              (setq position
  180.                    (pp1 (car x) stream (1+ curpos) rmargin))
  181.              (cond ((and (>= (setq width (- rmargin position))
  182.                              (setq size (flatsize (cdr x))))
  183.                          (<= size maxsize))
  184.                     (pp-rest-across (cdr x) stream position rmargin))
  185.                    ((consp (car x))
  186.                     (pp-moveto stream position curpos)
  187.                     (pp-rest (cdr x) stream curpos rmargin))
  188.                    ((> (- position curpos) max-normal-car)
  189.                     (pp-moveto stream position (+ curpos miser-size))
  190.                     (pp-rest (cdr x) stream (+ curpos miser-size) rmargin))
  191.                    (t (pp-rest (cdr x) stream position rmargin))))))
  192.  
  193. ; PP-MOVETO controls indentating and tabbing.
  194. ; If CUR > GOAL then goes to new line first.
  195. ; will space to GOAL
  196.  
  197. (defun pp-moveto (stream curpos goalpos &aux i)
  198.     (cond ((> curpos goalpos)
  199.            (terpri stream)
  200.            (setq curpos 1)
  201.            (if tabsize
  202.                (do nil
  203.                    ((< (- goalpos curpos) tabsize))
  204.                  (princ "\t" stream)
  205.                  (setq curpos (+ curpos tabsize))))))
  206.     (dotimes (i (- goalpos curpos)) (princ pp-space stream))
  207.     goalpos)
  208.  
  209. ; can print the rest of the list without new lines
  210.  
  211. (defun pp-rest-across (x stream curpos rmargin &aux position)
  212.     (setq position curpos)
  213.     (prog nil
  214.       lp
  215.       (cond ((null x) (princ pp-rpar stream) (return (1+ position)))
  216.             ((not (consp x))
  217.              (princ " . " stream)
  218.              (prin1 x stream)
  219.              (princ pp-rpar stream)
  220.              (return (+ 4 position (flatsize x))))
  221.             (t (princ pp-space stream)
  222.                (setq position
  223.                      (pp1 (car x) stream (1+ position) rmargin))
  224.                (setq x (cdr x))
  225.                (go lp)))))
  226.  
  227. ; Can print the rest of the list, but must use new lines for each element
  228.  
  229.  
  230. (defun pp-rest (x stream curpos rmargin &aux position pos2)
  231.     (setq position curpos)
  232.     (prog nil
  233.       lp
  234.       (cond ((null x) (princ pp-rpar stream) (return (1+ position)))
  235.             ((not (consp x))
  236.              (and (> (flatsize x) (- (- rmargin position) 3))
  237.                   (setq position (pp-moveto stream position curpos)))
  238.              (princ " . " stream)
  239.              (prin1 x stream)
  240.              (princ pp-rpar stream)
  241.              (return (+ position 4 (flatsize x))))
  242.             ((and 
  243.           (not (typep (car x) '(or list array struct)))
  244.                   (<= (setq pos2 (+ 1 position (flatsize (car x))))
  245.                       rmargin)
  246.                   (<= pos2 (+ curpos maxsize)))
  247.              (princ pp-space stream)
  248.              (prin1 (car x) stream)
  249.              (setq position pos2))
  250.             (t (pp-moveto stream position (1+ curpos))
  251.                (setq position
  252.                      (pp1 (car x) stream (1+ curpos) rmargin))))
  253.       (cond ((and (consp (car x)) (cdr x))
  254.              (setq position (pp-moveto stream position curpos))))
  255.       (setq x (cdr x))
  256.       (go lp)))
  257.  
  258.  
  259. ; Handles structures by printing in form:
  260. ;    #S(structtype :slot val
  261. ; ...
  262. ;              :slot val)
  263. ;
  264. ; code does not check for defaults.
  265.  
  266. (defun pp-astruct (x stream pos rmar &aux cur snames args)
  267.        (setq cur pos
  268.          snames (mapcar #'car (get (type-of x) '*struct-slots*))
  269.          args 
  270.          (mapcan #'(lambda (p) 
  271.                    (list p
  272.                      (apply
  273.                       (intern
  274.                        (strcat (string (type-of x)) 
  275.                            "-" 
  276.                            (string p)))
  277.                       (list x))))
  278.              snames))
  279.        (princ "#s" stream)
  280.        (if (and (>= (- rmar pos) (+ 2 (flatsize x)))
  281.         (<= (flatsize x) maxsize))
  282.        (pp1 (cons (type-of x) args) stream (+ 2 pos) rmar)
  283.        (prog ()
  284.          (princ pp-lpar stream)
  285.          (prin1 (type-of x) stream)
  286.          (princ pp-space stream)
  287.          (setq pos (setq cur (+ pos 4 (flatsize (type-of x)))))
  288.          lp
  289.          (prin1 (first args) stream)
  290.          (princ pp-space stream)
  291.          (setq cur
  292.                (pp1 (second args)
  293.                 stream
  294.                 (+ pos 1 (flatsize (first args)))
  295.                 rmar))
  296.          (setq args (cddr args))
  297.          (when (null args)
  298.                (princ pp-rpar stream)
  299.                (return-from pp-astruct (1+ cur)))
  300.          (pp-moveto stream cur pos)
  301.          (go lp))))
  302.  
  303.          
  304. ; PRINTMACROP is the printmacro interface routine.  Note that the
  305. ; called function has the same argument list as PP1.  It may either
  306. ; decide not to handle the form, by returning NIL (and not printing)
  307. ; or it may print the form and return the resulting position.
  308.  
  309. (defun printmacrop (x stream curpos rmargin &aux macro)
  310.     (and (symbolp (car x))
  311.      (car x)    ; must not be NIL (TAA fix)
  312.          (setq macro (get (car x) 'printmacro))
  313.          (apply macro (list x stream curpos rmargin))))
  314.  
  315. ; The remaining forms define various printmacros.
  316.  
  317.  
  318. ; Printing format (xxx xxx
  319. ;               <pp-rest>)
  320.  
  321.  
  322. (defun pp-binding-form (x stream pos rmar &aux cur)
  323.     (setq cur pos)
  324.     (cond ((and (>= (- rmar pos) (flatsize x))
  325.                 (<= (flatsize x) maxsize)) nil)
  326.           ((> (length x) 2)
  327.            (princ pp-lpar stream)
  328.            (prin1 (car x) stream)
  329.            (princ pp-space stream)
  330.            (setq cur
  331.                  (pp1 (cadr x)
  332.                       stream
  333.                       (+ 2 pos (flatsize (car x)))
  334.                       rmar))
  335.            (pp-moveto stream cur (+ pos 1))
  336.            (pp-rest (cddr x) stream (+ pos 1) rmar))))
  337.  
  338. ; Format (xxxx xxx xxx
  339. ;...
  340. ;           xxx xxx)
  341.  
  342. (defun pp-pair-form (x stream pos rmar &aux cur)
  343.     (setq cur pos)
  344.     (cond ((and (>= (- rmar pos) (flatsize x))
  345.                 (<= (flatsize x) maxsize)) nil)
  346.           ((> (length x) 1)
  347.            (princ pp-lpar stream)
  348.            (prin1 (first x) stream)
  349.            (princ pp-space stream)
  350.        (setq pos (setq cur (+ pos 2 (flatsize (first x)))))
  351.        (setq x (rest x))
  352.        (loop
  353.         (pp-moveto stream cur pos)
  354.         (setq cur (pp1 (first x) stream pos rmar))
  355.         (princ pp-space stream)
  356.         (setq x (rest x))
  357.         (setq cur (pp1 (first x) stream (1+ cur) rmar))
  358.         (when (null (setq x (rest x)))
  359.           (princ pp-rpar stream)
  360.           (return-from pp-pair-form (1+ cur)))))))
  361.  
  362. ; format (xxx xxx
  363. ;          xxx
  364. ;        <pprest>)
  365.  
  366.        
  367. (defun pp-do-form (x stream pos rmar &aux cur pos2)
  368.     (setq cur pos)
  369.     (cond ((and (>= (- rmar pos) (flatsize x))
  370.                 (<= (flatsize x) maxsize)) nil)
  371.           ((> (length x) 2)
  372.            (princ pp-lpar stream)
  373.            (prin1 (car x) stream)
  374.            (princ pp-space stream)
  375.            (setq pos2 (+ 2 pos (flatsize (car x))))
  376.            (setq cur (pp1 (cadr x) stream pos2 rmar))
  377.            (pp-moveto stream cur pos2)
  378.            (setq cur (pp1 (caddr x) stream pos2 rmar))
  379.            (pp-moveto stream cur (+ pos 1))
  380.            (pp-rest (cdddr x) stream (+ pos 1) rmar))))
  381.  
  382. ; format (xxx xxx xxx
  383. ;       <pprest>)
  384.  
  385. (defun pp-defining-form (x stream pos rmar &aux cur)
  386.     (setq cur pos)
  387.     (cond ((and (>= (- rmar pos) (flatsize x))
  388.                 (<= (flatsize x) maxsize)) nil)
  389.           ((> (length x) 3)
  390.            (princ pp-lpar stream)
  391.            (prin1 (car x) stream)
  392.            (princ pp-space stream)
  393.            (prin1 (cadr x) stream)
  394.            (princ pp-space stream)
  395.            (setq cur
  396.                  (pp1 (caddr x)
  397.                       stream
  398.                       (+ 3 pos (flatsize (car x)) (flatsize (cadr x)))
  399.                       rmar))
  400.            (pp-moveto stream cur (+ 3 pos))
  401.            (pp-rest (cdddr x) stream (+ 3 pos) rmar))))
  402.  
  403. (putprop 'quote
  404.          '(lambda (x stream pos rmargin)
  405.             (cond ((and (cdr x) (null (cddr x)))
  406.                    (princ "'" stream)
  407.                    (pp1 (cadr x) stream (1+ pos) rmargin))))
  408.          'printmacro)
  409.  
  410. (putprop 'backquote
  411.          '(lambda (x stream pos rmargin)
  412.             (cond ((and (cdr x) (null (cddr x)))
  413.                    (princ "`" stream)
  414.                    (pp1 (cadr x) stream (1+ pos) rmargin))))
  415.          'printmacro)
  416.  
  417. (putprop 'comma
  418.          '(lambda (x stream pos rmargin)
  419.             (cond ((and (cdr x) (null (cddr x)))
  420.                    (princ "," stream)
  421.                    (pp1 (cadr x) stream (1+ pos) rmargin))))
  422.          'printmacro)
  423.  
  424. (putprop 'comma-at
  425.          '(lambda (x stream pos rmargin)
  426.             (cond ((and (cdr x) (null (cddr x)))
  427.                    (princ ",@" stream)
  428.                    (pp1 (cadr x) stream (+ pos 2) rmargin))))
  429.          'printmacro)
  430.  
  431. (putprop 'function
  432.          '(lambda (x stream pos rmargin)
  433.             (cond ((and (cdr x) (null (cddr x)))
  434.                    (princ "#'" stream)
  435.                    (pp1 (cadr x) stream (+ pos 2) rmargin))))
  436.          'printmacro)
  437.  
  438. (putprop 'prog
  439.          'pp-binding-form
  440.          'printmacro)
  441.  
  442. (putprop 'prog*
  443.          'pp-binding-form
  444.          'printmacro)
  445.  
  446. (putprop 'let
  447.          'pp-binding-form
  448.          'printmacro)
  449.  
  450. (putprop 'let*
  451.          'pp-binding-form
  452.          'printmacro)
  453.  
  454. (putprop 'lambda
  455.          'pp-binding-form
  456.          'printmacro)
  457.  
  458. (putprop 'macro
  459.          'pp-binding-form
  460.          'printmacro)
  461.  
  462. (putprop 'do 'pp-do-form 'printmacro)
  463.  
  464. (putprop 'do*
  465.          'pp-do-form
  466.          'printmacro)
  467.  
  468. (putprop 'defun
  469.          'pp-defining-form
  470.          'printmacro)
  471.  
  472. (putprop 'defmacro
  473.          'pp-defining-form
  474.          'printmacro)
  475.  
  476.  
  477. (putprop 'setq
  478.      'pp-pair-form
  479.      'printmacro)
  480.  
  481. (putprop 'setf
  482.      'pp-pair-form
  483.      'printmacro)
  484.  
  485. (putprop 'psetq
  486.      'pp-pair-form
  487.      'printmacro)
  488.  
  489.  
  490. (putprop 'send
  491.      'pp-defining-form
  492.      'printmacro)
  493.  
  494.  
  495.