diff --git a/src/expand.clj b/src/expand.clj index 4ebafb0..c8ee81d 100644 --- a/src/expand.clj +++ b/src/expand.clj @@ -14,8 +14,11 @@ {})))) (def primitives - #{'let 'let-syntax 'letrec 'lambda 'syntax-rules 'if 'define - 'define-syntax 'begin}) + '#{let let-syntax letrec lambda syntax-rules if define + define-syntax begin}) + +(def builtins + '#{car cdr write display newline cons list}) (s/def ::binding #(match % @@ -209,6 +212,10 @@ :consequent ::datum :alternative (s/? ::datum)))) +(s/def ::prim-begin + (s/and seq? (s/cat :keyword ::variable + :body (s/+ ::datum)))) + (defn symtable-for-env [env] @@ -233,10 +240,12 @@ [:global 'when] [:macro (meta-syntax-rules () ((_ test body) - (if test body)))]} + (if test body)) + ((_ test body ...) + (if test (begin body))))]} (into {} (for [p primitives] [[:global p] [:primitive p]])) - (into {} (for [b '(+ - * / car cdr cons)] + (into {} (for [b builtins] [[:global b] [:var]])))) (defn nearest [[sym scopes] ss] @@ -456,6 +465,11 @@ (ex consequent)) (some-> alternative ex)))) +(defmethod expand-primitive 'begin + [datum _ env symtable-ref scopes] + (let [{:keys [body]} (s/conform ::prim-begin datum)] + (cons 'begin (map #(expand % env symtable-ref scopes) body)))) + (comment (let [env scheme-base-env [_ trans] (get scheme-base-env [:global 'and]) @@ -496,8 +510,8 @@ ;; lists ([f & xs] :seq) - (or (when-some [v (and (variable? f) - (offer-scopes f scopes))] + (or (when-let [v (and (variable? f) + (offer-scopes f scopes))] (match (lookup v env @symtable-ref) [:primitive prim] (expand-primitive datum prim env symtable-ref scopes) diff --git a/test/expand_test.clj b/test/expand_test.clj index 9937f17..c9e103c 100644 --- a/test/expand_test.clj +++ b/test/expand_test.clj @@ -92,7 +92,13 @@ ((m) x)))) (λ (x) (m)))))) - "`when` does not capture caller's scope")))) + "`when` does not capture caller's scope") + (t/is (= '(if 123 (begin (display "hello") + (newline))) + (sut/us-expand '(when 123 + (display "hello") + (newline)))) + "`when` captures multiple")))) (t/deftest prim-lambda-spec (t/is (s/valid? ::sut/prim-lambda '(lambda (x) x)))