diff options
Diffstat (limited to '')
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]] |