conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fixes bug 174594: Record read/write now terminate on cycles.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-07 01:41:21 -05:00
parent 1f352825f5
commit c0191a8283
4 changed files with 41 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lab/io-spec.ss
View File

@ -160,7 +160,7 @@
(syntax-rules ()
[(_ name)
(define (name . args)
(error 'name "not implemented" args))]))
(apply error 'name "not implemented" args))]))
;;; ----------------------------------------------------------
(module (get-char lookahead-char)

38
scheme/ikarus.writer.ss
View File

@ -633,7 +633,23 @@
[(hashtable-ref h x #f) =>
(lambda (n)
(hashtable-set! h x (fxadd1 n)))])]
;;; FIXME: recursive records/structs
[(struct? x)
(cond
[(hashtable-ref h x #f) =>
(lambda (n)
(hashtable-set! h x (fxadd1 n)))]
[else
(hashtable-set! h x 0)
(let ([rtd (struct-type-descriptor x)])
(unless
(and (record-type-descriptor? rtd)
(record-type-opaque? rtd))
(graph (struct-name x) h)
(let ([n (struct-length x)])
(let f ([idx 0])
(unless (fx= idx n)
(graph (struct-ref x idx) h)
(f (fxadd1 idx)))))))])]
))
(define (dynamic x h)
(cond
@ -660,6 +676,26 @@
(when (and (hashtable-ref h x #f)
(fxzero? (hashtable-ref h x #f)))
(hashtable-set! h x #f))])]
[(struct? x)
(cond
[(hashtable-ref h x #f) =>
(lambda (n)
(hashtable-set! h x (fxadd1 n)))]
[else
(hashtable-set! h x 0)
(let ([rtd (struct-type-descriptor x)])
(unless
(and (record-type-descriptor? rtd)
(record-type-opaque? rtd))
(dynamic (struct-name x) h)
(let ([n (struct-length x)])
(let f ([idx 0])
(unless (fx= idx n)
(dynamic (struct-ref x idx) h)
(f (fxadd1 idx)))))))
(when (and (hashtable-ref h x #f)
(fxzero? (hashtable-ref h x #f)))
(hashtable-set! h x #f))])]
;;; FIXME: recursive records/structs
))
(if (print-graph)

2
scheme/last-revision
View File

@ -1 +1 @@
1191
1192