From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 12 Dec 2022 01:57:04 +0000 (-0800)
Subject: Fix bug#63507.
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6abd9e5f4845af1908a53bc7f6b72d79cb573fd5;p=mit-scheme.git

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 6685f4046..7193fa271 100644
--- 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 9b8e2e9da..1f6d24b8e 100644
--- 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