<<>>
<<;;; PPrint.scheme>>
<<;;; Copyright Ó 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
<<;;; Last changed by Pavel on August 30, 1989 11:38:37 am PDT>>
<<;;; Michael Plass, January 20, 1989 9:45:17 pm PST>>

<<;;; NOTE: Eval this syntax definition before trying to compile this file!>>

(extend-syntax (define-pretty-printer)
(  (define-pretty-printer (name keys ...)
(pattern function) ...)
(with ((form (gensym))
 (port (gensym)))
(add-pretty-printer! 'name
(lambda (form port)
(cond
((syntax-match? '(name keys ...) 'pattern form)
(function form port))
...
(else
(default-pair-printer form port))))))))

(define pprint-routines '()) ; An AList of pretty-printing routines

(define (add-pretty-printer! name function)
(let ((lookup (assq name pprint-routines)))
(if lookup
(set-cdr! lookup function)
(set! pprint-routines
(cons (cons name function)
      pprint-routines)))
name))

(define (pprint expr . rest)
"Prettily print EXPR on the given port (or (CURRENT-OUTPUT-PORT))"
(let* ((backing-port
    (if (null? rest)
       (current-output-port)
       (car rest)))
 (structured-port
    (if (structured-port? backing-port)
       backing-port
       (make-structured-port backing-port))))
(cond
((pair? expr)
(if (primitive-syntax-marker? (car expr))
(set! expr (cons (primitive-syntax-marker->symbol (car expr))
           (cdr expr))))
(cond
((and (proper-list? expr)
(symbol? (car expr))
(assq (car expr) pprint-routines))
=>
(lambda (lookup)
((cdr lookup) expr structured-port)))
(else
(default-pair-printer expr structured-port))))
(else
(write expr structured-port)))))

(define (pprint-file input-name output-name)
(let* ((in (open-input-file input-name))
 (writer (make-writer))
 (out (make-structured-port writer)))
(let loop ((form (read in)))
(cond
((eof-object? form)
(close-output-port out)
(write-file-from-writer writer output-name))
(else
(pprint form out)
(newline out)
(newline out)
(loop (read in)))))))

(define (begin-list p)
(begin-structure p)
(display "(" p))

(define (end-list p)
(display ")" p)
(end-structure p))

(define (default-pair-printer expr p)
(begin-list p)
(pprint (car expr) p)
(cond
((not (null? (cdr expr)))
(if (pair? (car expr))
(breakpoint p 'always 1 " ")
(display " " p))
(begin-structure p)
(let loop ((tail (cdr expr)))
(cond
((pair? tail)
(pprint (car tail) p)
(cond
((not (null? (cdr tail))) ; There's more
(if (and (pair? (car tail))
      (not (memq (caar tail)
              '(quote unquote
          unquote-splicing
          quasiquote))))
(newline p)
(breakpoint p 'width 0 " "))
(loop (cdr tail)))))
(else
(display ". " p)
(pprint tail p))))
(end-structure p)))
(end-list p))

(define (pprint-vertical-list l p)
(begin-structure p)
(iterate* ((tail (list-tails l))
     (arg (each-time (car tail))))
(pprint arg p)
(if (not (null? (cdr tail))) ; There's more
(newline p)))
(end-structure p))

(define (pprint-bindings bindings p)
(cond
((syntax-match? '() '((v e) ...) bindings)
(display "(" p)
(pprint-vertical-list bindings p)
(display ")" p))
(else
(default-pair-printer bindings p))))

(define (pprint-binder form p)
(begin-list p)
(write (car form) p)
(display " " p)
(pprint-bindings (cadr form) p)
(breakpoint p 'look-left 3 " ")
(pprint-vertical-list (cddr form) p)
(end-list p))

(define-pretty-printer (let)
(  (let (binding ...) e1 e2 ...)
pprint-binder)

(  (let name bindings e1 e2 ...)
(lambda (form p)
(begin-list p)
(display "let " p)
(pprint (cadr form) p)
(display " " p)
(pprint-bindings (caddr form) p)
(breakpoint p 'look-left 3 " ")
(pprint-vertical-list (cdddr form) p)
(end-list p))))

(define-pretty-printer (let*)
(  (let* bindings e1 e2 ...)
pprint-binder))

(define-pretty-printer (iterate)
(  (iterate bindings e1 e2 ...)
pprint-binder))

(define-pretty-printer (iterate*)
(  (iterate* bindings e1 e2 ...)
pprint-binder))

(define-pretty-printer (letrec)
(  (letrec bindings e1 e2 ...)
pprint-binder))

(define-pretty-printer (if)
(  (if pred cons alt)
(lambda (form p)
(begin-list p)
(display "if " p)
(pprint (cadr form) p)
(breakpoint p 'united 3 " ")
(pprint (caddr form) p)
(breakpoint p 'united 3 " ")
(pprint (cadddr form) p)
(end-list p)))

(  (if pred cons)
(lambda (form p)
(begin-list p)
(display "if " p)
(pprint (cadr form) p)
(breakpoint p 'look-left 3 " ")
(pprint (caddr form) p)
(end-list p))))

(define-pretty-printer (define)
(  (define (form ...) e1 e2 ...)
(lambda (form p)
(begin-list p)
(display "define " p)
(pprint (cadr form) p)
(breakpoint p 'always 3)
(pprint-vertical-list (cddr form) p)
(end-list p)))

(  (define name expr)
(lambda (form p)
(begin-list p)
(display "define " p)
(pprint (cadr form) p)
(breakpoint p 'width 3 " ")
(pprint (caddr form) p)
(end-list p))))

(define-pretty-printer (quote)
(  (quote e)
(lambda (form p)
(display "'" p)
(pprint (cadr form) p))))

(define-pretty-printer (quasiquote)
(  (quasiquote e)
(lambda (form p)
(display "`" p)
(pprint (cadr form) p))))

(define-pretty-printer (unquote)
(  (unquote e)
(lambda (form p)
(display "," p)
(pprint (cadr form) p))))

(define-pretty-printer (unquote-splicing)
(  (unquote-splicing e)
(lambda (form p)
(display ",@" p)
(pprint (cadr form) p))))

(define-pretty-printer (extend-syntax)
(  (extend-syntax (name keys ...)
(pattern fender-or-expansion more ...) ...)
pprint-extend-syntax))

(define-pretty-printer (define-pretty-printer)
(  (define-pretty-printer (name keys ...)
(pattern function) ...)
pprint-extend-syntax))

(define (pprint-extend-syntax form p)
(begin-list p)
(write (car form) p)
(display " " p)
(pprint (cadr form) p)
(breakpoint p 'always 3)
(begin-structure p)
(display "(" p)
(pprint-vertical-list (caddr form) p)
(display ")" p)
(for-each (lambda (clause)
          (newline p)
          (newline p)
          (display "(" p)
          (pprint-vertical-list clause p)
          (display ")" p))
       (cdddr form))
(end-structure p)
(end-list p))

(define-pretty-printer (with)        ; For use inside EXTEND-SYNTAX forms
(  (with bindings e1 e2 ...)
pprint-binder))

(define-pretty-printer (lambda)
(  (lambda args e1 e2 ...)
(lambda (form p)
(begin-list p)
(display "lambda " p)
(pprint (cadr form) p)
(breakpoint p 'width 3 " ")
(pprint-vertical-list (cddr form) p)
(end-list p))))

(define-pretty-printer (begin)
(  (begin e1 e2 ...)
(lambda (form p)
(begin-list p)
(display "begin" p)
(breakpoint p 'width 3 " ")
(pprint-vertical-list (cdr form) p)
(end-list p))))

(define (pprint-call/cc form p)
(begin-list p)
(write (car form) p)
(breakpoint p 'width 3 " ")
(pprint-vertical-list (cdr form) p)
(end-list p))

(define-pretty-printer (call-with-current-continuation)
(  (call-with-current-continuation e)
pprint-call/cc))

(define-pretty-printer (call/cc)
(  (call/cc e)
pprint-call/cc))

(define (pprint-env-ref form p)
(define (ok-env-ref? form)
(or (symbol? form)
 (and (syntax-match? '(environment-ref)
                  '(environment-ref env 'name)
                  form)
   (symbol? (cadr (caddr form)))
(ok-env-ref? (cadr form)))))

(if (ok-env-ref? form)
(let loop ((form form))
(cond
((symbol? form)
(write form p))
(else
(loop (cadr form))
(display ":" p)
(write (cadr (caddr form)) p))))
(default-pair-printer form p)))

(define-pretty-printer (environment-ref)
((environment-ref env name)
pprint-env-ref))