git » blacktide.git » master » tree

[master] / test / com / tailrecursion / blacktide / jumps_test.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
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
(ns com.tailrecursion.blacktide.jumps-test
  "Statement transfers, outer labels, scope reentry and bounded control graphs."
  (:require [clojure.test :refer [deftest is]]
            [clojure.test.check.clojure-test :refer [defspec]]
            [clojure.test.check.generators :as gen]
            [clojure.test.check.properties :as prop]
            [com.tailrecursion.blacktide :refer [loophole label goto setq psetq]]
            [com.tailrecursion.blacktide.backend-fixture :as backend]))

(defn step [n] (dec n))
(defn more? [n] (pos? n))
(defn add [a b] (+' a b))
(defn odd-value? [n] (odd? n))
(defn record! [events tag value] (swap! events conj tag) value)

(deftest basic-and-conditional-transfers
  (is (= 1 (loophole [x 1] (goto end) (setq x 9) (label end) x)))
  (is (nil? (loophole [] (goto done) :unreachable (label done))))
  (is (nil? (loophole [] (label first) (label last))))
  (is (= 0 (loophole [n 3] (label again) (setq n (step n)) (when (more? n) (goto again)) n))))

(deftest scope-reentry
  (let [events (atom [])]
    (is (= 1 (loophole [n 3 result nil]
               (label again)
               (let [x (record! events n n)]
                 (setq n (step n))
                 (if (more? n) (goto again) (setq result x))) result)))
    (is (= [3 2 1] @events))))

(deftest invalid-transfers-even-in-dead-source
  (doseq [[body kind] [['(goto missing) :undefined-label]
                       ['(goto end) :undefined-label]
                       ['(do (label x) (label x)) :duplicate-label]
                       ['(label :keyword) :invalid-marker]
                       ['(goto qualified/name) :invalid-marker]
                       ['(vector (label x)) :marker-position]
                       ['(let [] (label x)) :marker-position]
                       ['(if true (label x) nil) :marker-position]
                       ['(case 0 0 (label x) nil) :marker-position]
                       ['(vector (do (goto done) 1)) :marker-position]
                       ['(let [x (do (goto done) 1)] x) :marker-position]
                       ['(setq x (do (goto done) 1)) :marker-position]
                       ['(loophole [] 1) :unsupported-form]]
          prefix [[] ['(goto done)]]]
    (is (= kind (:kind (backend/rejection (list* 'loophole '[x 0] (concat prefix [body '(label done)])))))
        (pr-str [prefix body]))))

(defn sum-through [input]
  (loophole [n input total 0]
    (label again)
    (when-not (more? n) (goto done))
    (setq total (add total n) n (step n))
    (goto again)
    (label done) total))

(defn fibonacci [input]
  (loophole [n input a 0 b 1]
    (label again)
    (when-not (more? n) (goto done))
    (psetq a b b (add a b))
    (setq n (step n))
    (goto again)
    (label done) a))

(defn reference-fibonacci [n]
  (loop [n n a 0 b 1] (if (zero? n) a (recur (dec n) b (+' a b)))))

(defspec bounded-algorithm-differentials {:num-tests 300 :seed 424242}
  (prop/for-all [n (gen/choose 0 49)]
    (and (= (reduce +' 0 (range 1 (inc n))) (sum-through n))
         (= (reference-fibonacci n) (fibonacci n)))))

(deftest large-sum
  (is (= 5000050000 (sum-through 100000))))

(defn reference-machine [table budget value]
  (loop [state 0 budget budget value value trace []]
    (if (zero? budget) [value trace]
      (let [{:keys [delta yes no]} (nth table state)
            next-value (+ value delta)]
        (recur (if (odd? next-value) yes no) (dec budget) next-value (conj trace [state value]))))))

(defn machine-form [table budget value labels wrapped?]
  (let [blocks
        (mapcat (fn [state {:keys [delta yes no]}]
                  (let [body (list 'let ['x (list 'record! 'events [state 'value] 'value)]
                                   (list 'setq 'value (list 'add 'x delta) 'budget '(step budget))
                                   (list 'if '(more? budget)
                                         (list 'if '(odd-value? value) (list 'goto (nth labels yes)) (list 'goto (nth labels no)))
                                         '(goto done)))]
                    [(list 'label (nth labels state)) (if wrapped? (list 'do (list 'do body)) body)]))
                (range) table)]
    (list 'let ['events '(atom [])]
          (list* 'loophole ['budget budget 'value value]
                 (concat ['(when-not (more? budget) (goto done)) (list 'goto (first labels))]
                         blocks ['(label done) ['value '(deref events)]])))))

(defn execute-machine [table budget value labels wrapped?]
  (binding [*ns* (the-ns 'com.tailrecursion.blacktide.jumps-test)]
    (try (eval (machine-form table budget value labels wrapped?))
         (catch Throwable e {:compiler-error (ex-message e)}))))

(defspec generated-bounded-control-graphs {:num-tests 60 :seed 8675309}
  (prop/for-all [table (gen/vector (gen/hash-map :delta (gen/choose -4 4)
                                                :yes (gen/choose 0 2) :no (gen/choose 0 2)) 3)
                 budget (gen/choose 0 13) value (gen/choose -20 20)]
    (let [expected (reference-machine table budget value)]
      (every? true?
        (for [[labels wrapped?] [['[end b c] false] ['[renamed-a renamed-b renamed-c] true]]]
          (= expected (execute-machine table budget value labels wrapped?)))))))