suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix some phase problems in program-processing programs

Browse Source 
svn: r10503

original commit: 44c5a757390775f2142a9f1dc2874ee41f285dcd
This commit is contained in:
Matthew Flatt 2008-06-29 15:11:20 +00:00
parent 6f6a582d5c
commit a3d4e9492f
1 changed files with 134 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

224
collects/mzlib/pretty.ss
View File

@ -793,6 +793,7 @@
(let* ([can-multi (and width (let* ([can-multi (and width
(not (size-hook obj display?)) (not (size-hook obj display?))
(or (pair? obj) (or (pair? obj)
(mpair? obj)
(vector? obj) (vector? obj)
(and (box? obj) print-box?) (and (box? obj) print-box?)
(and (custom-write? obj) (and (custom-write? obj)
@ -831,7 +832,10 @@
(expr-found pport graph-ref)) (expr-found pport graph-ref))
(pre-print pport obj) (pre-print pport obj)
(cond (cond
[(pair? obj) (pp-pair obj extra depth)] [(pair? obj) (pp-pair obj extra depth
pair? car cdr pair-open pair-close)]
[(mpair? obj) (pp-pair obj extra depth
mpair? mcar mcdr mpair-open mpair-close)]
[(vector? obj) [(vector? obj)
(out "#") (out "#")
(when print-vec-length? (when print-vec-length?
@ -858,22 +862,25 @@
;; Not possible to split obj across lines; so just write directly ;; Not possible to split obj across lines; so just write directly
(wr* pport obj depth display?)))) (wr* pport obj depth display?))))
(define (pp-expr expr extra depth) (define (pp-expr expr extra depth
(if (and (read-macro? expr pair? car cdr) apair? acar acdr open close)
(not (and found (hash-table-get found (cdr expr) #f)))) (if (and (read-macro? expr apair? acar acdr)
(equal? open "(")
(not (and found (hash-table-get found (acdr expr) #f))))
(begin (begin
(out (read-macro-prefix expr car)) (out (read-macro-prefix expr acar))
(pr (read-macro-body expr car cdr) (pr (read-macro-body expr acar acdr)
extra extra
pp-expr pp-expr
depth)) depth))
(let ((head (car expr))) (let ((head (acar expr)))
(if (or (and (symbol? head) (if (or (and (symbol? head)
(not (size-hook head display?))) (not (size-hook head display?)))
((pretty-print-remap-stylable) head)) ((pretty-print-remap-stylable) head))
(let ((proc (style head expr))) (let ((proc (style head expr apair? acar acdr)))
(if proc (if proc
(proc expr extra depth) (proc expr extra depth
apair? acar acdr open close)
(if (and #f (if (and #f
;; Why this special case? Currently disabled. ;; Why this special case? Currently disabled.
(> (string-length (> (string-length
@ -882,9 +889,12 @@
head head
((pretty-print-remap-stylable) head)))) ((pretty-print-remap-stylable) head))))
max-call-head-width)) max-call-head-width))
(pp-general expr extra #f #f #f pp-expr depth) (pp-general expr extra #f #f #f pp-expr depth
(pp-list expr extra pp-expr #t depth)))) apair? acar acdr open close)
(pp-list expr extra pp-expr #t depth))))) (pp-list expr extra pp-expr #t depth
apair? acar acdr open close))))
(pp-list expr extra pp-expr #t depth
apair? acar acdr open close)))))
(define (wr obj depth) (define (wr obj depth)
(wr* pport obj depth display?)) (wr* pport obj depth display?))
@ -892,44 +902,53 @@
;; (head item1 ;; (head item1
;; item2 ;; item2
;; item3) ;; item3)
(define (pp-call expr extra pp-item depth) (define (pp-call expr extra pp-item depth
(out "(") apair? acar acdr open close)
(wr (car expr) (dsub1 depth)) (out open)
(wr (acar expr) (dsub1 depth))
(let ([col (+ (ccol) 1)]) (let ([col (+ (ccol) 1)])
(pp-down ")" (cdr expr) col col extra pp-item #t #t depth))) (pp-down close (acdr expr) col col extra pp-item #t #t depth
apair? acar acdr open close)))
;; (head item1 item2 ;; (head item1 item2
;; item3 ;; item3
;; item4) ;; item4)
(define (pp-two-up expr extra pp-item depth) (define (pp-two-up expr extra pp-item depth
(out "(") apair? acar acdr open close)
(out open)
(let ([col (ccol)]) (let ([col (ccol)])
(wr (car expr) (dsub1 depth)) (wr (acar expr) (dsub1 depth))
(out " ") (out " ")
(wr (cadr expr) (dsub1 depth)) (wr (acar (acdr expr)) (dsub1 depth))
(pp-down ")" (cddr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth))) (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
apair? acar acdr open close)))
;; (head item1 ;; (head item1
;; item2 ;; item2
;; item3) ;; item3)
(define (pp-one-up expr extra pp-item depth) (define (pp-one-up expr extra pp-item depth
(out "(") apair? acar acdr open close)
(out open)
(let ([col (ccol)]) (let ([col (ccol)])
(wr (car expr) (dsub1 depth)) (wr (acar expr) (dsub1 depth))
(pp-down ")" (cdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth))) (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth
apair? acar acdr open close)))
;; (item1 ;; (item1
;; item2 ;; item2
;; item3) ;; item3)
(define (pp-list l extra pp-item check? depth) (define (pp-list l extra pp-item check? depth
(out "(") apair? acar acdr open close)
(out open)
(let ([col (ccol)]) (let ([col (ccol)])
(pp-down ")" l col col extra pp-item #f check? depth))) (pp-down close l col col extra pp-item #f check? depth
apair? acar acdr open close)))
(define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth) (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth
apair? acar acdr open close)
(let loop ([l l] [icol col1] [check? check-first?]) (let loop ([l l] [icol col1] [check? check-first?])
(check-expr-found (check-expr-found
l pport (and check? (pair? l)) l pport (and check? (apair? l))
(lambda (s) (lambda (s)
(indent col2) (indent col2)
(out ".") (out ".")
@ -944,11 +963,11 @@
(out closer)) (out closer))
(lambda () (lambda ()
(cond (cond
[(pair? l) [(apair? l)
(let ([rest (cdr l)]) (let ([rest (acdr l)])
(let ([extra (if (null? rest) (+ extra 1) 0)]) (let ([extra (if (null? rest) (+ extra 1) 0)])
(indent icol) (indent icol)
(pr (car l) extra pp-item (dsub1 depth)) (pr (acar l) extra pp-item (dsub1 depth))
(loop rest col2 check-rest?)))] (loop rest col2 check-rest?)))]
[(null? l) [(null? l)
(out closer)] (out closer)]
@ -959,12 +978,13 @@
(pr l (+ extra 1) pp-item (dsub1 depth)) (pr l (+ extra 1) pp-item (dsub1 depth))
(out closer)]))))) (out closer)])))))
(define (pp-general expr extra named? pp-1 pp-2 pp-3 depth) (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth
apair? acar acdr open close)
(define (tail1 rest col1 col3) (define (tail1 rest col1 col3)
(if (and pp-1 (pair? rest)) (if (and pp-1 (apair? rest))
(let* ((val1 (car rest)) (let* ((val1 (acar rest))
(rest (cdr rest)) (rest (acdr rest))
(extra (if (null? rest) (+ extra 1) 0))) (extra (if (null? rest) (+ extra 1) 0)))
(indent col3) (indent col3)
(pr val1 extra pp-1 depth) (pr val1 extra pp-1 depth)
@ -972,9 +992,9 @@
(tail2 rest col1 col3))) (tail2 rest col1 col3)))
(define (tail2 rest col1 col3) (define (tail2 rest col1 col3)
(if (and pp-2 (pair? rest)) (if (and pp-2 (apair? rest))
(let* ((val1 (car rest)) (let* ((val1 (acar rest))
(rest (cdr rest)) (rest (acdr rest))
(extra (if (null? rest) (+ extra 1) 0))) (extra (if (null? rest) (+ extra 1) 0)))
(indent col3) (indent col3)
(pr val1 extra pp-2 depth) (pr val1 extra pp-2 depth)
@ -982,55 +1002,78 @@
(tail3 rest col1))) (tail3 rest col1)))
(define (tail3 rest col1) (define (tail3 rest col1)
(pp-down ")" rest col1 col1 extra pp-3 #f #t depth)) (pp-down close rest col1 col1 extra pp-3 #f #t depth
apair? acar acdr open close))
(let* ([head (car expr)] (let* ([head (acar expr)]
[rest (cdr expr)] [rest (acdr expr)]
[col (ccol)]) [col (ccol)])
(out "(") (out open)
(wr head (dsub1 depth)) (wr head (dsub1 depth))
(if (and named? (pair? rest)) (if (and named? (apair? rest))
(let* ((name (car rest)) (let* ((name (acar rest))
(rest (cdr rest))) (rest (acdr rest)))
(out " ") (out " ")
(wr name (dsub1 depth)) (wr name (dsub1 depth))
(tail1 rest (+ col indent-general) (+ (ccol) 1))) (tail1 rest (+ col indent-general) (+ (ccol) 1)))
(tail1 rest (+ col indent-general) (+ (ccol) 1))))) (tail1 rest (+ col indent-general) (+ (ccol) 1)))))
(define (pp-expr-list l extra depth) (define (pp-expr-list l extra depth
(pp-list l extra pp-expr #t depth)) apair? acar acdr open close)
(pp-list l extra pp-expr #t depth
apair? acar acdr open close))
(define (pp-lambda expr extra depth) (define (pp-lambda expr extra depth
(pp-general expr extra #f pp-expr-list #f pp-expr depth)) apair? acar acdr open close)
(pp-general expr extra #f pp-expr-list #f pp-expr depth
apair? acar acdr open close))
(define (pp-if expr extra depth) (define (pp-if expr extra depth
(pp-general expr extra #f pp-expr #f pp-expr depth)) apair? acar acdr open close)
(pp-general expr extra #f pp-expr #f pp-expr depth
apair? acar acdr open close))
(define (pp-cond expr extra depth) (define (pp-cond expr extra depth
(pp-list expr extra pp-expr-list #t depth)) apair? acar acdr open close)
(pp-list expr extra pp-expr-list #t depth
apair? acar acdr open close))
(define (pp-class expr extra depth) (define (pp-syntax-case expr extra depth
(pp-two-up expr extra pp-expr-list depth)) apair? acar acdr open close)
(pp-two-up expr extra pp-expr-list depth
apair? acar acdr open close))
(define (pp-make-object expr extra depth) (define (pp-make-object expr extra depth
(pp-one-up expr extra pp-expr-list depth)) apair? acar acdr open close)
(pp-one-up expr extra pp-expr-list depth
apair? acar acdr open close))
(define (pp-case expr extra depth) (define (pp-case expr extra depth
(pp-general expr extra #f pp-expr #f pp-expr-list depth)) apair? acar acdr open close)
(pp-general expr extra #f pp-expr #f pp-expr-list depth
apair? acar acdr open close))
(define (pp-and expr extra depth) (define (pp-and expr extra depth
(pp-call expr extra pp-expr depth)) apair? acar acdr open close)
(pp-call expr extra pp-expr depth
apair? acar acdr open close))
(define (pp-let expr extra depth) (define (pp-let expr extra depth
(let* ((rest (cdr expr)) apair? acar acdr open close)
(named? (and (pair? rest) (symbol? (do-remap (car rest)))))) (let* ((rest (acdr expr))
(pp-general expr extra named? pp-expr-list #f pp-expr depth))) (named? (and (apair? rest) (symbol? (do-remap (acar rest))))))
(pp-general expr extra named? pp-expr-list #f pp-expr depth
apair? acar acdr open close)))
(define (pp-begin expr extra depth) (define (pp-begin expr extra depth
(pp-general expr extra #f #f #f pp-expr depth)) apair? acar acdr open close)
(pp-general expr extra #f #f #f pp-expr depth
apair? acar acdr open close))
(define (pp-do expr extra depth) (define (pp-do expr extra depth
(pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth)) apair? acar acdr open close)
(pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth
apair? acar acdr open close))
;; define formatting style (change these to suit your style) ;; define formatting style (change these to suit your style)
@ -1038,57 +1081,58 @@
(define max-call-head-width 5) (define max-call-head-width 5)
(define (no-sharing? expr count) (define (no-sharing? expr count acdr)
(if (and found (hash-table-get found (cdr expr) #f)) (if (and found (hash-table-get found (acdr expr) #f))
#f #f
(or (zero? count) (or (zero? count)
(no-sharing? (cdr expr) (sub1 count))))) (no-sharing? (acdr expr) (sub1 count) acdr))))
(define (style head expr) (define (style head expr apair? acar acdr)
(case (look-in-style-table head) (case (look-in-style-table head)
((lambda λ define define-macro define-syntax ((lambda λ define define-macro define-syntax
syntax-rules syntax-rules
shared shared
unless when) unless when)
(and (no-sharing? expr 1) (and (no-sharing? expr 1 acdr)
pp-lambda)) pp-lambda))
((if set! set!-values) ((if set! set!-values)
(and (no-sharing? expr 1) (and (no-sharing? expr 1 acdr)
pp-if)) pp-if))
((cond case-lambda) ((cond case-lambda)
(and (no-sharing? expr 0) (and (no-sharing? expr 0 acdr)
pp-cond)) pp-cond))
((case) ((case class)
(and (no-sharing? expr 1) (and (no-sharing? expr 1 acdr)
pp-case)) pp-case))
((and or import export ((and or import export
require require-for-syntax require-for-template require require-for-syntax require-for-template
provide link provide link
public private override rename inherit field init) public private override rename inherit field init)
(and (no-sharing? expr 0) (and (no-sharing? expr 0 acdr)
pp-and)) pp-and))
((let letrec let* ((let letrec let*
let-values letrec-values let*-values let-values letrec-values let*-values
let-syntax letrec-syntax let-syntax letrec-syntax
let-syntaxes letrec-syntaxes) let-syntaxes letrec-syntaxes)
(and (no-sharing? expr (and (no-sharing? expr
(if (and (pair? (cdr expr)) (if (and (apair? (acdr expr))
(symbol? (cadr expr))) (symbol? (acar (acdr expr))))
2 2
1)) 1)
acdr)
pp-let)) pp-let))
((begin begin0) ((begin begin0)
(and (no-sharing? expr 0) (and (no-sharing? expr 0 acdr)
pp-begin)) pp-begin))
((do letrec-syntaxes+values) ((do letrec-syntaxes+values)
(and (no-sharing? expr 2) (and (no-sharing? expr 2 acdr)
pp-do)) pp-do))
((send class syntax-case instantiate module) ((send syntax-case instantiate module)
(and (no-sharing? expr 2) (and (no-sharing? expr 2 acdr)
pp-class)) pp-syntax-case))
((make-object) ((make-object)
(and (no-sharing? expr 1) (and (no-sharing? expr 1 acdr)
pp-make-object)) pp-make-object))
(else #f))) (else #f)))