Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 22:59:16 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

supporting cyclic generic objects

Browse source
This commit is contained in:
Alex Shinn 2011-10-30 23:59:06 +09:00
parent cf7afa1e54
commit 86b9cc45be
2 changed files with 30 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
lib/srfi/38.scm
View file

@ -17,7 +17,18 @@
(set! seen (cons (cons x 1) seen))
(do ((i 0 (+ i 1)))
((= i (vector-length x)))
(find (vector-ref x i))))))
(find (vector-ref x i))))
(else
(let* ((type (type-of x))
(slots (and type (type-slots type))))
(cond
(slots
(set! seen (cons (cons x 1) seen))
(let lp ((i 0) (ls slots))
(cond
((pair? ls)
(find (slot-ref type x i))
(lp (+ i 1) (cdr ls)))))))))))
(let extract ((ls seen) (res '()))
(cond
((null? ls) res)
@ -91,6 +102,9 @@
(display " " out)
(wr (vector-ref x i))))))
(display ")" out))
((let ((type (type-of x)))
(and (type? type) (type-printer type)))
=> (lambda (printer) (printer x wr out)))
(else
(write x out))))))))))
@ -317,6 +331,19 @@
(let ((elt (vector-ref x i)))
(if (hole? elt)
(vector-set! x i (fill-hole elt))
(patch elt)))))))
(patch elt)))))
(else
(let* ((type (type-of x))
(slots (and type (type-slots type))))
(cond
(slots
(let lp ((i 0) (ls slots))
(cond
((pair? ls)
(let ((elt (slot-ref type x i)))
(if (hole? elt)
(slot-set! type x i (fill-hole elt))
(patch elt))
(lp (+ i 1) (cdr ls))))))))))))
(define read/ss read-with-shared-structure)

2
lib/srfi/38.sld
View file

@ -1,6 +1,6 @@
(define-library (srfi 38)
(import (scheme))
(import (scheme) (chibi ast))
(export write-with-shared-structure write/ss
read-with-shared-structure read/ss)
(include "38.scm"))