[#421] Support top-level do emitted from macro

src/sci/impl/analyzer.cljc

@@ -632,7 +632,7 @@
 
 ;;;; End vars
 
-(defn analyze-call [ctx expr]
+(defn analyze-call [ctx expr top-level?]
   (let [f (first expr)]
     (if (symbol? f)
       (let [;; in call position Clojure prioritizes special symbols over
@@ -689,8 +689,6 @@
                 var (analyze-var ctx expr)
                 set! (analyze-set! ctx expr)
                 import (mark-eval-call expr) ;; don't analyze children
-                ;; macroexpand-1 (macroexpand-1 ctx expr)
-                ;; macroexpand (macroexpand ctx expr)
                 ;; else:
                 (mark-eval-call (cons f (analyze-children ctx (rest expr)))))
               :else
@@ -705,9 +703,12 @@
                                    (rest expr))
                             (apply f expr
                                    (:bindings ctx) (rest expr)))
-                        expanded (if (:sci.impl/macroexpanding ctx)
-                                   v
-                                   (analyze ctx v))]
+                        expanded (cond (:sci.impl/macroexpanding ctx) v
+                                       (and top-level? (seq? v) (= 'do (first v)))
+                                       ;; hand back control to eval-form for
+                                       ;; interleaved analysis and eval
+                                       (types/->EvalForm v)
+                                       :else (analyze ctx v))]
                     expanded)
                   (mark-eval-call (cons f (analyze-children ctx (rest expr)))))
                 (catch #?(:clj Exception :cljs js/Error) e
@@ -720,33 +721,34 @@
         ret))))
 
 (defn analyze
-  [ctx expr]
-  ;; (prn "ana" expr)
-  (let [ret (cond (constant? expr) expr ;; constants do not carry metadata
-                  (symbol? expr) (let [v (resolve-symbol ctx expr false)]
-                                   (cond (constant? v) v
-                                         ;; (fn? v) (utils/vary-meta* v dissoc :sci.impl/op)
-                                         (vars/var? v) (if (:const (meta v))
-                                                         @v (types/->EvalVar v))
-                                         :else (merge-meta v (meta expr))))
-                  :else
-                  (merge-meta
-                   (cond
-                     (record? expr) expr ;; don't evaluate records
-                     (map? expr)
-                     (-> (zipmap (analyze-children ctx (keys expr))
-                                 (analyze-children ctx (vals expr)))
-                         mark-eval)
-                     (or (vector? expr) (set? expr))
-                     (-> (into (empty expr) (analyze-children ctx expr))
-                         mark-eval)
-                     (and (seq? expr) (seq expr))
-                     (analyze-call ctx expr)
-                     :else expr)
-                   (select-keys (meta expr)
-                                [:line :column :tag])))]
-    ;; (prn "ana" expr '-> ret 'm-> (meta ret))
-    ret))
+  ([ctx expr]
+   (analyze ctx expr false))
+  ([ctx expr top-level?]
+   ;; (prn "ana" expr)
+   (let [ret (cond (constant? expr) expr ;; constants do not carry metadata
+                   (symbol? expr) (let [v (resolve-symbol ctx expr false)]
+                                    (cond (constant? v) v
+                                          (vars/var? v) (if (:const (meta v))
+                                                          @v (types/->EvalVar v))
+                                          :else (merge-meta v (meta expr))))
+                   :else
+                   (merge-meta
+                    (cond
+                      (record? expr) expr ;; don't evaluate records
+                      (map? expr)
+                      (-> (zipmap (analyze-children ctx (keys expr))
+                                  (analyze-children ctx (vals expr)))
+                          mark-eval)
+                      (or (vector? expr) (set? expr))
+                      (-> (into (empty expr) (analyze-children ctx expr))
+                          mark-eval)
+                      (and (seq? expr) (seq expr))
+                      (analyze-call ctx expr top-level?)
+                      :else expr)
+                    (select-keys (meta expr)
+                                 [:line :column :tag])))]
+     ;; (prn "ana" expr '-> ret 'm-> (meta ret))
+     ret)))
 
 ;;;; Scratch
 

src/sci/impl/interpreter.cljc

@@ -651,12 +651,8 @@
 
 (vreset! utils/interpret interpret)
 
-(defn do? [expr]
-  (and (list? expr)
-       (= 'do (first expr))))
-
 (defn eval-form [ctx form]
-  (if (list? form)
+  (if (seq? form)
     (if (= 'do (first form))
       (loop [exprs (rest form)
              ret nil]
@@ -668,8 +664,10 @@
       (when (or (not (:uberscript ctx))
                 (= 'ns (first form))
                 (= 'require (first form)))
-        (let [analyzed (ana/analyze ctx form)
-              ret (interpret ctx analyzed)]
+        (let [analyzed (ana/analyze ctx form true)
+              ret (if (instance? sci.impl.types.EvalForm analyzed)
+                    (eval-form ctx (t/getVal analyzed))
+                    (interpret ctx analyzed))]
           ret)))
     (let [analyzed (ana/analyze ctx form)
           ret (interpret ctx analyzed)]

src/sci/impl/types.cljc

@@ -23,3 +23,8 @@
         :sci.impl.protocols/reified)
       (some-> x meta :sci.impl/type)
       (type x)))
+
+;; returned from analyzer when macroexpansion needs interleaved eval
+(deftype EvalForm [form]
+  IBox
+  (getVal [this] form))

test/sci/core_test.cljc

@@ -445,7 +445,12 @@
   (lets))))
 
 (foo 10)"))))
-  (is (= '(foo 1 2 3) (eval* "(defmacro foo [x y z] (list 'quote &form)) (foo 1 2 3)"))))
+  (is (= '(foo 1 2 3) (eval* "(defmacro foo [x y z] (list 'quote &form)) (foo 1 2 3)")))
+  (testing "top level macro that emits do form should be analyzed an eval'ed interleaved"
+    (is 'foo (eval* "(defmacro dude []
+                     `(do (ns ~'foo) (def ~'x (ns-name *ns*)) (ns ~'user)))
+                   (dude)
+                   foo/x"))))
 
 (deftest comment-test
   (is (nil? (eval* '(comment "anything"))))

test/sci/namespaces_test.cljc

@@ -1,7 +1,7 @@
 (ns sci.namespaces-test
   (:require
    [clojure.set :as set]
-   [clojure.test :as test :refer [deftest is testing]]
+   [clojure.test :as test :refer [deftest is]]
    [sci.test-utils :as tu]))
 
 (defn eval*

test/sci/records_test.cljc

@@ -110,4 +110,10 @@
 (let [a 6 b 2
       rect (Rectangle. a b)]
   (foo/area rect))"]
-    (is (= 12 (tu/eval* prog {})))))
+    (is (= 12 (tu/eval* prog {}))))
+  (testing "constructor can be used in protocol impls"
+    (is (= {:x 1}
+           (tu/eval*
+            "(defprotocol IFoo (foo [this]))
+             (defrecord Foo [x] IFoo (foo [this] (Foo. x)))
+             (foo (Foo. 1))" {})))))