diff options
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux | 166 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/array.lux | 38 | ||||
| -rw-r--r-- | stdlib/source/lux/data/text.lux | 3 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension.lux | 7 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux | 490 |
5 files changed, 347 insertions, 357 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 a9df2710c..d5a7bd3f5 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -53,13 +53,9 @@ [(def: (<name> inputI) (Unary Inst) (if (is? _.NOP <conversion>) + inputI (|>> inputI - (_.unwrap <unwrap>) - (_.wrap <wrap>)) - (|>> inputI - (_.unwrap <unwrap>) - <conversion> - (_.wrap <wrap>))))] + <conversion>)))] [conversion::double-to-float #$.Double _.D2F #$.Float] [conversion::double-to-int #$.Double _.D2I #$.Int] @@ -117,61 +113,61 @@ (bundle.install "short-to-long" (unary conversion::short-to-long)) ))) -(template [<name> <op> <unwrapX> <unwrapY> <wrap>] +(template [<name> <op>] [(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] + (|>> xI + yI + <op>))] + + [int::+ _.IADD] + [int::- _.ISUB] + [int::* _.IMUL] + [int::/ _.IDIV] + [int::% _.IREM] + [int::and _.IAND] + [int::or _.IOR] + [int::xor _.IXOR] + [int::shl _.ISHL] + [int::shr _.ISHR] + [int::ushr _.IUSHR] - [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] + [long::+ _.LADD] + [long::- _.LSUB] + [long::* _.LMUL] + [long::/ _.LDIV] + [long::% _.LREM] + [long::and _.LAND] + [long::or _.LOR] + [long::xor _.LXOR] + [long::shl _.LSHL] + [long::shr _.LSHR] + [long::ushr _.LUSHR] + + [float::+ _.FADD] + [float::- _.FSUB] + [float::* _.FMUL] + [float::/ _.FDIV] + [float::% _.FREM] - [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] + [double::+ _.DADD] + [double::- _.DSUB] + [double::* _.DMUL] + [double::/ _.DDIV] + [double::% _.DREM] ) (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>] +(template [<name> <op>] [(def: (<name> [xI yI]) (Binary Inst) (<| _.with-label (function (_ @then)) _.with-label (function (_ @end)) - (|>> xI (_.unwrap <unwrap>) - yI (_.unwrap <unwrap>) + (|>> xI + yI (<op> @then) falseI (_.GOTO @end) @@ -179,20 +175,20 @@ trueI (_.label @end))))] - [int::= _.IF_ICMPEQ #$.Int] - [int::< _.IF_ICMPLT #$.Int] + [int::= _.IF_ICMPEQ] + [int::< _.IF_ICMPLT] - [char::= _.IF_ICMPEQ #$.Char] - [char::< _.IF_ICMPLT #$.Char] + [char::= _.IF_ICMPEQ] + [char::< _.IF_ICMPLT] ) -(template [<name> <op> <reference> <unwrap>] +(template [<name> <op> <reference>] [(def: (<name> [xI yI]) (Binary Inst) (<| _.with-label (function (_ @then)) _.with-label (function (_ @end)) - (|>> xI (_.unwrap <unwrap>) - yI (_.unwrap <unwrap>) + (|>> xI + yI <op> (_.int <reference>) (_.IF_ICMPEQ @then) @@ -202,14 +198,14 @@ trueI (_.label @end))))] - [long::= _.LCMP +0 #$.Long] - [long::< _.LCMP -1 #$.Long] + [long::= _.LCMP +0] + [long::< _.LCMP -1] - [float::= _.FCMPG +0 #$.Float] - [float::< _.FCMPG -1 #$.Float] + [float::= _.FCMPG +0] + [float::< _.FCMPG -1] - [double::= _.DCMPG +0 #$.Double] - [double::< _.DCMPG -1 #$.Double] + [double::= _.DCMPG +0] + [double::< _.DCMPG -1] ) (def: int @@ -308,9 +304,7 @@ [arrayI (generate arrayS)] (wrap (|>> arrayI (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) - _.ARRAYLENGTH - _.I2L - (_.wrap #$.Long)))) + _.ARRAYLENGTH))) _ (phase.throw extension.invalid-syntax [proc %synthesis inputs]))) @@ -324,8 +318,6 @@ (do phase.monad [lengthI (generate lengthS)] (wrap (|>> lengthI - (_.unwrap #$.Long) - _.L2I (_.array (array-java-type (.nat nesting) elem-class))))) _ @@ -342,20 +334,18 @@ [arrayI (generate arrayS) idxI (generate idxS) #let [loadI (case elem-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)) + "boolean" _.BALOAD + "byte" _.BALOAD + "short" _.SALOAD + "int" _.IALOAD + "long" _.LALOAD + "float" _.FALOAD + "double" _.DALOAD + "char" _.CALOAD _ _.AALOAD)]] (wrap (|>> arrayI (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) idxI - (_.unwrap #$.Long) - _.L2I loadI))) _ @@ -374,21 +364,19 @@ idxI (generate idxS) valueI (generate valueS) #let [storeI (case elem-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) + "boolean" _.BASTORE + "byte" _.BASTORE + "short" _.SASTORE + "int" _.IASTORE + "long" _.LASTORE + "float" _.FASTORE + "double" _.DASTORE + "char" _.CASTORE _ _.AASTORE)]] (wrap (|>> arrayI (_.CHECKCAST (_t.descriptor (array-java-type (.nat nesting) elem-class))) _.DUP idxI - (_.unwrap #$.Long) - _.L2I valueI storeI))) @@ -528,8 +516,7 @@ [] (case (dictionary.get unboxed primitives) (#.Some primitive) - (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive)) - (_.wrap primitive))) + (wrap (_.GETSTATIC class field (#$.Primitive primitive))) #.None (wrap (_.GETSTATIC class field (_t.class unboxed (list)))))) @@ -549,7 +536,6 @@ (case (dictionary.get unboxed primitives) (#.Some primitive) (wrap (|>> valueI - (_.unwrap primitive) (_.PUTSTATIC class field (#$.Primitive primitive)) (_.string synthesis.unit))) @@ -575,8 +561,7 @@ (#.Some primitive) (wrap (|>> objectI (_.CHECKCAST class) - (_.GETFIELD class field (#$.Primitive primitive)) - (_.wrap primitive))) + (_.GETFIELD class field (#$.Primitive primitive)))) #.None (wrap (|>> objectI @@ -603,7 +588,6 @@ (_.CHECKCAST class) _.DUP valueI - (_.unwrap primitive) (_.PUTFIELD class field (#$.Primitive primitive)))) #.None diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index 4cb89c71b..d73ca2e7f 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -21,17 +21,28 @@ {#.doc "Mutable arrays."} (#.Primitive ..type-name (#.Cons a #.Nil))) -(with-expansions [<elem-type> (primitive "java.lang.Object") +(with-expansions [<index-type> (primitive "java.lang.Long") + <elem-type> (primitive "java.lang.Object") <array-type> (type (Array <elem-type>))] + (`` (for {(~~ (static host.jvm)) + (template: (!int value) + (|> value + (:coerce <index-type>) + "jvm object cast" + "jvm conversion long-to-int"))} + (as-is))) + (def: #export (new size) (All [a] (-> Nat (Array a))) (`` (for {(~~ (static host.old)) (:assume ("jvm anewarray" "(java.lang.Object )" size)) (~~ (static host.jvm)) - (:assume - (: (Array (primitive "java.lang.Object")) - ("jvm array new" size)))}))) + (|> size + !int + "jvm array new" + (: <array-type>) + :assume)}))) (def: #export (size array) (All [a] (-> (Array a) Nat)) @@ -39,7 +50,13 @@ ("jvm arraylength" array) (~~ (static host.jvm)) - ("jvm array length" (:coerce <array-type> array))}))) + (|> array + (:coerce <array-type>) + "jvm array length" + "jvm conversion int-to-long" + "jvm object cast" + (: <index-type>) + (:coerce Nat))}))) (def: #export (read index array) (All [a] @@ -52,7 +69,9 @@ (#.Some value))) (~~ (static host.jvm)) - (let [value ("jvm array read" index (:coerce <array-type> array))] + (let [value (|> array + (:coerce <array-type>) + ("jvm array read" (!int index)))] (if ("jvm object null?" value) #.None (#.Some (:assume value))))})) @@ -65,9 +84,10 @@ ("jvm aastore" array index value) (~~ (static host.jvm)) - (:assume - ("jvm array write" index (:coerce <elem-type> value) - (:coerce <array-type> array)))}))) + (|> array + (:coerce <array-type>) + ("jvm array write" (!int index) (:coerce <elem-type> value)) + :assume)}))) (def: #export (delete index array) (All [a] diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index a91beccef..42b8170b9 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -199,8 +199,9 @@ (|> input (:coerce (primitive "java.lang.String")) ("jvm member invoke virtual" "java.lang.String" "hashCode") - "jvm object cast" "jvm conversion int-to-long" + "jvm object cast" + (: (primitive "java.lang.Long")) (:coerce Nat))} ## Platform-independent default. (let [length ("lux text size" input)] diff --git a/stdlib/source/lux/tool/compiler/phase/extension.lux b/stdlib/source/lux/tool/compiler/phase/extension.lux index d9cf0d701..9d9563eba 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension.lux @@ -51,9 +51,7 @@ (exception: #export [a] (invalid-syntax {name Name} {%format (Format a)} {inputs (List a)}) (exception.report ["Extension" (%t name)] - ["Inputs" (|> inputs - (list@map %format) - (text.join-with text.new-line))])) + ["Inputs" (exception.enumerate %format inputs)])) (exception: #export [s i o] (unknown {name Name} {bundle (Bundle s i o)}) (exception.report @@ -61,8 +59,7 @@ ["Available" (|> bundle dictionary.keys (list.sort text@<) - (list@map %t) - (text.join-with text.new-line))])) + (exception.enumerate %t))])) (def: #export (install name handler) (All [s i o] diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux index fe9a63f09..998590d1c 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux @@ -4,7 +4,7 @@ ["." monad (#+ do)]] [control ["p" parser] - ["ex" exception (#+ exception:)] + ["." exception (#+ exception:)] pipe] [data ["." error (#+ Error)] @@ -30,9 +30,30 @@ [".A" type] [".A" inference]] ["#/" // #_ - ["#." analysis (#+ Analysis Operation Handler Bundle)] + ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] ["#." synthesis]]]]]) +(def: (custom [syntax handler]) + (All [s] + (-> [(Syntax s) + (-> Text Phase s (Operation Analysis))] + Handler)) + (function (_ extension-name analyse args) + (case (s.run args syntax) + (#error.Success inputs) + (handler extension-name analyse inputs) + + (#error.Failure error) + (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) + +(type: Member + {#class Text + #member Text}) + +(def: member + (Syntax Member) + ($_ p.and s.text s.text)) + (type: Method-Signature {#method Type #exceptions (List Type)}) @@ -42,7 +63,8 @@ (template [<name>] [(exception: #export (<name> {jvm-type java/lang/reflect/Type}) - (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))] + (exception.report + ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))] [jvm-type-is-not-a-class] [cannot-convert-to-a-class] @@ -52,7 +74,8 @@ (template [<name>] [(exception: #export (<name> {type Type}) - (%type type))] + (exception.report + ["Type" (%type type)]))] [non-object] [non-array] @@ -60,26 +83,50 @@ ) (template [<name>] - [(exception: #export (<name> {name Text}) - name)] + [(exception: #export (<name> {class Text}) + (exception.report + ["Class" (%t class)]))] + [unknown-class] [non-interface] [non-throwable] ) (template [<name>] + [(exception: #export (<name> {class Text} {field Text}) + (exception.report + ["Class" (%t class)] + ["Field" (%t field)]))] + + [unknown-field] + [not-a-static-field] + [not-a-virtual-field] + [cannot-set-a-final-field] + ) + +(template [<name>] + [(exception: #export (<name> {class Text} + {method Text} + {hints (List Method-Signature)}) + (exception.report + ["Class" class] + ["Method" method] + ["Hints" (|> hints + (list@map (|>> product.left %type (format text.new-line text.tab))) + (text.join-with ""))]))] + + [no-candidates] + [too-many-candidates] + ) + +(template [<name>] [(exception: #export (<name> {message Text}) message)] - [unknown-class] [primitives-cannot-have-type-parameters] [primitives-are-not-objects] - [unknown-field] [mistaken-field-owner] - [not-a-virtual-field] - [not-a-static-field] - [cannot-set-a-final-field] [cannot-cast] @@ -90,22 +137,10 @@ [cannot-correspond-type-with-a-class] ) -(template [<name>] - [(exception: #export (<name> {class Text} - {method Text} - {hints (List Method-Signature)}) - (ex.report ["Class" class] - ["Method" method] - ["Hints" (|> hints - (list@map (|>> product.left %type (format text.new-line text.tab))) - (text.join-with ""))]))] - - [no-candidates] - [too-many-candidates] - ) - +## TODO: Get rid of this template block and use the definition in +## lux/host.jvm.lux ASAP (template [<name> <class>] - [(def: #export <name> Type (#.Primitive <class> (list)))] + [(type: #export <name> (primitive <class>))] ## Boxes [Boolean "java.lang.Boolean"] @@ -133,29 +168,29 @@ Bundle (<| (///bundle.prefix "conversion") (|> ///bundle.empty - (///bundle.install "double-to-float" (//common.unary Double Float)) - (///bundle.install "double-to-int" (//common.unary Double Integer)) - (///bundle.install "double-to-long" (//common.unary Double Long)) - (///bundle.install "float-to-double" (//common.unary Float Double)) - (///bundle.install "float-to-int" (//common.unary Float Integer)) - (///bundle.install "float-to-long" (//common.unary Float Long)) - (///bundle.install "int-to-byte" (//common.unary Integer Byte)) - (///bundle.install "int-to-char" (//common.unary Integer Character)) - (///bundle.install "int-to-double" (//common.unary Integer Double)) - (///bundle.install "int-to-float" (//common.unary Integer Float)) - (///bundle.install "int-to-long" (//common.unary Integer Long)) - (///bundle.install "int-to-short" (//common.unary Integer Short)) - (///bundle.install "long-to-double" (//common.unary Long Double)) - (///bundle.install "long-to-float" (//common.unary Long Float)) - (///bundle.install "long-to-int" (//common.unary Long Integer)) - (///bundle.install "long-to-short" (//common.unary Long Short)) - (///bundle.install "long-to-byte" (//common.unary Long Byte)) - (///bundle.install "char-to-byte" (//common.unary Character Byte)) - (///bundle.install "char-to-short" (//common.unary Character Short)) - (///bundle.install "char-to-int" (//common.unary Character Integer)) - (///bundle.install "char-to-long" (//common.unary Character Long)) - (///bundle.install "byte-to-long" (//common.unary Byte Long)) - (///bundle.install "short-to-long" (//common.unary Short Long)) + (///bundle.install "double-to-float" (//common.unary ..double ..float)) + (///bundle.install "double-to-int" (//common.unary ..double ..int)) + (///bundle.install "double-to-long" (//common.unary ..double ..long)) + (///bundle.install "float-to-double" (//common.unary ..float ..double)) + (///bundle.install "float-to-int" (//common.unary ..float ..int)) + (///bundle.install "float-to-long" (//common.unary ..float ..long)) + (///bundle.install "int-to-byte" (//common.unary ..int ..byte)) + (///bundle.install "int-to-char" (//common.unary ..int ..char)) + (///bundle.install "int-to-double" (//common.unary ..int ..double)) + (///bundle.install "int-to-float" (//common.unary ..int ..float)) + (///bundle.install "int-to-long" (//common.unary ..int ..long)) + (///bundle.install "int-to-short" (//common.unary ..int ..short)) + (///bundle.install "long-to-double" (//common.unary ..long ..double)) + (///bundle.install "long-to-float" (//common.unary ..long ..float)) + (///bundle.install "long-to-int" (//common.unary ..long ..int)) + (///bundle.install "long-to-short" (//common.unary ..long ..short)) + (///bundle.install "long-to-byte" (//common.unary ..long ..byte)) + (///bundle.install "char-to-byte" (//common.unary ..char ..byte)) + (///bundle.install "char-to-short" (//common.unary ..char ..short)) + (///bundle.install "char-to-int" (//common.unary ..char ..int)) + (///bundle.install "char-to-long" (//common.unary ..char ..long)) + (///bundle.install "byte-to-long" (//common.unary ..byte ..long)) + (///bundle.install "short-to-long" (//common.unary ..short ..long)) ))) (template [<name> <prefix> <type>] @@ -178,8 +213,8 @@ (///bundle.install "ushr" (//common.binary <type> Integer <type>)) )))] - [bundle::int "int" Integer] - [bundle::long "long" Long] + [bundle::int "int" ..long] + [bundle::long "long" ..long] ) (template [<name> <prefix> <type>] @@ -196,16 +231,16 @@ (///bundle.install "<" (//common.binary <type> <type> Bit)) )))] - [bundle::float "float" Float] - [bundle::double "double" Double] + [bundle::float "float" ..float] + [bundle::double "double" ..double] ) (def: bundle::char Bundle (<| (///bundle.prefix "char") (|> ///bundle.empty - (///bundle.install "=" (//common.binary Character Character Bit)) - (///bundle.install "<" (//common.binary Character Character Bit)) + (///bundle.install "=" (//common.binary ..char ..char Bit)) + (///bundle.install "<" (//common.binary ..char ..char Bit)) ))) (def: #export boxes @@ -253,7 +288,7 @@ (case args (^ (list arrayC)) (do ////.monad - [_ (typeA.infer Nat) + [_ (typeA.infer ..int) [var-id varT] (typeA.with-env check.var) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) @@ -272,7 +307,7 @@ (case args (^ (list lengthC)) (do ////.monad - [lengthA (typeA.with-type Nat + [lengthA (typeA.with-type ..int (analyse lengthC)) expectedT (///.lift macro.expected-type) [level elem-class] (array-type-info expectedT) @@ -336,7 +371,7 @@ varT (typeA.with-env (check.clean varT)) [nesting elem-class] (array-type-info varT) - idxA (typeA.with-type Nat + idxA (typeA.with-type ..int (analyse idxC))] (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting)) (/////analysis.text elem-class) @@ -359,7 +394,7 @@ varT (typeA.with-env (check.clean varT)) [nesting elem-class] (array-type-info varT) - idxA (typeA.with-type Nat + idxA (typeA.with-type ..int (analyse idxC)) valueA (typeA.with-type varT (analyse valueC))] @@ -788,19 +823,54 @@ "Target Class: " class-name text.new-line)))) (#error.Failure _) - (/////analysis.throw unknown-field (format class-name "#" field-name))))) + (/////analysis.throw unknown-field [class-name field-name])))) (def: (static-field class-name field-name) - (-> Text Text (Operation [Type Bit])) + (-> Text Text (Operation [Type Text Bit])) (do ////.monad [[class fieldJ] (find-field class-name field-name) #let [modifiers (Field::getModifiers fieldJ)]] (if (Modifier::isStatic modifiers) (let [fieldJT (Field::getGenericType fieldJ)] (do @ - [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal modifiers)]))) - (/////analysis.throw not-a-static-field (format class-name "#" field-name))))) + [fieldT (java-type-to-lux-type fresh-mappings fieldJT) + unboxed (java-type-to-class fieldJT)] + (wrap [fieldT unboxed (Modifier::isFinal modifiers)]))) + (/////analysis.throw ..not-a-static-field [class-name field-name])))) + +(def: static::get + Handler + (..custom [..member + (function (_ extension-name analyse [class field]) + (do ////.monad + [[fieldT unboxed final?] (static-field class field) + _ (typeA.infer fieldT)] + (wrap (<| (#/////analysis.Extension extension-name) + (list (/////analysis.text class) + (/////analysis.text field) + (/////analysis.text unboxed))))))])) + +(def: static::put + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [_ (typeA.infer Any) + [fieldT unboxed final?] (static-field class field) + _ (////.assert cannot-set-a-final-field [class field] + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA)))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name %code args])) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Operation [Type Bit])) @@ -833,46 +903,7 @@ (/////analysis.throw non-object objectT))) fieldT (java-type-to-lux-type mappings fieldJT)] (wrap [fieldT (Modifier::isFinal modifiers)])) - (/////analysis.throw not-a-virtual-field (format class-name "#" field-name))))) - -(def: static::get - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [[fieldT final?] (static-field class field)] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: static::put - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC valueC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [_ (typeA.infer Any) - [fieldT final?] (static-field class field) - _ (////.assert cannot-set-a-final-field (format class "#" field) - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA)))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + (/////analysis.throw not-a-virtual-field [class-name field-name])))) (def: virtual::get Handler @@ -884,7 +915,8 @@ (do ////.monad [[objectT objectA] (typeA.with-inference (analyse objectC)) - [fieldT final?] (virtual-field class field objectT)] + [fieldT final?] (virtual-field class field objectT) + _ (typeA.infer fieldT)] (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA)))) _ @@ -905,7 +937,7 @@ (analyse objectC)) _ (typeA.infer objectT) [fieldT final?] (virtual-field class field objectT) - _ (////.assert cannot-set-a-final-field (format class "#" field) + _ (////.assert cannot-set-a-final-field [class field] (not final?)) valueA (typeA.with-type fieldT (analyse valueC))] @@ -1004,17 +1036,23 @@ (-> Nat Type) (|>> (n/* 2) inc #.Parameter)) -(def: (type-vars amount offset) - (-> Nat Nat (List Type)) - (if (n/= 0 amount) - (list) - (|> (list.indices amount) - (list@map (|>> (n/+ offset) idx-to-parameter))))) +(def: (jvm-type-var-mappings owner-tvars method-tvars) + (-> (List Text) (List Text) [(List Type) Mappings]) + (let [jvm-tvars (list@compose owner-tvars method-tvars) + lux-tvars (|> jvm-tvars + list.reverse + list.enumerate + (list@map (function (_ [idx name]) + [name (idx-to-parameter idx)])) + list.reverse) + num-owner-tvars (list.size owner-tvars) + owner-tvarsT (|> lux-tvars (list.take num-owner-tvars) (list@map product.right)) + mappings (dictionary.from-list text.hash lux-tvars)] + [owner-tvarsT mappings])) (def: (method-signature method-style method) (-> Method-Style Method (Operation Method-Signature)) (let [owner (Method::getDeclaringClass method) - owner-name (Class::getName owner) owner-tvars (case method-style #Static (list) @@ -1026,19 +1064,7 @@ method-tvars (|> (Method::getTypeParameters method) array.to-list (list@map (|>> TypeVariable::getName))) - num-owner-tvars (list.size owner-tvars) - num-method-tvars (list.size method-tvars) - all-tvars (list@compose owner-tvars method-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars 0) - method-tvarsT (type-vars num-method-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list@compose owner-tvarsT method-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dictionary.from-list text.hash))))] + [owner-tvarsT mappings] (jvm-type-var-mappings owner-tvars method-tvars)] (do ////.monad [inputsT (|> (Method::getGenericParameterTypes method) array.to-list @@ -1047,17 +1073,40 @@ exceptionsT (|> (Method::getGenericExceptionTypes method) array.to-list (monad.map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type.univ-q num-all-tvars) + #let [methodT (<| (type.univ-q (dictionary.size mappings)) (type.function (case method-style #Static inputsT _ - (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) + (list& (#.Primitive (Class::getName owner) owner-tvarsT) inputsT))) outputT)]] (wrap [methodT exceptionsT])))) +(def: (constructor-signature constructor) + (-> (Constructor Object) (Operation Method-Signature)) + (let [owner (Constructor::getDeclaringClass constructor) + owner-tvars (|> (Class::getTypeParameters owner) + array.to-list + (list@map (|>> TypeVariable::getName))) + method-tvars (|> (Constructor::getTypeParameters constructor) + array.to-list + (list@map (|>> TypeVariable::getName))) + [owner-tvarsT mappings] (jvm-type-var-mappings owner-tvars method-tvars)] + (do ////.monad + [inputsT (|> (Constructor::getGenericParameterTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive (Class::getName owner) owner-tvarsT) + constructorT (<| (type.univ-q (dictionary.size mappings)) + (type.function inputsT) + objectT)]] + (wrap [constructorT exceptionsT])))) + (type: Evaluation (#Pass Method-Signature) (#Hint Method-Signature) @@ -1105,41 +1154,6 @@ candidates (/////analysis.throw too-many-candidates [class-name method-name candidates])))) -(def: (constructor-signature constructor) - (-> (Constructor Object) (Operation Method-Signature)) - (let [owner (Constructor::getDeclaringClass constructor) - owner-name (Class::getName owner) - owner-tvars (|> (Class::getTypeParameters owner) - array.to-list - (list@map (|>> TypeVariable::getName))) - constructor-tvars (|> (Constructor::getTypeParameters constructor) - array.to-list - (list@map (|>> TypeVariable::getName))) - num-owner-tvars (list.size owner-tvars) - all-tvars (list@compose owner-tvars constructor-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars 0) - constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list@compose owner-tvarsT constructor-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dictionary.from-list text.hash))))] - (do ////.monad - [inputsT (|> (Constructor::getGenericParameterTypes constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) - constructorT (<| (type.univ-q num-all-tvars) - (type.function inputsT) - objectT)]] - (wrap [constructorT exceptionsT])))) - (def: constructor-method "<init>") (def: (constructor-candidate class-name arg-classes) @@ -1178,106 +1192,80 @@ (def: invoke::static Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text (List [Text Code])]) - (s.run args ($_ p.and s.text s.text (p.some ..typed-input)))) - (#error.Success [class method argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Static argsT) - [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC)) - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) - (/////analysis.text method) - (/////analysis.text outputJC) - (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) + (..custom [($_ p.and ..member (p.some ..typed-input)) + (function (_ extension-name analyse [[class method] argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Static argsT) + [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC)) + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) + (/////analysis.text method) + (/////analysis.text outputJC) + (decorate-inputs argsT argsA))))))])) (def: invoke::virtual Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input)))) - (#error.Success [class method objectC argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Virtual argsT) - [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) - (/////analysis.text method) - (/////analysis.text outputJC) - objectA - (decorate-inputs argsT argsA))))) + (..custom [($_ p.and ..member s.any (p.some ..typed-input)) + (function (_ extension-name analyse [[class method] objectC argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Virtual argsT) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) + _ + (undefined))] + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) + (/////analysis.text method) + (/////analysis.text outputJC) + objectA + (decorate-inputs argsT argsA))))))])) (def: invoke::special Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input)))) - (#error.Success [class method objectC argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Special argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) - (/////analysis.text method) - (/////analysis.text outputJC) - (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) + (..custom [($_ p.and ..member s.any (p.some ..typed-input)) + (function (_ extension-name analyse [[class method] objectC argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Special argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) + (/////analysis.text method) + (/////analysis.text outputJC) + (decorate-inputs argsT argsA))))))])) (def: invoke::interface Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some ..typed-input)))) - (#error.Success [class-name method objectC argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - class (load-class class-name) - _ (////.assert non-interface class-name - (Modifier::isInterface (Class::getModifiers class))) - [methodT exceptionsT] (method-candidate class-name method #Interface argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name - (list& (/////analysis.text class-name) - (/////analysis.text method) - (/////analysis.text outputJC) - (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) + (..custom [($_ p.and ..member s.any (p.some ..typed-input)) + (function (_ extension-name analyse [[class-name method] objectC argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + class (load-class class-name) + _ (////.assert non-interface class-name + (Modifier::isInterface (Class::getModifiers class))) + [methodT exceptionsT] (method-candidate class-name method #Interface argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name + (list& (/////analysis.text class-name) + (/////analysis.text method) + (/////analysis.text outputJC) + (decorate-inputs argsT argsA))))))])) (def: invoke::constructor - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text (List [Text Code])]) - (s.run args ($_ p.and s.text (p.some ..typed-input)))) - (#error.Success [class argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (constructor-candidate class argsT) - [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) - (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) + (..custom [($_ p.and s.text (p.some ..typed-input)) + (function (_ extension-name analyse [class argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (constructor-candidate class argsT) + [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) + (decorate-inputs argsT argsA))))))])) (def: bundle::member Bundle |