git » blacktide.git » master » tree

[master] / test / com / tailrecursion / blacktide / backend_fixture.clj 

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
(ns com.tailrecursion.blacktide.backend-fixture
  "Compile source and machine forms in a stable namespace; observe backend stages."
  (:require [com.tailrecursion.blacktide :refer [loophole label goto setq psetq]]
            [com.tailrecursion.blacktide.compiler :as compiler]
            [com.tailrecursion.blacktide.compiler.passes.graph :as graph]
            [com.tailrecursion.blacktide.compiler.passes.emit :as emit]
            [com.tailrecursion.blacktide.compiler.passes.numeric :as numeric]))

(defn with-backend [mode f]
  (with-redefs [numeric/program (if (= mode :generic) identity numeric/program)
                compiler/compile-program (if (= mode :dispatcher)
                                            (comp emit/program-form graph/allocate)
                                            compiler/compile-program)]
    (f)))

(defn run-form
  ([form] (run-form 'com.tailrecursion.blacktide.backend-fixture form))
  ([namespace form] (binding [*ns* (the-ns namespace)] (eval form))))

(defn root-error [error]
  (if-let [cause (ex-cause error)] (recur cause) error))

(defn rejection
  ([form] (rejection 'com.tailrecursion.blacktide.backend-fixture form))
  ([namespace form]
   (try (run-form namespace form) nil
        (catch Throwable error (ex-data (root-error error))))))

(defn compile-program [form mode]
  (with-backend mode #(run-form (list 'fn '[events] form))))

(defn capture [pass form]
  (let [result (atom nil) original @pass]
    (with-redefs-fn {pass (fn [& args] (let [out (apply original args)] (reset! result out) out))}
      #(compile-program form :default))
    @result))

(defn execution [form mode]
  (let [f (compile-program form mode) events (atom [])]
    (try {:value (f events) :trace @events}
         (catch Throwable error {:throw (class error) :trace @events}))))

(defn literal [value] {:op :literal :value value})
(defn local [id] {:op :local :id id})
(defn assign [id rhs] {:target id :value rhs})
(defn put-value [id value] (assign id {:op :value :value (literal value)}))
(defn call [id f & args] (assign id {:op :invoke :function (local f) :args (vec args)}))
(defn block [ops term] {:ops (vec ops) :term term})
(defn checked-machine [program] (graph/allocate (graph/validate program)))
(defn run-machine [machine]
  (binding [*ns* (the-ns 'com.tailrecursion.blacktide.backend-fixture)]
    (eval (emit/program-form machine))))