git » blacktide.git » master » tree

[master] / test / com / tailrecursion / blacktide / check.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
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
(ns com.tailrecursion.blacktide.check
  "Check production compiler pass bodies independently of the nanopass library."
  (:require [clojure.test :refer [deftest is]]
            [typed.clojure :as t]
            [com.tailrecursion.nanopass.check :as probes]
            [com.tailrecursion.blacktide.annotations :as annotations]
            [com.tailrecursion.blacktide.compiler.languages :as-alias l]
            [com.tailrecursion.blacktide.compiler.passes.boundaries :as boundaries]
            [com.tailrecursion.blacktide.compiler.passes.assignment :as assignment]))

(deftest compiler-passes
  (doseq [namespace annotations/compiler-namespaces
          :when (not= namespace 'com.tailrecursion.blacktide.compiler.languages)]
    (is (t/check-ns-clj namespace) (str namespace))))

(deftest compilation-stage-contracts
  (doseq [[accepted stages]
          [[true `[boundaries/stage assignment/stage]]
           [false `[assignment/stage boundaries/stage]]
           [false `[boundaries/stage]]]]
    (let [form `(fn [compilation#] (-> compilation# ~@stages))
          {:keys [ex delayed-errors]}
          (probes/check-form form `[l/Bound-Compilation :-> l/Assigned-Compilation])
          errors (concat delayed-errors (:errors (ex-data ex)))]
      (is (or (nil? ex) (= :top-level-error (:type-error (ex-data ex)))) (str ex))
      (is (= accepted (empty? errors)) (pr-str [form errors])))))

(deftest assignment-stage-exclusions
  (let [expr (fn [node] {:site {:form nil :file nil :line nil :column nil}
                         :jvm {:hint nil :var-meta {} :type :unknown :primitive? false :hint-error nil}
                         :node node})
        batch {:op :psetq :pairs []}
        assigned 'com.tailrecursion.blacktide.compiler.languages/Assigned-Expr]
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Bound-Node {:op :setq :pairs []} true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Assigned-Node {:op :setq :pairs []} false)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Bound-Node batch true)
    (probes/accepts? assigned (expr batch) false)
    (probes/accepts? assigned (expr {:op :do :forms [(expr batch)]}) false)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Native-Expr
                    (expr {:op :do :forms [(expr batch)]}) false)
    (probes/accepts? assigned (expr {:op :literal :value batch}) true)))

(deftest native-and-recur-boundaries
  (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Native-Node {:op :setq :pairs []} false)
  (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Native-Node
                  {:op :goto :name 'done} false)
  (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node
                  {:op :recur :target {:id 'loop :bindings []} :args []} true)
  (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node
                  {:op :recur :target {:id 'loop :bindings []} :args [{:op :literal :value 1}]} false))

(deftest host-preparation-boundary
  (let [operation {:op :method-value :name 'String/.length}
        unprepared {:op :host :operation operation :args []}
        prepared {:op :host-call :operation operation :args []}]
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Collections-Node unprepared true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Prepared-Node unprepared false)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Prepared-Node prepared true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node
                    (assoc prepared :args [{:op :literal :value nil}]) false)))

(deftest case-control-flow-boundary
  (let [expr {:site {:form nil :file nil :line nil :column nil}
              :jvm {:hint nil :var-meta {} :type Long/TYPE :primitive? true :hint-error nil}
              :node {:op :literal :value 0}}
        node {:op :case :selector expr :arms [expr]}]
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Assigned-Node node true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node node true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/CFG-Term node false)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/CFG-Term
                    {:op :switch :test {:op :literal :value 0} :targets [1 2]} true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Ordered-Node
                    {:op :switch :test {:op :literal :value 0} :targets [1 2]} false)))

(deftest numeric-representation-boundary
  (let [call {:op :numeric :operation {:op :static :class clojure.lang.Numbers :member 'add :tags nil} :args [] :parameters [] :return Number}
        expr {:op :bind :binding {:target 'x :value call}
              :body {:op :return :values [{:op :local :id 'x}]}}]
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Numeric-Rhs call true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Machine-Rhs call false)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Represented-Expr expr true)
    (probes/accepts? 'com.tailrecursion.blacktide.compiler.languages/Compact-Expr expr false)))