Fix strip-syntactic-closures so it handles circularity.

diff --git a/src/runtime/syntax.scm b/src/runtime/syntax.scm
index c102c994cf6768ad5203675c1f7dbea8ad4e4f91..f69031146a91b3514c863f4f77c734b54b5b8085 100644 (file)
--- a/src/runtime/syntax.scm
+++ b/src/runtime/syntax.scm
@@ -271,19 +271,20 @@ USA.
       (list (syntactic-closure-form closure)))))
 
 (define (strip-syntactic-closures object)
-  (if (let loop ((object object))
-       (if (pair? object)
-           (or (loop (car object))
-               (loop (cdr object)))
-           (syntactic-closure? object)))
-      (let loop ((object object))
-       (if (pair? object)
-           (cons (loop (car object))
-                 (loop (cdr object)))
-           (if (syntactic-closure? object)
-               (loop (syntactic-closure-form object))
-               object)))
-      object))
+  (let ((seen (make-key-weak-eq-hash-table)))
+    (let loop ((object object))
+      (cond ((pair? object)
+            (if (hash-table-ref/default seen object #f)
+                object
+                (begin
+                  (hash-table-set! seen object #t)
+                  (set-car! object (loop (car object)))
+                  (set-cdr! object (loop (cdr object)))
+                  object)))
+           ((syntactic-closure? object)
+            (loop (syntactic-closure-form object)))
+           (else
+            object)))))
 \f
 ;;;; Identifiers
 

diff --git a/tests/runtime/test-syntax.scm b/tests/runtime/test-syntax.scm
index bb142a596f0c5a3787e397ac65bf09dc60bc1383..1bad15b09942accc7c6dd583c8ef9e79f5d09315 100644 (file)
--- a/tests/runtime/test-syntax.scm
+++ b/tests/runtime/test-syntax.scm
@@ -265,3 +265,26 @@ USA.
                         (list y x ...))))
                    (bar 1 2))
                  '(2 1 19))))
+
+(define-test 'strip-syntactic-closures
+  (lambda ()
+    (let ((x (eval (read-from-string "'(a #1=(b . #1#))") test-environment)))
+      (assert-list x)
+      (assert-= (length x) 2)
+      (assert-eq (car x) 'a)
+      (assert-pair (cadr x))
+      (assert-eq (car (cadr x)) 'b)
+      (assert-eq (cdr (cadr x)) (cadr x)))
+    (let ((x
+          (eval (read-from-string "'(a #1=(b . #1#) #2=(c . #1#) #2#)")
+                test-environment)))
+      (assert-list x)
+      (assert-= (length x) 4)
+      (assert-eq (car x) 'a)
+      (assert-pair (cadr x))
+      (assert-eq (car (cadr x)) 'b)
+      (assert-eq (cdr (cadr x)) (cadr x))
+      (assert-pair (caddr x))
+      (assert-eq (car (caddr x)) 'c)
+      (assert-eq (cdr (caddr x)) (cadr x))
+      (assert-eq (cadddr x) (caddr x)))))
\ No newline at end of file