replace location-comparator with free-identifier-comparator

4 files changed, 56 insertions, 26 deletions

diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
index fc79867..c987dad 100644
--- a/multisyntax/examples/untyped-lambda-calculus.scm
+++ b/multisyntax/examples/untyped-lambda-calculus.scm
@@ -51,18 +51,18 @@
   transformer?
   (clauses unwrap-syntax-rules))
 
-(define (empty-map) (hashmap location-comparator))
+(define (empty-map) (hashmap free-identifier-comparator))
 
 (define initial-environment
-  (hashmap location-comparator
-           'lambda 'lambda
-           'define 'define
-           'define-syntax 'define-syntax
-           'splicing-let-syntax 'splicing-let-syntax
-           'splicing-letrec-syntax 'splicing-letrec-syntax
-           'let-syntax 'let-syntax
-           'letrec-syntax 'letrec-syntax
-           'syntax-rules 'syntax-rules))
+  (hashmap free-identifier-comparator
+           (empty-wrap 'lambda) 'lambda
+           (empty-wrap 'define) 'define
+           (empty-wrap 'define-syntax) 'define-syntax
+           (empty-wrap 'splicing-let-syntax) 'splicing-let-syntax
+           (empty-wrap 'splicing-letrec-syntax) 'splicing-letrec-syntax
+           (empty-wrap 'let-syntax) 'let-syntax
+           (empty-wrap 'letrec-syntax) 'letrec-syntax
+           (empty-wrap 'syntax-rules) 'syntax-rules))
 
 (define (church-numeral stx)
   ;; Convert the exact non-negative integer `stx` into a Church numeral.
@@ -103,9 +103,9 @@
 (define (union-names env new-names tfmrs)
   ;; Add `new-names` bound to `tfmrs` in `env`, overriding previous
   ;; bindings.
-  (hashmap-union (alist->hashmap location-comparator
+  (hashmap-union (alist->hashmap free-identifier-comparator
                                  (map (lambda (name tfmr)
-                                        (cons (resolve name) tfmr))
+                                        (cons name tfmr))
                                       new-names tfmrs))
                  env))
 
@@ -114,7 +114,7 @@
   (let ((stx (unwrap-syntax stx)))
     (and (pair? stx)
          (identifier? (car stx))
-         (let ((resolved (hashmap-ref/default env (resolve (car stx)) #f)))
+         (let ((resolved (hashmap-ref/default env (car stx) #f)))
            (eq? resolved id)))))
 
 (define (identifier-is-transformer env stx)
@@ -123,7 +123,7 @@
     (cond
       ((not (pair? stx)) #f)
       ((not (identifier? (car stx))) #f)
-      ((hashmap-ref/default env (resolve (car stx)) #f)
+      ((hashmap-ref/default env (car stx) #f)
        => (lambda (return)
             (and (transformer? return) return)))
       (else #f))))
@@ -202,7 +202,7 @@
          (list (empty-wrap 'lambda)
                renamed
                (expand-expr
-                (hashmap-set env (resolve renamed) 'variable)
+                (hashmap-set env renamed 'variable)
                 (add-substitution body bound renamed)))))
       ((is? env stx 'let-syntax)
        (let-syntax-expander env stx expand-expr))
@@ -246,7 +246,7 @@
   (let ((stx (unwrap-syntax stx)))
     (cond
       ((identifier? stx)
-       (hashmap-ref env (resolve stx) (lambda () (error "transformer not found" stx))))
+       (hashmap-ref env stx (lambda () (error "transformer not found" stx))))
       ((identifier-is-transformer env stx)
        => (lambda (tfmr)
             (macro-expand-expander (syntax->datum (syntax-car stx))
@@ -299,7 +299,7 @@
        (let* ((stx (unwrap-list stx))
               (name (syntax-cxr '(d a) stx))
               (tfmr (expand-transformer env (syntax-cxr '(d d a) stx))))
-         (values (hashmap-set globalenv (resolve name) tfmr) '())))
+         (values (hashmap-set globalenv name tfmr) '())))
       ((is? env stx 'splicing-let-syntax)
        (let*-values (((old-names new-names tfmrs body)
                       (on-bindings stx))
@@ -324,7 +324,7 @@
       ((is? env stx 'define)
        (let* ((name (syntax-cxr '(d a) stx))
               (expanded-value (expand-expr env (syntax-cxr '(d d a) stx))))
-         (values (hashmap-adjoin globalenv (resolve name) 'variable)
+         (values (hashmap-adjoin globalenv name 'variable)
                  (list (list (empty-wrap 'define)
                              name
                              expanded-value)))))
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index e4479b2..d34191d 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -312,6 +312,19 @@
   ;; and `id2` would refer to the same location.
   (=? location-comparator (resolve id1) (resolve id2)))
 
+(define free-identifier-comparator
+  (let ((free-identifier<?
+         (lambda (x y)
+           (<? location-comparator (resolve x) (resolve y))))
+        (free-identifier-hash
+         (lambda (x)
+           (+ (comparator-hash location-comparator (resolve x))))))
+    (make-comparator
+     identifier?
+     free-identifier=?
+     free-identifier<?
+     free-identifier-hash)))
+
 (define (bound-identifier=? id1 id2)
   ;; Returns true if binding one identifier would cause the other
   ;; identifier to be bound.
diff --git a/multisyntax/syntax-object.sld b/multisyntax/syntax-object.sld
index 89861f6..5ac29d6 100644
--- a/multisyntax/syntax-object.sld
+++ b/multisyntax/syntax-object.sld
@@ -23,6 +23,7 @@
   (export generate-lexical-location generate-lexical-locations
           lexical-location->string lexical-location-comparator
           bound-identifier-comparator location-comparator
+          free-identifier-comparator
           ;; Misc. predicates
           self-syntax? syntax?
           ;; Operations on wraps
diff --git a/test/examples/untyped-lambda-calculus.scm b/test/examples/untyped-lambda-calculus.scm
index 46f3f60..a2f308e 100644
--- a/test/examples/untyped-lambda-calculus.scm
+++ b/test/examples/untyped-lambda-calculus.scm
@@ -21,10 +21,10 @@
                    (expand initial-environment
                            (list (empty-wrap (quote inputs)) ...))))
        (test-equal name
+                   (quote output)
                    (map (lambda (term)
                           (debruijnize global-map term '()))
-                        expanded-list)
-                   (quote output))))))
+                        expanded-list))))))
 
 (define (test-expander)
   (test-alpha "identity"
@@ -32,19 +32,25 @@
               ((lambda 0)))
   (test-alpha "let-syntax of identifier"
               ((let-syntax ((λ lambda))
-                 (λ x x)))
+                 (λ x x))
+               (λ x x))
+              ((lambda 0)
+               (λ x x)))
+  (test-alpha "define-syntax of identifier"
+              ((define-syntax λ lambda)
+               (λ x x))
               ((lambda 0)))
   (test-alpha "lexical renaming of keywords"
               ((lambda lambda (lambda lambda)))
               ((lambda (0 0))))
-  (test-alpha "simple define-syntax"
+  (test-alpha "simple syntax-rules"
               ((define-syntax let
                  (syntax-rules ()
                    ((let ((name value)) body)
                     ((lambda name body) value))))
                (let ((x (f y))) (f x)))
               (((lambda (f 0)) (f y))))
-  (test-alpha "define-syntax with ellipsis"
+  (test-alpha "syntax-rules with ellipsis"
               ((define-syntax let
                  (syntax-rules ()
                    ((let ((name value)) body)
@@ -61,9 +67,19 @@
                             ((lambda (if 0
                                          0
                                          ((lambda (if 0
-                                                     0
-                                                     false))
-                                          b))) tmp))) a))))
+                                                      0
+                                                      false))
+                                          b))) tmp))) a)))
+  (test-alpha "splicing-let-syntax"
+              ((splicing-let-syntax ((λ lambda))
+                 (define-syntax lambda
+                   (syntax-rules ()
+                     ((_ (name) body) (λ name body))
+                     ((_ (name rest ...) body)
+                      (λ name (lambda (rest ...) body)))
+                     ((_ name body) (λ name body)))))
+               (lambda (x y) (x y)))
+              ((lambda (lambda (1 0))))))
 
 (define (test-untyped-lambda-calculus)
   (test-group "untyped lambda calculus"