aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation/jvm/procedure
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/jvm/procedure')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux (renamed from new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux)95
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux761
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux753
3 files changed, 774 insertions, 835 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
index b19287b4e..aeaa1d664 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.lux
@@ -9,22 +9,21 @@
["." text
format]
[collection
- ["." list ("#/." functor)]
["." dictionary]]]
- ["." macro (#+ with-gensyms)
- ["." code]
- ["s" syntax (#+ syntax:)]]
[tool
[compiler
["." synthesis (#+ Synthesis)]
["." phase
+ [generation
+ [extension (#+ Nullary Unary Binary Trinary Variadic
+ nullary unary binary trinary variadic)]]
["." extension
["." bundle]]]]]
[host (#+ import:)]]
[luxc
[lang
[host
- ["$" jvm (#+ Label Inst Method Handler Bundle)
+ ["$" jvm (#+ Label Inst Method Bundle)
["_t" type]
["_" inst]]]]]
["." ///
@@ -34,55 +33,10 @@
(#static MIN_VALUE Double)
(#static MAX_VALUE Double))
-## [Types]
-(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-Array $.Type (_t.array 1 ///.$Object))
(def: $String $.Type (_t.class "java.lang.String" (list)))
(def: $CharSequence $.Type (_t.class "java.lang.CharSequence" (list)))
-(syntax: (arity: {name s.local-identifier} {arity s.nat})
- (with-gensyms [g!_ g!extension g!extension-name g!phase g!inputs]
- (do @
- [g!inputC+ (monad.seq @ (list.repeat arity (macro.gensym "input")))
- #let [arityC (code.nat arity)]]
- (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension))
- (-> (-> (..Vector (~ arityC) Inst) Inst) ..Handler)
- (function ((~ g!_) (~ g!extension-name) (~ g!phase) (~ g!inputs))
- (case (~ g!inputs)
- (^ (list (~+ g!inputC+)))
- (do phase.monad
- [(~+ (|> g!inputC+
- (list/map (function (_ g!input)
- (list g!input (` ((~ g!phase) (~ g!input))))))
- list.concat))]
- ((~' wrap) ((~ g!extension) [(~+ g!inputC+)])))
-
- (~ g!_)
- (phase.fail (ex.construct extension.incorrect-arity
- [(~ g!extension-name) (~ arityC) (list.size (~ g!inputs))])))))))))))
-
-(arity: nullary 0)
-(arity: unary 1)
-(arity: binary 2)
-(arity: trinary 3)
-
-(def: #export (variadic extension)
- (-> Variadic Handler)
- (function (_ extension-name phase inputsS)
- (do phase.monad
- [inputsH (monad.map @ phase inputsS)]
- (wrap (extension inputsH)))))
-
-## [Instructions]
(def: lux-intI Inst (|>> _.I2L (_.wrap #$.Long)))
(def: jvm-intI Inst (|>> (_.unwrap #$.Long) _.L2I))
(def: check-stringI Inst (_.CHECKCAST "java.lang.String"))
@@ -102,26 +56,23 @@
(def: unitI Inst (_.string synthesis.unit))
-## Extensions
-### Lux
(def: (lux::is [referenceI sampleI])
- Binary
+ (Binary Inst)
(|>> referenceI
sampleI
(predicateI _.IF_ACMPEQ)))
(def: (lux::try riskyI)
- Unary
+ (Unary Inst)
(|>> riskyI
(_.CHECKCAST ///.function-class)
(_.INVOKESTATIC ///.runtime-class "try"
(_t.method (list ///.$Function) (#.Some $Object-Array) (list))
#0)))
-### Bits
(template [<name> <op>]
[(def: (<name> [maskI inputI])
- Binary
+ (Binary Inst)
(|>> inputI (_.unwrap #$.Long)
maskI (_.unwrap #$.Long)
<op> (_.wrap #$.Long)))]
@@ -133,7 +84,7 @@
(template [<name> <op>]
[(def: (<name> [shiftI inputI])
- Binary
+ (Binary Inst)
(|>> inputI (_.unwrap #$.Long)
shiftI jvm-intI
<op>
@@ -144,10 +95,9 @@
[bit::logical-right-shift _.LUSHR]
)
-### Numbers
(template [<name> <const> <type>]
[(def: (<name> _)
- Nullary
+ (Nullary Inst)
(|>> <const> (_.wrap <type>)))]
[frac::smallest (_.double (Double::MIN_VALUE)) #$.Double]
@@ -157,7 +107,7 @@
(template [<name> <type> <op>]
[(def: (<name> [paramI subjectI])
- Binary
+ (Binary Inst)
(|>> subjectI (_.unwrap <type>)
paramI (_.unwrap <type>)
<op>
@@ -179,7 +129,7 @@
(template [<eq> <lt> <unwrap> <cmp>]
[(template [<name> <reference>]
[(def: (<name> [paramI subjectI])
- Binary
+ (Binary Inst)
(|>> subjectI <unwrap>
paramI <unwrap>
<cmp>
@@ -195,7 +145,7 @@
(template [<name> <prepare> <transform>]
[(def: (<name> inputI)
- Unary
+ (Unary Inst)
(|>> inputI <prepare> <transform>))]
[int::frac (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)]
@@ -209,9 +159,8 @@
(_.INVOKESTATIC ///.runtime-class "decode_frac" (_t.method (list $String) (#.Some $Object-Array) (list)) #0)]
)
-### Text
(def: (text::size inputI)
- Unary
+ (Unary Inst)
(|>> inputI
..check-stringI
(_.INVOKEVIRTUAL "java.lang.String" "length" (_t.method (list) (#.Some _t.int) (list)) #0)
@@ -219,7 +168,7 @@
(template [<name> <pre-subject> <pre-param> <op> <post>]
[(def: (<name> [paramI subjectI])
- Binary
+ (Binary Inst)
(|>> subjectI <pre-subject>
paramI <pre-param>
<op> <post>))]
@@ -236,13 +185,13 @@
)
(def: (text::concat [leftI rightI])
- Binary
+ (Binary Inst)
(|>> leftI ..check-stringI
rightI ..check-stringI
(_.INVOKEVIRTUAL "java.lang.String" "concat" (_t.method (list $String) (#.Some $String) (list)) #0)))
(def: (text::clip [startI endI subjectI])
- Trinary
+ (Trinary Inst)
(|>> subjectI ..check-stringI
startI jvm-intI
endI jvm-intI
@@ -250,7 +199,7 @@
(def: index-method Method (_t.method (list $String _t.int) (#.Some _t.int) (list)))
(def: (text::index [startI partI textI])
- Trinary
+ (Trinary Inst)
(<| _.with-label (function (_ @not-found))
_.with-label (function (_ @end))
(|>> textI ..check-stringI
@@ -268,10 +217,9 @@
runtime.noneI
(_.label @end))))
-### I/O
(def: string-method Method (_t.method (list $String) #.None (list)))
(def: (io::log messageI)
- Unary
+ (Unary Inst)
(|>> (_.GETSTATIC "java.lang.System" "out" (_t.class "java.io.PrintStream" (list)))
messageI
..check-stringI
@@ -279,7 +227,7 @@
unitI))
(def: (io::error messageI)
- Unary
+ (Unary Inst)
(|>> (_.NEW "java.lang.Error")
_.DUP
messageI
@@ -288,17 +236,16 @@
_.ATHROW))
(def: (io::exit codeI)
- Unary
+ (Unary Inst)
(|>> codeI jvm-intI
(_.INVOKESTATIC "java.lang.System" "exit" (_t.method (list _t.int) #.None (list)) #0)
_.NULL))
(def: (io::current-time _)
- Nullary
+ (Nullary Inst)
(|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" (_t.method (list) (#.Some _t.long) (list)) #0)
(_.wrap #$.Long)))
-## Bundles
(def: bundle::lux
Bundle
(|> (: Bundle bundle.empty)
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
deleted file mode 100644
index 624af7ed8..000000000
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.jvm.lux
+++ /dev/null
@@ -1,761 +0,0 @@
-(.module:
- lux
- (lux (control [monad #+ do]
- ["p" parser ("#/." monad)]
- ["ex" exception #+ exception:])
- (data [product]
- ["e" error]
- [text ("#/." equivalence)]
- (text format
- ["l" lexer])
- (coll [list ("#/." functor)]
- (dictionary ["dict" unordered #+ Dict])))
- [macro ("#/." monad)]
- (macro [code]
- ["s" syntax #+ syntax:])
- [host])
- (luxc ["&" lang]
- (lang [".L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["_" inst]))
- ["la" analysis]
- (extension (analysis ["&." host]))
- ["ls" synthesis]))
- (// ["@" common]))
-
-(template [<name>]
- [(exception: #export (<name> {message Text})
- message)]
-
- [Invalid-Syntax-For-JVM-Type]
- [Invalid-Syntax-For-Argument-Generation]
- )
-
-(template [<name> <inst>]
- [(def: <name>
- $.Inst
- <inst>)]
-
- [L2S (|>> _.L2I _.I2S)]
- [L2B (|>> _.L2I _.I2B)]
- [L2C (|>> _.L2I _.I2C)]
- )
-
-(template [<name> <unwrap> <conversion> <wrap>]
- [(def: (<name> inputI)
- @.Unary
- (if (is? _.NOP <conversion>)
- (|>> inputI
- (_.unwrap <unwrap>)
- (_.wrap <wrap>))
- (|>> inputI
- (_.unwrap <unwrap>)
- <conversion>
- (_.wrap <wrap>))))]
-
- [convert//double-to-float #$.Double _.D2F #$.Float]
- [convert//double-to-int #$.Double _.D2I #$.Int]
- [convert//double-to-long #$.Double _.D2L #$.Long]
- [convert//float-to-double #$.Float _.F2D #$.Double]
- [convert//float-to-int #$.Float _.F2I #$.Int]
- [convert//float-to-long #$.Float _.F2L #$.Long]
- [convert//int-to-byte #$.Int _.I2B #$.Byte]
- [convert//int-to-char #$.Int _.I2C #$.Char]
- [convert//int-to-double #$.Int _.I2D #$.Double]
- [convert//int-to-float #$.Int _.I2F #$.Float]
- [convert//int-to-long #$.Int _.I2L #$.Long]
- [convert//int-to-short #$.Int _.I2S #$.Short]
- [convert//long-to-double #$.Long _.L2D #$.Double]
- [convert//long-to-float #$.Long _.L2F #$.Float]
- [convert//long-to-int #$.Long _.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 _.I2B #$.Byte]
- [convert//char-to-short #$.Char _.I2S #$.Short]
- [convert//char-to-int #$.Char _.NOP #$.Int]
- [convert//char-to-long #$.Char _.I2L #$.Long]
- [convert//byte-to-long #$.Byte _.I2L #$.Long]
- [convert//short-to-long #$.Short _.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))
- )))
-
-(template [<name> <op> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @.Binary
- (|>> xI (_.unwrap <unwrapX>)
- yI (_.unwrap <unwrapY>)
- <op> (_.wrap <wrap>)))]
-
- [int//+ _.IADD #$.Int #$.Int #$.Int]
- [int//- _.ISUB #$.Int #$.Int #$.Int]
- [int//* _.IMUL #$.Int #$.Int #$.Int]
- [int/// _.IDIV #$.Int #$.Int #$.Int]
- [int//% _.IREM #$.Int #$.Int #$.Int]
- [int//and _.IAND #$.Int #$.Int #$.Int]
- [int//or _.IOR #$.Int #$.Int #$.Int]
- [int//xor _.IXOR #$.Int #$.Int #$.Int]
- [int//shl _.ISHL #$.Int #$.Int #$.Int]
- [int//shr _.ISHR #$.Int #$.Int #$.Int]
- [int//ushr _.IUSHR #$.Int #$.Int #$.Int]
-
- [long//+ _.LADD #$.Long #$.Long #$.Long]
- [long//- _.LSUB #$.Long #$.Long #$.Long]
- [long//* _.LMUL #$.Long #$.Long #$.Long]
- [long/// _.LDIV #$.Long #$.Long #$.Long]
- [long//% _.LREM #$.Long #$.Long #$.Long]
- [long//and _.LAND #$.Long #$.Long #$.Long]
- [long//or _.LOR #$.Long #$.Long #$.Long]
- [long//xor _.LXOR #$.Long #$.Long #$.Long]
- [long//shl _.LSHL #$.Long #$.Int #$.Long]
- [long//shr _.LSHR #$.Long #$.Int #$.Long]
- [long//ushr _.LUSHR #$.Long #$.Int #$.Long]
-
- [float//+ _.FADD #$.Float #$.Float #$.Float]
- [float//- _.FSUB #$.Float #$.Float #$.Float]
- [float//* _.FMUL #$.Float #$.Float #$.Float]
- [float/// _.FDIV #$.Float #$.Float #$.Float]
- [float//% _.FREM #$.Float #$.Float #$.Float]
-
- [double//+ _.DADD #$.Double #$.Double #$.Double]
- [double//- _.DSUB #$.Double #$.Double #$.Double]
- [double//* _.DMUL #$.Double #$.Double #$.Double]
- [double/// _.DDIV #$.Double #$.Double #$.Double]
- [double//% _.DREM #$.Double #$.Double #$.Double]
- )
-
-(def: boolean-class ($t.class "java.lang.Boolean" (list)))
-(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class))
-(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class))
-
-(template [<name> <op> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @.Binary
- (<| _.with-label (function (_ @then))
- _.with-label (function (_ @end))
- (|>> xI (_.unwrap <unwrapX>)
- yI (_.unwrap <unwrapY>)
- (<op> @then)
- falseI
- (_.GOTO @end)
- (_.label @then)
- trueI
- (_.label @end))))]
-
- [int//= _.IF_ICMPEQ #$.Int #$.Int #$.Boolean]
- [int//< _.IF_ICMPLT #$.Int #$.Int #$.Boolean]
-
- [char//= _.IF_ICMPEQ #$.Char #$.Char #$.Boolean]
- [char//< _.IF_ICMPLT #$.Char #$.Char #$.Boolean]
- )
-
-(template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @.Binary
- (<| _.with-label (function (_ @then))
- _.with-label (function (_ @end))
- (|>> xI (_.unwrap <unwrapX>)
- yI (_.unwrap <unwrapY>)
- <op>
- (_.int <reference>)
- (_.IF_ICMPEQ @then)
- falseI
- (_.GOTO @end)
- (_.label @then)
- trueI
- (_.label @end))))]
-
- [long//= _.LCMP 0 #$.Long #$.Long #$.Boolean]
- [long//< _.LCMP -1 #$.Long #$.Long #$.Boolean]
-
- [float//= _.FCMPG 0 #$.Float #$.Float #$.Boolean]
- [float//< _.FCMPG -1 #$.Float #$.Float #$.Boolean]
-
- [double//= _.DCMPG 0 #$.Double #$.Double #$.Boolean]
- [double//< _.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
- _.ARRAYLENGTH
- _.I2L
- (_.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
- (_.unwrap #$.Long)
- _.L2I
- (_.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" (|>> _.BALOAD (_.wrap #$.Boolean))
- "byte" (|>> _.BALOAD (_.wrap #$.Byte))
- "short" (|>> _.SALOAD (_.wrap #$.Short))
- "int" (|>> _.IALOAD (_.wrap #$.Int))
- "long" (|>> _.LALOAD (_.wrap #$.Long))
- "float" (|>> _.FALOAD (_.wrap #$.Float))
- "double" (|>> _.DALOAD (_.wrap #$.Double))
- "char" (|>> _.CALOAD (_.wrap #$.Char))
- _ _.AALOAD)]]
- (wrap (|>> arrayI
- idxI
- (_.unwrap #$.Long)
- _.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" (|>> (_.unwrap #$.Boolean) _.BASTORE)
- "byte" (|>> (_.unwrap #$.Byte) _.BASTORE)
- "short" (|>> (_.unwrap #$.Short) _.SASTORE)
- "int" (|>> (_.unwrap #$.Int) _.IASTORE)
- "long" (|>> (_.unwrap #$.Long) _.LASTORE)
- "float" (|>> (_.unwrap #$.Float) _.FASTORE)
- "double" (|>> (_.unwrap #$.Double) _.DASTORE)
- "char" (|>> (_.unwrap #$.Char) _.CASTORE)
- _ _.AASTORE)]]
- (wrap (|>> arrayI
- _.DUP
- idxI
- (_.unwrap #$.Long)
- _.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
- _.NULL)
-
-(def: (object//null? objectI)
- @.Unary
- (<| _.with-label (function (_ @then))
- _.with-label (function (_ @end))
- (|>> objectI
- (_.IFNULL @then)
- falseI
- (_.GOTO @end)
- (_.label @then)
- trueI
- (_.label @end))))
-
-(def: (object//synchronized [monitorI exprI])
- @.Binary
- (|>> monitorI
- _.DUP
- _.MONITORENTER
- exprI
- _.SWAP
- _.MONITOREXIT))
-
-(def: (object//throw exceptionI)
- @.Unary
- (|>> exceptionI
- _.ATHROW))
-
-(def: (object//class proc translate inputs)
- (-> Text @.Proc)
- (case inputs
- (^ (list [_ (#.Text class)]))
- (do macro.monad
- []
- (wrap (|>> (_.string class)
- (_.INVOKESTATIC "java.lang.Class" "forName"
- ($t.method (list ($t.class "java.lang.String" (list)))
- (#.Some ($t.class "java.lang.Class" (list)))
- (list))
- #0))))
-
- _
- (&.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
- (_.INSTANCEOF class)
- (_.wrap #$.Boolean))))
-
- _
- (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-(def: (object//cast proc translate inputs)
- (-> Text @.Proc)
- (case inputs
- (^ (list [_ (#.Text from)] [_ (#.Text to)] valueS))
- (do macro.monad
- [valueI (translate valueS)]
- (case [from to]
- ## Wrap
- (^template [<primitive> <object> <type>]
- [<primitive> <object>]
- (wrap (|>> valueI (_.wrap <type>)))
-
- [<object> <primitive>]
- (wrap (|>> valueI (_.unwrap <type>))))
- (["boolean" "java.lang.Boolean" #$.Boolean]
- ["byte" "java.lang.Byte" #$.Byte]
- ["short" "java.lang.Short" #$.Short]
- ["int" "java.lang.Integer" #$.Int]
- ["long" "java.lang.Long" #$.Long]
- ["float" "java.lang.Float" #$.Float]
- ["double" "java.lang.Double" #$.Double]
- ["char" "java.lang.Character" #$.Char])
-
- _
- (wrap valueI)))
-
- _
- (&.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?)
- (@.install "cast" object//cast)
- )))
-
-(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 (|>> (_.GETSTATIC class field (#$.Primitive primitive))
- (_.wrap primitive))))
-
- #.None
- (wrap (_.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
- (_.unwrap primitive)
- (_.PUTSTATIC class field (#$.Primitive primitive))
- (_.string hostL.unit))))
-
- #.None
- (wrap (|>> valueI
- (_.CHECKCAST class)
- (_.PUTSTATIC class field ($t.class class (list)))
- (_.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
- (_.CHECKCAST class)
- (_.GETFIELD class field (#$.Primitive primitive))
- (_.wrap primitive))))
-
- #.None
- (wrap (|>> objectI
- (_.CHECKCAST class)
- (_.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
- (_.CHECKCAST class)
- _.DUP
- valueI
- (_.unwrap primitive)
- (_.PUTFIELD class field (#$.Primitive primitive)))))
-
- #.None
- (wrap (|>> objectI
- (_.CHECKCAST class)
- _.DUP
- valueI
- (_.CHECKCAST unboxed)
- (_.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: (translate-arg translate argS)
- (-> (-> ls.Synthesis (Meta $.Inst)) ls.Synthesis
- (Meta [$.Type $.Inst]))
- (case argS
- (^ [_ (#.Tuple (list [_ (#.Text argD)] argS))])
- (do macro.monad
- [argT (translate-type argD)
- argI (translate argS)]
- (wrap [argT argI]))
-
- _
- (&.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: (invoke//static proc translate inputs)
- (-> Text @.Proc)
- (case inputs
- (^ (list& [_ (#.Text class)] [_ (#.Text method)]
- [_ (#.Text unboxed)] argsS))
- (do macro.monad
- [argsTI (monad.map @ (translate-arg translate) argsS)
- returnT (method-return-type unboxed)]
- (wrap (|>> (_.fuse (list/map product.right argsTI))
- (_.INVOKESTATIC class method
- ($t.method (list/map product.left argsTI) returnT (list))
- #0))))
-
- _
- (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-(template [<name> <invoke> <interface?>]
- [(def: (<name> proc translate inputs)
- (-> Text @.Proc)
- (case inputs
- (^ (list& [_ (#.Text class)] [_ (#.Text method)]
- [_ (#.Text unboxed)] objectS argsS))
- (do macro.monad
- [objectI (translate objectS)
- argsTI (monad.map @ (translate-arg translate) argsS)
- returnT (method-return-type unboxed)]
- (wrap (|>> objectI
- (_.CHECKCAST class)
- (_.fuse (list/map product.right argsTI))
- (<invoke> class method
- ($t.method (list/map product.left argsTI) returnT (list))
- <interface?>))))
-
- _
- (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))]
-
- [invoke//virtual _.INVOKEVIRTUAL #0]
- [invoke//special _.INVOKESPECIAL #0]
- [invoke//interface _.INVOKEINTERFACE #1]
- )
-
-(def: (invoke//constructor proc translate inputs)
- (-> Text @.Proc)
- (case inputs
- (^ (list& [_ (#.Text class)] argsS))
- (do macro.monad
- [argsTI (monad.map @ (translate-arg translate) argsS)]
- (wrap (|>> (_.NEW class)
- _.DUP
- (_.fuse (list/map product.right argsTI))
- (_.INVOKESPECIAL class "<init>"
- ($t.method (list/map product.left argsTI) #.None (list))
- #0))))
-
- _
- (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs))))
-
-(def: member-procs
- @.Bundle
- (<| (@.prefix "member")
- (|> (dict.new text.hash)
- (dict.merge (<| (@.prefix "static")
- (|> (dict.new text.hash)
- (@.install "get" static//get)
- (@.install "put" static//put))))
- (dict.merge (<| (@.prefix "virtual")
- (|> (dict.new text.hash)
- (@.install "get" virtual//get)
- (@.install "put" virtual//put))))
- (dict.merge (<| (@.prefix "invoke")
- (|> (dict.new text.hash)
- (@.install "static" invoke//static)
- (@.install "virtual" invoke//virtual)
- (@.install "special" invoke//special)
- (@.install "interface" invoke//interface)
- (@.install "constructor" invoke//constructor))))
- )))
-
-(def: #export procedures
- @.Bundle
- (<| (@.prefix "jvm")
- (|> conversion-procs
- (dict.merge int-procs)
- (dict.merge long-procs)
- (dict.merge float-procs)
- (dict.merge double-procs)
- (dict.merge char-procs)
- (dict.merge array-procs)
- (dict.merge object-procs)
- (dict.merge member-procs)
- )))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
new file mode 100644
index 000000000..45e025d0b
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -0,0 +1,753 @@
+(.module:
+ [lux (#- int char)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["p" parser ("#@." monad)]
+ ["ex" exception (#+ exception:)]]
+ [data
+ ["." product]
+ ["." error]
+ ["." text
+ format
+ ["l" lexer]]
+ [collection
+ ["." list ("#@." functor)]
+ ["." dictionary (#+ Dictionary)]]]
+ [tool
+ [compiler
+ ["." synthesis (#+ Synthesis %synthesis)]
+ ["." phase ("#@." monad)
+ [generation
+ [extension (#+ Nullary Unary Binary
+ nullary unary binary)]]
+ ["." extension
+ ["." bundle]]]]]
+ [host (#+ import:)]]
+ [luxc
+ [lang
+ [host
+ ["$" jvm (#+ Primitive Label Inst Method Handler Bundle Operation)
+ ["_t" type]
+ ["_" inst]]]]])
+
+(template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
+
+ [invalid-syntax-for-jvm-type]
+ [invalid-syntax-for-argument-generation]
+ )
+
+(template [<name> <inst>]
+ [(def: <name>
+ Inst
+ <inst>)]
+
+ [L2S (|>> _.L2I _.I2S)]
+ [L2B (|>> _.L2I _.I2B)]
+ [L2C (|>> _.L2I _.I2C)]
+ )
+
+(template [<name> <unwrap> <conversion> <wrap>]
+ [(def: (<name> inputI)
+ (Unary Inst)
+ (if (is? _.NOP <conversion>)
+ (|>> inputI
+ (_.unwrap <unwrap>)
+ (_.wrap <wrap>))
+ (|>> inputI
+ (_.unwrap <unwrap>)
+ <conversion>
+ (_.wrap <wrap>))))]
+
+ [convert::double-to-float #$.Double _.D2F #$.Float]
+ [convert::double-to-int #$.Double _.D2I #$.Int]
+ [convert::double-to-long #$.Double _.D2L #$.Long]
+ [convert::float-to-double #$.Float _.F2D #$.Double]
+ [convert::float-to-int #$.Float _.F2I #$.Int]
+ [convert::float-to-long #$.Float _.F2L #$.Long]
+ [convert::int-to-byte #$.Int _.I2B #$.Byte]
+ [convert::int-to-char #$.Int _.I2C #$.Char]
+ [convert::int-to-double #$.Int _.I2D #$.Double]
+ [convert::int-to-float #$.Int _.I2F #$.Float]
+ [convert::int-to-long #$.Int _.I2L #$.Long]
+ [convert::int-to-short #$.Int _.I2S #$.Short]
+ [convert::long-to-double #$.Long _.L2D #$.Double]
+ [convert::long-to-float #$.Long _.L2F #$.Float]
+ [convert::long-to-int #$.Long _.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 _.I2B #$.Byte]
+ [convert::char-to-short #$.Char _.I2S #$.Short]
+ [convert::char-to-int #$.Char _.NOP #$.Int]
+ [convert::char-to-long #$.Char _.I2L #$.Long]
+ [convert::byte-to-long #$.Byte _.I2L #$.Long]
+ [convert::short-to-long #$.Short _.I2L #$.Long]
+ )
+
+(def: conversion
+ Bundle
+ (<| (bundle.prefix "convert")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "double-to-float" (unary convert::double-to-float))
+ (bundle.install "double-to-int" (unary convert::double-to-int))
+ (bundle.install "double-to-long" (unary convert::double-to-long))
+ (bundle.install "float-to-double" (unary convert::float-to-double))
+ (bundle.install "float-to-int" (unary convert::float-to-int))
+ (bundle.install "float-to-long" (unary convert::float-to-long))
+ (bundle.install "int-to-byte" (unary convert::int-to-byte))
+ (bundle.install "int-to-char" (unary convert::int-to-char))
+ (bundle.install "int-to-double" (unary convert::int-to-double))
+ (bundle.install "int-to-float" (unary convert::int-to-float))
+ (bundle.install "int-to-long" (unary convert::int-to-long))
+ (bundle.install "int-to-short" (unary convert::int-to-short))
+ (bundle.install "long-to-double" (unary convert::long-to-double))
+ (bundle.install "long-to-float" (unary convert::long-to-float))
+ (bundle.install "long-to-int" (unary convert::long-to-int))
+ (bundle.install "long-to-short" (unary convert::long-to-short))
+ (bundle.install "long-to-byte" (unary convert::long-to-byte))
+ (bundle.install "long-to-char" (unary convert::long-to-char))
+ (bundle.install "char-to-byte" (unary convert::char-to-byte))
+ (bundle.install "char-to-short" (unary convert::char-to-short))
+ (bundle.install "char-to-int" (unary convert::char-to-int))
+ (bundle.install "char-to-long" (unary convert::char-to-long))
+ (bundle.install "byte-to-long" (unary convert::byte-to-long))
+ (bundle.install "short-to-long" (unary convert::short-to-long))
+ )))
+
+(template [<name> <op> <unwrapX> <unwrapY> <wrap>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (|>> xI (_.unwrap <unwrapX>)
+ yI (_.unwrap <unwrapY>)
+ <op> (_.wrap <wrap>)))]
+
+ [int::+ _.IADD #$.Int #$.Int #$.Int]
+ [int::- _.ISUB #$.Int #$.Int #$.Int]
+ [int::* _.IMUL #$.Int #$.Int #$.Int]
+ [int::/ _.IDIV #$.Int #$.Int #$.Int]
+ [int::% _.IREM #$.Int #$.Int #$.Int]
+ [int::and _.IAND #$.Int #$.Int #$.Int]
+ [int::or _.IOR #$.Int #$.Int #$.Int]
+ [int::xor _.IXOR #$.Int #$.Int #$.Int]
+ [int::shl _.ISHL #$.Int #$.Int #$.Int]
+ [int::shr _.ISHR #$.Int #$.Int #$.Int]
+ [int::ushr _.IUSHR #$.Int #$.Int #$.Int]
+
+ [long::+ _.LADD #$.Long #$.Long #$.Long]
+ [long::- _.LSUB #$.Long #$.Long #$.Long]
+ [long::* _.LMUL #$.Long #$.Long #$.Long]
+ [long::/ _.LDIV #$.Long #$.Long #$.Long]
+ [long::% _.LREM #$.Long #$.Long #$.Long]
+ [long::and _.LAND #$.Long #$.Long #$.Long]
+ [long::or _.LOR #$.Long #$.Long #$.Long]
+ [long::xor _.LXOR #$.Long #$.Long #$.Long]
+ [long::shl _.LSHL #$.Long #$.Int #$.Long]
+ [long::shr _.LSHR #$.Long #$.Int #$.Long]
+ [long::ushr _.LUSHR #$.Long #$.Int #$.Long]
+
+ [float::+ _.FADD #$.Float #$.Float #$.Float]
+ [float::- _.FSUB #$.Float #$.Float #$.Float]
+ [float::* _.FMUL #$.Float #$.Float #$.Float]
+ [float::/ _.FDIV #$.Float #$.Float #$.Float]
+ [float::% _.FREM #$.Float #$.Float #$.Float]
+
+ [double::+ _.DADD #$.Double #$.Double #$.Double]
+ [double::- _.DSUB #$.Double #$.Double #$.Double]
+ [double::* _.DMUL #$.Double #$.Double #$.Double]
+ [double::/ _.DDIV #$.Double #$.Double #$.Double]
+ [double::% _.DREM #$.Double #$.Double #$.Double]
+ )
+
+(def: boolean-class (_t.class "java.lang.Boolean" (list)))
+(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class))
+(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class))
+
+(template [<name> <op> <unwrap>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI (_.unwrap <unwrap>)
+ yI (_.unwrap <unwrap>)
+ (<op> @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [int::= _.IF_ICMPEQ #$.Int]
+ [int::< _.IF_ICMPLT #$.Int]
+
+ [char::= _.IF_ICMPEQ #$.Char]
+ [char::< _.IF_ICMPLT #$.Char]
+ )
+
+(template [<name> <op> <reference> <unwrap>]
+ [(def: (<name> [xI yI])
+ (Binary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> xI (_.unwrap <unwrap>)
+ yI (_.unwrap <unwrap>)
+ <op>
+ (_.int <reference>)
+ (_.IF_ICMPEQ @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))]
+
+ [long::= _.LCMP +0 #$.Long]
+ [long::< _.LCMP -1 #$.Long]
+
+ [float::= _.FCMPG +0 #$.Float]
+ [float::< _.FCMPG -1 #$.Float]
+
+ [double::= _.DCMPG +0 #$.Double]
+ [double::< _.DCMPG -1 #$.Double]
+ )
+
+(def: int
+ Bundle
+ (<| (bundle.prefix "int")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary int::+))
+ (bundle.install "-" (binary int::-))
+ (bundle.install "*" (binary int::*))
+ (bundle.install "/" (binary int::/))
+ (bundle.install "%" (binary int::%))
+ (bundle.install "=" (binary int::=))
+ (bundle.install "<" (binary int::<))
+ (bundle.install "and" (binary int::and))
+ (bundle.install "or" (binary int::or))
+ (bundle.install "xor" (binary int::xor))
+ (bundle.install "shl" (binary int::shl))
+ (bundle.install "shr" (binary int::shr))
+ (bundle.install "ushr" (binary int::ushr))
+ )))
+
+(def: long
+ Bundle
+ (<| (bundle.prefix "long")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary long::+))
+ (bundle.install "-" (binary long::-))
+ (bundle.install "*" (binary long::*))
+ (bundle.install "/" (binary long::/))
+ (bundle.install "%" (binary long::%))
+ (bundle.install "=" (binary long::=))
+ (bundle.install "<" (binary long::<))
+ (bundle.install "and" (binary long::and))
+ (bundle.install "or" (binary long::or))
+ (bundle.install "xor" (binary long::xor))
+ (bundle.install "shl" (binary long::shl))
+ (bundle.install "shr" (binary long::shr))
+ (bundle.install "ushr" (binary long::ushr))
+ )))
+
+(def: float
+ Bundle
+ (<| (bundle.prefix "float")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary float::+))
+ (bundle.install "-" (binary float::-))
+ (bundle.install "*" (binary float::*))
+ (bundle.install "/" (binary float::/))
+ (bundle.install "%" (binary float::%))
+ (bundle.install "=" (binary float::=))
+ (bundle.install "<" (binary float::<))
+ )))
+
+(def: double
+ Bundle
+ (<| (bundle.prefix "double")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "+" (binary double::+))
+ (bundle.install "-" (binary double::-))
+ (bundle.install "*" (binary double::*))
+ (bundle.install "/" (binary double::/))
+ (bundle.install "%" (binary double::%))
+ (bundle.install "=" (binary double::=))
+ (bundle.install "<" (binary double::<))
+ )))
+
+(def: char
+ Bundle
+ (<| (bundle.prefix "char")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "=" (binary char::=))
+ (bundle.install "<" (binary char::<))
+ )))
+
+(def: (array::length arrayD arrayI)
+ (Binary Inst)
+ (|>> arrayI
+ (_.CHECKCAST arrayD)
+ _.ARRAYLENGTH
+ _.I2L
+ (_.wrap #$.Long)))
+
+(def: (array::new proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.i64 level)
+ (synthesis.text class)
+ lengthS))
+ (do phase.monad
+ [lengthI (generate lengthS)
+ #let [arrayJT (_t.array (.nat 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
+ (_.unwrap #$.Long)
+ _.L2I
+ (_.array arrayJT))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (array::read proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ idxS
+ arrayS))
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)
+ #let [loadI (case class
+ "boolean" (|>> _.BALOAD (_.wrap #$.Boolean))
+ "byte" (|>> _.BALOAD (_.wrap #$.Byte))
+ "short" (|>> _.SALOAD (_.wrap #$.Short))
+ "int" (|>> _.IALOAD (_.wrap #$.Int))
+ "long" (|>> _.LALOAD (_.wrap #$.Long))
+ "float" (|>> _.FALOAD (_.wrap #$.Float))
+ "double" (|>> _.DALOAD (_.wrap #$.Double))
+ "char" (|>> _.CALOAD (_.wrap #$.Char))
+ _ _.AALOAD)]]
+ (wrap (|>> arrayI
+ idxI
+ (_.unwrap #$.Long)
+ _.L2I
+ loadI)))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (array::write proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ idxS
+ valueS
+ arrayS))
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)
+ valueI (generate valueS)
+ #let [storeI (case class
+ "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE)
+ "byte" (|>> (_.unwrap #$.Byte) _.BASTORE)
+ "short" (|>> (_.unwrap #$.Short) _.SASTORE)
+ "int" (|>> (_.unwrap #$.Int) _.IASTORE)
+ "long" (|>> (_.unwrap #$.Long) _.LASTORE)
+ "float" (|>> (_.unwrap #$.Float) _.FASTORE)
+ "double" (|>> (_.unwrap #$.Double) _.DASTORE)
+ "char" (|>> (_.unwrap #$.Char) _.CASTORE)
+ _ _.AASTORE)]]
+ (wrap (|>> arrayI
+ _.DUP
+ idxI
+ (_.unwrap #$.Long)
+ _.L2I
+ valueI
+ storeI)))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: array
+ Bundle
+ (<| (bundle.prefix "array")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "length" (unary array::length))
+ (bundle.install "new" array::new)
+ (bundle.install "read" array::read)
+ (bundle.install "write" array::write)
+ )))
+
+(def: (object::null _)
+ (Nullary Inst)
+ _.NULL)
+
+(def: (object::null? objectI)
+ (Unary Inst)
+ (<| _.with-label (function (_ @then))
+ _.with-label (function (_ @end))
+ (|>> objectI
+ (_.IFNULL @then)
+ falseI
+ (_.GOTO @end)
+ (_.label @then)
+ trueI
+ (_.label @end))))
+
+(def: (object::synchronized [monitorI exprI])
+ (Binary Inst)
+ (|>> monitorI
+ _.DUP
+ _.MONITORENTER
+ exprI
+ _.SWAP
+ _.MONITOREXIT))
+
+(def: (object::throw exceptionI)
+ (Unary Inst)
+ (|>> exceptionI
+ _.ATHROW))
+
+(def: (object::class proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)))
+ (do phase.monad
+ []
+ (wrap (|>> (_.string class)
+ (_.INVOKESTATIC "java.lang.Class" "forName"
+ (_t.method (list (_t.class "java.lang.String" (list)))
+ (#.Some (_t.class "java.lang.Class" (list)))
+ (list))
+ false))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (object::instance? proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class) objectS))
+ (do phase.monad
+ [objectI (generate objectS)]
+ (wrap (|>> objectI
+ (_.INSTANCEOF class)
+ (_.wrap #$.Boolean))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (object::cast proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text from) (synthesis.text to) valueS))
+ (do phase.monad
+ [valueI (generate valueS)]
+ (case [from to]
+ ## Wrap
+ (^template [<primitive> <object> <type>]
+ [<primitive> <object>]
+ (wrap (|>> valueI (_.wrap <type>)))
+
+ [<object> <primitive>]
+ (wrap (|>> valueI (_.unwrap <type>))))
+ (["boolean" "java.lang.Boolean" #$.Boolean]
+ ["byte" "java.lang.Byte" #$.Byte]
+ ["short" "java.lang.Short" #$.Short]
+ ["int" "java.lang.Integer" #$.Int]
+ ["long" "java.lang.Long" #$.Long]
+ ["float" "java.lang.Float" #$.Float]
+ ["double" "java.lang.Double" #$.Double]
+ ["char" "java.lang.Character" #$.Char])
+
+ _
+ (wrap valueI)))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: object
+ Bundle
+ (<| (bundle.prefix "object")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "null" (nullary object::null))
+ (bundle.install "null?" (unary object::null?))
+ (bundle.install "synchronized" (binary object::synchronized))
+ (bundle.install "throw" (unary object::throw))
+ (bundle.install "class" object::class)
+ (bundle.install "instance?" object::instance?)
+ (bundle.install "cast" object::cast)
+ )))
+
+(def: primitives
+ (Dictionary Text Primitive)
+ (|> (list ["boolean" #$.Boolean]
+ ["byte" #$.Byte]
+ ["short" #$.Short]
+ ["int" #$.Int]
+ ["long" #$.Long]
+ ["float" #$.Float]
+ ["double" #$.Double]
+ ["char" #$.Char])
+ (dictionary.from-list text.hash)))
+
+(def: (static::get proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)))
+ (do phase.monad
+ []
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive))
+ (_.wrap primitive)))
+
+ #.None
+ (wrap (_.GETSTATIC class field (_t.class unboxed (list))))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (static::put proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)
+ valueS))
+ (do phase.monad
+ [valueI (generate valueS)]
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> valueI
+ (_.unwrap primitive)
+ (_.PUTSTATIC class field (#$.Primitive primitive))
+ (_.string synthesis.unit)))
+
+ #.None
+ (wrap (|>> valueI
+ (_.CHECKCAST class)
+ (_.PUTSTATIC class field (_t.class class (list)))
+ (_.string synthesis.unit)))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (virtual::get proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)
+ objectS))
+ (do phase.monad
+ [objectI (generate objectS)]
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.GETFIELD class field (#$.Primitive primitive))
+ (_.wrap primitive)))
+
+ #.None
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.GETFIELD class field (_t.class unboxed (list)))))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (virtual::put proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list (synthesis.text class)
+ (synthesis.text field)
+ (synthesis.text unboxed)
+ valueS
+ objectS))
+ (do phase.monad
+ [valueI (generate valueS)
+ objectI (generate objectS)]
+ (case (dictionary.get unboxed primitives)
+ (#.Some primitive)
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ _.DUP
+ valueI
+ (_.unwrap primitive)
+ (_.PUTFIELD class field (#$.Primitive primitive))))
+
+ #.None
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ _.DUP
+ valueI
+ (_.CHECKCAST unboxed)
+ (_.PUTFIELD class field (_t.class unboxed (list)))))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: base-type
+ (l.Lexer $.Type)
+ ($_ p.either
+ (p.after (l.this "boolean") (p@wrap _t.boolean))
+ (p.after (l.this "byte") (p@wrap _t.byte))
+ (p.after (l.this "short") (p@wrap _t.short))
+ (p.after (l.this "int") (p@wrap _t.int))
+ (p.after (l.this "long") (p@wrap _t.long))
+ (p.after (l.this "float") (p@wrap _t.float))
+ (p.after (l.this "double") (p@wrap _t.double))
+ (p.after (l.this "char") (p@wrap _t.char))
+ (p@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: (generate-type argD)
+ (-> Text (Operation $.Type))
+ (case (l.run argD java-type)
+ (#error.Failure error)
+ (phase.throw invalid-syntax-for-jvm-type argD)
+
+ (#error.Success type)
+ (phase@wrap type)))
+
+(def: (generate-arg generate argS)
+ (-> (-> Synthesis (Operation Inst)) Synthesis
+ (Operation [$.Type Inst]))
+ (case argS
+ (^ (synthesis.tuple (list (synthesis.text argD) argS)))
+ (do phase.monad
+ [argT (generate-type argD)
+ argI (generate argS)]
+ (wrap [argT argI]))
+
+ _
+ (phase.throw invalid-syntax-for-argument-generation "")))
+
+(def: (method-return-type description)
+ (-> Text (Operation (Maybe $.Type)))
+ (case description
+ "void"
+ (phase@wrap #.None)
+
+ _
+ (phase@map (|>> #.Some) (generate-type description))))
+
+(def: (invoke::static proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list& (synthesis.text class)
+ (synthesis.text method)
+ (synthesis.text unboxed)
+ argsS))
+ (do phase.monad
+ [argsTI (monad.map @ (generate-arg generate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> (_.fuse (list@map product.right argsTI))
+ (_.INVOKESTATIC class method
+ (_t.method (list@map product.left argsTI) returnT (list))
+ false))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(template [<name> <invoke> <interface?>]
+ [(def: (<name> proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list& (synthesis.text class)
+ (synthesis.text method)
+ (synthesis.text unboxed)
+ objectS
+ argsS))
+ (do phase.monad
+ [objectI (generate objectS)
+ argsTI (monad.map @ (generate-arg generate) argsS)
+ returnT (method-return-type unboxed)]
+ (wrap (|>> objectI
+ (_.CHECKCAST class)
+ (_.fuse (list@map product.right argsTI))
+ (<invoke> class method
+ (_t.method (list@map product.left argsTI) returnT (list))
+ <interface?>))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))]
+
+ [invoke::virtual _.INVOKEVIRTUAL false]
+ [invoke::special _.INVOKESPECIAL false]
+ [invoke::interface _.INVOKEINTERFACE true]
+ )
+
+(def: (invoke::constructor proc generate inputs)
+ Handler
+ (case inputs
+ (^ (list& (synthesis.text class) argsS))
+ (do phase.monad
+ [argsTI (monad.map @ (generate-arg generate) argsS)]
+ (wrap (|>> (_.NEW class)
+ _.DUP
+ (_.fuse (list@map product.right argsTI))
+ (_.INVOKESPECIAL class "<init>"
+ (_t.method (list@map product.left argsTI) #.None (list))
+ false))))
+
+ _
+ (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: member
+ Bundle
+ (<| (bundle.prefix "member")
+ (|> (: Bundle bundle.empty)
+ (dictionary.merge (<| (bundle.prefix "static")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "get" static::get)
+ (bundle.install "put" static::put))))
+ (dictionary.merge (<| (bundle.prefix "virtual")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "get" virtual::get)
+ (bundle.install "put" virtual::put))))
+ (dictionary.merge (<| (bundle.prefix "invoke")
+ (|> (: Bundle bundle.empty)
+ (bundle.install "static" invoke::static)
+ (bundle.install "virtual" invoke::virtual)
+ (bundle.install "special" invoke::special)
+ (bundle.install "interface" invoke::interface)
+ (bundle.install "constructor" invoke::constructor))))
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (bundle.prefix "jvm")
+ (|> ..conversion
+ (dictionary.merge ..int)
+ (dictionary.merge ..long)
+ (dictionary.merge ..float)
+ (dictionary.merge ..double)
+ (dictionary.merge ..char)
+ (dictionary.merge ..array)
+ (dictionary.merge ..object)
+ (dictionary.merge ..member)
+ )))