- pretty-printing record type now work properly and share/graph
marks are propagated between record fields and surrounding context.
This commit is contained in:
Abdulaziz Ghuloum
parent
f570ea8c2a
commit
0d91ab9774
|
|
@ -14,7 +14,8 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
|
|||
ikarus.lists.ss ikarus.load.ss ikarus.main.ss \
|
||||
ikarus.multiple-values.ss ikarus.numerics.ss \
|
||||
ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
|
||||
ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
|
||||
ikarus.pretty-print.ss ikarus.pretty-formats.ss \
|
||||
ikarus.promises.ss ikarus.reader.ss \
|
||||
ikarus.records.procedural.ss ikarus.conditions.ss \
|
||||
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
||||
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
|
||||
|
|
|
|||
|
|
@ -169,7 +169,8 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
|
|||
ikarus.lists.ss ikarus.load.ss ikarus.main.ss \
|
||||
ikarus.multiple-values.ss ikarus.numerics.ss \
|
||||
ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.ss \
|
||||
ikarus.pretty-print.ss ikarus.promises.ss ikarus.reader.ss \
|
||||
ikarus.pretty-print.ss ikarus.pretty-formats.ss \
|
||||
ikarus.promises.ss ikarus.reader.ss \
|
||||
ikarus.records.procedural.ss ikarus.conditions.ss \
|
||||
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
|
||||
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \
|
||||
|
|
|
|||
|
|
@ -55,6 +55,7 @@
|
|||
(set-fmt! 'let-values '(_ (0 [e 0 e] ...) tab e tab e* ...))
|
||||
(set-fmt! 'cond '(_ tab [0 e ...] ...))
|
||||
(set-fmt! 'define '(_ name tab e ...))
|
||||
(set-fmt! 'set! '(_ name tab e))
|
||||
(set-fmt! 'case-lambda
|
||||
'(_ tab [0 e ...] ...))
|
||||
(set-fmt! 'struct-case
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@
|
|||
(export pretty-print pretty-width)
|
||||
(import
|
||||
(rnrs hashtables)
|
||||
(only (ikarus writer) traverse traversal-helpers)
|
||||
(only (ikarus.pretty-formats) get-fmt)
|
||||
(except (ikarus) pretty-print pretty-width))
|
||||
(define (map1ltr f ls)
|
||||
|
|
@ -39,7 +40,7 @@
|
|||
(define-struct cbox (length boxes))
|
||||
(define-struct pbox (length ls last))
|
||||
(define-struct mbox (length str val))
|
||||
(define-struct vbox (length ls))
|
||||
(define-struct vbox (length prefix ls))
|
||||
(define-struct fbox (length box* sep*))
|
||||
(define (box-length x)
|
||||
(cond
|
||||
|
|
@ -50,7 +51,8 @@
|
|||
[(vbox? x) (vbox-length x)]
|
||||
[(fbox? x) (fbox-length x)]
|
||||
[else (die 'boxify "invalid box" x)]))
|
||||
(define (boxify x)
|
||||
(define (boxify x h)
|
||||
(define shared-idx 0)
|
||||
(define (conc . a*)
|
||||
(let ([n
|
||||
(let f ([a* a*] [len 0])
|
||||
|
|
@ -59,11 +61,11 @@
|
|||
[else
|
||||
(f (cdr a*) (fx+ len (box-length (car a*))))]))])
|
||||
(make-cbox n a*)))
|
||||
(define (boxify-list ls alt-fmt*)
|
||||
(define (boxify-list ls)
|
||||
(define (sum-box* ls)
|
||||
(cond
|
||||
[(null? (cdr ls))
|
||||
(fx+ (box-length (car ls)) 2)]
|
||||
(box-length (car ls))]
|
||||
[else
|
||||
(fx+ (box-length (car ls))
|
||||
(fxadd1 (sum-box* (cdr ls))))]))
|
||||
|
|
@ -82,16 +84,16 @@
|
|||
(cond
|
||||
[(not (pair? fmt)) #t]
|
||||
[(eq? (car fmt) 'read-macro)
|
||||
(and (list? ls) (fx= (length ls) 2))]
|
||||
(and (unshared-list? ls) (fx= (length ls) 2))]
|
||||
[else
|
||||
(let ([a (car fmt)] [fmt (cdr fmt)])
|
||||
(cond
|
||||
[(or (eq? a 'tab) (fixnum? a))
|
||||
(good-match? fmt ls)]
|
||||
[(and (pair? fmt) (eq? (car fmt) '...))
|
||||
(and (list? ls)
|
||||
(and (unshared-list? ls)
|
||||
(andmap (lambda (x) (good-match? a x)) ls))]
|
||||
[(pair? ls)
|
||||
[(and (pair? ls) (not (graphed? ls)))
|
||||
(and (good-match? a (car ls))
|
||||
(good-match? fmt (cdr ls)))]
|
||||
[else #f]))]))
|
||||
|
|
@ -110,105 +112,111 @@
|
|||
[else alt-fmt*]))
|
||||
(define (return sep* box*)
|
||||
(let ([n (sum-box* box*)])
|
||||
(make-fbox n box* sep*)))
|
||||
(let ([a (car ls)])
|
||||
(cond
|
||||
[(applicable-formats a alt-fmt*) =>
|
||||
(lambda (fmt*)
|
||||
(let ([fmt (select-alt fmt* ls)])
|
||||
(module (fmt-dots? skip-fmt fmt-tab sub-fmt)
|
||||
(define (parse-fmt x)
|
||||
(define (parse-dots tab fmt x)
|
||||
(cond
|
||||
[(and (pair? x) (eq? (car x) '...))
|
||||
(values tab fmt #t (cdr x))]
|
||||
[else
|
||||
(values tab fmt #f x)]))
|
||||
(define (parse-tab tab x)
|
||||
(conc "(" (make-fbox n box* sep*) ")")))
|
||||
(define (boxify-list ls alt-fmt*)
|
||||
(let ([a (car ls)])
|
||||
(cond
|
||||
[(applicable-formats a alt-fmt*) =>
|
||||
(lambda (fmt*)
|
||||
(let ([fmt (select-alt fmt* ls)])
|
||||
(module (fmt-dots? skip-fmt fmt-tab sub-fmt)
|
||||
(define (parse-fmt x)
|
||||
(define (parse-dots tab fmt x)
|
||||
(cond
|
||||
[(and (pair? x) (eq? (car x) '...))
|
||||
(values tab fmt #t (cdr x))]
|
||||
[else
|
||||
(values tab fmt #f x)]))
|
||||
(define (parse-tab tab x)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(parse-dots tab (car x) (cdr x))]
|
||||
[else (values tab #f #f #f)]))
|
||||
(cond
|
||||
[(pair? x)
|
||||
(parse-dots tab (car x) (cdr x))]
|
||||
[else (values tab #f #f #f)]))
|
||||
(let ([a0 (car x)])
|
||||
(cond
|
||||
[(eq? a0 'tab)
|
||||
(parse-tab (pretty-indent) (cdr x))]
|
||||
[(fixnum? a0)
|
||||
(parse-tab a0 (cdr x))]
|
||||
[else (parse-tab #f x)]))]
|
||||
[else (values (pretty-indent) #f #f #f)]))
|
||||
(define (fmt-dots? x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
dots))
|
||||
(define (fmt-tab x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
tab))
|
||||
(define (sub-fmt x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
subfmt))
|
||||
(define (skip-fmt x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
fmt)))
|
||||
(define (boxify/fmt fmt x)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(let ([a0 (car x)])
|
||||
(cond
|
||||
[(eq? a0 'tab)
|
||||
(parse-tab (pretty-indent) (cdr x))]
|
||||
[(fixnum? a0)
|
||||
(parse-tab a0 (cdr x))]
|
||||
[else (parse-tab #f x)]))]
|
||||
[else (values (pretty-indent) #f #f #f)]))
|
||||
(define (fmt-dots? x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
dots))
|
||||
(define (fmt-tab x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
tab))
|
||||
(define (sub-fmt x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
subfmt))
|
||||
(define (skip-fmt x)
|
||||
(let-values ([(tab subfmt dots fmt) (parse-fmt x)])
|
||||
fmt)))
|
||||
;(import M)
|
||||
(define (boxify/fmt fmt x)
|
||||
[(and (pair? fmt) (unshared-list? x))
|
||||
(boxify-list x
|
||||
(if (eq? (car fmt) 'alt)
|
||||
(cdr fmt)
|
||||
(list fmt)))]
|
||||
[else (boxify x)]))
|
||||
(define (read-macro? x)
|
||||
(and (pair? x) (eq? (car x) 'read-macro)))
|
||||
(cond
|
||||
[(and (pair? fmt) (pair? x) (list? x))
|
||||
(boxify-list x
|
||||
(if (eq? (car fmt) 'alt)
|
||||
(cdr fmt)
|
||||
(list fmt)))]
|
||||
[else (boxify x)]))
|
||||
(define (read-macro? x)
|
||||
(and (pair? x) (eq? (car x) 'read-macro)))
|
||||
(cond
|
||||
[(read-macro? fmt)
|
||||
(conc (cdr fmt) (boxify (cadr ls)))]
|
||||
[(fmt-dots? fmt)
|
||||
(return (fmt-tab fmt)
|
||||
(map1ltr (lambda (x) (boxify/fmt (sub-fmt fmt) x))
|
||||
ls))]
|
||||
[else
|
||||
(let-values ([(sep* ls)
|
||||
(let f ([fmt (skip-fmt fmt)] [ls (cdr ls)])
|
||||
(cond
|
||||
[(null? ls)
|
||||
(values '() '())]
|
||||
[(fmt-dots? fmt)
|
||||
(values (fmt-tab fmt)
|
||||
(map1ltr (lambda (x)
|
||||
[(read-macro? fmt)
|
||||
(conc (cdr fmt) (boxify (cadr ls)))]
|
||||
[(fmt-dots? fmt)
|
||||
(return (fmt-tab fmt)
|
||||
(map1ltr (lambda (x) (boxify/fmt (sub-fmt fmt) x))
|
||||
ls))]
|
||||
[else
|
||||
(let ([a (boxify/fmt (sub-fmt fmt) a)])
|
||||
(let-values ([(sep* ls)
|
||||
(let f ([fmt (skip-fmt fmt)] [ls (cdr ls)])
|
||||
(cond
|
||||
[(null? ls)
|
||||
(values '() '())]
|
||||
[(fmt-dots? fmt)
|
||||
(values (fmt-tab fmt)
|
||||
(map1ltr
|
||||
(lambda (x)
|
||||
(boxify/fmt (sub-fmt fmt) x))
|
||||
ls))]
|
||||
[else
|
||||
(let-values ([(f^ l^)
|
||||
(f (skip-fmt fmt) (cdr ls))])
|
||||
(values (cons (fmt-tab fmt) f^)
|
||||
(cons (boxify/fmt
|
||||
(sub-fmt fmt)
|
||||
(car ls))
|
||||
l^)))]))])
|
||||
(return sep* (cons (boxify/fmt (sub-fmt fmt) a) ls)))])))]
|
||||
[else
|
||||
(return (gensep*-default ls) (map1ltr boxify ls))])))
|
||||
ls))]
|
||||
[else
|
||||
(let ([a
|
||||
(boxify/fmt (sub-fmt fmt)
|
||||
(car ls))])
|
||||
(let-values ([(f^ l^)
|
||||
(f (skip-fmt fmt)
|
||||
(cdr ls))])
|
||||
(values (cons (fmt-tab fmt) f^)
|
||||
(cons a l^))))]))])
|
||||
(return sep* (cons a ls))))])))]
|
||||
[else
|
||||
(return (gensep*-default ls) (map1ltr boxify ls))])))
|
||||
(boxify-list ls '()))
|
||||
(define (boxify-pair x)
|
||||
(let-values ([(ls last)
|
||||
(let f ([x x])
|
||||
(cond
|
||||
[(pair? x)
|
||||
(let ([a (boxify (car x))])
|
||||
(let-values ([(ls last) (f (cdr x))])
|
||||
(values (cons a ls) last)))]
|
||||
[else
|
||||
(values '() (boxify x))]))])
|
||||
(let ([n
|
||||
(let f ([ls ls] [n 4])
|
||||
(cond
|
||||
[(null? ls) n]
|
||||
[else
|
||||
(f (cdr ls)
|
||||
(fx+ (fxadd1 n) (box-length (car ls))))]))])
|
||||
(make-pbox (fx+ n (box-length last)) ls last))))
|
||||
(define (boxify-cdrs x)
|
||||
(cond
|
||||
[(and (pair? x) (not (graphed? x)))
|
||||
(let ([a (boxify (car x))])
|
||||
(let-values ([(ls last) (boxify-cdrs (cdr x))])
|
||||
(values (cons a ls) last)))]
|
||||
[else
|
||||
(values '() (boxify x))]))
|
||||
(let ([a (boxify (car x))])
|
||||
(let-values ([(ls last) (boxify-cdrs (cdr x))])
|
||||
(let ([ls (cons a ls)])
|
||||
(let ([n
|
||||
(let f ([ls ls] [n 4])
|
||||
(cond
|
||||
[(null? ls) n]
|
||||
[else
|
||||
(f (cdr ls)
|
||||
(fx+ (fxadd1 n) (box-length (car ls))))]))])
|
||||
(make-pbox (fx+ n (box-length last)) ls last))))))
|
||||
(define (boxify-vector x)
|
||||
(let ([ls (map1ltr boxify (vector->list x))])
|
||||
(let ([n
|
||||
|
|
@ -217,19 +225,104 @@
|
|||
[(null? ls) n]
|
||||
[else
|
||||
(f (cdr ls) (fx+ n (box-length (car ls))))]))])
|
||||
(make-vbox (fx+ (fx+ n 2) (vector-length x)) ls))))
|
||||
(cond
|
||||
[(null? x) "()"]
|
||||
[(vector? x) (boxify-vector x)]
|
||||
[(list? x) (boxify-list x '())]
|
||||
[(pair? x) (boxify-pair x)]
|
||||
[(setbox? x)
|
||||
(let ([i (format "#~a=" (setbox-idx x))]
|
||||
[b (boxify (setbox-data x))])
|
||||
(make-cbox (+ (string-length i) (box-length b))
|
||||
(list i b)))]
|
||||
[(refbox? x) (format "#~a#" (refbox-idx x))]
|
||||
[else (format "~s" x)]))
|
||||
(make-vbox (fx+ (fx+ n 2) (vector-length x)) "#" ls))))
|
||||
(define (boxify-bytevector x)
|
||||
(define prefix "#vu8")
|
||||
(let ([ls (map (lambda (x) (number->string x))
|
||||
(bytevector->u8-list x))])
|
||||
(let ([len (fold-left (lambda (ac s) (+ 1 ac (string-length s)))
|
||||
(+ 1 (string-length prefix))
|
||||
ls)])
|
||||
(make-vbox len prefix ls))))
|
||||
(define (graphed? x)
|
||||
(import traversal-helpers)
|
||||
(let ([b (hashtable-ref h x #f)])
|
||||
(let ([b (if (fixnum? b) b (car b))])
|
||||
(cond
|
||||
[(cyclic-set? b) #t]
|
||||
[(shared-set? b) (print-graph)]
|
||||
[else #f]))))
|
||||
(define (unshared-list? x)
|
||||
;;; all cdrs of non-empty list are not-shared?
|
||||
(and (pair? x)
|
||||
(let f ([x (cdr x)])
|
||||
(or (null? x)
|
||||
(and (pair? x)
|
||||
(not (graphed? x))
|
||||
(f (cdr x)))))))
|
||||
(define (boxify-struct x)
|
||||
(define (boxify-vanilla-struct x)
|
||||
(cond
|
||||
[(let ([rtd (struct-type-descriptor x)])
|
||||
(and (record-type-descriptor? rtd)
|
||||
(record-type-opaque? rtd)))
|
||||
"#<unknown>"]
|
||||
[else
|
||||
(let* ([name (boxify (struct-name x))]
|
||||
[ls
|
||||
(let ([n (struct-length x)])
|
||||
(let f ([i 0])
|
||||
(cond
|
||||
[(fx= i n) '()]
|
||||
[else
|
||||
(let ([a (boxify (struct-ref x i))])
|
||||
(cons a (f (+ i 1))))])))]
|
||||
[ls (cons name ls)]
|
||||
[len (fold-left (lambda (ac s) (+ 1 ac (box-length s)))
|
||||
-1 ls)])
|
||||
(conc "#[" (make-fbox len ls #f) "]"))]))
|
||||
(define (boxify-custom-struct out)
|
||||
(import traversal-helpers)
|
||||
(let ([ls
|
||||
(let f ([cache (cdr out)])
|
||||
(cond
|
||||
[(not cache) (list (car out))]
|
||||
[else
|
||||
(let ([obj (boxify (cache-object cache))])
|
||||
(let ([ls (f (cache-next cache))])
|
||||
(cons* (cache-string cache) obj ls)))]))])
|
||||
(let ([len (fold-left (lambda (ac s) (+ 1 ac (box-length s)))
|
||||
-1 ls)])
|
||||
(make-fbox len ls #f))))
|
||||
(let ([b (hashtable-ref h x #f)])
|
||||
(cond
|
||||
[(pair? b) (boxify-custom-struct (cdr b))]
|
||||
[else (boxify-vanilla-struct x)])))
|
||||
(define (boxify-shared x k)
|
||||
(import traversal-helpers)
|
||||
(let ([b (hashtable-ref h x #f)])
|
||||
(let ([b (if (fixnum? b) b (car b))])
|
||||
(cond
|
||||
[(mark-set? b)
|
||||
(string-append "#"
|
||||
(number->string (fxsra b mark-shift))
|
||||
"#")]
|
||||
[(or (cyclic-set? b)
|
||||
(and (shared-set? b) (print-graph)))
|
||||
(let ([n shared-idx])
|
||||
(set! shared-idx (+ shared-idx 1))
|
||||
(set-mark! x h n)
|
||||
(let ([str (string-append "#" (number->string n) "=")])
|
||||
(let ([xbox (k x)])
|
||||
(make-cbox (+ (string-length str) (box-length xbox))
|
||||
(list str xbox)))))]
|
||||
[else (k x)]))))
|
||||
(define (boxify x)
|
||||
(cond
|
||||
[(null? x) "()"]
|
||||
[(vector? x) (boxify-shared x boxify-vector)]
|
||||
[(unshared-list? x) (boxify-shared x boxify-list)]
|
||||
[(pair? x) (boxify-shared x boxify-pair)]
|
||||
[(bytevector? x) (boxify-shared x boxify-bytevector)]
|
||||
[(struct? x) (boxify-shared x boxify-struct)]
|
||||
;[(setbox? x)
|
||||
; (let ([i (format "#~a=" (setbox-idx x))]
|
||||
; [b (boxify (setbox-data x))])
|
||||
; (make-cbox (+ (string-length i) (box-length b))
|
||||
; (list i b)))]
|
||||
;[(refbox? x) (format "#~a#" (refbox-idx x))]
|
||||
[else (format "~s" x)]))
|
||||
(boxify x))
|
||||
(define string-esc-table
|
||||
'((7 . "a")
|
||||
(8 . "b")
|
||||
|
|
@ -244,7 +337,7 @@
|
|||
(cond
|
||||
[(fx< n 10) (integer->char (fx+ n (char->integer #\0)))]
|
||||
[else (integer->char (fx+ (fx- n 10) (char->integer #\A)))]))
|
||||
(define (output x p)
|
||||
(define (output x p)
|
||||
(define (output-cbox x p col)
|
||||
(let g ([ls (cbox-boxes x)] [p p] [col col])
|
||||
(cond
|
||||
|
|
@ -317,16 +410,17 @@
|
|||
(display (mbox-str x) p)
|
||||
(f (mbox-val x) p (fx+ col (string-length (mbox-str x)))))
|
||||
(define (output-vbox x p col)
|
||||
(let ([ls (vbox-ls x)])
|
||||
(display (vbox-prefix x) p)
|
||||
(let ([ls (vbox-ls x)] [col (+ col (string-length (vbox-prefix x)))])
|
||||
(cond
|
||||
[(null? ls)
|
||||
(display "#()" p)
|
||||
(fx+ col 3)]
|
||||
(display "()" p)
|
||||
(fx+ col 2)]
|
||||
[else
|
||||
(display "#(" p)
|
||||
(display "(" p)
|
||||
(let g ([ls (cdr ls)] [p p]
|
||||
[col (f (car ls) p (fx+ col 2))]
|
||||
[start (fx+ col 2)])
|
||||
[col (f (car ls) p (fx+ col 1))]
|
||||
[start (fx+ col 1)])
|
||||
(cond
|
||||
[(null? ls)
|
||||
(display ")" p)
|
||||
|
|
@ -443,13 +537,9 @@
|
|||
[else
|
||||
(let ([col (f box p left)])
|
||||
(output-rest-multi box* sep* p col left))])))
|
||||
(display "(" p)
|
||||
(let ([col (fx+ col 1)]
|
||||
[box* (fbox-box* x)]
|
||||
(let ([box* (fbox-box* x)]
|
||||
[sep* (fbox-sep* x)])
|
||||
(let ([col (output-box-init (car box*) (cdr box*) sep* p col)])
|
||||
(display ")" p)
|
||||
(fx+ col 1))))
|
||||
(output-box-init (car box*) (cdr box*) sep* p col)))
|
||||
(define (f x p col)
|
||||
(cond
|
||||
[(string? x)
|
||||
|
|
@ -465,140 +555,10 @@
|
|||
(newline p))
|
||||
;;;
|
||||
|
||||
(define (hasher x h)
|
||||
(define (vec-graph x i j)
|
||||
(unless (fx= i j)
|
||||
(graph (vector-ref x i))
|
||||
(vec-graph x (fxadd1 i) j)))
|
||||
(define (vec-dynamic x i j)
|
||||
(unless (fx= i j)
|
||||
(dynamic (vector-ref x i))
|
||||
(vec-dynamic x (fxadd1 i) j)))
|
||||
(define rv #f)
|
||||
(define (graph x)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (n)
|
||||
(set! rv #t)
|
||||
(hashtable-set! h x (fxadd1 n)))]
|
||||
[else
|
||||
(hashtable-set! h x 0)
|
||||
(graph (car x))
|
||||
(graph (cdr x))])]
|
||||
[(vector? x)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (n)
|
||||
(set! rv #t)
|
||||
(hashtable-set! h x (fxadd1 n)))]
|
||||
[else
|
||||
(hashtable-set! h x 0)
|
||||
(vec-graph x 0 (vector-length x))])]
|
||||
[(gensym? x)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (n)
|
||||
(set! rv #t)
|
||||
(hashtable-set! h x (fxadd1 n)))])]))
|
||||
(define (dynamic x)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (n)
|
||||
(set! rv #t)
|
||||
(hashtable-set! h x (fxadd1 n)))]
|
||||
[else
|
||||
(hashtable-set! h x 0)
|
||||
(dynamic (car x))
|
||||
(dynamic (cdr x))
|
||||
(when (and (hashtable-ref h x #f)
|
||||
(fxzero? (hashtable-ref h x #f)))
|
||||
(hashtable-set! h x #f))])]
|
||||
[(vector? x)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (n)
|
||||
(set! rv #t)
|
||||
(hashtable-set! h x (fxadd1 n)))]
|
||||
[else
|
||||
(hashtable-set! h x 0)
|
||||
(vec-dynamic x 0 (vector-length x))
|
||||
(when (and (hashtable-ref h x #f)
|
||||
(fxzero? (hashtable-ref h x #f)))
|
||||
(hashtable-set! h x #f))])]))
|
||||
(if (print-graph)
|
||||
(graph x)
|
||||
(dynamic x))
|
||||
rv)
|
||||
|
||||
(define-struct setbox (idx data))
|
||||
(define-struct refbox (idx))
|
||||
|
||||
(define (rewrite-shared x h)
|
||||
(define counter 0)
|
||||
(let f ([x x])
|
||||
(cond
|
||||
[(pair? x)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (n)
|
||||
(cond
|
||||
[(setbox? n)
|
||||
(make-refbox (setbox-idx n))]
|
||||
[(and (fixnum? n) (fx> n 0))
|
||||
(let ([box (make-setbox counter #f)])
|
||||
(set! counter (add1 counter))
|
||||
(hashtable-set! h x box)
|
||||
(let* ([a (f (car x))]
|
||||
[d (f (cdr x))])
|
||||
(set-setbox-data! box (cons a d))
|
||||
box))]
|
||||
[else
|
||||
(let* ([a (f (car x))]
|
||||
[d (f (cdr x))])
|
||||
(if (and (eq? a (car x))
|
||||
(eq? d (cdr x)))
|
||||
x
|
||||
(cons a d)))]))]
|
||||
[else
|
||||
(let* ([a (f (car x))]
|
||||
[d (f (cdr x))])
|
||||
(if (and (eq? a (car x))
|
||||
(eq? d (cdr x)))
|
||||
x
|
||||
(cons a d)))])]
|
||||
[(vector? x)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (n)
|
||||
(cond
|
||||
[(setbox? n)
|
||||
(make-refbox (setbox-idx n))]
|
||||
[(and (fixnum? n) (fx> n 0))
|
||||
(let ([box (make-setbox counter #f)])
|
||||
(set! counter (add1 counter))
|
||||
(hashtable-set! h x box)
|
||||
(set-setbox-data! box
|
||||
(list->vector
|
||||
(map1ltr f (vector->list x))))
|
||||
box)]
|
||||
[else
|
||||
(list->vector (map1ltr f (vector->list x)))]))]
|
||||
[else
|
||||
(list->vector (map1ltr f (vector->list x)))])]
|
||||
[else x])))
|
||||
|
||||
(define (unshare x)
|
||||
(define (pretty x p)
|
||||
(let ([h (make-eq-hashtable)])
|
||||
(if (hasher x h)
|
||||
(rewrite-shared x h)
|
||||
x)))
|
||||
;;;
|
||||
(define (pretty x p)
|
||||
(output (boxify (unshare x)) p))
|
||||
(traverse x h)
|
||||
(output (boxify x h) p)))
|
||||
;;;
|
||||
(define pretty-print
|
||||
(case-lambda
|
||||
|
|
|
|||
|
|
@ -17,7 +17,8 @@
|
|||
(library (ikarus writer)
|
||||
|
||||
(export write display format printf fprintf print-error
|
||||
print-unicode print-graph put-datum traverse)
|
||||
print-unicode print-graph put-datum traverse
|
||||
traversal-helpers)
|
||||
|
||||
(import
|
||||
(rnrs hashtables)
|
||||
|
|
@ -39,42 +40,57 @@
|
|||
(make-parameter #t))
|
||||
|
||||
|
||||
;;; association list in hash table is one of the following forms:
|
||||
;;;
|
||||
;;; a fixnum:
|
||||
(define cyclic-bit #b001)
|
||||
(define shared-bit #b010)
|
||||
(define marked-bit #b100)
|
||||
(define mark-shift 3)
|
||||
;;;
|
||||
;;; or a pair of a fixnum (above) and a cache:
|
||||
(define-struct cache (string object next))
|
||||
(define (cyclic-set? b)
|
||||
(fx= (fxand b cyclic-bit) cyclic-bit))
|
||||
(define (shared-set? b)
|
||||
(fx= (fxand b shared-bit) shared-bit))
|
||||
(define (mark-set? b)
|
||||
(fx= (fxand b marked-bit) marked-bit))
|
||||
|
||||
(define (set-mark! x h n)
|
||||
(let ([b (hashtable-ref h x #f)])
|
||||
(cond
|
||||
[(fixnum? b)
|
||||
(hashtable-set! h x
|
||||
(fxior (fxsll n mark-shift) marked-bit b))]
|
||||
[else
|
||||
(set-car! b
|
||||
(fxior (fxsll n mark-shift) marked-bit (car b)))])))
|
||||
(module traversal-helpers
|
||||
(cyclic-set? shared-set? mark-set? set-mark! set-shared! shared?
|
||||
shared-bit cyclic-bit marked-bit mark-shift
|
||||
make-cache cache-string cache-object cache-next)
|
||||
;;; association list in hash table is one of the following forms:
|
||||
;;;
|
||||
;;; a fixnum:
|
||||
(define cyclic-bit #b001)
|
||||
(define shared-bit #b010)
|
||||
(define marked-bit #b100)
|
||||
(define mark-shift 3)
|
||||
;;;
|
||||
;;; or a pair of a fixnum (above) and a cache:
|
||||
(define-struct cache (string object next))
|
||||
(define (cyclic-set? b)
|
||||
(fx= (fxand b cyclic-bit) cyclic-bit))
|
||||
(define (shared-set? b)
|
||||
(fx= (fxand b shared-bit) shared-bit))
|
||||
(define (mark-set? b)
|
||||
(fx= (fxand b marked-bit) marked-bit))
|
||||
|
||||
(define (set-mark! x h n)
|
||||
(let ([b (hashtable-ref h x #f)])
|
||||
(cond
|
||||
[(fixnum? b)
|
||||
(hashtable-set! h x
|
||||
(fxior (fxsll n mark-shift) marked-bit b))]
|
||||
[else
|
||||
(set-car! b
|
||||
(fxior (fxsll n mark-shift) marked-bit (car b)))])))
|
||||
|
||||
(define (set-shared! x h)
|
||||
(let ([b (hashtable-ref h x #f)])
|
||||
(cond
|
||||
[(fixnum? b)
|
||||
(hashtable-set! h x (fxior shared-bit b))]
|
||||
[else
|
||||
(set-car! b (fxior shared-bit (car b)))])))
|
||||
|
||||
(define (shared? x h)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (b)
|
||||
(if (fixnum? b)
|
||||
(shared-set? b)
|
||||
(let ([b (car b)])
|
||||
(shared-set? b))))]
|
||||
[else #f])))
|
||||
(import traversal-helpers)
|
||||
|
||||
|
||||
(define (shared? x h)
|
||||
(cond
|
||||
[(hashtable-ref h x #f) =>
|
||||
(lambda (b)
|
||||
(if (fixnum? b)
|
||||
(shared-set? b)
|
||||
(let ([b (car b)])
|
||||
(shared-set? b))))]
|
||||
[else #f]))
|
||||
(define (cannot-happen)
|
||||
(error 'ikarus-writer "internal error"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
1627
|
||||
1628
|
||||
|
|
|
|||
Loading…
Reference in New Issue