diff options
Diffstat (limited to '')
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/function.lux | 85 | ||||
| -rw-r--r-- | new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux | 239 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/array.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/data/text.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/host.jvm.lux | 132 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/type.lux | 41 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase.lux | 7 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux | 486 |
8 files changed, 562 insertions, 432 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.lux b/new-luxc/source/luxc/lang/translation/jvm/function.lux index ae876c3fc..d0764796f 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/function.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/function.lux @@ -9,13 +9,13 @@ ["." text format] [collection - ["." list ("#/." functor monoid)]]] + ["." list ("#@." functor monoid)]]] [target - [jvm - ["." type (#+ Type Method)]]] + ["." jvm #_ + ["#" type (#+ Type Method)]]] [tool [compiler - [analysis (#+ Arity)] + [analysis (#+ Arity Environment)] [synthesis (#+ Synthesis Abstraction Apply)] ["_." reference (#+ Register Variable)] ["." phase @@ -30,9 +30,8 @@ ["." runtime] ["." reference]]) - (def: arity-field Text "arity") -(def: $Object Type (type.class "java.lang.Object" (list))) +(def: $Object Type (jvm.class "java.lang.Object" (list))) (def: (poly-arg? arity) (-> Arity Bit) @@ -40,29 +39,29 @@ (def: (reset-method class) (-> Text Method) - (type.method (list) (#.Some (type.class class (list))) (list))) + (jvm.method (list) (#.Some (jvm.class class (list))) (list))) (def: (captured-args env) - (-> (List Variable) (List Type)) + (-> Environment (List Type)) (list.repeat (list.size env) $Object)) (def: (init-method env arity) - (-> (List Variable) Arity Method) + (-> Environment Arity Method) (if (poly-arg? arity) - (type.method (list.concat (list (captured-args env) - (list type.int) - (list.repeat (dec arity) $Object))) - #.None - (list)) - (type.method (captured-args env) #.None (list)))) + (jvm.method (list.concat (list (captured-args env) + (list jvm.int) + (list.repeat (dec arity) $Object))) + #.None + (list)) + (jvm.method (captured-args env) #.None (list)))) (def: (implementation-method arity) - (type.method (list.repeat arity $Object) (#.Some $Object) (list))) + (jvm.method (list.repeat arity $Object) (#.Some $Object) (list))) (def: get-amount-of-partialsI Inst (|>> (_.ALOAD 0) - (_.GETFIELD //.function-class runtime.partials-field type.int))) + (_.GETFIELD //.function-class runtime.partials-field jvm.int))) (def: (load-fieldI class field) (-> Text Text Inst) @@ -72,7 +71,7 @@ (def: (inputsI start amount) (-> Register Nat Inst) (|> (list.n/range start (n/+ start (dec amount))) - (list/map _.ALOAD) + (list@map _.ALOAD) _.fuse)) (def: (applysI start amount) @@ -97,24 +96,24 @@ (list.repeat amount) _.fuse)) -(def: (with-captured env) - (-> (List Variable) Def) - (|> (list.enumerate env) - (list/map (.function (_ [env-idx env-source]) - (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object))) - def.fuse)) +(def: #export with-environment + (-> Environment Def) + (|>> list.enumerate + (list@map (.function (_ [env-idx env-source]) + (def.field #$.Private $.finalF (reference.foreign-name env-idx) $Object))) + def.fuse)) (def: (with-partial arity) (-> Arity Def) (if (poly-arg? arity) (|> (list.n/range 0 (n/- 2 arity)) - (list/map (.function (_ idx) + (list@map (.function (_ idx) (def.field #$.Private $.finalF (reference.partial-name idx) $Object))) def.fuse) function.identity)) (def: (instance class arity env) - (-> Text Arity (List Variable) (Operation Inst)) + (-> Text Arity Environment (Operation Inst)) (do phase.monad [captureI+ (monad.map @ reference.variable env) #let [argsI (if (poly-arg? arity) @@ -129,14 +128,14 @@ (_.INVOKESPECIAL class "<init>" (init-method env arity) #0))))) (def: (with-reset class arity env) - (-> Text Arity (List Variable) Def) + (-> Text Arity Environment Def) (def.method #$.Public $.noneM "reset" (reset-method class) (if (poly-arg? arity) (let [env-size (list.size env) captureI (|> (case env-size 0 (list) _ (list.n/range 0 (dec env-size))) - (list/map (.function (_ source) + (list@map (.function (_ source) (|>> (_.ALOAD 0) (_.GETFIELD class (reference.foreign-name source) $Object)))) _.fuse) @@ -161,7 +160,7 @@ (def: function-init-method Method - (type.method (list type.int) #.None (list))) + (jvm.method (list jvm.int) #.None (list))) (def: (function-init arity env-size) (-> Arity Nat Inst) @@ -172,21 +171,21 @@ (_.INVOKESPECIAL //.function-class "<init>" function-init-method #0)))) (def: (with-init class env arity) - (-> Text (List Variable) Arity Def) + (-> Text Environment Arity Def) (let [env-size (list.size env) offset-partial (: (-> Nat Nat) (|>> inc (n/+ env-size))) store-capturedI (|> (case env-size 0 (list) _ (list.n/range 0 (dec env-size))) - (list/map (.function (_ register) + (list@map (.function (_ register) (|>> (_.ALOAD 0) (_.ALOAD (inc register)) (_.PUTFIELD class (reference.foreign-name register) $Object)))) _.fuse) store-partialI (if (poly-arg? arity) (|> (list.n/range 0 (n/- 2 arity)) - (list/map (.function (_ idx) + (list@map (.function (_ idx) (let [register (offset-partial idx)] (|>> (_.ALOAD 0) (_.ALOAD (inc register)) @@ -201,18 +200,18 @@ _.RETURN)))) (def: (with-apply class env function-arity @begin bodyI apply-arity) - (-> Text (List Variable) Arity Label Inst Arity + (-> Text Environment Arity Label Inst Arity Def) (let [num-partials (dec function-arity) @default ($.new-label []) - @labels (list/map $.new-label (list.repeat num-partials [])) + @labels (list@map $.new-label (list.repeat num-partials [])) arity-over-extent (|> (.int function-arity) (i/- (.int apply-arity))) - casesI (|> (list/compose @labels (list @default)) + casesI (|> (list@compose @labels (list @default)) (list.zip2 (list.n/range 0 num-partials)) - (list/map (.function (_ [stage @label]) + (list@map (.function (_ [stage @label]) (let [load-partialsI (if (n/> 0 stage) (|> (list.n/range 0 (dec stage)) - (list/map (|>> reference.partial-name (load-fieldI class))) + (list@map (|>> reference.partial-name (load-fieldI class))) _.fuse) function.identity)] (cond (i/= arity-over-extent (.int stage)) @@ -242,7 +241,7 @@ load-capturedI (|> (case env-size 0 (list) _ (list.n/range 0 (dec env-size))) - (list/map (|>> reference.foreign-name (load-fieldI class))) + (list@map (|>> reference.foreign-name (load-fieldI class))) _.fuse)] (|>> (_.label @label) (_.NEW class) @@ -262,20 +261,20 @@ (_.TABLESWITCH +0 (|> num-partials dec .int) @default @labels) casesI - (_.INVOKESTATIC //.runtime-class "apply_fail" (type.method (list) #.None (list)) #0) + (_.INVOKESTATIC //.runtime-class "apply_fail" (jvm.method (list) #.None (list)) #0) _.NULL _.ARETURN )))) (def: #export (with-function @begin class env arity bodyI) - (-> Label Text (List Variable) Arity Inst + (-> Label Text Environment Arity Inst (Operation [Def Inst])) (let [env-size (list.size env) applyD (: Def (if (poly-arg? arity) (|> (n/min arity runtime.num-apply-variants) (list.n/range 1) - (list/map (with-apply class env arity @begin bodyI)) + (list@map (with-apply class env arity @begin bodyI)) (list& (with-implementation arity @begin bodyI)) def.fuse) (def.method #$.Public $.strictM runtime.apply-method (runtime.apply-signature 1) @@ -284,7 +283,7 @@ _.ARETURN)))) functionD (: Def (|>> (def.int-field #$.Public ($_ $.++F $.staticF $.finalF) arity-field (.int arity)) - (with-captured env) + (with-environment env) (with-partial arity) (with-init class env arity) (with-reset class arity env) @@ -323,7 +322,7 @@ [functionI (translate functionS) argsI (monad.map @ translate argsS) #let [applyI (|> (segment runtime.num-apply-variants argsI) - (list/map (.function (_ chunkI+) + (list@map (.function (_ chunkI+) (|>> (_.CHECKCAST //.function-class) (_.fuse chunkI+) (_.INVOKEVIRTUAL //.function-class runtime.apply-method (runtime.apply-signature (list.size chunkI+)) #0)))) 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 55798c806..be2a0bace 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux @@ -31,6 +31,8 @@ ["." generation [extension (#+ Nullary Unary Binary nullary unary binary)]] + [analysis + [".A" reference]] ["." extension ["." bundle] [analysis @@ -39,17 +41,27 @@ [luxc [lang [host - ["$" jvm (#+ Label Inst Handler Bundle Operation Phase) + ["$" jvm (#+ Label Inst Def Handler Bundle Operation Phase) ["_" inst] - ["_." def]]]]]) + ["_." def]]]]] + ["." /// #_ + ["#." reference] + ["#." function]]) -(template [<name>] - [(exception: #export (<name> {message Text}) - message)] +(exception: #export invalid-syntax-for-argument-generation) - [invalid-syntax-for-jvm-type] - [invalid-syntax-for-argument-generation] - ) +(def: (custom [parser handler]) + (All [s] + (-> [(<s>.Parser s) + (-> Text Phase s (Operation Inst))] + Handler)) + (function (_ extension-name phase input) + (case (<s>.run input parser) + (#error.Success input') + (handler extension-name phase input') + + (#error.Failure error) + (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) (template [<name> <inst>] [(def: <name> @@ -306,7 +318,17 @@ "char" jvm.char _ (jvm.class elem-class (list))))) -(def: (array::length extension-name generate inputs) +(def: (primitive-array-length-handler jvm-primitive) + (-> Type Handler) + (..custom [<s>.any + (function (_ extension-name generate arrayS) + (do phase.monad + [arrayI (generate arrayS)] + (wrap (|>> arrayI + (_.CHECKCAST (jvm.descriptor (jvm.array 1 jvm-primitive))) + _.ARRAYLENGTH))))])) + +(def: (array::length::object extension-name generate inputs) Handler (case inputs (^ (list (synthesis.i64 nesting) @@ -427,7 +449,17 @@ Bundle (<| (bundle.prefix "array") (|> bundle.empty - (bundle.install "length" array::length) + (dictionary.merge (<| (bundle.prefix "length") + (|> bundle.empty + (bundle.install "boolean" (primitive-array-length-handler jvm.boolean)) + (bundle.install "byte" (primitive-array-length-handler jvm.byte)) + (bundle.install "short" (primitive-array-length-handler jvm.short)) + (bundle.install "int" (primitive-array-length-handler jvm.int)) + (bundle.install "long" (primitive-array-length-handler jvm.long)) + (bundle.install "float" (primitive-array-length-handler jvm.float)) + (bundle.install "double" (primitive-array-length-handler jvm.double)) + (bundle.install "char" (primitive-array-length-handler jvm.char)) + (bundle.install "object" array::length::object)))) (dictionary.merge (<| (bundle.prefix "new") (|> bundle.empty (bundle.install "boolean" (new-primitive-array-handler jvm.boolean)) @@ -671,62 +703,30 @@ _ (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) -(def: base-type - (<t>.Parser Type) - ($_ <>.either - (<>.after (<t>.this "boolean") (<>@wrap jvm.boolean)) - (<>.after (<t>.this "byte") (<>@wrap jvm.byte)) - (<>.after (<t>.this "short") (<>@wrap jvm.short)) - (<>.after (<t>.this "int") (<>@wrap jvm.int)) - (<>.after (<t>.this "long") (<>@wrap jvm.long)) - (<>.after (<t>.this "float") (<>@wrap jvm.float)) - (<>.after (<t>.this "double") (<>@wrap jvm.double)) - (<>.after (<t>.this "char") (<>@wrap jvm.char)) - (<>@map (function (_ name) - (jvm.class name (list))) - (<t>.many (<t>.none-of "["))) - )) - -(def: java-type - (<t>.Parser Type) - (do <>.monad - [raw base-type - nesting (<>.some (<t>.this "[]"))] - (wrap (jvm.array (list.size nesting) raw)))) - -(def: (generate-type argD) - (-> Text (Operation Type)) - (case (<t>.run java-type argD) - (#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 - [argD (phase.lift (:: error.monad map - jvm.reflection-class - (jvm.parse-signature argD))) - argT (generate-type argD) + [argT (phase.lift (<t>.run jvm.parse-signature argD)) argI (generate argS)] (wrap [argT argI])) _ - (phase.throw invalid-syntax-for-argument-generation ""))) + (phase.throw invalid-syntax-for-argument-generation []))) (def: (method-return-type description) (-> Text (Operation (Maybe Type))) (case description - "void" + (^ (static jvm.void-descriptor)) (phase@wrap #.None) _ - (phase@map (|>> #.Some) (generate-type description)))) + (|> description + (<t>.run jvm.parse-signature) + phase.lift + (phase@map (|>> #.Some))))) (def: (prepare-argI [type argI]) (-> [Type Inst] Inst) @@ -738,46 +738,35 @@ #.None argI)) -(def: (invoke::static extension-name generate inputs) +(def: invoke::static 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 ..prepare-argI argsTI)) - (_.INVOKESTATIC class method - (jvm.method (list@map product.left argsTI) returnT (list)) - false)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))) + (..custom + [($_ <>.and <s>.text <s>.text <s>.text (<>.some <s>.any)) + (function (_ extension-name generate [class method unboxed argsS]) + (do phase.monad + [argsTI (monad.map @ (generate-arg generate) argsS) + returnT (method-return-type unboxed)] + (wrap (|>> (_.fuse (list@map ..prepare-argI argsTI)) + (_.INVOKESTATIC class method + (jvm.method (list@map product.left argsTI) returnT (list)) + false)))))])) (template [<name> <invoke> <interface?>] - [(def: (<name> extension-name generate inputs) + [(def: <name> 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 ..prepare-argI argsTI)) - (<invoke> class method - (jvm.method (list@map product.left argsTI) returnT (list)) - <interface?>)))) - - _ - (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))] + (..custom + [($_ <>.and <s>.text <s>.text <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension-name generate [class method 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 ..prepare-argI argsTI)) + (<invoke> class method + (jvm.method (list@map product.left argsTI) returnT (list)) + <interface?>)))))]))] [invoke::virtual _.INVOKEVIRTUAL false] [invoke::special _.INVOKESPECIAL false] @@ -821,19 +810,6 @@ (bundle.install "constructor" invoke::constructor)))) ))) -(def: (custom [parser handler]) - (All [s] - (-> [(<s>.Parser s) - (-> Text Phase s (Operation Inst))] - Handler)) - (function (_ extension-name phase input) - (case (<s>.run input parser) - (#error.Success input') - (handler extension-name phase input') - - (#error.Failure error) - (phase.throw extension.invalid-syntax [extension-name %synthesis input])))) - (def: var (<s>.Parser Var) <s>.text) @@ -902,7 +878,7 @@ (def: return (<s>.Parser Return) - (<>.or (<s>.constant! ["" "void"]) + (<>.or (<s>.constant! ["" jvm.void-descriptor]) ..jvm-type)) (def: overriden-method-definition @@ -998,6 +974,39 @@ (#synthesis.Extension [name inputsS+]) (#synthesis.Extension [name (list@map recur inputsS+)])))) +(def: $Object (jvm.class jvm.object-class (list))) + +(def: (anonymous-init-method env) + (-> Environment Method) + (jvm.method (list.repeat (list.size env) $Object) + #.None + (list))) + +(def: (with-anonymous-init class env) + (-> Text Environment Def) + (let [store-capturedI (|> env + list.size + list.indices + (list@map (.function (_ register) + (|>> (_.ALOAD 0) + (_.ALOAD (inc register)) + (_.PUTFIELD class (///reference.foreign-name register) $Object)))) + _.fuse)] + (_def.method #$.Public $.noneM "<init>" (anonymous-init-method env) + (|>> (_.ALOAD 0) + (_.INVOKESPECIAL jvm.object-class "<init>" (jvm.method (list) #.None (list)) #0) + store-capturedI + _.RETURN)))) + +(def: (anonymous-instance class env) + (-> Text Environment (Operation Inst)) + (do phase.monad + [captureI+ (monad.map @ ///reference.variable env)] + (wrap (|>> (_.NEW class) + _.DUP + (_.fuse captureI+) + (_.INVOKESPECIAL class "<init>" (anonymous-init-method env) #0))))) + (def: class::anonymous Handler (..custom @@ -1012,14 +1021,15 @@ constructor-args overriden-methods]) (do phase.monad - [#let [global-mapping (|> overriden-methods - ## Get all the environments. - (list@map product.left) - ## Combine them. - list@join - ## Remove duplicates. - (set.from-list reference.hash) - set.to-list + [#let [total-environment (|> overriden-methods + ## Get all the environments. + (list@map product.left) + ## Combine them. + list@join + ## Remove duplicates. + (set.from-list reference.hash) + set.to-list) + global-mapping (|> total-environment ## Give them names as "foreign" variables. list.enumerate (list@map (function (_ [id capture]) @@ -1043,14 +1053,13 @@ self-name arguments returnT exceptionsT (normalize-method-body local-mapping body)])) overriden-methods)] - ## _ (generation.save! true ["" function-class] - ## [function-class - ## (def.class #$.V1_6 #$.Public $.finalC - ## function-class (list) - ## ($.simple-class //.function-class) (list) - ## functionD)]) - _ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])] - (wrap _.DUP)))])) + _ (generation.save! true ["" class-name] + [class-name + (_def.class #$.V1_6 #$.Public $.finalC + class-name (list) + super-class super-interfaces + (|>> (///function.with-environment total-environment)))])] + (anonymous-instance class-name total-environment)))])) (def: bundle::class Bundle diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index b6f877d73..cac39d65f 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -50,7 +50,7 @@ (~~ (static @.jvm)) (|> array (:coerce <array-type>) - "jvm array length" + "jvm array length object" "jvm conversion int-to-long" "jvm object cast" (: <index-type>) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index a9cec1526..ad5d49ae2 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -189,7 +189,7 @@ (def: (hash input) (`` (for {(~~ (static @.old)) (|> input - (: (primitive "java.lang.String" [])) + (: (primitive "java.lang.String")) "jvm invokevirtual:java.lang.String:hashCode:" "jvm convert int-to-long" (:coerce Nat)) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index d93edbfe4..495d8a7ce 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -1811,27 +1811,27 @@ {type (..type^ imports (list))} size) {#.doc (doc "Create an array of the given type, with the given size." - (array Object 10))} - (case type - (^template [<primitive> <array-op>] - (^ (#jvm.Primitive <primitive>)) - (wrap (list (` (<array-op> (~ size)))))) - ([#jvm.Boolean "jvm znewarray"] - [#jvm.Byte "jvm bnewarray"] - [#jvm.Short "jvm snewarray"] - [#jvm.Int "jvm inewarray"] - [#jvm.Long "jvm lnewarray"] - [#jvm.Float "jvm fnewarray"] - [#jvm.Double "jvm dnewarray"] - [#jvm.Char "jvm cnewarray"]) - - _ - (wrap (list (` ("jvm anewarray" (~ (type$ type)) (~ size))))))) + (array java/lang/Object 10))} + (let [g!size (` (|> (~ size) + (.: .Nat) + (.:coerce (.primitive "java.lang.Long")) + "jvm object cast" + "jvm conversion long-to-int"))] + (case type + (^template [<primitive> <array-op>] + (^ (#jvm.Primitive <primitive>)) + (wrap (list (` (<array-op> (~ g!size)))))) + ([#jvm.Boolean "jvm array new boolean"] + [#jvm.Byte "jvm array new byte"] + [#jvm.Short "jvm array new short"] + [#jvm.Int "jvm array new int"] + [#jvm.Long "jvm array new long"] + [#jvm.Float "jvm array new float"] + [#jvm.Double "jvm array new double"] + [#jvm.Char "jvm array new char"]) -(syntax: #export (array-length array) - {#.doc (doc "Gives the length of an array." - (array-length my-array))} - (wrap (list (` ("jvm arraylength" (~ array)))))) + _ + (wrap (list (` ("jvm array new object" (~ (type$ type)) (~ g!size)))))))) (def: (type->class-name type) (-> .Type (Meta Text)) @@ -1855,6 +1855,35 @@ _ (macro.fail (format "Cannot convert to JVM type: " (type.to-text type)))))) +(syntax: #export (array-length array) + {#.doc (doc "Gives the length of an array." + (array-length my-array))} + (case array + [_ (#.Identifier array-name)] + (do macro.monad + [array-type (macro.find-type array-name) + array-jvm-type (type->class-name array-type) + #let [g!extension (code.text (case array-jvm-type + "[Z" "jvm array length boolean" + "[B" "jvm array length byte" + "[S" "jvm array length short" + "[I" "jvm array length int" + "[J" "jvm array length long" + "[F" "jvm array length float" + "[D" "jvm array length double" + "[C" "jvm array length char" + _ "jvm array length object"))]] + (wrap (list (` (.|> ((~ g!extension) (~ array)) + "jvm conversion int-to-long" + "jvm object cast" + (.: (.primitive "java.lang.Long")) + (.:coerce .Nat)))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array-length (~ g!array))))))))) + (syntax: #export (array-read idx array) {#.doc (doc "Loads an element from an array." (array-read 10 my-array))} @@ -1862,22 +1891,29 @@ [_ (#.Identifier array-name)] (do macro.monad [array-type (macro.find-type array-name) - array-jvm-type (type->class-name array-type)] + array-jvm-type (type->class-name array-type) + #let [g!idx (` (.|> (~ idx) + (.: .Nat) + (.:coerce (.primitive "java.lang.Long")) + "jvm object cast" + "jvm conversion long-to-int"))]] (case array-jvm-type - (^template [<type> <array-op>] + (^template [<type> <array-op> <box>] <type> - (wrap (list (` (<array-op> (~ array) (~ idx)))))) - (["[Z" "jvm zaload"] - ["[B" "jvm baload"] - ["[S" "jvm saload"] - ["[I" "jvm iaload"] - ["[J" "jvm jaload"] - ["[F" "jvm faload"] - ["[D" "jvm daload"] - ["[C" "jvm caload"]) + (wrap (list (` (.|> (<array-op> (~ g!idx) (~ array)) + "jvm object cast" + (.: (.primitive <box>))))))) + (["[Z" "jvm array read boolean" "java.lang.Boolean"] + ["[B" "jvm array read byte" "java.lang.Byte"] + ["[S" "jvm array read short" "java.lang.Short"] + ["[I" "jvm array read int" "java.lang.Integer"] + ["[J" "jvm array read long" "java.lang.Long"] + ["[F" "jvm array read float" "java.lang.Float"] + ["[D" "jvm array read double" "java.lang.Double"] + ["[C" "jvm array read char" "java.lang.Character"]) _ - (wrap (list (` ("jvm aaload" (~ array) (~ idx))))))) + (wrap (list (` ("jvm array read object" (~ g!idx) (~ array))))))) _ (with-gensyms [g!array] @@ -1891,22 +1927,30 @@ [_ (#.Identifier array-name)] (do macro.monad [array-type (macro.find-type array-name) - array-jvm-type (type->class-name array-type)] + array-jvm-type (type->class-name array-type) + #let [g!idx (` (.|> (~ idx) + (.: .Nat) + (.:coerce (.primitive "java.lang.Long")) + "jvm object cast" + "jvm conversion long-to-int"))]] (case array-jvm-type - (^template [<type> <array-op>] + (^template [<type> <array-op> <box>] <type> - (wrap (list (` (<array-op> (~ array) (~ idx) (~ value)))))) - (["[Z" "jvm zastore"] - ["[B" "jvm bastore"] - ["[S" "jvm sastore"] - ["[I" "jvm iastore"] - ["[J" "jvm jastore"] - ["[F" "jvm fastore"] - ["[D" "jvm dastore"] - ["[C" "jvm castore"]) + (let [g!value (` (.|> (~ value) + (.:coerce (.primitive <box>)) + "jvm object cast"))] + (wrap (list (` (<array-op> (~ g!idx) (~ g!value) (~ array))))))) + (["[Z" "jvm array write boolean" "java.lang.Boolean"] + ["[B" "jvm array write byte" "java.lang.Byte"] + ["[S" "jvm array write short" "java.lang.Short"] + ["[I" "jvm array write int" "java.lang.Integer"] + ["[J" "jvm array write long" "java.lang.Long"] + ["[F" "jvm array write float" "java.lang.Float"] + ["[D" "jvm array write double" "java.lang.Double"] + ["[C" "jvm array write char" "java.lang.Character"]) _ - (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) + (wrap (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array))))))) _ (with-gensyms [g!array] diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux index 98880e5a8..d8851d978 100644 --- a/stdlib/source/lux/target/jvm/type.lux +++ b/stdlib/source/lux/target/jvm/type.lux @@ -28,6 +28,7 @@ (template [<name> <reflection>] [(def: #export <name> <reflection>)] + [void-reflection "void"] [boolean-reflection "boolean"] [byte-reflection "byte"] [short-reflection "short"] @@ -38,14 +39,14 @@ [char-reflection "char"] ) -(def: array-prefix "[") +(def: #export array-prefix "[") (def: object-prefix "L") (def: var-prefix "T") (def: wildcard-descriptor "*") (def: lower-prefix "-") (def: upper-prefix "+") (def: object-suffix ";") -(def: object-class "java.lang.Object") +(def: #export object-class "java.lang.Object") (def: valid-var-characters/head (format "abcdefghijklmnopqrstuvwxyz" @@ -278,24 +279,24 @@ )))) (def: #export parse-signature - (-> Text (Error Type)) - (<t>.run (<>.rec - (function (_ recur) - ($_ <>.or - ($_ <>.or - (<t>.this ..boolean-descriptor) - (<t>.this ..byte-descriptor) - (<t>.this ..short-descriptor) - (<t>.this ..int-descriptor) - (<t>.this ..long-descriptor) - (<t>.this ..float-descriptor) - (<t>.this ..double-descriptor) - (<t>.this ..char-descriptor) - ) - ..parse-generic - (<>.after (<t>.this ..array-prefix) - recur) - ))))) + (Parser Type) + (<>.rec + (function (_ recur) + ($_ <>.or + ($_ <>.or + (<t>.this ..boolean-descriptor) + (<t>.this ..byte-descriptor) + (<t>.this ..short-descriptor) + (<t>.this ..int-descriptor) + (<t>.this ..long-descriptor) + (<t>.this ..float-descriptor) + (<t>.this ..double-descriptor) + (<t>.this ..char-descriptor) + ) + ..parse-generic + (<>.after (<t>.this ..array-prefix) + recur) + )))) (def: #export (method args return exceptions) (-> (List Type) (Maybe Type) (List Generic) Method) diff --git a/stdlib/source/lux/tool/compiler/phase.lux b/stdlib/source/lux/tool/compiler/phase.lux index a6b080a19..6137e9fd6 100644 --- a/stdlib/source/lux/tool/compiler/phase.lux +++ b/stdlib/source/lux/tool/compiler/phase.lux @@ -1,7 +1,7 @@ (.module: [lux #* [abstract - [monad (#+ do)]] + [monad (#+ Monad do)]] [control ["." state] ["ex" exception (#+ Exception exception:)] @@ -10,7 +10,7 @@ ["s" code]]] [data ["." product] - ["." error (#+ Error) ("#;." functor)] + ["." error (#+ Error) ("#@." functor)] ["." text format]] [time @@ -23,6 +23,7 @@ (state.State' Error s o)) (def: #export monad + (All [s] (Monad (Operation s))) (state.with error.monad)) (type: #export (Phase s i o) @@ -73,7 +74,7 @@ (def: #export (lift error) (All [s a] (-> (Error a) (Operation s a))) (function (_ state) - (error;map (|>> [state]) error))) + (error@map (|>> [state]) error))) (syntax: #export (assert exception message test) (wrap (list (` (if (~ test) 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 61d65e67f..947bbc69f 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -6,7 +6,8 @@ ["." monad (#+ do)]] [control ["p" parser - ["s" code (#+ Parser)]] + ["s" code (#+ Parser)] + ["<t>" text]] ["." exception (#+ exception:)] pipe] [data @@ -53,6 +54,117 @@ ["_jvm_upper" upper-relationship-name upper-relationship-type] ) +## 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> #.Nil))] + + ## Boxes + [Boolean "java.lang.Boolean"] + [Byte "java.lang.Byte"] + [Short "java.lang.Short"] + [Integer "java.lang.Integer"] + [Long "java.lang.Long"] + [Float "java.lang.Float"] + [Double "java.lang.Double"] + [Character "java.lang.Character"] + [String "java.lang.String"] + + ## Primitives + [boolean jvm.boolean-reflection] + [byte jvm.byte-reflection] + [short jvm.short-reflection] + [int jvm.int-reflection] + [long jvm.long-reflection] + [float jvm.float-reflection] + [double jvm.double-reflection] + [char jvm.char-reflection] + ) + +(type: Mapping + (Dictionary Var .Type)) + +(def: fresh-mapping Mapping (dictionary.new text.hash)) + +(exception: #export (unknown-jvm-type-var {var Var}) + (exception.report + ["Var" (%t var)])) + +(def: (generic-type mapping generic) + (-> Mapping Generic (Check .Type)) + (case generic + (#jvm.Var var) + (case (dictionary.get var mapping) + #.None + (check.throw ..unknown-jvm-type-var var) + + (#.Some type) + (check@wrap type)) + + (#jvm.Wildcard wildcard) + (case wildcard + #.None + (do check.monad + [[id type] check.existential] + (wrap type)) + + (#.Some [bound limit]) + (do check.monad + [limitT (generic-type mapping limit)] + (case bound + #jvm.Lower + (wrap (lower-relationship-type limitT)) + + #jvm.Upper + (wrap (upper-relationship-type limitT))))) + + (#jvm.Class name parameters) + (do check.monad + [parametersT+ (monad.map @ (generic-type mapping) parameters)] + (wrap (#.Primitive name parametersT+))))) + +(def: (class-type mapping [name parameters]) + (-> Mapping Class (Check .Type)) + (do check.monad + [parametersT+ (monad.map @ (generic-type mapping) parameters)] + (wrap (#.Primitive name parametersT+)))) + +(def: (jvm-type mapping type) + (-> Mapping Type (Check .Type)) + (case type + (#jvm.Primitive primitive) + (check@wrap (case primitive + #jvm.Boolean ..boolean + #jvm.Byte ..byte + #jvm.Short ..short + #jvm.Int ..int + #jvm.Long ..long + #jvm.Float ..float + #jvm.Double ..double + #jvm.Char ..char)) + + (#jvm.Generic generic) + (generic-type mapping generic) + + (#jvm.Array type) + (case type + (#jvm.Primitive primitive) + (check@wrap (#.Primitive (jvm.descriptor (jvm.array 1 type)) (list))) + + _ + (do check.monad + [elementT (jvm-type mapping type)] + (wrap (.type (Array elementT))))))) + +(def: (return-type mapping type) + (-> Mapping Return (Check .Type)) + (case type + #.None + (check@wrap Any) + + (#.Some type) + (jvm-type mapping type))) + (def: (custom [syntax handler]) (All [s] (-> [(Parser s) @@ -161,33 +273,6 @@ [cannot-correspond-type-with-a-class] ) -## 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> #.Nil))] - - ## Boxes - [Boolean "java.lang.Boolean"] - [Byte "java.lang.Byte"] - [Short "java.lang.Short"] - [Integer "java.lang.Integer"] - [Long "java.lang.Long"] - [Float "java.lang.Float"] - [Double "java.lang.Double"] - [Character "java.lang.Character"] - [String "java.lang.String"] - - ## Primitives - [boolean "boolean"] - [byte "byte"] - [short "short"] - [int "int"] - [long "long"] - [float "float"] - [double "double"] - [char "char"] - ) - (def: bundle::conversion Bundle (<| (///bundle.prefix "conversion") @@ -237,8 +322,8 @@ (///bundle.install "ushr" (//common.binary <type> Integer <type>)) )))] - [bundle::int "int" ..long] - [bundle::long "long" ..long] + [bundle::int jvm.int-reflection ..long] + [bundle::long jvm.long-reflection ..long] ) (template [<name> <prefix> <type>] @@ -255,13 +340,13 @@ (///bundle.install "<" (//common.binary <type> <type> Bit)) )))] - [bundle::float "float" ..float] - [bundle::double "double" ..double] + [bundle::float jvm.float-reflection ..float] + [bundle::double jvm.double-reflection ..double] ) (def: bundle::char Bundle - (<| (///bundle.prefix "char") + (<| (///bundle.prefix jvm.char-reflection) (|> ///bundle.empty (///bundle.install "=" (//common.binary ..char ..char Bit)) (///bundle.install "<" (//common.binary ..char ..char Bit)) @@ -269,14 +354,14 @@ (def: #export boxes (Dictionary Text Text) - (|> (list ["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) + (|> (list [jvm.boolean-reflection "java.lang.Boolean"] + [jvm.byte-reflection "java.lang.Byte"] + [jvm.short-reflection "java.lang.Short"] + [jvm.int-reflection "java.lang.Integer"] + [jvm.long-reflection "java.lang.Long"] + [jvm.float-reflection "java.lang.Float"] + [jvm.double-reflection "java.lang.Double"] + [jvm.char-reflection "java.lang.Character"]) (dictionary.from-list text.hash))) (def: (array-type-info allow-primitives? arrayT) @@ -303,13 +388,27 @@ (#.Primitive class _) (if (dictionary.contains? class boxes) - (/////analysis.throw primitives-cannot-have-type-parameters class) + (/////analysis.throw ..primitives-cannot-have-type-parameters class) (////@wrap [level class])) _ (/////analysis.throw non-array arrayT)))) -(def: array::length +(def: (primitive-array-length-handler primitive-type) + (-> Type Handler) + (function (_ extension-name analyse args) + (case args + (^ (list arrayC)) + (do ////.monad + [_ (typeA.infer ..int) + arrayA (typeA.with-type (#.Primitive (jvm.descriptor (jvm.array 1 primitive-type)) (list)) + (analyse arrayC))] + (wrap (#/////analysis.Extension extension-name (list arrayA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: array::length::object Handler (function (_ extension-name analyse args) (case args @@ -363,14 +462,47 @@ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: (check-jvm objectT) - (-> .Type (Operation Text)) + (-> .Type (Operation Type)) (case objectT - (#.Primitive name _) - (////@wrap name) + (#.Primitive name #.Nil) + (case name + (^ (static jvm.boolean-reflection)) (////@wrap jvm.boolean) + (^ (static jvm.byte-reflection)) (////@wrap jvm.byte) + (^ (static jvm.short-reflection)) (////@wrap jvm.short) + (^ (static jvm.int-reflection)) (////@wrap jvm.int) + (^ (static jvm.long-reflection)) (////@wrap jvm.long) + (^ (static jvm.float-reflection)) (////@wrap jvm.float) + (^ (static jvm.double-reflection)) (////@wrap jvm.double) + (^ (static jvm.char-reflection)) (////@wrap jvm.char) + _ (if (text.starts-with? jvm.array-prefix name) + (////.lift (<t>.run jvm.parse-signature name)) + (////@wrap (jvm.class name (list))))) + + (^ (#.Primitive (static array.type-name) + (list elementT))) + (|> elementT + check-jvm + (////@map (jvm.array 1))) + + (#.Primitive name parameters) + (do ////.monad + [parameters (monad.map @ check-jvm parameters) + parameters (monad.map @ (function (_ parameter) + (case parameter + (#jvm.Generic generic) + (wrap generic) + + _ + (/////analysis.throw ..primitives-cannot-have-type-parameters name))) + parameters)] + (////@wrap (jvm.class name parameters))) + + (#.Named name anonymous) + (check-jvm anonymous) (^template [<tag>] (<tag> id) - (////@wrap "java.lang.Object")) + (////@wrap (jvm.class "java.lang.Object" (list)))) ([#.Var] [#.Ex]) @@ -394,16 +526,16 @@ (def: (check-object objectT) (-> .Type (Operation Text)) (do ////.monad - [name (check-jvm objectT)] - (if (dictionary.contains? name boxes) + [name (:: @ map jvm.reflection-class (check-jvm objectT))] + (if (dictionary.contains? name ..boxes) (/////analysis.throw ..primitives-are-not-objects [name]) (////@wrap name)))) (def: (check-return type) (-> .Type (Operation Text)) (if (is? .Any type) - (////@wrap "void") - (check-jvm type))) + (////@wrap jvm.void-descriptor) + (////@map jvm.signature (check-jvm type)))) (def: (read-primitive-array-handler lux-type jvm-type) (-> .Type Type Handler) @@ -495,39 +627,49 @@ Bundle (<| (///bundle.prefix "array") (|> ///bundle.empty - (///bundle.install "length" array::length) + (dictionary.merge (<| (///bundle.prefix "length") + (|> ///bundle.empty + (///bundle.install jvm.boolean-reflection (primitive-array-length-handler jvm.boolean)) + (///bundle.install jvm.byte-reflection (primitive-array-length-handler jvm.byte)) + (///bundle.install jvm.short-reflection (primitive-array-length-handler jvm.short)) + (///bundle.install jvm.int-reflection (primitive-array-length-handler jvm.int)) + (///bundle.install jvm.long-reflection (primitive-array-length-handler jvm.long)) + (///bundle.install jvm.float-reflection (primitive-array-length-handler jvm.float)) + (///bundle.install jvm.double-reflection (primitive-array-length-handler jvm.double)) + (///bundle.install jvm.char-reflection (primitive-array-length-handler jvm.char)) + (///bundle.install "object" array::length::object)))) (dictionary.merge (<| (///bundle.prefix "new") (|> ///bundle.empty - (///bundle.install "boolean" (new-primitive-array-handler jvm.boolean)) - (///bundle.install "byte" (new-primitive-array-handler jvm.byte)) - (///bundle.install "short" (new-primitive-array-handler jvm.short)) - (///bundle.install "int" (new-primitive-array-handler jvm.int)) - (///bundle.install "long" (new-primitive-array-handler jvm.long)) - (///bundle.install "float" (new-primitive-array-handler jvm.float)) - (///bundle.install "double" (new-primitive-array-handler jvm.double)) - (///bundle.install "char" (new-primitive-array-handler jvm.char)) + (///bundle.install jvm.boolean-reflection (new-primitive-array-handler jvm.boolean)) + (///bundle.install jvm.byte-reflection (new-primitive-array-handler jvm.byte)) + (///bundle.install jvm.short-reflection (new-primitive-array-handler jvm.short)) + (///bundle.install jvm.int-reflection (new-primitive-array-handler jvm.int)) + (///bundle.install jvm.long-reflection (new-primitive-array-handler jvm.long)) + (///bundle.install jvm.float-reflection (new-primitive-array-handler jvm.float)) + (///bundle.install jvm.double-reflection (new-primitive-array-handler jvm.double)) + (///bundle.install jvm.char-reflection (new-primitive-array-handler jvm.char)) (///bundle.install "object" array::new::object)))) (dictionary.merge (<| (///bundle.prefix "read") (|> ///bundle.empty - (///bundle.install "boolean" (read-primitive-array-handler ..boolean jvm.boolean)) - (///bundle.install "byte" (read-primitive-array-handler ..byte jvm.byte)) - (///bundle.install "short" (read-primitive-array-handler ..short jvm.short)) - (///bundle.install "int" (read-primitive-array-handler ..int jvm.int)) - (///bundle.install "long" (read-primitive-array-handler ..long jvm.long)) - (///bundle.install "float" (read-primitive-array-handler ..float jvm.float)) - (///bundle.install "double" (read-primitive-array-handler ..double jvm.double)) - (///bundle.install "char" (read-primitive-array-handler ..char jvm.char)) + (///bundle.install jvm.boolean-reflection (read-primitive-array-handler ..boolean jvm.boolean)) + (///bundle.install jvm.byte-reflection (read-primitive-array-handler ..byte jvm.byte)) + (///bundle.install jvm.short-reflection (read-primitive-array-handler ..short jvm.short)) + (///bundle.install jvm.int-reflection (read-primitive-array-handler ..int jvm.int)) + (///bundle.install jvm.long-reflection (read-primitive-array-handler ..long jvm.long)) + (///bundle.install jvm.float-reflection (read-primitive-array-handler ..float jvm.float)) + (///bundle.install jvm.double-reflection (read-primitive-array-handler ..double jvm.double)) + (///bundle.install jvm.char-reflection (read-primitive-array-handler ..char jvm.char)) (///bundle.install "object" array::read::object)))) (dictionary.merge (<| (///bundle.prefix "write") (|> ///bundle.empty - (///bundle.install "boolean" (write-primitive-array-handler ..boolean jvm.boolean)) - (///bundle.install "byte" (write-primitive-array-handler ..byte jvm.byte)) - (///bundle.install "short" (write-primitive-array-handler ..short jvm.short)) - (///bundle.install "int" (write-primitive-array-handler ..int jvm.int)) - (///bundle.install "long" (write-primitive-array-handler ..long jvm.long)) - (///bundle.install "float" (write-primitive-array-handler ..float jvm.float)) - (///bundle.install "double" (write-primitive-array-handler ..double jvm.double)) - (///bundle.install "char" (write-primitive-array-handler ..char jvm.char)) + (///bundle.install jvm.boolean-reflection (write-primitive-array-handler ..boolean jvm.boolean)) + (///bundle.install jvm.byte-reflection (write-primitive-array-handler ..byte jvm.byte)) + (///bundle.install jvm.short-reflection (write-primitive-array-handler ..short jvm.short)) + (///bundle.install jvm.int-reflection (write-primitive-array-handler ..int jvm.int)) + (///bundle.install jvm.long-reflection (write-primitive-array-handler ..long jvm.long)) + (///bundle.install jvm.float-reflection (write-primitive-array-handler ..float jvm.float)) + (///bundle.install jvm.double-reflection (write-primitive-array-handler ..double jvm.double)) + (///bundle.install jvm.char-reflection (write-primitive-array-handler ..char jvm.char)) (///bundle.install "object" array::write::object)))) ))) @@ -727,11 +869,6 @@ ## else (/////analysis.throw cannot-convert-to-a-class jvm-type))) -(type: Mapping - (Dictionary Var .Type)) - -(def: fresh-mapping Mapping (dictionary.new text.hash)) - (def: (java-type-to-lux-type mapping java-type) (-> Mapping java/lang/reflect/Type (Operation .Type)) (<| (case (host.check TypeVariable java-type) @@ -760,17 +897,25 @@ (#.Some java-type) (let [java-type (:coerce (java/lang/Class java/lang/Object) java-type) class-name (java/lang/Class::getName java-type)] - (////@wrap (case (array.size (java/lang/Class::getTypeParameters java-type)) - 0 - (case class-name - "void" - Any - - _ - (#.Primitive class-name (list))) - - arity - (|> (list.indices arity) + (case (array.size (java/lang/Class::getTypeParameters java-type)) + 0 + (case class-name + (^ (static jvm.void-reflection)) + (////@wrap Any) + + _ + (if (text.starts-with? jvm.array-prefix class-name) + (case (<t>.run jvm.parse-signature (jvm.binary-name class-name)) + (#error.Success jtype) + (typeA.with-env + (jvm-type fresh-mapping jtype)) + + (#error.Failure error) + (/////analysis.fail error)) + (////@wrap (#.Primitive class-name (list))))) + + arity + (////@wrap (|> (list.indices arity) list.reverse (list@map (|>> (n/* 2) inc #.Parameter)) (#.Primitive class-name) @@ -832,8 +977,11 @@ (dictionary.from-list text.hash))) )) + (#.Named name anonymousT) + (correspond-type-params class anonymousT) + _ - (/////analysis.throw non-jvm-type type))) + (/////analysis.throw ..non-jvm-type type))) (def: (class-candiate-parents from-name fromT to-name to-class) (-> Text .Type Text (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit]))) @@ -861,7 +1009,7 @@ (monad.map ////.monad (function (_ superT) (do ////.monad - [super-name (check-jvm superT) + [super-name (:: @ map jvm.reflection-class (check-jvm superT)) super-class (load-class super-name)] (wrap [[super-name superT] (java/lang/Class::isAssignableFrom super-class to-class)]))) @@ -877,24 +1025,24 @@ (^ (list fromC)) (do ////.monad [toT (///.lift macro.expected-type) - to-name (check-jvm toT) + to-name (:: @ map jvm.reflection-class (check-jvm toT)) [fromT fromA] (typeA.with-inference (analyse fromC)) - from-name (check-jvm fromT) + from-name (:: @ map jvm.reflection-class (check-jvm fromT)) can-cast? (: (Operation Bit) (case [from-name to-name] (^template [<primitive> <object>] - (^or [<primitive> <object>] - [<object> <primitive>]) + (^or (^ [(static <primitive>) <object>]) + (^ [<object> (static <primitive>)])) (wrap #1)) - (["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) + ([jvm.boolean-reflection "java.lang.Boolean"] + [jvm.byte-reflection "java.lang.Byte"] + [jvm.short-reflection "java.lang.Short"] + [jvm.int-reflection "java.lang.Integer"] + [jvm.long-reflection "java.lang.Long"] + [jvm.float-reflection "java.lang.Float"] + [jvm.double-reflection "java.lang.Double"] + [jvm.char-reflection "java.lang.Character"]) _ (do @ @@ -1131,7 +1279,7 @@ (def: reflection-arguments (-> (List Text) (Operation (List Text))) - (|>> (monad.map error.monad jvm.parse-signature) + (|>> (monad.map error.monad (<t>.run jvm.parse-signature)) (:: error.monad map (list@map jvm.reflection-class)) ////.lift)) @@ -1403,12 +1551,19 @@ _ (////.assert non-interface class-name (Modifier::isInterface (java/lang/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))) + [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-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class-name) (/////analysis.text method) (/////analysis.text outputJC) + objectA (decorate-inputs argsT argsA))))))])) (def: invoke::constructor @@ -1470,96 +1625,17 @@ (Parser Class) (s.form (p.and s.text (p.some ..generic)))) -(exception: #export (unknown-jvm-type-var {var Var}) - (exception.report - ["Var" (%t var)])) - -(def: (generic-type mapping generic) - (-> Mapping Generic (Check .Type)) - (case generic - (#jvm.Var var) - (case (dictionary.get var mapping) - #.None - (check.throw unknown-jvm-type-var var) - - (#.Some type) - (check@wrap type)) - - (#jvm.Wildcard wildcard) - (case wildcard - #.None - (do check.monad - [[id type] check.existential] - (wrap type)) - - (#.Some [bound limit]) - (do check.monad - [limitT (generic-type mapping limit)] - (case bound - #jvm.Lower - (wrap (lower-relationship-type limitT)) - - #jvm.Upper - (wrap (upper-relationship-type limitT))))) - - (#jvm.Class name parameters) - (do check.monad - [parametersT+ (monad.map @ (generic-type mapping) parameters)] - (wrap (#.Primitive name parametersT+))))) - -(def: (class-type mapping [name parameters]) - (-> Mapping Class (Check .Type)) - (do check.monad - [parametersT+ (monad.map @ (generic-type mapping) parameters)] - (wrap (#.Primitive name parametersT+)))) - -(def: (jvm-type mapping type) - (-> Mapping Type (Check .Type)) - (case type - (#jvm.Primitive primitive) - (check@wrap (case primitive - #jvm.Boolean ..boolean - #jvm.Byte ..byte - #jvm.Short ..short - #jvm.Int ..int - #jvm.Long ..long - #jvm.Float ..float - #jvm.Double ..double - #jvm.Char ..char)) - - (#jvm.Generic generic) - (generic-type mapping generic) - - (#jvm.Array type) - (case type - (#jvm.Primitive primitive) - (check@wrap (#.Primitive (jvm.descriptor (jvm.array 1 type)) (list))) - - _ - (do check.monad - [elementT (jvm-type mapping type)] - (wrap (.type (Array elementT))))))) - -(def: (return-type mapping type) - (-> Mapping Return (Check .Type)) - (case type - #.None - (check@wrap Any) - - (#.Some type) - (jvm-type mapping type))) - (def: primitive (Parser Primitive) ($_ p.or - (s.identifier! ["" "boolean"]) - (s.identifier! ["" "byte"]) - (s.identifier! ["" "short"]) - (s.identifier! ["" "int"]) - (s.identifier! ["" "long"]) - (s.identifier! ["" "float"]) - (s.identifier! ["" "double"]) - (s.identifier! ["" "char"]) + (s.identifier! ["" jvm.boolean-reflection]) + (s.identifier! ["" jvm.byte-reflection]) + (s.identifier! ["" jvm.short-reflection]) + (s.identifier! ["" jvm.int-reflection]) + (s.identifier! ["" jvm.long-reflection]) + (s.identifier! ["" jvm.float-reflection]) + (s.identifier! ["" jvm.double-reflection]) + (s.identifier! ["" jvm.char-reflection]) )) (def: type @@ -1595,7 +1671,7 @@ (def: return (Parser Return) - (p.or (s.identifier! ["" "void"]) + (p.or (s.identifier! ["" jvm.void-reflection]) ..type)) (type: #export (Overriden-Method a) @@ -1677,14 +1753,14 @@ (case type (#jvm.Primitive primitive) (case primitive - #jvm.Boolean (/////analysis.constant ["" "boolean"]) - #jvm.Byte (/////analysis.constant ["" "byte"]) - #jvm.Short (/////analysis.constant ["" "short"]) - #jvm.Int (/////analysis.constant ["" "int"]) - #jvm.Long (/////analysis.constant ["" "long"]) - #jvm.Float (/////analysis.constant ["" "float"]) - #jvm.Double (/////analysis.constant ["" "double"]) - #jvm.Char (/////analysis.constant ["" "char"])) + #jvm.Boolean (/////analysis.constant ["" jvm.boolean-reflection]) + #jvm.Byte (/////analysis.constant ["" jvm.byte-reflection]) + #jvm.Short (/////analysis.constant ["" jvm.short-reflection]) + #jvm.Int (/////analysis.constant ["" jvm.int-reflection]) + #jvm.Long (/////analysis.constant ["" jvm.long-reflection]) + #jvm.Float (/////analysis.constant ["" jvm.float-reflection]) + #jvm.Double (/////analysis.constant ["" jvm.double-reflection]) + #jvm.Char (/////analysis.constant ["" jvm.char-reflection])) (#jvm.Generic generic) (generic-analysis generic) @@ -1696,7 +1772,7 @@ (-> Return Analysis) (case return #.None - (/////analysis.constant ["" "void"]) + (/////analysis.constant ["" jvm.void-descriptor]) (#.Some type) (type-analysis type))) |