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

pretty-print: make check for escape points linear in input

Browse Source
This commit is contained in:
Matthew Flatt 2011-01-04 10:37:33 -07:00
parent 3bb120545f
commit 9fa957e780
1 changed files with 64 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/racket/pretty.rkt
View File

@ -560,22 +560,29 @@
(define escapes-table (define escapes-table
(let* ([table (make-hasheq)] (let* ([table (make-hasheq)]
[local-cycle (and found-cycle (make-hasheq))] [local-compound (and print-as-qq?
(make-hasheq))]
[is-compound! (lambda (obj)
(hash-set! local-compound obj #t))]
[escapes! (lambda (obj) [escapes! (lambda (obj)
(hash-set! table obj #t) (hash-set! table obj #t)
#t)] #t)]
[orf (lambda (a b) (or a b))]) [orf (lambda (a b) (or a b))])
(and print-as-qq? (when print-as-qq?
(let loop ([obj obj]) (let loop ([obj obj])
(if (and local-cycle (hash-ref local-cycle obj #f))
#f
(begin
(when local-cycle
(hash-set! local-cycle obj #t))
(begin0
(cond (cond
[ #f] [(hash-ref table obj #f)
;; already decided that it escapes
#t]
[(and local-compound
(hash-ref local-compound obj #f))
;; either still deciding (so assume #f) or
;; already decided that no escape is needed
#f]
[else
(cond
[(vector? obj) [(vector? obj)
(is-compound! obj)
(let ([len (vector-length obj)]) (let ([len (vector-length obj)])
(let vloop ([esc? #f][i 0]) (let vloop ([esc? #f][i 0])
(if (= i len) (if (= i len)
@ -584,19 +591,23 @@
(vloop (or (loop (vector-ref obj i)) esc?) (vloop (or (loop (vector-ref obj i)) esc?)
(add1 i)))))] (add1 i)))))]
[(pair? obj) [(pair? obj)
(is-compound! obj)
(and (orf (loop (car obj)) (and (orf (loop (car obj))
(loop (cdr obj))) (loop (cdr obj)))
(escapes! obj))] (escapes! obj))]
[(mpair? obj) [(mpair? obj)
(is-compound! obj)
(loop (mcar obj)) (loop (mcar obj))
(loop (mcdr obj)) (loop (mcdr obj))
;; always unquoted: ;; always unquoted:
#t] #t]
[(and (box? obj) print-box?) [(and (box? obj) print-box?)
(is-compound! obj)
(and (loop (unbox obj)) (and (loop (unbox obj))
(escapes! obj))] (escapes! obj))]
[(and (custom-write? obj) [(and (custom-write? obj)
(not (struct-type? obj))) (not (struct-type? obj)))
(is-compound! obj)
(let ([kind (if (custom-print-quotable? obj) (let ([kind (if (custom-print-quotable? obj)
(custom-print-quotable-accessor obj) (custom-print-quotable-accessor obj)
'self)]) 'self)])
@ -605,18 +616,18 @@
(memq kind '(never))) (memq kind '(never)))
(escapes! obj)))] (escapes! obj)))]
[(struct? obj) [(struct? obj)
(is-compound! obj)
(and (or (loop (struct->vector obj)) (and (or (loop (struct->vector obj))
(not (prefab-struct-key obj))) (not (prefab-struct-key obj)))
(escapes! obj))] (escapes! obj))]
[(hash? obj) [(hash? obj)
(is-compound! obj)
(and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) (and (for/fold ([esc? #f]) ([(k v) (in-hash obj)])
(or (orf (loop v) (or (orf (loop v)
(loop k)) (loop k))
esc?)) esc?))
(escapes! obj))] (escapes! obj))]
[else #f]) [else #f])])))
(when local-cycle
(hash-remove! local-cycle obj)))))))
table)) table))
(define cycle-counter 0) (define cycle-counter 0)