diff --git a/src/expand.clj b/src/expand.clj index e2d7202..a90eb9a 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -102,6 +102,25 @@ :formals ::lambda-formals :body ::body))) +(s/def ::prim-let + (s/and ::unsyntax + (s/cat :keyword ::identifier + :bindings + (s/and ::unsyntax + (s/coll-of + (s/and ::unsyntax + (s/cat :rhs ::identifier + :lhs ::datum)) + :kind sequential?)) + :body ::body))) + +(s/def ::prim-if + (s/and ::unsyntax + (s/cat :keyword ::identifier + :condition ::datum + :consequent ::datum + :alternative ::datum))) + #_ @@ -188,6 +207,31 @@ (expand (scm/rescope x scopeholder) env* store-atom))))))) +(defmethod expand-primitive 'let + [stx _ env store-atom] + (let [{:keys [bindings body]} (s/conform ::prim-let stx)] + (assert (list? bindings)) + (binding-form + stx env store-atom + (doall (for [{:keys [rhs]} bindings] + [(scm/syntax-e rhs) [:var]])) + (fn [scopeholder env*] + (concat (list 'let + (for [{:keys [rhs lhs]} bindings] + (list (scm/rescope rhs scopeholder) lhs))) + (for [x body] + (expand (scm/rescope x scopeholder) + env* store-atom))))))) + +(defmethod expand-primitive 'if + [stx _ env store-atom] + (let [{:keys [condition consequent alternative]} + (s/conform ::prim-if stx)] + (assert ((every-pred scm/datum?) condition consequent alternative)) + (cons 'if + (for [x [condition consequent alternative]] + (expand x env store-atom))))) + (defn expand ([stx] (let [scopeholder (scm/new-scopeholder) diff --git a/test/expand_test.clj b/test/expand_test.clj index d743027..f548a81 100644 --- a/test/expand_test.clj +++ b/test/expand_test.clj @@ -45,10 +45,26 @@ scm/syntax->datum)) (t/deftest expand-test - (t/is (= '(lambda (x) x) - (expand #scm/stx (#scm/stx lambda - #scm/stx (#scm/stx x) - #scm/stx x))))) + (t/is (thrown? Exception (expand #scm/stx x))) + (t/testing "primitive forms" + (t/testing "lambda" + (t/is (= '(lambda (x) x) + (expand #scm/stx (#scm/stx lambda + #scm/stx (#scm/stx x) + #scm/stx x))))) + (t/testing "let" + (t/is (= '(let ((x 123)) + x) + (expand #scm/stx (#scm/stx let + #scm/stx (#scm/stx (#scm/stx x + #scm/stx 123)) + #scm/stx x))))) + (t/testing "if" + (t/is (= '(if 123 true false) + (expand #scm/stx (#scm/stx if + #scm/stx 123 + #scm/stx true + #scm/stx false))))))) ;;; specs