aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/lang.clj411
-rw-r--r--src/lang/analyser.clj299
-rw-r--r--src/lang/compiler.clj254
3 files changed, 458 insertions, 506 deletions
diff --git a/src/lang.clj b/src/lang.clj
index 4dd8e159c..5e4316db4 100644
--- a/src/lang.clj
+++ b/src/lang.clj
@@ -6,11 +6,6 @@
[compiler :as &compiler])
:reload))
-(defn write-file [file data]
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
- ;; (prn 'write-file 'file file 'stream stream 'data data)
- (.write stream data)))
-
(comment
;; TODO: Add macros.
;; TODO: Re-implement compiler in language.
@@ -32,28 +27,6 @@
;; TODO:
;; TODO:
- (let [test '([:lang.parser/case-branch [:lang.parser/variant "Nil" ()]
- [:lang.parser/ident "yx"]]
- [:lang.parser/case-branch [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/ident "xs*"])]
- [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/fn-call [:lang.parser/ident "++"] ([:lang.parser/ident "xs*"] [:lang.parser/ident "ys"])])]])
- convert (fn [cases]
- (list (reduce (fn [acc [_ shape body]]
- (clojure.core.match/match shape
- [::&parser/variant ?tag ?elems]
- (let [=elems (map (fn [elem]
- (clojure.core.match/match elem
- [::&parser/ident ?ident]
- [::ident ?ident]))
- ?elems)]
- (conj acc [?tag =elems body]))))
- []
- cases)))]
- (convert test))
-
- (enumerate (list (list '["Nil" [] branch-0]
- '["Cons" [x xs*] branch-1])))
-
-
(let [source-code (slurp "test2.lang")
tokens (&lexer/lex source-code)
;; _ (prn 'tokens tokens)
@@ -64,249 +37,171 @@
class-data (&compiler/compile "test2" ann-syntax)
;; _ (prn 'class-data class-data)
]
- (write-file "test2.class" class-data))
+ (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. "test2.class"))]
+ (.write stream class-data)))
;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
)
(comment
-
- (let [data '([::&parser/case-branch [::&parser/variant "Nil" ()]
- [::&parser/ident "ys"]]
- [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/ident "xs*"])]
- [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/fn-call [::&parser/ident "++"] ([::&parser/ident "xs*"] [::&parser/ident "ys"])])]])
- ;; count-registers (fn count-registers [pattern]
- ;; (clojure.core.match/match pattern
- ;; [::&parser/ident _]
- ;; 0
-
- ;; [::&parser/variant _ ?members]
- ;; (reduce + (count ?members) (map count-registers ?members))))
- gen-impl (fn gen-impl [offset pattern]
- (clojure.core.match/match pattern
- [::&parser/ident _]
- [1 [::case-bind -1 offset]]
+ ;; (let [branches '([::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~"])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]]
+ ;; [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~@"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "++"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])])]]
+ ;; [::&parser/case-branch [::&parser/ident "_"] [::&parser/variant "Cons" ([::&parser/ident "head"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]])
+ ;; ;; Step 1: Get all vars
+ ;; get-vars (fn get-vars [pattern]
+ ;; (clojure.core.match/match pattern
+ ;; [::&parser/ident ?name]
+ ;; (list ?name)
- [::&parser/variant ?tag ?members]
- (let [regs+insns (mapv (fn [idx member]
- (clojure.core.match/match member
- [::&parser/ident _]
- [1 [::case-sub-bind (+ offset (inc idx))]]))
- (range (count ?members))
- ?members)]
- [(reduce + 1 (map first regs+insns)) [::case-try ?tag (mapv second regs+insns)]])
- (reduce + (count ?members) (map gen-impl ?members))))]
- (reduce (fn [accum branch]
- (clojure.core.match/match branch
- [::&parser/case-branch ?pattern ?body]
- (clojure.core.match/match ?pattern
- [::&parser/variant ?tag ?members]
- (let [[extra-registers impl] (gen-impl 0 ?pattern)
- _ (prn 'impl extra-registers impl)
- $branch (get-in accum [:paths :total])]
- (-> accum
- (update-in [:patterns]
- (fn [patterns]
- (if (contains? patterns ?tag)
- (if (= (get patterns [?tag :arity]) (count ?members))
- (update-in patterns [?tag :branches] conj {:test impl
- :link $branch})
- (assert "Pattern arity doesn't match!"))
- (assoc patterns ?tag {:arity (count ?members)
- :branches [{:test impl
- :link $branch}]}))))
- (update-in [:paths]
- (fn [paths]
- (-> paths
- (update-in [:total] inc)
- (assoc-in [:links $branch] ?body))))
- (update-in [:registers] + (dec extra-registers)))))
- ))
- {:registers 1
- :patterns {}
- :paths {:total 0
- :links {}}}
- data))
+ ;; [::&parser/variant ?tag ?members]
+ ;; (mapcat get-vars ?members)
+
+ ;; [::&parser/string ?text]
+ ;; '()))
+ ;; vars+body (for [branch branches]
+ ;; (clojure.core.match/match branch
+ ;; [::&parser/case-branch ?pattern ?body]
+ ;; [(get-vars ?pattern) ?body]))
+ ;; ;; _ (prn 'vars+body vars+body)
+ ;; max-registers (reduce max 0 (map (comp count first) vars+body))
+ ;; ;; _ (prn 'max-registers max-registers)
+ ;; ;; Step 2: Analyse bodies
+ ;; ;; all-analysis (map (fn [[vars body]]
+ ;; ;; (reduce #(with-local %2 [::&type/object "java.lang.Object" []] %1)
+ ;; ;; (analyse-form* body)
+ ;; ;; (reverse vars)))
+ ;; ;; vars+body)
+ ;; ;; Step 3: Extract bodies
+ ;; [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch]
+ ;; (clojure.core.match/match branch
+ ;; [::&parser/case-branch ?pattern ?body]
+ ;; [(inc $link) (assoc links $link ?body) (conj branches* [::&parser/case-branch ?pattern $link])]))
+ ;; [0 {} []]
+ ;; branches)
+ ;; ;; Step 4: Pattens -> Instructions
+ ;; ;; ->instructions (fn ->instructions [locals pattern]
+ ;; ;; (clojure.core.match/match pattern
+ ;; ;; [::&parser/variant ?tag ?members]
+ ;; ;; [::pm-variant ?tag (map (partial ->instructions locals) ?members)]
+
+ ;; ;; [::&parser/ident ?name]
+ ;; ;; [::pm-local (get locals ?name)]
+
+ ;; ;; [::&parser/string ?text]
+ ;; ;; [::pm-text ?text]
+ ;; ;; ))
+ ;; ;; $scope 0 ;; scope-id
+ ;; ;; $local 11 ;; next-local-idx
+ ;; ;; branches** (for [[branch branch-vars] (map vector branches* (map first vars+body))
+ ;; ;; :let [[_ locals] (reduce (fn [[$local =locals] $var]
+ ;; ;; [(inc $local) (assoc =locals $var [::local $scope $local])])
+ ;; ;; [$local {}] branch-vars)]]
+ ;; ;; (clojure.core.match/match branch
+ ;; ;; [::&parser/case-branch ?pattern ?body]
+ ;; ;; [(->instructions locals ?pattern) ?body]))
+ ;; ;; _ (prn branches**)
+ ;; ;; Step 5: Re-structure branching
+ ;; ]
+ ;; ;; [branch-mappings branches**]
+ ;; branches*)
- '([::&parser/case-branch [::&parser/variant "Nil" ()]
- [::&parser/ident "ys"]]
- [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/ident "xs*"])]
- [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/fn-call [::&parser/ident "++"] ([::&parser/ident "xs*"] [::&parser/ident "ys"])])]])
-
- '([:try "Nil" []]
- [:try "Cons" [[:bind 0 1] [:bind 1 2]]])
- (list '["Nil" [] branch-0]
- '["Cons" [x xs*] branch-1])
-
- [:if [% tag "Nil"]
- branch-0
- [:let [%0 %1]
- branch-1]]
- (let [enumerate (fn [xs] (map vector (range (count xs)) xs))
- cases (enumerate (list (list '["Nil" [] branch-0]
- '["Cons" [x xs*] branch-1])))
- classify-cases (fn [[idx cases]]
- [idx (reduce (fn [order [tag members branch]]
- (if-let [{:keys [arity branches] :as sub-struct} (get order tag)]
- (if (= arity (count members))
- (update-in order [tag :branches] conj [members branch])
- (assert (str "Arity doesn't match:" (count members) " != " arity)))
- (assoc order tag {:arity (count members)
- :branches (vector [members branch])})))
- {}
- cases)])
- ;; case->struct (fn [cases]
- ;; (let [struct (classify-case cases)
- ;; struct* (seq struct)]
- ;; (reduce (fn [inner [tag {:keys [arity branches]}]]
- ;; [:if [% tag "Nil"]
- ;; branch-0
- ;; inner])
- ;; (second (last struct*))
- ;; (butlast struct*))
- ;; ))
- ]
- ;; (classify-case cases)
- (let [;; separated (apply map list cases)
- classifications (map classify-cases cases)
- classifications* (sort-by first > classifications)]
- ((fn [[idx struct]]
- (prn idx struct)
- (if-let [default (get struct nil)]
- (reduce (fn [[dbinds dbranch] [tag [binds branch]]]
- [:if tag
- [:let binds
- branch]
- [:let dbinds
- dbranch]])
- (-> default :branches first)
- (seq struct))
- (let [struct* (seq struct)]
- (reduce (fn [[dbinds dbranch] [tag sub-struct]]
- (let [[binds branch] (-> sub-struct :branches first)]
- [:if tag
- [:let binds
- branch]
- [:let dbinds
- dbranch]]))
- (-> struct* last second :branches first)
- (butlast struct*)))))
- (first classifications*))
- ))
- ;; ([0 {"Cons" {:arity 2, :branches [[[x xs*] branch-1]]}, "Nil" {:arity 0, :branches [[[] branch-0]]}}])
+ ;; (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0]
+ ;; [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1]
+ ;; [[:lang/pm-local [:lang/local 0 11]] 2])
+ ;; classify-outer (fn [struct [branch $body]]
+ ;; (clojure.core.match/match branch
+ ;; [::pm-variant ?tag ?members]
+ ;; (update-in struct [:cases ?tag] conj {:members ?members
+ ;; :body $body})
+
+ ;; [::pm-text ?text]
+ ;; (update-in struct [:tests] conj {:test [::text ?text]
+ ;; :body $body})
+
+ ;; [::pm-local ?binding]
+ ;; (assoc struct :default {:storage ?binding
+ ;; :body $body})))
+ ;; outer-classification (reduce classify-outer
+ ;; {:cases {}
+ ;; :tests '()
+ ;; :default nil}
+ ;; data)
+ ;; full-classifier (fn full-classifier [global]
+ ;; (prn 'full-classifier global)
+ ;; (let [subcases (:cases global)]
+ ;; (if (empty? subcases)
+ ;; global
+ ;; (let [crossed (sort (fn [x1 x2] (> (-> x1 second :cases count) (-> x2 second :cases count)))
+ ;; (for [[tag subs] subcases
+ ;; :let [_ (prn 'subcases tag subs)]
+ ;; :let [parts (for [cross (apply map list (map :members subs))
+ ;; :let [_ (prn 'cross tag cross)]
+ ;; ;; :let [_ (prn '(map :body subs) (map :body subs))]
+ ;; ;; :let [_ (prn (class cross) (count cross)
+ ;; ;; (class (map :body subs)) (count (map :body subs)))]
+ ;; :let [cross+ (map vector cross (map :body subs))]
+ ;; ;; :let [_ (prn 'cross+ tag (class cross+) (count cross+))]
+ ;; ;; :let [_ (prn 'cross+ tag cross+)]
+ ;; :let [cross++ (reduce classify-outer
+ ;; {:cases {}
+ ;; :tests '()
+ ;; :default nil}
+ ;; cross+)]
+ ;; ;; :let [_ (prn 'cross++ tag cross++)]
+ ;; ]
+ ;; cross++)]
+ ;; :let [_ (prn 'parts parts)]]
+ ;; [tag parts]))
+
+ ;; ]
+ ;; (assoc global :cases (reduce (fn [tree [tag subcases]]
+ ;; (update-in tree [tag] #(conj (or % []) (full-classifier subcases))))
+ ;; {}
+ ;; crossed))))))]
+ ;; (full-classifier outer-classification))
+ )
- ;; {"Cons" {:arity 2, :branches [[[x xs*] branch-1]]},
- ;; "Nil" {:arity 0, :branches [[[] branch-0]]}}
-
-
- ;; .........................
-
- ;; (case elems
- ;; #Nil
- ;; elems
-
- ;; (#Cons head tail)
- ;; (case head
- ;; (#Cons (#Symbol "~") (#Cons unquoted #Nil))
- ;; (#Cons unquoted (template tail))
-
- ;; (#Cons (#Symbol "~@") (#Cons spliced #Nil))
- ;; (#Cons (#Symbol "++") (#Cons spliced (template tail)))
-
- ;; _
- ;; (#Cons head (template tail)))
- ;; )
-
- ;; Total registers: 3
- ;; [{:tag "Nil" :data [] :path path-1}
- ;; {:tag "Cons" :data [[:bind head] [:bind tail]] :path path-2}]
-
- ;; {path-0 [:branch "Nil" []]
- ;; path-1 [:branch "Cons" [[:bind head] [:bind tail]]]}
-
- ;; Total registers: 6
- ;; {path-0 [:branch "Cons" [[:adt "Symbol" [[:string-cmp "~"]]] [:adt "Cons" [[:bind unquoted] [:adt "Nil" []]]]]]
- ;; path-1 [:branch "Cons" [[:adt "Symbol" [[:string-cmp "~@"]]] [:adt "Cons" [[:bind spliced] [:adt "Nil" []]]]]]
- ;; path-2 [:default _]}
-
- ;; {"#default#" [:default path-2 _]
- ;; "Cons" [:branches [path-0 path-1]
- ;; [[[:adt "Symbol" [[:string-cmp "~"]]] [:adt "Cons" [[:bind unquoted] [:adt "Nil" []]]]]
- ;; [[:adt "Symbol" [[:string-cmp "~@"]]] [:adt "Cons" [[:bind spliced] [:adt "Nil" []]]]]]]}
-
- ;; [:branches]
+(comment
+ [{2 [:lang.parser/variant "Cons" ([:lang.parser/ident "head"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])],
+ 1 [:lang.parser/variant "Cons" ([:lang.parser/variant "Symbol" ([:lang.parser/string "++"])] [:lang.parser/variant "Cons" ([:lang.parser/ident "spliced"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])])],
+ 0 [:lang.parser/variant "Cons" ([:lang.parser/ident "unquoted"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])]}
+ {:type :lang/adt*,
+ :patterns {"Cons" ({:type :lang/adt*,
+ :patterns {"Symbol" ({:type :lang/text-tests,
+ :patterns {"~@" #{1},
+ "~" #{0}},
+ :defaults [],
+ :branches #{0 1}})},
+ :default nil,
+ :branches #{0 1}}
+ {:type :lang/adt*,
+ :patterns {"Cons" ({:type :lang/defaults,
+ :stores {[:lang/local 0 11] #{0 1}},
+ :branches #{0 1}}
+ {:type :lang/adt*,
+ :patterns {"Nil" ()},
+ :default nil,
+ :branches #{0 1}})},
+ :default nil,
+ :branches #{0 1}})},
+ :default [:lang/default [:lang/local 0 11] 2],
+ :branches #{0 1 2}}]
-
- ;; (case elems
- ;; #Nil
- ;; elems
-
- ;; (#Cons (list (' ~) unquoted) tail)
- ;; (list* unquoted (template tail))
-
- ;; (#Cons (list (' ~@) spliced) tail)
- ;; (list* "++" spliced (template tail))
-
- ;; _
- ;; (#Cons head (template tail))
- ;; )
-
- ;; [{:tag "Nil" :data [] :path path-1}
- ;; {:tag "Cons" :data [[:bind head] [:bind tail]] :path path-2}]
-
- ;; [[{:tag "Cons" :data [%0 %1] :path nil
- ;; :sub-cases [[{:tag "Symbol" :data [[:string-cmp "~"]] :path path-1}
- ;; {:tag "Symbol" :data [[:string-cmp "~@"]] :path path-2}]
- ;; [{:tag "Cons" :data [[:bind unquoted] {:tag "Nil" :data []}] :path path-1}
- ;; {:tag "Cons" :data [[:bind spliced] {:tag "Nil" :data []}] :path path-2}]]}
- ;; {:tag ::default :path path-3}]]
-
- ;; [[["Cons" ["Symbol" "~"] ["Cons" unquoted ["Nil"]]]
- ;; ["Cons" ["Symbol" "~@"] ["Cons" spliced ["Nil"]]]
- ;; _]]
-
- ;; [[["Symbol" "~"]
- ;; ["Symbol" "~@"]]
- ;; [["Cons" unquoted ["Nil"]]
- ;; ["Cons" spliced ["Nil"]]]]
-
- ;; (if (= "Cons" (:: % tag))
- ;; (let [%0 (:: % _0)
- ;; %1 (:: % _1)]
- ;; (if (= "Symbol" (:: %0 tag))
- ;; (let [%0|0 (:: %0 _0)]
- ;; (if (= "~" %0|0)
- ;; (if (= "Cons" (:: %1 tag))
- ;; (let [%1|0 (:: %1 _0)
- ;; %1|1 (:: %1 _1)]
- ;; (if (= "Nil" (:: %1|1 tag))
- ;; (let [unquoted %1|0]
- ;; <path-1>)
- ;; <path-3>))
- ;; <path-3>)
- ;; (if (= "@~" %0|0)
- ;; (if (= "Cons" (:: %1 tag))
- ;; (let [%1|0 (:: %1 _0)
- ;; %1|1 (:: %1 _1)]
- ;; (if (= "Nil" (:: %1|1 tag))
- ;; (let [unquoted %1|0]
- ;; <path-2>)
- ;; <path-3>))
- ;; <path-3>)
- ;; <path-3>)))
- ;; <path-3>))
- ;; <path-3>)
-
+ (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0]
+ [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1]
+ [[:lang/pm-local [:lang/local 0 11]] 2])
+ ]
+ (generate-branches data))
+
+ ;; (def (workday? d)
+ ;; (case d
+ ;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday]
+ ;; true)
+ ;; (or [#Saturday #Sunday]
+ ;; false)))
-
- ;; (list (list '["Nil" [] ...]
- ;; '["Cons" [head tail] ...]))
-
- ;; (list (list '["Cons" [["Symbol" ["~"]] ["Cons" [unquoted ["Nil" []]]]] ...]
- ;; '["Cons" [["Symbol" ["~@"]] ["Cons" [spliced ["Nil" []]]]] ...]))
)
-
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 72ea43e69..f45f44138 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -117,22 +117,6 @@
=return)
)))
-(defn ^:private with-anon-locals [amount k]
- (fn [state]
- (let [env (-> state :env first)
- $scope (:id env)
- =locals (for [$local (take amount (iterate inc (:counter env)))]
- (annotated [::local $scope $local] [::&type/object "java.lang.Object" []]))
- =return ((k =locals) (update-in state [:env] #(cons (update-in (first %) [:counter] + amount) (rest %))))]
- (match =return
- [::&util/ok [?state ?value]]
- (do ;; (prn 'POST-WITH-LOCAL name (-> ?state :env first))
- [::&util/ok [(update-in ?state [:env] #(cons (update-in (first %) [:counter] - amount) (rest %)))
- ?value]])
-
- _
- =return))))
-
(defn ^:private with-locals [mappings monad]
(fn [state]
(let [=return (monad (update-in state [:env] #(cons (update-in (first %) [:mappings] merge mappings)
@@ -423,142 +407,159 @@
(exec [=exprs (map-m analyse-form* ?exprs)]
(return (annotated [::do =exprs] (-> =exprs last :type)))))
+(let [fold-branches (fn [struct entry]
+ (let [struct* (clojure.core.match/match (nth entry 0)
+ [::pm-text ?text]
+ (clojure.core.match/match (:type struct)
+ ::text-tests (update-in struct [:patterns ?text] (fn [bodies]
+ (if bodies
+ (conj bodies (nth entry 1))
+ #{(nth entry 1)})))
+ nil (-> struct
+ (assoc :type ::text-tests)
+ (assoc-in [:patterns ?text] #{(nth entry 1)}))
+ _ (assert false "Can't do match."))
+ [::pm-variant ?tag ?members]
+ (clojure.core.match/match (:type struct)
+ ::adt (update-in struct [:patterns]
+ (fn [branches]
+ (if-let [{:keys [arity cases]} (get branches ?tag)]
+ (if (= arity (count ?members))
+ (-> branches
+ (update-in [?tag :cases] conj {:case ?members
+ :body (nth entry 1)})
+ (update-in [?tag :branches] conj (nth entry 1)))
+ (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity)))
+ (assoc branches ?tag {:arity (count ?members)
+ :cases [{:case ?members
+ :body (nth entry 1)}]
+ :branches #{(nth entry 1)}}))))
+ nil (-> struct
+ (assoc :type ::adt)
+ (assoc-in [:patterns ?tag] {:arity (count ?members)
+ :cases [{:case ?members
+ :body (nth entry 1)}]
+ :branches #{(nth entry 1)}}))
+ _ (assert false "Can't do match."))
+
+ [::pm-local ?local]
+ (update-in struct [:defaults] conj [::default ?local (nth entry 1)]))]
+ (update-in struct* [:branches] conj (nth entry 1))))
+ base-struct {:type nil
+ :patterns {}
+ :defaults []
+ :branches #{}}
+ generate-branches (fn generate-branches [data]
+ (let [branches* (reduce fold-branches base-struct data)]
+ ;; (prn 'generate-branches data)
+ ;; (prn 'branches* branches*)
+ ;; (.print System/out (prn-str 'branches* branches*))
+ ;; (.print System/out (prn-str '(:type branches*) (:type branches*)))
+ (clojure.core.match/match (:type branches*)
+ ::text-tests branches*
+ ::adt (do (assert (<= (count (:defaults branches*)) 1))
+ {:type ::adt*
+ :patterns (into {} (for [[?tag ?struct] (:patterns branches*)
+ ;; :let [_ (prn '(:patterns branches*) ?tag ?struct)]
+ ]
+ [?tag {:parts (let [grouped-parts (apply map list (for [{:keys [case body]} (:cases ?struct)]
+ (map #(vector % body) case)))]
+ (map generate-branches grouped-parts))
+ :branches (:branches ?struct)}]))
+ :default (-> branches* :defaults first)
+ :branches (:branches branches*)})
+ nil {:type ::defaults,
+ :stores (reduce (fn [total [_ ?store ?body]]
+ (update-in total [?store] (fn [mapping]
+ (if mapping
+ (conj mapping ?body)
+ #{?body}))))
+ {}
+ (:defaults branches*))
+ :branches (:branches branches*)})))
+ get-vars (fn get-vars [pattern]
+ (clojure.core.match/match pattern
+ [::&parser/ident ?name]
+ (list ?name)
+
+ [::&parser/variant ?tag ?members]
+ (mapcat get-vars ?members)
+
+ [::&parser/string ?text]
+ '()))
+ ->instructions (fn ->instructions [locals pattern]
+ (clojure.core.match/match pattern
+ [::&parser/variant ?tag ?members]
+ [::pm-variant ?tag (map (partial ->instructions locals) ?members)]
+
+ [::&parser/ident ?name]
+ [::pm-local (get locals ?name)]
+
+ [::&parser/string ?text]
+ [::pm-text ?text]
+ ))]
+ (defn ->decision-tree [$scope $base branches]
+ (let [;; Step 1: Get all vars
+ vars+body (for [branch branches]
+ (clojure.core.match/match branch
+ [::&parser/case-branch ?pattern ?body]
+ [(get-vars ?pattern) ?body]))
+ max-registers (reduce max 0 (map (comp count first) vars+body))
+ ;; Step 2: Analyse bodies
+ [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch]
+ (clojure.core.match/match branch
+ [::&parser/case-branch ?pattern ?body]
+ [(inc $link) (assoc links $link ?body) (conj branches* [::&parser/case-branch ?pattern $link])]))
+ [0 {} []]
+ branches)
+ ;; Step 4: Pattens -> Instructions
+ branches** (for [[branch branch-vars] (map vector branches* (map first vars+body))
+ :let [[_ locals] (reduce (fn [[$local =locals] $var]
+ [(inc $local) (assoc =locals $var [::local $scope $local])])
+ [$base {}] branch-vars)]]
+ (clojure.core.match/match branch
+ [::&parser/case-branch ?pattern ?body]
+ [(->instructions locals ?pattern) ?body]))
+ ;; _ (prn branches**)
+ ;; Step 5: Re-structure branching
+ ]
+ [max-registers branch-mappings (generate-branches branches**)])))
+
(defanalyser analyse-case
[::&parser/case ?variant ?branches]
- (exec [;; :let [_ (prn '?variant ?variant)]
- =variant (analyse-form* ?variant)
- ;; :let [_ (prn '=variant =variant)]
- ;; {:registers 3,
- ;; :patterns {"Cons" {:arity 2, :branches [{:test [:lang/case-try "Cons" [[:lang/case-sub-bind 1] [:lang/case-sub-bind 2]]], :link 1}]},
- ;; "Nil" {:arity 0, :branches [{:test [:lang/case-try "Nil" []], :link 0}]}},
- ;; :paths {:total 2,
- ;; :links {1 [:lang.parser/variant "Cons" ([:lang.parser/ident "x"] [:lang.parser/fn-call [:lang.parser/ident "++"] ([:lang.parser/ident "xs*"] [:lang.parser/ident "ys"])])],
- ;; 0 [:lang.parser/ident "ys"]}}}
- [$base =branches] (with-anon-locals 1
- (fn [=locals]
- ;; (prn 'analyse-case '=locals (map :form =locals))
- (exec [=branches (map-m (fn [?branch]
- ;; (prn '?branch ?branch)
- (match ?branch
- [::&parser/case-branch [::&parser/variant ?tag ?members] ?body]
- (let [num-members (count ?members)]
- (with-anon-locals num-members
- (fn [=locals]
- ;; (prn '?branch/=locals (map :form =locals))
- (exec [[inner-num locals+ members+] (reduce-m (fn member-fold [[?inner-num locals-map =members] [?local ?member]]
- (match ?member
- [::&parser/ident ?name]
- (return [?inner-num
- (assoc locals-map ?name ?local)
- (conj =members (:form ?local))])
-
- [::&parser/string ?text]
- (return [?inner-num
- locals-map
- (conj =members [::match-text ?text])])
-
- [::&parser/variant ?subtag ?submembers]
- (let [num-submembers (count ?submembers)]
- (with-anon-locals num-submembers
- (fn [=sublocals]
- (exec [[subinner-num sublocals+ submembers+] (reduce-m member-fold [0 {} []] (map vector =sublocals ?submembers))
- ;; :let [_ (prn 'subinner-num subinner-num 'sublocals+ sublocals+ 'submembers+ submembers+)]
- ]
- (return [(+ ?inner-num num-submembers subinner-num)
- (merge locals-map sublocals+)
- (conj =members [::subcase ?subtag submembers+])])))))
- ))
- [0 {} []]
- (map vector =locals ?members))
- ;; :let [_ (prn 'inner-num inner-num 'locals+ locals+ 'members+ members+)]
- ;; :let [_ (prn (first =members) ?body)]
- =body (with-locals locals+
- (analyse-form* ?body))
- ;; :let [_ (prn '?body ?body =body)]
- ]
- (return [(+ num-members inner-num) [::branch-adt ?tag members+ =body]])))))))
- ?branches)]
- (return [(first =locals) =branches]))))
- :let [total-registers (+ 1 (reduce max 0 (map first =branches)))
- ;; _ (prn '=branches total-registers (map second =branches))
- ;; _ (assert false)
- ]
- ;; ([::&parser/case-branch [::&parser/variant "Nil" ()]
- ;; [::&parser/ident "ys"]]
- ;; [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/ident "xs*"])]
- ;; [::&parser/variant "Cons" ([::&parser/ident "x"] [::&parser/fn-call [::&parser/ident "++"] ([::&parser/ident "xs*"] [::&parser/ident "ys"])])]])
- ;; :let [_ (prn '?branches ?branches)
- ;; case-analysis (let [gen-impl (fn gen-impl [offset pattern]
- ;; (clojure.core.match/match pattern
- ;; [::&parser/ident _]
- ;; [1 [::case-bind -1 offset]]
-
- ;; [::&parser/variant ?tag ?members]
- ;; (let [regs+insns (mapv (fn [idx member]
- ;; (clojure.core.match/match member
- ;; [::&parser/ident _]
- ;; [1 [::case-sub-bind (+ offset (inc idx))]]))
- ;; (range (count ?members))
- ;; ?members)]
- ;; [(reduce + 1 (map first regs+insns)) [::case-try ?tag (mapv second regs+insns)]])
- ;; (reduce + (count ?members) (map gen-impl ?members))))]
- ;; (reduce (fn [accum branch]
- ;; (clojure.core.match/match branch
- ;; [::&parser/case-branch ?pattern ?body]
- ;; (clojure.core.match/match ?pattern
- ;; [::&parser/variant ?tag ?members]
- ;; (let [[extra-registers impl] (gen-impl 0 ?pattern)
- ;; _ (prn 'impl extra-registers impl)
- ;; $branch (get-in accum [:paths :total])]
- ;; (-> accum
- ;; (update-in [:patterns]
- ;; (fn [patterns]
- ;; (if (contains? patterns ?tag)
- ;; (if (= (get patterns [?tag :arity]) (count ?members))
- ;; (update-in patterns [?tag :branches] conj {:test impl
- ;; :link $branch})
- ;; (assert "Pattern arity doesn't match!"))
- ;; (assoc patterns ?tag {:arity (count ?members)
- ;; :branches [{:test impl
- ;; :link $branch}]}))))
- ;; (update-in [:paths]
- ;; (fn [paths]
- ;; (-> paths
- ;; (update-in [:total] inc)
- ;; (assoc-in [:links $branch] ?body))))
- ;; (update-in [:registers] + (dec extra-registers)))))
- ;; ))
- ;; {:registers 1
- ;; :patterns {}
- ;; :paths {:total 0
- ;; :links {}}}
- ;; ?branches))
- ;; _ (prn 'case-analysis case-analysis)
- ;; _ (assert false)]
- ;; =branches (map-m identity ;; (fn [branch]
- ;; ;; ;; (prn 'branch branch)
- ;; ;; (match branch
- ;; ;; [::&parser/case-branch [::&parser/variant ?tag ?parts] ?body]
- ;; ;; (exec [;; :let [_ (prn ?tag ?label '?body ?body)]
- ;; ;; ;; (reduce-m (fn [?part]
- ;; ;; ;; (match ?part
- ;; ;; ;; [::&parser/ident ?label]
- ;; ;; ;; (exec [idx next-local-idx
- ;; ;; ;; =body (with-local ?label [::&type/object "java.lang.Object" []]
- ;; ;; ;; (analyse-form* ?body))]
- ;; ;; ;; (return ...)))
- ;; ;; ;; )
- ;; ;; ;; ?parts)
- ;; ;; idx next-local-idx
- ;; ;; =body (with-local ?label [::&type/object "java.lang.Object" []]
- ;; ;; (analyse-form* ?body))
- ;; ;; ;; :let [_ (prn ?tag ?label '=body =body)]
- ;; ;; ]
- ;; ;; (return [?tag ?label idx =body]))))
- ;; ?branches)
- ;; :let [_ (prn '=branches =branches)]
+ (exec [=variant (analyse-form* ?variant)
+ ;; :let [_ (prn 'analyse-case '=variant =variant)]
+ $scope scope-id
+ ;; :let [_ (prn 'analyse-case '$scope $scope)]
+ $base next-local-idx
+ ;; :let [_ (prn 'analyse-case '$base $base)]
+ [registers mappings tree] (exec [=branches (map-m (fn [?branch]
+ (match ?branch
+ [::&parser/case-branch [::&parser/variant ?tag ?members] ?body]
+ (exec [[_ locals+] (reduce-m (fn member-fold [[$local locals-map] ?member]
+ (match ?member
+ [::&parser/ident ?name]
+ (return [(inc $local) (assoc locals-map ?name (annotated [::local $scope $local] [::&type/object "java.lang.Object" []]))])
+
+ [::&parser/variant ?subtag ?submembers]
+ (reduce-m member-fold [$local locals-map] ?submembers)
+
+ _
+ (return [$local locals-map])
+ ))
+ [$base {}]
+ ?members)
+ ;; :let [_ (prn 'analyse-case 'locals+ locals+)]
+ =body (with-locals locals+
+ (analyse-form* ?body))
+ ;; :let [_ (prn 'analyse-case '=body =body)]
+ ]
+ (return [::&parser/case-branch [::&parser/variant ?tag ?members] =body]))))
+ ?branches)]
+ (return (->decision-tree $scope $base =branches)))
+ ;; :let [_ (prn 'analyse-case '[registers mappings tree] [registers mappings tree])]
]
- (return (annotated [::case $base =variant total-registers (map second =branches)] ::&type/nothing))))
+ (return (annotated [::case (dec $base) =variant registers mappings tree] ::&type/nothing))))
(defanalyser analyse-let
[::&parser/let ?label ?value ?body]
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index c6c75558e..e04178fed 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -1,6 +1,7 @@
(ns lang.compiler
(:refer-clojure :exclude [compile])
(:require [clojure.string :as string]
+ [clojure.set :as set]
[clojure.core.match :refer [match]]
(lang [type :as &type]
[lexer :as &lexer]
@@ -283,108 +284,163 @@
(.visitInsn *writer* Opcodes/POP))
(compile-form (assoc *state* :form (last ?exprs)))))
-(let [oclass (->class "java.lang.Object")
+(let [+tag-sig+ (->type-signature "java.lang.String")
+ variant-class* (->class +variant-class+)
+ oclass (->class "java.lang.Object")
+ +tuple-field-sig+ (->type-signature "java.lang.Object")
equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
+ (defn compile-decision-tree [writer mappings cleanup-level next-label default-label decision-tree]
+ ;; (prn 'compile-decision-tree cleanup-level decision-tree)
+ (match decision-tree
+ [::test-text ?text $body]
+ (let [$else (new Label)]
+ (doto writer
+ ;; object
+ (.visitInsn Opcodes/DUP) ;; object, object
+ (.visitLdcInsn ?text) ;; object, object, text
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; object, B
+ (.visitJumpInsn Opcodes/IFEQ $else) ;; object
+ (.visitInsn Opcodes/POP) ;;
+ (.visitJumpInsn Opcodes/GOTO next-label)
+ (.visitLabel $else)
+ (-> (doto (.visitInsn Opcodes/POP))
+ (->> (dotimes [_ (inc cleanup-level)])))
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+
+ [::store [::&analyser/local 0 ?idx] _]
+ ;; object
+ (.visitVarInsn writer Opcodes/ASTORE ?idx) ;;
+
+ [::test-adt ?branches ?cases]
+ (doto writer
+ ;; object
+ (.visitTypeInsn Opcodes/CHECKCAST variant-class*) ;; variant
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" +tag-sig+) ;; variant, tag
+ (-> (doto (.visitInsn Opcodes/DUP) ;; variant, tag, tag
+ (.visitLdcInsn ?tag) ;; variant, tag, tag, text
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig) ;; variant, tag, B
+ (.visitJumpInsn Opcodes/IFEQ tag-else-label) ;; variant, tag
+ (.visitInsn Opcodes/POP) ;; variant
+ (do (let [arity (-> ?subcases first (nth 2) count)
+ tuple-class (str "test2/Tuple" arity)]
+ (when (> arity 0)
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" +tuple-field-sig+) ;; variant, object
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class) ;; variant, tuple
+ ))
+ (doseq [subcase ?subcases
+ :let [else-label (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (when (not (empty? ?subseq))
+ (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [next-label (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; variant, tuple, tuple
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?subidx) +tuple-field-sig+) ;; variant, tuple, object
+ (compile-decision-tree mappings cleanup-level next-label else-label ?subpart) ;; variant, tuple
+ (.visitLabel next-label))))
+ (doto writer
+ (-> (doto (.visitInsn Opcodes/POP))
+ (->> (dotimes [_ (+ cleanup-level (if (> arity 0) 2 1))]))) ;;
+ (.visitJumpInsn Opcodes/GOTO (or next-label (get mappings $body)))
+ (.visitLabel else-label)))
+ ))
+ ))
+ ;; variant, tag ->
+ (.visitLabel tag-else-label))
+ (->> (doseq [[?tag ?subcases] ?cases
+ :let [tag-else-label (new Label)]])))
+ (-> (doto (.visitInsn Opcodes/POP))
+ (->> (dotimes [_ (+ cleanup-level 2)])))
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+ ))
+
+(defn sequence-parts [branches parts]
+ ;; (.print System/out (prn-str 'sequence-parts branches parts))
+ (if (empty? parts)
+ '(())
+ (let [[head & tail] parts
+ expanded (case (:type head)
+ ::&analyser/defaults
+ (for [[?local ?supports] (:stores head)
+ ?body (set/intersection branches ?supports)
+ ;; :when (set/subset? branches ?supports)
+ ]
+ [[::store ?local ?body] #{?body}])
+
+ ::&analyser/text-tests
+ (concat (for [[?text ?supports] (:patterns head)
+ ?body (set/intersection branches ?supports)
+ ;; :when (set/subset? branches ?supports)
+ ]
+ [[::test-text ?text ?body] #{?body}])
+ (for [[_ ?local ?body] (:defaults head)
+ :when (contains? branches ?body)]
+ [[::store ?local ?body] #{?body}]))
+
+ ::&analyser/adt*
+ (do (assert (nil? (:default head)))
+ (list (list [::test-adt branches (into {} (for [[?tag ?struct] (:patterns head)
+ :let [?supports (:branches ?struct)]]
+ [?tag (for [?body (set/intersection branches ?supports)
+ subseq (sequence-parts #{?body} (:parts ?struct))]
+ [::subcase ?body subseq])]))])))
+ )]
+ (for [[step branches*] expanded
+ tail* (sequence-parts branches* tail)
+ ;; :let [_ (.print System/out (prn-str 'tail* tail*))]
+ ]
+ (cons step tail*)))))
+
+(let [oclass (->class "java.lang.Object")
+ equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")
+ ex-class (->class "java.lang.IllegalStateException")]
(defcompiler ^:private compile-case
;; [::&analyser/case ?variant ?branches]
- [::&analyser/case ?base ?variant ?registers ?branches]
- (let [variant-class* (->class +variant-class+)]
- ;; (prn [:case ?base ?variant ?registers ?branches])
- (match (:form ?base)
- [::&analyser/local _ ?base-idx]
- (let [start-label (new Label)
- end-label (new Label)
- default-label (new Label)]
- (dotimes [idx ?registers]
- (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx idx)))
- (.visitLabel *writer* start-label)
- (compile-form (assoc *state* :form ?variant))
- (.visitTypeInsn *writer* Opcodes/CHECKCAST variant-class*)
- (.visitVarInsn *writer* Opcodes/ASTORE ?base-idx)
- (doseq [?branch ?branches
- :let [else-label (new Label)]]
- (match ?branch
- [::&analyser/branch-adt ?tag ?members ?body]
- (doto *writer*
- (.visitVarInsn Opcodes/ALOAD ?base-idx)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
- (.visitLdcInsn ?tag)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ else-label)
- (do (when (not (empty? ?members))
- (let [tuple-class (str "test2/Tuple" (count ?members))
- mk-sub-fold (fn mk-sub-fold [cleanup-level default-label tuple-class]
- (fn sub-fold [?tfield member]
- (let [next-label (new Label)
- cleanup-label (new Label)]
- (match member
- [::&analyser/local 0 ?idx]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitLabel next-label))
-
- [::&analyser/match-text ?text]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
- (.visitLdcInsn ?text)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ cleanup-label)
- (.visitJumpInsn Opcodes/GOTO next-label)
- (.visitLabel cleanup-label)
- (-> (doto (.visitInsn Opcodes/POP))
- (->> (dotimes [_ cleanup-level])))
- (.visitJumpInsn Opcodes/GOTO default-label)
- (.visitLabel next-label))
-
- [::&analyser/subcase ?subtag ?submembers]
- (let [tuple-class* (str "test2/Tuple" (count ?submembers))]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD tuple-class (str "_" ?tfield) (->type-signature "java.lang.Object"))
- (.visitTypeInsn Opcodes/CHECKCAST variant-class*)
- (.visitInsn Opcodes/DUP)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "tag" (->type-signature "java.lang.String"))
- (.visitLdcInsn ?subtag)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL oclass "equals" equals-sig)
- (.visitJumpInsn Opcodes/IFEQ cleanup-label)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class*)
- (do (dorun (map (mk-sub-fold (inc cleanup-level) default-label tuple-class*)
- (range (count ?submembers))
- ?submembers)))
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO next-label)
- (.visitLabel cleanup-label)
- (-> (doto (.visitInsn Opcodes/POP))
- (->> (dotimes [_ (inc cleanup-level)])))
- (.visitJumpInsn Opcodes/GOTO default-label)
- (.visitLabel next-label)
- ))))))]
- (doto *writer*
- (.visitVarInsn Opcodes/ALOAD ?base-idx)
- (.visitFieldInsn Opcodes/GETFIELD variant-class* "value" (->type-signature "java.lang.Object"))
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class))
- (dorun (map (mk-sub-fold 1 else-label tuple-class)
- (range (count ?members))
- ?members))
- (.visitInsn *writer* Opcodes/POP)))
- (compile-form (assoc *state* :form ?body)))
- (.visitJumpInsn Opcodes/GOTO end-label)
- (.visitLabel else-label))))
- ;; Default branch
- (let [ex-class (->class "java.lang.IllegalStateException")]
- (doto *writer*
- (.visitLabel default-label)
- (.visitInsn Opcodes/ACONST_NULL)
- (.visitTypeInsn Opcodes/NEW ex-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
- (.visitInsn Opcodes/ATHROW)))
- (.visitLabel *writer* end-label)))
- )))
+ [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree]
+ (do ;; (prn 'compile-case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree)
+ ;; (assert false)
+ (let [start-label (new Label)
+ end-label (new Label)
+ ;; default-label (new Label)
+ entries (for [[?branch ?body] ?branch-mappings
+ :let [label (new Label)]]
+ [[?branch label]
+ [label ?body]])
+ mappings* (into {} (map first entries))]
+ (dotimes [idx ?max-registers]
+ (.visitLocalVariable *writer* (str "__" idx "__") (->java-sig ::&type/any) nil start-label end-label (+ ?base-idx (inc idx))))
+ (compile-form (assoc *state* :form ?variant))
+ (.visitLabel *writer* start-label)
+ (let [default-label (new Label)
+ default-code (:default ?decision-tree)]
+ (compile-decision-tree *writer* mappings* 0 nil default-label
+ (-> (sequence-parts (:branches ?decision-tree) (list ?decision-tree))
+ first first))
+ (.visitLabel *writer* default-label)
+ (if default-code
+ (do (prn 'default-code default-code)
+ (assert false)
+ ;; (.visitInsn Opcodes/POP) ;; ...
+ (compile-form (assoc *state* :form default-code))
+ (.visitJumpInsn *writer* Opcodes/GOTO end-label))
+ (doto *writer*
+ ;; (.visitInsn Opcodes/POP)
+ (.visitTypeInsn Opcodes/NEW ex-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ (.visitInsn Opcodes/ATHROW))))
+ ;; (compile-decision-tree *state* *writer* mappings* 1 nil (:branches ?decision-tree) ?decision-tree)
+ (doseq [[?label ?body] (map second entries)]
+ (.visitLabel *writer* ?label)
+ (compile-form (assoc *state* :form ?body))
+ (.visitJumpInsn *writer* Opcodes/GOTO end-label))
+ (.visitLabel *writer* end-label)
+ ))
+ ))
(defcompiler ^:private compile-let
[::&analyser/let ?idx ?label ?value ?body]