home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / pp.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  20.6 KB  |  569 lines
  1. ;; pretty-printer by mf
  2. ;*************************************************************
  3. (define *pp:port* #t)   ; default value = current output
  4. (define *pp:lgth* 80)   ; default value = max length of a line
  5.  
  6. (define (pp obj . options)
  7.   ; obj = file name in a string or
  8.   ;       expression to be pretty printed
  9.   ; options = toutes facultatives
  10.   ; destination = file name in a string
  11.   ;               #t ==> current output (default value)
  12.   ;               #f ==> a string
  13.   ; line-length = integer >= 0 = max length of a line on output
  14.   ;               (default value = 80)
  15.   (let ((dest 'output))
  16.     (set! *pp:port* #t)
  17.     (set! *pp:lgth* 80)
  18.     (let loop ((L options))
  19.       (when (not (null? L))
  20.             ; there is options....
  21.             (cond ((string? (car L)) ; output in a file
  22.                    (set! *pp:port* (open-output-file (car L)))
  23.                    (set! dest 'file))
  24.                   ((integer? (car L))
  25.                    (set! *pp:lgth* (car L)))
  26.                   ((boolean? (car L)) ; current output or a string
  27.                    (when (not (car L))
  28.                          (set! *pp:port* (open-output-string))
  29.                          (set! dest 'string))))
  30.             (loop (cdr L))))
  31.  
  32.     (if (string? obj)     ; file name
  33.         (let* ((p (open-input-file obj))
  34.               (to-pp (read p)))
  35.           (while (not (eof-object? to-pp))
  36.                  (*pp:pp-one-exp* to-pp)
  37.                  (format *pp:port* "~%")
  38.                  (set! to-pp (read p))))
  39.         (*pp:pp-one-exp* obj))
  40.     (cond ((eq? dest 'file) (close-output-port *pp:port*))
  41.           ((eq? dest 'string) (get-output-string *pp:port*)))))
  42.  
  43. ;*************************************************************
  44. ;    pretty-print an expression
  45. ;*************************************************************
  46.  
  47. (define *pp:cur-pos* 0)   ; current position in line
  48.  
  49. (define *pp:line* 1)      ; current line
  50.  
  51. (define *pp:lgth-symb* 0) ; lgth of symb to write
  52.  
  53. (define *printer-list* '(()))
  54.  
  55. (define *pp:last-symb-is-new-line* #t)
  56.  
  57. (define *pp:to-substitute* #t)
  58.  
  59. (define *pp:last* 0)  ; for *pp:fit?*
  60.  
  61. (define (*pp:pp-one-exp* expr)
  62.   (set! *pp:cur-pos* 0)   ; current position in line
  63.   (set! *pp:line* 1)      ; current line
  64.   (set! *pp:lgth-symb* 0) ; lgth of symb to write
  65.   (set! *pp:last-symb-is-new-line* #t)
  66.   (set! *pp:to-substitute* #t)
  67.   (set! *pp:last* 0)  ; for *pp:fit?*
  68.   (let ((expr (if (procedure? expr) (procedure-body expr)
  69.                   expr)))
  70.     (*pp:print-expr* expr *pp:cur-pos*)
  71.     (format *pp:port* "~%")
  72.     #t))
  73.  
  74.  
  75. (define (*pp:out-char* c)        ; output the char c NOT at end of line
  76.   ; c = left parenthesis|quote|quasiquote|unquote|unquote-splicing
  77.   (format *pp:port* "~A" c)
  78.   (set! *pp:last-symb-is-new-line* #t)
  79.   (set! *pp:cur-pos* (+ *pp:cur-pos* 1)))
  80.  
  81. (define (*pp:left-par*) ; output a left parenthesis
  82.   (*pp:out-char* #\( ))
  83.  
  84. (define (*pp:out-char-eol* c)     ; output the char c perhaps at end of line
  85.   ; c = right parenthesis|space|period
  86.   (format *pp:port* "~A" c)
  87.   (set! *pp:last-symb-is-new-line* #f)
  88.   (set! *pp:cur-pos* (+ *pp:cur-pos* 1)))
  89.  
  90. (define (*pp:right-par*) ; output a right parenthesis
  91.   (*pp:out-char-eol* #\)))
  92.  
  93. (define (*pp:space*)    ; output a space
  94.   (*pp:out-char-eol* #\space))
  95.  
  96. (define (*pp:period*)        ; output " . "
  97.   (*pp:space*)
  98.   (*pp:out-char-eol* #\.)
  99.   (*pp:space*))
  100.  
  101. (define (*pp:output-symb* symb)   ; output the symbol symb
  102.   (format *pp:port* "~S" symb)
  103.   (set! *pp:last-symb-is-new-line* #f)
  104.   (set! *pp:cur-pos* (+ *pp:cur-pos* *pp:lgth-symb*)))
  105.  
  106.  
  107. (define (*pp:newline-indent* x)  ; output a newline and x spaces
  108.   (when (not *pp:last-symb-is-new-line*)
  109.         (format *pp:port* "~%")
  110.         (cond ((<= x 0) #t)
  111.               ((>= x *pp:lgth*) (set! x 0))
  112.               (else
  113.                (format *pp:port* "~A" (make-string x #\space))))
  114.         (set! *pp:last-symb-is-new-line* #t)
  115.         (set! *pp:line* (+ *pp:line* 1))
  116.         (set! *pp:cur-pos* x)))
  117.  
  118.  
  119. ; #t if expr will fit between *pp:last* and *pp:lgth*
  120. (define (*pp:fit?* expr)
  121.  
  122.   (define (inc-pos? val)
  123.     (if (<= (+ *pp:last* val) *pp:lgth*)
  124.         (begin (set! *pp:last* (+ *pp:last* val)) #t)
  125.         #f))
  126.  
  127.   (cond ((keyword? expr)
  128.          (set! *pp:lgth-symb* (string-length (keyword->string expr)))
  129.          (inc-pos? *pp:lgth-symb*))
  130.         ((symbol? expr)
  131.          (set! *pp:lgth-symb* (string-length (symbol->string expr)))
  132.          (inc-pos? *pp:lgth-symb*))
  133.         ((string? expr)    ; don't forget " "
  134.          (set! *pp:lgth-symb* (+ 2 (string-length expr)))
  135.          (inc-pos? *pp:lgth-symb*))
  136.         ((boolean? expr)   ; #t or #f
  137.          (set! *pp:lgth-symb* 2)
  138.          (inc-pos? *pp:lgth-symb*))
  139.         ((number? expr)
  140.          (set! *pp:lgth-symb*  (string-length (number->string expr)))
  141.          (inc-pos? *pp:lgth-symb*))
  142.         ((eof-object? expr) (inc-pos? 5))  ;??????????????????
  143.         ((char? expr)                   ; #\...
  144.          (inc-pos? (case expr
  145.                      (#\null 6)
  146.                      (#\bell 6)
  147.                      (#\space 7)
  148.                      (#\delete 8)
  149.                      (#\backspace 11)
  150.                      (#\tab 5)
  151.                      (#\newline 9)
  152.                      (#\page 6)
  153.                      (#\return 8)
  154.                      (#\escape 8)
  155.                      (else 3))))
  156.         ((pair? expr)      ; ( a b ...)
  157.          (let ((head (car expr))
  158.                (tail (cdr expr))
  159.                (subst (*pp:abbrev* expr)))
  160.            (cond (subst      ; to substitute
  161.                   (set! *pp:lgth-symb* 
  162.                         (if (or (eq? subst 'unquote-splicing)
  163.                                 (eq? subst 'quote-unquote))
  164.                             2 
  165.                             1))
  166.                   (and (inc-pos? *pp:lgth-symb*)
  167.                        (*pp:fit?* tail)))
  168.                  ((null? tail)    ;  (a)
  169.                   (and (inc-pos? 2) (*pp:fit?* head)))
  170.                  ((and (pair? tail)
  171.                        (null? (cdr tail))) ; (a b)
  172.                   (and (inc-pos? 1) (*pp:fit?* head) (*pp:fit?* tail)))
  173.                  (else            ; (a b ...)
  174.                   (and (inc-pos? 2) (*pp:fit?* head) (*pp:fit?* tail))))))
  175.         ((vector? expr)
  176.          (letrec ((vlen (- (vector-length expr) 1))
  177.                   (vloop
  178.                    (lambda (n)
  179.                      (if (< n vlen)
  180.                          (and (inc-pos? 1)
  181.                               (*pp:fit?* (vector-ref expr n))
  182.                               (vloop (+ n 1)))
  183.                          (and (inc-pos? 1)
  184.                               (*pp:fit?* (vector-ref expr vlen)))))))
  185.            (and (inc-pos? 2) (vloop 0))))
  186.         (else   ; null list
  187.          #t)))
  188.  
  189. ;******************************************************************
  190. ; output an expression
  191. ;******************************************************************
  192. (define (*pp:print-expr* expr pos)
  193.   (let ((special 
  194.          (if (and *pp:to-substitute* (pair? expr))
  195.              (assoc (car expr) *printer-list*)
  196.              #f)))
  197.     (if (pair? special)
  198.         ((cdr special) expr pos)
  199.         (begin (set! *pp:last* *pp:cur-pos*)
  200.                (if (not (*pp:fit?* expr))
  201.                    (*pp:newline-indent* pos))
  202.                (cond ((vector? expr) (*pp:print-vector* expr pos))
  203.                      ((not (pair? expr))
  204.                       ; *pp:lgth-symb* = lgth of the last symb
  205.                       (*pp:output-symb* expr))
  206.                      ((and (not (pair? (car expr)))
  207.                            (list? expr))  ; (operator args)
  208.                       (*pp:print-op* expr pos))
  209.                      (else (*pp:print-list* expr pos)))))))
  210.  
  211. ;******************************************************************
  212. ; output a vector
  213. ;******************************************************************
  214. (define (*pp:print-vector* vect pos)
  215.   (*pp:out-char* "#")   
  216. ; en attendant de pouvoir mettre :
  217. ;  (*pp:out-char* #\#)
  218.   (*pp:left-par*)
  219.   (let ((vect-lgth (- (vector-length vect) 1))
  220.         (n 0))
  221.     (set! pos (+ pos 2))
  222.     (*pp:print-expr* (vector-ref vect n) pos) ; first element
  223.     (while (< n vect-lgth)
  224.            (*pp:space*)
  225.            (set! n (+ n 1))
  226.            (*pp:print-expr* (vector-ref vect n) pos)))
  227.   (*pp:right-par*))
  228.  
  229.   ;******************************************************************
  230. ; output (operator args)
  231. ;******************************************************************
  232. (define (*pp:print-op* expr pos)
  233.   (*pp:left-par*)
  234.   (*pp:print-expr* (car expr) (+ pos 1))
  235.   (let ((first-line *pp:line*))
  236.     (unless (null? (cdr expr))
  237.           (set! *pp:last* *pp:cur-pos*)
  238.           (if (or (and (pair? (cadr expr)) (not (*pp:fit?* (caadr expr))))
  239.                   (and (not (pair? (cadr expr)))
  240.                        (not (*pp:fit?* (cadr expr)))))
  241.               (*pp:newline-indent* (+ pos 1))
  242.               (*pp:space*))
  243.  
  244.           (set! pos *pp:cur-pos*)
  245.           (set! *pp:last-symb-is-new-line* #t)
  246.           (*pp:print-expr* (cadr expr) pos) ; 1st arg on the same line
  247.           (for-each (lambda (arg)
  248.                       (set! *pp:last* *pp:cur-pos*)
  249. ;                     (if (or (not (*pp:fit?* arg)) (< first-line *pp:line*))
  250.                       (if (not (*pp:fit?* arg))
  251.                           (*pp:newline-indent* pos)
  252.                           (*pp:space*))
  253.                       (*pp:print-expr* arg pos))
  254.                     (cddr expr))))
  255.   (*pp:right-par*))
  256.  
  257. ;******************************************************************
  258. ; output (if cond then else)
  259. ;******************************************************************
  260. (define (*pp:print-if* expr pos)
  261.   (let ((on-new-line #f) (first-line *pp:line*))
  262.     (*pp:left-par*)
  263.     (*pp:print-expr* (car expr) pos)   ; if
  264.     (*pp:space*)
  265.     (set! pos *pp:cur-pos*)
  266.     (set! *pp:last-symb-is-new-line* #t) ; to stay on the same line
  267.     (*pp:print-expr* (cadr expr) pos)       ; cond
  268.     (set! *pp:last* *pp:cur-pos*)
  269.     (set! on-new-line (or (not (*pp:fit?* (cddr expr)))  ; (then else)
  270.                           (< first-line *pp:line*)))
  271.     (if on-new-line (*pp:newline-indent* pos) (*pp:space*))
  272.     (*pp:print-expr* (caddr expr) pos) ; then
  273.     (when (not (null? (cdddr expr)))
  274.           (if on-new-line (*pp:newline-indent* pos) (*pp:space*))
  275.           (*pp:print-expr* (cadddr expr) pos))
  276.     (*pp:right-par*)))
  277.  
  278. ;******************************************************************
  279. ; output clause
  280. ;******************************************************************
  281. (define (*pp:print-clause* clause pos)
  282.   (*pp:left-par*)
  283.   (unless (null? clause)
  284.           (*pp:print-expr* (car clause) pos)
  285.           (set! *pp:last* *pp:cur-pos*)
  286.           (if (not (*pp:fit?* (cdr clause)))
  287.               (*pp:newline-indent* pos)
  288.               (*pp:space*))
  289.           (set! clause (cdr clause))
  290.           (while (not (null? clause))
  291.                  (*pp:print-expr* (car clause) pos)
  292.                  (unless (null? (cdr clause))
  293.                        (set! *pp:last* *pp:cur-pos*)
  294.                        (if (not (*pp:fit?* (cadr clause)))
  295.                            (*pp:newline-indent* pos)
  296.                            (*pp:space*)))
  297.                  (set! clause (cdr clause))))
  298.   (*pp:right-par*))
  299.  
  300. ;******************************************************************
  301. ; output (cond clauses)
  302. ;******************************************************************
  303. (define (*pp:print-cond* expr pos)
  304.   (*pp:left-par*)
  305.   (*pp:print-expr* (car expr) (+ pos 1)) ; output "cond"
  306.   (*pp:space*)
  307.   (set! pos (+  pos 6))
  308.   (*pp:print-clause* (cadr expr) (+ pos 1))  ; the first clause
  309.   (for-each (lambda (clause)
  310.               (*pp:newline-indent* pos)
  311.               (*pp:print-clause* clause (+ pos 1)))
  312.             (cddr expr))
  313.   (*pp:right-par*))
  314.  
  315. ;******************************************************************
  316. ; output (case clauses)
  317. ;******************************************************************
  318. (define (*pp:print-case* expr pos)
  319.   (*pp:left-par*)
  320.   (*pp:print-expr* (car expr) (+ pos 1))
  321.   (*pp:space*)
  322.   (set! pos (+  pos 2))
  323.   (*pp:print-expr* (cadr expr) pos)
  324.   (for-each (lambda (clause)
  325.               (*pp:newline-indent* pos)
  326.               (*pp:print-clause* clause pos))
  327.             (cddr expr))
  328.   (*pp:right-par*))
  329.  
  330. ;******************************************************************
  331. ; output (do inits exit body)
  332. ;******************************************************************
  333. (define (*pp:print-do* expr pos)
  334.   (*pp:left-par*)
  335.   (*pp:print-expr* (car expr) (+ pos 1))  ; do
  336.   (*pp:space*)
  337.   (let ((inits (cadr expr))
  338.         (exit (caddr expr))
  339.         (body (cdddr expr))
  340.         (pos-ie (+ pos 4))
  341.         (pos-body (+ pos 2)))
  342.     (*pp:print-clause* inits pos-ie)
  343.     (*pp:newline-indent* pos-ie)
  344.     (*pp:print-clause* exit pos-ie)
  345.     (for-each (lambda (expr)
  346.                 (*pp:newline-indent* pos-body)
  347.                 (*pp:print-expr* expr pos-body))
  348.               body))
  349.   (*pp:right-par*))
  350.  
  351. ;******************************************************************
  352. ; output  (let|let*|letrec|let-syntax|letrec-syntax bindings  body)
  353. ;******************************************************************
  354. (define (*pp:print-let* expr pos)
  355.  
  356.   (define (print-binding bind pos)
  357.     (*pp:left-par*)
  358.     (*pp:print-expr* (car bind) pos)
  359.     (*pp:space*)
  360.     (set! *pp:last-symb-is-new-line* #t) ; to stay on the same line
  361.     (*pp:print-expr* (cadr bind) pos)
  362.     (*pp:right-par*))
  363.  
  364.   (*pp:newline-indent* pos)
  365.   (*pp:left-par*)
  366.   (*pp:print-expr* (car expr) (+ pos 1))
  367.   (*pp:space*)
  368.   (set! pos (+ pos 2))
  369.   (let ((pos-bind (+ pos *pp:lgth-symb* 1))
  370.         (bindings (cadr expr))
  371.         (body (cddr expr)))
  372.     (if (symbol? bindings)          ; named let
  373.         (begin (*pp:print-expr* bindings pos-bind)
  374.                (*pp:space*)
  375.                (set! pos-bind (+ pos-bind *pp:lgth-symb* 1))
  376.                (set! bindings (caddr expr))
  377.                (set! body (cdr body))))
  378.     (*pp:left-par*)
  379.     (when (not (null? bindings))
  380.       (print-binding (car bindings) pos-bind)  ; the first binding
  381.       (for-each (lambda (clause)
  382.               (*pp:newline-indent* pos-bind)
  383.               (print-binding clause pos-bind))                  
  384.             (cdr bindings)))
  385.     (*pp:right-par*)
  386.     (for-each (lambda (expr)
  387.                 (*pp:newline-indent* pos)
  388.                 (*pp:print-expr* expr pos))
  389.               body))
  390.   (*pp:right-par*))
  391.  
  392. ;******************************************************************
  393. ; output (define|define-macro|extend-syntax|when|unless|while arg body) 
  394. ; on a new line  
  395. ;******************************************************************
  396. (define (*pp:print-sform* expr pos)
  397.   (*pp:newline-indent* pos)
  398.   (*pp:left-par*)
  399.   (*pp:print-expr* (car expr) (+ pos 1))
  400.   (*pp:space*)
  401.   (set! pos (+ pos 2))
  402.   (set! *pp:last* *pp:cur-pos*)
  403.   (if (not (*pp:fit?* (cadr expr))) (*pp:newline-indent* pos))
  404.   (*pp:print-expr* (cadr expr) pos)
  405.   (let ((next-on-new-line (pair? (cadr expr))))
  406.     (for-each (lambda (arg)
  407.                 (set! *pp:last* *pp:cur-pos*)
  408.                 (if (or next-on-new-line (not (*pp:fit?* arg)))
  409.                     (*pp:newline-indent* pos)
  410.                     (*pp:space*))
  411.                 (*pp:print-expr* arg pos))
  412.               (cddr expr)))
  413.   (*pp:right-par*))
  414.  
  415. ;******************************************************************
  416. ;  output (lambda arg body) 
  417. ;******************************************************************
  418. (define (*pp:print-lambda* expr pos)
  419.   (let ((next-line #f))
  420.     (*pp:left-par*)
  421.     (*pp:print-expr* (car expr) (+ pos 1))
  422.     (*pp:space*)
  423.     (set! pos (+ pos 2))
  424.     (set! *pp:last* *pp:cur-pos*)
  425.     (unless (*pp:fit?* (cadr expr))
  426.             (set! next-line #t)
  427.             (*pp:newline-indent* pos))
  428.     (*pp:print-expr* (cadr expr) pos)
  429.     (set! next-line (or next-line (not (*pp:fit?* (cddr expr)))))
  430.     (for-each (lambda (arg)
  431.                 (if next-line (*pp:newline-indent* pos))
  432.                 (*pp:print-expr* arg pos))
  433.               (cddr expr))
  434.     (*pp:right-par*)))
  435.  
  436. ;******************************************************************
  437. ; check for substitution of quote, quasiquote, unquote, unquote-splicing
  438. ; general rules :
  439. ;   After a quote, symbols don't have to be substitued except for unquote
  440. ;******************************************************************
  441. (define (*pp:abbrev* expr)
  442.   (if (and *pp:to-substitute* (pair? expr))
  443.       (cond ((and (pair? (cdr expr))
  444.                   (null? (cddr expr))
  445.                   (eq? (car expr) 'quote))    ; (quote x)
  446.              (if (and (pair? (cadr expr))
  447.                       (eq? (caadr expr) 'unquote))
  448.                  'quote-unquote
  449.                  'quote))
  450.             (else
  451.              (if (memq (car expr)
  452.                        '(quasiquote unquote unquote-splicing))
  453.                  (car expr)
  454.                  #f)))
  455.       #f))
  456.  
  457. ;******************************************************************
  458. ;  output (quote arg)                        ==> 'arg 
  459. ;         (quote ( arg1 arg2 ...))           ==> '(arg1 ag2 ...)
  460. ;         (quote (unquote arg))              ==> ',arg
  461. ;         (quote (unquote arg1 arg2 ...))    ==> ',(arg1 arg2 ...)
  462. ;         (quasiquote arg)                   ==> `arg
  463. ;         (quasiquote (arg1 arg2 ...))       ==> `(arg1 arg2 ...)
  464. ;         (unquote arg)                      ==> , arg
  465. ;         (unquote (arg1 arg2 ...))          ==> ,(arg1 arg2 ...)
  466. ;         (unquote-splicing  arg)            ==> ,@ arg
  467. ;         (unquote-splicing (arg1 arg2 ...)) ==> ,@(arg1 arg2 ...)
  468. ;******************************************************************
  469. (define (*pp:print-quote*  expr pos)
  470.   (let ((which (*pp:abbrev* expr)))
  471.     (cond ((not which)
  472.            (set! *pp:to-substitute* #f)
  473.            (*pp:print-expr* expr pos)
  474.            (set! *pp:to-substitute* #t))
  475.           ((eq? which 'quote)
  476.            (set! *pp:to-substitute* #f)
  477.            (set! *pp:last* (+ *pp:cur-pos* 1))
  478.            (if (not (*pp:fit?* (cdr expr))) (*pp:newline-indent* pos))
  479.            (*pp:out-char* #\')
  480.            (*pp:print-expr* (cadr expr) (+ pos 1))
  481.            (set! *pp:to-substitute* #t))
  482.           ((eq? which 'quote-unquote)
  483.            (*pp:out-char* #\') (*pp:out-char* #\,)
  484.            (*pp:print-expr* (car (cdadr expr)) (+ pos 2)))
  485.           (else
  486.            (case which
  487.              (quasiquote (*pp:out-char* #\`))
  488.              (unquote (*pp:out-char* #\,))
  489.              (unquote-splicing (*pp:out-char* #\,) (*pp:out-char* #\@)))
  490.            (*pp:print-expr* (cadr expr)
  491.                             (+ pos (if (eq? which 'unquote-splicing)
  492.                                        2 
  493.                                        1)))))))
  494.  
  495. ;******************************************************************
  496. ;  output (call/cc|call-with-current-continuation body)
  497. ;******************************************************************
  498. (define (*pp:print-sform0* expr pos)
  499.   (*pp:left-par*)
  500.   (*pp:print-expr* (car expr) pos)
  501.   (set! pos (+ pos 2))
  502.   (for-each (lambda (arg)
  503.               (*pp:newline-indent* pos)
  504.               (*pp:print-expr* arg pos))
  505.             (cdr expr))
  506.   (*pp:right-par*))
  507.  
  508.  
  509. ;******************************************************************
  510. ;  output a list
  511. ;******************************************************************
  512. (define (*pp:print-list*  lst pos)
  513.   (*pp:left-par*)
  514.   (set! pos (+ pos 1))
  515.   (*pp:print-expr* (car lst) pos)  ; 1st element
  516.   (let ((last #f) (lst (cdr lst)))
  517.     (while (and (not (null? lst)) (not last))
  518.            (cond ((not (pair? lst))
  519.                   (*pp:period*)
  520.                   (*pp:print-expr* lst pos)
  521.                   (set! last #t))
  522.                  (else
  523.                   (*pp:space*)
  524.                   (*pp:print-expr* (car lst) pos)))
  525.            (if (not last) (set! lst (cdr lst)))))
  526.   (*pp:right-par*))
  527.     
  528. ;******************************************************************
  529. ;  define special forms
  530. ;******************************************************************
  531.  
  532. (define (printer-add form printer)    ; add special pretty printers
  533.   (set! *printer-list*
  534.         (cons '()
  535.               (cons (cons form printer)
  536.                     (cdr *printer-list*)))))
  537.   
  538. (printer-add 'quote *pp:print-quote*)
  539. (printer-add 'quasiquote *pp:print-quote*)
  540. (printer-add 'unquote *pp:print-quote*)
  541. (printer-add 'unquote-splicing *pp:print-quote*)
  542.  
  543. (printer-add 'lambda *pp:print-lambda*)
  544.  
  545. (printer-add 'define *pp:print-sform*)
  546. (printer-add 'define-macro *pp:print-sform*)
  547. (printer-add 'extend-syntax *pp:print-sform*)
  548. (printer-add 'when *pp:print-sform*)
  549. (printer-add 'unless *pp:print-sform*)
  550. (printer-add 'while *pp:print-sform*)
  551.  
  552. (printer-add 'let *pp:print-let*)
  553. (printer-add 'letrec *pp:print-let*)
  554. (printer-add 'let* *pp:print-let*)
  555. (printer-add 'let-syntax *pp:print-let*)
  556. (printer-add 'letrec-syntax *pp:print-let*)
  557.  
  558. (printer-add 'do *pp:print-do*)
  559.  
  560. (printer-add 'if *pp:print-if*)
  561.  
  562. (printer-add 'cond *pp:print-cond*)
  563.  
  564. (printer-add 'case *pp:print-case*)
  565. (printer-add 'record-case *pp:print-case*)
  566.  
  567. (printer-add 'call-with-current-continuation *pp:print-sform0*)
  568. (printer-add 'call/cc *pp:print-sform0*)
  569.