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

53
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,15 +871,17 @@
(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
(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)
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)))

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

@ -113,7 +113,13 @@
(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)