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

117
collects/racket/pretty.rkt
View File

@ -560,63 +560,74 @@
(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)) (cond
#f [(hash-ref table obj #f)
(begin ;; already decided that it escapes
(when local-cycle #t]
(hash-set! local-cycle obj #t)) [(and local-compound
(begin0 (hash-ref local-compound obj #f))
(cond ;; either still deciding (so assume #f) or
[ #f] ;; already decided that no escape is needed
[(vector? obj) #f]
(let ([len (vector-length obj)]) [else
(let vloop ([esc? #f][i 0]) (cond
(if (= i len) [(vector? obj)
(and esc? (is-compound! obj)
(escapes! obj)) (let ([len (vector-length obj)])
(vloop (or (loop (vector-ref obj i)) esc?) (let vloop ([esc? #f][i 0])
(add1 i)))))] (if (= i len)
[(pair? obj) (and esc?
(and (orf (loop (car obj)) (escapes! obj))
(loop (cdr obj))) (vloop (or (loop (vector-ref obj i)) esc?)
(escapes! obj))] (add1 i)))))]
[(mpair? obj) [(pair? obj)
(loop (mcar obj)) (is-compound! obj)
(loop (mcdr obj)) (and (orf (loop (car obj))
;; always unquoted: (loop (cdr obj)))
#t] (escapes! obj))]
[(and (box? obj) print-box?) [(mpair? obj)
(and (loop (unbox obj)) (is-compound! obj)
(escapes! obj))] (loop (mcar obj))
[(and (custom-write? obj) (loop (mcdr obj))
(not (struct-type? obj))) ;; always unquoted:
(let ([kind (if (custom-print-quotable? obj) #t]
(custom-print-quotable-accessor obj) [(and (box? obj) print-box?)
'self)]) (is-compound! obj)
(and (or (and (loop (extract-sub-objects obj pport)) (and (loop (unbox obj))
(not (memq kind '(self always)))) (escapes! obj))]
(memq kind '(never))) [(and (custom-write? obj)
(escapes! obj)))] (not (struct-type? obj)))
[(struct? obj) (is-compound! obj)
(and (or (loop (struct->vector obj)) (let ([kind (if (custom-print-quotable? obj)
(not (prefab-struct-key obj))) (custom-print-quotable-accessor obj)
(escapes! obj))] 'self)])
[(hash? obj) (and (or (and (loop (extract-sub-objects obj pport))
(and (for/fold ([esc? #f]) ([(k v) (in-hash obj)]) (not (memq kind '(self always))))
(or (orf (loop v) (memq kind '(never)))
(loop k)) (escapes! obj)))]
esc?)) [(struct? obj)
(escapes! obj))] (is-compound! obj)
[else #f]) (and (or (loop (struct->vector obj))
(when local-cycle (not (prefab-struct-key obj)))
(hash-remove! local-cycle obj))))))) (escapes! obj))]
[(hash? obj)
(is-compound! obj)
(and (for/fold ([esc? #f]) ([(k v) (in-hash obj)])
(or (orf (loop v)
(loop k))
esc?))
(escapes! obj))]
[else #f])])))
table)) table))
(define cycle-counter 0) (define cycle-counter 0)