224 lines
6.8 KiB
Scheme
224 lines
6.8 KiB
Scheme
;;;; A Very Tiny Pretty Printer (VtPP) for Mini-Scheme
|
|
;;;
|
|
;;; Date written 28-Nov-1989 by Akira Kida
|
|
;;; Date revised 24-Jan-1990 by Atsushi Moriwaki
|
|
;;; Date revised 17-May-1994 by Akira Kida
|
|
;;;
|
|
|
|
;; Columns of display device.
|
|
(define *pp-display-width* 80)
|
|
|
|
;; Margin of display-width
|
|
;; 8 means 80% of *pp-display-width*, i.e., if *pp-display-width* is
|
|
;; set to 80, the result is 64. The prety-print procedure will watch
|
|
;; for the current output column, and if the output seem to exceed
|
|
;; this limit, it tries to insert newlines somewhere in the current
|
|
;; sub-list. However, sometimes this may fail, and output may get even
|
|
;; longer than *pp-display-width*. This is a feature, not a bug. :-)
|
|
(define *pp-display-margin* 8)
|
|
|
|
;; Number of elements will possibly be displayed in one line.
|
|
;; pretty-print will never display more then this number of elements
|
|
;; on a single physical line. There is no feature around this. :-)
|
|
(define *pp-display-elements* 12)
|
|
|
|
|
|
;;; print n spaces
|
|
(define (spaces n)
|
|
(if (positive? n)
|
|
(begin
|
|
(display " ")
|
|
(spaces (- n 1)))))
|
|
|
|
|
|
;;; get definition of a procedure or a macro
|
|
(define (getd symbol)
|
|
(if (not (symbol? symbol))
|
|
(error "getd: expects symbol value"))
|
|
(let ((code (eval symbol)))
|
|
(cond
|
|
;; since a closure is also a macro, we should check macro first.
|
|
((macro? code)
|
|
(let ((def (get-closure-code code)))
|
|
(cons 'macro (list symbol def))))
|
|
((closure? code)
|
|
(let ((def (get-closure-code code)))
|
|
(cons
|
|
'define
|
|
(cons
|
|
(cons symbol (car (cdr def)))
|
|
(cdr (cdr def))))))
|
|
(else
|
|
;; if symbol is not a macro nor closure,
|
|
;; we shall generate error function call code.
|
|
(list 'error "Not a S-Expression procedure:" (list 'quote symbol))))))
|
|
|
|
|
|
;;; pretty printer main procedure
|
|
;;;
|
|
(define (pretty-print a-list)
|
|
; List of procedures which need exceptional handling.
|
|
; Structure or each element in the list is
|
|
;
|
|
; (name . special-indentation)
|
|
;
|
|
; where name is a symbol and
|
|
; special-indentation is an integer.
|
|
;
|
|
; #1 Standard format, non special case.
|
|
; (proc
|
|
; arg1
|
|
; arg2
|
|
; arg3)
|
|
;
|
|
; #2 Format for special-indentation == 0
|
|
; (proc arg1
|
|
; arg2
|
|
; arg3)
|
|
;
|
|
; #3 Format for special-indentation == 1
|
|
; (proc arg1
|
|
; arg2
|
|
; arg3)
|
|
;
|
|
; #4 Format for let style = 2
|
|
; (let ((x .....)
|
|
; (y .....))
|
|
; <....>
|
|
; <....>)
|
|
;
|
|
(define exception
|
|
'((lambda . 0) (if . 0) (and . 1)
|
|
(or . 1) (let . 2) (case . 0)
|
|
(define . 0) (macro . 0)
|
|
(map . 0) (apply . 0)
|
|
(eq? . 1) (eqv? . 1) (set! . 0)
|
|
(let* . 2) (letrec . 2)
|
|
(* . 1) (/ . 1) (+ . 1) (- . 1)
|
|
(= . 1) (< . 1) (> . 1) (<= . 1) (>= . 1)
|
|
(do . 2)
|
|
(call-with-input-file . 0) (call-with-output-file . 0)))
|
|
; special quote abbrev.
|
|
(define special
|
|
'((quote 1 . "'") (quasiquote 1 . "`")
|
|
(unquote 2 . ",") (unquote-splicing 2 . ",@")))
|
|
; calculate appropriate margins
|
|
(define pp-margin (/ (* *pp-display-width* *pp-display-margin*) 10))
|
|
; check whether the number of elements exceeds n or not.
|
|
(define (less-than-n-elements? a-list n)
|
|
; count elements in a-list at most (n+1)
|
|
(define (up-to-nth a-list n c)
|
|
(cond
|
|
((null? a-list) c)
|
|
((pair? a-list)
|
|
(set! c (up-to-nth (car a-list) n c))
|
|
(if (< n c)
|
|
c
|
|
(up-to-nth (cdr a-list) n c)))
|
|
(else (+ c 1))))
|
|
(< (up-to-nth a-list n 0) n))
|
|
; check if the length is fit within n columns or not.
|
|
(define (fit-in-n-width? a-list n)
|
|
(< (print-width a-list) n))
|
|
; indent and pretty-print
|
|
(define (do-pp a-list col)
|
|
(spaces col)
|
|
(pp-list a-list col 2))
|
|
;; main logic.
|
|
(define (pp-list a-list col step)
|
|
(cond
|
|
((atom? a-list) (write a-list)) ; atom
|
|
((and (assq (car a-list) special)
|
|
(pair? (cdr a-list))
|
|
(null? (cddr a-list))) ; check for proper quote etc.
|
|
(let ((s (assq (car a-list) special)))
|
|
(display (cddr s)) ; display using abbrev.
|
|
(pp-list
|
|
(cadr a-list)
|
|
(+ col (- (print-width (cddr s)) 2))
|
|
(cadr s))))
|
|
((and (less-than-n-elements? a-list *pp-display-elements*)
|
|
(fit-in-n-width? a-list (- pp-margin col)))
|
|
(display "(")
|
|
(do-pp (car a-list) 0)
|
|
(pp-args #f (cdr a-list) 1))
|
|
(else ; long list.
|
|
(let* ((sym (car a-list))
|
|
(ex-col (assq sym exception)))
|
|
(if (pair? ex-col) ; check for exception.,
|
|
(case (cdr ex-col)
|
|
((0 1)
|
|
(display "(")
|
|
(write sym)
|
|
(display " ")
|
|
(pp-list (cadr a-list) (+ col 2 (print-width sym)) 2)
|
|
(pp-args
|
|
#t
|
|
(cdr (cdr a-list))
|
|
(+ col 2 (if (zero? (cdr ex-col)) 0 (print-width sym)))))
|
|
((2)
|
|
(display "(")
|
|
(write sym)
|
|
(display " ")
|
|
(if (symbol? (cadr a-list))
|
|
(begin ; named let
|
|
(write (cadr a-list))
|
|
(display " ")
|
|
(pp-list
|
|
(caddr a-list)
|
|
(+ col 3 (print-width sym) (print-width (cadr a-list)))
|
|
1)
|
|
(pp-args #t (cdddr a-list) (+ col 2)))
|
|
(begin ; usual let
|
|
(pp-list (cadr a-list) (+ col 2 (print-width sym)) 1)
|
|
(pp-args #t (cddr a-list) (+ col 2)))))
|
|
(else
|
|
(error "Illegal exception")))
|
|
(begin ; normal case.
|
|
(display "(")
|
|
(pp-list (car a-list) (+ col 1) 2)
|
|
(pp-args #t (cdr a-list) (+ col step))))))))
|
|
;; display arguments
|
|
(define (pp-args nl a-list col)
|
|
(cond
|
|
((null? a-list) (display ")"))
|
|
((pair? a-list)
|
|
(if nl (newline))
|
|
(do-pp (car a-list) col)
|
|
(pp-args nl (cdr a-list) col))
|
|
(else
|
|
(display " . ")
|
|
(write a-list)
|
|
(display ")"))))
|
|
;;
|
|
;; main of pretty-print begins here.
|
|
;;
|
|
(do-pp a-list 0)
|
|
(newline))
|
|
|
|
|
|
|
|
;;; pretty print procedure(s)/macro(s).
|
|
;;; (pretty 'a-symbol) ; pretty print a procedure or macro
|
|
;;; (pretty '(sym1 sym2 ...)) ; pretty print procedures and/or macros
|
|
(define (pretty symbols)
|
|
(if (pair? symbols)
|
|
(for-each
|
|
(lambda (x) (pretty-print (getd x)) (newline))
|
|
symbols)
|
|
(pretty-print (getd symbols))))
|
|
|
|
|
|
|
|
;;; pretty print user-interface
|
|
;;;
|
|
;;; usage:
|
|
;;; (pp sym1 sym2 ...) ; obtain procedure/macro definitions in sequence
|
|
;;;
|
|
;;; Note: pp never evaluate its argument, so you do not have to specify
|
|
;;; (pp 'proc-name). Use (pp proc-name) instead.
|
|
;;;
|
|
(macro pp (lambda (pp-macro)
|
|
`(pretty ',(cdr pp-macro))))
|
|
|