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)

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)))