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?)))) (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,15 +871,17 @@
(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
;; Why this special case? Currently disabled.
(> (string-length
(symbol->string (symbol->string
(if (symbol? head) (if (symbol? head)
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)))) (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)))

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\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)