src/expand.clj

@@ -1,11 +1,11 @@
 (ns expand
-  (:require [clojure.spec.alpha :as s]
-            [clojure.core.match :refer [match]]
-            [spec-dict.main :refer [dict]]
-            [clojure.set :as set]
-            [clojure.pprint :as pprint]
-            [clojure.string :as str]
-            [clojure.walk]))
+  (:require
+   [clojure.core.match :refer [match]]
+   [clojure.pprint :as pprint]
+   [clojure.set :as set]
+   [clojure.spec.alpha :as s]
+   [clojure.walk]
+   [spec-dict.main :refer [dict]]))
 
 (defmacro todo
   ([] `(throw (ex-info "todo" {})))
@@ -392,7 +392,9 @@
                     (for [x formals]
                       (bind-lexical [x scopes*]
                                     [:var] symtable-ref)))]
-    (concat (list 'lambda formals)
+    (concat (list 'lambda
+                  (for [x formals]
+                    (offer-scopes x scopes*)))
             (for [e body]
               (expand e env* symtable-ref scopes*)))))
 
@@ -416,10 +418,12 @@
         scopes* (conj scopes (new-scope))
         env* (apply merge env
                     (for [[x rhs] bindings]
-                      (bind-lexical
-                       [x scopes*]
-                       [:macro (expand rhs env symtable-ref scopes)]
-                       symtable-ref)))]
+                      (let [trans (->> (expand rhs env symtable-ref scopes)
+                                       (s/conform ::prim-syntax-rules))]
+                        (bind-lexical
+                         [x scopes*]
+                         [:macro trans]
+                         symtable-ref))))]
     (concat (list 'let-syntax bindings)
             (for [e body]
               (expand e env* symtable-ref scopes*)))))
@@ -428,7 +432,7 @@
   [datum _ env symtable-ref scopes]
   (let [r (s/conform ::prim-syntax-rules datum)]
     (assert (not (s/invalid? r)))
-    r))
+    datum))
 
 (defmethod expand-primitive 'if
   [datum _ env symtable-ref scopes]
@@ -522,3 +526,9 @@
        (variable-symbol x)
        x))
    datum))
+
+(defn us-expand [datum]
+  (unscope (expand datum)))
+
+(defn rg-expand [datum]
+  (regensym (expand datum)))

test/expand_test.clj

@@ -1,8 +1,9 @@
 (ns expand-test
-  (:require [expand :as sut]
-            [clojure.test :as t]
-            [clojure.spec.alpha :as s]
-            [clojure.core.match :refer [match]]))
+  (:require
+   [clojure.core.match :refer [match]]
+   [clojure.spec.alpha :as s]
+   [clojure.test :as t]
+   [expand :as sut]))
 
 (t/deftest scheme-base-env-test
   (t/is (s/valid? ::sut/environment sut/scheme-base-env)))
@@ -43,46 +44,50 @@
   (t/testing "simple data"
     (t/is (= 'a (s/conform ::patern 'a)))))
 
-(defn- us-expand [datum]
-  (sut/unscope (sut/expand datum)))
-
-(defn- rg-expand [datum]
-  (sut/regensym (sut/expand datum)))
-
 (t/deftest expand-test
   (t/testing "unbound symbol"
     (t/is (thrown? Exception (sut/expand 'x))))
   (t/testing "lambda"
     (t/is (= '(lambda (x) x)
-             (us-expand '(λ (x) x)))))
-  #_(t/testing "syntax-rules"
-      (t/is (= '(lambda (x) x)
-               (sut/expand
-                '(syntax-rules
-                  ()
-                  ((_)))))))
+             (sut/us-expand '(λ (x) x)))))
+  (t/testing "let-syntax"
+    (t/is (= '(let-syntax ((m (syntax-rules
+                               ()
+                               ((m) 123))))
+                456)
+             (sut/expand
+              '(let-syntax ((m (syntax-rules
+                                ()
+                                ((m) 123))))
+                 456)))))
   (t/testing "let"
     (t/is (= '(let ((x 123)
                     (y 456))
                 (+ x y))
-             (us-expand
+             (sut/us-expand
               '(let ((x 123)
                      (y 456))
                  (+ x y))))))
   (t/testing "application"
     (t/is (= '(lambda (f x) (f x))
-             (us-expand '(lambda (f x) (f x))))))
+             (sut/us-expand '(lambda (f x) (f x))))))
   (t/testing "macros"
     (t/testing "when"
       (t/is (= '(let ((x 123)) (if x 456))
-               (us-expand '(let ((x 123))
-                             (when x 456)))))
+               (sut/us-expand '(let ((x 123))
+                                 (when x 456)))))
       (t/is (= '(let (([body #{s0}] 123))
                   (if [body #{s0}]
                     456))
-               (rg-expand '(let ((body 123))
-                             (when body 456))))
-            "`when` is hygienic"))))
+               (sut/rg-expand '(let ((body 123))
+                                 (when body 456))))
+            "`when` is hygienic"))
+    (t/is (sut/rg-expand '(let ((x 123))
+                            (let-syntax ((m (syntax-rules
+                                             ()
+                                             ((m) x))))
+                              (λ (x)
+                                 (m))))))))
 
 (t/deftest prim-lambda-spec
   (t/is (s/valid? ::sut/prim-lambda '(lambda (x) x)))