- 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 2008-10-16 02:43:03 -04:00
parent f570ea8c2a
commit 0d91ab9774
6 changed files with 277 additions and 298 deletions

View File

@ -14,7 +14,8 @@ EXTRA_DIST=ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
ikarus.lists.ss ikarus.load.ss ikarus.main.ss \ ikarus.lists.ss ikarus.load.ss ikarus.main.ss \
ikarus.multiple-values.ss ikarus.numerics.ss \ ikarus.multiple-values.ss ikarus.numerics.ss \
ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.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.records.procedural.ss ikarus.conditions.ss \
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \ ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \ ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \

View File

@ -169,7 +169,8 @@ EXTRA_DIST = ikarus.boot.4.prebuilt ikarus.boot.8.prebuilt \
ikarus.lists.ss ikarus.load.ss ikarus.main.ss \ ikarus.lists.ss ikarus.load.ss ikarus.main.ss \
ikarus.multiple-values.ss ikarus.numerics.ss \ ikarus.multiple-values.ss ikarus.numerics.ss \
ikarus.pairs.ss ikarus.posix.ss ikarus.predicates.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.records.procedural.ss ikarus.conditions.ss \
ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \ ikarus.singular-objects.ss ikarus.sort.ss ikarus.strings.ss \
ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \ ikarus.structs.ss ikarus.symbols.ss ikarus.timer.ss ikarus.trace.ss \

View File

@ -55,6 +55,7 @@
(set-fmt! 'let-values '(_ (0 [e 0 e] ...) tab e tab e* ...)) (set-fmt! 'let-values '(_ (0 [e 0 e] ...) tab e tab e* ...))
(set-fmt! 'cond '(_ tab [0 e ...] ...)) (set-fmt! 'cond '(_ tab [0 e ...] ...))
(set-fmt! 'define '(_ name tab e ...)) (set-fmt! 'define '(_ name tab e ...))
(set-fmt! 'set! '(_ name tab e))
(set-fmt! 'case-lambda (set-fmt! 'case-lambda
'(_ tab [0 e ...] ...)) '(_ tab [0 e ...] ...))
(set-fmt! 'struct-case (set-fmt! 'struct-case

View File

@ -18,6 +18,7 @@
(export pretty-print pretty-width) (export pretty-print pretty-width)
(import (import
(rnrs hashtables) (rnrs hashtables)
(only (ikarus writer) traverse traversal-helpers)
(only (ikarus.pretty-formats) get-fmt) (only (ikarus.pretty-formats) get-fmt)
(except (ikarus) pretty-print pretty-width)) (except (ikarus) pretty-print pretty-width))
(define (map1ltr f ls) (define (map1ltr f ls)
@ -39,7 +40,7 @@
(define-struct cbox (length boxes)) (define-struct cbox (length boxes))
(define-struct pbox (length ls last)) (define-struct pbox (length ls last))
(define-struct mbox (length str val)) (define-struct mbox (length str val))
(define-struct vbox (length ls)) (define-struct vbox (length prefix ls))
(define-struct fbox (length box* sep*)) (define-struct fbox (length box* sep*))
(define (box-length x) (define (box-length x)
(cond (cond
@ -50,7 +51,8 @@
[(vbox? x) (vbox-length x)] [(vbox? x) (vbox-length x)]
[(fbox? x) (fbox-length x)] [(fbox? x) (fbox-length x)]
[else (die 'boxify "invalid box" x)])) [else (die 'boxify "invalid box" x)]))
(define (boxify x) (define (boxify x h)
(define shared-idx 0)
(define (conc . a*) (define (conc . a*)
(let ([n (let ([n
(let f ([a* a*] [len 0]) (let f ([a* a*] [len 0])
@ -59,11 +61,11 @@
[else [else
(f (cdr a*) (fx+ len (box-length (car a*))))]))]) (f (cdr a*) (fx+ len (box-length (car a*))))]))])
(make-cbox n a*))) (make-cbox n a*)))
(define (boxify-list ls alt-fmt*) (define (boxify-list ls)
(define (sum-box* ls) (define (sum-box* ls)
(cond (cond
[(null? (cdr ls)) [(null? (cdr ls))
(fx+ (box-length (car ls)) 2)] (box-length (car ls))]
[else [else
(fx+ (box-length (car ls)) (fx+ (box-length (car ls))
(fxadd1 (sum-box* (cdr ls))))])) (fxadd1 (sum-box* (cdr ls))))]))
@ -82,16 +84,16 @@
(cond (cond
[(not (pair? fmt)) #t] [(not (pair? fmt)) #t]
[(eq? (car fmt) 'read-macro) [(eq? (car fmt) 'read-macro)
(and (list? ls) (fx= (length ls) 2))] (and (unshared-list? ls) (fx= (length ls) 2))]
[else [else
(let ([a (car fmt)] [fmt (cdr fmt)]) (let ([a (car fmt)] [fmt (cdr fmt)])
(cond (cond
[(or (eq? a 'tab) (fixnum? a)) [(or (eq? a 'tab) (fixnum? a))
(good-match? fmt ls)] (good-match? fmt ls)]
[(and (pair? fmt) (eq? (car fmt) '...)) [(and (pair? fmt) (eq? (car fmt) '...))
(and (list? ls) (and (unshared-list? ls)
(andmap (lambda (x) (good-match? a x)) ls))] (andmap (lambda (x) (good-match? a x)) ls))]
[(pair? ls) [(and (pair? ls) (not (graphed? ls)))
(and (good-match? a (car ls)) (and (good-match? a (car ls))
(good-match? fmt (cdr ls)))] (good-match? fmt (cdr ls)))]
[else #f]))])) [else #f]))]))
@ -110,7 +112,8 @@
[else alt-fmt*])) [else alt-fmt*]))
(define (return sep* box*) (define (return sep* box*)
(let ([n (sum-box* box*)]) (let ([n (sum-box* box*)])
(make-fbox n box* sep*))) (conc "(" (make-fbox n box* sep*) ")")))
(define (boxify-list ls alt-fmt*)
(let ([a (car ls)]) (let ([a (car ls)])
(cond (cond
[(applicable-formats a alt-fmt*) => [(applicable-formats a alt-fmt*) =>
@ -151,10 +154,9 @@
(define (skip-fmt x) (define (skip-fmt x)
(let-values ([(tab subfmt dots fmt) (parse-fmt x)]) (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
fmt))) fmt)))
;(import M)
(define (boxify/fmt fmt x) (define (boxify/fmt fmt x)
(cond (cond
[(and (pair? fmt) (pair? x) (list? x)) [(and (pair? fmt) (unshared-list? x))
(boxify-list x (boxify-list x
(if (eq? (car fmt) 'alt) (if (eq? (car fmt) 'alt)
(cdr fmt) (cdr fmt)
@ -170,6 +172,7 @@
(map1ltr (lambda (x) (boxify/fmt (sub-fmt fmt) x)) (map1ltr (lambda (x) (boxify/fmt (sub-fmt fmt) x))
ls))] ls))]
[else [else
(let ([a (boxify/fmt (sub-fmt fmt) a)])
(let-values ([(sep* ls) (let-values ([(sep* ls)
(let f ([fmt (skip-fmt fmt)] [ls (cdr ls)]) (let f ([fmt (skip-fmt fmt)] [ls (cdr ls)])
(cond (cond
@ -177,30 +180,35 @@
(values '() '())] (values '() '())]
[(fmt-dots? fmt) [(fmt-dots? fmt)
(values (fmt-tab fmt) (values (fmt-tab fmt)
(map1ltr (lambda (x) (map1ltr
(lambda (x)
(boxify/fmt (sub-fmt fmt) x)) (boxify/fmt (sub-fmt fmt) x))
ls))] ls))]
[else [else
(let ([a
(boxify/fmt (sub-fmt fmt)
(car ls))])
(let-values ([(f^ l^) (let-values ([(f^ l^)
(f (skip-fmt fmt) (cdr ls))]) (f (skip-fmt fmt)
(cdr ls))])
(values (cons (fmt-tab fmt) f^) (values (cons (fmt-tab fmt) f^)
(cons (boxify/fmt (cons a l^))))]))])
(sub-fmt fmt) (return sep* (cons a ls))))])))]
(car ls))
l^)))]))])
(return sep* (cons (boxify/fmt (sub-fmt fmt) a) ls)))])))]
[else [else
(return (gensep*-default ls) (map1ltr boxify ls))]))) (return (gensep*-default ls) (map1ltr boxify ls))])))
(boxify-list ls '()))
(define (boxify-pair x) (define (boxify-pair x)
(let-values ([(ls last) (define (boxify-cdrs x)
(let f ([x x])
(cond (cond
[(pair? x) [(and (pair? x) (not (graphed? x)))
(let ([a (boxify (car x))]) (let ([a (boxify (car x))])
(let-values ([(ls last) (f (cdr x))]) (let-values ([(ls last) (boxify-cdrs (cdr x))])
(values (cons a ls) last)))] (values (cons a ls) last)))]
[else [else
(values '() (boxify x))]))]) (values '() (boxify x))]))
(let ([a (boxify (car x))])
(let-values ([(ls last) (boxify-cdrs (cdr x))])
(let ([ls (cons a ls)])
(let ([n (let ([n
(let f ([ls ls] [n 4]) (let f ([ls ls] [n 4])
(cond (cond
@ -208,7 +216,7 @@
[else [else
(f (cdr ls) (f (cdr ls)
(fx+ (fxadd1 n) (box-length (car ls))))]))]) (fx+ (fxadd1 n) (box-length (car ls))))]))])
(make-pbox (fx+ n (box-length last)) ls last)))) (make-pbox (fx+ n (box-length last)) ls last))))))
(define (boxify-vector x) (define (boxify-vector x)
(let ([ls (map1ltr boxify (vector->list x))]) (let ([ls (map1ltr boxify (vector->list x))])
(let ([n (let ([n
@ -217,19 +225,104 @@
[(null? ls) n] [(null? ls) n]
[else [else
(f (cdr ls) (fx+ n (box-length (car ls))))]))]) (f (cdr ls) (fx+ n (box-length (car ls))))]))])
(make-vbox (fx+ (fx+ n 2) (vector-length x)) ls)))) (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 (cond
[(null? x) "()"] [(null? x) "()"]
[(vector? x) (boxify-vector x)] [(vector? x) (boxify-shared x boxify-vector)]
[(list? x) (boxify-list x '())] [(unshared-list? x) (boxify-shared x boxify-list)]
[(pair? x) (boxify-pair x)] [(pair? x) (boxify-shared x boxify-pair)]
[(setbox? x) [(bytevector? x) (boxify-shared x boxify-bytevector)]
(let ([i (format "#~a=" (setbox-idx x))] [(struct? x) (boxify-shared x boxify-struct)]
[b (boxify (setbox-data x))]) ;[(setbox? x)
(make-cbox (+ (string-length i) (box-length b)) ; (let ([i (format "#~a=" (setbox-idx x))]
(list i b)))] ; [b (boxify (setbox-data x))])
[(refbox? x) (format "#~a#" (refbox-idx x))] ; (make-cbox (+ (string-length i) (box-length b))
; (list i b)))]
;[(refbox? x) (format "#~a#" (refbox-idx x))]
[else (format "~s" x)])) [else (format "~s" x)]))
(boxify x))
(define string-esc-table (define string-esc-table
'((7 . "a") '((7 . "a")
(8 . "b") (8 . "b")
@ -317,16 +410,17 @@
(display (mbox-str x) p) (display (mbox-str x) p)
(f (mbox-val x) p (fx+ col (string-length (mbox-str x))))) (f (mbox-val x) p (fx+ col (string-length (mbox-str x)))))
(define (output-vbox x p col) (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 (cond
[(null? ls) [(null? ls)
(display "#()" p) (display "()" p)
(fx+ col 3)] (fx+ col 2)]
[else [else
(display "#(" p) (display "(" p)
(let g ([ls (cdr ls)] [p p] (let g ([ls (cdr ls)] [p p]
[col (f (car ls) p (fx+ col 2))] [col (f (car ls) p (fx+ col 1))]
[start (fx+ col 2)]) [start (fx+ col 1)])
(cond (cond
[(null? ls) [(null? ls)
(display ")" p) (display ")" p)
@ -443,13 +537,9 @@
[else [else
(let ([col (f box p left)]) (let ([col (f box p left)])
(output-rest-multi box* sep* p col left))]))) (output-rest-multi box* sep* p col left))])))
(display "(" p) (let ([box* (fbox-box* x)]
(let ([col (fx+ col 1)]
[box* (fbox-box* x)]
[sep* (fbox-sep* x)]) [sep* (fbox-sep* x)])
(let ([col (output-box-init (car box*) (cdr box*) sep* p col)]) (output-box-init (car box*) (cdr box*) sep* p col)))
(display ")" p)
(fx+ col 1))))
(define (f x p col) (define (f x p col)
(cond (cond
[(string? x) [(string? x)
@ -465,140 +555,10 @@
(newline p)) (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)
(let ([h (make-eq-hashtable)])
(if (hasher x h)
(rewrite-shared x h)
x)))
;;;
(define (pretty x p) (define (pretty x p)
(output (boxify (unshare x)) p)) (let ([h (make-eq-hashtable)])
(traverse x h)
(output (boxify x h) p)))
;;; ;;;
(define pretty-print (define pretty-print
(case-lambda (case-lambda

View File

@ -17,7 +17,8 @@
(library (ikarus writer) (library (ikarus writer)
(export write display format printf fprintf print-error (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 (import
(rnrs hashtables) (rnrs hashtables)
@ -39,6 +40,10 @@
(make-parameter #t)) (make-parameter #t))
(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: ;;; association list in hash table is one of the following forms:
;;; ;;;
;;; a fixnum: ;;; a fixnum:
@ -66,6 +71,14 @@
(set-car! b (set-car! b
(fxior (fxsll n mark-shift) marked-bit (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) (define (shared? x h)
(cond (cond
[(hashtable-ref h x #f) => [(hashtable-ref h x #f) =>
@ -74,7 +87,10 @@
(shared-set? b) (shared-set? b)
(let ([b (car b)]) (let ([b (car b)])
(shared-set? b))))] (shared-set? b))))]
[else #f])) [else #f])))
(import traversal-helpers)
(define (cannot-happen) (define (cannot-happen)
(error 'ikarus-writer "internal error")) (error 'ikarus-writer "internal error"))

View File

@ -1 +1 @@
1627 1628