Change environments in untyped LC to use location comparators instead of

bound identifier comparators

NOTE: location comparators are a non-standard thing equivalent to a free
identifier comparator. Should replace later.

The previous code would fail when attempting to process identifiers that
came from the output of a macro transformer, because those are marked.

5 files changed, 83 insertions, 60 deletions

diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
index a073881..899fe48 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 bound-identifier-comparator))
+(define (empty-map) (hashmap location-comparator))
 
 (define initial-environment
-  (hashmap bound-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))
+  (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))
 
 (define (church-numeral stx)
   ;; Convert the exact non-negative integer `stx` into a Church numeral.
@@ -103,22 +103,24 @@
 (define (union-names env new-names tfmrs)
   ;; Add `new-names` bound to `tfmrs` in `env`, overriding previous
   ;; bindings.
-  (hashmap-union (alist->hashmap bound-identifier-comparator
-                                 (map cons new-names tfmrs))
+  (hashmap-union (alist->hashmap location-comparator
+                                 (map (lambda (name tfmr)
+                                        (cons (resolve name) tfmr))
+                                      new-names tfmrs))
                  env))
 
 (define (is? env stx id)
   ;; Return true if `stx` in `env` is `eq?` to `id`.
   (let ((stx (unwrap-syntax stx)))
     (and (pair? stx) (identifier? (car stx))
-         (let ((resolved (hashmap-ref/default env (car stx) #f)))
+         (let ((resolved (hashmap-ref/default env (resolve (car stx)) #f)))
            (eq? resolved id)))))
 
 (define (identifier-is-transformer env stx)
   ;; Returns transformer if `stx` is a syntax-rules transformer in `env`.
   (cond
     ((not (identifier? (syntax-car stx))) #f)
-    ((hashmap-ref/default env (syntax-car stx) #f)
+    ((hashmap-ref/default env (resolve (syntax-car stx)) #f)
      => (lambda (return)
           (and (transformer? return) return)))
     (else #f)))
@@ -161,7 +163,7 @@
         (let ((matcher (caar tfmr))
               (producer (cdar tfmr)))
           (cond
-            ((matcher tfmr) => producer)
+            ((matcher stx) => producer)
             (else (loop (cdr tfmr))))))))
 
 (define (macro-expand-expander env stx tfmr K)
@@ -178,12 +180,6 @@
   ;; TODO: fix function application
   ;; Expander of expressions (not toplevel statements).
   (let ((stx (unwrap-syntax stx)))
-    #;(begin
-        (display (list stx (syntax->datum stx) (self-syntax? stx))) (newline)
-        (display (map (lambda (pair)
-                      (cons (syntax->datum (car pair)) (cdr pair)))
-                    (hashmap->alist env)))
-        (newline))
     (cond
       ((and (exact-integer? stx) (positive? stx))
        (church-numeral stx))
@@ -199,7 +195,7 @@
          (list (empty-wrap 'lambda)
                renamed
                (expand-expr
-                (hashmap-set env renamed 'variable)
+                (hashmap-set env (resolve renamed) 'variable)
                 (add-substitution body bound renamed)))))
       ((is? env stx 'let-syntax)
        (let-syntax-expander env stx expand-expr))
@@ -221,10 +217,16 @@
   ;; object.
   (define (operate clause)
     (let*-values (((clause) (unwrap-list clause))
+                  ((literals) (unwrap-list literals))
                   ((matcher bindings _)
                    (compile-pattern literals
                                     (list-ref clause 0)
-                                    ellipsis)))
+                                    ellipsis))
+                  ((bindings)
+                   (hashmap-map (lambda (key value)
+                                  (values key (car value)))
+                                bound-identifier-comparator
+                                bindings)))
       (cons matcher (compile-producer literals
                                       (list-ref clause 1)
                                       bindings
@@ -235,7 +237,7 @@
   (let ((stx (unwrap-syntax stx)))
     (cond
       ((identifier? stx)
-       (hashmap-ref env stx (lambda () (error "transformer not found" stx))))
+       (hashmap-ref env (resolve stx) (lambda () (error "transformer not found" stx))))
       ((identifier-is-transformer env stx)
        => (lambda (tfmr)
             (macro-expand-expander env
@@ -244,15 +246,16 @@
                                    (lambda (stx)
                                      (expand-transformer env stx)))))
       ((is? env stx 'syntax-rules)
-       (if (identifier? (syntax-cxr '(d a) stx))
-           (expand-syntax-rules env
-                                (syntax-cxr '(d a) stx)
-                                (syntax-cxr '(d d a) stx)
-                                (syntax-cxr '(d d d) stx))
-           (expand-syntax-rules env
-                                #f
-                                (syntax-cxr '(d a) stx)
-                                (syntax-cxr '(d d) stx))))
+       (let ((stx (unwrap-list stx)))
+         (if (identifier? (syntax-cxr '(d a) stx))
+             (expand-syntax-rules env
+                                  (syntax-cxr '(d a) stx)
+                                  (syntax-cxr '(d d a) stx)
+                                  (syntax-cxr '(d d d) stx))
+             (expand-syntax-rules env
+                                  #f
+                                  (syntax-cxr '(d a) stx)
+                                  (syntax-cxr '(d d) stx)))))
       ((is? env stx 'let-syntax)
        (let-syntax-expander env stx expand-transformer))
       ((is? env stx 'letrec-syntax)
@@ -281,9 +284,10 @@
         (env (hashmap-union lexenv globalenv)))
     (cond
       ((is? env stx 'define-syntax)
-       (let* ((name (syntax-cxr '(d a) stx))
+       (let* ((stx (unwrap-list stx))
+              (name (syntax-cxr '(d a) stx))
               (tfmr (expand-transformer env (syntax-cxr '(d d a) stx))))
-         (values (hashmap-adjoin globalenv name tfmr) '())))
+         (values (hashmap-set globalenv (resolve name) tfmr) '())))
       ((is? env stx 'splicing-let-syntax)
        (let*-values (((old-names new-names tfmrs body)
                       (on-bindings stx))
@@ -308,7 +312,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 name 'variable)
+         (values (hashmap-adjoin globalenv (resolve name) 'variable)
                  (list (list (empty-wrap 'define)
                              name
                              expanded-value)))))
@@ -319,9 +323,10 @@
                                    tfmr
                                    (lambda (stx)
                                      (expand-toplevel globalenv lexenv stx)))))
-      (else (values globalenv
-                    (list
-                     (expand-expr (hashmap-union lexenv globalenv) stx)))))))
+      (else
+       (values globalenv
+               (list
+                (expand-expr (hashmap-union lexenv globalenv) stx)))))))
 
 (define (expand initenv stx)
   ;; Expand `stx`, which is a list of syntax forms, into a list of syntax
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index 54aaf89..f634b81 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -77,7 +77,7 @@
                  "."
                  (number->string (lexical-location->unique-id ll))))
 
-(define environment-key-comparator
+(define location-comparator
   ;; Comparator for keys to the environment that stores substitutions.
   ;; 
   ;; Keys are either regular Scheme symbols or unique lexical locations.
@@ -146,7 +146,7 @@
 (define empty-wrap
   ;; Wrap `expr` with an empty timestamp set and environment.
   (let ((empty-timestamp-set (set timestamp-comparator))
-        (empty-mapping (mapping environment-key-comparator)))
+        (empty-mapping (mapping location-comparator)))
     (lambda (expr)
       (raw-wrap expr
                 empty-timestamp-set
@@ -291,8 +291,8 @@
        (error "generate-symbol requires symbol" symbol))
      (raw-wrap symbol
                (set timestamp-comparator (generate-unique-integer))
-               (mapping environment-key-comparator)
-               (mapping environment-key-comparator)))))
+               (mapping location-comparator)
+               (mapping location-comparator)))))
 
 (define (generate-temporaries lst)
   ;; Generate a list of identifiers from `generate-identifier`.
@@ -310,7 +310,7 @@
 (define (free-identifier=? id1 id2)
   ;; Returns true if, when inserted into output as free identifiers, `id1`
   ;; and `id2` would refer to the same location.
-  (=? environment-key-comparator (resolve id1) (resolve id2)))
+  (=? location-comparator (resolve id1) (resolve id2)))
 
 (define (bound-identifier=? id1 id2)
   ;; Returns true if binding one identifier would cause the other
@@ -321,7 +321,7 @@
 (define bound-identifier-comparator
   (let ((bound-identifier<?
          (lambda (id1 id2)
-           (comparator-if<=> environment-key-comparator
+           (comparator-if<=> location-comparator
                              (resolve id1)
                              (resolve id2)
              #t
@@ -333,7 +333,7 @@
          (lambda (id)
            (+ (comparator-hash set-comparator
                                (wrap->timestamps id))
-              (comparator-hash environment-key-comparator
+              (comparator-hash location-comparator
                                (resolve id))))))
     (make-comparator
      identifier?
diff --git a/multisyntax/syntax-object.sld b/multisyntax/syntax-object.sld
index 31060b4..89861f6 100644
--- a/multisyntax/syntax-object.sld
+++ b/multisyntax/syntax-object.sld
@@ -22,7 +22,7 @@
           (multisyntax utils))
   (export generate-lexical-location generate-lexical-locations
           lexical-location->string lexical-location-comparator
-          environment-key-comparator bound-identifier-comparator
+          bound-identifier-comparator location-comparator
           ;; Misc. predicates
           self-syntax? syntax?
           ;; Operations on wraps
diff --git a/test/run.scm b/test/run.scm
index bb2fca0..201c849 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -31,18 +31,36 @@
 (import (multisyntax examples untyped-lambda-calculus)
         (multisyntax syntax-object))
 
-#;(let-values (((global-map expanded-list)
-              (expand initial-environment (list (empty-wrap '(lambda x x)))))))
+(let-values (((global-map expanded-list)
+              (expand initial-environment (list (empty-wrap '(lambda x x))))))
+  (display (alpha expanded-list)) (newline))
 
-#;(define-values (global-map expanded-list)
-  (expand initial-environment
-          (list (empty-wrap '(let-syntax ((λ lambda))
-                               (λ x x))))))
+(let-values (((global-map expanded-list)
+              (expand initial-environment
+                      (list (empty-wrap '(let-syntax ((λ lambda))
+                                           (λ x x)))))))
+  (display (alpha expanded-list)) (newline))
 
 (let-values (((global-map expanded-list)
               (expand initial-environment
                       (list (empty-wrap '(lambda lambda (lambda lambda)))))))
-  (alpha expanded-list))
+  (display (alpha expanded-list)) (newline))
+
+(let-values (((global-map expanded-list)
+              (expand initial-environment
+                      (list (empty-wrap '(define I (lambda x x)))
+                            (empty-wrap '(I (lambda I I)))))))
+  (display (alpha expanded-list)) (newline))
+
+(let-values (((global-map expanded-list)
+              (expand initial-environment
+                      (list (empty-wrap
+                             '(define-syntax let
+                                (syntax-rules ()
+                                  ((let (name value) body)
+                                   ((lambda name body) value)))))
+                            (empty-wrap '(let (x (lambda x x)) (x x)))))))
+  (display (alpha expanded-list)) (newline))
 
 #;(begin
   (load "examples/untyped-lambda-calculus.sld")
diff --git a/test/syntax-object.scm b/test/syntax-object.scm
index 674a675..31d6b22 100644
--- a/test/syntax-object.scm
+++ b/test/syntax-object.scm
@@ -17,9 +17,9 @@
   (list '() 1 #\a #f "a" #u8(1 2 3 4)))
 
 (define (test-locations)
-  (test-assert (comparator-test-type environment-key-comparator
+  (test-assert (comparator-test-type location-comparator
                                        (generate-lexical-location 'test)))
-  (test-assert (comparator-test-type environment-key-comparator
+  (test-assert (comparator-test-type location-comparator
                                        'test)))
 
 (define (test-self-syntax)
@@ -98,7 +98,7 @@
                                                  (generate-timestamp))
                                   (empty-wrap 'test)
                                   newloc)))
-      (test-assert (=? environment-key-comparator
+      (test-assert (=? location-comparator
                        'test
                        (resolve stx)))))
   (test-group "mismatched resolved name"
@@ -106,7 +106,7 @@
            (stx (add-substitution (empty-wrap 'test)
                                   (empty-wrap 'test2)
                                   newloc)))
-      (test-assert (=? environment-key-comparator
+      (test-assert (=? location-comparator
                        'test
                        (resolve stx)))))
   (test-group "multiple names in environment"
@@ -118,7 +118,7 @@
            (stx (add-substitution stx
                                   (empty-wrap 'test2)
                                   loc2)))
-      (test-assert (=? environment-key-comparator
+      (test-assert (=? location-comparator
                        (resolve stx)
                        loc1))))
   (test-group "intermediate substitutions"
@@ -128,7 +128,7 @@
                                   (empty-wrap 'test)
                                   loc1))
            (stx (add-substitution stx stx loc2)))
-      (test-assert (=? environment-key-comparator
+      (test-assert (=? location-comparator
                        (resolve stx)
                        loc2)))))