diff --git a/lab/io-spec.ss b/lab/io-spec.ss index aacab1f..0bcf8f6 100644 --- a/lab/io-spec.ss +++ b/lab/io-spec.ss @@ -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) diff --git a/lab/io-test.ss b/lab/io-test.ss index 0fc4365..c053ef2 100755 --- a/lab/io-test.ss +++ b/lab/io-test.ss @@ -8,9 +8,9 @@ (syntax-rules () [(_ name body) (begin - (printf "running ~s ..." 'name) + (printf "running ~s ... " 'name) body - (printf " ok\n"))])) + (printf "ok\n"))])) (define (make-n-byte-custom-binary-input-port n) (assert (<= 0 n 256)) diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss index 0636330..f9fc444 100644 --- a/scheme/ikarus.writer.ss +++ b/scheme/ikarus.writer.ss @@ -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) diff --git a/scheme/last-revision b/scheme/last-revision index f37c021..8cdd21d 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1191 +1192