Fix bug #63438.

Abandon overly-clever mechanism to use generated interned symbols in syntaxer
output.  Leaving the uninterned renames will always work.

diff --git a/src/runtime/syntax-rename.scm b/src/runtime/syntax-rename.scm
index c734ebf9ac5f0f98b7e23f867cc23e040ff2d142..6685f40460c46fe2934d595524f25ff6b6184934 100644 (file)
--- a/src/runtime/syntax-rename.scm
+++ b/src/runtime/syntax-rename.scm
@@ -44,131 +44,76 @@ USA.
 ;;; collisions.  A name collision occurs when one of the bound identifiers has
 ;;; an original name that is the same as the original name of one of the free
 ;;; identifiers.  If there are no name collisions, then it is safe to restore
-;;; the original name.  Otherwise the bound identifier is replaced by an
-;;; interned symbol with a computed name that's designed to be unique.
+;;; the original name.
 
 (declare (usual-integrations))
 
 (add-boot-deps! '(runtime dynamic) '(runtime predicate-dispatch))
 \f
-(define (make-local-identifier-renamer)
-  ((rdb:identifier-renamer (rename-db)) new-identifier))
-
-(define (with-identifier-renaming thunk)
-  (parameterize ((rename-db (initial-rename-db)))
-    (post-process-output (thunk))))
-
 (define-deferred rename-db
   (make-unsettable-parameter 'unbound))
 
 (define-record-type <rename-db>
-    (make-rename-db identifier-renamer lookup-rename)
+    (make-rename-db mapping unmapping)
     rename-db?
-  (identifier-renamer rdb:identifier-renamer)
-  (lookup-rename rdb:lookup-rename))
-
-(define (initial-rename-db)
-  (let ((frame-id 0)
-       (mapping-table (make-strong-eq-hash-table))
-       (unmapping-table (make-strong-eq-hash-table)))
-
-    (define (identifier-renamer get-rename)
-      (let ((delayed-frame-id (delay (new-frame-id))))
-       (lambda (identifier)
-         (guarantee identifier? identifier)
-         (let ((bucket
-                (hash-table-intern! mapping-table
-                                    identifier
-                                    (lambda () (list 'bucket)))))
-           (let ((entry (assq delayed-frame-id (cdr bucket))))
-             (if entry
-                 (cdr entry)
-                 (let ((rename (get-rename identifier)))
-                   (set-cdr! bucket
-                             (cons (cons delayed-frame-id rename)
-                                   (cdr bucket)))
-                   (hash-table-set! unmapping-table
-                                    rename
-                                    (cons identifier delayed-frame-id))
-                   rename)))))))
-
-    (define (new-frame-id)
-      (let ((n (+ frame-id 1)))
-       (set! frame-id n)
-       n))
-
-    (define (lookup-rename rename)
-      (hash-table-ref/default unmapping-table rename #f))
-
-    (make-rename-db identifier-renamer lookup-rename)))
-
-(define (rename->original rename)
-  (let ((entry ((rdb:lookup-rename (rename-db)) rename)))
-    (if entry
-       (car entry)
-       rename)))
-\f
-;;;; Post processing
+  (mapping rdb:mapping)
+  (unmapping rdb:unmapping))
+
+(define (with-identifier-renaming thunk)
+  (parameterize ((rename-db
+                 (make-rename-db (make-strong-eq-hash-table)
+                                 (make-strong-eq-hash-table))))
+    (post-process-output (thunk))))
 
 (define (post-process-output expression)
   (trace-reduce expression)
   (let ((safe-set (make-strong-eq-hash-table)))
     (compute-substitution expression
-                         (lambda (rename original)
-                           (hash-table-set! safe-set rename original)))
-    (alpha-substitute (make-final-substitution safe-set) expression)))
+      (lambda (rename original)
+       (hash-table-set! safe-set rename original)))
+    (alpha-substitute (lambda (rename)
+                       (hash-table-ref/default safe-set rename rename))
+                     expression)))
 
-(define (mark-local-bindings bound body mark-safe!)
-  (let ((free
-        (lset-difference eq?
-                         (compute-substitution body mark-safe!)
-                         bound)))
-    (for-each (lambda (rename)
-               (let ((original (rename->original rename)))
-                 (if (and (symbol? original)
-                          (not (any (lambda (rename*)
-                                      (eq? original
-                                           (rename->original rename*)))
-                                    free)))
-                     (mark-safe! rename original))))
-             bound)
-    free))
-
-(define (make-final-substitution safe-set)
-  (let ((lookup-rename (rdb:lookup-rename (rename-db)))
-       (uninterned-table (make-strong-eq-hash-table)))
-
-    (define (finalize-renamed-identifier rename)
-      (guarantee identifier? rename 'finalize-renamed-identifier)
-      (let ((entry (lookup-rename rename)))
-       (if entry
-           (let ((original (car entry))
-                 (frame-id (force (cdr entry))))
-             (if (interned-symbol? original)
-                 (symbol "." original "." frame-id)
-                 (finalize-uninterned original frame-id)))
-           rename)))
-
-    (define (finalize-uninterned original frame-id)
+(define (make-local-identifier-renamer)
+  (let ((frame-id (list 'frame-id))
+       (mapping (rdb:mapping (rename-db)))
+       (unmapping (rdb:unmapping (rename-db))))
+    (lambda (original)
+      (guarantee identifier? original)
       (let ((bucket
-            (hash-table-intern! uninterned-table
+            (hash-table-intern! mapping
                                 original
                                 (lambda () (list 'bucket)))))
-       (let ((entry (assv frame-id (cdr bucket))))
+       (let ((entry (assq frame-id (cdr bucket))))
          (if entry
              (cdr entry)
-             (let ((finalized
-                    (symbol "." (identifier->symbol original)
-                            "." frame-id
-                            "-" (length (cdr bucket)))))
+             (let ((rename (generate-uninterned-symbol)))
                (set-cdr! bucket
-                         (cons (cons frame-id finalized)
+                         (cons (cons frame-id rename)
                                (cdr bucket)))
-               finalized)))))
+               (hash-table-set! unmapping rename original)
+               rename)))))))
 
-    (lambda (rename)
-      (or (hash-table-ref/default safe-set rename #f)
-         (finalize-renamed-identifier rename)))))
+(define (mark-local-bindings bound body mark-safe!)
+  (let ((free
+        (lset-difference eq?
+                         (compute-substitution body mark-safe!)
+                         bound)))
+    (let ((rename->original
+          (let ((unmapping (rdb:unmapping (rename-db))))
+            (lambda (rename)
+              (hash-table-ref/default unmapping rename rename)))))
+      (for-each (lambda (rename)
+                 (let ((original (rename->original rename)))
+                   (if (and (symbol? original)
+                            (not (any (lambda (rename*)
+                                        (eq? original
+                                             (rename->original rename*)))
+                                      free)))
+                       (mark-safe! rename original))))
+               bound))
+    free))
 \f
 ;;;; Compute substitution
 

diff --git a/tests/runtime/test-syntax-rename.scm b/tests/runtime/test-syntax-rename.scm
index 567ac956022bf99ab9c4c1fc771889be23522fc8..9b8e2e9da7b48090e64ec363e7058336ea630da0 100644 (file)
--- a/tests/runtime/test-syntax-rename.scm
+++ b/tests/runtime/test-syntax-rename.scm
@@ -63,10 +63,10 @@ USA.
              (outer car)
              (let ((car 15))
                (cons car (inner))))))
-      (assert-equal (unsyntax (syntax expr test-environment))
-                   '(let ((.car.1 13))
-                      (let ((.car.2 15))
-                        (cons .car.2 (list car .car.1))))))))
+      (assert-matches (unsyntax (syntax expr test-environment))
+                     '(let ((?x1 13))
+                        (let ((?x2 15))
+                          (cons ?x2 (list car ?x1))))))))
 
 (define-test 'keyword-environments
   (lambda ()

diff --git a/tests/runtime/test-syntax.scm b/tests/runtime/test-syntax.scm
index 3a9cc197eda8b1ffec978eb914f80326f002942d..8975d5a254567e9fb5d38dbcc59a17ad555a6a4e 100644 (file)
--- a/tests/runtime/test-syntax.scm
+++ b/tests/runtime/test-syntax.scm
@@ -115,7 +115,7 @@ USA.
 
 (define-test 'bug-57785
   (lambda ()
-    (assert-equal
+    (assert-matches
      (unsyntax
       (syntax '(lambda ()
 
@@ -135,9 +135,9 @@ USA.
                 (bat x))
               test-environment))
      '(lambda ()
-       (let ((.md.1-0 'quux))
-         (let ((.md.2-1 .md.1-0))
-           (list .md.1-0 'x)))))))
+       (let ((?x1 'quux))
+         (let ((?x2 ?x1))
+           (list ?x1 'x)))))))
 
 (define-test 'bug-57793
   (lambda ()
@@ -179,6 +179,36 @@ USA.
              test-environment))
      '(lambda ()
        (start)))))
+
+(define-test 'bug-63438
+  (lambda ()
+    (assert-matches
+     (unsyntax
+      (syntax '(let ()
+                (define-syntax foo
+                  (syntax-rules ()
+                    ((foo 0)
+                     (foo 1 x))
+                    ((foo 1 y)
+                     (lambda (x y)
+                       (list (list x y)
+                             (lambda (y) (list x y)))))))
+                (foo 0))
+             test-environment))
+     '(let ()
+       (lambda (?x1 ?x2)
+         (list (list ?x1 ?x2) (lambda (?x3) (list ?x1 ?x3))))))
+    (assert-matches
+     (unsyntax
+      (syntax '(let ((.x.1-0 123))
+                (define-syntax foo
+                   (syntax-rules ()
+                     ((foo y) (lambda (x) y))))
+                ((foo .x.1-0) 456))
+             test-environment))
+     '(let ((.x.1-0 123))
+       (let ((?x1 456))
+         .x.1-0)))))
 \f
 ;;;; Tests of syntax-rules, from Larceny: