118 lines
2.7 KiB
Scheme
118 lines
2.7 KiB
Scheme
|
;;; -*-Scheme-*-
|
||
|
|
;;;
|
||
|
|
;;; Trivial pretty-printer
|
||
|
|
|
||
|
|
(provide 'pp)
|
||
|
|
|
||
|
|
(define pp)
|
||
|
|
|
||
|
|
(let ((max-pos 55) (pos 0) (tab-stop 8))
|
||
|
|
|
||
|
|
(put 'lambda 'special #t)
|
||
|
|
(put 'macro 'special #t)
|
||
|
|
(put 'define 'special #t)
|
||
|
|
(put 'define-macro 'special #t)
|
||
|
|
(put 'define-structure 'special #t)
|
||
|
|
(put 'fluid-let 'special #t)
|
||
|
|
(put 'let 'special #t)
|
||
|
|
(put 'let* 'special #t)
|
||
|
|
(put 'letrec 'special #t)
|
||
|
|
(put 'case 'special #t)
|
||
|
|
|
||
|
|
(put 'call-with-current-continuation 'long #t)
|
||
|
|
|
||
|
|
(put 'quote 'abbr "'")
|
||
|
|
(put 'quasiquote 'abbr "`")
|
||
|
|
(put 'unquote 'abbr ",")
|
||
|
|
(put 'unquote-splicing 'abbr ",@")
|
||
|
|
|
||
|
|
(set! pp (lambda (x)
|
||
|
|
(set! pos 0)
|
||
|
|
(cond ((eq? (type x) 'compound)
|
||
|
|
(set! x (procedure-lambda x)))
|
||
|
|
((eq? (type x) 'macro)
|
||
|
|
(set! x (macro-body x))))
|
||
|
|
(fluid-let ((garbage-collect-notify? #f))
|
||
|
|
(pp-object x))
|
||
|
|
#v))
|
||
|
|
|
||
|
|
(define (flat-size s)
|
||
|
|
(fluid-let ((print-length 50) (print-depth 10))
|
||
|
|
(string-length (format #f "~a" s))))
|
||
|
|
|
||
|
|
(define (pp-object x)
|
||
|
|
(if (or (null? x) (pair? x))
|
||
|
|
(pp-list x)
|
||
|
|
(if (void? x)
|
||
|
|
(display "#v")
|
||
|
|
(write x))
|
||
|
|
(set! pos (+ pos (flat-size x)))))
|
||
|
|
|
||
|
|
(define (pp-list x)
|
||
|
|
(if (and (pair? x)
|
||
|
|
(symbol? (car x))
|
||
|
|
(string? (get (car x) 'abbr))
|
||
|
|
(= 2 (length x)))
|
||
|
|
(let ((abbr (get (car x) 'abbr)))
|
||
|
|
(display abbr)
|
||
|
|
(set! pos (+ pos (flat-size abbr)))
|
||
|
|
(pp-object (cadr x)))
|
||
|
|
(if (> (flat-size x) (- max-pos pos))
|
||
|
|
(pp-list-vertically x)
|
||
|
|
(pp-list-horizontally x))))
|
||
|
|
|
||
|
|
(define (pp-list-vertically x)
|
||
|
|
(maybe-pp-list-vertically #t x))
|
||
|
|
|
||
|
|
(define (pp-list-horizontally x)
|
||
|
|
(maybe-pp-list-vertically #f x))
|
||
|
|
|
||
|
|
(define (maybe-pp-list-vertically vertical? list)
|
||
|
|
(display "(")
|
||
|
|
(set! pos (1+ pos))
|
||
|
|
(if (null? list)
|
||
|
|
(begin
|
||
|
|
(display ")")
|
||
|
|
(set! pos (1+ pos)))
|
||
|
|
(let ((pos1 pos))
|
||
|
|
(pp-object (car list))
|
||
|
|
(if (and vertical?
|
||
|
|
(or
|
||
|
|
(and (pair? (car list))
|
||
|
|
(not (null? (cdr list))))
|
||
|
|
(and (symbol? (car list))
|
||
|
|
(get (car list) 'long))))
|
||
|
|
(indent-newline (1- pos1)))
|
||
|
|
(let ((pos2 (1+ pos)) (key (car list)))
|
||
|
|
(let tail ((flag #f) (l (cdr list)))
|
||
|
|
(cond ((pair? l)
|
||
|
|
(if flag
|
||
|
|
(indent-newline
|
||
|
|
(if (and (symbol? key) (get key 'special))
|
||
|
|
(1+ pos1)
|
||
|
|
pos2))
|
||
|
|
(display " ")
|
||
|
|
(set! pos (1+ pos)))
|
||
|
|
(pp-object (car l))
|
||
|
|
(tail vertical? (cdr l)))
|
||
|
|
(else
|
||
|
|
(cond ((not (null? l))
|
||
|
|
(display " . ")
|
||
|
|
(set! pos (+ pos 3))
|
||
|
|
(if flag (indent-newline pos2))
|
||
|
|
(pp-object l)))
|
||
|
|
(display ")")
|
||
|
|
(set! pos (1+ pos)))))))))
|
||
|
|
|
||
|
|
(define (indent-newline x)
|
||
|
|
(newline)
|
||
|
|
(set! pos x)
|
||
|
|
(let loop ((i x))
|
||
|
|
(cond ((>= i tab-stop)
|
||
|
|
(display "\t")
|
||
|
|
(loop (- i tab-stop)))
|
||
|
|
((> i 0)
|
||
|
|
(display " ")
|
||
|
|
(loop (1- i)))))))
|
||
|
|
|