569 lines
21 KiB
Plaintext
569 lines
21 KiB
Plaintext
|
;; pretty-printer by mf
|
||
|
|
;*************************************************************
|
||
|
|
(define *pp:port* #t) ; default value = current output
|
||
|
|
(define *pp:lgth* 80) ; default value = max length of a line
|
||
|
|
|
||
|
|
(define (pp obj . options)
|
||
|
|
; obj = file name in a string or
|
||
|
|
; expression to be pretty printed
|
||
|
|
; options = toutes facultatives
|
||
|
|
; destination = file name in a string
|
||
|
|
; #t ==> current output (default value)
|
||
|
|
; #f ==> a string
|
||
|
|
; line-length = integer >= 0 = max length of a line on output
|
||
|
|
; (default value = 80)
|
||
|
|
(let ((dest 'output))
|
||
|
|
(set! *pp:port* #t)
|
||
|
|
(set! *pp:lgth* 80)
|
||
|
|
(let loop ((L options))
|
||
|
|
(when (not (null? L))
|
||
|
|
; there is options....
|
||
|
|
(cond ((string? (car L)) ; output in a file
|
||
|
|
(set! *pp:port* (open-output-file (car L)))
|
||
|
|
(set! dest 'file))
|
||
|
|
((integer? (car L))
|
||
|
|
(set! *pp:lgth* (car L)))
|
||
|
|
((boolean? (car L)) ; current output or a string
|
||
|
|
(when (not (car L))
|
||
|
|
(set! *pp:port* (open-output-string))
|
||
|
|
(set! dest 'string))))
|
||
|
|
(loop (cdr L))))
|
||
|
|
|
||
|
|
(if (string? obj) ; file name
|
||
|
|
(let* ((p (open-input-file obj))
|
||
|
|
(to-pp (read p)))
|
||
|
|
(while (not (eof-object? to-pp))
|
||
|
|
(*pp:pp-one-exp* to-pp)
|
||
|
|
(format *pp:port* "~%")
|
||
|
|
(set! to-pp (read p))))
|
||
|
|
(*pp:pp-one-exp* obj))
|
||
|
|
(cond ((eq? dest 'file) (close-output-port *pp:port*))
|
||
|
|
((eq? dest 'string) (get-output-string *pp:port*)))))
|
||
|
|
|
||
|
|
;*************************************************************
|
||
|
|
; pretty-print an expression
|
||
|
|
;*************************************************************
|
||
|
|
|
||
|
|
(define *pp:cur-pos* 0) ; current position in line
|
||
|
|
|
||
|
|
(define *pp:line* 1) ; current line
|
||
|
|
|
||
|
|
(define *pp:lgth-symb* 0) ; lgth of symb to write
|
||
|
|
|
||
|
|
(define *printer-list* '(()))
|
||
|
|
|
||
|
|
(define *pp:last-symb-is-new-line* #t)
|
||
|
|
|
||
|
|
(define *pp:to-substitute* #t)
|
||
|
|
|
||
|
|
(define *pp:last* 0) ; for *pp:fit?*
|
||
|
|
|
||
|
|
(define (*pp:pp-one-exp* expr)
|
||
|
|
(set! *pp:cur-pos* 0) ; current position in line
|
||
|
|
(set! *pp:line* 1) ; current line
|
||
|
|
(set! *pp:lgth-symb* 0) ; lgth of symb to write
|
||
|
|
(set! *pp:last-symb-is-new-line* #t)
|
||
|
|
(set! *pp:to-substitute* #t)
|
||
|
|
(set! *pp:last* 0) ; for *pp:fit?*
|
||
|
|
(let ((expr (if (procedure? expr) (procedure-body expr)
|
||
|
|
expr)))
|
||
|
|
(*pp:print-expr* expr *pp:cur-pos*)
|
||
|
|
(format *pp:port* "~%")
|
||
|
|
#t))
|
||
|
|
|
||
|
|
|
||
|
|
(define (*pp:out-char* c) ; output the char c NOT at end of line
|
||
|
|
; c = left parenthesis|quote|quasiquote|unquote|unquote-splicing
|
||
|
|
(format *pp:port* "~A" c)
|
||
|
|
(set! *pp:last-symb-is-new-line* #t)
|
||
|
|
(set! *pp:cur-pos* (+ *pp:cur-pos* 1)))
|
||
|
|
|
||
|
|
(define (*pp:left-par*) ; output a left parenthesis
|
||
|
|
(*pp:out-char* #\( ))
|
||
|
|
|
||
|
|
(define (*pp:out-char-eol* c) ; output the char c perhaps at end of line
|
||
|
|
; c = right parenthesis|space|period
|
||
|
|
(format *pp:port* "~A" c)
|
||
|
|
(set! *pp:last-symb-is-new-line* #f)
|
||
|
|
(set! *pp:cur-pos* (+ *pp:cur-pos* 1)))
|
||
|
|
|
||
|
|
(define (*pp:right-par*) ; output a right parenthesis
|
||
|
|
(*pp:out-char-eol* #\)))
|
||
|
|
|
||
|
|
(define (*pp:space*) ; output a space
|
||
|
|
(*pp:out-char-eol* #\space))
|
||
|
|
|
||
|
|
(define (*pp:period*) ; output " . "
|
||
|
|
(*pp:space*)
|
||
|
|
(*pp:out-char-eol* #\.)
|
||
|
|
(*pp:space*))
|
||
|
|
|
||
|
|
(define (*pp:output-symb* symb) ; output the symbol symb
|
||
|
|
(format *pp:port* "~S" symb)
|
||
|
|
(set! *pp:last-symb-is-new-line* #f)
|
||
|
|
(set! *pp:cur-pos* (+ *pp:cur-pos* *pp:lgth-symb*)))
|
||
|
|
|
||
|
|
|
||
|
|
(define (*pp:newline-indent* x) ; output a newline and x spaces
|
||
|
|
(when (not *pp:last-symb-is-new-line*)
|
||
|
|
(format *pp:port* "~%")
|
||
|
|
(cond ((<= x 0) #t)
|
||
|
|
((>= x *pp:lgth*) (set! x 0))
|
||
|
|
(else
|
||
|
|
(format *pp:port* "~A" (make-string x #\space))))
|
||
|
|
(set! *pp:last-symb-is-new-line* #t)
|
||
|
|
(set! *pp:line* (+ *pp:line* 1))
|
||
|
|
(set! *pp:cur-pos* x)))
|
||
|
|
|
||
|
|
|
||
|
|
; #t if expr will fit between *pp:last* and *pp:lgth*
|
||
|
|
(define (*pp:fit?* expr)
|
||
|
|
|
||
|
|
(define (inc-pos? val)
|
||
|
|
(if (<= (+ *pp:last* val) *pp:lgth*)
|
||
|
|
(begin (set! *pp:last* (+ *pp:last* val)) #t)
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(cond ((keyword? expr)
|
||
|
|
(set! *pp:lgth-symb* (string-length (keyword->string expr)))
|
||
|
|
(inc-pos? *pp:lgth-symb*))
|
||
|
|
((symbol? expr)
|
||
|
|
(set! *pp:lgth-symb* (string-length (symbol->string expr)))
|
||
|
|
(inc-pos? *pp:lgth-symb*))
|
||
|
|
((string? expr) ; don't forget " "
|
||
|
|
(set! *pp:lgth-symb* (+ 2 (string-length expr)))
|
||
|
|
(inc-pos? *pp:lgth-symb*))
|
||
|
|
((boolean? expr) ; #t or #f
|
||
|
|
(set! *pp:lgth-symb* 2)
|
||
|
|
(inc-pos? *pp:lgth-symb*))
|
||
|
|
((number? expr)
|
||
|
|
(set! *pp:lgth-symb* (string-length (number->string expr)))
|
||
|
|
(inc-pos? *pp:lgth-symb*))
|
||
|
|
((eof-object? expr) (inc-pos? 5)) ;??????????????????
|
||
|
|
((char? expr) ; #\...
|
||
|
|
(inc-pos? (case expr
|
||
|
|
(#\null 6)
|
||
|
|
(#\bell 6)
|
||
|
|
(#\space 7)
|
||
|
|
(#\delete 8)
|
||
|
|
(#\backspace 11)
|
||
|
|
(#\tab 5)
|
||
|
|
(#\newline 9)
|
||
|
|
(#\page 6)
|
||
|
|
(#\return 8)
|
||
|
|
(#\escape 8)
|
||
|
|
(else 3))))
|
||
|
|
((pair? expr) ; ( a b ...)
|
||
|
|
(let ((head (car expr))
|
||
|
|
(tail (cdr expr))
|
||
|
|
(subst (*pp:abbrev* expr)))
|
||
|
|
(cond (subst ; to substitute
|
||
|
|
(set! *pp:lgth-symb*
|
||
|
|
(if (or (eq? subst 'unquote-splicing)
|
||
|
|
(eq? subst 'quote-unquote))
|
||
|
|
2
|
||
|
|
1))
|
||
|
|
(and (inc-pos? *pp:lgth-symb*)
|
||
|
|
(*pp:fit?* tail)))
|
||
|
|
((null? tail) ; (a)
|
||
|
|
(and (inc-pos? 2) (*pp:fit?* head)))
|
||
|
|
((and (pair? tail)
|
||
|
|
(null? (cdr tail))) ; (a b)
|
||
|
|
(and (inc-pos? 1) (*pp:fit?* head) (*pp:fit?* tail)))
|
||
|
|
(else ; (a b ...)
|
||
|
|
(and (inc-pos? 2) (*pp:fit?* head) (*pp:fit?* tail))))))
|
||
|
|
((vector? expr)
|
||
|
|
(letrec ((vlen (- (vector-length expr) 1))
|
||
|
|
(vloop
|
||
|
|
(lambda (n)
|
||
|
|
(if (< n vlen)
|
||
|
|
(and (inc-pos? 1)
|
||
|
|
(*pp:fit?* (vector-ref expr n))
|
||
|
|
(vloop (+ n 1)))
|
||
|
|
(and (inc-pos? 1)
|
||
|
|
(*pp:fit?* (vector-ref expr vlen)))))))
|
||
|
|
(and (inc-pos? 2) (vloop 0))))
|
||
|
|
(else ; null list
|
||
|
|
#t)))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output an expression
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-expr* expr pos)
|
||
|
|
(let ((special
|
||
|
|
(if (and *pp:to-substitute* (pair? expr))
|
||
|
|
(assoc (car expr) *printer-list*)
|
||
|
|
#f)))
|
||
|
|
(if (pair? special)
|
||
|
|
((cdr special) expr pos)
|
||
|
|
(begin (set! *pp:last* *pp:cur-pos*)
|
||
|
|
(if (not (*pp:fit?* expr))
|
||
|
|
(*pp:newline-indent* pos))
|
||
|
|
(cond ((vector? expr) (*pp:print-vector* expr pos))
|
||
|
|
((not (pair? expr))
|
||
|
|
; *pp:lgth-symb* = lgth of the last symb
|
||
|
|
(*pp:output-symb* expr))
|
||
|
|
((and (not (pair? (car expr)))
|
||
|
|
(list? expr)) ; (operator args)
|
||
|
|
(*pp:print-op* expr pos))
|
||
|
|
(else (*pp:print-list* expr pos)))))))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output a vector
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-vector* vect pos)
|
||
|
|
(*pp:out-char* "#")
|
||
|
|
; en attendant de pouvoir mettre :
|
||
|
|
; (*pp:out-char* #\#)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(let ((vect-lgth (- (vector-length vect) 1))
|
||
|
|
(n 0))
|
||
|
|
(set! pos (+ pos 2))
|
||
|
|
(*pp:print-expr* (vector-ref vect n) pos) ; first element
|
||
|
|
(while (< n vect-lgth)
|
||
|
|
(*pp:space*)
|
||
|
|
(set! n (+ n 1))
|
||
|
|
(*pp:print-expr* (vector-ref vect n) pos)))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (operator args)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-op* expr pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) (+ pos 1))
|
||
|
|
(let ((first-line *pp:line*))
|
||
|
|
(unless (null? (cdr expr))
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
(if (or (and (pair? (cadr expr)) (not (*pp:fit?* (caadr expr))))
|
||
|
|
(and (not (pair? (cadr expr)))
|
||
|
|
(not (*pp:fit?* (cadr expr)))))
|
||
|
|
(*pp:newline-indent* (+ pos 1))
|
||
|
|
(*pp:space*))
|
||
|
|
|
||
|
|
(set! pos *pp:cur-pos*)
|
||
|
|
(set! *pp:last-symb-is-new-line* #t)
|
||
|
|
(*pp:print-expr* (cadr expr) pos) ; 1st arg on the same line
|
||
|
|
(for-each (lambda (arg)
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
; (if (or (not (*pp:fit?* arg)) (< first-line *pp:line*))
|
||
|
|
(if (not (*pp:fit?* arg))
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:space*))
|
||
|
|
(*pp:print-expr* arg pos))
|
||
|
|
(cddr expr))))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (if cond then else)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-if* expr pos)
|
||
|
|
(let ((on-new-line #f) (first-line *pp:line*))
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) pos) ; if
|
||
|
|
(*pp:space*)
|
||
|
|
(set! pos *pp:cur-pos*)
|
||
|
|
(set! *pp:last-symb-is-new-line* #t) ; to stay on the same line
|
||
|
|
(*pp:print-expr* (cadr expr) pos) ; cond
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
(set! on-new-line (or (not (*pp:fit?* (cddr expr))) ; (then else)
|
||
|
|
(< first-line *pp:line*)))
|
||
|
|
(if on-new-line (*pp:newline-indent* pos) (*pp:space*))
|
||
|
|
(*pp:print-expr* (caddr expr) pos) ; then
|
||
|
|
(when (not (null? (cdddr expr)))
|
||
|
|
(if on-new-line (*pp:newline-indent* pos) (*pp:space*))
|
||
|
|
(*pp:print-expr* (cadddr expr) pos))
|
||
|
|
(*pp:right-par*)))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output clause
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-clause* clause pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(unless (null? clause)
|
||
|
|
(*pp:print-expr* (car clause) pos)
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
(if (not (*pp:fit?* (cdr clause)))
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:space*))
|
||
|
|
(set! clause (cdr clause))
|
||
|
|
(while (not (null? clause))
|
||
|
|
(*pp:print-expr* (car clause) pos)
|
||
|
|
(unless (null? (cdr clause))
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
(if (not (*pp:fit?* (cadr clause)))
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:space*)))
|
||
|
|
(set! clause (cdr clause))))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (cond clauses)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-cond* expr pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) (+ pos 1)) ; output "cond"
|
||
|
|
(*pp:space*)
|
||
|
|
(set! pos (+ pos 6))
|
||
|
|
(*pp:print-clause* (cadr expr) (+ pos 1)) ; the first clause
|
||
|
|
(for-each (lambda (clause)
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:print-clause* clause (+ pos 1)))
|
||
|
|
(cddr expr))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (case clauses)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-case* expr pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) (+ pos 1))
|
||
|
|
(*pp:space*)
|
||
|
|
(set! pos (+ pos 2))
|
||
|
|
(*pp:print-expr* (cadr expr) pos)
|
||
|
|
(for-each (lambda (clause)
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:print-clause* clause pos))
|
||
|
|
(cddr expr))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (do inits exit body)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-do* expr pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) (+ pos 1)) ; do
|
||
|
|
(*pp:space*)
|
||
|
|
(let ((inits (cadr expr))
|
||
|
|
(exit (caddr expr))
|
||
|
|
(body (cdddr expr))
|
||
|
|
(pos-ie (+ pos 4))
|
||
|
|
(pos-body (+ pos 2)))
|
||
|
|
(*pp:print-clause* inits pos-ie)
|
||
|
|
(*pp:newline-indent* pos-ie)
|
||
|
|
(*pp:print-clause* exit pos-ie)
|
||
|
|
(for-each (lambda (expr)
|
||
|
|
(*pp:newline-indent* pos-body)
|
||
|
|
(*pp:print-expr* expr pos-body))
|
||
|
|
body))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (let|let*|letrec|let-syntax|letrec-syntax bindings body)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-let* expr pos)
|
||
|
|
|
||
|
|
(define (print-binding bind pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car bind) pos)
|
||
|
|
(*pp:space*)
|
||
|
|
(set! *pp:last-symb-is-new-line* #t) ; to stay on the same line
|
||
|
|
(*pp:print-expr* (cadr bind) pos)
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) (+ pos 1))
|
||
|
|
(*pp:space*)
|
||
|
|
(set! pos (+ pos 2))
|
||
|
|
(let ((pos-bind (+ pos *pp:lgth-symb* 1))
|
||
|
|
(bindings (cadr expr))
|
||
|
|
(body (cddr expr)))
|
||
|
|
(if (symbol? bindings) ; named let
|
||
|
|
(begin (*pp:print-expr* bindings pos-bind)
|
||
|
|
(*pp:space*)
|
||
|
|
(set! pos-bind (+ pos-bind *pp:lgth-symb* 1))
|
||
|
|
(set! bindings (caddr expr))
|
||
|
|
(set! body (cdr body))))
|
||
|
|
(*pp:left-par*)
|
||
|
|
(when (not (null? bindings))
|
||
|
|
(print-binding (car bindings) pos-bind) ; the first binding
|
||
|
|
(for-each (lambda (clause)
|
||
|
|
(*pp:newline-indent* pos-bind)
|
||
|
|
(print-binding clause pos-bind))
|
||
|
|
(cdr bindings)))
|
||
|
|
(*pp:right-par*)
|
||
|
|
(for-each (lambda (expr)
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:print-expr* expr pos))
|
||
|
|
body))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (define|define-macro|extend-syntax|when|unless|while arg body)
|
||
|
|
; on a new line
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-sform* expr pos)
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) (+ pos 1))
|
||
|
|
(*pp:space*)
|
||
|
|
(set! pos (+ pos 2))
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
(if (not (*pp:fit?* (cadr expr))) (*pp:newline-indent* pos))
|
||
|
|
(*pp:print-expr* (cadr expr) pos)
|
||
|
|
(let ((next-on-new-line (pair? (cadr expr))))
|
||
|
|
(for-each (lambda (arg)
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
(if (or next-on-new-line (not (*pp:fit?* arg)))
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:space*))
|
||
|
|
(*pp:print-expr* arg pos))
|
||
|
|
(cddr expr)))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (lambda arg body)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-lambda* expr pos)
|
||
|
|
(let ((next-line #f))
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) (+ pos 1))
|
||
|
|
(*pp:space*)
|
||
|
|
(set! pos (+ pos 2))
|
||
|
|
(set! *pp:last* *pp:cur-pos*)
|
||
|
|
(unless (*pp:fit?* (cadr expr))
|
||
|
|
(set! next-line #t)
|
||
|
|
(*pp:newline-indent* pos))
|
||
|
|
(*pp:print-expr* (cadr expr) pos)
|
||
|
|
(set! next-line (or next-line (not (*pp:fit?* (cddr expr)))))
|
||
|
|
(for-each (lambda (arg)
|
||
|
|
(if next-line (*pp:newline-indent* pos))
|
||
|
|
(*pp:print-expr* arg pos))
|
||
|
|
(cddr expr))
|
||
|
|
(*pp:right-par*)))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; check for substitution of quote, quasiquote, unquote, unquote-splicing
|
||
|
|
; general rules :
|
||
|
|
; After a quote, symbols don't have to be substitued except for unquote
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:abbrev* expr)
|
||
|
|
(if (and *pp:to-substitute* (pair? expr))
|
||
|
|
(cond ((and (pair? (cdr expr))
|
||
|
|
(null? (cddr expr))
|
||
|
|
(eq? (car expr) 'quote)) ; (quote x)
|
||
|
|
(if (and (pair? (cadr expr))
|
||
|
|
(eq? (caadr expr) 'unquote))
|
||
|
|
'quote-unquote
|
||
|
|
'quote))
|
||
|
|
(else
|
||
|
|
(if (memq (car expr)
|
||
|
|
'(quasiquote unquote unquote-splicing))
|
||
|
|
(car expr)
|
||
|
|
#f)))
|
||
|
|
#f))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (quote arg) ==> 'arg
|
||
|
|
; (quote ( arg1 arg2 ...)) ==> '(arg1 ag2 ...)
|
||
|
|
; (quote (unquote arg)) ==> ',arg
|
||
|
|
; (quote (unquote arg1 arg2 ...)) ==> ',(arg1 arg2 ...)
|
||
|
|
; (quasiquote arg) ==> `arg
|
||
|
|
; (quasiquote (arg1 arg2 ...)) ==> `(arg1 arg2 ...)
|
||
|
|
; (unquote arg) ==> , arg
|
||
|
|
; (unquote (arg1 arg2 ...)) ==> ,(arg1 arg2 ...)
|
||
|
|
; (unquote-splicing arg) ==> ,@ arg
|
||
|
|
; (unquote-splicing (arg1 arg2 ...)) ==> ,@(arg1 arg2 ...)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-quote* expr pos)
|
||
|
|
(let ((which (*pp:abbrev* expr)))
|
||
|
|
(cond ((not which)
|
||
|
|
(set! *pp:to-substitute* #f)
|
||
|
|
(*pp:print-expr* expr pos)
|
||
|
|
(set! *pp:to-substitute* #t))
|
||
|
|
((eq? which 'quote)
|
||
|
|
(set! *pp:to-substitute* #f)
|
||
|
|
(set! *pp:last* (+ *pp:cur-pos* 1))
|
||
|
|
(if (not (*pp:fit?* (cdr expr))) (*pp:newline-indent* pos))
|
||
|
|
(*pp:out-char* #\')
|
||
|
|
(*pp:print-expr* (cadr expr) (+ pos 1))
|
||
|
|
(set! *pp:to-substitute* #t))
|
||
|
|
((eq? which 'quote-unquote)
|
||
|
|
(*pp:out-char* #\') (*pp:out-char* #\,)
|
||
|
|
(*pp:print-expr* (car (cdadr expr)) (+ pos 2)))
|
||
|
|
(else
|
||
|
|
(case which
|
||
|
|
(quasiquote (*pp:out-char* #\`))
|
||
|
|
(unquote (*pp:out-char* #\,))
|
||
|
|
(unquote-splicing (*pp:out-char* #\,) (*pp:out-char* #\@)))
|
||
|
|
(*pp:print-expr* (cadr expr)
|
||
|
|
(+ pos (if (eq? which 'unquote-splicing)
|
||
|
|
2
|
||
|
|
1)))))))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output (call/cc|call-with-current-continuation body)
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-sform0* expr pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(*pp:print-expr* (car expr) pos)
|
||
|
|
(set! pos (+ pos 2))
|
||
|
|
(for-each (lambda (arg)
|
||
|
|
(*pp:newline-indent* pos)
|
||
|
|
(*pp:print-expr* arg pos))
|
||
|
|
(cdr expr))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; output a list
|
||
|
|
;******************************************************************
|
||
|
|
(define (*pp:print-list* lst pos)
|
||
|
|
(*pp:left-par*)
|
||
|
|
(set! pos (+ pos 1))
|
||
|
|
(*pp:print-expr* (car lst) pos) ; 1st element
|
||
|
|
(let ((last #f) (lst (cdr lst)))
|
||
|
|
(while (and (not (null? lst)) (not last))
|
||
|
|
(cond ((not (pair? lst))
|
||
|
|
(*pp:period*)
|
||
|
|
(*pp:print-expr* lst pos)
|
||
|
|
(set! last #t))
|
||
|
|
(else
|
||
|
|
(*pp:space*)
|
||
|
|
(*pp:print-expr* (car lst) pos)))
|
||
|
|
(if (not last) (set! lst (cdr lst)))))
|
||
|
|
(*pp:right-par*))
|
||
|
|
|
||
|
|
;******************************************************************
|
||
|
|
; define special forms
|
||
|
|
;******************************************************************
|
||
|
|
|
||
|
|
(define (printer-add form printer) ; add special pretty printers
|
||
|
|
(set! *printer-list*
|
||
|
|
(cons '()
|
||
|
|
(cons (cons form printer)
|
||
|
|
(cdr *printer-list*)))))
|
||
|
|
|
||
|
|
(printer-add 'quote *pp:print-quote*)
|
||
|
|
(printer-add 'quasiquote *pp:print-quote*)
|
||
|
|
(printer-add 'unquote *pp:print-quote*)
|
||
|
|
(printer-add 'unquote-splicing *pp:print-quote*)
|
||
|
|
|
||
|
|
(printer-add 'lambda *pp:print-lambda*)
|
||
|
|
|
||
|
|
(printer-add 'define *pp:print-sform*)
|
||
|
|
(printer-add 'define-macro *pp:print-sform*)
|
||
|
|
(printer-add 'extend-syntax *pp:print-sform*)
|
||
|
|
(printer-add 'when *pp:print-sform*)
|
||
|
|
(printer-add 'unless *pp:print-sform*)
|
||
|
|
(printer-add 'while *pp:print-sform*)
|
||
|
|
|
||
|
|
(printer-add 'let *pp:print-let*)
|
||
|
|
(printer-add 'letrec *pp:print-let*)
|
||
|
|
(printer-add 'let* *pp:print-let*)
|
||
|
|
(printer-add 'let-syntax *pp:print-let*)
|
||
|
|
(printer-add 'letrec-syntax *pp:print-let*)
|
||
|
|
|
||
|
|
(printer-add 'do *pp:print-do*)
|
||
|
|
|
||
|
|
(printer-add 'if *pp:print-if*)
|
||
|
|
|
||
|
|
(printer-add 'cond *pp:print-cond*)
|
||
|
|
|
||
|
|
(printer-add 'case *pp:print-case*)
|
||
|
|
(printer-add 'record-case *pp:print-case*)
|
||
|
|
|
||
|
|
(printer-add 'call-with-current-continuation *pp:print-sform0*)
|
||
|
|
(printer-add 'call/cc *pp:print-sform0*)
|