Fix bug#63507.

Continue to use uninterned symbols, but incorporate the original symbol's name
into the rename.

diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm
index 6685f40460c46fe2934d595524f25ff6b6184934..7193fa271f7445de26f95ae888c0fbac5e2613b2 100644 (file)
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -54,15 +54,17 @@ USA.
   (make-unsettable-parameter 'unbound))
 
 (define-record-type <rename-db>
-    (make-rename-db mapping unmapping)
+    (make-rename-db mapping unmapping counter)
     rename-db?
   (mapping rdb:mapping)
-  (unmapping rdb:unmapping))
+  (unmapping rdb:unmapping)
+  (counter rdb:counter rdb:set-counter!))
 
 (define (with-identifier-renaming thunk)
   (parameterize ((rename-db
                  (make-rename-db (make-strong-eq-hash-table)
-                                 (make-strong-eq-hash-table))))
+                                 (make-strong-eq-hash-table)
+                                 0)))
     (post-process-output (thunk))))
 
 (define (post-process-output expression)
@@ -88,13 +90,23 @@ USA.
        (let ((entry (assq frame-id (cdr bucket))))
          (if entry
              (cdr entry)
-             (let ((rename (generate-uninterned-symbol)))
-               (set-cdr! bucket
-                         (cons (cons frame-id rename)
-                               (cdr bucket)))
+             (let ((rename (rename-id original)))
+               (set-cdr! bucket (cons (cons frame-id rename) (cdr bucket)))
                (hash-table-set! unmapping rename original)
                rename)))))))
 
+(define (rename-id id)
+  (let* ((rdb (rename-db))
+        (n (rdb:counter rdb))
+        (rename
+         (string->uninterned-symbol
+          (string-append "."
+                         (symbol->string (identifier->symbol id))
+                         "."
+                         (number->string n)))))
+    (rdb:set-counter! rdb (+ n 1))
+    rename))
+
 (define (mark-local-bindings bound body mark-safe!)
   (let ((free
         (lset-difference eq?

diff --git a/tests/runtime/test-syntax-rename.scm b/tests/runtime/test-syntax-rename.scm
index 9b8e2e9da7b48090e64ec363e7058336ea630da0..1f6d24b8e5fbb9ce9064d9cdf9494e0c7fd4cb9b 100644 (file)
--- a/tests/runtime/test-syntax-rename.scm
+++ b/tests/runtime/test-syntax-rename.scm
@@ -84,4 +84,26 @@ USA.
                              (define (c x)
                                (+ a x)))
                            system-global-environment))
-                 '(begin (define a 3) (define b 4) (define (c x) (+ a x))))))
\ No newline at end of file
+                 '(begin (define a 3) (define b 4) (define (c x) (+ a x))))))
+
+(define-test 'bug-63507
+  (lambda ()
+    (let ((result
+          (unsyntax
+           (syntax
+            '(let ()
+               (define-syntax foo
+                 (syntax-rules ()
+                   ((foo x)
+                    (let ((t x))
+                      t))))
+               (foo 123))
+            test-environment))))
+      (assert-matches result
+                     '(let ()
+                        (let ((?x 123))
+                          ?x)))
+      (assert-true
+       (string-prefix? ".t."
+                      (symbol->string
+                       (identifier->symbol (caddr (caddr result)))))))))
\ No newline at end of file