[_CDCSL_93-16_]<1>Cedar>release>TendrilsScheme>PPrint.scheme

;;; PPrint.scheme

;;; 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)

(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)

(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))