From 86b9cc45becf046bf96ea991f46b3ed8141d6f7e Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 30 Oct 2011 23:59:06 +0900 Subject: [PATCH] supporting cyclic generic objects --- lib/srfi/38.scm | 31 +++++++++++++++++++++++++++++-- lib/srfi/38.sld | 2 +- 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/lib/srfi/38.scm b/lib/srfi/38.scm index b8dde4cf..72f64087 100644 --- a/lib/srfi/38.scm +++ b/lib/srfi/38.scm @@ -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) diff --git a/lib/srfi/38.sld b/lib/srfi/38.sld index 72f3417d..7b7a5de9 100644 --- a/lib/srfi/38.sld +++ b/lib/srfi/38.sld @@ -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"))