542 lines
13 KiB
Common Lisp
542 lines
13 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: pp.s
|
||
|
||
; Last Revision: 29-August-85 1600ct
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; SCHEME 84 -- PCS Compiler -- July 1984 ;
|
||
; ;
|
||
; David Bartley ;
|
||
; ;
|
||
; PrettyPrinter ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
|
||
(define pp ; PP
|
||
(lambda (exp . args)
|
||
(let ((port (car args))
|
||
(margin (or (cadr args) 72)))
|
||
(fluid-let
|
||
((output-port
|
||
(cond ((null? port) (fluid output-port))
|
||
((port? port) port)
|
||
((string? port)
|
||
(let ((p (open-output-file port)))
|
||
(set-line-length! (max margin (line-length p)) p)
|
||
p))
|
||
(else 'CONSOLE))))
|
||
(%pretty-printer exp
|
||
(min margin (line-length (fluid output-port))))
|
||
(when (string? port)
|
||
(close-output-port (fluid output-port)))
|
||
*the-non-printing-object*))))
|
||
|
||
|
||
(define %pp-me ; %PP-ME
|
||
(lambda (e)
|
||
(let ((m (and (pair? e)
|
||
(getprop (car e) 'PCS*MACRO))))
|
||
(cond ((null? m)
|
||
e)
|
||
((pair? m) ; alias
|
||
(cons (cdr m)(cdr e)))
|
||
(else ; macro
|
||
(pp (m e)))))))
|
||
|
||
|
||
(syntax (%pp-set-pattern id pat) ; %PP-SET-PATTERN
|
||
(PUTPROP id pat '%PRETTY-PRINTER-PATTERN))
|
||
|
||
|
||
(syntax (%pp-get-pattern id) ; %PP-GET-PATTERN
|
||
(GETPROP id '%PRETTY-PRINTER-PATTERN))
|
||
|
||
|
||
;;;
|
||
;;; Pretty Printer Pattern Definitions
|
||
;;;
|
||
|
||
(begin
|
||
(let ((pattern '(KEY . (2 . V-TAIL)))) ; BEGIN style
|
||
(%pp-set-pattern 'BEGIN pattern)
|
||
(%pp-set-pattern 'BEGIN0 pattern)
|
||
(%pp-set-pattern 'SEQUENCE pattern))
|
||
|
||
(let ((pattern '(NEAT (() . EXP) . (2 . V-TAIL)))) ; DEFINE style
|
||
(%pp-set-pattern 'ALIAS pattern)
|
||
(%pp-set-pattern 'ACCESS pattern)
|
||
(%pp-set-pattern 'APPLY-IF pattern)
|
||
(%pp-set-pattern 'DEFINE pattern)
|
||
(%pp-set-pattern 'DEFINE-INTEGRABLE
|
||
pattern)
|
||
(%pp-set-pattern 'MACRO pattern)
|
||
(%pp-set-pattern 'REC pattern)
|
||
(%pp-set-pattern 'SET-FLUID! pattern)
|
||
(%pp-set-pattern 'SYNTAX pattern))
|
||
|
||
(let ((pattern '(KEY (() . BVL) . (2 . V-TAIL)))) ; LAMBDA style
|
||
(%pp-set-pattern 'LAMBDA pattern)
|
||
(%pp-set-pattern 'FLUID-LAMBDA pattern)
|
||
(%pp-set-pattern 'NAMED-LAMBDA pattern))
|
||
|
||
(let ((pattern '(KEY (3 . TUPLES) . (2 . V-TAIL)))) ; LETREC style
|
||
(%pp-set-pattern 'LETREC pattern))
|
||
|
||
(let ((pattern '(0 . LET))) ; LET style
|
||
(%pp-set-pattern 'LET pattern)
|
||
(%pp-set-pattern 'LET* pattern)
|
||
(%pp-set-pattern 'FLUID-LET pattern))
|
||
|
||
;;(let ((pattern '(NEAT . (() . V-TAIL)))) ; SET! style
|
||
;; (%pp-set-pattern 'SET! pattern)
|
||
;; (%pp-set-pattern 'IF pattern) ; use default (0 . call)
|
||
;; (%pp-set-pattern 'WHEN pattern) ; for these short names
|
||
;; (%pp-set-pattern 'AND pattern)
|
||
;; (%pp-set-pattern 'OR pattern))
|
||
|
||
(%pp-set-pattern 'COND '(KEY . (() . COND-TAIL)))
|
||
|
||
(%pp-set-pattern 'CASE '(KEY (() . EXP) . (2 . CASE-TAIL)))
|
||
|
||
(%pp-set-pattern 'DO '(KEY (() . TUPLES)
|
||
(4 . COMB)
|
||
. (2 . V-TAIL)))
|
||
|
||
(%pp-set-pattern '%PP-FUN-CALL '(0 . CALL)) ; arbitrary function calls
|
||
|
||
(%pp-set-pattern '%PP-COMBINATION '(0 . COMB)) ; arbitrary combinations
|
||
'())
|
||
|
||
;;; --------------------------------------------------------------------------
|
||
|
||
|
||
(define %pretty-printer
|
||
(lambda (expression margin)
|
||
(letrec
|
||
|
||
;-------!
|
||
|
||
((cp margin) ; current position
|
||
|
||
(miser-cp (max 20 (quotient margin 2)))
|
||
|
||
(nice-fit (max 50 (quotient margin 2)))
|
||
|
||
(call-pat (%pp-get-pattern '%PP-FUN-CALL))
|
||
|
||
(comb-pat (%pp-get-pattern '%PP-COMBINATION))
|
||
|
||
;;
|
||
;; PP-EXP pretty-prints expression X at the current position
|
||
;;
|
||
|
||
(pp-exp
|
||
(lambda (x)
|
||
(cond ((atom? x) ; X = atom ?
|
||
(pp-atom x))
|
||
|
||
((atom? (cdr x)) ; X = (atom) or (atom . atom) ?
|
||
(pp-block x cp))
|
||
|
||
((pair? (car x)) ; X = ((...)...) ?
|
||
(pp-by-pattern x cp comb-pat))
|
||
|
||
((and (null? (cddr x)) ; X = (quote ...)
|
||
(memq (car x) '(QUOTE
|
||
QUASIQUOTE
|
||
%QQ-C %QQ-CA %QQ-CD)))
|
||
(pp-block x cp))
|
||
|
||
((and (pair? (cddr x)) ; X = (... . ,value)
|
||
(null? (cdddr x))
|
||
(eq? (cadr x) '%QQ-C))
|
||
(pp-block x cp))
|
||
|
||
((symbol? (car x)) ; X = (symbol . args) ?
|
||
(pp-by-pattern x cp
|
||
(or (%pp-get-pattern (car x))
|
||
call-pat)))
|
||
|
||
(else
|
||
(pp-block x cp))))) ; X = (?)
|
||
|
||
|
||
;; PP-BY-PATTERN pretty-prints expression X at the current position
|
||
;; (passed in IP) using the pattern PAT
|
||
;;
|
||
;; Assumptions:
|
||
;; PAT is a valid pattern
|
||
;; X is a pair and (cdr X) is a pair
|
||
;; (car X) is an atom
|
||
;; X might not be properly structured according to PAT
|
||
|
||
(pp-by-pattern
|
||
(lambda (x ip pat) ; ip = new base for -tabs
|
||
(cond
|
||
((number? (car pat)) ; PAT = (tab . fun) ?
|
||
(move (- ip (car pat)))
|
||
(pp-by-function x (cdr pat)))
|
||
|
||
((null? (car pat)) ; PAT = (() . fun) ?
|
||
(move (- cp 1))
|
||
(pp-by-function x (cdr pat)))
|
||
|
||
((and (eq? (car pat) 'NEAT)
|
||
(all-fits-nicely? x)) ; X fits neatly on this line?
|
||
(pp-block x cp))
|
||
|
||
;; ((and (eq? (car pat) 'ALL)
|
||
;; (all-fits? x)) ; X fits on this line?
|
||
;; (pp-block x cp))
|
||
|
||
(else ; PAT = (KEY ...)
|
||
(prin-op x) ; emit paren and keyword
|
||
(pp-by-pat-tail (cdr x)
|
||
ip ; emit the rest of X
|
||
(cdr pat)))
|
||
)))
|
||
|
||
(pp-by-pat-tail
|
||
(lambda (x ip pat)
|
||
(cond ((or (atom? x) ; X and PAT out of synch?
|
||
(null? pat))
|
||
(pp-v-tail x)) ; yes, use the default method
|
||
((eq? (car x) '%QQ-C)
|
||
(pp-block-tail x ip))
|
||
(else
|
||
(let ((pat1 (car pat))
|
||
(pat* (cdr pat)))
|
||
(if (atom? pat1)
|
||
(begin ; PAT matches the tail
|
||
(move (if (null? pat1)
|
||
(- cp 1) ; PAT = (() . fun)
|
||
(- ip pat1))) ; PAT = (num . fun)
|
||
(pp-by-function x pat*))
|
||
(let ((tab1 (car pat1))
|
||
(fun1 (cdr pat1)))
|
||
(move (if (null? tab1)
|
||
(- cp 1) ; PAT = ((() . fun) ...)
|
||
(- ip tab1))) ; PAT = ((num . fun)...)
|
||
(pp-by-function
|
||
(car x) fun1) ; pp the car
|
||
(pp-by-pat-tail ; pp the cdr
|
||
(cdr x) ip pat*))))))))
|
||
|
||
(pp-by-function
|
||
(lambda (x fun)
|
||
(if (null? fun)
|
||
(pp-call x)
|
||
(case fun
|
||
(exp (pp-exp x))
|
||
(v-tail (pp-v-tail x))
|
||
(call (pp-call x))
|
||
(bvl (pp-block x cp))
|
||
(tuples (pp-tuples x))
|
||
(let (pp-let x))
|
||
(cond-tail (pp-cond-tail x))
|
||
(case-tail (pp-case-tail x))
|
||
(comb (pp-comb x))
|
||
(else (pp-call x))))))
|
||
|
||
(pp-let
|
||
(lambda (x)
|
||
(if (atom? x)
|
||
(pp-atom x)
|
||
(let ((p cp))
|
||
(prin-op x)
|
||
(move (- cp 1))
|
||
(when (and (cadr x) ; named LET ?
|
||
(atom? (cadr x)))
|
||
(set! x (cdr x))
|
||
(pp-atom (car x)) ; name
|
||
(move (- p 5)))
|
||
(if (pair? (cdr x))
|
||
(begin
|
||
(pp-tuples (cadr x)) ; pairs
|
||
(move (- p 2))
|
||
(pp-v-tail (cddr x))) ; body
|
||
(pp-atomic-tail (cdr x)))))))
|
||
|
||
(pp-call
|
||
(lambda (x)
|
||
(cond ((or (atom? x)
|
||
(null? (cdr x)) ; no arguments
|
||
(all-fits-nicely? x))
|
||
(pp-block x cp))
|
||
((and (symbol? (car x))
|
||
( < (print-length (car x)) 5))
|
||
(pp-hang x))
|
||
(else
|
||
(let ((p cp))
|
||
(prin-op x)
|
||
(move (- p 3))
|
||
(pp-v-tail (cdr x)))))))
|
||
|
||
(pp-comb
|
||
(lambda (x)
|
||
(cond ((or (atom? x)
|
||
(and (pair? (cdr x)) ; length = 2 ?
|
||
(null? (cddr x))
|
||
(all-fits-nicely? x)))
|
||
(pp-block x cp))
|
||
((and (symbol? (car x))
|
||
( < (print-length (car x)) 5))
|
||
(pp-hang x))
|
||
(else
|
||
(pp-v x)))))
|
||
|
||
(pp-case-tail
|
||
(lambda (x)
|
||
(if (atom? x)
|
||
(pp-atomic-tail x)
|
||
(let ((p cp)
|
||
(next (car x))
|
||
(rest (cdr x)))
|
||
(pp-case-item next)
|
||
(if (null? rest)
|
||
(pp-atomic-tail rest)
|
||
(begin
|
||
(move p)
|
||
(pp-case-tail rest)))))))
|
||
|
||
(pp-case-item
|
||
(lambda (x)
|
||
(cond ((atom? x)
|
||
(pp-atom x))
|
||
((all-fits-nicely? x)
|
||
(pp-block x cp))
|
||
(else
|
||
(display "(")
|
||
(set! cp (- cp 1))
|
||
(let ((p cp))
|
||
(pp-block (car x) cp)
|
||
(move p)
|
||
(pp-v-tail (cdr x)))))))
|
||
|
||
(pp-cond-tail
|
||
(lambda (x)
|
||
(if (atom? x)
|
||
(pp-atomic-tail x)
|
||
(let ((p cp)
|
||
(next (car x))
|
||
(rest (cdr x)))
|
||
(pp-comb next)
|
||
(if (null? rest)
|
||
(pp-atomic-tail rest)
|
||
(begin
|
||
(move p)
|
||
(pp-cond-tail rest)))))))
|
||
|
||
(pp-tuples
|
||
(lambda (x)
|
||
(if (and x (atom? x))
|
||
(pp-atom x)
|
||
(begin
|
||
(display "(")
|
||
(set! cp (- cp 1))
|
||
(pp-tuples-tail x)))))
|
||
|
||
(pp-tuples-tail
|
||
(lambda (x)
|
||
(if (atom? x)
|
||
(pp-atomic-tail x)
|
||
(let ((p cp)
|
||
(next (car x))
|
||
(rest (cdr x)))
|
||
(if (or (atom? next)
|
||
(all-fits-nicely? next))
|
||
(pp-block next cp)
|
||
(pp-comb next))
|
||
(if (null? rest)
|
||
(pp-atomic-tail rest)
|
||
(begin
|
||
(move p)
|
||
(pp-tuples-tail rest)))))))
|
||
|
||
(pp-hang
|
||
(lambda (x)
|
||
(if (atom? x)
|
||
(pp-atom x)
|
||
(begin
|
||
(prin-op x)
|
||
(move (- cp 1))
|
||
(pp-v-tail (cdr x))))))
|
||
|
||
(pp-v
|
||
(lambda (x)
|
||
(if (and x (atom? x))
|
||
(pp-atom x)
|
||
(begin
|
||
(display "(")
|
||
(set! cp (- cp 1))
|
||
(pp-v-tail x)))))
|
||
|
||
(pp-v-tail
|
||
(lambda (x)
|
||
(cond ((atom? x)
|
||
(pp-atomic-tail x))
|
||
((eq? (car x) '%QQ-C)
|
||
(pp-block-tail x cp))
|
||
(else
|
||
(let ((p cp)
|
||
(next (car x))
|
||
(rest (cdr x)))
|
||
(pp-exp next)
|
||
(if (null? rest)
|
||
(pp-atomic-tail rest)
|
||
(begin
|
||
(move p)
|
||
(pp-v-tail rest))))))))
|
||
|
||
(pp-block
|
||
(lambda (x ip)
|
||
(if (atom? x)
|
||
(pp-atom x)
|
||
(let ((quasi (assq (car x)
|
||
'((QUOTE . "'")
|
||
(QUASIQUOTE . "`")
|
||
(%QQ-C . ",")
|
||
(%QQ-CA . ",@")
|
||
(%QQ-CD . ",.")))))
|
||
(cond ((and quasi
|
||
(pair? (cdr x))
|
||
(null? (cddr x)))
|
||
(let* ((prefix (cdr quasi))
|
||
(len (string-length prefix)))
|
||
(display prefix)
|
||
(set! cp (- cp len))
|
||
(pp-block (cadr x) (- ip len))))
|
||
(else
|
||
(display "(")
|
||
(set! cp (- cp 1))
|
||
(pp-block-tail x (- ip 1))) )))))
|
||
|
||
(pp-block-tail
|
||
(lambda (x ip)
|
||
(cond ((atom? x)
|
||
(pp-atomic-tail x))
|
||
((and (eq? (car x) '%QQ-C)
|
||
(pair? (cdr x))
|
||
(null? (cddr x)))
|
||
(display " . ,")
|
||
(set! cp (- cp 4))
|
||
(pp-block (cadr x)(- ip 4))
|
||
(display ")")
|
||
(set! cp (- cp 1)))
|
||
(else
|
||
(let* ((carx (car x))
|
||
(fits (all-fits? carx)))
|
||
(cond ((and (not fits)
|
||
(>? ip cp))
|
||
(move ip)
|
||
(pp-block-tail x ip))
|
||
(else
|
||
(if fits ; print the CAR
|
||
(pp-block carx ip)
|
||
(begin
|
||
(pp-exp carx)
|
||
(move ip)))
|
||
(if (atom? (cdr x)) ; print the CDR
|
||
(pp-atomic-tail (cdr x))
|
||
(begin
|
||
(move (- cp 1))
|
||
(pp-block-tail (cdr x) ip))))))))))
|
||
|
||
(pp-atom
|
||
(lambda (x)
|
||
(write x)
|
||
(set! cp (- margin
|
||
(- (current-column) 1)))))
|
||
|
||
(pp-atomic-tail
|
||
(lambda (x)
|
||
(cond ((null? x)
|
||
(display ")")
|
||
(set! cp (- cp 1)))
|
||
(else
|
||
(display " . ")
|
||
(set! cp (- cp 3))
|
||
(pp-atom x)
|
||
(display ")")
|
||
(set! cp (- cp 1))))))
|
||
|
||
(prin-op
|
||
(lambda (x)
|
||
(let ((op (car x))
|
||
(p cp))
|
||
(display "(")
|
||
(set! cp (- cp 1))
|
||
(pp-block op cp)
|
||
;; (when ( < cp miser-cp) ;; causes a bug??
|
||
;; (move (- p 2)))
|
||
)))
|
||
|
||
(move
|
||
(lambda (p)
|
||
(when ( < cp p)
|
||
(newline) ; move left
|
||
(set! cp margin))
|
||
(when ( > cp p)
|
||
(let ((cp4 (- cp 4))) ; move right
|
||
(if ( >= cp4 p)
|
||
(begin
|
||
(display " ")
|
||
(set! cp cp4))
|
||
(begin
|
||
(display " ")
|
||
(set! cp (- cp 1)))))
|
||
(move p))))
|
||
|
||
(all-fits?
|
||
(lambda (x)
|
||
(fits-in? x cp 0)))
|
||
|
||
(all-fits-nicely?
|
||
(lambda (x)
|
||
(fits-in? x (min cp nice-fit) 0)))
|
||
|
||
(fits-in? ; returns length[X] if <= SIZE
|
||
(lambda (x space acc) ; returns #!FALSE otherwise
|
||
(cond ((pair? x)
|
||
(fits-in-tail? x space acc))
|
||
((or (symbol? x) (number? x) (string? x)
|
||
(char? x) (null? x))
|
||
(let ((len (print-length x))) ; broken
|
||
(and ( >= space len)
|
||
(+ acc len))))
|
||
(else #!false))))
|
||
|
||
(fits-in-tail?
|
||
(lambda (x space acc)
|
||
(cond ((null? acc) #!false)
|
||
(( < space 2) #!false)
|
||
((null? x) (+ acc 1))
|
||
((atom? x) (fits-in? x (- space 4)(+ acc 4)))
|
||
(else
|
||
(let ((len (fits-in? (car x) space 0)))
|
||
(and len
|
||
(fits-in-tail? (cdr x)
|
||
(- (- space len) 1)
|
||
(+ (+ acc len) 1))))))))
|
||
|
||
(make-printable
|
||
(lambda (obj)
|
||
(cond ((closure? obj)
|
||
(apply-if (assq 'SOURCE (%reify obj 0))
|
||
(lambda (entry)
|
||
(display obj)
|
||
(display " =")
|
||
(newline)
|
||
(cdr entry))
|
||
obj))
|
||
;; other special cases ...
|
||
(else obj))))
|
||
|
||
;-------!
|
||
)
|
||
(begin
|
||
(pp-exp (make-printable expression))
|
||
*the-non-printing-object*))))
|
||
|