src/expand.clj

@@ -48,8 +48,10 @@
 
 (s/def ::datum any?)
 
+(declare variable?)
+
 (s/def ::template
-  (s/or :var symbol?
+  (s/or :var variable?
         :lit ::literal
         :list (s/and (s/* ::template-element) sequential?)))
 
@@ -110,12 +112,9 @@
 (deftype Variable [symbol scopes]
   Object
   (equals [x y]
-    (tap> y)
     (if-some [[y-symbol y-scopes] (destructure-variable y)]
-      (do (tap> [symbol y-symbol])
-          (tap> [scopes y-scopes])
-          (and (.equals symbol y-symbol)
-               (.equals scopes y-scopes)))
+      (and (.equals symbol y-symbol)
+           (.equals scopes y-scopes))
       false))
   IVariable
   (variable-symbol [this] symbol)
@@ -373,12 +372,20 @@
 
 (defn transcribe [template env symtable scopes]
   (match template
-    [:var x] (match (lookup (offer-scopes x scopes) env symtable)
-               [:syntax syn] syn
-               :else (offer-scopes x scopes))
+    [:var x] (let [x* (offer-scopes x scopes)]
+               (match (lookup x* env symtable)
+                 [:syntax syn] syn
+                 :else x*))
     [:lit x] x
     [:list xs] (map #(transcribe % env symtable scopes) xs)))
 
+(defn resolve-template [template scopes]
+  (clojure.walk/postwalk
+   #(if (variable? %)
+      (offer-scopes % scopes)
+      %)
+   template))
+
 
 ;;; expand
 
@@ -420,6 +427,7 @@
                     (for [[x rhs] bindings]
                       (let [trans (->> (expand rhs env symtable-ref scopes)
                                        (s/conform ::prim-syntax-rules))]
+                        (assert (not (s/invalid? trans)))
                         (bind-lexical
                          [x scopes*]
                          [:macro trans]
@@ -430,9 +438,14 @@
 
 (defmethod expand-primitive 'syntax-rules
   [datum _ env symtable-ref scopes]
-  (let [r (s/conform ::prim-syntax-rules datum)]
-    (assert (not (s/invalid? r)))
-    datum))
+  (assert (s/valid? ::prim-syntax-rules datum))
+  (let [scopes* (conj scopes (new-scope))
+        keywords (nth datum 1)
+        rules (nthrest datum 2)]
+    (concat (list 'syntax-rules
+                  keywords)
+            (for [[pattern template] rules]
+              (list pattern (resolve-template template scopes*))))))
 
 (defmethod expand-primitive 'if
   [datum _ env symtable-ref scopes]
@@ -506,7 +519,8 @@
          (let [[sym scopes] (destructure-variable x)
                syms (swap!
                      c
-                     #(let [r (set/difference scopes (keys %))]
+                     #(let [r (set/difference scopes
+                                              (set (keys %)))]
                         (into %
                               (map-indexed
                                (fn [n a]

test/expand_test.clj

@@ -82,12 +82,16 @@
                (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/is (= '(let (([x #{s0}] 123))
+                (let-syntax ((m (syntax-rules () ((m) x))))
+                  (lambda ([x #{s1 s2 s0}])
+                          [x #{s0}])))
+             (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)))