From 9eaaaf953ba7ce1eeb805603f4e113aa15f5178f Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Mon, 8 Jan 2018 21:40:06 -0400
Subject: - Moved all translation code under the JVM path (in preparation for
porting the JS back-end).
---
new-luxc/source/luxc/lang/analysis/expression.lux | 2 +-
new-luxc/source/luxc/lang/eval.lux | 4 +-
new-luxc/source/luxc/lang/extension/statement.lux | 6 +-
new-luxc/source/luxc/lang/host.jvm.lux | 2 +-
new-luxc/source/luxc/lang/macro.lux | 2 +-
new-luxc/source/luxc/lang/translation.lux | 15 +-
new-luxc/source/luxc/lang/translation/case.jvm.lux | 230 ------
.../source/luxc/lang/translation/common.jvm.lux | 136 ----
new-luxc/source/luxc/lang/translation/eval.jvm.lux | 47 --
.../luxc/lang/translation/expression.jvm.lux | 76 --
.../source/luxc/lang/translation/function.jvm.lux | 325 ---------
.../source/luxc/lang/translation/imports.jvm.lux | 149 ----
.../source/luxc/lang/translation/jvm/case.jvm.lux | 230 ++++++
.../luxc/lang/translation/jvm/common.jvm.lux | 136 ++++
.../source/luxc/lang/translation/jvm/eval.jvm.lux | 46 ++
.../luxc/lang/translation/jvm/expression.jvm.lux | 80 ++
.../luxc/lang/translation/jvm/function.jvm.lux | 325 +++++++++
.../luxc/lang/translation/jvm/imports.jvm.lux | 149 ++++
.../source/luxc/lang/translation/jvm/loop.jvm.lux | 80 ++
.../luxc/lang/translation/jvm/primitive.jvm.lux | 35 +
.../luxc/lang/translation/jvm/procedure.jvm.lux | 27 +
.../lang/translation/jvm/procedure/common.jvm.lux | 809 +++++++++++++++++++++
.../lang/translation/jvm/procedure/host.jvm.lux | 761 +++++++++++++++++++
.../luxc/lang/translation/jvm/reference.jvm.lux | 49 ++
.../luxc/lang/translation/jvm/runtime.jvm.lux | 603 +++++++++++++++
.../luxc/lang/translation/jvm/statement.jvm.lux | 159 ++++
.../luxc/lang/translation/jvm/structure.jvm.lux | 61 ++
new-luxc/source/luxc/lang/translation/loop.jvm.lux | 80 --
.../source/luxc/lang/translation/primitive.jvm.lux | 35 -
.../source/luxc/lang/translation/procedure.jvm.lux | 27 -
.../luxc/lang/translation/procedure/common.jvm.lux | 809 ---------------------
.../luxc/lang/translation/procedure/host.jvm.lux | 761 -------------------
.../source/luxc/lang/translation/reference.jvm.lux | 49 --
.../source/luxc/lang/translation/runtime.jvm.lux | 603 ---------------
.../source/luxc/lang/translation/statement.jvm.lux | 159 ----
.../source/luxc/lang/translation/structure.jvm.lux | 61 --
new-luxc/source/luxc/repl.lux | 2 +-
37 files changed, 3566 insertions(+), 3564 deletions(-)
delete mode 100644 new-luxc/source/luxc/lang/translation/case.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/common.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/eval.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/expression.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/function.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/imports.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/statement.jvm.lux
create mode 100644 new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/loop.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/primitive.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/procedure.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/reference.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/runtime.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/statement.jvm.lux
delete mode 100644 new-luxc/source/luxc/lang/translation/structure.jvm.lux
diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux
index d19e98bd8..8907ba665 100644
--- a/new-luxc/source/luxc/lang/analysis/expression.lux
+++ b/new-luxc/source/luxc/lang/analysis/expression.lux
@@ -15,7 +15,7 @@
[".L" macro]
[".L" extension]
["la" analysis]
- (translation [".T" common])))
+ (translation (jvm [".T" common]))))
(// [".A" common]
[".A" function]
[".A" primitive]
diff --git a/new-luxc/source/luxc/lang/eval.lux b/new-luxc/source/luxc/lang/eval.lux
index 87cbadfa0..eb16cc433 100644
--- a/new-luxc/source/luxc/lang/eval.lux
+++ b/new-luxc/source/luxc/lang/eval.lux
@@ -6,8 +6,8 @@
(lang [".L" extension]
(analysis [".A" expression])
(synthesis [".S" expression])
- (translation [".T" expression]
- [".T" eval]))))
+ (translation (jvm [".T" expression]
+ [".T" eval])))))
(def: #export (eval type exprC)
&.Eval
diff --git a/new-luxc/source/luxc/lang/extension/statement.lux b/new-luxc/source/luxc/lang/extension/statement.lux
index 7eb2b36bf..31e1759a0 100644
--- a/new-luxc/source/luxc/lang/extension/statement.lux
+++ b/new-luxc/source/luxc/lang/extension/statement.lux
@@ -17,9 +17,9 @@
(analysis [".A" common]
[".A" expression])
(synthesis [".S" expression])
- (translation [".T" expression]
- [".T" statement]
- [".T" eval])
+ (translation (jvm [".T" expression]
+ [".T" statement]
+ [".T" eval]))
[".L" eval])))
(exception: #export Invalid-Statement)
diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux
index 6eb8aacbc..7ec0df535 100644
--- a/new-luxc/source/luxc/lang/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/host.jvm.lux
@@ -14,7 +14,7 @@
[io])
(luxc ["&" lang]
(lang [".L" variable #+ Register]
- (translation [".T" common]))))
+ (translation (jvm [".T" common])))))
(host.import org/objectweb/asm/Label)
diff --git a/new-luxc/source/luxc/lang/macro.lux b/new-luxc/source/luxc/lang/macro.lux
index 71b140c6e..deebba0bf 100644
--- a/new-luxc/source/luxc/lang/macro.lux
+++ b/new-luxc/source/luxc/lang/macro.lux
@@ -5,7 +5,7 @@
[macro]
[host])
(luxc (lang [".L" host]
- (translation [".T" common]))))
+ (translation (jvm [".T" common])))))
(for {"JVM" (as-is (host.import java/lang/reflect/Method
(invoke [Object (Array Object)] #try Object))
diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux
index 9a2b27122..cbd63b998 100644
--- a/new-luxc/source/luxc/lang/translation.lux
+++ b/new-luxc/source/luxc/lang/translation.lux
@@ -34,14 +34,13 @@
(analysis [".A" expression]
[".A" common])
(synthesis [".S" expression])
- (translation [".T" runtime]
- [".T" statement]
- [".T" common #+ Artifacts]
- [".T" expression]
- [".T" eval]
- [".T" imports])
- ["&." eval])
- ))
+ ["&." eval]))
+ (/ (jvm [".T" runtime]
+ [".T" statement]
+ [".T" common #+ Artifacts]
+ [".T" expression]
+ [".T" eval]
+ [".T" imports])))
(def: analyse
(&.Analyser)
diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux
deleted file mode 100644
index b693f50b8..000000000
--- a/new-luxc/source/luxc/lang/translation/case.jvm.lux
+++ /dev/null
@@ -1,230 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- (data text/format)
- [macro "macro/" Monad])
- (luxc ["_" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$i" inst]))
- ["ls" synthesis]))
- [//runtime])
-
-(def: $Object $.Type ($t.class "java.lang.Object" (list)))
-
-(def: (pop-altI stack-depth)
- (-> Nat $.Inst)
- (case stack-depth
- +0 id
- +1 $i.POP
- +2 $i.POP2
- _ ## (n/> +2)
- (|>> $i.POP2
- (pop-altI (n/- +2 stack-depth)))))
-
-(def: peekI
- $.Inst
- (|>> $i.DUP
- ($i.INVOKESTATIC hostL.runtime-class
- "pm_peek"
- ($t.method (list //runtime.$Stack)
- (#.Some $Object)
- (list))
- false)))
-
-(def: popI
- $.Inst
- (|>> ($i.INVOKESTATIC hostL.runtime-class
- "pm_pop"
- ($t.method (list //runtime.$Stack)
- (#.Some //runtime.$Stack)
- (list))
- false)))
-
-(def: pushI
- $.Inst
- (|>> ($i.INVOKESTATIC hostL.runtime-class
- "pm_push"
- ($t.method (list //runtime.$Stack $Object)
- (#.Some //runtime.$Stack)
- (list))
- false)))
-
-(exception: #export Unrecognized-Path)
-
-(def: (translate-path' translate stack-depth @else @end path)
- (-> (-> ls.Synthesis (Meta $.Inst))
- Nat $.Label $.Label ls.Path (Meta $.Inst))
- (case path
- (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))])
- (do macro.Monad
- [bodyI (translate bodyS)]
- (wrap (|>> (pop-altI stack-depth)
- bodyI
- ($i.GOTO @end))))
-
- (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))])
- (macro/wrap popI)
-
- (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))])
- (macro/wrap (|>> peekI
- ($i.ASTORE register)))
-
- [_ (#.Bool value)]
- (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)]
- (|>> peekI
- ($i.unwrap #$.Boolean)
- (jumpI @else))))
-
- (^template [ ]
- [_ ( value)]
- (macro/wrap (|>> peekI
- ($i.unwrap #$.Long)
- ($i.long (|> value ))
- $i.LCMP
- ($i.IFNE @else))))
- ([#.Nat (:! Int)]
- [#.Int (: Int)]
- [#.Deg (:! Int)])
-
- [_ (#.Frac value)]
- (macro/wrap (|>> peekI
- ($i.unwrap #$.Double)
- ($i.double value)
- $i.DCMPL
- ($i.IFNE @else)))
-
- [_ (#.Text value)]
- (macro/wrap (|>> peekI
- ($i.string value)
- ($i.INVOKEVIRTUAL "java.lang.Object"
- "equals"
- ($t.method (list $Object)
- (#.Some $t.boolean)
- (list))
- false)
- ($i.IFEQ @else)))
-
- (^template [ ]
- (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
- (macro/wrap (case idx
- +0
- (|>> peekI
- ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
- ($i.int 0)
- $i.AALOAD
- pushI)
-
- _
- (|>> peekI
- ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
- ($i.int (nat-to-int idx))
- ($i.INVOKESTATIC hostL.runtime-class
-
- ($t.method (list //runtime.$Tuple $t.int)
- (#.Some $Object)
- (list))
- false)
- pushI))))
- (["lux case tuple left" "pm_left"]
- ["lux case tuple right" "pm_right"])
-
- (^template [ ]
- (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
- (macro/wrap (<| $i.with-label (function [@success])
- $i.with-label (function [@fail])
- (|>> peekI
- ($i.CHECKCAST ($t.descriptor //runtime.$Variant))
- ($i.int (nat-to-int idx))
-
- ($i.INVOKESTATIC hostL.runtime-class "pm_variant"
- ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag)
- (#.Some //runtime.$Datum)
- (list))
- false)
- $i.DUP
- ($i.IFNULL @fail)
- ($i.GOTO @success)
- ($i.label @fail)
- $i.POP
- ($i.GOTO @else)
- ($i.label @success)
- pushI))))
- (["lux case variant left" $i.NULL]
- ["lux case variant right" ($i.string "")])
-
- (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))])
- (do macro.Monad
- [leftI (translate-path' translate stack-depth @else @end leftP)
- rightI (translate-path' translate stack-depth @else @end rightP)]
- (wrap (|>> leftI
- rightI)))
-
- (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))])
- (do macro.Monad
- [@alt-else $i.make-label
- leftI (translate-path' translate (n/inc stack-depth) @alt-else @end leftP)
- rightI (translate-path' translate stack-depth @else @end rightP)]
- (wrap (|>> $i.DUP
- leftI
- ($i.label @alt-else)
- $i.POP
- rightI)))
-
- _
- (_.throw Unrecognized-Path (%code path))))
-
-(def: (translate-path translate path @end)
- (-> (-> ls.Synthesis (Meta $.Inst))
- ls.Path $.Label (Meta $.Inst))
- (do macro.Monad
- [@else $i.make-label
- pathI (translate-path' translate +1 @else @end path)]
- (wrap (|>> pathI
- ($i.label @else)
- $i.POP
- ($i.INVOKESTATIC hostL.runtime-class
- "pm_fail"
- ($t.method (list) #.None (list))
- false)
- $i.NULL
- ($i.GOTO @end)))))
-
-(def: #export (translate-if testI thenI elseI)
- (-> $.Inst $.Inst $.Inst $.Inst)
- (<| $i.with-label (function [@else])
- $i.with-label (function [@end])
- (|>> testI
- ($i.unwrap #$.Boolean)
- ($i.IFEQ @else)
- thenI
- ($i.GOTO @end)
- ($i.label @else)
- elseI
- ($i.label @end))))
-
-(def: #export (translate-case translate valueS path)
- (-> (-> ls.Synthesis (Meta $.Inst))
- ls.Synthesis ls.Path (Meta $.Inst))
- (do macro.Monad
- [@end $i.make-label
- valueI (translate valueS)
- pathI (translate-path translate path @end)]
- (wrap (|>> valueI
- $i.NULL
- $i.SWAP
- pushI
- pathI
- ($i.label @end)))))
-
-(def: #export (translate-let translate register inputS exprS)
- (-> (-> ls.Synthesis (Meta $.Inst))
- Nat ls.Synthesis ls.Synthesis (Meta $.Inst))
- (do macro.Monad
- [inputI (translate inputS)
- exprI (translate exprS)]
- (wrap (|>> inputI
- ($i.ASTORE register)
- exprI))))
diff --git a/new-luxc/source/luxc/lang/translation/common.jvm.lux b/new-luxc/source/luxc/lang/translation/common.jvm.lux
deleted file mode 100644
index a4eb5b93b..000000000
--- a/new-luxc/source/luxc/lang/translation/common.jvm.lux
+++ /dev/null
@@ -1,136 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["ex" exception #+ exception:])
- [io]
- (concurrency [atom #+ Atom atom])
- (data ["e" error #+ Error]
- [text "text/" Hash]
- text/format
- (coll [dict #+ Dict]))
- [macro]
- [host]
- (world [blob #+ Blob]
- [file #+ File]))
- (luxc [lang]
- (lang [".L" variable #+ Register]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst])))))
-
-(host.import org/objectweb/asm/Opcodes
- (#static V1_6 int))
-
-(host.import org/objectweb/asm/Label)
-
-(host.import java/lang/Object)
-
-(host.import java/lang/reflect/Field
- (get [#? Object] #try #? Object))
-
-(host.import (java/lang/Class c)
- (getField [String] #try Field))
-
-(host.import java/lang/ClassLoader
- (loadClass [String] (Class Object)))
-
-(type: #export Bytecode Blob)
-
-(type: #export Class-Store (Atom (Dict Text Bytecode)))
-
-(type: #export Artifacts (Dict File Blob))
-
-(type: #export Host
- {#loader ClassLoader
- #store Class-Store
- #artifacts Artifacts
- #context [Text Nat]
- #anchor (Maybe [Label Register])})
-
-(exception: #export Unknown-Class)
-(exception: #export Class-Already-Stored)
-(exception: #export No-Function-Being-Compiled)
-(exception: #export Cannot-Overwrite-Artifact)
-(exception: #export Cannot-Load-Definition)
-(exception: #export Invalid-Definition-Value)
-
-(def: #export (with-artifacts action)
- (All [a] (-> (Meta a) (Meta [Artifacts a])))
- (function [compiler]
- (case (action (update@ #.host
- (|>> (:! Host)
- (set@ #artifacts (dict.new text.Hash))
- (:! Void))
- compiler))
- (#e.Success [compiler' output])
- (#e.Success [(update@ #.host
- (|>> (:! Host)
- (set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts)))
- (:! Void))
- compiler')
- [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts))
- output]])
-
- (#e.Error error)
- (#e.Error error))))
-
-(def: #export (record-artifact name content)
- (-> Text Blob (Meta Unit))
- (function [compiler]
- (if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name))
- (ex.throw Cannot-Overwrite-Artifact name)
- (#e.Success [(update@ #.host
- (|>> (:! Host)
- (update@ #artifacts (dict.put name content))
- (:! Void))
- compiler)
- []]))))
-
-(def: #export (store-class name byte-code)
- (-> Text Bytecode (Meta Unit))
- (function [compiler]
- (let [store (|> (get@ #.host compiler)
- (:! Host)
- (get@ #store))]
- (if (dict.contains? name (|> store atom.read io.run))
- (ex.throw Class-Already-Stored name)
- (#e.Success [compiler (io.run (atom.update (dict.put name byte-code) store))])
- ))))
-
-(def: #export (load-class name)
- (-> Text (Meta (Class Object)))
- (function [compiler]
- (let [host (:! Host (get@ #.host compiler))
- store (|> host (get@ #store) atom.read io.run)]
- (if (dict.contains? name store)
- (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))])
- (ex.throw Unknown-Class name)))))
-
-(def: #export value-field Text "_value")
-(def: #export $Object $.Type ($t.class "java.lang.Object" (list)))
-
-(def: #export (load-definition compiler)
- (-> Compiler
- (-> Ident Blob (Error Top)))
- (function [(^@ def-ident [def-module def-name]) def-bytecode]
- (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name)))
- class-name (format (text.replace-all "/" "." def-module) "." normal-name)]
- (<| (macro.run compiler)
- (do macro.Monad
- [_ (..store-class class-name def-bytecode)
- class (..load-class class-name)]
- (case (do e.Monad
- [field (Class::getField [..value-field] class)]
- (Field::get [#.None] field))
- (#e.Success (#.Some def-value))
- (wrap def-value)
-
- (#e.Success #.None)
- (lang.throw Invalid-Definition-Value (%ident def-ident))
-
- (#e.Error error)
- (lang.throw Cannot-Load-Definition
- (format "Definition: " (%ident def-ident) "\n"
- "Error:\n"
- error))))))))
diff --git a/new-luxc/source/luxc/lang/translation/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/eval.jvm.lux
deleted file mode 100644
index 9cce16a49..000000000
--- a/new-luxc/source/luxc/lang/translation/eval.jvm.lux
+++ /dev/null
@@ -1,47 +0,0 @@
-(.module:
- lux
- (lux (control monad)
- (data [text]
- text/format)
- [macro]
- [host #+ do-to])
- (luxc ["&" lang]
- (lang (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- ["la" analysis]
- ["ls" synthesis]
- (translation [".T" common]))
- ))
-
-(host.import java/lang/reflect/Field
- (get [Object] Object))
-
-(host.import (java/lang/Class a)
- (getField [String] Field))
-
-(def: #export (eval valueI)
- (-> $.Inst (Meta Top))
- (do macro.Monad
- [current-module macro.current-module-name
- class-name (:: @ map %code (macro.gensym (format current-module "/eval")))
- #let [store-name (text.replace-all "/" "." class-name)
- bytecode ($d.class #$.V1_6
- #$.Public $.noneC
- class-name
- (list) ["java.lang.Object" (list)]
- (list)
- (|>> ($d.field #$.Public ($_ $.++F $.finalF $.staticF)
- commonT.value-field commonT.$Object)
- ($d.method #$.Public ($_ $.++M $.staticM $.strictM)
- ""
- ($t.method (list) #.None (list))
- (|>> valueI
- ($i.PUTSTATIC store-name commonT.value-field commonT.$Object)
- $i.RETURN))))]
- _ (commonT.store-class store-name bytecode)
- class (commonT.load-class store-name)]
- (wrap (|> class
- (Class::getField [commonT.value-field])
- (Field::get (host.null))))))
diff --git a/new-luxc/source/luxc/lang/translation/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/expression.jvm.lux
deleted file mode 100644
index 4496de784..000000000
--- a/new-luxc/source/luxc/lang/translation/expression.jvm.lux
+++ /dev/null
@@ -1,76 +0,0 @@
-(.module:
- lux
- (lux (control monad
- ["ex" exception #+ exception:]
- ["p" parser])
- (data ["e" error]
- text/format)
- [macro]
- (macro ["s" syntax]))
- (luxc ["&" lang]
- (lang [".L" variable #+ Variable Register]
- (host ["$" jvm])
- ["ls" synthesis]
- (translation [".T" common]
- [".T" primitive]
- [".T" structure]
- [".T" eval]
- [".T" procedure]
- [".T" function]
- [".T" reference]
- [".T" case]))))
-
-(exception: #export Unrecognized-Synthesis)
-
-(def: #export (translate synthesis)
- (-> ls.Synthesis (Meta $.Inst))
- (case synthesis
- (^code [])
- primitiveT.translate-unit
-
- (^code [(~ singleton)])
- (translate singleton)
-
- (^template [ ]
- [_ ( value)]
- ( value))
- ([#.Bool primitiveT.translate-bool]
- [#.Nat primitiveT.translate-nat]
- [#.Int primitiveT.translate-int]
- [#.Deg primitiveT.translate-deg]
- [#.Frac primitiveT.translate-frac]
- [#.Text primitiveT.translate-text])
-
- (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS)))
- (structureT.translate-variant translate tag last? valueS)
-
- (^code [(~+ members)])
- (structureT.translate-tuple translate members)
-
- (^ [_ (#.Form (list [_ (#.Int var)]))])
- (if (variableL.captured? var)
- (referenceT.translate-captured var)
- (referenceT.translate-local var))
-
- [_ (#.Symbol definition)]
- (referenceT.translate-definition definition)
-
- (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS)))
- (caseT.translate-let translate register inputS exprS)
-
- (^code ("lux case" (~ inputS) (~ pathPS)))
- (caseT.translate-case translate inputS pathPS)
-
- (^multi (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS)))
- [(s.run environment (p.some s.int)) (#e.Success environment)])
- (functionT.translate-function translate environment arity bodyS)
-
- (^code ("lux call" (~ functionS) (~+ argsS)))
- (functionT.translate-call translate functionS argsS)
-
- (^code ((~ [_ (#.Text procedure)]) (~+ argsS)))
- (procedureT.translate-procedure translate procedure argsS)
-
- _
- (&.throw Unrecognized-Synthesis (%code synthesis))
- ))
diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux
deleted file mode 100644
index 3070800fe..000000000
--- a/new-luxc/source/luxc/lang/translation/function.jvm.lux
+++ /dev/null
@@ -1,325 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do])
- (data [text]
- text/format
- (coll [list "list/" Functor Monoid]))
- [macro])
- (luxc ["&" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- ["la" analysis]
- ["ls" synthesis]
- (translation [".T" common]
- [".T" runtime]
- [".T" reference])
- [".L" variable #+ Variable])))
-
-
-(def: arity-field Text "arity")
-(def: $Object $.Type ($t.class "java.lang.Object" (list)))
-
-(def: (poly-arg? arity)
- (-> ls.Arity Bool)
- (n/> +1 arity))
-
-(def: (reset-method class)
- (-> Text $.Method)
- ($t.method (list) (#.Some ($t.class class (list))) (list)))
-
-(def: (captured-args env)
- (-> (List Variable) (List $.Type))
- (list.repeat (list.size env) $Object))
-
-(def: (init-method env arity)
- (-> (List Variable) ls.Arity $.Method)
- (if (poly-arg? arity)
- ($t.method (list.concat (list (captured-args env)
- (list $t.int)
- (list.repeat (n/dec arity) $Object)))
- #.None
- (list))
- ($t.method (captured-args env) #.None (list))))
-
-(def: (implementation-method arity)
- ($t.method (list.repeat arity $Object) (#.Some $Object) (list)))
-
-(def: get-amount-of-partialsI
- $.Inst
- (|>> ($i.ALOAD +0)
- ($i.GETFIELD hostL.function-class runtimeT.partials-field $t.int)))
-
-(def: (load-fieldI class field)
- (-> Text Text $.Inst)
- (|>> ($i.ALOAD +0)
- ($i.GETFIELD class field $Object)))
-
-(def: (inputsI start amount)
- (-> $.Register Nat $.Inst)
- (|> (list.n/range start (n/+ start (n/dec amount)))
- (list/map $i.ALOAD)
- $i.fuse))
-
-(def: (applysI start amount)
- (-> $.Register Nat $.Inst)
- (let [max-args (n/min amount runtimeT.num-apply-variants)
- later-applysI (if (n/> runtimeT.num-apply-variants amount)
- (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount))
- id)]
- (|>> ($i.CHECKCAST hostL.function-class)
- (inputsI start max-args)
- ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature max-args) false)
- later-applysI)))
-
-(def: (inc-intI by)
- (-> Nat $.Inst)
- (|>> ($i.int (nat-to-int by))
- $i.IADD))
-
-(def: (nullsI amount)
- (-> Nat $.Inst)
- (|> $i.NULL
- (list.repeat amount)
- $i.fuse))
-
-(def: (with-captured env)
- (-> (List Variable) $.Def)
- (|> (list.enumerate env)
- (list/map (function [[env-idx env-source]]
- ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object)))
- $d.fuse))
-
-(def: (with-partial arity)
- (-> ls.Arity $.Def)
- (if (poly-arg? arity)
- (|> (list.n/range +0 (n/- +2 arity))
- (list/map (function [idx]
- ($d.field #$.Private $.finalF (referenceT.partial idx) $Object)))
- $d.fuse)
- id))
-
-(def: (instance class arity env)
- (-> Text ls.Arity (List Variable) (Meta $.Inst))
- (do macro.Monad
- [captureI+ (monad.map @ referenceT.translate-variable env)
- #let [argsI (if (poly-arg? arity)
- (|> (nullsI (n/dec arity))
- (list ($i.int 0))
- $i.fuse)
- id)]]
- (wrap (|>> ($i.NEW class)
- $i.DUP
- ($i.fuse captureI+)
- argsI
- ($i.INVOKESPECIAL class "" (init-method env arity) false)))))
-
-(def: (with-reset class arity env)
- (-> Text ls.Arity (List Variable) $.Def)
- ($d.method #$.Public $.noneM "reset" (reset-method class)
- (if (poly-arg? arity)
- (let [env-size (list.size env)
- captureI (|> (case env-size
- +0 (list)
- _ (list.n/range +0 (n/dec env-size)))
- (list/map (function [source]
- (|>> ($i.ALOAD +0)
- ($i.GETFIELD class (referenceT.captured source) $Object))))
- $i.fuse)
- argsI (|> (nullsI (n/dec arity))
- (list ($i.int 0))
- $i.fuse)]
- (|>> ($i.NEW class)
- $i.DUP
- captureI
- argsI
- ($i.INVOKESPECIAL class "" (init-method env arity) false)
- $i.ARETURN))
- (|>> ($i.ALOAD +0)
- $i.ARETURN))))
-
-(def: (with-implementation arity @begin bodyI)
- (-> Nat $.Label $.Inst $.Def)
- ($d.method #$.Public $.strictM "impl" (implementation-method arity)
- (|>> ($i.label @begin)
- bodyI
- $i.ARETURN)))
-
-(def: function-init-method
- $.Method
- ($t.method (list $t.int) #.None (list)))
-
-(def: (function-init arity env-size)
- (-> ls.Arity Nat $.Inst)
- (if (n/= +1 arity)
- (|>> ($i.int 0)
- ($i.INVOKESPECIAL hostL.function-class "" function-init-method false))
- (|>> ($i.ILOAD (n/inc env-size))
- ($i.INVOKESPECIAL hostL.function-class "" function-init-method false))))
-
-(def: (with-init class env arity)
- (-> Text (List Variable) ls.Arity $.Def)
- (let [env-size (list.size env)
- offset-partial (: (-> Nat Nat)
- (|>> n/inc (n/+ env-size)))
- store-capturedI (|> (case env-size
- +0 (list)
- _ (list.n/range +0 (n/dec env-size)))
- (list/map (function [register]
- (|>> ($i.ALOAD +0)
- ($i.ALOAD (n/inc register))
- ($i.PUTFIELD class (referenceT.captured register) $Object))))
- $i.fuse)
- store-partialI (if (poly-arg? arity)
- (|> (list.n/range +0 (n/- +2 arity))
- (list/map (function [idx]
- (let [register (offset-partial idx)]
- (|>> ($i.ALOAD +0)
- ($i.ALOAD (n/inc register))
- ($i.PUTFIELD class (referenceT.partial idx) $Object)))))
- $i.fuse)
- id)]
- ($d.method #$.Public $.noneM "" (init-method env arity)
- (|>> ($i.ALOAD +0)
- (function-init arity env-size)
- store-capturedI
- store-partialI
- $i.RETURN))))
-
-(def: (with-apply class env function-arity @begin bodyI apply-arity)
- (-> Text (List Variable) ls.Arity $.Label $.Inst ls.Arity
- $.Def)
- (let [num-partials (n/dec function-arity)
- @default ($.new-label [])
- @labels (list/map $.new-label (list.repeat num-partials []))
- arity-over-extent (|> (nat-to-int function-arity) (i/- (nat-to-int apply-arity)))
- casesI (|> (list/compose @labels (list @default))
- (list.zip2 (list.n/range +0 num-partials))
- (list/map (function [[stage @label]]
- (let [load-partialsI (if (n/> +0 stage)
- (|> (list.n/range +0 (n/dec stage))
- (list/map (|>> referenceT.partial (load-fieldI class)))
- $i.fuse)
- id)]
- (cond (i/= arity-over-extent (nat-to-int stage))
- (|>> ($i.label @label)
- ($i.ALOAD +0)
- (when (n/> +0 stage)
- ($i.INVOKEVIRTUAL class "reset" (reset-method class) false))
- load-partialsI
- (inputsI +1 apply-arity)
- ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
- $i.ARETURN)
-
- (i/> arity-over-extent (nat-to-int stage))
- (let [args-to-completion (|> function-arity (n/- stage))
- args-left (|> apply-arity (n/- args-to-completion))]
- (|>> ($i.label @label)
- ($i.ALOAD +0)
- ($i.INVOKEVIRTUAL class "reset" (reset-method class) false)
- load-partialsI
- (inputsI +1 args-to-completion)
- ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
- (applysI (n/inc args-to-completion) args-left)
- $i.ARETURN))
-
- ## (i/< arity-over-extent (nat-to-int stage))
- (let [env-size (list.size env)
- load-capturedI (|> (case env-size
- +0 (list)
- _ (list.n/range +0 (n/dec env-size)))
- (list/map (|>> referenceT.captured (load-fieldI class)))
- $i.fuse)]
- (|>> ($i.label @label)
- ($i.NEW class)
- $i.DUP
- load-capturedI
- get-amount-of-partialsI
- (inc-intI apply-arity)
- load-partialsI
- (inputsI +1 apply-arity)
- (nullsI (|> num-partials (n/- apply-arity) (n/- stage)))
- ($i.INVOKESPECIAL class "" (init-method env function-arity) false)
- $i.ARETURN))
- ))))
- $i.fuse)]
- ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.apply-signature apply-arity)
- (|>> get-amount-of-partialsI
- ($i.TABLESWITCH 0 (|> num-partials n/dec nat-to-int)
- @default @labels)
- casesI
- ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false)
- $i.NULL
- $i.ARETURN
- ))))
-
-(def: #export (with-function @begin class env arity bodyI)
- (-> $.Label Text (List Variable) ls.Arity $.Inst
- (Meta [$.Def $.Inst]))
- (let [env-size (list.size env)
- applyD (: $.Def
- (if (poly-arg? arity)
- (|> (n/min arity runtimeT.num-apply-variants)
- (list.n/range +1)
- (list/map (with-apply class env arity @begin bodyI))
- (list& (with-implementation arity @begin bodyI))
- $d.fuse)
- ($d.method #$.Public $.strictM runtimeT.apply-method (runtimeT.apply-signature +1)
- (|>> ($i.label @begin)
- bodyI
- $i.ARETURN))))
- functionD (: $.Def
- (|>> ($d.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (nat-to-int arity))
- (with-captured env)
- (with-partial arity)
- (with-init class env arity)
- (with-reset class arity env)
- applyD
- ))]
- (do macro.Monad
- [instanceI (instance class arity env)]
- (wrap [functionD instanceI]))))
-
-(def: #export (translate-function translate env arity bodyS)
- (-> (-> ls.Synthesis (Meta $.Inst))
- (List Variable) ls.Arity ls.Synthesis
- (Meta $.Inst))
- (do macro.Monad
- [@begin $i.make-label
- [function-class bodyI] (hostL.with-sub-context
- (hostL.with-anchor [@begin +1]
- (translate bodyS)))
- this-module macro.current-module-name
- #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]
- [functionD instanceI] (with-function @begin function-class env arity bodyI)
- _ (commonT.store-class function-class
- ($d.class #$.V1_6 #$.Public $.finalC
- function-class (list)
- ($.simple-class hostL.function-class) (list)
- functionD))]
- (wrap instanceI)))
-
-(def: (segment size elems)
- (All [a] (-> Nat (List a) (List (List a))))
- (let [[pre post] (list.split size elems)]
- (if (list.empty? post)
- (list pre)
- (list& pre (segment size post)))))
-
-(def: #export (translate-call translate functionS argsS)
- (-> (-> ls.Synthesis (Meta $.Inst))
- ls.Synthesis (List ls.Synthesis)
- (Meta $.Inst))
- (do macro.Monad
- [functionI (translate functionS)
- argsI (monad.map @ translate argsS)
- #let [applyI (|> (segment runtimeT.num-apply-variants argsI)
- (list/map (function [chunkI+]
- (|>> ($i.CHECKCAST hostL.function-class)
- ($i.fuse chunkI+)
- ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false))))
- $i.fuse)]]
- (wrap (|>> functionI
- applyI))))
diff --git a/new-luxc/source/luxc/lang/translation/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/imports.jvm.lux
deleted file mode 100644
index 892dd869f..000000000
--- a/new-luxc/source/luxc/lang/translation/imports.jvm.lux
+++ /dev/null
@@ -1,149 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["p" parser]
- ["ex" exception #+ exception:]
- pipe)
- (concurrency [promise #+ Promise]
- [stm #+ Var STM])
- (data ["e" error #+ Error]
- [maybe]
- [product]
- [text "text/" Eq]
- text/format
- (coll [list "list/" Functor Fold]
- [dict #+ Dict]))
- [macro]
- (macro [code]
- ["s" syntax])
- [io #+ IO Process io]
- [host])
- (luxc ["&" lang]
- (lang [".L" module])))
-
-(exception: #export Invalid-Imports)
-(exception: #export Module-Cannot-Import-Itself)
-(exception: #export Circular-Dependency)
-
-(host.import (java/util/concurrent/Future a)
- (get [] #io a))
-
-(host.import (java/util/concurrent/CompletableFuture a)
- (new [])
- (complete [a] boolean)
- (#static [a] completedFuture [a] (CompletableFuture a)))
-
-(type: Import
- {#module Text
- #alias Text})
-
-(def: import (s.Syntax Import) (s.tuple (p.seq s.text s.text)))
-
-(def: compilations
- (Var (Dict Text (CompletableFuture (Error Compiler))))
- (stm.var (dict.new text.Hash)))
-
-(def: (promise-to-future promise)
- (All [a] (-> (Promise a) (Future a)))
- (let [future (CompletableFuture::new [])]
- (exec (:: promise.Functor map
- (function [value] (CompletableFuture::complete [value] future))
- promise)
- future)))
-
-(def: from-io
- (All [a] (-> (IO a) (Process a)))
- (:: io.Monad map (|>> #e.Success)))
-
-(def: (translate-dependency translate-module dependency compiler)
- (-> (-> Text Compiler (Process Compiler))
- (-> Text Compiler (IO (Future (Error Compiler)))))
- (<| (Future::get [])
- promise-to-future
- (do promise.Monad
- [[new? future] (stm.commit (: (STM [Bool (CompletableFuture (Error Compiler))])
- (do stm.Monad
- [current-compilations (stm.read compilations)]
- (case (dict.get dependency current-compilations)
- (#.Some ongoing)
- (wrap [false ongoing])
-
- #.None
- (do @
- [#let [pending (: (CompletableFuture (Error Compiler))
- (CompletableFuture::new []))]
- _ (stm.write (dict.put dependency pending current-compilations)
- compilations)]
- (wrap [true pending]))))))]
- (if new?
- (exec (promise.future (io (CompletableFuture::complete [(io.run (translate-module dependency compiler))]
- future)))
- (wrap future))
- (wrap future)))))
-
-(def: compiled?
- (-> Module Bool)
- (|>> (get@ #.module-state)
- (case>
- (^or #.Cached #.Compiled)
- true
-
- _
- false)))
-
-(def: (merge-modules current-module from-dependency from-current)
- (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module]))
- (|> from-dependency
- (list.filter (|>> product.right compiled?))
- (list/fold (function [[dep-name dep-module] total] (&.pl-put dep-name dep-module total))
- from-current)))
-
-(def: (merge-compilers current-module dependency total)
- (-> Text Compiler Compiler Compiler)
- (|> total
- (update@ #.modules (merge-modules current-module (get@ #.modules dependency)))
- (set@ #.seed (get@ #.seed dependency))))
-
-(def: #export (translate-imports translate-module annotations)
- (-> (-> Text Compiler (Process Compiler))
- Code
- (Meta (Process Compiler)))
- (do macro.Monad
- [_ (moduleL.set-annotations annotations)
- current-module macro.current-module-name
- imports (let [imports (|> (macro.get-tuple-ann (ident-for #.imports) annotations)
- (maybe.default (list)))]
- (case (s.run imports (p.some import))
- (#e.Success imports)
- (wrap imports)
-
- (#e.Error error)
- (&.throw Invalid-Imports (%code (code.tuple imports)))))
- dependencies (monad.map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler)))))
- (function [[dependency alias]]
- (do @
- [_ (&.assert Module-Cannot-Import-Itself current-module
- (not (text/= current-module dependency)))
- already-seen? (moduleL.exists? dependency)
- circular-dependency? (if already-seen?
- (moduleL.active? dependency)
- (wrap false))
- _ (&.assert Circular-Dependency (format "From: " current-module "\n"
- " To: " dependency)
- (not circular-dependency?))
- _ (moduleL.import dependency)
- _ (if (text/= "" alias)
- (wrap [])
- (moduleL.alias alias dependency))
- compiler macro.get-compiler]
- (if already-seen?
- (wrap (io (CompletableFuture::completedFuture [(#e.Success compiler)])))
- (wrap (translate-dependency translate-module dependency compiler))))))
- imports)
- compiler macro.get-compiler]
- (wrap (do io.Monad
- [dependencies (monad.seq io.Monad (list/map from-io dependencies))
- dependencies (|> dependencies
- (list/map (Future::get []))
- (monad.seq io.Monad))]
- (wrap (list/fold (merge-compilers current-module) compiler dependencies))))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
new file mode 100644
index 000000000..b693f50b8
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux
@@ -0,0 +1,230 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data text/format)
+ [macro "macro/" Monad])
+ (luxc ["_" lang]
+ (lang [".L" host]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$i" inst]))
+ ["ls" synthesis]))
+ [//runtime])
+
+(def: $Object $.Type ($t.class "java.lang.Object" (list)))
+
+(def: (pop-altI stack-depth)
+ (-> Nat $.Inst)
+ (case stack-depth
+ +0 id
+ +1 $i.POP
+ +2 $i.POP2
+ _ ## (n/> +2)
+ (|>> $i.POP2
+ (pop-altI (n/- +2 stack-depth)))))
+
+(def: peekI
+ $.Inst
+ (|>> $i.DUP
+ ($i.INVOKESTATIC hostL.runtime-class
+ "pm_peek"
+ ($t.method (list //runtime.$Stack)
+ (#.Some $Object)
+ (list))
+ false)))
+
+(def: popI
+ $.Inst
+ (|>> ($i.INVOKESTATIC hostL.runtime-class
+ "pm_pop"
+ ($t.method (list //runtime.$Stack)
+ (#.Some //runtime.$Stack)
+ (list))
+ false)))
+
+(def: pushI
+ $.Inst
+ (|>> ($i.INVOKESTATIC hostL.runtime-class
+ "pm_push"
+ ($t.method (list //runtime.$Stack $Object)
+ (#.Some //runtime.$Stack)
+ (list))
+ false)))
+
+(exception: #export Unrecognized-Path)
+
+(def: (translate-path' translate stack-depth @else @end path)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ Nat $.Label $.Label ls.Path (Meta $.Inst))
+ (case path
+ (^ [_ (#.Form (list [_ (#.Text "lux case exec")] bodyS))])
+ (do macro.Monad
+ [bodyI (translate bodyS)]
+ (wrap (|>> (pop-altI stack-depth)
+ bodyI
+ ($i.GOTO @end))))
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case pop")]))])
+ (macro/wrap popI)
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case bind")] [_ (#.Nat register)]))])
+ (macro/wrap (|>> peekI
+ ($i.ASTORE register)))
+
+ [_ (#.Bool value)]
+ (macro/wrap (let [jumpI (if value $i.IFEQ $i.IFNE)]
+ (|>> peekI
+ ($i.unwrap #$.Boolean)
+ (jumpI @else))))
+
+ (^template [ ]
+ [_ ( value)]
+ (macro/wrap (|>> peekI
+ ($i.unwrap #$.Long)
+ ($i.long (|> value ))
+ $i.LCMP
+ ($i.IFNE @else))))
+ ([#.Nat (:! Int)]
+ [#.Int (: Int)]
+ [#.Deg (:! Int)])
+
+ [_ (#.Frac value)]
+ (macro/wrap (|>> peekI
+ ($i.unwrap #$.Double)
+ ($i.double value)
+ $i.DCMPL
+ ($i.IFNE @else)))
+
+ [_ (#.Text value)]
+ (macro/wrap (|>> peekI
+ ($i.string value)
+ ($i.INVOKEVIRTUAL "java.lang.Object"
+ "equals"
+ ($t.method (list $Object)
+ (#.Some $t.boolean)
+ (list))
+ false)
+ ($i.IFEQ @else)))
+
+ (^template [ ]
+ (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
+ (macro/wrap (case idx
+ +0
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
+ ($i.int 0)
+ $i.AALOAD
+ pushI)
+
+ _
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor //runtime.$Tuple))
+ ($i.int (nat-to-int idx))
+ ($i.INVOKESTATIC hostL.runtime-class
+
+ ($t.method (list //runtime.$Tuple $t.int)
+ (#.Some $Object)
+ (list))
+ false)
+ pushI))))
+ (["lux case tuple left" "pm_left"]
+ ["lux case tuple right" "pm_right"])
+
+ (^template [ ]
+ (^ [_ (#.Form (list [_ (#.Text )] [_ (#.Nat idx)]))])
+ (macro/wrap (<| $i.with-label (function [@success])
+ $i.with-label (function [@fail])
+ (|>> peekI
+ ($i.CHECKCAST ($t.descriptor //runtime.$Variant))
+ ($i.int (nat-to-int idx))
+
+ ($i.INVOKESTATIC hostL.runtime-class "pm_variant"
+ ($t.method (list //runtime.$Variant //runtime.$Tag //runtime.$Flag)
+ (#.Some //runtime.$Datum)
+ (list))
+ false)
+ $i.DUP
+ ($i.IFNULL @fail)
+ ($i.GOTO @success)
+ ($i.label @fail)
+ $i.POP
+ ($i.GOTO @else)
+ ($i.label @success)
+ pushI))))
+ (["lux case variant left" $i.NULL]
+ ["lux case variant right" ($i.string "")])
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case seq")] leftP rightP))])
+ (do macro.Monad
+ [leftI (translate-path' translate stack-depth @else @end leftP)
+ rightI (translate-path' translate stack-depth @else @end rightP)]
+ (wrap (|>> leftI
+ rightI)))
+
+ (^ [_ (#.Form (list [_ (#.Text "lux case alt")] leftP rightP))])
+ (do macro.Monad
+ [@alt-else $i.make-label
+ leftI (translate-path' translate (n/inc stack-depth) @alt-else @end leftP)
+ rightI (translate-path' translate stack-depth @else @end rightP)]
+ (wrap (|>> $i.DUP
+ leftI
+ ($i.label @alt-else)
+ $i.POP
+ rightI)))
+
+ _
+ (_.throw Unrecognized-Path (%code path))))
+
+(def: (translate-path translate path @end)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ ls.Path $.Label (Meta $.Inst))
+ (do macro.Monad
+ [@else $i.make-label
+ pathI (translate-path' translate +1 @else @end path)]
+ (wrap (|>> pathI
+ ($i.label @else)
+ $i.POP
+ ($i.INVOKESTATIC hostL.runtime-class
+ "pm_fail"
+ ($t.method (list) #.None (list))
+ false)
+ $i.NULL
+ ($i.GOTO @end)))))
+
+(def: #export (translate-if testI thenI elseI)
+ (-> $.Inst $.Inst $.Inst $.Inst)
+ (<| $i.with-label (function [@else])
+ $i.with-label (function [@end])
+ (|>> testI
+ ($i.unwrap #$.Boolean)
+ ($i.IFEQ @else)
+ thenI
+ ($i.GOTO @end)
+ ($i.label @else)
+ elseI
+ ($i.label @end))))
+
+(def: #export (translate-case translate valueS path)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ ls.Synthesis ls.Path (Meta $.Inst))
+ (do macro.Monad
+ [@end $i.make-label
+ valueI (translate valueS)
+ pathI (translate-path translate path @end)]
+ (wrap (|>> valueI
+ $i.NULL
+ $i.SWAP
+ pushI
+ pathI
+ ($i.label @end)))))
+
+(def: #export (translate-let translate register inputS exprS)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ Nat ls.Synthesis ls.Synthesis (Meta $.Inst))
+ (do macro.Monad
+ [inputI (translate inputS)
+ exprI (translate exprS)]
+ (wrap (|>> inputI
+ ($i.ASTORE register)
+ exprI))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux
new file mode 100644
index 000000000..a4eb5b93b
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux
@@ -0,0 +1,136 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ [io]
+ (concurrency [atom #+ Atom atom])
+ (data ["e" error #+ Error]
+ [text "text/" Hash]
+ text/format
+ (coll [dict #+ Dict]))
+ [macro]
+ [host]
+ (world [blob #+ Blob]
+ [file #+ File]))
+ (luxc [lang]
+ (lang [".L" variable #+ Register]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst])))))
+
+(host.import org/objectweb/asm/Opcodes
+ (#static V1_6 int))
+
+(host.import org/objectweb/asm/Label)
+
+(host.import java/lang/Object)
+
+(host.import java/lang/reflect/Field
+ (get [#? Object] #try #? Object))
+
+(host.import (java/lang/Class c)
+ (getField [String] #try Field))
+
+(host.import java/lang/ClassLoader
+ (loadClass [String] (Class Object)))
+
+(type: #export Bytecode Blob)
+
+(type: #export Class-Store (Atom (Dict Text Bytecode)))
+
+(type: #export Artifacts (Dict File Blob))
+
+(type: #export Host
+ {#loader ClassLoader
+ #store Class-Store
+ #artifacts Artifacts
+ #context [Text Nat]
+ #anchor (Maybe [Label Register])})
+
+(exception: #export Unknown-Class)
+(exception: #export Class-Already-Stored)
+(exception: #export No-Function-Being-Compiled)
+(exception: #export Cannot-Overwrite-Artifact)
+(exception: #export Cannot-Load-Definition)
+(exception: #export Invalid-Definition-Value)
+
+(def: #export (with-artifacts action)
+ (All [a] (-> (Meta a) (Meta [Artifacts a])))
+ (function [compiler]
+ (case (action (update@ #.host
+ (|>> (:! Host)
+ (set@ #artifacts (dict.new text.Hash))
+ (:! Void))
+ compiler))
+ (#e.Success [compiler' output])
+ (#e.Success [(update@ #.host
+ (|>> (:! Host)
+ (set@ #artifacts (|> (get@ #.host compiler) (:! Host) (get@ #artifacts)))
+ (:! Void))
+ compiler')
+ [(|> compiler' (get@ #.host) (:! Host) (get@ #artifacts))
+ output]])
+
+ (#e.Error error)
+ (#e.Error error))))
+
+(def: #export (record-artifact name content)
+ (-> Text Blob (Meta Unit))
+ (function [compiler]
+ (if (|> compiler (get@ #.host) (:! Host) (get@ #artifacts) (dict.contains? name))
+ (ex.throw Cannot-Overwrite-Artifact name)
+ (#e.Success [(update@ #.host
+ (|>> (:! Host)
+ (update@ #artifacts (dict.put name content))
+ (:! Void))
+ compiler)
+ []]))))
+
+(def: #export (store-class name byte-code)
+ (-> Text Bytecode (Meta Unit))
+ (function [compiler]
+ (let [store (|> (get@ #.host compiler)
+ (:! Host)
+ (get@ #store))]
+ (if (dict.contains? name (|> store atom.read io.run))
+ (ex.throw Class-Already-Stored name)
+ (#e.Success [compiler (io.run (atom.update (dict.put name byte-code) store))])
+ ))))
+
+(def: #export (load-class name)
+ (-> Text (Meta (Class Object)))
+ (function [compiler]
+ (let [host (:! Host (get@ #.host compiler))
+ store (|> host (get@ #store) atom.read io.run)]
+ (if (dict.contains? name store)
+ (#e.Success [compiler (ClassLoader::loadClass [name] (get@ #loader host))])
+ (ex.throw Unknown-Class name)))))
+
+(def: #export value-field Text "_value")
+(def: #export $Object $.Type ($t.class "java.lang.Object" (list)))
+
+(def: #export (load-definition compiler)
+ (-> Compiler
+ (-> Ident Blob (Error Top)))
+ (function [(^@ def-ident [def-module def-name]) def-bytecode]
+ (let [normal-name (format (lang.normalize-name def-name) (%n (text/hash def-name)))
+ class-name (format (text.replace-all "/" "." def-module) "." normal-name)]
+ (<| (macro.run compiler)
+ (do macro.Monad
+ [_ (..store-class class-name def-bytecode)
+ class (..load-class class-name)]
+ (case (do e.Monad
+ [field (Class::getField [..value-field] class)]
+ (Field::get [#.None] field))
+ (#e.Success (#.Some def-value))
+ (wrap def-value)
+
+ (#e.Success #.None)
+ (lang.throw Invalid-Definition-Value (%ident def-ident))
+
+ (#e.Error error)
+ (lang.throw Cannot-Load-Definition
+ (format "Definition: " (%ident def-ident) "\n"
+ "Error:\n"
+ error))))))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux
new file mode 100644
index 000000000..c326895a2
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/eval.jvm.lux
@@ -0,0 +1,46 @@
+(.module:
+ lux
+ (lux (control monad)
+ (data [text]
+ text/format)
+ [macro]
+ [host #+ do-to])
+ (luxc ["&" lang]
+ (lang (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst]))
+ ["la" analysis]
+ ["ls" synthesis]))
+ (// [".T" common]))
+
+(host.import java/lang/reflect/Field
+ (get [Object] Object))
+
+(host.import (java/lang/Class a)
+ (getField [String] Field))
+
+(def: #export (eval valueI)
+ (-> $.Inst (Meta Top))
+ (do macro.Monad
+ [current-module macro.current-module-name
+ class-name (:: @ map %code (macro.gensym (format current-module "/eval")))
+ #let [store-name (text.replace-all "/" "." class-name)
+ bytecode ($d.class #$.V1_6
+ #$.Public $.noneC
+ class-name
+ (list) ["java.lang.Object" (list)]
+ (list)
+ (|>> ($d.field #$.Public ($_ $.++F $.finalF $.staticF)
+ commonT.value-field commonT.$Object)
+ ($d.method #$.Public ($_ $.++M $.staticM $.strictM)
+ ""
+ ($t.method (list) #.None (list))
+ (|>> valueI
+ ($i.PUTSTATIC store-name commonT.value-field commonT.$Object)
+ $i.RETURN))))]
+ _ (commonT.store-class store-name bytecode)
+ class (commonT.load-class store-name)]
+ (wrap (|> class
+ (Class::getField [commonT.value-field])
+ (Field::get (host.null))))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux
new file mode 100644
index 000000000..82c8c0ec0
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux
@@ -0,0 +1,80 @@
+(.module:
+ lux
+ (lux (control monad
+ ["ex" exception #+ exception:]
+ ["p" parser])
+ (data ["e" error]
+ text/format)
+ [macro]
+ (macro ["s" syntax]))
+ (luxc ["&" lang]
+ (lang [".L" variable #+ Variable Register]
+ [".L" extension]
+ (host ["$" jvm])
+ ["ls" synthesis]))
+ (// [".T" common]
+ [".T" primitive]
+ [".T" structure]
+ [".T" eval]
+ [".T" function]
+ [".T" reference]
+ [".T" case]
+ [".T" procedure]))
+
+(exception: #export Unrecognized-Synthesis)
+
+(def: #export (translate synthesis)
+ (-> ls.Synthesis (Meta $.Inst))
+ (case synthesis
+ (^code [])
+ primitiveT.translate-unit
+
+ (^code [(~ singleton)])
+ (translate singleton)
+
+ (^template [ ]
+ [_ ( value)]
+ ( value))
+ ([#.Bool primitiveT.translate-bool]
+ [#.Nat primitiveT.translate-nat]
+ [#.Int primitiveT.translate-int]
+ [#.Deg primitiveT.translate-deg]
+ [#.Frac primitiveT.translate-frac]
+ [#.Text primitiveT.translate-text])
+
+ (^code ((~ [_ (#.Nat tag)]) (~ [_ (#.Bool last?)]) (~ valueS)))
+ (structureT.translate-variant translate tag last? valueS)
+
+ (^code [(~+ members)])
+ (structureT.translate-tuple translate members)
+
+ (^ [_ (#.Form (list [_ (#.Int var)]))])
+ (if (variableL.captured? var)
+ (referenceT.translate-captured var)
+ (referenceT.translate-local var))
+
+ [_ (#.Symbol definition)]
+ (referenceT.translate-definition definition)
+
+ (^code ("lux let" (~ [_ (#.Nat register)]) (~ inputS) (~ exprS)))
+ (caseT.translate-let translate register inputS exprS)
+
+ (^code ("lux case" (~ inputS) (~ pathPS)))
+ (caseT.translate-case translate inputS pathPS)
+
+ (^multi (^code ("lux function" (~ [_ (#.Nat arity)]) [(~+ environment)] (~ bodyS)))
+ [(s.run environment (p.some s.int)) (#e.Success environment)])
+ (functionT.translate-function translate environment arity bodyS)
+
+ (^code ("lux call" (~ functionS) (~+ argsS)))
+ (functionT.translate-call translate functionS argsS)
+
+ (^code ((~ [_ (#.Text procedure)]) (~+ argsS)))
+ (procedureT.translate-procedure translate procedure argsS)
+ ## (do macro.Monad
+ ## [translation (extensionL.find-translation procedure)]
+ ## (translation argsS))
+
+ _
+ (&.throw Unrecognized-Synthesis (%code synthesis))
+ ))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux
new file mode 100644
index 000000000..6fb446bc4
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux
@@ -0,0 +1,325 @@
+(.module:
+ lux
+ (lux (control [monad #+ do])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor Monoid]))
+ [macro])
+ (luxc ["&" lang]
+ (lang [".L" host]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst]))
+ ["la" analysis]
+ ["ls" synthesis]
+ [".L" variable #+ Variable]))
+ (// [".T" common]
+ [".T" runtime]
+ [".T" reference]))
+
+
+(def: arity-field Text "arity")
+(def: $Object $.Type ($t.class "java.lang.Object" (list)))
+
+(def: (poly-arg? arity)
+ (-> ls.Arity Bool)
+ (n/> +1 arity))
+
+(def: (reset-method class)
+ (-> Text $.Method)
+ ($t.method (list) (#.Some ($t.class class (list))) (list)))
+
+(def: (captured-args env)
+ (-> (List Variable) (List $.Type))
+ (list.repeat (list.size env) $Object))
+
+(def: (init-method env arity)
+ (-> (List Variable) ls.Arity $.Method)
+ (if (poly-arg? arity)
+ ($t.method (list.concat (list (captured-args env)
+ (list $t.int)
+ (list.repeat (n/dec arity) $Object)))
+ #.None
+ (list))
+ ($t.method (captured-args env) #.None (list))))
+
+(def: (implementation-method arity)
+ ($t.method (list.repeat arity $Object) (#.Some $Object) (list)))
+
+(def: get-amount-of-partialsI
+ $.Inst
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD hostL.function-class runtimeT.partials-field $t.int)))
+
+(def: (load-fieldI class field)
+ (-> Text Text $.Inst)
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD class field $Object)))
+
+(def: (inputsI start amount)
+ (-> $.Register Nat $.Inst)
+ (|> (list.n/range start (n/+ start (n/dec amount)))
+ (list/map $i.ALOAD)
+ $i.fuse))
+
+(def: (applysI start amount)
+ (-> $.Register Nat $.Inst)
+ (let [max-args (n/min amount runtimeT.num-apply-variants)
+ later-applysI (if (n/> runtimeT.num-apply-variants amount)
+ (applysI (n/+ runtimeT.num-apply-variants start) (n/- runtimeT.num-apply-variants amount))
+ id)]
+ (|>> ($i.CHECKCAST hostL.function-class)
+ (inputsI start max-args)
+ ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature max-args) false)
+ later-applysI)))
+
+(def: (inc-intI by)
+ (-> Nat $.Inst)
+ (|>> ($i.int (nat-to-int by))
+ $i.IADD))
+
+(def: (nullsI amount)
+ (-> Nat $.Inst)
+ (|> $i.NULL
+ (list.repeat amount)
+ $i.fuse))
+
+(def: (with-captured env)
+ (-> (List Variable) $.Def)
+ (|> (list.enumerate env)
+ (list/map (function [[env-idx env-source]]
+ ($d.field #$.Private $.finalF (referenceT.captured env-idx) $Object)))
+ $d.fuse))
+
+(def: (with-partial arity)
+ (-> ls.Arity $.Def)
+ (if (poly-arg? arity)
+ (|> (list.n/range +0 (n/- +2 arity))
+ (list/map (function [idx]
+ ($d.field #$.Private $.finalF (referenceT.partial idx) $Object)))
+ $d.fuse)
+ id))
+
+(def: (instance class arity env)
+ (-> Text ls.Arity (List Variable) (Meta $.Inst))
+ (do macro.Monad
+ [captureI+ (monad.map @ referenceT.translate-variable env)
+ #let [argsI (if (poly-arg? arity)
+ (|> (nullsI (n/dec arity))
+ (list ($i.int 0))
+ $i.fuse)
+ id)]]
+ (wrap (|>> ($i.NEW class)
+ $i.DUP
+ ($i.fuse captureI+)
+ argsI
+ ($i.INVOKESPECIAL class "" (init-method env arity) false)))))
+
+(def: (with-reset class arity env)
+ (-> Text ls.Arity (List Variable) $.Def)
+ ($d.method #$.Public $.noneM "reset" (reset-method class)
+ (if (poly-arg? arity)
+ (let [env-size (list.size env)
+ captureI (|> (case env-size
+ +0 (list)
+ _ (list.n/range +0 (n/dec env-size)))
+ (list/map (function [source]
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD class (referenceT.captured source) $Object))))
+ $i.fuse)
+ argsI (|> (nullsI (n/dec arity))
+ (list ($i.int 0))
+ $i.fuse)]
+ (|>> ($i.NEW class)
+ $i.DUP
+ captureI
+ argsI
+ ($i.INVOKESPECIAL class "" (init-method env arity) false)
+ $i.ARETURN))
+ (|>> ($i.ALOAD +0)
+ $i.ARETURN))))
+
+(def: (with-implementation arity @begin bodyI)
+ (-> Nat $.Label $.Inst $.Def)
+ ($d.method #$.Public $.strictM "impl" (implementation-method arity)
+ (|>> ($i.label @begin)
+ bodyI
+ $i.ARETURN)))
+
+(def: function-init-method
+ $.Method
+ ($t.method (list $t.int) #.None (list)))
+
+(def: (function-init arity env-size)
+ (-> ls.Arity Nat $.Inst)
+ (if (n/= +1 arity)
+ (|>> ($i.int 0)
+ ($i.INVOKESPECIAL hostL.function-class "" function-init-method false))
+ (|>> ($i.ILOAD (n/inc env-size))
+ ($i.INVOKESPECIAL hostL.function-class "" function-init-method false))))
+
+(def: (with-init class env arity)
+ (-> Text (List Variable) ls.Arity $.Def)
+ (let [env-size (list.size env)
+ offset-partial (: (-> Nat Nat)
+ (|>> n/inc (n/+ env-size)))
+ store-capturedI (|> (case env-size
+ +0 (list)
+ _ (list.n/range +0 (n/dec env-size)))
+ (list/map (function [register]
+ (|>> ($i.ALOAD +0)
+ ($i.ALOAD (n/inc register))
+ ($i.PUTFIELD class (referenceT.captured register) $Object))))
+ $i.fuse)
+ store-partialI (if (poly-arg? arity)
+ (|> (list.n/range +0 (n/- +2 arity))
+ (list/map (function [idx]
+ (let [register (offset-partial idx)]
+ (|>> ($i.ALOAD +0)
+ ($i.ALOAD (n/inc register))
+ ($i.PUTFIELD class (referenceT.partial idx) $Object)))))
+ $i.fuse)
+ id)]
+ ($d.method #$.Public $.noneM "" (init-method env arity)
+ (|>> ($i.ALOAD +0)
+ (function-init arity env-size)
+ store-capturedI
+ store-partialI
+ $i.RETURN))))
+
+(def: (with-apply class env function-arity @begin bodyI apply-arity)
+ (-> Text (List Variable) ls.Arity $.Label $.Inst ls.Arity
+ $.Def)
+ (let [num-partials (n/dec function-arity)
+ @default ($.new-label [])
+ @labels (list/map $.new-label (list.repeat num-partials []))
+ arity-over-extent (|> (nat-to-int function-arity) (i/- (nat-to-int apply-arity)))
+ casesI (|> (list/compose @labels (list @default))
+ (list.zip2 (list.n/range +0 num-partials))
+ (list/map (function [[stage @label]]
+ (let [load-partialsI (if (n/> +0 stage)
+ (|> (list.n/range +0 (n/dec stage))
+ (list/map (|>> referenceT.partial (load-fieldI class)))
+ $i.fuse)
+ id)]
+ (cond (i/= arity-over-extent (nat-to-int stage))
+ (|>> ($i.label @label)
+ ($i.ALOAD +0)
+ (when (n/> +0 stage)
+ ($i.INVOKEVIRTUAL class "reset" (reset-method class) false))
+ load-partialsI
+ (inputsI +1 apply-arity)
+ ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
+ $i.ARETURN)
+
+ (i/> arity-over-extent (nat-to-int stage))
+ (let [args-to-completion (|> function-arity (n/- stage))
+ args-left (|> apply-arity (n/- args-to-completion))]
+ (|>> ($i.label @label)
+ ($i.ALOAD +0)
+ ($i.INVOKEVIRTUAL class "reset" (reset-method class) false)
+ load-partialsI
+ (inputsI +1 args-to-completion)
+ ($i.INVOKEVIRTUAL class "impl" (implementation-method function-arity) false)
+ (applysI (n/inc args-to-completion) args-left)
+ $i.ARETURN))
+
+ ## (i/< arity-over-extent (nat-to-int stage))
+ (let [env-size (list.size env)
+ load-capturedI (|> (case env-size
+ +0 (list)
+ _ (list.n/range +0 (n/dec env-size)))
+ (list/map (|>> referenceT.captured (load-fieldI class)))
+ $i.fuse)]
+ (|>> ($i.label @label)
+ ($i.NEW class)
+ $i.DUP
+ load-capturedI
+ get-amount-of-partialsI
+ (inc-intI apply-arity)
+ load-partialsI
+ (inputsI +1 apply-arity)
+ (nullsI (|> num-partials (n/- apply-arity) (n/- stage)))
+ ($i.INVOKESPECIAL class "" (init-method env function-arity) false)
+ $i.ARETURN))
+ ))))
+ $i.fuse)]
+ ($d.method #$.Public $.noneM runtimeT.apply-method (runtimeT.apply-signature apply-arity)
+ (|>> get-amount-of-partialsI
+ ($i.TABLESWITCH 0 (|> num-partials n/dec nat-to-int)
+ @default @labels)
+ casesI
+ ($i.INVOKESTATIC hostL.runtime-class "apply_fail" ($t.method (list) #.None (list)) false)
+ $i.NULL
+ $i.ARETURN
+ ))))
+
+(def: #export (with-function @begin class env arity bodyI)
+ (-> $.Label Text (List Variable) ls.Arity $.Inst
+ (Meta [$.Def $.Inst]))
+ (let [env-size (list.size env)
+ applyD (: $.Def
+ (if (poly-arg? arity)
+ (|> (n/min arity runtimeT.num-apply-variants)
+ (list.n/range +1)
+ (list/map (with-apply class env arity @begin bodyI))
+ (list& (with-implementation arity @begin bodyI))
+ $d.fuse)
+ ($d.method #$.Public $.strictM runtimeT.apply-method (runtimeT.apply-signature +1)
+ (|>> ($i.label @begin)
+ bodyI
+ $i.ARETURN))))
+ functionD (: $.Def
+ (|>> ($d.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (nat-to-int arity))
+ (with-captured env)
+ (with-partial arity)
+ (with-init class env arity)
+ (with-reset class arity env)
+ applyD
+ ))]
+ (do macro.Monad
+ [instanceI (instance class arity env)]
+ (wrap [functionD instanceI]))))
+
+(def: #export (translate-function translate env arity bodyS)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ (List Variable) ls.Arity ls.Synthesis
+ (Meta $.Inst))
+ (do macro.Monad
+ [@begin $i.make-label
+ [function-class bodyI] (hostL.with-sub-context
+ (hostL.with-anchor [@begin +1]
+ (translate bodyS)))
+ this-module macro.current-module-name
+ #let [function-class (format (text.replace-all "/" "." this-module) "." function-class)]
+ [functionD instanceI] (with-function @begin function-class env arity bodyI)
+ _ (commonT.store-class function-class
+ ($d.class #$.V1_6 #$.Public $.finalC
+ function-class (list)
+ ($.simple-class hostL.function-class) (list)
+ functionD))]
+ (wrap instanceI)))
+
+(def: (segment size elems)
+ (All [a] (-> Nat (List a) (List (List a))))
+ (let [[pre post] (list.split size elems)]
+ (if (list.empty? post)
+ (list pre)
+ (list& pre (segment size post)))))
+
+(def: #export (translate-call translate functionS argsS)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ ls.Synthesis (List ls.Synthesis)
+ (Meta $.Inst))
+ (do macro.Monad
+ [functionI (translate functionS)
+ argsI (monad.map @ translate argsS)
+ #let [applyI (|> (segment runtimeT.num-apply-variants argsI)
+ (list/map (function [chunkI+]
+ (|>> ($i.CHECKCAST hostL.function-class)
+ ($i.fuse chunkI+)
+ ($i.INVOKEVIRTUAL hostL.function-class runtimeT.apply-method (runtimeT.apply-signature (list.size chunkI+)) false))))
+ $i.fuse)]]
+ (wrap (|>> functionI
+ applyI))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux
new file mode 100644
index 000000000..892dd869f
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/imports.jvm.lux
@@ -0,0 +1,149 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["p" parser]
+ ["ex" exception #+ exception:]
+ pipe)
+ (concurrency [promise #+ Promise]
+ [stm #+ Var STM])
+ (data ["e" error #+ Error]
+ [maybe]
+ [product]
+ [text "text/" Eq]
+ text/format
+ (coll [list "list/" Functor Fold]
+ [dict #+ Dict]))
+ [macro]
+ (macro [code]
+ ["s" syntax])
+ [io #+ IO Process io]
+ [host])
+ (luxc ["&" lang]
+ (lang [".L" module])))
+
+(exception: #export Invalid-Imports)
+(exception: #export Module-Cannot-Import-Itself)
+(exception: #export Circular-Dependency)
+
+(host.import (java/util/concurrent/Future a)
+ (get [] #io a))
+
+(host.import (java/util/concurrent/CompletableFuture a)
+ (new [])
+ (complete [a] boolean)
+ (#static [a] completedFuture [a] (CompletableFuture a)))
+
+(type: Import
+ {#module Text
+ #alias Text})
+
+(def: import (s.Syntax Import) (s.tuple (p.seq s.text s.text)))
+
+(def: compilations
+ (Var (Dict Text (CompletableFuture (Error Compiler))))
+ (stm.var (dict.new text.Hash)))
+
+(def: (promise-to-future promise)
+ (All [a] (-> (Promise a) (Future a)))
+ (let [future (CompletableFuture::new [])]
+ (exec (:: promise.Functor map
+ (function [value] (CompletableFuture::complete [value] future))
+ promise)
+ future)))
+
+(def: from-io
+ (All [a] (-> (IO a) (Process a)))
+ (:: io.Monad map (|>> #e.Success)))
+
+(def: (translate-dependency translate-module dependency compiler)
+ (-> (-> Text Compiler (Process Compiler))
+ (-> Text Compiler (IO (Future (Error Compiler)))))
+ (<| (Future::get [])
+ promise-to-future
+ (do promise.Monad
+ [[new? future] (stm.commit (: (STM [Bool (CompletableFuture (Error Compiler))])
+ (do stm.Monad
+ [current-compilations (stm.read compilations)]
+ (case (dict.get dependency current-compilations)
+ (#.Some ongoing)
+ (wrap [false ongoing])
+
+ #.None
+ (do @
+ [#let [pending (: (CompletableFuture (Error Compiler))
+ (CompletableFuture::new []))]
+ _ (stm.write (dict.put dependency pending current-compilations)
+ compilations)]
+ (wrap [true pending]))))))]
+ (if new?
+ (exec (promise.future (io (CompletableFuture::complete [(io.run (translate-module dependency compiler))]
+ future)))
+ (wrap future))
+ (wrap future)))))
+
+(def: compiled?
+ (-> Module Bool)
+ (|>> (get@ #.module-state)
+ (case>
+ (^or #.Cached #.Compiled)
+ true
+
+ _
+ false)))
+
+(def: (merge-modules current-module from-dependency from-current)
+ (-> Text (List [Text Module]) (List [Text Module]) (List [Text Module]))
+ (|> from-dependency
+ (list.filter (|>> product.right compiled?))
+ (list/fold (function [[dep-name dep-module] total] (&.pl-put dep-name dep-module total))
+ from-current)))
+
+(def: (merge-compilers current-module dependency total)
+ (-> Text Compiler Compiler Compiler)
+ (|> total
+ (update@ #.modules (merge-modules current-module (get@ #.modules dependency)))
+ (set@ #.seed (get@ #.seed dependency))))
+
+(def: #export (translate-imports translate-module annotations)
+ (-> (-> Text Compiler (Process Compiler))
+ Code
+ (Meta (Process Compiler)))
+ (do macro.Monad
+ [_ (moduleL.set-annotations annotations)
+ current-module macro.current-module-name
+ imports (let [imports (|> (macro.get-tuple-ann (ident-for #.imports) annotations)
+ (maybe.default (list)))]
+ (case (s.run imports (p.some import))
+ (#e.Success imports)
+ (wrap imports)
+
+ (#e.Error error)
+ (&.throw Invalid-Imports (%code (code.tuple imports)))))
+ dependencies (monad.map @ (: (-> [Text Text] (Meta (IO (Future (Error Compiler)))))
+ (function [[dependency alias]]
+ (do @
+ [_ (&.assert Module-Cannot-Import-Itself current-module
+ (not (text/= current-module dependency)))
+ already-seen? (moduleL.exists? dependency)
+ circular-dependency? (if already-seen?
+ (moduleL.active? dependency)
+ (wrap false))
+ _ (&.assert Circular-Dependency (format "From: " current-module "\n"
+ " To: " dependency)
+ (not circular-dependency?))
+ _ (moduleL.import dependency)
+ _ (if (text/= "" alias)
+ (wrap [])
+ (moduleL.alias alias dependency))
+ compiler macro.get-compiler]
+ (if already-seen?
+ (wrap (io (CompletableFuture::completedFuture [(#e.Success compiler)])))
+ (wrap (translate-dependency translate-module dependency compiler))))))
+ imports)
+ compiler macro.get-compiler]
+ (wrap (do io.Monad
+ [dependencies (monad.seq io.Monad (list/map from-io dependencies))
+ dependencies (|> dependencies
+ (list/map (Future::get []))
+ (monad.seq io.Monad))]
+ (wrap (list/fold (merge-compilers current-module) compiler dependencies))))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux
new file mode 100644
index 000000000..2e585fb11
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux
@@ -0,0 +1,80 @@
+(.module:
+ lux
+ (lux (control [monad #+ do])
+ (data [text]
+ text/format
+ (coll [list "list/" Functor Monoid]))
+ [macro])
+ (luxc ["&" lang]
+ (lang [".L" host]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst]))
+ ["la" analysis]
+ ["ls" synthesis]
+ [".L" variable #+ Variable Register]))
+ (// [".T" common]
+ [".T" runtime]
+ [".T" reference]))
+
+(def: (constant? register changeS)
+ (-> Register ls.Synthesis Bool)
+ (case changeS
+ (^multi (^code ((~ [_ (#.Int var)])))
+ (i/= (variableL.local register)
+ var))
+ true
+
+ _
+ false))
+
+(def: #export (translate-recur translate argsS)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ (List ls.Synthesis)
+ (Meta $.Inst))
+ (do macro.Monad
+ [[@begin offset] hostL.anchor
+ #let [pairs (list.zip2 (list.n/range offset (|> (list.size argsS) n/dec (n/+ offset)))
+ argsS)]
+ ## It may look weird that first I compile the values separately,
+ ## and then I compile the stores/allocations.
+ ## It must be done that way in order to avoid a potential bug.
+ ## Let's say that you'll recur with 2 expressions: X and Y.
+ ## If Y depends on the value of X, and you don't compile values
+ ## and stores separately, then by the time Y is evaluated, it
+ ## will refer to the new value of X, instead of the old value, as
+ ## must be the case.
+ valuesI+ (monad.map @ (function [[register argS]]
+ (: (Meta $.Inst)
+ (if (constant? register argS)
+ (wrap id)
+ (translate argS))))
+ pairs)
+ #let [storesI+ (list/map (function [[register argS]]
+ (: $.Inst
+ (if (constant? register argS)
+ id
+ ($i.ASTORE register))))
+ (list.reverse pairs))]]
+ (wrap (|>> ($i.fuse valuesI+)
+ ($i.fuse storesI+)
+ ($i.GOTO @begin)))))
+
+(def: #export (translate-loop translate offset initsS+ bodyS)
+ (-> (-> ls.Synthesis (Meta $.Inst))
+ Nat (List ls.Synthesis) ls.Synthesis
+ (Meta $.Inst))
+ (do macro.Monad
+ [@begin $i.make-label
+ initsI+ (monad.map @ translate initsS+)
+ bodyI (hostL.with-anchor [@begin offset]
+ (translate bodyS))
+ #let [initializationI (|> (list.enumerate initsI+)
+ (list/map (function [[register initI]]
+ (|>> initI
+ ($i.ASTORE (n/+ offset register)))))
+ $i.fuse)]]
+ (wrap (|>> initializationI
+ ($i.label @begin)
+ bodyI))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux
new file mode 100644
index 000000000..f92c7025a
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux
@@ -0,0 +1,35 @@
+(.module:
+ lux
+ (lux (control monad)
+ (data text/format)
+ [macro "macro/" Monad])
+ (luxc ["&" lang]
+ (lang [".L" host]
+ (host ["$" jvm]
+ (jvm ["$i" inst]
+ ["$t" type]))
+ ["la" analysis]
+ ["ls" synthesis]))
+ (// [".T" common]))
+
+(def: #export translate-unit
+ (Meta $.Inst)
+ (macro/wrap ($i.string hostL.unit)))
+
+(def: #export (translate-bool value)
+ (-> Bool (Meta $.Inst))
+ (macro/wrap ($i.GETSTATIC "java.lang.Boolean"
+ (if value "TRUE" "FALSE")
+ ($t.class "java.lang.Boolean" (list)))))
+
+(do-template [ ]
+ [(def: #export ( value)
+ (-> (Meta $.Inst))
+ (macro/wrap (|>> ( value) )))]
+
+ [translate-nat Nat (|>> (:! Int) $i.long) ($i.wrap #$.Long)]
+ [translate-int Int $i.long ($i.wrap #$.Long)]
+ [translate-deg Deg (|>> (:! Int) $i.long) ($i.wrap #$.Long)]
+ [translate-frac Frac $i.double ($i.wrap #$.Double)]
+ [translate-text Text $i.string id]
+ )
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux
new file mode 100644
index 000000000..e4f8b9908
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure.jvm.lux
@@ -0,0 +1,27 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["ex" exception #+ exception:])
+ (data [maybe]
+ text/format
+ (coll [dict])))
+ (luxc ["&" lang]
+ (lang (host ["$" jvm])
+ ["ls" synthesis]))
+ (/ ["/." common]
+ ["/." host]))
+
+(exception: #export Unknown-Procedure)
+
+(def: procedures
+ /common.Bundle
+ (|> /common.procedures
+ (dict.merge /host.procedures)))
+
+(def: #export (translate-procedure translate name args)
+ (-> (-> ls.Synthesis (Meta $.Inst)) Text (List ls.Synthesis)
+ (Meta $.Inst))
+ (<| (maybe.default (&.throw Unknown-Procedure (%t name)))
+ (do maybe.Monad
+ [proc (dict.get name procedures)]
+ (wrap (proc translate args)))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux
new file mode 100644
index 000000000..c7513fd6e
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux
@@ -0,0 +1,809 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["p" parser]
+ ["ex" exception #+ exception:])
+ (data ["e" error]
+ [text]
+ text/format
+ (coll [list "list/" Functor]
+ [dict #+ Dict]))
+ [macro #+ with-gensyms]
+ (macro [code]
+ ["s" syntax #+ syntax:])
+ [host])
+ (luxc ["&" lang]
+ (lang [".L" host]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst]))
+ ["la" analysis]
+ ["ls" synthesis]))
+ (/// [".T" runtime]
+ [".T" case]
+ [".T" function]
+ [".T" loop]))
+
+(host.import java/lang/Long
+ (#static MIN_VALUE Long)
+ (#static MAX_VALUE Long))
+
+(host.import java/lang/Double
+ (#static MIN_VALUE Double)
+ (#static MAX_VALUE Double)
+ (#static NaN Double)
+ (#static POSITIVE_INFINITY Double)
+ (#static NEGATIVE_INFINITY Double))
+
+## [Types]
+(type: #export Translator
+ (-> ls.Synthesis (Meta $.Inst)))
+
+(type: #export Proc
+ (-> Translator (List ls.Synthesis) (Meta $.Inst)))
+
+(type: #export Bundle
+ (Dict Text Proc))
+
+(syntax: (Vector [size s.nat] elemT)
+ (wrap (list (` [(~+ (list.repeat size elemT))]))))
+
+(type: #export Nullary (-> (Vector +0 $.Inst) $.Inst))
+(type: #export Unary (-> (Vector +1 $.Inst) $.Inst))
+(type: #export Binary (-> (Vector +2 $.Inst) $.Inst))
+(type: #export Trinary (-> (Vector +3 $.Inst) $.Inst))
+(type: #export Variadic (-> (List $.Inst) $.Inst))
+
+## [Utils]
+(def: $Object $.Type ($t.class "java.lang.Object" (list)))
+(def: $Object-Array $.Type ($t.array +1 $Object))
+(def: $Variant $.Type ($t.array +1 $Object))
+(def: $String $.Type ($t.class "java.lang.String" (list)))
+(def: $CharSequence $.Type ($t.class "java.lang.CharSequence" (list)))
+(def: $Function $.Type ($t.class hostL.function-class (list)))
+
+(def: #export (install name unnamed)
+ (-> Text (-> Text Proc)
+ (-> Bundle Bundle))
+ (dict.put name (unnamed name)))
+
+(def: #export (prefix prefix bundle)
+ (-> Text Bundle Bundle)
+ (|> bundle
+ dict.entries
+ (list/map (function [[key val]] [(format prefix " " key) val]))
+ (dict.from-list text.Hash)))
+
+(def: (wrong-arity proc expected actual)
+ (-> Text Nat Nat Text)
+ (format "Wrong number of arguments for " (%t proc) "\n"
+ "Expected: " (|> expected nat-to-int %i) "\n"
+ " Actual: " (|> actual nat-to-int %i)))
+
+(syntax: (arity: [name s.local-symbol] [arity s.nat])
+ (with-gensyms [g!proc g!name g!translate g!inputs]
+ (do @
+ [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))]
+ (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc))
+ (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst)
+ (-> Text ..Proc))
+ (function [(~ g!name)]
+ (function [(~ g!translate) (~ g!inputs)]
+ (case (~ g!inputs)
+ (^ (list (~+ g!input+)))
+ (do macro.Monad
+ [(~+ (|> g!input+
+ (list/map (function [g!input]
+ (list g!input (` ((~ g!translate) (~ g!input))))))
+ list.concat))]
+ ((~' wrap) ((~ g!proc) [(~+ g!input+)])))
+
+ (~' _)
+ (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs))))))))))))))
+
+(arity: nullary +0)
+(arity: unary +1)
+(arity: binary +2)
+(arity: trinary +3)
+
+(def: #export (variadic proc)
+ (-> Variadic (-> Text Proc))
+ (function [proc-name]
+ (function [translate inputsS]
+ (do macro.Monad
+ [inputsI (monad.map @ translate inputsS)]
+ (wrap (proc inputsI))))))
+
+## [Instructions]
+(def: lux-intI $.Inst (|>> $i.I2L ($i.wrap #$.Long)))
+(def: jvm-intI $.Inst (|>> ($i.unwrap #$.Long) $i.L2I))
+
+(def: (array-writeI arrayI idxI elemI)
+ (-> $.Inst $.Inst $.Inst
+ $.Inst)
+ (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array))
+ $i.DUP
+ idxI jvm-intI
+ elemI
+ $i.AASTORE))
+
+(def: (predicateI tester)
+ (-> (-> $.Label $.Inst)
+ $.Inst)
+ (<| $i.with-label (function [@then])
+ $i.with-label (function [@end])
+ (|>> (tester @then)
+ ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
+ ($i.GOTO @end)
+ ($i.label @then)
+ ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
+ ($i.label @end)
+ )))
+
+(def: unitI $.Inst ($i.string hostL.unit))
+
+## [Procedures]
+## [[Lux]]
+(def: (lux//is [leftI rightI])
+ Binary
+ (|>> leftI
+ rightI
+ (predicateI $i.IF_ACMPEQ)))
+
+(def: (lux//if [testI thenI elseI])
+ Trinary
+ (caseT.translate-if testI thenI elseI))
+
+(def: (lux//try riskyI)
+ Unary
+ (|>> riskyI
+ ($i.CHECKCAST hostL.function-class)
+ ($i.INVOKESTATIC hostL.runtime-class "try"
+ ($t.method (list $Function) (#.Some $Object-Array) (list))
+ false)))
+
+(def: (lux//noop valueI)
+ Unary
+ valueI)
+
+(exception: #export Wrong-Syntax)
+(def: #export (wrong-syntax procedure args)
+ (-> Text (List ls.Synthesis) Text)
+ (format "Procedure: " procedure "\n"
+ "Arguments: " (%code (code.tuple args))))
+
+(def: lux//loop
+ (-> Text Proc)
+ (function [proc-name]
+ (function [translate inputsS]
+ (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any))
+ (#e.Success [offset initsS+ bodyS])
+ (loopT.translate-loop translate offset initsS+ bodyS)
+
+ (#e.Error error)
+ (&.throw Wrong-Syntax (wrong-syntax proc-name inputsS)))
+ )))
+
+(def: lux//recur
+ (-> Text Proc)
+ (function [proc-name]
+ (function [translate inputsS]
+ (loopT.translate-recur translate inputsS))))
+
+## [[Bits]]
+(do-template [ ]
+ [(def: ( [inputI maskI])
+ Binary
+ (|>> inputI ($i.unwrap #$.Long)
+ maskI ($i.unwrap #$.Long)
+ ($i.wrap #$.Long)))]
+
+ [bit//and $i.LAND]
+ [bit//or $i.LOR]
+ [bit//xor $i.LXOR]
+ )
+
+(def: (bit//count inputI)
+ Unary
+ (|>> inputI ($i.unwrap #$.Long)
+ ($i.INVOKESTATIC "java.lang.Long" "bitCount" ($t.method (list $t.long) (#.Some $t.int) (list)) false)
+ lux-intI))
+
+(do-template [ ]
+ [(def: ( [inputI shiftI])
+ Binary
+ (|>> inputI ($i.unwrap #$.Long)
+ shiftI jvm-intI
+
+ ($i.wrap #$.Long)))]
+
+ [bit//shift-left $i.LSHL]
+ [bit//shift-right $i.LSHR]
+ [bit//unsigned-shift-right $i.LUSHR]
+ )
+
+## [[Arrays]]
+(def: (array//new lengthI)
+ Unary
+ (|>> lengthI jvm-intI ($i.ANEWARRAY ($t.binary-name "java.lang.Object"))))
+
+(def: (array//get [arrayI idxI])
+ Binary
+ (<| $i.with-label (function [@is-null])
+ $i.with-label (function [@end])
+ (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array))
+ idxI jvm-intI
+ $i.AALOAD
+ $i.DUP
+ ($i.IFNULL @is-null)
+ runtimeT.someI
+ ($i.GOTO @end)
+ ($i.label @is-null)
+ $i.POP
+ runtimeT.noneI
+ ($i.label @end))))
+
+(def: (array//put [arrayI idxI elemI])
+ Trinary
+ (array-writeI arrayI idxI elemI))
+
+(def: (array//remove [arrayI idxI])
+ Binary
+ (array-writeI arrayI idxI $i.NULL))
+
+(def: (array//size arrayI)
+ Unary
+ (|>> arrayI ($i.CHECKCAST ($t.descriptor $Object-Array))
+ $i.ARRAYLENGTH
+ lux-intI))
+
+## [[Numbers]]
+(def: nat-method
+ $.Method
+ ($t.method (list $t.long $t.long) (#.Some $t.long) (list)))
+
+(def: deg-method $.Method nat-method)
+
+(def: compare-nat-method
+ $.Method
+ ($t.method (list $t.long $t.long) (#.Some $t.int) (list)))
+
+(do-template [ ]
+ [(def: ( _)
+ Nullary
+ (|>> ($i.wrap )))]
+
+ [nat//min ($i.long 0) #$.Long]
+ [nat//max ($i.long -1) #$.Long]
+
+ [int//min ($i.long Long::MIN_VALUE) #$.Long]
+ [int//max ($i.long Long::MAX_VALUE) #$.Long]
+
+ [frac//smallest ($i.double Double::MIN_VALUE) #$.Double]
+ [frac//min ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double]
+ [frac//max ($i.double Double::MAX_VALUE) #$.Double]
+ [frac//not-a-number ($i.double Double::NaN) #$.Double]
+ [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double]
+ [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double]
+
+ [deg//min ($i.long 0) #$.Long]
+ [deg//max ($i.long -1) #$.Long]
+ )
+
+(do-template [ ]
+ [(def: ( [subjectI paramI])
+ Binary
+ (|>> subjectI ($i.unwrap )
+ paramI ($i.unwrap )
+
+ ($i.wrap )))]
+
+ [int//add #$.Long $i.LADD]
+ [int//sub #$.Long $i.LSUB]
+ [int//mul #$.Long $i.LMUL]
+ [int//div #$.Long $i.LDIV]
+ [int//rem #$.Long $i.LREM]
+
+ [nat//add #$.Long $i.LADD]
+ [nat//sub #$.Long $i.LSUB]
+ [nat//mul #$.Long $i.LMUL]
+ [nat//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_nat" nat-method false)]
+ [nat//rem #$.Long ($i.INVOKESTATIC hostL.runtime-class "rem_nat" nat-method false)]
+
+ [frac//add #$.Double $i.DADD]
+ [frac//sub #$.Double $i.DSUB]
+ [frac//mul #$.Double $i.DMUL]
+ [frac//div #$.Double $i.DDIV]
+ [frac//rem #$.Double $i.DREM]
+
+ [deg//add #$.Long $i.LADD]
+ [deg//sub #$.Long $i.LSUB]
+ [deg//mul #$.Long ($i.INVOKESTATIC hostL.runtime-class "mul_deg" deg-method false)]
+ [deg//div #$.Long ($i.INVOKESTATIC hostL.runtime-class "div_deg" deg-method false)]
+ [deg//rem #$.Long $i.LSUB]
+ [deg//scale #$.Long $i.LMUL]
+ [deg//reciprocal #$.Long $i.LDIV]
+ )
+
+(do-template [ ]
+ [(do-template [ ]
+ [(def: ( [subjectI paramI])
+ Binary
+ (|>> subjectI
+ paramI
+
+ ($i.int )
+ (predicateI $i.IF_ICMPEQ)))]
+ [ 0]
+ [ -1])]
+
+ [nat//eq nat//lt ($i.unwrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false)]
+ [int//eq int//lt ($i.unwrap #$.Long) $i.LCMP]
+ [frac//eq frac//lt ($i.unwrap #$.Double) $i.DCMPG]
+ [deg//eq deg//lt ($i.unwrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "compare_nat" compare-nat-method false)]
+ )
+
+(do-template [ ]
+ [(def: ( inputI)
+ Unary
+ (|>> inputI ))]
+
+ [nat//to-int id id]
+ [nat//char ($i.unwrap #$.Long)
+ ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))]
+
+ [int//to-nat id id]
+ [int//to-frac ($i.unwrap #$.Long) (<| ($i.wrap #$.Double) $i.L2D)]
+
+ [frac//to-int ($i.unwrap #$.Double) (<| ($i.wrap #$.Long) $i.D2L)]
+ [frac//to-deg ($i.unwrap #$.Double)
+ (<| ($i.wrap #$.Long) ($i.INVOKESTATIC hostL.runtime-class "frac_to_deg"
+ ($t.method (list $t.double) (#.Some $t.long) (list)) false))]
+ [frac//encode ($i.unwrap #$.Double)
+ ($i.INVOKESTATIC "java.lang.Double" "toString" ($t.method (list $t.double) (#.Some $String) (list)) false)]
+ [frac//decode ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKESTATIC hostL.runtime-class "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) false)]
+
+ [deg//to-frac ($i.unwrap #$.Long)
+ (<| ($i.wrap #$.Double) ($i.INVOKESTATIC hostL.runtime-class "deg_to_frac"
+ ($t.method (list $t.long) (#.Some $t.double) (list)) false))]
+ )
+
+## [[Text]]
+(do-template [ ]
+ [(def: ( inputI)
+ Unary
+ (|>> inputI
+ ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKEVIRTUAL ($t.method (list) (#.Some ) (list)) false)
+ ))]
+
+ [text//size "java.lang.String" "length" lux-intI $t.int]
+ [text//hash "java.lang.Object" "hashCode" lux-intI $t.int]
+ [text//trim "java.lang.String" "trim" id $String]
+ [text//upper "java.lang.String" "toUpperCase" id $String]
+ [text//lower "java.lang.String" "toLowerCase" id $String]
+ )
+
+(do-template [ ]
+ [(def: ( [subjectI paramI])
+ Binary
+ (|>> subjectI
+ paramI
+ ))]
+
+ [text//eq id id
+ ($i.INVOKEVIRTUAL "java.lang.Object" "equals" ($t.method (list $Object) (#.Some $t.boolean) (list)) false)
+ ($i.wrap #$.Boolean)]
+ [text//lt ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKEVIRTUAL "java.lang.String" "compareTo" ($t.method (list $String) (#.Some $t.int) (list)) false)
+ (<| (predicateI $i.IF_ICMPEQ) ($i.int -1))]
+ [text//concat ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) false)
+ id]
+ [text//contains? ($i.CHECKCAST "java.lang.String") ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKEVIRTUAL "java.lang.String" "contains" ($t.method (list $CharSequence) (#.Some $t.boolean) (list)) false)
+ ($i.wrap #$.Boolean)]
+ [text//char ($i.CHECKCAST "java.lang.String") jvm-intI
+ ($i.INVOKESTATIC hostL.runtime-class "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) false)
+ id]
+ )
+
+(do-template [ ]
+ [(def: ( [subjectI paramI extraI])
+ Trinary
+ (|>> subjectI
+ paramI
+ extraI
+ ))]
+
+ [text//clip ($i.CHECKCAST "java.lang.String") jvm-intI jvm-intI
+ ($i.INVOKESTATIC hostL.runtime-class "text_clip"
+ ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) false)]
+ [text//replace-once ($i.CHECKCAST "java.lang.String")
+ (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false)
+ ($i.CHECKCAST "java.lang.String"))
+ ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t.method (list $String $String) (#.Some $String) (list)) false)]
+ [text//replace-all ($i.CHECKCAST "java.lang.String")
+ (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false)
+ ($i.CHECKCAST "java.lang.String"))
+ ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t.method (list $String $String) (#.Some $String) (list)) false)]
+ )
+
+(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list)))
+(do-template [ ]
+ [(def: ( [textI partI startI])
+ Trinary
+ (<| $i.with-label (function [@not-found])
+ $i.with-label (function [@end])
+ (|>> textI ($i.CHECKCAST "java.lang.String")
+ partI ($i.CHECKCAST "java.lang.String")
+ startI jvm-intI
+ ($i.INVOKEVIRTUAL "java.lang.String" index-method false)
+ $i.DUP
+ ($i.int -1)
+ ($i.IF_ICMPEQ @not-found)
+ lux-intI
+ runtimeT.someI
+ ($i.GOTO @end)
+ ($i.label @not-found)
+ $i.POP
+ runtimeT.noneI
+ ($i.label @end))))]
+
+ [text//index "indexOf"]
+ [text//last-index "lastIndexOf"]
+ )
+
+## [[Math]]
+(def: math-unary-method ($t.method (list $t.double) (#.Some $t.double) (list)))
+(def: math-binary-method ($t.method (list $t.double $t.double) (#.Some $t.double) (list)))
+
+(do-template [ ]
+ [(def: ( inputI)
+ Unary
+ (|>> inputI
+ ($i.unwrap #$.Double)
+ ($i.INVOKESTATIC "java.lang.Math" math-unary-method false)
+ ($i.wrap #$.Double)))]
+
+ [math//cos "cos"]
+ [math//sin "sin"]
+ [math//tan "tan"]
+ [math//acos "acos"]
+ [math//asin "asin"]
+ [math//atan "atan"]
+ [math//cosh "cosh"]
+ [math//sinh "sinh"]
+ [math//tanh "tanh"]
+ [math//exp "exp"]
+ [math//log "log"]
+ [math//root2 "sqrt"]
+ [math//root3 "cbrt"]
+ [math//ceil "ceil"]
+ [math//floor "floor"]
+ )
+
+(do-template [ ]
+ [(def: ( [inputI paramI])
+ Binary
+ (|>> inputI ($i.unwrap #$.Double)
+ paramI ($i.unwrap #$.Double)
+ ($i.INVOKESTATIC "java.lang.Math" math-binary-method false)
+ ($i.wrap #$.Double)))]
+
+ [math//atan2 "atan2"]
+ [math//pow "pow"]
+ )
+
+(def: (math//round inputI)
+ Unary
+ (|>> inputI
+ ($i.unwrap #$.Double)
+ ($i.INVOKESTATIC "java.lang.Math" "round" ($t.method (list $t.double) (#.Some $t.long) (list)) false)
+ $i.L2D
+ ($i.wrap #$.Double)))
+
+## [[IO]]
+(def: string-method $.Method ($t.method (list $String) #.None (list)))
+(def: (io//log messageI)
+ Unary
+ (|>> ($i.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list)))
+ messageI
+ ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false)
+ unitI))
+
+(def: (io//error messageI)
+ Unary
+ (|>> ($i.NEW "java.lang.Error")
+ $i.DUP
+ messageI
+ ($i.CHECKCAST "java.lang.String")
+ ($i.INVOKESPECIAL "java.lang.Error" "" string-method false)
+ $i.ATHROW))
+
+(def: (io//exit codeI)
+ Unary
+ (|>> codeI jvm-intI
+ ($i.INVOKESTATIC "java.lang.System" "exit" ($t.method (list $t.int) #.None (list)) false)
+ $i.NULL))
+
+(def: (io//current-time [])
+ Nullary
+ (|>> ($i.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) false)
+ ($i.wrap #$.Long)))
+
+## [[Atoms]]
+(def: atom-class Text "java.util.concurrent.atomic.AtomicReference")
+(def: (atom//new initI)
+ Unary
+ (|>> ($i.NEW atom-class)
+ $i.DUP
+ initI
+ ($i.INVOKESPECIAL atom-class "" ($t.method (list $Object) #.None (list)) false)))
+
+(def: (atom//read atomI)
+ Unary
+ (|>> atomI
+ ($i.CHECKCAST atom-class)
+ ($i.INVOKEVIRTUAL atom-class "get" ($t.method (list) (#.Some $Object) (list)) false)))
+
+(def: (atom//compare-and-swap [atomI oldI newI])
+ Trinary
+ (|>> atomI
+ ($i.CHECKCAST atom-class)
+ oldI
+ newI
+ ($i.INVOKEVIRTUAL atom-class "compareAndSet" ($t.method (list $Object $Object) (#.Some $t.boolean) (list)) false)
+ ($i.wrap #$.Boolean)))
+
+## [[Box]]
+(def: empty-boxI
+ $.Inst
+ (|>> ($i.int 1) ($i.ANEWARRAY ($t.binary-name "java.lang.Object"))))
+
+(def: check-boxI
+ $.Inst
+ ($i.CHECKCAST ($t.descriptor $Object-Array)))
+
+(def: (box//new initI)
+ Unary
+ (|>> empty-boxI
+ $i.DUP ($i.int 0) initI $i.AASTORE))
+
+(def: (box//read boxI)
+ Unary
+ (|>> boxI check-boxI
+ ($i.int 0) $i.AALOAD))
+
+(def: (box//write [valueI boxI])
+ Binary
+ (|>> boxI check-boxI
+ ($i.int 0) valueI $i.AASTORE
+ unitI))
+
+## [[Processes]]
+(def: (process//concurrency-level [])
+ Nullary
+ (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) false)
+ ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false)
+ lux-intI))
+
+(def: (process//future procedureI)
+ Unary
+ (|>> procedureI ($i.CHECKCAST hostL.function-class)
+ ($i.INVOKESTATIC hostL.runtime-class "future"
+ ($t.method (list $Function) (#.Some $Object) (list)) false)))
+
+(def: (process//schedule [millisecondsI procedureI])
+ Binary
+ (|>> millisecondsI ($i.unwrap #$.Long)
+ procedureI ($i.CHECKCAST hostL.function-class)
+ ($i.INVOKESTATIC hostL.runtime-class "schedule"
+ ($t.method (list $t.long $Function) (#.Some $Object) (list)) false)))
+
+## [Bundles]
+(def: lux-procs
+ Bundle
+ (|> (dict.new text.Hash)
+ (install "noop" (unary lux//noop))
+ (install "is" (binary lux//is))
+ (install "try" (unary lux//try))
+ (install "if" (trinary lux//if))
+ (install "loop" lux//loop)
+ (install "recur" lux//recur)
+ ))
+
+(def: bit-procs
+ Bundle
+ (<| (prefix "bit")
+ (|> (dict.new text.Hash)
+ (install "count" (unary bit//count))
+ (install "and" (binary bit//and))
+ (install "or" (binary bit//or))
+ (install "xor" (binary bit//xor))
+ (install "shift-left" (binary bit//shift-left))
+ (install "unsigned-shift-right" (binary bit//unsigned-shift-right))
+ (install "shift-right" (binary bit//shift-right))
+ )))
+
+(def: nat-procs
+ Bundle
+ (<| (prefix "nat")
+ (|> (dict.new text.Hash)
+ (install "+" (binary nat//add))
+ (install "-" (binary nat//sub))
+ (install "*" (binary nat//mul))
+ (install "/" (binary nat//div))
+ (install "%" (binary nat//rem))
+ (install "=" (binary nat//eq))
+ (install "<" (binary nat//lt))
+ (install "min" (nullary nat//min))
+ (install "max" (nullary nat//max))
+ (install "to-int" (unary nat//to-int))
+ (install "char" (unary nat//char)))))
+
+(def: int-procs
+ Bundle
+ (<| (prefix "int")
+ (|> (dict.new text.Hash)
+ (install "+" (binary int//add))
+ (install "-" (binary int//sub))
+ (install "*" (binary int//mul))
+ (install "/" (binary int//div))
+ (install "%" (binary int//rem))
+ (install "=" (binary int//eq))
+ (install "<" (binary int//lt))
+ (install "min" (nullary int//min))
+ (install "max" (nullary int//max))
+ (install "to-nat" (unary int//to-nat))
+ (install "to-frac" (unary int//to-frac)))))
+
+(def: deg-procs
+ Bundle
+ (<| (prefix "deg")
+ (|> (dict.new text.Hash)
+ (install "+" (binary deg//add))
+ (install "-" (binary deg//sub))
+ (install "*" (binary deg//mul))
+ (install "/" (binary deg//div))
+ (install "%" (binary deg//rem))
+ (install "=" (binary deg//eq))
+ (install "<" (binary deg//lt))
+ (install "scale" (binary deg//scale))
+ (install "reciprocal" (binary deg//reciprocal))
+ (install "min" (nullary deg//min))
+ (install "max" (nullary deg//max))
+ (install "to-frac" (unary deg//to-frac)))))
+
+(def: frac-procs
+ Bundle
+ (<| (prefix "frac")
+ (|> (dict.new text.Hash)
+ (install "+" (binary frac//add))
+ (install "-" (binary frac//sub))
+ (install "*" (binary frac//mul))
+ (install "/" (binary frac//div))
+ (install "%" (binary frac//rem))
+ (install "=" (binary frac//eq))
+ (install "<" (binary frac//lt))
+ (install "smallest" (nullary frac//smallest))
+ (install "min" (nullary frac//min))
+ (install "max" (nullary frac//max))
+ (install "not-a-number" (nullary frac//not-a-number))
+ (install "positive-infinity" (nullary frac//positive-infinity))
+ (install "negative-infinity" (nullary frac//negative-infinity))
+ (install "to-deg" (unary frac//to-deg))
+ (install "to-int" (unary frac//to-int))
+ (install "encode" (unary frac//encode))
+ (install "decode" (unary frac//decode)))))
+
+(def: text-procs
+ Bundle
+ (<| (prefix "text")
+ (|> (dict.new text.Hash)
+ (install "=" (binary text//eq))
+ (install "<" (binary text//lt))
+ (install "concat" (binary text//concat))
+ (install "index" (trinary text//index))
+ (install "size" (unary text//size))
+ (install "hash" (unary text//hash))
+ (install "replace-once" (trinary text//replace-once))
+ (install "replace-all" (trinary text//replace-all))
+ (install "char" (binary text//char))
+ (install "clip" (trinary text//clip))
+ (install "upper" (unary text//upper))
+ (install "lower" (unary text//lower))
+ )))
+
+(def: array-procs
+ Bundle
+ (<| (prefix "array")
+ (|> (dict.new text.Hash)
+ (install "new" (unary array//new))
+ (install "get" (binary array//get))
+ (install "put" (trinary array//put))
+ (install "remove" (binary array//remove))
+ (install "size" (unary array//size))
+ )))
+
+(def: math-procs
+ Bundle
+ (<| (prefix "math")
+ (|> (dict.new text.Hash)
+ (install "cos" (unary math//cos))
+ (install "sin" (unary math//sin))
+ (install "tan" (unary math//tan))
+ (install "acos" (unary math//acos))
+ (install "asin" (unary math//asin))
+ (install "atan" (unary math//atan))
+ (install "cosh" (unary math//cosh))
+ (install "sinh" (unary math//sinh))
+ (install "tanh" (unary math//tanh))
+ (install "exp" (unary math//exp))
+ (install "log" (unary math//log))
+ (install "root2" (unary math//root2))
+ (install "root3" (unary math//root3))
+ (install "ceil" (unary math//ceil))
+ (install "floor" (unary math//floor))
+ (install "round" (unary math//round))
+ (install "atan2" (binary math//atan2))
+ (install "pow" (binary math//pow))
+ )))
+
+(def: io-procs
+ Bundle
+ (<| (prefix "io")
+ (|> (dict.new text.Hash)
+ (install "log" (unary io//log))
+ (install "error" (unary io//error))
+ (install "exit" (unary io//exit))
+ (install "current-time" (nullary io//current-time)))))
+
+(def: atom-procs
+ Bundle
+ (<| (prefix "atom")
+ (|> (dict.new text.Hash)
+ (install "new" (unary atom//new))
+ (install "read" (unary atom//read))
+ (install "compare-and-swap" (trinary atom//compare-and-swap)))))
+
+(def: box-procs
+ Bundle
+ (<| (prefix "box")
+ (|> (dict.new text.Hash)
+ (install "new" (unary box//new))
+ (install "read" (unary box//read))
+ (install "write" (binary box//write)))))
+
+(def: process-procs
+ Bundle
+ (<| (prefix "process")
+ (|> (dict.new text.Hash)
+ (install "concurrency-level" (nullary process//concurrency-level))
+ (install "future" (unary process//future))
+ (install "schedule" (binary process//schedule))
+ )))
+
+(def: #export procedures
+ Bundle
+ (<| (prefix "lux")
+ (|> (dict.new text.Hash)
+ (dict.merge lux-procs)
+ (dict.merge bit-procs)
+ (dict.merge nat-procs)
+ (dict.merge int-procs)
+ (dict.merge deg-procs)
+ (dict.merge frac-procs)
+ (dict.merge text-procs)
+ (dict.merge array-procs)
+ (dict.merge math-procs)
+ (dict.merge io-procs)
+ (dict.merge atom-procs)
+ (dict.merge box-procs)
+ (dict.merge process-procs)
+ )))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
new file mode 100644
index 000000000..30d17cac3
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
@@ -0,0 +1,761 @@
+(.module:
+ lux
+ (lux (control [monad #+ do]
+ ["p" parser "parser/" Monad]
+ ["ex" exception #+ exception:])
+ (data [product]
+ ["e" error]
+ [text "text/" Eq]
+ (text format
+ ["l" lexer])
+ (coll [list "list/" Functor]
+ [dict #+ Dict]))
+ [macro "macro/" Monad]
+ (macro [code]
+ ["s" syntax #+ syntax:])
+ [host])
+ (luxc ["&" lang]
+ (lang [".L" host]
+ (host ["$" jvm]
+ (jvm ["$t" type]
+ ["$d" def]
+ ["$i" inst]))
+ ["la" analysis]
+ (extension (analysis ["&." host]))
+ ["ls" synthesis]))
+ (// ["@" common]))
+
+(exception: #export Invalid-Syntax-For-JVM-Type)
+(exception: #export Invalid-Syntax-For-Argument-Generation)
+
+(do-template [ ]
+ [(def:
+ $.Inst
+ )]
+
+ [L2S (|>> $i.L2I $i.I2S)]
+ [L2B (|>> $i.L2I $i.I2B)]
+ [L2C (|>> $i.L2I $i.I2C)]
+ )
+
+(do-template [ ]
+ [(def: ( inputI)
+ @.Unary
+ (if (is $i.NOP )
+ (|>> inputI
+ ($i.unwrap )
+ ($i.wrap ))
+ (|>> inputI
+ ($i.unwrap )
+
+ ($i.wrap ))))]
+
+ [convert//double-to-float #$.Double $i.D2F #$.Float]
+ [convert//double-to-int #$.Double $i.D2I #$.Int]
+ [convert//double-to-long #$.Double $i.D2L #$.Long]
+ [convert//float-to-double #$.Float $i.F2D #$.Double]
+ [convert//float-to-int #$.Float $i.F2I #$.Int]
+ [convert//float-to-long #$.Float $i.F2L #$.Long]
+ [convert//int-to-byte #$.Int $i.I2B #$.Byte]
+ [convert//int-to-char #$.Int $i.I2C #$.Char]
+ [convert//int-to-double #$.Int $i.I2D #$.Double]
+ [convert//int-to-float #$.Int $i.I2F #$.Float]
+ [convert//int-to-long #$.Int $i.I2L #$.Long]
+ [convert//int-to-short #$.Int $i.I2S #$.Short]
+ [convert//long-to-double #$.Long $i.L2D #$.Double]
+ [convert//long-to-float #$.Long $i.L2F #$.Float]
+ [convert//long-to-int #$.Long $i.L2I #$.Int]
+ [convert//long-to-short #$.Long L2S #$.Short]
+ [convert//long-to-byte #$.Long L2B #$.Byte]
+ [convert//long-to-char #$.Long L2C #$.Char]
+ [convert//char-to-byte #$.Char $i.I2B #$.Byte]
+ [convert//char-to-short #$.Char $i.I2S #$.Short]
+ [convert//char-to-int #$.Char $i.NOP #$.Int]
+ [convert//char-to-long #$.Char $i.I2L #$.Long]
+ [convert//byte-to-long #$.Byte $i.I2L #$.Long]
+ [convert//short-to-long #$.Short $i.I2L #$.Long]
+ )
+
+(def: conversion-procs
+ @.Bundle
+ (<| (@.prefix "convert")
+ (|> (dict.new text.Hash)
+ (@.install "double-to-float" (@.unary convert//double-to-float))
+ (@.install "double-to-int" (@.unary convert//double-to-int))
+ (@.install "double-to-long" (@.unary convert//double-to-long))
+ (@.install "float-to-double" (@.unary convert//float-to-double))
+ (@.install "float-to-int" (@.unary convert//float-to-int))
+ (@.install "float-to-long" (@.unary convert//float-to-long))
+ (@.install "int-to-byte" (@.unary convert//int-to-byte))
+ (@.install "int-to-char" (@.unary convert//int-to-char))
+ (@.install "int-to-double" (@.unary convert//int-to-double))
+ (@.install "int-to-float" (@.unary convert//int-to-float))
+ (@.install "int-to-long" (@.unary convert//int-to-long))
+ (@.install "int-to-short" (@.unary convert//int-to-short))
+ (@.install "long-to-double" (@.unary convert//long-to-double))
+ (@.install "long-to-float" (@.unary convert//long-to-float))
+ (@.install "long-to-int" (@.unary convert//long-to-int))
+ (@.install "long-to-short" (@.unary convert//long-to-short))
+ (@.install "long-to-byte" (@.unary convert//long-to-byte))
+ (@.install "long-to-char" (@.unary convert//long-to-char))
+ (@.install "char-to-byte" (@.unary convert//char-to-byte))
+ (@.install "char-to-short" (@.unary convert//char-to-short))
+ (@.install "char-to-int" (@.unary convert//char-to-int))
+ (@.install "char-to-long" (@.unary convert//char-to-long))
+ (@.install "byte-to-long" (@.unary convert//byte-to-long))
+ (@.install "short-to-long" (@.unary convert//short-to-long))
+ )))
+
+(do-template [ ]
+ [(def: ( [xI yI])
+ @.Binary
+ (|>> xI ($i.unwrap )
+ yI ($i.unwrap )
+ ($i.wrap )))]
+
+ [int//+ $i.IADD #$.Int #$.Int #$.Int]
+ [int//- $i.ISUB #$.Int #$.Int #$.Int]
+ [int//* $i.IMUL #$.Int #$.Int #$.Int]
+ [int/// $i.IDIV #$.Int #$.Int #$.Int]
+ [int//% $i.IREM #$.Int #$.Int #$.Int]
+ [int//and $i.IAND #$.Int #$.Int #$.Int]
+ [int//or $i.IOR #$.Int #$.Int #$.Int]
+ [int//xor $i.IXOR #$.Int #$.Int #$.Int]
+ [int//shl $i.ISHL #$.Int #$.Int #$.Int]
+ [int//shr $i.ISHR #$.Int #$.Int #$.Int]
+ [int//ushr $i.IUSHR #$.Int #$.Int #$.Int]
+
+ [long//+ $i.LADD #$.Long #$.Long #$.Long]
+ [long//- $i.LSUB #$.Long #$.Long #$.Long]
+ [long//* $i.LMUL #$.Long #$.Long #$.Long]
+ [long/// $i.LDIV #$.Long #$.Long #$.Long]
+ [long//% $i.LREM #$.Long #$.Long #$.Long]
+ [long//and $i.LAND #$.Long #$.Long #$.Long]
+ [long//or $i.LOR #$.Long #$.Long #$.Long]
+ [long//xor $i.LXOR #$.Long #$.Long #$.Long]
+ [long//shl $i.LSHL #$.Long #$.Int #$.Long]
+ [long//shr $i.LSHR #$.Long #$.Int #$.Long]
+ [long//ushr $i.LUSHR #$.Long #$.Int #$.Long]
+
+ [float//+ $i.FADD #$.Float #$.Float #$.Float]
+ [float//- $i.FSUB #$.Float #$.Float #$.Float]
+ [float//* $i.FMUL #$.Float #$.Float #$.Float]
+ [float/// $i.FDIV #$.Float #$.Float #$.Float]
+ [float//% $i.FREM #$.Float #$.Float #$.Float]
+
+ [double//+ $i.DADD #$.Double #$.Double #$.Double]
+ [double//- $i.DSUB #$.Double #$.Double #$.Double]
+ [double//* $i.DMUL #$.Double #$.Double #$.Double]
+ [double/// $i.DDIV #$.Double #$.Double #$.Double]
+ [double//% $i.DREM #$.Double #$.Double #$.Double]
+ )
+
+(do-template [ ]
+ [(def: ( [xI yI])
+ @.Binary
+ (<| $i.with-label (function [@then])
+ $i.with-label (function [@end])
+ (|>> xI ($i.unwrap )
+ yI ($i.unwrap )
+ ( @then)
+ ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
+ ($i.GOTO @end)
+ ($i.label @then)
+ ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
+ ($i.label @end))))]
+
+ [int//= $i.IF_ICMPEQ #$.Int #$.Int #$.Boolean]
+ [int//< $i.IF_ICMPLT #$.Int #$.Int #$.Boolean]
+
+ [char//= $i.IF_ICMPEQ #$.Char #$.Char #$.Boolean]
+ [char//< $i.IF_ICMPLT #$.Char #$.Char #$.Boolean]
+ )
+
+(do-template [ ]
+ [(def: ( [xI yI])
+ @.Binary
+ (<| $i.with-label (function [@then])
+ $i.with-label (function [@end])
+ (|>> xI ($i.unwrap )
+ yI ($i.unwrap )
+
+ ($i.int )
+ ($i.IF_ICMPEQ @then)
+ ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
+ ($i.GOTO @end)
+ ($i.label @then)
+ ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
+ ($i.label @end))))]
+
+ [long//= $i.LCMP 0 #$.Long #$.Long #$.Boolean]
+ [long//< $i.LCMP -1 #$.Long #$.Long #$.Boolean]
+
+ [float//= $i.FCMPG 0 #$.Float #$.Float #$.Boolean]
+ [float//< $i.FCMPG -1 #$.Float #$.Float #$.Boolean]
+
+ [double//= $i.DCMPG 0 #$.Double #$.Double #$.Boolean]
+ [double//< $i.DCMPG -1 #$.Double #$.Double #$.Boolean]
+ )
+
+(def: int-procs
+ @.Bundle
+ (<| (@.prefix "int")
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary int//+))
+ (@.install "-" (@.binary int//-))
+ (@.install "*" (@.binary int//*))
+ (@.install "/" (@.binary int///))
+ (@.install "%" (@.binary int//%))
+ (@.install "=" (@.binary int//=))
+ (@.install "<" (@.binary int//<))
+ (@.install "and" (@.binary int//and))
+ (@.install "or" (@.binary int//or))
+ (@.install "xor" (@.binary int//xor))
+ (@.install "shl" (@.binary int//shl))
+ (@.install "shr" (@.binary int//shr))
+ (@.install "ushr" (@.binary int//ushr))
+ )))
+
+(def: long-procs
+ @.Bundle
+ (<| (@.prefix "long")
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary long//+))
+ (@.install "-" (@.binary long//-))
+ (@.install "*" (@.binary long//*))
+ (@.install "/" (@.binary long///))
+ (@.install "%" (@.binary long//%))
+ (@.install "=" (@.binary long//=))
+ (@.install "<" (@.binary long//<))
+ (@.install "and" (@.binary long//and))
+ (@.install "or" (@.binary long//or))
+ (@.install "xor" (@.binary long//xor))
+ (@.install "shl" (@.binary long//shl))
+ (@.install "shr" (@.binary long//shr))
+ (@.install "ushr" (@.binary long//ushr))
+ )))
+
+(def: float-procs
+ @.Bundle
+ (<| (@.prefix "float")
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary float//+))
+ (@.install "-" (@.binary float//-))
+ (@.install "*" (@.binary float//*))
+ (@.install "/" (@.binary float///))
+ (@.install "%" (@.binary float//%))
+ (@.install "=" (@.binary float//=))
+ (@.install "<" (@.binary float//<))
+ )))
+
+(def: double-procs
+ @.Bundle
+ (<| (@.prefix "double")
+ (|> (dict.new text.Hash)
+ (@.install "+" (@.binary double//+))
+ (@.install "-" (@.binary double//-))
+ (@.install "*" (@.binary double//*))
+ (@.install "/" (@.binary double///))
+ (@.install "%" (@.binary double//%))
+ (@.install "=" (@.binary double//=))
+ (@.install "<" (@.binary double//<))
+ )))
+
+(def: char-procs
+ @.Bundle
+ (<| (@.prefix "char")
+ (|> (dict.new text.Hash)
+ (@.install "=" (@.binary char//=))
+ (@.install "<" (@.binary char//<))
+ )))
+
+(def: (array//length arrayI)
+ @.Unary
+ (|>> arrayI
+ $i.ARRAYLENGTH
+ $i.I2L
+ ($i.wrap #$.Long)))
+
+(def: (array//new proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Nat level)] [_ (#.Text class)] lengthS))
+ (do macro.Monad
+ [lengthI (translate lengthS)
+ #let [arrayJT ($t.array level (case class
+ "boolean" $t.boolean
+ "byte" $t.byte
+ "short" $t.short
+ "int" $t.int
+ "long" $t.long
+ "float" $t.float
+ "double" $t.double
+ "char" $t.char
+ _ ($t.class class (list))))]]
+ (wrap (|>> lengthI
+ ($i.unwrap #$.Long)
+ $i.L2I
+ ($i.array arrayJT))))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: (array//read proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)] idxS arrayS))
+ (do macro.Monad
+ [arrayI (translate arrayS)
+ idxI (translate idxS)
+ #let [loadI (case class
+ "boolean" (|>> $i.BALOAD ($i.wrap #$.Boolean))
+ "byte" (|>> $i.BALOAD ($i.wrap #$.Byte))
+ "short" (|>> $i.SALOAD ($i.wrap #$.Short))
+ "int" (|>> $i.IALOAD ($i.wrap #$.Int))
+ "long" (|>> $i.LALOAD ($i.wrap #$.Long))
+ "float" (|>> $i.FALOAD ($i.wrap #$.Float))
+ "double" (|>> $i.DALOAD ($i.wrap #$.Double))
+ "char" (|>> $i.CALOAD ($i.wrap #$.Char))
+ _ $i.AALOAD)]]
+ (wrap (|>> arrayI
+ idxI
+ ($i.unwrap #$.Long)
+ $i.L2I
+ loadI)))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: (array//write proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)] idxS valueS arrayS))
+ (do macro.Monad
+ [arrayI (translate arrayS)
+ idxI (translate idxS)
+ valueI (translate valueS)
+ #let [storeI (case class
+ "boolean" (|>> ($i.unwrap #$.Boolean) $i.BASTORE)
+ "byte" (|>> ($i.unwrap #$.Byte) $i.BASTORE)
+ "short" (|>> ($i.unwrap #$.Short) $i.SASTORE)
+ "int" (|>> ($i.unwrap #$.Int) $i.IASTORE)
+ "long" (|>> ($i.unwrap #$.Long) $i.LASTORE)
+ "float" (|>> ($i.unwrap #$.Float) $i.FASTORE)
+ "double" (|>> ($i.unwrap #$.Double) $i.DASTORE)
+ "char" (|>> ($i.unwrap #$.Char) $i.CASTORE)
+ _ $i.AASTORE)]]
+ (wrap (|>> arrayI
+ $i.DUP
+ idxI
+ ($i.unwrap #$.Long)
+ $i.L2I
+ valueI
+ storeI)))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: array-procs
+ @.Bundle
+ (<| (@.prefix "array")
+ (|> (dict.new text.Hash)
+ (@.install "length" (@.unary array//length))
+ (@.install "new" array//new)
+ (@.install "read" array//read)
+ (@.install "write" array//write)
+ )))
+
+(def: (object//null _)
+ @.Nullary
+ $i.NULL)
+
+(def: (object//null? objectI)
+ @.Unary
+ (<| $i.with-label (function [@then])
+ $i.with-label (function [@end])
+ (|>> objectI
+ ($i.IFNULL @then)
+ ($i.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list)))
+ ($i.GOTO @end)
+ ($i.label @then)
+ ($i.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list)))
+ ($i.label @end))))
+
+(def: (object//synchronized [monitorI exprI])
+ @.Binary
+ (|>> monitorI
+ $i.DUP
+ $i.MONITORENTER
+ exprI
+ $i.SWAP
+ $i.MONITOREXIT))
+
+(def: (object//throw exceptionI)
+ @.Unary
+ (|>> exceptionI
+ $i.ATHROW))
+
+(def: (object//class proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)]))
+ (do macro.Monad
+ []
+ (wrap (|>> ($i.string class)
+ ($i.INVOKESTATIC "java.lang.Class" "forName"
+ ($t.method (list ($t.class "java.lang.String" (list)))
+ (#.Some ($t.class "java.lang.Class" (list)))
+ (list))
+ false))))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: (object//instance? proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)] objectS))
+ (do macro.Monad
+ [objectI (translate objectS)]
+ (wrap (|>> objectI
+ ($i.INSTANCEOF class)
+ ($i.wrap #$.Boolean))))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: object-procs
+ @.Bundle
+ (<| (@.prefix "object")
+ (|> (dict.new text.Hash)
+ (@.install "null" (@.nullary object//null))
+ (@.install "null?" (@.unary object//null?))
+ (@.install "synchronized" (@.binary object//synchronized))
+ (@.install "throw" (@.unary object//throw))
+ (@.install "class" object//class)
+ (@.install "instance?" object//instance?)
+ )))
+
+(def: primitives
+ (Dict Text $.Primitive)
+ (|> (list ["boolean" #$.Boolean]
+ ["byte" #$.Byte]
+ ["short" #$.Short]
+ ["int" #$.Int]
+ ["long" #$.Long]
+ ["float" #$.Float]
+ ["double" #$.Double]
+ ["char" #$.Char])
+ (dict.from-list text.Hash)))
+
+(def: (static//get proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)]))
+ (do macro.Monad
+ []
+ (case (dict.get unboxed primitives)
+ (#.Some primitive)
+ (let [primitive (case unboxed
+ "boolean" #$.Boolean
+ "byte" #$.Byte
+ "short" #$.Short
+ "int" #$.Int
+ "long" #$.Long
+ "float" #$.Float
+ "double" #$.Double
+ "char" #$.Char
+ _ (undefined))]
+ (wrap (|>> ($i.GETSTATIC class field (#$.Primitive primitive))
+ ($i.wrap primitive))))
+
+ #.None
+ (wrap ($i.GETSTATIC class field ($t.class unboxed (list))))))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: (static//put proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS))
+ (do macro.Monad
+ [valueI (translate valueS)]
+ (case (dict.get unboxed primitives)
+ (#.Some primitive)
+ (let [primitive (case unboxed
+ "boolean" #$.Boolean
+ "byte" #$.Byte
+ "short" #$.Short
+ "int" #$.Int
+ "long" #$.Long
+ "float" #$.Float
+ "double" #$.Double
+ "char" #$.Char
+ _ (undefined))]
+ (wrap (|>> valueI
+ ($i.unwrap primitive)
+ ($i.PUTSTATIC class field (#$.Primitive primitive))
+ ($i.string hostL.unit))))
+
+ #.None
+ (wrap (|>> valueI
+ ($i.CHECKCAST class)
+ ($i.PUTSTATIC class field ($t.class class (list)))
+ ($i.string hostL.unit)))))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: (virtual//get proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] objectS))
+ (do macro.Monad
+ [objectI (translate objectS)]
+ (case (dict.get unboxed primitives)
+ (#.Some primitive)
+ (let [primitive (case unboxed
+ "boolean" #$.Boolean
+ "byte" #$.Byte
+ "short" #$.Short
+ "int" #$.Int
+ "long" #$.Long
+ "float" #$.Float
+ "double" #$.Double
+ "char" #$.Char
+ _ (undefined))]
+ (wrap (|>> objectI
+ ($i.CHECKCAST class)
+ ($i.GETFIELD class field (#$.Primitive primitive))
+ ($i.wrap primitive))))
+
+ #.None
+ (wrap (|>> objectI
+ ($i.CHECKCAST class)
+ ($i.GETFIELD class field ($t.class unboxed (list)))))))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: (virtual//put proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list [_ (#.Text class)] [_ (#.Text field)] [_ (#.Text unboxed)] valueS objectS))
+ (do macro.Monad
+ [valueI (translate valueS)
+ objectI (translate objectS)]
+ (case (dict.get unboxed primitives)
+ (#.Some primitive)
+ (let [primitive (case unboxed
+ "boolean" #$.Boolean
+ "byte" #$.Byte
+ "short" #$.Short
+ "int" #$.Int
+ "long" #$.Long
+ "float" #$.Float
+ "double" #$.Double
+ "char" #$.Char
+ _ (undefined))]
+ (wrap (|>> objectI
+ ($i.CHECKCAST class)
+ $i.DUP
+ valueI
+ ($i.unwrap primitive)
+ ($i.PUTFIELD class field (#$.Primitive primitive)))))
+
+ #.None
+ (wrap (|>> objectI
+ ($i.CHECKCAST class)
+ $i.DUP
+ valueI
+ ($i.CHECKCAST unboxed)
+ ($i.PUTFIELD class field ($t.class unboxed (list)))))))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(def: base-type
+ (l.Lexer $.Type)
+ ($_ p.either
+ (p.after (l.this "boolean") (parser/wrap $t.boolean))
+ (p.after (l.this "byte") (parser/wrap $t.byte))
+ (p.after (l.this "short") (parser/wrap $t.short))
+ (p.after (l.this "int") (parser/wrap $t.int))
+ (p.after (l.this "long") (parser/wrap $t.long))
+ (p.after (l.this "float") (parser/wrap $t.float))
+ (p.after (l.this "double") (parser/wrap $t.double))
+ (p.after (l.this "char") (parser/wrap $t.char))
+ (parser/map (function [name]
+ ($t.class name (list)))
+ (l.many (l.none-of "[")))
+ ))
+
+(def: java-type
+ (l.Lexer $.Type)
+ (do p.Monad
+ [raw base-type
+ nesting (p.some (l.this "[]"))]
+ (wrap ($t.array (list.size nesting) raw))))
+
+(def: (translate-type argD)
+ (-> Text (Meta $.Type))
+ (case (l.run argD java-type)
+ (#e.Error error)
+ (&.throw Invalid-Syntax-For-JVM-Type argD)
+
+ (#e.Success type)
+ (macro/wrap type)))
+
+(def: (prepare-input inputT inputI)
+ (-> $.Type $.Inst $.Inst)
+ (case inputT
+ (#$.Primitive primitive)
+ (|>> inputI ($i.unwrap primitive))
+
+ (#$.Generic generic)
+ (case generic
+ (^or (#$.Var _) (#$.Wildcard _))
+ (|>> inputI ($i.CHECKCAST "java.lang.Object"))
+
+ (#$.Class class-name _)
+ (|>> inputI ($i.CHECKCAST class-name)))
+
+ _
+ (|>> inputI ($i.CHECKCAST ($t.descriptor inputT)))))
+
+(def: (translate-args translate argsS)
+ (-> (-> ls.Synthesis (Meta $.Inst)) (List ls.Synthesis)
+ (Meta (List [$.Type $.Inst])))
+ (case argsS
+ #.Nil
+ (macro/wrap #.Nil)
+
+ (^ (list& [_ (#.Tuple (list [_ (#.Text argD)] argS))] tail))
+ (do macro.Monad
+ [argT (translate-type argD)
+ argI (:: @ map (prepare-input argT) (translate argS))
+ =tail (translate-args translate tail)]
+ (wrap (list& [argT argI] =tail)))
+
+ _
+ (&.throw Invalid-Syntax-For-Argument-Generation "")))
+
+(def: (method-return-type description)
+ (-> Text (Meta (Maybe $.Type)))
+ (case description
+ "void"
+ (macro/wrap #.None)
+
+ _
+ (macro/map (|>> #.Some) (translate-type description))))
+
+(def: (prepare-return returnT returnI)
+ (-> (Maybe $.Type) $.Inst $.Inst)
+ (case returnT
+ #.None
+ (|>> returnI
+ ($i.string hostL.unit))
+
+ (#.Some type)
+ (case type
+ (#$.Primitive primitive)
+ (|>> returnI ($i.wrap primitive))
+
+ _
+ returnI)))
+
+(def: (invoke//static proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list& [_ (#.Text class)] [_ (#.Text method)]
+ [_ (#.Text unboxed)] argsS))
+ (do macro.Monad
+ [argsTI (translate-args translate argsS)
+ returnT (method-return-type unboxed)
+ #let [callI (|>> ($i.fuse (list/map product.right argsTI))
+ ($i.INVOKESTATIC class method
+ ($t.method (list/map product.left argsTI) returnT (list))
+ false))]]
+ (wrap (prepare-return returnT callI)))
+
+ _
+ (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
+
+(do-template [ ]
+ [(def: ( proc translate inputs)
+ (-> Text @.Proc)
+ (case inputs
+ (^ (list& [_ (#.Text class)] [_ (#.Text method)]
+ [_ (#.Text unboxed)] objectS argsS))
+ (do macro.Monad
+ [objectI (translate objectS)
+ argsTI (translate-args translate argsS)
+ returnT (method-return-type unboxed)
+ #let [callI (|>> objectI
+ ($i.CHECKCAST class)
+ ($i.fuse (list/map product.right argsTI))
+ ( class method
+ ($t.method (list/map product.left argsTI) returnT (list))
+