aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--source/lux.lux17
-rw-r--r--src/lux.clj94
-rw-r--r--src/lux/analyser.clj595
-rw-r--r--src/lux/compiler.clj683
-rw-r--r--src/lux/compiler/case.clj568
-rw-r--r--src/lux/compiler/host.clj194
-rw-r--r--src/lux/compiler/lambda.clj176
-rw-r--r--src/lux/host.clj3
-rw-r--r--src/lux/macro.clj (renamed from src/lux/macros.clj)26
-rw-r--r--src/lux/type.clj49
10 files changed, 1195 insertions, 1210 deletions
diff --git a/source/lux.lux b/source/lux.lux
index 3e29a50c9..f11e8031b 100644
--- a/source/lux.lux
+++ b/source/lux.lux
@@ -67,6 +67,16 @@
[java.lang.Object _7] [java.lang.Object _8]])
## Base functions & macros
+(def' let'
+ (lambda' _ tokens
+ (lambda' _ state
+ (case' tokens
+ (#Cons lhs (#Cons rhs (#Cons body #Nil)))
+ [(#Cons (#Form (#Cons (#Ident "case'") (#Cons rhs (#Cons lhs (#Cons body #Nil)))))
+ #Nil)
+ state])
+ )))
+
(def' lambda
(lambda' _ tokens
(lambda' _ state
@@ -84,7 +94,8 @@
(#Cons (#Form (#Cons (#Ident "_") args'))
(#Cons body #Nil)))))
#Nil))))))
- [(#Cons output #Nil) state]))))
+ [(#Cons output #Nil) state])
+ )))
(declare-macro lambda)
(def' def
@@ -106,6 +117,10 @@
[(#Cons output #Nil) state])))
(declare-macro def)
+(def (comment tokens state)
+ [#Nil state])
+(declare-macro comment)
+
(def (+ x y)
(jvm;iadd x y))
diff --git a/src/lux.clj b/src/lux.clj
index 3e0b3e9c0..3c29968de 100644
--- a/src/lux.clj
+++ b/src/lux.clj
@@ -10,9 +10,6 @@
;; TODO: Make macros monadic.
;; TODO: Finish type system.
;; TODO: Re-implement compiler in language.
- ;; TODO: Add signatures & structures OR type-classes.
- ;; TODO: Add type-level computations.
- ;; TODO: Add thunks.
;; TODO: Do tail-call optimization.
;; TODO: Adding metadata to global vars.
;; TODO: Add records.
@@ -20,8 +17,7 @@
;; TODO: Add extra arities (apply2, apply3, ..., apply16)
;; TODO: Allow setting fields.
;; TODO: monitor enter & monitor exit.
- ;; TODO: Reinplement "if" as a macro on top of case.
- ;; TODO: Remember to optimized calling global functions.
+ ;; TODO: Remember to optimize calling global functions.
;; TODO: Reader macros.
;; TODO:
;; TODO:
@@ -31,94 +27,6 @@
(time (&compiler/compile-all ["lux" ;; "test2"
]))
-
-
- (deftype (Session c p s)
- (-> (-> p s c) c))
-
- ;; (: bind (All [m a b]
- ;; (-> (-> a (m b)) (m a) (m b))))
-
- (do (defn >> [v]
- (fn [session]
- (session v)))
-
- (defn >> [v]
- (client v (fn [_ client*]
- (k _ client*))))
-
- (def <<
- (server nil (fn [v server*]
- (k v server*))))
-
- (defn pipe [])
-
- (<< (fn [x server*]
- (server* nil (fn [y server**]
- (server** (+ x y) k)))))
-
- (def (select' k)
- (lambda [msg session]
- (session nil (k msg))))
-
- (def (choose choice)
- (lambda [msg session]
- (session choice ...)))
-
- (def <<
- (lambda [next peer]
- (peer [] (lambda [x peer']
- (next x peer')))))
-
- (def (>> x)
- (lambda [next peer]
- (peer x (lambda [_ peer']
- (next [] peer')))))
-
- (def server
- (loop [_ []]
- (select #Add
- (do [x <<
- y <<
- _ (>> (+ x y))]
- (recur []))
-
- #Neg
- (do [x <<
- _ (>> (neg x))]
- (recur []))
-
- #Quit
- end)))
-
- (def client
- (do [_ (choose #Add)
- _ (>> 5)
- _ (>> 10)
- x+y <<]
- (choose #Quit)))
-
- (def <END>
- (fn [session]
- nil))
-
- (bind << (fn [x]
- (bind << (fn [y]
- (>> (+ x y))))))
-
- (do [x <<
- y <<]
- (>> (+ x y)))
-
- (defn <$> [consumer producer init]
- (let [[x producer*] (producer init)
- [y consumer*] (consumer x)]
- [consumer* producer* y]))
-
- ((<$> (<< <END>) ((>> 5) <END>)))
- )
-
-
;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
;; cd output && jar cvf test2.jar * && java -cp "test2.jar" test2 && cd ..
)
diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj
index 3183c7166..de75b9f26 100644
--- a/src/lux/analyser.clj
+++ b/src/lux/analyser.clj
@@ -6,7 +6,7 @@
normalize-ident]]
[parser :as &parser]
[type :as &type]
- [macros :as &macros]
+ [macro :as &macro]
[host :as &host])))
;; [Util]
@@ -71,7 +71,7 @@
_
=return))))
-(defn ^:private with-let [name mode type body]
+(defn ^:private with-local [name mode type body]
(fn [state]
(let [old-mappings (-> state ::&util/local-envs first (get-in [:locals :mappings]))
=return (body (update-in state [::&util/local-envs]
@@ -95,9 +95,9 @@
_
=return))))
-(defn ^:private with-lets [locals monad]
+(defn ^:private with-locals [locals monad]
(reduce (fn [inner [label elem]]
- (with-let label :local elem inner))
+ (with-local label :local elem inner))
monad
(reverse locals)))
@@ -106,22 +106,29 @@
[::&util/ok [state (-> state ::&util/local-envs first :closure :mappings)]]))
(defn ^:private analyse-1 [elem]
- (exec [output (analyse-ast elem)
- _ (&util/assert! (= 1 (count output)) "[Analyser Error] Can't expand to other than 1 element.")]
- (return (first output))))
+ (exec [output (analyse-ast elem)]
+ (match output
+ ([x] :seq)
+ (return x)
+
+ :else
+ (fail "[Analyser Error] Can't expand to other than 1 element."))))
(defn ^:private analyse-2 [el1 el2]
- (exec [output (mapcat-m analyse-ast (list el1 el2))
- _ (&util/assert! (= 2 (count output))
- "[Analyser Error] Can't expand to other than 2 elements.")]
- (return [(first output) (second output)])))
+ (exec [output (mapcat-m analyse-ast (list el1 el2))]
+ (match output
+ ([x y] :seq)
+ (return [x y])
+
+ :else
+ (fail "[Analyser Error] Can't expand to other than 2 elements."))))
(defn ^:private with-lambda [self self-type arg arg-type body]
(fn [state]
(let [body* (with-env (-> state ::&util/local-envs first :inner-closures str)
(exec [$scope &util/get-scope]
- (with-let self :self self-type
- (with-let arg :local arg-type
+ (with-local self :self self-type
+ (with-local arg :local arg-type
(exec [=return body
=captured captured-vars]
(return [$scope =next =captured =return]))))))]
@@ -133,9 +140,9 @@
(match register
[::Expression _ register-type]
(let [register* [::Expression [::captured scope (get-in frame [:closure :counter]) register] register-type]]
- [register* (-> frame
- (update-in [:closure :counter] inc)
- (assoc-in [:closure :mappings ident] register*))])))
+ [register* (update-in frame [:closure] #(-> %
+ (update-in [:counter] inc)
+ (assoc-in [:mappings ident] register*)))])))
(defn ^:private extract-ident [ident]
(match ident
@@ -162,8 +169,8 @@
(-> % :closure :mappings (contains? ident) not))
[inner outer] (split-with no-binding? stack*)]
(if (empty? outer)
- (if-let [global|import (get-in state [::&util/global-env ident])]
- [::&util/ok [state (list global|import)]]
+ (if-let [global (get-in state [::&util/global-env ident])]
+ [::&util/ok [state (list global)]]
[::&util/failure (str "[Analyser Error] Unresolved identifier: " ident)])
(let [[=local inner*] (reduce (fn [[register new-inner] frame]
(let [[register* frame*] (close-over (:name frame) ident register frame)]
@@ -186,18 +193,8 @@
[::global ?module ?name]
(exec [macro? (macro? ?module ?name)]
(if macro?
- (let [macro-class (str ?module "$" (normalize-ident ?name))
- output (-> (.loadClass loader macro-class)
- .getDeclaredConstructors
- first
- (.newInstance (to-array [(int 0) nil]))
- (.apply (&macros/->lux+ loader ?args))
- (.apply nil))
- ;; _ (prn 'output (str ?module ":" ?name) output (.-_1 output) (.-tag (.-_1 output)))
- macro-expansion (&macros/->clojure+ (.-_1 output))
- state* (.-_2 output)
- ;; _ (prn 'macro-expansion (str ?module ":" ?name) state* macro-expansion)
- ]
+ (let [macro-class (&host/location (list ?name ?module))
+ [macro-expansion state*] (&macro/expand loader macro-class)]
(mapcat-m analyse-ast macro-expansion))
(exec [=args (mapcat-m analyse-ast ?args)
:let [[needs-num =return-type] (match =fn-type
@@ -223,450 +220,174 @@
=exprs-types (map-m expr-type =exprs)]
(return (list [::Expression [::do =exprs] (last =exprs-types)]))))
-(do-template [<name> <tag>]
- (defn <name> [tests ?token body-id]
- (match (:struct tests)
- [<tag> ?patterns ?defaults]
- {:struct [<tag> (update-in ?patterns [?token] (fn [bodies]
- (if bodies
- (conj bodies body-id)
- #{body-id})))
- ?defaults]
- :branches (conj (:branches tests) body-id)}
-
- [::???Tests]
- {:struct [<tag> {?token #{body-id}} (list)]
- :branches (conj (:branches tests) body-id)}
+(defn ^:private locals [member]
+ (match member
+ [::&parser/Ident ?name]
+ (list ?name)
- :else
- (assert false "Can't do match.")))
+ [::&parser/Tuple ?submembers]
+ (mapcat locals ?submembers)
- ^:private bool-tests ::BoolTests
- ^:private int-tests ::IntTests
- ^:private real-tests ::RealTests
- ^:private char-tests ::CharTests
- ^:private text-tests ::TextTests
- )
+ [::&parser/Form ([[::&parser/Tag _] & ?submembers] :seq)]
+ (mapcat locals ?submembers)
-(defn with-default [struct ?local $body]
- (match (:struct tests)
- [::BoolTests ?patterns ?defaults]
- {:struct [::BoolTests ?patterns (conj ?defaults [::default ?local $body])]
- :branches (conj (:branches tests) body-id)}
+ _
+ (list)))
- [::IntTests ?patterns ?defaults]
- {:struct [::IntTests ?patterns (conj ?defaults [::default ?local $body])]
- :branches (conj (:branches tests) body-id)}
+(defn ^:private analyse-branch [max-registers [bindings body]]
+ (reduce (fn [body* name]
+ (with-local name :local +dont-care-type+ body*))
+ (reduce (fn [body* _]
+ (with-local "#" :local +dont-care-type+ body*))
+ (analyse-1 body)
+ (range (- max-registers (count bindings))))
+ bindings))
- [::RealTests ?patterns ?defaults]
- {:struct [::RealTests ?patterns (conj ?defaults [::default ?local $body])]
- :branches (conj (:branches tests) body-id)}
+(defn ^:private analyse-case [analyse-ast ?variant ?branches]
+ (exec [=variant (analyse-1 ?variant)
+ _ (assert! (and (> (count ?branches) 0) (even? (count ?branches)))
+ "Unbalanced branches in \"case'\" expression.")
+ :let [branches (partition 2 ?branches)
+ locals-per-branch (map locals (map first branches))
+ max-locals (reduce max 0 (map count locals-per-branch))]
+ base-register next-local-idx
+ =bodies (map-m (partial analyse-branch max-locals)
+ (map vector locals-per-branch (map second branches)))
+ =body-types (map-m expr-type =bodies)
+ =case-type (reduce-m &type/merge [::&type/Nothing] =body-types)
+ :let [=branches (map vector (map first branches) =bodies)]]
+ (return (list [::Expression [::case =variant base-register max-locals =branches] =case-type]))))
- [::CharTests ?patterns ?defaults]
- {:struct [::CharTests ?patterns (conj ?defaults [::default ?local $body])]
- :branches (conj (:branches tests) body-id)}
+(defn ^:private raise-expr [arg syntax]
+ (match syntax
+ [::Expression ?form ?type]
+ (match ?form
+ [::bool ?value]
+ syntax
- [::TextTests ?patterns ?defaults]
- {:struct [::TextTests ?patterns (conj ?defaults [::default ?local $body])]
- :branches (conj (:branches tests) body-id)}
- ))
+ [::int ?value]
+ syntax
-(def ^:private product-match [<type> ?tag ?members body-id]
- (condp = (:type struct)
- <type> (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 body-id})
- (update-in [?tag :branches] conj body-id))
- (assert false (str "Arity doesn't match. " (count ?members) "=/=" arity)))
- (assoc branches ?tag {:arity (count ?members)
- :cases [{:case ?members
- :body body-id}]
- :branches #{body-id}}))))
- nil (-> struct
- (assoc :type <type>)
- (assoc-in [:patterns ?tag] {:arity (count ?members)
- :cases [{:case ?members
- :body body-id}]
- :branches #{body-id}}))
- ;; else
- (assert false "Can't do match.")
- ))
+ [::real ?value]
+ syntax
-(def ^:private gen-product-branches [generate-branches <type> branches]
- (do (assert (<= (count (:defaults branches)) 1))
- {:type <type>
- :patterns (into {} (for [[?tag ?struct] (:patterns branches)]
- [?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)}))
-
-(let [fold-branch (fn [struct [pattern $body]]
- (match pattern
- [::BoolPM ?value]
- (bool-tests struct $body)
-
- [::IntPM ?value]
- (int-tests struct $body)
-
- [::RealPM ?value]
- (real-tests struct $body)
-
- [::CharPM ?token]
- (char-tests struct $body)
-
- [::TextPM ?text]
- (text-tests struct $body)
-
- [::TuplePM ?members]
- (product-match struct ::tuple-tests nil ?members $body)
-
- [::VariantPM ?tag ?members]
- (product-match struct ::variant-tests ?tag ?members $body)
-
- [::LocalPM ?local]
- (with-default struct ?local $body)
- ))
- base-struct [::???Tests]
- generate-branches (fn generate-branches [data]
- (let [branches* (reduce fold-branch base-struct data)]
- (match branches*
- [::BoolTests _] branches*
- [::IntTests _] branches*
- [::RealTests _] branches*
- [::CharTests _] branches*
- [::TextTests _] branches*
- ::TupleTests (gen-product-branches generate-branches ::tuple-tests branches*)
- ::VariantTests (gen-product-branches generate-branches ::variant-tests 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]
- (match pattern
- [::&parser/Bool ?value]
- (list)
-
- [::&parser/Int ?value]
- (list)
-
- [::&parser/Real ?value]
- (list)
-
- [::&parser/Char ?token]
- (list)
-
- [::&parser/Text ?text]
- (list)
-
- [::&parser/Tag _]
- (list)
-
- [::&parser/Ident ?name]
- (list ?name)
-
- [::&parser/Tuple ?members]
- (mapcat get-vars ?members)
-
- [::&parser/Form ([[::&parser/Tag _] & ?members] :seq)]
- (mapcat get-vars ?members)
- ))
- ->instructions (fn ->instructions [locals pattern]
- (clojure.core.match/match pattern
- [::&parser/Bool ?value]
- [::BoolPM ?value]
-
- [::&parser/Int ?value]
- [::IntPM ?value]
-
- [::&parser/Real ?value]
- [::RealPM ?value]
-
- [::&parser/Char ?value]
- [::CharPM ?value]
-
- [::&parser/Text ?value]
- [::TextPM ?value]
-
- [::&parser/Tag ?tag]
- [::VariantPM ?tag (list)]
-
- [::&parser/Ident ?name]
- [::LocalPM (get locals ?name)]
-
- [::&parser/Tuple ?members]
- [::TuplePM (map (partial ->instructions locals) ?members)]
-
- [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)]
- [::VariantPM ?tag (map (partial ->instructions locals) ?members)]
- ))]
- (defn ^:private ->decision-tree [$base branches]
- (let [vars (for [branch branches]
- (clojure.core.match/match branch
- [::case-branch ?pattern ?body]
- (get-vars ?pattern)))
- [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch]
- (clojure.core.match/match branch
- [::case-branch ?pattern ?body]
- [(inc $link) (assoc links $link ?body) (conj branches* [::case-branch ?pattern $link])]))
- [0 {} []]
- branches)
- branches** (for [[branch branch-vars] (map vector branches* vars)
- :let [[_ locals] (reduce (fn [[$local =locals] $var]
- [(inc $local) (assoc =locals $var [::local $local])])
- [$base {}] branch-vars)]]
- (clojure.core.match/match branch
- [::case-branch ?pattern ?body]
- [(->instructions locals ?pattern) ?body]))
- max-registers (reduce max 0 (map count vars))]
- [max-registers branch-mappings (generate-branches branches**)])))
-
-(defn ^:private locals-getter [?member]
- (match ?member
- [::&parser/Ident ?name]
- (list [?name +dont-care-type+])
+ [::char ?value]
+ syntax
- [::&parser/Tuple ?submembers]
- (mapcat locals-getter ?submembers)
+ [::text ?value]
+ syntax
+
+ [::tuple ?members]
+ [::Expression [::tuple (map (partial raise-expr arg) ?members)] ?type]
- [::&parser/Form ([[::&parser/Tag ?subtag] & ?submembers] :seq)]
- (mapcat locals-getter ?submembers)
+ [::variant ?tag ?members]
+ [::Expression [::variant ?tag (map (partial raise-expr arg) ?members)] ?type]
+
+ [::local ?idx]
+ [::Expression [::local (inc ?idx)] ?type]
+
+ [::captured _ _ ?source]
+ ?source
- _
- (list)
- ))
+ [::self ?curried]
+ [::Expression [::self (cons arg (map (partial raise-expr arg) ?curried))] ?type]
-(defn ^:private analyse-case-branches [branches]
- (map-m (fn [[?pattern ?body]]
- (match ?pattern
- [::&parser/Bool ?token]
- (exec [=body (analyse-1 ?body)]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Int ?token]
- (exec [=body (analyse-1 ?body)]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Real ?token]
- (exec [=body (analyse-1 ?body)]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Char ?token]
- (exec [=body (analyse-1 ?body)]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Text ?token]
- (exec [=body (analyse-1 ?body)]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Ident ?name]
- (exec [=body (with-let ?name :local +dont-care-type+
- (analyse-1 ?body))]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Tag ?tag]
- (exec [=body (analyse-1 ?body)]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Tuple ?members]
- (exec [=body (with-lets (mapcat locals-getter ?members)
- (analyse-1 ?body))]
- (return [::case-branch ?pattern =body]))
-
- [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)]
- (exec [=body (with-lets (mapcat locals-getter ?members)
- (analyse-1 ?body))]
- (return [::case-branch ?pattern =body]))
- ))
- branches))
+ [::global _ _]
+ syntax
-(defn ^:private analyse-case [analyse-ast ?variant ?branches]
- (exec [=variant (analyse-1 ?variant)
- _ (assert! (and (> (count ?branches) 0) (even? (count ?branches)))
- "Imbalanced branches in \"case'\" expression.")
- $base next-local-idx
- [num-registers mappings tree] (exec [=branches (analyse-case-branches (partition 2 ?branches))]
- (return (->decision-tree $base =branches)))]
- (return (list [::Expression [::case $base =variant num-registers mappings tree] +dont-care-type+]))))
-
-(defn ^:private raise-tree-bindings [raise-expr arg ?tree]
- (let [tree-partial-f (partial raise-tree-bindings raise-expr arg)]
- (case (:type ?tree)
- (::tuple ::variant)
- (-> ?tree
- (update-in [:patterns]
- #(into {} (for [[?tag ?unapply] %]
- [?tag (update-in ?unapply [:parts] (partial map tree-partial-f))])))
- (update-in [:default]
- (fn [[tag local $branch :as total]]
- (if total
- (match (raise-expr arg [::Expression local [::&type/Nothing]])
- [::Expression local* [::&type/Nothing]]
- [tag local* $branch])))))
-
- ::defaults
- (update-in ?tree [:stores]
- #(into {} (for [[?store ?branches] %]
- (match (raise-expr arg [::Expression ?store [::&type/Nothing]])
- [::Expression =store [::&type/Nothing]]
- [=store ?branches]))))
- ;; else
- (assert false (pr-str ?tree))
- )))
+ [::case ?variant ?base ?num-bindings ?pm-struct]
+ ...
-(defn ^:private raise-expr [arg syntax]
- ;; (prn 'raise-bindings body)
- (let [partial-f (partial raise-expr arg)
- tree-partial-f (partial raise-tree-bindings raise-expr arg)]
- (match syntax
- [::Expression ?form ?type]
- (match ?form
- [::bool ?value]
- syntax
-
- [::int ?value]
- syntax
-
- [::real ?value]
- syntax
-
- [::char ?value]
- syntax
-
- [::text ?value]
- syntax
-
- [::tuple ?members]
- [::Expression [::tuple (map partial-f ?members)] ?type]
+ [::lambda ?scope ?captured ?args ?value]
+ [::Expression [::lambda (pop ?scope)
+ (into {} (for [[?name ?sub-syntax] ?captured]
+ [?name (raise-expr arg ?sub-syntax)]))
+ ?args
+ ?value]
+ ?type]
- [::variant ?tag ?members]
- [::Expression [::variant ?tag (map partial-f ?members)] ?type]
-
- [::local ?idx]
- [::Expression [::local (inc ?idx)] ?type]
-
- [::captured _ _ ?source]
- ?source
-
- [::self ?curried]
- [::Expression [::self (cons arg (map partial-f ?curried))] ?type]
-
- [::global _ _]
- syntax
-
- [::let ?idx ?value ?body]
- [::Expression [::let (inc ?idx) (partial-f ?value)
- (partial-f ?body)]
- ?type]
-
- [::case ?base ?variant ?registers ?mappings ?tree]
- (let [=variant (partial-f ?variant)
- =mappings (into {} (for [[idx syntax] ?mappings]
- [idx (partial-f syntax)]))
- =tree (tree-partial-f ?tree)]
- [::Expression [::case (inc ?base) =variant ?registers =mappings =tree] ?type])
-
- [::lambda ?scope ?captured ?args ?value]
- [::Expression [::lambda (pop ?scope)
- (into {} (for [[?name ?sub-syntax] ?captured]
- [?name (partial-f ?sub-syntax)]))
- ?args
- ?value]
- ?type]
-
- [::call ?func ?args]
- [::Expression [::call (partial-f ?func) (map partial-f ?args)] ?type]
-
- [::do ?asts]
- [::Expression [::do (map partial-f ?asts)] ?type]
-
- [::jvm-getstatic _ _]
- syntax
-
- [::jvm-invokevirtual ?class ?method ?arg-classes ?obj ?args]
- [::Expression [::jvm-invokevirtual ?class ?method ?arg-classes
- (partial-f ?obj)
- (map partial-f ?args)]
- ?type]
+ [::call ?func ?args]
+ [::Expression [::call (raise-expr arg ?func) (map (partial raise-expr arg) ?args)] ?type]
- ;; Integer arithmetic
- [::jvm-iadd ?x ?y]
- [::Expression [::jvm-iadd (partial-f ?x) (partial-f ?y)] ?type]
+ [::do ?asts]
+ [::Expression [::do (map (partial raise-expr arg) ?asts)] ?type]
- [::jvm-isub ?x ?y]
- [::Expression [::jvm-isub (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-getstatic _ _]
+ syntax
+
+ [::jvm-invokevirtual ?class ?method ?arg-classes ?obj ?args]
+ [::Expression [::jvm-invokevirtual ?class ?method ?arg-classes
+ (raise-expr arg ?obj)
+ (map (partial raise-expr arg) ?args)]
+ ?type]
- [::jvm-imul ?x ?y]
- [::Expression [::jvm-imul (partial-f ?x) (partial-f ?y)] ?type]
+ ;; Integer arithmetic
+ [::jvm-iadd ?x ?y]
+ [::Expression [::jvm-iadd (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-idiv ?x ?y]
- [::Expression [::jvm-idiv (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-isub ?x ?y]
+ [::Expression [::jvm-isub (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-irem ?x ?y]
- [::Expression [::jvm-irem (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-imul ?x ?y]
+ [::Expression [::jvm-imul (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- ;; Long arithmetic
- [::jvm-ladd ?x ?y]
- [::Expression [::jvm-ladd (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-idiv ?x ?y]
+ [::Expression [::jvm-idiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-lsub ?x ?y]
- [::Expression [::jvm-lsub (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-irem ?x ?y]
+ [::Expression [::jvm-irem (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-lmul ?x ?y]
- [::Expression [::jvm-lmul (partial-f ?x) (partial-f ?y)] ?type]
+ ;; Long arithmetic
+ [::jvm-ladd ?x ?y]
+ [::Expression [::jvm-ladd (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-ldiv ?x ?y]
- [::Expression [::jvm-ldiv (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-lsub ?x ?y]
+ [::Expression [::jvm-lsub (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-lrem ?x ?y]
- [::Expression [::jvm-lrem (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-lmul ?x ?y]
+ [::Expression [::jvm-lmul (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- ;; Float arithmetic
- [::jvm-fadd ?x ?y]
- [::Expression [::jvm-fadd (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-ldiv ?x ?y]
+ [::Expression [::jvm-ldiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-fsub ?x ?y]
- [::Expression [::jvm-fsub (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-lrem ?x ?y]
+ [::Expression [::jvm-lrem (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-fmul ?x ?y]
- [::Expression [::jvm-fmul (partial-f ?x) (partial-f ?y)] ?type]
+ ;; Float arithmetic
+ [::jvm-fadd ?x ?y]
+ [::Expression [::jvm-fadd (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-fdiv ?x ?y]
- [::Expression [::jvm-fdiv (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-fsub ?x ?y]
+ [::Expression [::jvm-fsub (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-frem ?x ?y]
- [::Expression [::jvm-frem (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-fmul ?x ?y]
+ [::Expression [::jvm-fmul (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- ;; Double arithmetic
- [::jvm-dadd ?x ?y]
- [::Expression [::jvm-dadd (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-fdiv ?x ?y]
+ [::Expression [::jvm-fdiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-dsub ?x ?y]
- [::Expression [::jvm-dsub (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-frem ?x ?y]
+ [::Expression [::jvm-frem (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-dmul ?x ?y]
- [::Expression [::jvm-dmul (partial-f ?x) (partial-f ?y)] ?type]
+ ;; Double arithmetic
+ [::jvm-dadd ?x ?y]
+ [::Expression [::jvm-dadd (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-ddiv ?x ?y]
- [::Expression [::jvm-ddiv (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-dsub ?x ?y]
+ [::Expression [::jvm-dsub (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- [::jvm-drem ?x ?y]
- [::Expression [::jvm-drem (partial-f ?x) (partial-f ?y)] ?type]
+ [::jvm-dmul ?x ?y]
+ [::Expression [::jvm-dmul (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
- _
- (assert false syntax)
- ))))
+ [::jvm-ddiv ?x ?y]
+ [::Expression [::jvm-ddiv (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
+
+ [::jvm-drem ?x ?y]
+ [::Expression [::jvm-drem (raise-expr arg ?x) (raise-expr arg ?y)] ?type]
+
+ _
+ (assert false syntax)
+ )))
(defn ^:private analyse-lambda [analyse-ast ?self ?arg ?body]
(exec [[_ =arg =return :as =function] &type/fresh-function
diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj
index 1ff3a503e..742455b86 100644
--- a/src/lux/compiler.clj
+++ b/src/lux/compiler.clj
@@ -11,7 +11,8 @@
[type :as &type]
[lexer :as &lexer]
[parser :as &parser]
- [analyser :as &analyser])
+ [analyser :as &analyser]
+ [host :as &host])
:reload)
(:import (org.objectweb.asm Opcodes
Label
@@ -19,9 +20,6 @@
MethodVisitor)))
;; [Utils/General]
-(defn ^:private storage-id [scope]
- (->> scope reverse (map normalize-ident) (interpose "$") (reduce str "")))
-
(defn ^:private write-file [file data]
(with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
(.write stream data)))
@@ -45,6 +43,7 @@
(def ^:private +local-prefix+ "l")
(def ^:private +partial-prefix+ "p")
(def ^:private +closure-prefix+ "c")
+(def ^:private +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;")
(def ^:private ->package ->class)
@@ -163,11 +162,9 @@
(defn ^:private compile-global [compile *type* ?owner-class ?name]
(exec [*writer* &util/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (storage-id (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class (&host/location (list ?name ?owner-class))) "_datum" "Ljava/lang/Object;")]]
(return nil)))
-(def +apply-signature+ "(Ljava/lang/Object;)Ljava/lang/Object;")
-
(defn ^:private compile-call [compile *type* ?fn ?args]
(exec [*writer* &util/get-writer
_ (compile ?fn)
@@ -184,7 +181,7 @@
:let [_ (match (:form ?fn)
[::&analyser/global ?owner-class ?fn-name]
(let [arg-sig (->type-signature "java.lang.Object")
- call-class (storage-id (list ?fn-name ?owner-class))
+ call-class (&host/location (list ?fn-name ?owner-class))
provides-num (count ?args)]
(if (>= provides-num ?needs-num)
(let [impl-sig (str "(" (reduce str "" (repeat ?needs-num arg-sig)) ")" arg-sig)]
@@ -209,122 +206,6 @@
)]]
(return nil)))
-(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field]
- (exec [*writer* &util/get-writer
- :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]]
- (return nil)))
-
-(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object]
- (exec [*writer* &util/get-writer
- _ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
- :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (->class ?class) ?field (->java-sig *type*))]]
- (return nil)))
-
-(let [class+metthod+sig {"boolean" [(->class "java.lang.Boolean") "booleanValue" "()Z"]
- "byte" [(->class "java.lang.Byte") "byteValue" "()B"]
- "short" [(->class "java.lang.Short") "shortValue" "()S"]
- "int" [(->class "java.lang.Integer") "intValue" "()I"]
- "long" [(->class "java.lang.Long") "longValue" "()J"]
- "float" [(->class "java.lang.Float") "floatValue" "()F"]
- "double" [(->class "java.lang.Double") "doubleValue" "()D"]
- "char" [(->class "java.lang.Character") "charValue" "()C"]}]
- (defn ^:private prepare-arg! [*writer* class-name]
- (if-let [[class method sig] (get class+metthod+sig class-name)]
- (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST class)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig))
- (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name)))))
-
-;; (let [boolean-class "java.lang.Boolean"
-;; integer-class "java.lang.Integer"
-;; char-class "java.lang.Character"]
-;; (defn prepare-return! [*writer* *type*]
-;; (match *type*
-;; ::&type/nothing
-;; (.visitInsn *writer* Opcodes/ACONST_NULL)
-
-;; [::&type/primitive "char"]
-;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class)))
-
-;; [::&type/primitive "int"]
-;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class)))
-
-;; [::&type/primitive "boolean"]
-;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class)))
-
-;; [::&type/Data ?oclass]
-;; nil)))
-
-(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
- (exec [*writer* &util/get-writer
- :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
- _ (map-m (fn [[class-name arg]]
- (exec [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (map vector ?classes ?args))
- :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class ?class) ?method method-sig)
- ;; (prepare-return! *writer* *type*)
- )]]
- (return nil)))
-
-(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args]
- (exec [*writer* &util/get-writer
- :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
- _ (compile ?object)
- :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
- _ (map-m (fn [[class-name arg]]
- (exec [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (map vector ?classes ?args))
- :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig)
- ;; (prepare-return! *writer* *type*)
- )]]
- (return nil)))
-
-(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args]
- (exec [*writer* &util/get-writer
- :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
- class* (->class ?class)
- _ (doto *writer*
- (.visitTypeInsn Opcodes/NEW class*)
- (.visitInsn Opcodes/DUP))]
- _ (map-m (fn [[class-name arg]]
- (exec [ret (compile arg)
- :let [_ (prepare-arg! *writer* class-name)]]
- (return ret)))
- (map vector ?classes ?args))
- :let [_ (doto *writer*
- (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
- (return nil)))
-
-(defn ^:private compile-jvm-new-array [compile *type* ?class ?length]
- (exec [*writer* &util/get-writer
- :let [_ (doto *writer*
- (.visitLdcInsn (int ?length))
- (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]]
- (return nil)))
-
-(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem]
- (exec [*writer* &util/get-writer
- _ (compile ?array)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn (int ?idx)))]
- _ (compile ?elem)
- :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
- (return nil)))
-
-(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx]
- (exec [*writer* &util/get-writer
- _ (compile ?array)
- :let [_ (doto *writer*
- (.visitLdcInsn (int ?idx))
- (.visitInsn Opcodes/AALOAD))]]
- (return nil)))
-
(defn ^:private compile-do [compile *type* ?exprs]
(exec [*writer* &util/get-writer
_ (map-m (fn [expr]
@@ -335,450 +216,12 @@
_ (compile (last ?exprs))]
(return nil)))
-(do-template [<name> <wrapper-class> <value-method> <method-sig>]
- (defn <name> [writer mappings default-label ?pairs]
- (doseq [[?token $body] ?pairs
- :let [$else (new Label)]]
- (doto writer
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
- (.visitLdcInsn ?token)
- (.visitJumpInsn Opcodes/IF_ICMPNE $else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel $else)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO default-label)))
-
- ^:private compile-compare-bools "java.lang.Boolean" "booleanValue" "()Z"
- ^:private compile-compare-chars "java.lang.Character" "charValue" "()C"
- )
-
-(do-template [<name> <wrapper-class> <value-method> <method-sig> <cmp-op>]
- (defn <name> [writer mappings default-label ?pairs]
- (doseq [[?token $body] ?pairs
- :let [$else (new Label)]]
- (doto writer
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
- (.visitLdcInsn ?token)
- (.visitInsn <cmp-op>)
- (.visitJumpInsn Opcodes/IFNE $else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel $else)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO default-label)))
-
- ^:private compile-compare-ints "java.lang.Long" "longValue" "()J" Opcodes/LCMP
- ^:private compile-compare-reals "java.lang.Double" "doubleValue" "()D" Opcodes/DCMPL
- )
-
-(defn ^:private compile-compare-texts [writer mappings default-label ?pairs]
- (doseq [[?token $body] ?pairs
- :let [$else (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP)
- (.visitLdcInsn ?token)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Object") "equals" (str "(" (->type-signature "java.lang.Object") ")Z"))
- (.visitJumpInsn Opcodes/IFEQ $else)
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel $else)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO default-label)))
-
-(let [+tag-sig+ (->type-signature "java.lang.String")
- variant-class* (->class +variant-class+)
- tuple-class* (->class +tuple-class+)
- +variant-field-sig+ (->type-signature "java.lang.Object")
- oclass (->class "java.lang.Object")
- equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
- (defn ^:private compile-decision-tree [writer mappings default-label decision-tree]
- (match decision-tree
- [::test-bool ?pairs]
- (compile-compare-bools writer mappings default-label ?pairs)
-
- [::test-int ?pairs]
- (compile-compare-ints writer mappings default-label ?pairs)
-
- [::test-real ?pairs]
- (compile-compare-reals writer mappings default-label ?pairs)
-
- [::test-char ?pairs]
- (compile-compare-chars writer mappings default-label ?pairs)
-
- [::test-text ?pairs]
- (compile-compare-texts writer mappings default-label ?pairs)
-
- [::store [::&analyser/local ?idx] $body]
- (doto writer
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body)))
-
- [::test-tuple ?branches ?cases]
- (let [[_ ?subcases] (first ?cases)
- arity (-> ?subcases first (nth 2) count)
- tuple-class** (str tuple-class* arity)]
- (doto writer
- ;; object
- (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple
- (do (doseq [subcase ?subcases
- :let [next-subcase (new Label)]]
- (match subcase
- [::subcase $body ?subseq]
- (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
- :let [sub-next-elem (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP) ;; tuple, tuple
- (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; tuple, object
- (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple
- (.visitLabel sub-next-elem)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel next-subcase)))
- )))
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)))
-
- [::test-variant ?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)
- variant-class** (str variant-class* arity)]
- (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN
- (doseq [subcase ?subcases
- :let [next-subcase (new Label)]]
- (match subcase
- [::subcase $body ?subseq]
- (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
- :let [sub-next-elem (new Label)]]
- (doto writer
- (.visitInsn Opcodes/DUP) ;; variant, variant
- (.visitFieldInsn Opcodes/GETFIELD variant-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; variant, object
- (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant
- (.visitLabel sub-next-elem)))
- (doto writer
- (.visitInsn Opcodes/POP)
- (.visitJumpInsn Opcodes/GOTO (get mappings $body))
- (.visitLabel next-subcase)))
- ))
- ))
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)
- ;; variant, tag ->
- (.visitLabel tag-else-label))
- (->> (doseq [[?tag ?subcases] ?cases
- :let [tag-else-label (new Label)]])))
- ;; variant, tag ->
- (.visitInsn Opcodes/POP) ;; variant ->
- (.visitInsn Opcodes/POP) ;; ->
- (.visitJumpInsn Opcodes/GOTO default-label)))
- ))
-
-(defn ^:private sequence-val [<test-tag> struct branches]
- (concat (list [[<test-tag> (for [[?token ?supports] (:patterns struct)
- ?body (set/intersection branches ?supports)]
- [?token ?body])]
- branches])
- (for [[_ ?local ?body] (:defaults struct)
- :when (contains? branches ?body)]
- [[::store ?local ?body] #{?body}])))
-
-(defn ^:private sequence-product [<test-tag> struct branches]
- (concat (let [patterns (into {} (for [[?tag ?struct] (:patterns struct)
- :let [?parts (:parts ?struct)
- num-parts (count ?parts)
- ?supports (:branches ?struct)
- subcases (for [?body (set/intersection branches ?supports)
- subseq (sequence-parts #{?body} ?parts)
- :when (= num-parts (count subseq))]
- [::subcase ?body subseq])]
- :when (not (empty? subcases))]
- [?tag subcases]))]
- (if (empty? patterns)
- '()
- (list [[<test-tag> branches patterns]
- branches])))
- (if-let [[_ ?local ?body] (:default struct)]
- (for [?body (set/intersection branches #{?body})]
- [[::store ?local ?body] #{?body}])
- '())))
-
-(defn ^:private sequence-parts [branches parts]
- (if (empty? parts)
- (list (list))
- (let [[head & tail] parts
- expanded (case (:type head)
- ::&analyser/defaults
- (for [[?local ?supports] (:stores head)
- ?body (set/intersection branches ?supports)]
- [[::store ?local ?body] #{?body}])
-
- ::&analyser/bool-tests
- (sequence-val ::test-bool head branches)
-
- ::&analyser/int-tests
- (sequence-val ::test-int head branches)
-
- ::&analyser/real-tests
- (sequence-val ::test-real head branches)
-
- ::&analyser/char-tests
- (sequence-val ::test-char head branches)
-
- ::&analyser/text-tests
- (sequence-val ::test-text head branches)
-
- ::&analyser/tuple
- (sequence-product ::test-tuple head branches)
-
- ::&analyser/variant
- (sequence-product ::test-variant head branches)
- )]
- (for [[step branches*] expanded
- tail* (sequence-parts branches* 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")]
- (defn ^:private compile-case [compile *type* ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree]
- (exec [*writer* &util/get-writer
- :let [start-label (new Label)
- end-label (new Label)
- entries (for [[?branch ?body] ?branch-mappings
- :let [label (new Label)]]
- [[?branch label]
- [label ?body]])
- mappings* (into {} (map first entries))
- _ (dotimes [offset ?max-registers]
- (let [idx (+ ?base-idx offset)]
- (.visitLocalVariable *writer* (str +local-prefix+ idx) (->java-sig [::&type/Any]) nil start-label end-label idx)))]
- _ (compile ?variant)
- :let [_ (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitLabel start-label))
- default-label (new Label)
- ;; _ (prn '?decision-tree ?decision-tree)
- _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts (:branches ?decision-tree) (list ?decision-tree)))]
- (if (or (:default ?decision-tree)
- (not (empty? (:defaults ?decision-tree))))
- (butlast pieces)
- pieces))]
- (compile-decision-tree *writer* mappings* default-label decision-tree))
- (.visitLabel *writer* default-label)
- (if-let [[_ [_ ?idx] ?body] (or (:default ?decision-tree)
- (first (:defaults ?decision-tree)))]
- (doto *writer*
- (.visitInsn Opcodes/DUP)
- (.visitVarInsn Opcodes/ASTORE ?idx)
- (.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
- (doto *writer*
- (.visitInsn Opcodes/POP)
- (.visitTypeInsn Opcodes/NEW ex-class)
- (.visitInsn Opcodes/DUP)
- (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
- (.visitInsn Opcodes/ATHROW))))]
- _ (map-m (fn [[?label ?body]]
- (exec [:let [_ (do (.visitLabel *writer* ?label)
- (.visitInsn *writer* Opcodes/POP))]
- ret (compile ?body)
- :let [_ (.visitJumpInsn *writer* Opcodes/GOTO end-label)]]
- (return ret)))
- (map second entries))
- :let [_ (.visitLabel *writer* end-label)]]
- (return nil))))
-
-(let [clo-field-sig (->type-signature "java.lang.Object")
- lambda-return-sig (->type-signature "java.lang.Object")
- <init>-return "V"
- counter-sig "I"
- +datum-sig+ (->type-signature "java.lang.Object")]
- (defn ^:private lambda-impl-signature [args]
- (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig))
-
- (defn ^:private lambda-<init>-signature [closed-over args]
- (let [num-args (count args)]
- (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig))
- (if (> num-args 1)
- (reduce str counter-sig (repeat (dec num-args) clo-field-sig)))
- ")"
- <init>-return)))
-
- (defn ^:private add-lambda-<init> [class class-name closed-over args init-signature]
- (let [num-args (count args)
- num-mappings (count closed-over)]
- (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD ?captured-id)
- (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
- (->> (let [captured-name (str +closure-prefix+ ?captured-id)])
- (match (:form ?captured)
- [::&analyser/captured ?closure-id ?captured-id ?source])
- (doseq [[?name ?captured] closed-over])))
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitInsn Opcodes/ICONST_0)
- (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset))
- (.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig))
- (->> (let [field-name (str +partial-prefix+ clo_idx)]
- (doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
- (.visitEnd)))
- (dotimes [clo_idx (dec num-args)])
- (let [offset (+ 2 num-mappings)]))))
- (->> (when (> num-args 1))))
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))))
-
- (do-template [<name> <prefix>]
- (defn <name> [writer class-name vars]
- (dotimes [idx (count vars)]
- (doto writer
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name (str <prefix> idx) clo-field-sig))))
-
- ^:private add-closure-vars +closure-prefix+
- ^:private add-partial-vars +partial-prefix+
- )
-
- (defn ^:private add-nulls [writer amount]
- (dotimes [_ amount]
- (.visitInsn writer Opcodes/ACONST_NULL)))
-
- (defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature]
- (let [num-args (count args)
- num-captured (dec num-args)
- default-label (new Label)
- branch-labels (for [_ (range num-captured)]
- (new Label))]
- (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil)
- (.visitCode)
- (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
- (.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig)
- (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
- (-> (doto (.visitLabel branch-label)
- (.visitTypeInsn Opcodes/NEW class-name)
- (.visitInsn Opcodes/DUP)
- (add-closure-vars class-name closed-over)
- (.visitLdcInsn (int current-captured))
- (add-partial-vars class-name (take current-captured args))
- (.visitVarInsn Opcodes/ALOAD 1)
- (add-nulls (- (dec num-captured) current-captured))
- (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature)
- (.visitInsn Opcodes/ARETURN))
- (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))])))
- (.visitLabel default-label))
- (->> (when (> num-args 1))))
- (.visitVarInsn Opcodes/ALOAD 0)
- (add-partial-vars class-name (butlast args))
- (.visitVarInsn Opcodes/ALOAD 1)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature)
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))))
-
- (defn ^:private add-lambda-impl [class compile impl-signature impl-body]
- (&util/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil)
- (.visitCode))
- (exec [;; :let [_ (prn 'add-lambda-impl/_0)]
- *writer* &util/get-writer
- ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)]
- ret (compile impl-body)
- ;; :let [_ (prn 'add-lambda-impl/_2 ret)]
- :let [_ (doto *writer*
- (.visitInsn Opcodes/ARETURN)
- (.visitMaxs 0 0)
- (.visitEnd))]
- ;; :let [_ (prn 'add-lambda-impl/_3)]
- ]
- (return ret))))
-
- (defn ^:private instance-closure [compile lambda-class closed-over args init-signature]
- (exec [*writer* &util/get-writer
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/NEW lambda-class)
- (.visitInsn Opcodes/DUP))]
- _ (->> closed-over
- (sort #(< (-> %1 second :form (nth 2))
- (-> %2 second :form (nth 2))))
- (map-m (fn [[?name ?captured]]
- (match (:form ?captured)
- [::&analyser/captured ?closure-id ?captured-id ?source]
- (compile ?source)))))
- :let [num-args (count args)
- _ (do (when (> num-args 1)
- (.visitInsn *writer* Opcodes/ICONST_0)
- (add-nulls *writer* (dec num-args)))
- (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature))]]
- (return nil)))
-
- (defn ^:private add-lambda-<clinit> [class class-name args <init>-sig]
- (let [num-args (count args)]
- (doto (.visitMethod class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
- (.visitCode)
- (.visitTypeInsn Opcodes/NEW class-name)
- (.visitInsn Opcodes/DUP)
- (-> (doto (.visitInsn *writer* Opcodes/ICONST_0)
- (add-nulls (dec num-args)))
- (->> (when (> num-args 1))))
- (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" <init>-sig)
- (.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+)
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))))
-
- (defn ^:private compile-lambda [compile *type* ?scope ?closure ?args ?body with-datum? instance?]
- (exec [:let [lambda-class (storage-id ?scope)
- impl-signature (lambda-impl-signature ?args)
- <init>-sig (lambda-<init>-signature ?closure ?args)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
- lambda-class nil "java/lang/Object" (into-array [(->class +function-class+)]))
- (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil)
- (.visitEnd))
- (->> (let [captured-name (str +closure-prefix+ ?captured-id)])
- (match (:form ?captured)
- [::&analyser/captured ?closure-id ?captured-id ?source])
- (doseq [[?name ?captured] ?closure])))
- (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil)
- (.visitEnd))
- (->> (when (> (count ?args) 1))))
- (-> (doto (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil)
- (add-lambda-<clinit> lambda-class ?args <init>-sig))
- (when with-datum?))
- (add-lambda-apply lambda-class ?closure ?args impl-signature <init>-sig)
- (add-lambda-<init> lambda-class ?closure ?args <init>-sig)
- )]
- _ (add-lambda-impl =class compile impl-signature ?body)
- :let [_ (.visitEnd =class)]
- _ (save-class! lambda-class (.toByteArray =class))]
- (if instance?
- (instance-closure compile lambda-class ?closure ?args <init>-sig)
- (return nil))))
- )
-
(defn ^:private compile-field [compile *type* ?name body]
(exec [*writer* &util/get-writer
- class-name &analyser/module-name
- :let [outer-class (->class class-name)
+ module-name &analyser/module-name
+ :let [outer-class (->class module-name)
datum-sig (->type-signature "java.lang.Object")
- current-class (storage-id (list ?name outer-class))
+ current-class (&host/location (list ?name outer-class))
_ (.visitInnerClass *writer* current-class outer-class nil (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
@@ -800,101 +243,17 @@
(return nil)))
(defn ^:private compile-def [compile *type* name value]
- (exec [_ (match value
- [::&analyser/Expression ?form _]
- (match ?form
- [::&analyser/lambda ?scope ?captured ?args ?body]
- (compile-lambda compile *type* ?scope ?closure ?args ?body true false)
-
- _
- (compile-field compile *type* name value))
-
- _
- (fail "Can only define expressions."))]
- (return nil)))
-
-(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods]
- (exec [*writer* &util/get-writer
- loader &util/loader
- :let [parent-dir (->package ?package)
- full-name (str parent-dir "/" ?name)
- super-class* (->class ?super-class)
- =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
- full-name nil super-class* nil))
- _ (do (doseq [[field props] ?fields]
- (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil)
- (.visitEnd)))
- (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
- (.visitCode)
- (.visitVarInsn Opcodes/ALOAD 0)
- (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "<init>" "()V")
- (.visitInsn Opcodes/RETURN)
- (.visitMaxs 0 0)
- (.visitEnd))
- (.visitEnd =class)
- (.mkdirs (java.io.File. (str "output/" parent-dir))))]
- _ (save-class! full-name (.toByteArray =class))]
- (return nil)))
-
-(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods]
- (exec [*writer* &util/get-writer
- loader &util/loader
- :let [parent-dir (->package ?package)
- full-name (str parent-dir "/" ?name)
- =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
- (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE)
- full-name nil "java/lang/Object" nil))
- _ (do (doseq [[?method ?props] ?methods
- :let [[?args ?return] (:type ?props)
- signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]]
- (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
- (.visitEnd =interface)
- (.mkdirs (java.io.File. (str "output/" parent-dir))))]
- _ (save-class! full-name (.toByteArray =interface))]
- (return nil)))
-
-(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>]
- (defn <name> [compile *type* ?x ?y]
- (exec [:let [+wrapper-class+ (->class <wrapper-class>)]
- *writer* &util/get-writer
- _ (compile ?x)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
- _ (compile ?y)
- :let [_ (doto *writer*
- (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
- _ (doto *writer*
- (.visitInsn <opcode>)
- (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (->type-signature <wrapper-class>))))]]
- (return nil)))
-
- ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
- ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
-
- ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
- ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
-
- ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
- ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
-
- ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
- )
+ (match value
+ [::&analyser/Expression ?form _]
+ (match ?form
+ [::&analyser/lambda ?scope ?captured ?args ?body]
+ (compile-lambda compile *type* ?scope ?closure ?args ?body true false)
+
+ _
+ (compile-field compile *type* name value))
+
+ _
+ (fail "Can only define expressions.")))
(defn ^:private compile-self-call [compile ?assumed-args]
(exec [*writer* &util/get-writer
@@ -944,8 +303,8 @@
[::&analyser/variant ?tag ?members]
(compile-variant compile-expression (:type syntax) ?tag ?members)
- [::&analyser/case ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree]
- (compile-case compile-expression (:type syntax) ?base-idx ?variant ?max-registers ?branch-mappings ?decision-tree)
+ [::&analyser/case ?variant ?base-register ?num-registers ?branches]
+ (compile-case compile-expression (:type syntax) ?variant ?base-register ?num-registers ?branches)
[::&analyser/lambda ?scope ?frame ?args ?body]
(compile-lambda compile-expression (:type syntax) ?scope ?frame ?args ?body false true)
diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj
new file mode 100644
index 000000000..8f35ec2c0
--- /dev/null
+++ b/src/lux/compiler/case.clj
@@ -0,0 +1,568 @@
+
+(let [+tag-sig+ (->type-signature "java.lang.String")
+ variant-class* (->class +variant-class+)
+ tuple-class* (->class +tuple-class+)
+ +variant-field-sig+ (->type-signature "java.lang.Object")
+ oclass (->class "java.lang.Object")
+ equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
+ (defn ^:private compile-decision-tree [writer mappings default-label decision-tree]
+ (match decision-tree
+ [::test-bool ?pairs]
+ (compile-compare-bools writer mappings default-label ?pairs)
+
+ [::test-int ?pairs]
+ (compile-compare-ints writer mappings default-label ?pairs)
+
+ [::test-real ?pairs]
+ (compile-compare-reals writer mappings default-label ?pairs)
+
+ [::test-char ?pairs]
+ (compile-compare-chars writer mappings default-label ?pairs)
+
+ [::test-text ?pairs]
+ (compile-compare-texts writer mappings default-label ?pairs)
+
+ [::store ?idx $body]
+ (doto writer
+ (.visitVarInsn Opcodes/ASTORE ?idx)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body)))
+
+ [::test-tuple ?branches ?cases]
+ (let [[_ ?subcases] (first ?cases)
+ arity (-> ?subcases first (nth 2) count)
+ tuple-class** (str tuple-class* arity)]
+ (doto writer
+ ;; object
+ (.visitTypeInsn Opcodes/CHECKCAST tuple-class**) ;; tuple
+ (do (doseq [subcase ?subcases
+ :let [next-subcase (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [sub-next-elem (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; tuple, tuple
+ (.visitFieldInsn Opcodes/GETFIELD tuple-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; tuple, object
+ (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; tuple
+ (.visitLabel sub-next-elem)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel next-subcase)))
+ )))
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+
+ [::test-variant ?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)
+ variant-class** (str variant-class* arity)]
+ (.visitTypeInsn writer Opcodes/CHECKCAST variant-class**) ;; variantN
+ (doseq [subcase ?subcases
+ :let [next-subcase (new Label)]]
+ (match subcase
+ [::subcase $body ?subseq]
+ (do (doseq [[?subpart ?subidx] (map vector ?subseq (range (count ?subseq)))
+ :let [sub-next-elem (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP) ;; variant, variant
+ (.visitFieldInsn Opcodes/GETFIELD variant-class** (str +partial-prefix+ ?subidx) +variant-field-sig+) ;; variant, object
+ (compile-decision-tree (assoc mappings $body sub-next-elem) next-subcase ?subpart) ;; variant
+ (.visitLabel sub-next-elem)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel next-subcase)))
+ ))
+ ))
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)
+ ;; variant, tag ->
+ (.visitLabel tag-else-label))
+ (->> (doseq [[?tag ?subcases] ?cases
+ :let [tag-else-label (new Label)]])))
+ ;; variant, tag ->
+ (.visitInsn Opcodes/POP) ;; variant ->
+ (.visitInsn Opcodes/POP) ;; ->
+ (.visitJumpInsn Opcodes/GOTO default-label)))
+ ))
+
+(defn ^:private map-branches [idx mappings patterns]
+ (reduce (fn [[idx mappings patterns*] [test body]]
+ [(inc idx)
+ (assoc mappings idx body)
+ (cons [test idx] patterns*)])
+ [idx mappings (list)]
+ patterns))
+
+(defn ^:private map-bodies [pm-struct]
+ (match pm-struct
+ [::BoolPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::BoolPM patterns* defaults*]])
+
+ [::IntPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::IntPM patterns* defaults*]])
+
+ [::RealPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::RealPM patterns* defaults*]])
+
+ [::CharPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::CharPM patterns* defaults*]])
+
+ [::TextPM ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::TextPM patterns* defaults*]])
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::TuplePM ?num-elems patterns* defaults*]])
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (let [[idx mappings patterns*] (map-branches 0 {} ?patterns)
+ [_ mappings* defaults*] (map-branches idx mappings ?defaults)]
+ [mappings* [::VariantPM ?tags patterns* defaults*]])
+
+ [::?PM ?defaults]
+ (let [[_ mappings defaults*] (map-branches 0 {} ?defaults)]
+ [mappings [::?PM defaults*]])))
+
+(defn ^:private get-default [pm-struct]
+ (match pm-struct
+ [::BoolPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::IntPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::RealPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::CharPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::TextPM ?patterns ?defaults]
+ (first ?defaults)
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (first ?defaults)
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (first ?defaults)
+
+ [::?PM ?defaults]
+ (first ?defaults)
+ ))
+
+(do-template [<name> <wrapper-class> <value-method> <method-sig>]
+ (defn <name> [writer mappings $default ?patterns]
+ (doseq [[?token $body] ?patterns
+ :let [$else (new Label)]]
+ (doto writer
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
+ (.visitLdcInsn ?token)
+ (.visitJumpInsn Opcodes/IF_ICMPNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $default)))
+
+ ^:private compile-bool-pm "java.lang.Boolean" "booleanValue" "()Z"
+ ^:private compile-char-pm "java.lang.Character" "charValue" "()C"
+ )
+
+(do-template [<name> <wrapper-class> <value-method> <method-sig> <cmp-op>]
+ (defn <name> [writer mappings $default ?patterns]
+ (doseq [[?token $body] ?patterns
+ :let [$else (new Label)]]
+ (doto writer
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class <wrapper-class>) <value-method> <method-sig>)
+ (.visitLdcInsn ?token)
+ (.visitInsn <cmp-op>)
+ (.visitJumpInsn Opcodes/IFNE $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $default)))
+
+ ^:private compile-int-pm "java.lang.Long" "longValue" "()J" Opcodes/LCMP
+ ^:private compile-real-pm "java.lang.Double" "doubleValue" "()D" Opcodes/DCMPL
+ )
+
+(defn ^:private compile-text-pm [writer mappings $default ?patterns]
+ (doseq [[?token $body] ?patterns
+ :let [$else (new Label)]]
+ (doto writer
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn ?token)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.lang.Object") "equals" (str "(" (->type-signature "java.lang.Object") ")Z"))
+ (.visitJumpInsn Opcodes/IFEQ $else)
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO (get mappings $body))
+ (.visitLabel $else)))
+ (doto writer
+ (.visitInsn Opcodes/POP)
+ (.visitJumpInsn Opcodes/GOTO $default)))
+
+(defn ^:private compile-tuple-pm [writer mapping $default ?num-elems ?patterns]
+ (let [sub-patterns (map (fn [idx]
+ (map (fn [tup body]
+ [(nth tup idx) body])
+ ?patterns))
+ (range ?num-elems))
+ subpm-structs (map group-patterns sub-patterns)
+ [pat-h & pat-t] subpm-structs
+ (for [(get-branches pat-h)
+ (cull pat-t)]
+ )
+ (reduce (fn [branches pattern]
+ ( (group-patterns pattern)))
+ (get-branches pat-h)
+ pat-t)
+ (sequence-tests sub-patterns)]
+ ))
+
+(defn ^:private compile-pm [writer mapping pm-struct]
+ (match pm-struct
+ [::BoolPM ?patterns ?defaults]
+ (compile-bool-pm writer mapping $default ?patterns)
+
+ [::IntPM ?patterns ?defaults]
+ (compile-int-pm writer mapping $default ?patterns)
+
+ [::RealPM ?patterns ?defaults]
+ (compile-real-pm writer mapping $default ?patterns)
+
+ [::CharPM ?patterns ?defaults]
+ (compile-char-pm writer mapping $default ?patterns)
+
+ [::TextPM ?patterns ?defaults]
+ (compile-text-pm writer mapping $default ?patterns)
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (compile-tuple-pm writer mapping $default ?num-elems ?patterns)
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (first ?defaults)
+
+ [::?PM ?defaults]
+ (first ?defaults)
+ ))
+
+(do-template [<name> <pm-tag>]
+ (defn <name> [pm value body]
+ (match pm
+ [<pm-tag> ?branches ?defaults]
+ (return [<pm-tag> (cons [value body] ?branches) ?defaults])
+
+ [::?PM ?defaults]
+ (return [<pm-tag> (list [value body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!")))
+
+ ^:private group-bool-pm ::BoolPM
+ ^:private group-int-pm ::IntPM
+ ^:private group-real-pm ::RealPM
+ ^:private group-char-pm ::CharPM
+ ^:private group-text-pm ::textPM
+ )
+
+(defn ^:private group-branch [pm [pattern body]]
+ (match pattern
+ [::&parser/Bool ?value]
+ (group-bool-pm pm ?value body)
+
+ [::&parser/Int ?value]
+ (group-int-pm pm ?value body)
+
+ [::&parser/Real ?value]
+ (group-real-pm pm ?value body)
+
+ [::&parser/Char ?value]
+ (group-char-pm pm ?value body)
+
+ [::&parser/Text ?value]
+ (group-text-pm pm ?value body)
+
+ [::&parser/Tuple ?members]
+ (match pm
+ [::TuplePM ?num-elems ?branches ?defaults]
+ (exec [_ (assert! (= ?num-elems (count ?members))
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " (count ?members)))]
+ (return [::TuplePM ?num-elems (cons [?members body] ?branches) ?defaults]))
+
+ [::?PM ?defaults]
+ (return [::TuplePM (count ?members) (list [?members body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!"))
+
+ [::&parser/Tag ?tag]
+ (let [members (list)
+ num-members (count members)]
+ (match pm
+ [::VariantPM ?variants ?branches ?defaults]
+ (exec [variants* (if-let [?num-elems (get ?variants ?tag)]
+ (exec [_ (assert! (= ?num-elems num-members)
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
+ (return ?variants))
+ (return (assoc ?variants ?tag num-members)))]
+ (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
+
+ [::?PM ?defaults]
+ (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!")))
+
+ [::&parser/Form ([[::&parser/Tag ?tag] & ?members] :seq)]
+ (let [members ?members
+ num-members (count members)]
+ (match pm
+ [::VariantPM ?variants ?branches ?defaults]
+ (exec [variants* (if-let [?num-elems (get ?variants ?tag)]
+ (exec [_ (assert! (= ?num-elems num-members)
+ (str "[Analyser Error] Mismatch in tuple size: " ?num-elems " =/= " num-members))]
+ (return ?variants))
+ (return (assoc ?variants ?tag num-members)))]
+ (return [::VariantPM variants* (conj ?branches [[?tag members] body]) ?defaults]))
+
+ [::?PM ?defaults]
+ (return [::VariantPM {?tag num-members} (list [[?tag members] body]) ?defaults])
+
+ _
+ (fail "Can't match pattern!")))
+
+ [::&parser/Ident ?name]
+ (match pm
+ [::BoolPM ?patterns ?defaults]
+ (return [::BoolPM ?patterns (conj ?defaults [?name body])])
+
+ [::IntPM ?patterns ?defaults]
+ (return [::IntPM ?patterns (conj ?defaults [?name body])])
+
+ [::RealPM ?patterns ?defaults]
+ (return [::RealPM ?patterns (conj ?defaults [?name body])])
+
+ [::CharPM ?patterns ?defaults]
+ (return [::CharPM ?patterns (conj ?defaults [?name body])])
+
+ [::TextPM ?patterns ?defaults]
+ (return [::TextPM ?patterns (conj ?defaults [?name body])])
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (return [::TuplePM ?num-elems ?patterns (conj ?defaults [?name body])])
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (return [::VariantPM ?tags ?patterns (conj ?defaults [?name body])])
+
+ [::?PM ?defaults]
+ (return [::?PM (conj ?defaults [?name body])]))
+ ))
+
+(defn ^:private valid-paths [group]
+ (set (match group
+ [::BoolPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::IntPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::RealPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::CharPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::TextPM ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (concat (map second ?patterns) (map second ?defaults))
+
+ [::?PM ?defaults]
+ (map second ?defaults))))
+
+(defn ^:private sequence-multi-pm [sequence-pm prev-paths groups]
+ (match groups
+ ([head & tail] :seq)
+ (for [:let [curr-paths (set/intersection prev-paths (valid-paths head))]
+ [head-paths head-test] (sequence-pm curr-paths head)]
+ [:multi-test head-test head-paths (sequence-multi-pm sequence-pm head-paths tail)])
+
+ _
+ (list (list))))
+
+(do-template [<name> <pm> <test>]
+ (defn <name> [prev-paths group]
+ (match group
+ [<pm> ?patterns ?defaults]
+ (return (concat (for [[value $body] ?patterns
+ :when (contains? prev-paths $body)]
+ [<test> value #{$body}])
+ (match ?defaults
+ ([[default-register $body] & _] :seq)
+ (list [<test> default-register #{$body}])
+
+ :else
+ (list))))
+
+ :else
+ (fail "")))
+
+ ^:private sequence-bool ::BoolPM ::test-bool
+ ^:private sequence-int ::IntPM ::test-int
+ ^:private sequence-real ::RealPM ::test-real
+ ^:private sequence-char ::CharPM ::test-char
+ ^:private sequence-text ::TextPM ::test-text
+ )
+
+(defn ^:private sequence-? [group]
+ [::?PM ([[default-register $body] & _] :seq)]
+ (return (list [<test> default-register #{$body}]))
+
+ :else
+ (fail ""))
+
+(defn ^:private sequence-pm [group]
+ (match group
+ [::BoolPM _ _]
+ (sequence-bool group)
+
+ [::IntPM _ _]
+ (sequence-int group)
+
+ [::RealPM _ _]
+ (sequence-real group)
+
+ [::CharPM _ _]
+ (sequence-char group)
+
+ [::TextPM _ _]
+ (sequence-text group)
+
+ [::?PM _]
+ (sequence-? group)
+
+ [::TuplePM ?num-elems ?patterns ?defaults]
+ (exec [:let [sub-patterns (map (fn [idx]
+ (map (fn [[tup body]]
+ [(nth tup idx) body])
+ ?patterns))
+ (range ?num-elems))]
+ groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns)
+ tuple-paths (valid-paths group)
+ sub-seqs (sequence-multi-pm sequence-pm tuple-paths groups)]
+ (return (cons [::test-tuple ?num-elems sub-seqs]
+ (match ?defaults
+ ([[default-register $body] & _] :seq)
+ (list [<test> default-register #{$body}])
+
+ :else
+ (list)))))
+
+ [::VariantPM ?tags ?patterns ?defaults]
+ (map-m (fn [tag]
+ (exec [:let [members+bodies (mapcat (fn [[ptag pmembers pbody]]
+ (if (= ptag tag)
+ (list [pmembers pbody])
+ (list)))
+ ?patterns)
+ sub-patterns (map (fn [idx]
+ (map (fn [[tup body]]
+ [(nth tup idx) body])
+ members+bodies))
+ (range ?num-elems))]
+ groups (map-m #(reduce-m group-branch [::?PM (list)] %) sub-patterns)
+ tag-paths (set (map second members+bodies))
+ sub-seqs (sequence-multi-pm sequence-pm tag-paths groups)]
+ (cons [::test-variant tag ?num-elems sub-seqs]
+ (match ?defaults
+ ([[default-register $body] & _] :seq)
+ (list [<test> default-register #{$body}])
+
+ :else
+ (list)))))
+ (keys ?tags))
+ ))
+
+(defn ^:private decision-tree [branches]
+ (exec [group (reduce-m group-branch [::?PM (list)] branches)
+ :let [[mappings group*] (map-bodies group)
+ paths (valid-paths group*)]]
+ (sequence-pm paths group*)))
+
+(let [ex-class (->class "java.lang.IllegalStateException")]
+ (defn ^:private compile-case [compile *type* ?variant ?base-register ?num-registers ?branches]
+ (exec [*writer* &util/get-writer
+ :let [$start (new Label)
+ $end (new Label)
+ _ (dotimes [offset ?num-registers]
+ (let [idx (+ ?base-register offset)]
+ (.visitLocalVariable *writer* (str +local-prefix+ idx) (->java-sig [::&type/Any]) nil $start $end idx)))]
+ _ (compile ?variant)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLabel $start))]
+ :let [[mapping tree] (decision-tree ?branches)]
+
+ :let [[mappings pm-struct*] (map-bodies pm-struct)
+ entries (for [[?branch ?body] mappings
+ :let [label (new Label)]]
+ [[?branch label]
+ [label ?body]])
+ mappings* (into {} (map first entries))
+ ]
+ :let [$default (new Label)
+ _ (do (doseq [decision-tree (let [pieces (map first (sequence-parts ?pm-struct))]
+ (if (get-default pm-struct)
+ (butlast pieces)
+ pieces))]
+ (compile-decision-tree *writer* mappings* $default decision-tree))
+ (.visitLabel *writer* $default)
+ (if-let [[?idx ?body] (get-default pm-struct)]
+ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitVarInsn Opcodes/ASTORE ?idx)
+ (.visitJumpInsn Opcodes/GOTO (get mappings* ?body)))
+ (doto *writer*
+ (.visitInsn Opcodes/POP)
+ (.visitTypeInsn Opcodes/NEW ex-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL ex-class "<init>" "()V")
+ (.visitInsn Opcodes/ATHROW))))]
+ _ (map-m (fn [[?label ?body]]
+ (exec [:let [_ (do (.visitLabel *writer* ?label)
+ (.visitInsn *writer* Opcodes/POP))]
+ ret (compile ?body)
+ :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]]
+ (return ret)))
+ (map second entries))
+ :let [_ (.visitLabel *writer* $end)]]
+ (return nil))))
diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj
new file mode 100644
index 000000000..dfe67eece
--- /dev/null
+++ b/src/lux/compiler/host.clj
@@ -0,0 +1,194 @@
+
+(let [class+metthod+sig {"boolean" [(->class "java.lang.Boolean") "booleanValue" "()Z"]
+ "byte" [(->class "java.lang.Byte") "byteValue" "()B"]
+ "short" [(->class "java.lang.Short") "shortValue" "()S"]
+ "int" [(->class "java.lang.Integer") "intValue" "()I"]
+ "long" [(->class "java.lang.Long") "longValue" "()J"]
+ "float" [(->class "java.lang.Float") "floatValue" "()F"]
+ "double" [(->class "java.lang.Double") "doubleValue" "()D"]
+ "char" [(->class "java.lang.Character") "charValue" "()C"]}]
+ (defn ^:private prepare-arg! [*writer* class-name]
+ (if-let [[class method sig] (get class+metthod+sig class-name)]
+ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST class)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class method sig))
+ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class class-name)))))
+
+;; (let [boolean-class "java.lang.Boolean"
+;; integer-class "java.lang.Integer"
+;; char-class "java.lang.Character"]
+;; (defn prepare-return! [*writer* *type*]
+;; (match *type*
+;; ::&type/nothing
+;; (.visitInsn *writer* Opcodes/ACONST_NULL)
+
+;; [::&type/primitive "char"]
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class char-class) "valueOf" (str "(C)" (->type-signature char-class)))
+
+;; [::&type/primitive "int"]
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class integer-class) "valueOf" (str "(I)" (->type-signature integer-class)))
+
+;; [::&type/primitive "boolean"]
+;; (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class boolean-class) "valueOf" (str "(Z)" (->type-signature boolean-class)))
+
+;; [::&type/Data ?oclass]
+;; nil)))
+
+
+(defn ^:private compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args]
+ (exec [*writer* &util/get-writer
+ :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+ _ (map-m (fn [[class-name arg]]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
+ :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (->class ?class) ?method method-sig)
+ ;; (prepare-return! *writer* *type*)
+ )]]
+ (return nil)))
+
+(defn ^:private compile-jvm-invokevirtual [compile *type* ?class ?method ?classes ?object ?args]
+ (exec [*writer* &util/get-writer
+ :let [method-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")" (->java-sig *type*))]
+ _ (compile ?object)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
+ _ (map-m (fn [[class-name arg]]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
+ :let [_ (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL (->class ?class) ?method method-sig)
+ ;; (prepare-return! *writer* *type*)
+ )]]
+ (return nil)))
+
+(defn ^:private compile-jvm-new [compile *type* ?class ?classes ?args]
+ (exec [*writer* &util/get-writer
+ :let [init-sig (str "(" (reduce str "" (map ->type-signature ?classes)) ")V")
+ class* (->class ?class)
+ _ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW class*)
+ (.visitInsn Opcodes/DUP))]
+ _ (map-m (fn [[class-name arg]]
+ (exec [ret (compile arg)
+ :let [_ (prepare-arg! *writer* class-name)]]
+ (return ret)))
+ (map vector ?classes ?args))
+ :let [_ (doto *writer*
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "<init>" init-sig))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-new-array [compile *type* ?class ?length]
+ (exec [*writer* &util/get-writer
+ :let [_ (doto *writer*
+ (.visitLdcInsn (int ?length))
+ (.visitTypeInsn Opcodes/ANEWARRAY (->class ?class)))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-aastore [compile *type* ?array ?idx ?elem]
+ (exec [*writer* &util/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/DUP)
+ (.visitLdcInsn (int ?idx)))]
+ _ (compile ?elem)
+ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]]
+ (return nil)))
+
+(defn ^:private compile-jvm-aaload [compile *type* ?array ?idx]
+ (exec [*writer* &util/get-writer
+ _ (compile ?array)
+ :let [_ (doto *writer*
+ (.visitLdcInsn (int ?idx))
+ (.visitInsn Opcodes/AALOAD))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-getstatic [compile *type* ?class ?field]
+ (exec [*writer* &util/get-writer
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (->class ?class) ?field (->java-sig *type*))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-getfield [compile *type* ?class ?field ?object]
+ (exec [*writer* &util/get-writer
+ _ (compile ?object)
+ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST (->class ?class))]
+ :let [_ (.visitFieldInsn *writer* Opcodes/GETFIELD (->class ?class) ?field (->java-sig *type*))]]
+ (return nil)))
+
+(defn ^:private compile-jvm-class [compile *type* ?package ?name ?super-class ?fields ?methods]
+ (let [parent-dir (->package ?package)
+ full-name (str parent-dir "/" ?name)
+ super-class* (->class ?super-class)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ full-name nil super-class* nil))
+ _ (do (doseq [[field props] ?fields]
+ (doto (.visitField =class Opcodes/ACC_PUBLIC field (->type-signature (:type props)) nil nil)
+ (.visitEnd)))
+ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL super-class* "<init>" "()V")
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ (.visitEnd =class)
+ (.mkdirs (java.io.File. (str "output/" parent-dir))))]
+ (save-class! full-name (.toByteArray =class))))
+
+(defn ^:private compile-jvm-interface [compile *type* ?package ?name ?fields ?methods]
+ (let [parent-dir (->package ?package)
+ full-name (str parent-dir "/" ?name)
+ =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE)
+ full-name nil "java/lang/Object" nil))
+ _ (do (doseq [[?method ?props] ?methods
+ :let [[?args ?return] (:type ?props)
+ signature (str "(" (reduce str "" (map ->type-signature ?args)) ")" (->type-signature ?return))]]
+ (.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
+ (.visitEnd =interface)
+ (.mkdirs (java.io.File. (str "output/" parent-dir))))]
+ (save-class! full-name (.toByteArray =interface))))
+
+(do-template [<name> <opcode> <wrapper-class> <value-method> <value-method-sig> <wrapper-method> <wrapper-method-sig>]
+ (defn <name> [compile *type* ?x ?y]
+ (exec [:let [+wrapper-class+ (->class <wrapper-class>)]
+ *writer* &util/get-writer
+ _ (compile ?x)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))]
+ _ (compile ?y)
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ <value-method> <value-method-sig>))
+ _ (doto *writer*
+ (.visitInsn <opcode>)
+ (.visitMethodInsn Opcodes/INVOKESTATIC +wrapper-class+ <wrapper-method> (str <wrapper-method-sig> (->type-signature <wrapper-class>))))]]
+ (return nil)))
+
+ ^:private compile-jvm-iadd Opcodes/IADD "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-isub Opcodes/ISUB "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-imul Opcodes/IMUL "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-idiv Opcodes/IDIV "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+ ^:private compile-jvm-irem Opcodes/IREM "java.lang.Integer" "intValue" "()I" "valueOf" "(I)"
+
+ ^:private compile-jvm-ladd Opcodes/LADD "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-lsub Opcodes/LSUB "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-lmul Opcodes/LMUL "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-ldiv Opcodes/LDIV "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+ ^:private compile-jvm-lrem Opcodes/LREM "java.lang.Long" "longValue" "()J" "valueOf" "(J)"
+
+ ^:private compile-jvm-fadd Opcodes/FADD "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-fsub Opcodes/FSUB "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-fmul Opcodes/FMUL "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-fdiv Opcodes/FDIV "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+ ^:private compile-jvm-frem Opcodes/FREM "java.lang.Float" "floatValue" "()F" "valueOf" "(F)"
+
+ ^:private compile-jvm-dadd Opcodes/DADD "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-dsub Opcodes/DSUB "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-dmul Opcodes/DMUL "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-ddiv Opcodes/DDIV "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ ^:private compile-jvm-drem Opcodes/DREM "java.lang.Double" "doubleValue" "()D" "valueOf" "(D)"
+ )
diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj
new file mode 100644
index 000000000..b3bfc4860
--- /dev/null
+++ b/src/lux/compiler/lambda.clj
@@ -0,0 +1,176 @@
+(ns lux.compiler.lambda)
+
+;; [Utils]
+(def ^:private clo-field-sig (->type-signature "java.lang.Object"))
+(def ^:private lambda-return-sig (->type-signature "java.lang.Object"))
+(def ^:private <init>-return "V")
+(def ^:private counter-sig "I")
+(def ^:private +datum-sig+ (->type-signature "java.lang.Object"))
+
+(defn ^:private lambda-impl-signature [args]
+ (str (reduce str "(" (repeat (count args) clo-field-sig)) ")" lambda-return-sig))
+
+(defn ^:private lambda-<init>-signature [closed-over args]
+ (let [num-args (count args)]
+ (str "(" (reduce str "" (repeat (count closed-over) clo-field-sig))
+ (if (> num-args 1)
+ (reduce str counter-sig (repeat (dec num-args) clo-field-sig)))
+ ")"
+ <init>-return)))
+
+(defn ^:private add-lambda-<init> [class class-name closed-over args init-signature]
+ (let [num-args (count args)
+ num-mappings (count closed-over)]
+ (doto (.visitMethod class Opcodes/ACC_PUBLIC "<init>" init-signature nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD ?captured-id)
+ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig))
+ (->> (let [captured-name (str +closure-prefix+ ?captured-id)])
+ (match (:form ?captured)
+ [::&analyser/captured ?closure-id ?captured-id ?source])
+ (doseq [[?name ?captured] closed-over])))
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitInsn Opcodes/ICONST_0)
+ (.visitFieldInsn Opcodes/PUTFIELD class-name "_counter" counter-sig)
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD (+ clo_idx offset))
+ (.visitFieldInsn Opcodes/PUTFIELD class-name field-name clo-field-sig))
+ (->> (let [field-name (str +partial-prefix+ clo_idx)]
+ (doto (.visitField class (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) field-name clo-field-sig nil nil)
+ (.visitEnd)))
+ (dotimes [clo_idx (dec num-args)])
+ (let [offset (+ 2 num-mappings)]))))
+ (->> (when (> num-args 1))))
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+(do-template [<name> <prefix>]
+ (defn <name> [writer class-name vars]
+ (dotimes [idx (count vars)]
+ (doto writer
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name (str <prefix> idx) clo-field-sig))))
+
+ ^:private add-closure-vars +closure-prefix+
+ ^:private add-partial-vars +partial-prefix+
+ )
+
+(defn ^:private add-nulls [writer amount]
+ (dotimes [_ amount]
+ (.visitInsn writer Opcodes/ACONST_NULL)))
+
+(defn ^:private add-lambda-apply [class class-name closed-over args impl-signature init-signature]
+ (let [num-args (count args)
+ num-captured (dec num-args)
+ default-label (new Label)
+ branch-labels (for [_ (range num-captured)]
+ (new Label))]
+ (doto (.visitMethod class Opcodes/ACC_PUBLIC "apply" +apply-signature+ nil nil)
+ (.visitCode)
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitFieldInsn Opcodes/GETFIELD class-name "_counter" counter-sig)
+ (.visitTableSwitchInsn 0 (dec num-captured) default-label (into-array Label branch-labels))
+ (-> (doto (.visitLabel branch-label)
+ (.visitTypeInsn Opcodes/NEW class-name)
+ (.visitInsn Opcodes/DUP)
+ (add-closure-vars class-name closed-over)
+ (.visitLdcInsn (int current-captured))
+ (add-partial-vars class-name (take current-captured args))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (add-nulls (- (dec num-captured) current-captured))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" init-signature)
+ (.visitInsn Opcodes/ARETURN))
+ (->> (doseq [[branch-label current-captured] (map vector branch-labels (range (count branch-labels)))])))
+ (.visitLabel default-label))
+ (->> (when (> num-args 1))))
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (add-partial-vars class-name (butlast args))
+ (.visitVarInsn Opcodes/ALOAD 1)
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" impl-signature)
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+(defn ^:private add-lambda-impl [class compile impl-signature impl-body]
+ (&util/with-writer (doto (.visitMethod class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil)
+ (.visitCode))
+ (exec [;; :let [_ (prn 'add-lambda-impl/_0)]
+ *writer* &util/get-writer
+ ;; :let [_ (prn 'add-lambda-impl/_1 *writer*)]
+ ret (compile impl-body)
+ ;; :let [_ (prn 'add-lambda-impl/_2 ret)]
+ :let [_ (doto *writer*
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))]
+ ;; :let [_ (prn 'add-lambda-impl/_3)]
+ ]
+ (return ret))))
+
+(defn ^:private instance-closure [compile lambda-class closed-over args init-signature]
+ (exec [*writer* &util/get-writer
+ :let [_ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW lambda-class)
+ (.visitInsn Opcodes/DUP))]
+ _ (->> closed-over
+ (sort #(< (-> %1 second :form (nth 2))
+ (-> %2 second :form (nth 2))))
+ (map-m (fn [[?name ?captured]]
+ (match (:form ?captured)
+ [::&analyser/captured ?closure-id ?captured-id ?source]
+ (compile ?source)))))
+ :let [num-args (count args)
+ _ (do (when (> num-args 1)
+ (.visitInsn *writer* Opcodes/ICONST_0)
+ (add-nulls *writer* (dec num-args)))
+ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "<init>" init-signature))]]
+ (return nil)))
+
+(defn ^:private add-lambda-<clinit> [class class-name args <init>-sig]
+ (let [num-args (count args)]
+ (doto (.visitMethod class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil)
+ (.visitCode)
+ (.visitTypeInsn Opcodes/NEW class-name)
+ (.visitInsn Opcodes/DUP)
+ (-> (doto (.visitInsn *writer* Opcodes/ICONST_0)
+ (add-nulls (dec num-args)))
+ (->> (when (> num-args 1))))
+ (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "<init>" <init>-sig)
+ (.visitFieldInsn Opcodes/PUTSTATIC class-name "_datum" +datum-sig+)
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))))
+
+;; [Resources]
+(defn compile-lambda [compile *type* ?scope ?closure ?args ?body with-datum? instance?]
+ (exec [:let [lambda-class (&host/location ?scope)
+ impl-signature (lambda-impl-signature ?args)
+ <init>-sig (lambda-<init>-signature ?closure ?args)
+ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER)
+ lambda-class nil "java/lang/Object" (into-array [(->class +function-class+)]))
+ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil)
+ (.visitEnd))
+ (->> (let [captured-name (str +closure-prefix+ ?captured-id)])
+ (match (:form ?captured)
+ [::&analyser/captured ?closure-id ?captured-id ?source])
+ (doseq [[?name ?captured] ?closure])))
+ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) "_counter" counter-sig nil nil)
+ (.visitEnd))
+ (->> (when (> (count ?args) 1))))
+ (-> (doto (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "_datum" +datum-sig+ nil nil)
+ (add-lambda-<clinit> lambda-class ?args <init>-sig))
+ (when with-datum?))
+ (add-lambda-apply lambda-class ?closure ?args impl-signature <init>-sig)
+ (add-lambda-<init> lambda-class ?closure ?args <init>-sig)
+ )]
+ _ (add-lambda-impl =class compile impl-signature ?body)
+ :let [_ (.visitEnd =class)]
+ _ (save-class! lambda-class (.toByteArray =class))]
+ (if instance?
+ (instance-closure compile lambda-class ?closure ?args <init>-sig)
+ (return nil))))
diff --git a/src/lux/host.clj b/src/lux/host.clj
index 1dbe0e989..8f9337157 100644
--- a/src/lux/host.clj
+++ b/src/lux/host.clj
@@ -96,3 +96,6 @@
lookup-static-method true
lookup-virtual-method false
)
+
+(defn location [scope]
+ (->> scope reverse (map normalize-ident) (interpose "$") (reduce str "")))
diff --git a/src/lux/macros.clj b/src/lux/macro.clj
index 4d255a13c..52001b24f 100644
--- a/src/lux/macros.clj
+++ b/src/lux/macro.clj
@@ -1,8 +1,8 @@
-(ns lux.macros
+(ns lux.macro
(:require [lux.parser :as &parser]))
;; [Utils]
-(defn ^:private ->lux+* [->lux loader xs]
+(defn ^:private ->lux+ [->lux loader xs]
(reduce (fn [tail x]
(doto (.newInstance (.loadClass loader "lux.Variant2"))
(-> .-tag (set! "Cons"))
@@ -20,7 +20,7 @@
(defn ^:private ->lux-one [->lux loader tag values]
(doto (.newInstance (.loadClass loader "lux.Variant1"))
(-> .-tag (set! tag))
- (-> .-_1 (set! (->lux+* ->lux loader values)))))
+ (-> .-_1 (set! (->lux+ ->lux loader values)))))
(defn ^:private ->lux [loader x]
(match x
@@ -44,11 +44,11 @@
(->lux-many ->lux loader "Form" ?elems)
))
-(defn ^:private ->clojure+* [->clojure xs]
+(defn ^:private ->clojure+ [->clojure xs]
(case (.-tag xs)
"Nil" (list)
"Cons" (cons (->clojure (.-_1 xs))
- (->clojure+* ->clojure (.-_2 xs)))
+ (->clojure+ ->clojure (.-_2 xs)))
))
(defn ^:private ->clojure [x]
@@ -60,10 +60,16 @@
"Text" [::&parser/Text (.-_1 x)]
"Tag" [::&parser/Tag (.-_1 x)]
"Ident" [::&parser/Ident (.-_1 x)]
- "Tuple" [::&parser/Tuple (->clojure+* ->clojure (.-_1 x))]
- "Form" [::&parser/Form (->clojure+* ->clojure (.-_1 x))]))
+ "Tuple" [::&parser/Tuple (->clojure+ ->clojure (.-_1 x))]
+ "Form" [::&parser/Form (->clojure+ ->clojure (.-_1 x))]))
;; [Resources]
-(def ->lux+ (partial ->lux+* ->lux))
-
-(def ->clojure+ (partial ->clojure+* ->clojure))
+(defn expand [loader macro-class]
+ (let [expansion (-> (.loadClass loader macro-class)
+ .getDeclaredConstructors
+ first
+ (.newInstance (to-array [(int 0) nil]))
+ (.apply (->lux+* ->lux loader ?args))
+ (.apply nil))]
+ [(->> expansion .-_1 (->clojure+* ->clojure))
+ (.-_2 output)]))
diff --git a/src/lux/type.clj b/src/lux/type.clj
index 9d9cf77aa..0c1b34070 100644
--- a/src/lux/type.clj
+++ b/src/lux/type.clj
@@ -1,5 +1,5 @@
(ns lux.type
- (:refer-clojure :exclude [resolve apply])
+ (:refer-clojure :exclude [deref apply merge])
(:require [clojure.core.match :refer [match]]
[lux.util :as &util :refer [exec return* return fail fail*
repeat-m try-m try-all-m map-m
@@ -9,7 +9,7 @@
;; [Util]
(def ^:private success (return nil))
-(defn ^:private resolve [id]
+(defn ^:private deref [id]
(fn [state]
(if-let [top+bottom (get-in state [::&util/types ::mappings id])]
[::&util/ok [state top+bottom]]
@@ -45,7 +45,7 @@
;; success
;; [_ [::var ?id]]
-;; (exec [[=top =bottom] (resolve ?id)]
+;; (exec [[=top =bottom] (deref ?id)]
;; (try-all-m [(exec [_ (solve expected =top)]
;; success)
;; (exec [_ (solve =top expected)
@@ -54,7 +54,7 @@
;; success)]))
;; [[::var ?id] _]
-;; (exec [[=top =bottom] (resolve ?id)]
+;; (exec [[=top =bottom] (deref ?id)]
;; (try-all-m [(exec [_ (solve =bottom actual)]
;; success)
;; (exec [_ (solve actual =bottom)
@@ -99,7 +99,7 @@
(defn clean [type]
(match type
[::var ?id]
- (exec [[=top =bottom] (resolve ?id)]
+ (exec [[=top =bottom] (deref ?id)]
(clean =top))
[::function ?args ?return]
@@ -110,8 +110,9 @@
;; ::any
;; (return [::object "java.lang.Object" []])
- _
- (return type)))
+ ;; _
+ ;; (return type)
+ ))
;; Java Reflection
(def success (return nil))
@@ -160,6 +161,40 @@
(solve n!output g!output))
))
+(let [&& #(and %1 %2)]
+ (defn merge [x y]
+ (match [x y]
+ [_ [::Nothing]]
+ (return x)
+
+ [[::Nothing] _]
+ (return y)
+
+ [[::Variant x!cases] [::Variant y!cases]]
+ (and (reduce && true
+ (for [[xslot xtype] (keys x!cases)]
+ (if-let [ytype (get y!cases xslot)]
+ (= xtype ytype)
+ true)))
+ (reduce && true
+ (for [[yslot ytype] (keys y!cases)]
+ (if-let [xtype (get x!cases yslot)]
+ (= xtype ytype)
+ true))))
+ (return [::Variant (clojure.core/merge x!cases y!cases)])
+ (fail (str "Incompatible variants: " (pr-str x) " and " (pr-str y)))
+
+ [[::Record x!fields] [::Record y!fields]]
+ (if (and (= (keys x!fields) (keys y!fields))
+ (->> (keys x!fields)
+ (map #(= (get x!fields %) (get y!fields %)))
+ (reduce && true)))
+ (return x)
+ (fail (str "Incompatible records: " (pr-str x) " and " (pr-str y))))
+
+ :else
+ (fail (str "Can't merge types: " (pr-str x) " and " (pr-str y))))))
+
(comment
;; Types
[::Any]