fix self-syntax and shadowing of syntax keywords

4 files changed, 35 insertions, 8 deletions

diff --git a/multisyntax/examples/untyped-lambda-calculus.scm b/multisyntax/examples/untyped-lambda-calculus.scm
index feea5f5..a073881 100644
--- a/multisyntax/examples/untyped-lambda-calculus.scm
+++ b/multisyntax/examples/untyped-lambda-calculus.scm
@@ -109,9 +109,10 @@
 
 (define (is? env stx id)
   ;; Return true if `stx` in `env` is `eq?` to `id`.
-  (and (identifier? (syntax-car stx))
-       (let ((resolved (hashmap-ref/default env (syntax-car stx) #f)))
-         (eq? resolved id))))
+  (let ((stx (unwrap-syntax stx)))
+    (and (pair? stx) (identifier? (car stx))
+         (let ((resolved (hashmap-ref/default env (car stx) #f)))
+           (eq? resolved id)))))
 
 (define (identifier-is-transformer env stx)
   ;; Returns transformer if `stx` is a syntax-rules transformer in `env`.
@@ -177,19 +178,29 @@
   ;; 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))
+      ((self-syntax? stx) stx)
       ((identifier? stx) stx)
       ((is? env stx 'lambda)
        (let* ((bound (syntax-cxr '(d a) stx))
-              (renamed (generate-identifier (syntax->datum bound)))
+              (renamed (add-substitution
+                        bound
+                        bound
+                        (generate-lexical-location (syntax->datum bound))))
               (body (syntax-cxr '(d d a) stx)))
          (list (empty-wrap 'lambda)
                renamed
                (expand-expr
-                (hashmap-adjoin env renamed 'variable)
-                (add-substitution body renamed bound)))))
+                (hashmap-set env renamed 'variable)
+                (add-substitution body bound renamed)))))
       ((is? env stx 'let-syntax)
        (let-syntax-expander env stx expand-expr))
       ((is? env stx 'letrec-syntax)
@@ -324,3 +335,13 @@
           (fold globalenv (cdr stxlist) (append-reverse next acc)))))
   (fold initenv (unwrap-list stx) '()))
 
+(define (alpha stx)
+  (let ((stx (unwrap-syntax stx)))
+    (cond
+      ((pair? stx) (cons (alpha (car stx)) (alpha (cdr stx))))
+      ((identifier? stx)
+       (let ((loc (resolve stx)))
+         (if (symbol? loc)
+             loc
+             (lexical-location->string loc))))
+      (else stx))))
diff --git a/multisyntax/examples/untyped-lambda-calculus.sld b/multisyntax/examples/untyped-lambda-calculus.sld
index 2ace753..1076111 100644
--- a/multisyntax/examples/untyped-lambda-calculus.sld
+++ b/multisyntax/examples/untyped-lambda-calculus.sld
@@ -19,5 +19,5 @@
           (multisyntax syntax-object)
           (multisyntax pattern matcher)
           (multisyntax pattern producer))
-  (export expand transformer? initial-environment)
+  (export expand transformer? initial-environment alpha)
   (include "untyped-lambda-calculus.scm"))
\ No newline at end of file
diff --git a/multisyntax/syntax-object.scm b/multisyntax/syntax-object.scm
index 2bd2060..54aaf89 100644
--- a/multisyntax/syntax-object.scm
+++ b/multisyntax/syntax-object.scm
@@ -358,6 +358,7 @@
           ((pair? expr) (cons (push-wrap stx (car expr))
                               (push-wrap stx (cdr expr))))
           ((vector? expr) (vector-map (cut push-wrap stx <>) expr))
+          ((self-syntax? expr) expr)
           (else stx)))
       stx))
 
diff --git a/test/run.scm b/test/run.scm
index 23d3af2..bb2fca0 100644
--- a/test/run.scm
+++ b/test/run.scm
@@ -34,11 +34,16 @@
 #;(let-values (((global-map expanded-list)
               (expand initial-environment (list (empty-wrap '(lambda x x)))))))
 
-(define-values (global-map expanded-list)
+#;(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 '(lambda lambda (lambda lambda)))))))
+  (alpha expanded-list))
+
 #;(begin
   (load "examples/untyped-lambda-calculus.sld")
   (import (multisyntax examples untyped-lambda-calculus test))