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?))))
(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
(out (read-macro-prefix expr car))
(pr (read-macro-body expr car cdr)
@ -870,16 +871,18 @@
(if (or (and (symbol? head)
(not (size-hook head display?)))
((pretty-print-remap-stylable) head))
(let ((proc (style head)))
(let ((proc (style head expr)))
(if proc
(proc expr extra depth)
(if (> (string-length
(symbol->string
(if (symbol? head)
head
((pretty-print-remap-stylable) head))))
max-call-head-width)
(pp-general expr extra #f #f #f pp-expr depth)
(if (and #f
;; Why this special case? Currently disabled.
(> (string-length
(symbol->string
(if (symbol? head)
head
((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)))))
@ -1035,38 +1038,58 @@
(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)
((lambda λ define define-macro define-syntax
syntax-rules
shared
unless when)
pp-lambda)
(and (no-sharing? expr 1)
pp-lambda))
((if set! set!-values)
pp-if)
(and (no-sharing? expr 1)
pp-if))
((cond case-lambda)
pp-cond)
(and (no-sharing? expr 0)
pp-cond))
((case)
pp-case)
(and (no-sharing? expr 1)
pp-case))
((and or import export
require require-for-syntax require-for-template
provide link
public private override rename inherit field init)
pp-and)
(and (no-sharing? expr 0)
pp-and))
((let letrec let*
let-values letrec-values let*-values
let-syntax letrec-syntax
let-syntaxes letrec-syntaxes)
pp-let)
(and (no-sharing? expr
(if (and (pair? (cdr expr))
(symbol? (cadr expr)))
2
1))
pp-let))
((begin begin0)
pp-begin)
(and (no-sharing? expr 0)
pp-begin))
((do letrec-syntaxes+values)
pp-do)
(and (no-sharing? expr 2)
pp-do))
((send class syntax-case instantiate module)
pp-class)
(and (no-sharing? expr 2)
pp-class))
((make-object)
pp-make-object)
(and (no-sharing? expr 1)
pp-make-object))
(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])
(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))
(let ([table (pretty-print-extend-style-table #f null null)])
(parameterize ([pretty-print-current-style-table
(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))
(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])
(test "10" pretty-format 10)
@ -157,7 +163,7 @@
(λ (val dsp? port)
(write (wrap-content val) port))])
(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])
(let ()