aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/lang/translation
diff options
context:
space:
mode:
Diffstat (limited to 'new-luxc/source/luxc/lang/translation')
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux174
1 files changed, 116 insertions, 58 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index 7d9cd9cc5..d3fea1152 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -296,7 +296,7 @@
"char" _t.char
_ (_t.class elem-class (list)))))
-(def: (array::length proc generate inputs)
+(def: (array::length extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.i64 nesting)
@@ -309,9 +309,22 @@
_.ARRAYLENGTH)))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
-
-(def: (array::new proc generate inputs)
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+
+(def: (new-primitive-array-handler jvm-primitive)
+ (-> Type Handler)
+ (function (_ extension-name generate inputs)
+ (case inputs
+ (^ (list lengthS))
+ (do phase.monad
+ [lengthI (generate lengthS)]
+ (wrap (|>> lengthI
+ (_.array (_t.array 1 jvm-primitive)))))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: (array::new::object extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.i64 nesting)
@@ -323,9 +336,25 @@
(_.array (array-java-type (.nat nesting) elem-class)))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
-
-(def: (array::read proc generate inputs)
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+
+(def: (read-primitive-array-handler jvm-primitive loadI)
+ (-> Type Inst Handler)
+ (function (_ extension-name generate inputs)
+ (case inputs
+ (^ (list idxS arrayS))
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (_t.descriptor (_t.array 1 jvm-primitive)))
+ idxI
+ loadI)))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
+
+(def: (array::read::object extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.i64 nesting)
@@ -334,26 +363,35 @@
arrayS))
(do phase.monad
[arrayI (generate arrayS)
- idxI (generate idxS)
- #let [loadI (case elem-class
- "boolean" _.BALOAD
- "byte" _.BALOAD
- "short" _.SALOAD
- "int" _.IALOAD
- "long" _.LALOAD
- "float" _.FALOAD
- "double" _.DALOAD
- "char" _.CALOAD
- _ _.AALOAD)]]
+ idxI (generate idxS)]
(wrap (|>> arrayI
(_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class)))
idxI
- loadI)))
+ _.AALOAD)))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+
+(def: (write-primitive-array-handler jvm-primitive storeI)
+ (-> Type Inst Handler)
+ (function (_ extension-name generate inputs)
+ (case inputs
+ (^ (list idxS valueS arrayS))
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)
+ valueI (generate valueS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (_t.descriptor (_t.array 1 jvm-primitive)))
+ _.DUP
+ idxI
+ valueI
+ storeI)))
+
+ _
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
-(def: (array::write proc generate inputs)
+(def: (array::write::object extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.i64 nesting)
@@ -364,35 +402,55 @@
(do phase.monad
[arrayI (generate arrayS)
idxI (generate idxS)
- valueI (generate valueS)
- #let [storeI (case elem-class
- "boolean" _.BASTORE
- "byte" _.BASTORE
- "short" _.SASTORE
- "int" _.IASTORE
- "long" _.LASTORE
- "float" _.FASTORE
- "double" _.DASTORE
- "char" _.CASTORE
- _ _.AASTORE)]]
+ valueI (generate valueS)]
(wrap (|>> arrayI
(_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class)))
_.DUP
idxI
valueI
- storeI)))
+ _.AASTORE)))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
(def: array
Bundle
(<| (bundle.prefix "array")
- (|> (: Bundle bundle.empty)
+ (|> bundle.empty
(bundle.install "length" array::length)
- (bundle.install "new" array::new)
- (bundle.install "read" array::read)
- (bundle.install "write" array::write)
+ (dictionary.merge (<| (bundle.prefix "new")
+ (|> bundle.empty
+ (bundle.install "boolean" (new-primitive-array-handler _t.boolean))
+ (bundle.install "byte" (new-primitive-array-handler _t.byte))
+ (bundle.install "short" (new-primitive-array-handler _t.short))
+ (bundle.install "int" (new-primitive-array-handler _t.int))
+ (bundle.install "long" (new-primitive-array-handler _t.long))
+ (bundle.install "float" (new-primitive-array-handler _t.float))
+ (bundle.install "double" (new-primitive-array-handler _t.double))
+ (bundle.install "char" (new-primitive-array-handler _t.char))
+ (bundle.install "object" array::new::object))))
+ (dictionary.merge (<| (bundle.prefix "read")
+ (|> bundle.empty
+ (bundle.install "boolean" (read-primitive-array-handler _t.boolean _.BALOAD))
+ (bundle.install "byte" (read-primitive-array-handler _t.byte _.BALOAD))
+ (bundle.install "short" (read-primitive-array-handler _t.short _.SALOAD))
+ (bundle.install "int" (read-primitive-array-handler _t.int _.IALOAD))
+ (bundle.install "long" (read-primitive-array-handler _t.long _.LALOAD))
+ (bundle.install "float" (read-primitive-array-handler _t.float _.FALOAD))
+ (bundle.install "double" (read-primitive-array-handler _t.double _.DALOAD))
+ (bundle.install "char" (read-primitive-array-handler _t.char _.CALOAD))
+ (bundle.install "object" array::read::object))))
+ (dictionary.merge (<| (bundle.prefix "write")
+ (|> bundle.empty
+ (bundle.install "boolean" (write-primitive-array-handler _t.boolean _.BASTORE))
+ (bundle.install "byte" (write-primitive-array-handler _t.byte _.BASTORE))
+ (bundle.install "short" (write-primitive-array-handler _t.short _.SASTORE))
+ (bundle.install "int" (write-primitive-array-handler _t.int _.IASTORE))
+ (bundle.install "long" (write-primitive-array-handler _t.long _.LASTORE))
+ (bundle.install "float" (write-primitive-array-handler _t.float _.FASTORE))
+ (bundle.install "double" (write-primitive-array-handler _t.double _.DASTORE))
+ (bundle.install "char" (write-primitive-array-handler _t.char _.CASTORE))
+ (bundle.install "object" array::write::object))))
)))
(def: (object::null _)
@@ -425,7 +483,7 @@
(|>> exceptionI
_.ATHROW))
-(def: (object::class proc generate inputs)
+(def: (object::class extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.text class)))
@@ -439,9 +497,9 @@
false))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: (object::instance? proc generate inputs)
+(def: (object::instance? extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.text class) objectS))
@@ -452,9 +510,9 @@
(_.wrap #_t.Boolean))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: (object::cast proc generate inputs)
+(def: (object::cast extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.text from) (synthesis.text to) valueS))
@@ -481,7 +539,7 @@
(wrap valueI)))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
(def: object
Bundle
@@ -508,7 +566,7 @@
["char" #_t.Char])
(dictionary.from-list text.hash)))
-(def: (static::get proc generate inputs)
+(def: (static::get extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.text class)
@@ -524,9 +582,9 @@
(wrap (_.GETSTATIC class field (_t.class unboxed (list))))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: (static::put proc generate inputs)
+(def: (static::put extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.text class)
@@ -548,9 +606,9 @@
(_.string synthesis.unit)))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: (virtual::get proc generate inputs)
+(def: (virtual::get extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.text class)
@@ -571,9 +629,9 @@
(_.GETFIELD class field (_t.class unboxed (list)))))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: (virtual::put proc generate inputs)
+(def: (virtual::put extension-name generate inputs)
Handler
(case inputs
(^ (list (synthesis.text class)
@@ -601,7 +659,7 @@
(_.PUTFIELD class field (_t.class unboxed (list)))))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
(def: base-type
(l.Parser Type)
@@ -667,7 +725,7 @@
#.None
argI))
-(def: (invoke::static proc generate inputs)
+(def: (invoke::static extension-name generate inputs)
Handler
(case inputs
(^ (list& (synthesis.text class)
@@ -683,10 +741,10 @@
false))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
(template [<name> <invoke> <interface?>]
- [(def: (<name> proc generate inputs)
+ [(def: (<name> extension-name generate inputs)
Handler
(case inputs
(^ (list& (synthesis.text class)
@@ -706,14 +764,14 @@
<interface?>))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))]
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))]
[invoke::virtual _.INVOKEVIRTUAL false]
[invoke::special _.INVOKESPECIAL false]
[invoke::interface _.INVOKEINTERFACE true]
)
-(def: (invoke::constructor proc generate inputs)
+(def: (invoke::constructor extension-name generate inputs)
Handler
(case inputs
(^ (list& (synthesis.text class) argsS))
@@ -727,7 +785,7 @@
false))))
_
- (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
(def: member
Bundle