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

fix pretty-print so that special handling of 'lambda', 'quote', etc. doesn't hide sharing that shoul dbe displayed

Browse Source 
svn: r10482
This commit is contained in:
Matthew Flatt 2008-06-27 22:07:28 +00:00
parent 009aabf8e1
commit 69b4ffc7c0
3 changed files with 54 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/mzlib/pretty.ss
View File

@ -859,7 +859,8 @@
(wr* pport obj depth display?)))) (wr* pport obj depth display?))))
(define (pp-expr expr extra depth) (define (pp-expr expr extra depth)
(if (read-macro? expr pair? car cdr) (if (and (read-macro? expr pair? car cdr)
(not (and found (hash-table-get found (cdr expr) #f))))
(begin (begin
(out (read-macro-prefix expr car)) (out (read-macro-prefix expr car))
(pr (read-macro-body expr car cdr) (pr (read-macro-body expr car cdr)
@ -870,16 +871,18 @@
(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))) (let ((proc (style head expr)))
(if proc (if proc
(proc expr extra depth) (proc expr extra depth)
(if (> (string-length (if (and #f
(symbol->string ;; Why this special case? Currently disabled.
(if (symbol? head) (> (string-length
head (symbol->string
((pretty-print-remap-stylable) head)))) (if (symbol? head)
max-call-head-width) head
(pp-general expr extra #f #f #f pp-expr depth) ((pretty-print-remap-stylable) head))))
max-call-head-width))
(pp-general expr extra #f #f #f pp-expr depth)
(pp-list expr extra pp-expr #t depth)))) (pp-list expr extra pp-expr #t depth))))
(pp-list expr extra pp-expr #t depth))))) (pp-list expr extra pp-expr #t depth)))))
@ -1035,38 +1038,58 @@
(define max-call-head-width 5) (define max-call-head-width 5)
(define (style head) (define (no-sharing? expr count)
(if (and found (hash-table-get found (cdr expr) #f))
#f
(or (zero? count)
(no-sharing? (cdr expr) (sub1 count)))))
(define (style head expr)
(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)
pp-lambda) (and (no-sharing? expr 1)
pp-lambda))
((if set! set!-values) ((if set! set!-values)
pp-if) (and (no-sharing? expr 1)
pp-if))
((cond case-lambda) ((cond case-lambda)
pp-cond) (and (no-sharing? expr 0)
pp-cond))
((case) ((case)
pp-case) (and (no-sharing? expr 1)
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)
pp-and) (and (no-sharing? expr 0)
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)
pp-let) (and (no-sharing? expr
(if (and (pair? (cdr expr))
(symbol? (cadr expr)))
2
1))
pp-let))
((begin begin0) ((begin begin0)
pp-begin) (and (no-sharing? expr 0)
pp-begin))
((do letrec-syntaxes+values) ((do letrec-syntaxes+values)
pp-do) (and (no-sharing? expr 2)
pp-do))
((send class syntax-case instantiate module) ((send class syntax-case instantiate module)
pp-class) (and (no-sharing? expr 2)
pp-class))
((make-object) ((make-object)
pp-make-object) (and (no-sharing? expr 1)
pp-make-object))
(else #f))) (else #f)))

2
collects/tests/mzscheme/pp-regression.ss
View File

File diff suppressed because one or more lines are too long

14
collects/tests/mzscheme/pretty.ss
View File

@ -105,15 +105,21 @@
(parameterize ([pretty-print-columns 20]) (parameterize ([pretty-print-columns 20])
(test "(1234567890 1 2 3 4)" pretty-format '(1234567890 1 2 3 4)) (test "(1234567890 1 2 3 4)" pretty-format '(1234567890 1 2 3 4))
(test "(1234567890xx\n 1\n 2\n 3\n 4)" pretty-format '(1234567890xx 1 2 3 4)) (test "(1234567890xx\n 1\n 2\n 3\n 4)" pretty-format '(1234567890xx 1 2 3 4))
(test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)) (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))
(let ([table (pretty-print-extend-style-table #f null null)]) (let ([table (pretty-print-extend-style-table #f null null)])
(parameterize ([pretty-print-current-style-table (parameterize ([pretty-print-current-style-table
(pretty-print-extend-style-table table '(lambda) '(list))]) (pretty-print-extend-style-table table '(lambda) '(list))])
(test "(lambda\n 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))) (test "(lambda\n 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)))
(test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)) (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))
(parameterize ([pretty-print-current-style-table table]) (parameterize ([pretty-print-current-style-table table])
(test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))))) (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)))
;; Make sure special case for lambda, etc, doesn't hide sharing:
(let ([a (read (open-input-string "#0=((x) 1 . #0#)"))])
(test "(lambda\n .\n #0=((x) 1 . #0#))" pretty-format `(lambda . ,a)))
(let ([a (read (open-input-string "#0=((1 . #0#))"))])
(test "(quote\n .\n #0=((1 . #0#)))" pretty-format `(quote . ,a))
(test "'#0=((1 . #0#))" pretty-format `(quote ,a)))))
(parameterize ([pretty-print-exact-as-decimal #t]) (parameterize ([pretty-print-exact-as-decimal #t])
(test "10" pretty-format 10) (test "10" pretty-format 10)
@ -157,7 +163,7 @@
(λ (val dsp? port) (λ (val dsp? port)
(write (wrap-content val) port))]) (write (wrap-content val) port))])
(test "(lambda (x)\n abcdef)" pretty-format (add-wrappers '(lambda (x) abcdef))) (test "(lambda (x)\n abcdef)" pretty-format (add-wrappers '(lambda (x) abcdef)))
(test "(call/cc\n call/cc)" pretty-format (add-wrappers '(call/cc call/cc))))) (test "(call/cc\n call/cc)" pretty-format (add-wrappers '(call/cc call/cc)))))
(parameterize ([print-struct #t]) (parameterize ([print-struct #t])
(let () (let ()