aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux174
-rw-r--r--stdlib/source/lux/data/collection/array.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux127
3 files changed, 226 insertions, 81 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
diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux
index aeb0cc55f..b6f877d73 100644
--- a/stdlib/source/lux/data/collection/array.lux
+++ b/stdlib/source/lux/data/collection/array.lux
@@ -38,7 +38,7 @@
(~~ (static @.jvm))
(|> size
!int
- "jvm array new"
+ "jvm array new object"
(: <array-type>)
:assume)})))
@@ -69,7 +69,7 @@
(~~ (static @.jvm))
(let [value (|> array
(:coerce <array-type>)
- ("jvm array read" (!int index)))]
+ ("jvm array read object" (!int index)))]
(if ("jvm object null?" value)
#.None
(#.Some (:assume value))))}))
@@ -84,7 +84,7 @@
(~~ (static @.jvm))
(|> array
(:coerce <array-type>)
- ("jvm array write" (!int index) (:coerce <elem-type> value))
+ ("jvm array write object" (!int index) (:coerce <elem-type> value))
:assume)})))
(def: #export (delete index array)
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
index 14a77c65c..5040438b5 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -1,5 +1,7 @@
(.module:
[lux (#- char int)
+ ["." host (#+ import:)]
+ ["." macro]
[abstract
["." monad (#+ do)]]
[control
@@ -19,8 +21,9 @@
["." dictionary (#+ Dictionary)]]]
["." type
["." check]]
- ["." macro]
- ["." host (#+ import:)]]
+ [target
+ [jvm
+ ["_." type]]]]
["." // #_
["#." common]
["#/" //
@@ -85,11 +88,12 @@
(template [<name>]
[(exception: #export (<name> {class Text})
(exception.report
- ["Class" (%t class)]))]
+ ["Class/type" (%t class)]))]
[unknown-class]
[non-interface]
[non-throwable]
+ [primitives-are-not-objects]
)
(template [<name>]
@@ -124,7 +128,6 @@
message)]
[primitives-cannot-have-type-parameters]
- [primitives-are-not-objects]
[mistaken-field-owner]
@@ -255,8 +258,8 @@
["char" "java.lang.Character"])
(dictionary.from-list text.hash)))
-(def: (array-type-info arrayT)
- (-> Type (Operation [Nat Text]))
+(def: (array-type-info allow-primitives? arrayT)
+ (-> Bit Type (Operation [Nat Text]))
(loop [level 0
currentT arrayT]
(case currentT
@@ -272,7 +275,10 @@
(recur (inc level) elemT)
(#.Primitive class #.Nil)
- (////@wrap [level class])
+ (if (and (dictionary.contains? class boxes)
+ (not allow-primitives?))
+ (/////analysis.throw ..primitives-are-not-objects [class])
+ (////@wrap [level class]))
(#.Primitive class _)
(if (dictionary.contains? class boxes)
@@ -293,7 +299,7 @@
arrayA (typeA.with-type (type (Array varT))
(analyse arrayC))
varT (typeA.with-env (check.clean varT))
- [array-nesting elem-class] (array-type-info (type (Array varT)))]
+ [array-nesting elem-class] (array-type-info true (type (Array varT)))]
(wrap (#/////analysis.Extension extension-name (list (/////analysis.nat array-nesting)
(/////analysis.text elem-class)
arrayA))))
@@ -301,7 +307,21 @@
_
(/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
-(def: array::new
+(def: (new-primitive-array-handler primitive-type)
+ (-> _type.Type Handler)
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list lengthC))
+ (do ////.monad
+ [lengthA (typeA.with-type ..int
+ (analyse lengthC))
+ _ (typeA.infer (#.Primitive (_type.descriptor (_type.array 1 primitive-type)) (list)))]
+ (wrap (#/////analysis.Extension extension-name (list lengthA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
+
+(def: array::new::object
Handler
(function (_ extension-name analyse args)
(case args
@@ -310,7 +330,7 @@
[lengthA (typeA.with-type ..int
(analyse lengthC))
expectedT (///.lift macro.expected-type)
- [level elem-class] (array-type-info expectedT)
+ [level elem-class] (array-type-info false expectedT)
_ (if (n/> 0 level)
(wrap [])
(/////analysis.throw non-array expectedT))]
@@ -355,10 +375,26 @@
(do ////.monad
[name (check-jvm objectT)]
(if (dictionary.contains? name boxes)
- (/////analysis.throw primitives-are-not-objects name)
+ (/////analysis.throw ..primitives-are-not-objects [name])
(////@wrap name))))
-(def: array::read
+(def: (read-primitive-array-handler lux-type jvm-type)
+ (-> Type _type.Type Handler)
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list idxC arrayC))
+ (do ////.monad
+ [_ (typeA.infer lux-type)
+ idxA (typeA.with-type ..int
+ (analyse idxC))
+ arrayA (typeA.with-type (#.Primitive (_type.descriptor (_type.array 1 jvm-type)) (list))
+ (analyse arrayC))]
+ (wrap (#/////analysis.Extension extension-name (list idxA arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
+
+(def: array::read::object
Handler
(function (_ extension-name analyse args)
(case args
@@ -370,7 +406,7 @@
(analyse arrayC))
varT (typeA.with-env
(check.clean varT))
- [nesting elem-class] (array-type-info varT)
+ [nesting elem-class] (array-type-info false varT)
idxA (typeA.with-type ..int
(analyse idxC))]
(wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting))
@@ -381,7 +417,28 @@
_
(/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
-(def: array::write
+(def: (write-primitive-array-handler lux-type jvm-type)
+ (-> Type _type.Type Handler)
+ (let [array-type (#.Primitive (_type.descriptor (_type.array 1 jvm-type)) (list))]
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list idxC valueC arrayC))
+ (do ////.monad
+ [_ (typeA.infer array-type)
+ idxA (typeA.with-type ..int
+ (analyse idxC))
+ valueA (typeA.with-type lux-type
+ (analyse valueC))
+ arrayA (typeA.with-type array-type
+ (analyse arrayC))]
+ (wrap (#/////analysis.Extension extension-name (list idxA
+ valueA
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))))
+
+(def: array::write::object
Handler
(function (_ extension-name analyse args)
(case args
@@ -393,7 +450,7 @@
(analyse arrayC))
varT (typeA.with-env
(check.clean varT))
- [nesting elem-class] (array-type-info varT)
+ [nesting elem-class] (array-type-info false varT)
idxA (typeA.with-type ..int
(analyse idxC))
valueA (typeA.with-type varT
@@ -412,9 +469,39 @@
(<| (///bundle.prefix "array")
(|> ///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 _type.boolean))
+ (///bundle.install "byte" (new-primitive-array-handler _type.byte))
+ (///bundle.install "short" (new-primitive-array-handler _type.short))
+ (///bundle.install "int" (new-primitive-array-handler _type.int))
+ (///bundle.install "long" (new-primitive-array-handler _type.long))
+ (///bundle.install "float" (new-primitive-array-handler _type.float))
+ (///bundle.install "double" (new-primitive-array-handler _type.double))
+ (///bundle.install "char" (new-primitive-array-handler _type.char))
+ (///bundle.install "object" array::new::object))))
+ (dictionary.merge (<| (///bundle.prefix "read")
+ (|> ///bundle.empty
+ (///bundle.install "boolean" (read-primitive-array-handler ..boolean _type.boolean))
+ (///bundle.install "byte" (read-primitive-array-handler ..byte _type.byte))
+ (///bundle.install "short" (read-primitive-array-handler ..short _type.short))
+ (///bundle.install "int" (read-primitive-array-handler ..int _type.int))
+ (///bundle.install "long" (read-primitive-array-handler ..long _type.long))
+ (///bundle.install "float" (read-primitive-array-handler ..float _type.float))
+ (///bundle.install "double" (read-primitive-array-handler ..double _type.double))
+ (///bundle.install "char" (read-primitive-array-handler ..char _type.char))
+ (///bundle.install "object" array::read::object))))
+ (dictionary.merge (<| (///bundle.prefix "write")
+ (|> ///bundle.empty
+ (///bundle.install "boolean" (write-primitive-array-handler ..boolean _type.boolean))
+ (///bundle.install "byte" (write-primitive-array-handler ..byte _type.byte))
+ (///bundle.install "short" (write-primitive-array-handler ..short _type.short))
+ (///bundle.install "int" (write-primitive-array-handler ..int _type.int))
+ (///bundle.install "long" (write-primitive-array-handler ..long _type.long))
+ (///bundle.install "float" (write-primitive-array-handler ..float _type.float))
+ (///bundle.install "double" (write-primitive-array-handler ..double _type.double))
+ (///bundle.install "char" (write-primitive-array-handler ..char _type.char))
+ (///bundle.install "object" array::write::object))))
)))
(def: object::null
@@ -746,9 +833,9 @@
_
(do @
- [_ (////.assert primitives-are-not-objects from-name
+ [_ (////.assert ..primitives-are-not-objects [from-name]
(not (dictionary.contains? from-name boxes)))
- _ (////.assert primitives-are-not-objects to-name
+ _ (////.assert ..primitives-are-not-objects [to-name]
(not (dictionary.contains? to-name boxes)))
to-class (load-class to-name)]
(loop [[current-name currentT] [from-name valueT]]