From 4248cc22881a7eaa8f74bc426f2b0ba284b23153 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 23 Jul 2021 01:05:41 -0400 Subject: Automatically handling input/output conversions for methods in new JVM compiler. --- lux-jvm/source/luxc/lang/directive/jvm.lux | 113 ++++++----- .../luxc/lang/translation/jvm/extension/host.lux | 222 ++++++++++++++------- lux-jvm/source/program.lux | 2 +- stdlib/source/library/lux/target/jvm/type/lux.lux | 63 +++++- .../language/lux/phase/extension/analysis/jvm.lux | 92 ++++++--- stdlib/source/test/lux.lux | 79 ++++++-- stdlib/source/test/lux/ffi.jvm.lux | 56 +++++- 7 files changed, 448 insertions(+), 179 deletions(-) diff --git a/lux-jvm/source/luxc/lang/directive/jvm.lux b/lux-jvm/source/luxc/lang/directive/jvm.lux index 841f31b92..fe3889c38 100644 --- a/lux-jvm/source/luxc/lang/directive/jvm.lux +++ b/lux-jvm/source/luxc/lang/directive/jvm.lux @@ -17,6 +17,7 @@ [text ["%" format (#+ format)]] [collection + [array (#+ Array)] ["." list ("#\." fold functor monoid)] ["." dictionary (#+ Dictionary)] ["." row (#+ Row) ("#\." functor fold)]]] @@ -28,7 +29,7 @@ [encoding ["." name (#+ External)]] ["#." type (#+ Type Constraint) - [category (#+ Void Value Return Primitive Object Class Array Var Parameter)] + [category (#+ Void Value Return Primitive Object Class Var Parameter)] ["." parser] [".T" lux] ["#/." signature] @@ -1026,9 +1027,9 @@ arguments' (monad.map ! (function (_ [name type]) (\ ! map (|>> [name]) - (//A.reflection_type mapping type))) + (//A.boxed_reflection_type mapping type))) arguments) - returnT (//A.reflection_return mapping /type.void) + returnT (//A.boxed_reflection_return mapping /type.void) [_scope bodyA] (|> arguments' (#.Cons [self selfT]) list.reverse @@ -1056,9 +1057,9 @@ arguments' (monad.map ! (function (_ [name type]) (\ ! map (|>> [name]) - (//A.reflection_type mapping type))) + (//A.boxed_reflection_type mapping type))) arguments) - returnT (//A.reflection_return mapping returnJ) + returnT (//A.boxed_reflection_return mapping returnJ) [_scope bodyA] (|> arguments' (#.Cons [self selfT]) list.reverse @@ -1084,9 +1085,9 @@ arguments' (monad.map ! (function (_ [name type]) (\ ! map (|>> [name]) - (//A.reflection_type mapping type))) + (//A.boxed_reflection_type mapping type))) arguments) - returnT (//A.reflection_return mapping returnJ) + returnT (//A.boxed_reflection_return mapping returnJ) [_scope bodyA] (|> arguments' (#.Cons [self selfT]) list.reverse @@ -1110,9 +1111,9 @@ arguments' (monad.map ! (function (_ [name type]) (\ ! map (|>> [name]) - (//A.reflection_type mapping type))) + (//A.boxed_reflection_type mapping type))) arguments) - returnT (//A.reflection_return mapping returnJ) + returnT (//A.boxed_reflection_return mapping returnJ) [_scope bodyA] (|> arguments' list.reverse (list\fold scopeA.with_local (analyse archive bodyC)) @@ -1165,11 +1166,7 @@ (\ ! map (|>> [typeJ]) (synthesise archive termA))) constructor_argumentsA) - bodyS (synthesise archive - (list\fold (function (_ _) - (|>> (#analysis.Function (list)))) - (analysis.tuple (list (analysis.unit) bodyA)) - (list.repeat (|> arguments list.size (nat.max 1)) [])))] + bodyS (synthesise archive (#analysis.Function (list) (//A.hide_method_body (list.size arguments) bodyA)))] (wrap [privacy strict_floating_point? annotations method_tvars exceptions self arguments constructor_argumentsS (case bodyS @@ -1188,11 +1185,7 @@ synthesise directive.synthesis] (directive.lift_synthesis (do ! - [bodyS (synthesise archive - (list\fold (function (_ _) - (|>> (#analysis.Function (list)))) - (analysis.tuple (list (analysis.unit) bodyA)) - (list.repeat (|> arguments list.size (nat.max 1)) [])))] + [bodyS (synthesise archive (#analysis.Function (list) (//A.hide_method_body (list.size arguments) bodyA)))] (wrap [[super_name super_tvars] method_name strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ (case bodyS @@ -1211,11 +1204,7 @@ synthesise directive.synthesis] (directive.lift_synthesis (do ! - [bodyS (synthesise archive - (list\fold (function (_ _) - (|>> (#analysis.Function (list)))) - (analysis.tuple (list (analysis.unit) bodyA)) - (list.repeat (|> arguments list.size (nat.max 1)) [])))] + [bodyS (synthesise archive (#analysis.Function (list) (//A.hide_method_body (list.size arguments) bodyA)))] (wrap [name privacy final? strict_floating_point? annotations method_tvars self arguments returnJ exceptionsJ (case bodyS @@ -1234,11 +1223,7 @@ synthesise directive.synthesis] (directive.lift_synthesis (do ! - [bodyS (synthesise archive - (list\fold (function (_ _) - (|>> (#analysis.Function (list)))) - (analysis.tuple (list (analysis.unit) bodyA)) - (list.repeat (|> arguments list.size (nat.max 1)) [])))] + [bodyS (synthesise archive (#analysis.Function (list) (//A.hide_method_body (list.size arguments) bodyA)))] (wrap [name privacy strict_floating_point? annotations method_tvars arguments returnJ exceptionsJ (case bodyS @@ -1282,22 +1267,26 @@ (do ! [constructor_argumentsG (monad.map ! (|>> product.right (generate archive)) constructor_argumentsS) - bodyG (generate archive bodyS) + bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) #let [[super_name super_vars] (parser.read_class super_class) super_constructor_argument_values (_.fuse constructor_argumentsG) super_constructorT (/type.method [(list) (list\map product.left constructor_argumentsS) /type.void - (list)])]] + (list)]) + argumentsT (list\map product.right arguments) + initialize_object! (: Inst + (|>> (_.ALOAD 0) + super_constructor_argument_values + (_.INVOKESPECIAL super_class ..constructor_name super_constructorT)))]] (wrap (def.method (..visibility privacy) (if strict_floating_point? jvm.strictM jvm.noneM) ..constructor_name - (/type.method [method_tvars (list\map product.right arguments) /type.void exceptions]) - (|>> (_.ALOAD 0) - super_constructor_argument_values - (_.INVOKESPECIAL super_class ..constructor_name super_constructorT) + (/type.method [method_tvars argumentsT /type.void exceptions]) + (|>> initialize_object! + (//G.prepare_arguments 1 argumentsT) bodyG _.RETURN))))))) @@ -1310,14 +1299,16 @@ generate directive.generation] (directive.lift_generation (do ! - [bodyG (generate archive bodyS)] + [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) + #let [argumentsT (list\map product.right arguments)]] (wrap (def.method #jvm.Public (if strict_floating_point? jvm.strictM jvm.noneM) method_name - (/type.method [method_tvars (list\map product.right arguments) returnJ exceptionsJ]) - (|>> bodyG + (/type.method [method_tvars argumentsT returnJ exceptionsJ]) + (|>> (//G.prepare_arguments 1 argumentsT) + bodyG (//G.returnI returnJ)))))))) (def: (virtual_method_generation archive method) @@ -1329,7 +1320,8 @@ generate directive.generation] (directive.lift_generation (do ! - [bodyG (generate archive bodyS)] + [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) + #let [argumentsT (list\map product.right arguments)]] (wrap (def.method (..visibility privacy) (|> jvm.noneM (jvm.++M (if strict_floating_point? @@ -1339,8 +1331,9 @@ jvm.finalM jvm.noneM))) method_name - (/type.method [method_tvars (list\map product.right arguments) returnJ exceptionsJ]) - (|>> bodyG + (/type.method [method_tvars argumentsT returnJ exceptionsJ]) + (|>> (//G.prepare_arguments 1 argumentsT) + bodyG (//G.returnI returnJ)))))))) (def: (static_method_generation archive method) @@ -1352,15 +1345,17 @@ generate directive.generation] (directive.lift_generation (do ! - [bodyG (generate archive bodyS)] + [bodyG (generate archive (//G.hidden_method_body (list.size arguments) bodyS)) + #let [argumentsT (list\map product.right arguments)]] (wrap (def.method (..visibility privacy) (|> jvm.staticM (jvm.++M (if strict_floating_point? jvm.strictM jvm.noneM))) method_name - (/type.method [method_tvars (list\map product.right arguments) returnJ exceptionsJ]) - (|>> bodyG + (/type.method [method_tvars argumentsT returnJ exceptionsJ]) + (|>> (//G.prepare_arguments 0 argumentsT) + bodyG (//G.returnI returnJ)))))))) (def: (method_generation archive super_class method) @@ -1382,8 +1377,24 @@ (\ phase.monad wrap (..abstract_method_generation method)) )) -(def: jvm::class - ..Handler +(import: java/lang/ClassLoader) + +(def: (convert_overriden_method method) + (-> (Method Code) (Maybe (//A.Overriden_Method Code))) + (case method + (#Override [[parent_name parent_variables] method_name strict_floating_point? annotations variables + self arguments return exceptions + body]) + (#.Some [(/type.class parent_name parent_variables) method_name + strict_floating_point? (list) variables + self arguments return exceptions + body]) + + _ + #.None)) + +(def: (jvm::class class_loader) + (-> java/lang/ClassLoader ..Handler) (..custom [($_ <>.and ..class_declaration @@ -1414,6 +1425,10 @@ (generation.execute! header)) #let [supers (: (List (Type Class)) (list& super_class super_interfaces))] + _ (|> methodsC + (list.all ..convert_overriden_method) + (//A.require_complete_method_concretion class_loader supers) + directive.lift_analysis) methodsA (monad.map ! (method_analysis archive declaration supers) methodsC) methodsS (monad.map ! (method_synthesis archive) methodsA) methodsG (monad.map ! (method_generation archive super_class) methodsS) @@ -1459,9 +1474,9 @@ _ (generation.log! (format "JVM Interface " (%.text class_name)))] (wrap directive.no_requirements)))))])) -(def: #export (bundle extender) - (-> jvm.Extender (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition)) +(def: #export (bundle class_loader extender) + (-> java/lang/ClassLoader jvm.Extender (directive.Bundle jvm.Anchor jvm.Inst jvm.Definition)) (|> bundle.empty (dictionary.put "lux def generation" (..def::generation extender)) - (dictionary.put "jvm class" ..jvm::class) + (dictionary.put "jvm class" (..jvm::class class_loader)) (dictionary.put "jvm class interface" ..jvm::class::interface))) diff --git a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux index e647bf71b..89c7053f9 100644 --- a/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux +++ b/lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux @@ -7,21 +7,23 @@ [control ["." exception (#+ exception:)] ["." function] - ["<>" parser ("#@." monad) + ["<>" parser ("#\." monad) ["<.>" text] ["<.>" synthesis (#+ Parser)]]] [data ["." product] - ["." maybe ("#@." functor)] - ["." text ("#@." equivalence) + ["." maybe ("#\." functor)] + ["." text ("#\." equivalence) ["%" format (#+ format)]] [collection - ["." list ("#@." monad)] + ["." list ("#\." monad fold)] ["." dictionary (#+ Dictionary)] ["." set]]] + [macro + ["." template]] [math [number - ["." nat]]] + ["n" nat]]] [target [jvm ["." type (#+ Type Typed Argument) @@ -33,9 +35,9 @@ ["." parser]]]] [tool [compiler - ["." phase ("#@." monad)] + ["." phase ("#\." monad)] [reference (#+) - ["." variable (#+ Variable)]] + ["." variable (#+ Variable Register)]] [meta [archive (#+ Archive)]] [language @@ -568,15 +570,15 @@ (do phase.monad [valueI (generate archive valueS)] (`` (cond (~~ (template [ ] - [(and (text@= (reflection.reflection (type.reflection )) + [(and (text\= (reflection.reflection (type.reflection )) from) - (text@= + (text\= to)) (wrap (|>> valueI (_.wrap ))) - (and (text@= + (and (text\= from) - (text@= (reflection.reflection (type.reflection )) + (text\= (reflection.reflection (type.reflection )) to)) (wrap (|>> valueI (_.unwrap )))] @@ -731,10 +733,10 @@ (..custom [($_ <>.and ..class .text ..return (<>.some ..input)) (function (_ extension_name generate archive [class method outputT inputsTS]) - (do {@ phase.monad} - [inputsTI (monad.map @ (generate_input generate archive) inputsTS)] - (wrap (|>> (_.fuse (list@map product.right inputsTI)) - (_.INVOKESTATIC class method (type.method [(list) (list@map product.left inputsTI) outputT (list)])) + (do {! phase.monad} + [inputsTI (monad.map ! (generate_input generate archive) inputsTS)] + (wrap (|>> (_.fuse (list\map product.right inputsTI)) + (_.INVOKESTATIC class method (type.method [(list) (list\map product.left inputsTI) outputT (list)])) (prepare_output outputT)))))])) (template [ ] @@ -743,15 +745,15 @@ (..custom [($_ <>.and ..class .text ..return .any (<>.some ..input)) (function (_ extension_name generate archive [class method outputT objectS inputsTS]) - (do {@ phase.monad} + (do {! phase.monad} [objectI (generate archive objectS) - inputsTI (monad.map @ (generate_input generate archive) inputsTS)] + inputsTI (monad.map ! (generate_input generate archive) inputsTS)] (wrap (|>> objectI (_.CHECKCAST class) - (_.fuse (list@map product.right inputsTI)) + (_.fuse (list\map product.right inputsTI)) ( class method (type.method [(list) - (list@map product.left inputsTI) + (list\map product.left inputsTI) outputT (list)])) (prepare_output outputT)))))]))] @@ -766,12 +768,12 @@ (..custom [($_ <>.and ..class (<>.some ..input)) (function (_ extension_name generate archive [class inputsTS]) - (do {@ phase.monad} - [inputsTI (monad.map @ (generate_input generate archive) inputsTS)] + (do {! phase.monad} + [inputsTI (monad.map ! (generate_input generate archive) inputsTS)] (wrap (|>> (_.NEW class) _.DUP - (_.fuse (list@map product.right inputsTI)) - (_.INVOKESPECIAL class "" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))))))])) + (_.fuse (list\map product.right inputsTI)) + (_.INVOKESPECIAL class "" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))))))])) (def: member_bundle Bundle @@ -806,6 +808,37 @@ (Parser Argument) (.tuple (<>.and .text ..value))) +(def: #export (hidden_method_body arity body) + (-> Nat Synthesis Synthesis) + (case [arity body] + [0 _] body + [1 _] body + + [2 (#synthesis.Control (#synthesis.Branch (#synthesis.Let _ 2 hidden)))] + hidden + + [_ (#synthesis.Control (#synthesis.Branch (#synthesis.Case _ path)))] + (loop [path path] + (case path + (^or #synthesis.Pop + (#synthesis.Access _) + (#synthesis.Bind _) + (#synthesis.Bit_Fork _) + (#synthesis.I64_Fork _) + (#synthesis.F64_Fork _) + (#synthesis.Text_Fork _) + (#synthesis.Alt _)) + body + + (#synthesis.Seq _ next) + (recur next) + + (#synthesis.Then hidden) + hidden)) + + _ + body)) + (def: overriden_method_definition (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)]) (.tuple @@ -820,14 +853,16 @@ arguments (.tuple (<>.some ..argument)) returnT ..return exceptionsT (.tuple (<>.some ..class)) - [environment _ _ body] (.function 1 - (.loop (<>.exactly 0 .any) - (.tuple .any)))] + [environment _ _ body] (<| (.function 1) + (.loop (<>.exactly 0 .any)) + .tuple + (<>.after .any) + .any)] (wrap [environment [ownerT name strict_fp? annotations vars self_name arguments returnT exceptionsT - body]])))) + (..hidden_method_body (list.size arguments) body)]])))) (def: (normalize_path normalize) (-> (-> Synthesis Synthesis) @@ -851,12 +886,12 @@ [#synthesis.Access]) (#synthesis.Bit_Fork when then else) - (#synthesis.Bit_Fork when (recur then) (maybe@map recur else)) + (#synthesis.Bit_Fork when (recur then) (maybe\map recur else)) (^template [] [( [[test then] elses]) ( [[test (recur then)] - (list@map (function (_ [else_test else_then]) + (list\map (function (_ [else_test else_then]) [else_test (recur else_then)]) elses)])]) ([#synthesis.I64_Fork] @@ -878,7 +913,7 @@ (synthesis.variant [lefts right? (recur sub)]) (^ (synthesis.tuple members)) - (synthesis.tuple (list@map recur members)) + (synthesis.tuple (list\map recur members)) (^ (synthesis.variable var)) (|> mapping @@ -899,13 +934,13 @@ (synthesis.branch/get [path (recur recordS)]) (^ (synthesis.loop/scope [offset initsS+ bodyS])) - (synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)]) + (synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)]) (^ (synthesis.loop/recur updatesS+)) - (synthesis.loop/recur (list@map recur updatesS+)) + (synthesis.loop/recur (list\map recur updatesS+)) (^ (synthesis.function/abstraction [environment arity bodyS])) - (synthesis.function/abstraction [(list@map (function (_ captured) + (synthesis.function/abstraction [(list\map (function (_ captured) (case captured (^ (synthesis.variable var)) (|> mapping @@ -920,10 +955,10 @@ bodyS]) (^ (synthesis.function/apply [functionS inputsS+])) - (synthesis.function/apply [(recur functionS) (list@map recur inputsS+)]) + (synthesis.function/apply [(recur functionS) (list\map recur inputsS+)]) (#synthesis.Extension [name inputsS+]) - (#synthesis.Extension [name (list@map recur inputsS+)])))) + (#synthesis.Extension [name (list\map recur inputsS+)])))) (def: $Object (type.class "java.lang.Object" (list))) @@ -940,27 +975,68 @@ (let [store_capturedI (|> env list.size list.indices - (list@map (.function (_ register) + (list\map (.function (_ register) (|>> (_.ALOAD 0) (_.ALOAD (inc register)) (_.PUTFIELD class (///reference.foreign_name register) $Object)))) _.fuse)] (_def.method #$.Public $.noneM "" (anonymous_init_method env) (|>> (_.ALOAD 0) - ((_.fuse (list@map product.right inputsTI))) - (_.INVOKESPECIAL super_class "" (type.method [(list) (list@map product.left inputsTI) type.void (list)])) + ((_.fuse (list\map product.right inputsTI))) + (_.INVOKESPECIAL super_class "" (type.method [(list) (list\map product.left inputsTI) type.void (list)])) store_capturedI _.RETURN)))) (def: (anonymous_instance generate archive class env) (-> Phase Archive (Type Class) (Environment Synthesis) (Operation Inst)) - (do {@ phase.monad} - [captureI+ (monad.map @ (generate archive) env)] + (do {! phase.monad} + [captureI+ (monad.map ! (generate archive) env)] (wrap (|>> (_.NEW class) _.DUP (_.fuse captureI+) (_.INVOKESPECIAL class "" (anonymous_init_method env)))))) +(def: (prepare_argument lux_register argumentT jvm_register) + (-> Register (Type Value) Register [Register Inst]) + (case (type.primitive? argumentT) + (#.Left argumentT) + [(n.+ 1 jvm_register) + (if (n.= lux_register jvm_register) + (|>>) + (|>> (_.ALOAD jvm_register) + (_.ASTORE lux_register)))] + + (#.Right argumentT) + (template.let [(wrap_primitive ) + [[(n.+ jvm_register) + (|>> ( jvm_register) + (_.wrap ) + (_.ASTORE lux_register))]]] + (`` (cond (~~ (template [ ] + [(\ type.equivalence = argumentT) + (wrap_primitive )] + + [1 _.ILOAD type.boolean] + [1 _.ILOAD type.byte] + [1 _.ILOAD type.short] + [1 _.ILOAD type.int] + [1 _.ILOAD type.char] + [1 _.FLOAD type.float] + [2 _.LLOAD type.long])) + + ## (\ type.equivalence = type.double argumentT) + (wrap_primitive 2 _.DLOAD type.double)))))) + +(def: #export (prepare_arguments offset types) + (-> Nat (List (Type Value)) Inst) + (|> types + list.enumeration + (list\fold (function (_ [lux_register type] [jvm_register before]) + (let [[jvm_register' after] (prepare_argument (n.+ offset lux_register) type jvm_register)] + [jvm_register' (|>> before after)])) + (: [Register Inst] [offset (|>>)])) + product.right)) + (def: #export (returnI returnT) (-> (Type Return) Inst) (case (type.void? returnT) @@ -979,21 +1055,23 @@ _.ARETURN) (#.Right returnT) - (cond (or (\ type.equivalence = type.boolean returnT) - (\ type.equivalence = type.byte returnT) - (\ type.equivalence = type.short returnT) - (\ type.equivalence = type.int returnT) - (\ type.equivalence = type.char returnT)) - _.IRETURN - - (\ type.equivalence = type.long returnT) - _.LRETURN - - (\ type.equivalence = type.float returnT) - _.FRETURN - - ## (\ type.equivalence = type.double returnT) - _.DRETURN)))) + (template.let [(unwrap_primitive ) + [(|>> (_.unwrap ) + )]] + (`` (cond (~~ (template [ ] + [(\ type.equivalence = returnT) + (unwrap_primitive )] + + [_.IRETURN type.boolean] + [_.IRETURN type.byte] + [_.IRETURN type.short] + [_.IRETURN type.int] + [_.IRETURN type.char] + [_.FRETURN type.float] + [_.LRETURN type.long])) + + ## (\ type.equivalence = type.double returnT) + (unwrap_primitive _.DRETURN type.double))))))) (def: class::anonymous Handler @@ -1007,33 +1085,33 @@ super_interfaces inputsTS overriden_methods]) - (do {@ phase.monad} + (do {! phase.monad} [[context _] (generation.with_new_context archive (wrap [])) #let [[module_id artifact_id] context anonymous_class_name (///.class_name context) class (type.class anonymous_class_name (list)) total_environment (|> overriden_methods ## Get all the environments. - (list@map product.left) + (list\map product.left) ## Combine them. - list@join + list\join ## Remove duplicates. (set.from_list synthesis.hash) set.to_list) global_mapping (|> total_environment ## Give them names as "foreign" variables. list.enumeration - (list@map (function (_ [id capture]) + (list\map (function (_ [id capture]) [capture (#variable.Foreign id)])) (dictionary.from_list synthesis.hash)) - normalized_methods (list@map (function (_ [environment + normalized_methods (list\map (function (_ [environment [ownerT name strict_fp? annotations vars self_name arguments returnT exceptionsT body]]) (let [local_mapping (|> environment list.enumeration - (list@map (function (_ [foreign_id capture]) + (list\map (function (_ [foreign_id capture]) [(synthesis.variable/foreign foreign_id) (|> global_mapping (dictionary.get capture) @@ -1044,26 +1122,26 @@ self_name arguments returnT exceptionsT (normalize_method_body local_mapping body)])) overriden_methods)] - inputsTI (monad.map @ (generate_input generate archive) inputsTS) + inputsTI (monad.map ! (generate_input generate archive) inputsTS) method_definitions (|> normalized_methods - (monad.map @ (function (_ [ownerT name - strict_fp? annotations vars + (monad.map ! (function (_ [ownerT name + strict_fp? annotations varsT self_name arguments returnT exceptionsT bodyS]) - (do @ + (do ! [bodyG (generation.with_context artifact_id - (generate archive bodyS))] + (generate archive bodyS)) + #let [argumentsT (list\map product.right arguments)]] (wrap (_def.method #$.Public (if strict_fp? ($_ $.++M $.finalM $.strictM) $.finalM) name - (type.method [vars - (list@map product.right arguments) - returnT - exceptionsT]) - (|>> bodyG (returnI returnT))))))) - (\ @ map _def.fuse)) + (type.method [varsT argumentsT returnT exceptionsT]) + (|>> (prepare_arguments 1 argumentsT) + bodyG + (returnI returnT))))))) + (\ ! map _def.fuse)) #let [directive [anonymous_class_name (_def.class #$.V1_6 #$.Public $.finalC anonymous_class_name (list) diff --git a/lux-jvm/source/program.lux b/lux-jvm/source/program.lux index 13979573d..fa0e19109 100644 --- a/lux-jvm/source/program.lux +++ b/lux-jvm/source/program.lux @@ -292,7 +292,7 @@ (io.io platform) ## generation.bundle translation.bundle - (|>> ..extender directive.bundle) + (|>> ..extender (directive.bundle loader)) (jvm/program.program jvm/runtime.class_name) [_.Anchor _.Inst _.Definition] ..extender diff --git a/stdlib/source/library/lux/target/jvm/type/lux.lux b/stdlib/source/library/lux/target/jvm/type/lux.lux index 45fd34c8d..b4abe4093 100644 --- a/stdlib/source/library/lux/target/jvm/type/lux.lux +++ b/stdlib/source/library/lux/target/jvm/type/lux.lux @@ -7,7 +7,7 @@ ["." try] ["." exception (#+ exception:)] ["<>" parser ("#\." monad) - ["" text (#+ Parser)]]] + ["<.>" text (#+ Parser)]]] [data ["." product] ["." text ("#\." equivalence) @@ -24,6 +24,7 @@ ["#." signature] ["#." reflection] ["#." parser] + ["#." box] ["/#" // #_ [encoding ["#." name]]]]) @@ -66,6 +67,22 @@ [char //parser.char //reflection.char] ) +(template [ ] + [(def: + (Parser (Check Type)) + (<>.after + (<>\wrap (check\wrap (#.Primitive #.Nil)))))] + + [boxed_boolean //parser.boolean //box.boolean] + [boxed_byte //parser.byte //box.byte] + [boxed_short //parser.short //box.short] + [boxed_int //parser.int //box.int] + [boxed_long //parser.long //box.long] + [boxed_float //parser.float //box.float] + [boxed_double //parser.double //box.double] + [boxed_char //parser.char //box.char] + ) + (def: primitive (Parser (Check Type)) ($_ <>.either @@ -79,6 +96,19 @@ ..char )) +(def: boxed_primitive + (Parser (Check Type)) + ($_ <>.either + ..boxed_boolean + ..boxed_byte + ..boxed_short + ..boxed_int + ..boxed_long + ..boxed_float + ..boxed_double + ..boxed_char + )) + (def: wildcard (Parser (Check Type)) (<>.after //parser.wildcard @@ -101,19 +131,19 @@ (|> (do <>.monad [name //parser.class_name parameters (|> (<>.some parameter) - (<>.after (.this //signature.parameters_start)) - (<>.before (.this //signature.parameters_end)) + (<>.after (.this //signature.parameters_start)) + (<>.before (.this //signature.parameters_end)) (<>.default (list)))] (wrap (do {! check.monad} [parameters (monad.seq ! parameters)] (wrap (#.Primitive name parameters))))) - (<>.after (.this //descriptor.class_prefix)) - (<>.before (.this //descriptor.class_suffix)))) + (<>.after (.this //descriptor.class_prefix)) + (<>.before (.this //descriptor.class_suffix)))) (template [ ] [(def: (-> (Parser (Check Type)) (Parser (Check Type))) - (|> (<>.after (.this )) + (|> (<>.after (.this )) ## TODO: Re-enable Lower and Upper, instead of using the simplified limit. ## (<>\map (check\map (|>> .type))) ))] @@ -160,7 +190,7 @@ _ (|> elementT array.Array .type))))) - (<>.after (.this //descriptor.array_prefix)))) + (<>.after (.this //descriptor.array_prefix)))) (def: #export (type mapping) (-> Mapping (Parser (Check Type))) @@ -172,6 +202,16 @@ (..array type) )))) +(def: #export (boxed_type mapping) + (-> Mapping (Parser (Check Type))) + (<>.rec + (function (_ type) + ($_ <>.either + ..boxed_primitive + (parameter mapping) + (..array type) + )))) + (def: #export (return mapping) (-> Mapping (Parser (Check Type))) ($_ <>.either @@ -179,9 +219,16 @@ (..type mapping) )) +(def: #export (boxed_return mapping) + (-> Mapping (Parser (Check Type))) + ($_ <>.either + ..void + (..boxed_type mapping) + )) + (def: #export (check operation input) (All [a] (-> (Parser (Check a)) Text (Check a))) - (case (.run operation input) + (case (.run operation input) (#try.Success check) check diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux index 66f7271db..e5af044c3 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -853,7 +853,9 @@ (#try.Failure error) (phase.fail error)))] + [boxed_reflection_type Value luxT.boxed_type] [reflection_type Value luxT.type] + [boxed_reflection_return Return luxT.boxed_return] [reflection_return Return luxT.return] ) @@ -1679,7 +1681,7 @@ arguments' (monad.map ! (function (_ [name jvmT]) (do ! - [luxT (reflection_type mapping jvmT)] + [luxT (boxed_reflection_type mapping jvmT)] (wrap [name luxT]))) arguments) [scope bodyA] (|> arguments' @@ -1755,7 +1757,7 @@ arguments' (monad.map ! (function (_ [name jvmT]) (do ! - [luxT (reflection_type mapping jvmT)] + [luxT (boxed_reflection_type mapping jvmT)] (wrap [name luxT]))) arguments) [scope bodyA] (|> arguments' @@ -1829,7 +1831,7 @@ arguments' (monad.map ! (function (_ [name jvmT]) (do ! - [luxT (reflection_type mapping jvmT)] + [luxT (boxed_reflection_type mapping jvmT)] (wrap [name luxT]))) arguments) [scope bodyA] (|> arguments' @@ -1944,6 +1946,35 @@ mapping override_mapping)))) +(def: #export (hide_method_body arity bodyA) + (-> Nat Analysis Analysis) + (<| /////analysis.tuple + (list (/////analysis.unit)) + (case arity + (^or 0 1) + bodyA + + 2 + (#/////analysis.Case (/////analysis.unit) + [{#/////analysis.when + (#/////analysis.Bind 2) + + #/////analysis.then + bodyA} + (list)]) + + _ + (#/////analysis.Case (/////analysis.unit) + [{#/////analysis.when + (#/////analysis.Complex + (#/////analysis.Tuple (|> arity + list.indices + (list\map (|>> (n.+ 2) #/////analysis.Bind))))) + + #/////analysis.then + bodyA} + (list)])))) + (def: #export (analyse_overriden_method analyse archive selfT mapping supers method) (-> Phase Archive .Type Mapping (List (Type Class)) (Overriden_Method Code) (Operation Analysis)) (let [[parent_type method_name @@ -1965,10 +1996,10 @@ arguments' (monad.map ! (function (_ [name jvmT]) (do ! - [luxT (reflection_type mapping jvmT)] + [luxT (boxed_reflection_type mapping jvmT)] (wrap [name luxT]))) arguments) - returnT (reflection_return mapping return) + returnT (boxed_reflection_return mapping return) [scope bodyA] (|> arguments' (#.Cons [self_name selfT]) list.reverse @@ -1989,7 +2020,7 @@ (#/////analysis.Function (list\map (|>> /////analysis.variable) (scope.environment scope)) - (/////analysis.tuple (list bodyA))) + (..hide_method_body (list.size arguments) bodyA)) )))))) (type: #export (Method_Definition a) @@ -2052,6 +2083,31 @@ local (format "anonymous-class" (%.nat id))] (format global ..jvm_package_separator local))) +(def: #export (require_complete_method_concretion class_loader supers methods) + (-> java/lang/ClassLoader (List (Type Class)) (List (Overriden_Method Code)) (Operation Any)) + (do {! phase.monad} + [required_abstract_methods (phase.lift (all_abstract_methods class_loader supers)) + available_methods (phase.lift (all_methods class_loader supers)) + overriden_methods (monad.map ! (function (_ [parent_type method_name + strict_fp? annotations type_vars + self_name arguments return exceptions + body]) + (do ! + [aliasing (super_aliasing class_loader parent_type)] + (wrap [method_name (|> (jvm.method [type_vars + (list\map product.right arguments) + return + exceptions]) + (jvm_alias.method aliasing))]))) + methods) + #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) + invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] + _ (phase.assert ..missing_abstract_methods missing_abstract_methods + (list.empty? missing_abstract_methods)) + _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods + (list.empty? invalid_overriden_methods))] + (wrap []))) + (def: (class::anonymous class_loader) (-> java/lang/ClassLoader Handler) (..custom @@ -2097,27 +2153,9 @@ (analyse archive term))] (wrap [type termA]))) constructor_args) - methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping (#.Cons super_class super_interfaces)) methods) - required_abstract_methods (phase.lift (all_abstract_methods class_loader (list& super_class super_interfaces))) - available_methods (phase.lift (all_methods class_loader (list& super_class super_interfaces))) - overriden_methods (monad.map ! (function (_ [parent_type method_name - strict_fp? annotations type_vars - self_name arguments return exceptions - body]) - (do ! - [aliasing (super_aliasing class_loader parent_type)] - (wrap [method_name (|> (jvm.method [type_vars - (list\map product.right arguments) - return - exceptions]) - (jvm_alias.method aliasing))]))) - methods) - #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) - invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] - _ (phase.assert ..missing_abstract_methods missing_abstract_methods - (list.empty? missing_abstract_methods)) - _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods - (list.empty? invalid_overriden_methods))] + #let [supers (#.Cons super_class super_interfaces)] + _ (..require_complete_method_concretion class_loader supers methods) + methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping supers) methods)] (wrap (#/////analysis.Extension extension_name (list (class_analysis super_class) (/////analysis.tuple (list\map class_analysis super_interfaces)) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 20d21d74d..fcf33fa79 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -61,22 +61,6 @@ [_ (wrap [])] body))) -(def: identity - Test - (do {! random.monad} - [value random.nat - #let [object (: (Random (Atom Nat)) - (\ ! map atom.atom (wrap value)))] - self object] - ($_ _.and - (_.test "Every value is identical to itself." - (is? self self)) - (do ! - [other object] - (_.test "Values created separately can't be identical." - (not (is? self other)))) - ))) - (def: prelude_macros Test ($_ _.and @@ -739,12 +723,70 @@ dummy)))) ))) +(def: for_value + Test + (do random.monad + [left random.nat + right (random.ascii/lower 1)] + ($_ _.and + (_.cover [/.Either] + (and (exec + (: (/.Either Nat Text) + (#.Left left)) + true) + (exec + (: (/.Either Nat Text) + (#.Right right)) + true))) + (_.cover [/.Any] + (and (exec + (: /.Any + left) + true) + (exec + (: /.Any + right) + true))) + (_.cover [/.Nothing] + (and (exec + (: (-> /.Any /.Nothing) + (function (_ _) + (undefined))) + true) + (exec + (: (-> /.Any /.Int) + (function (_ _) + (: /.Int (undefined)))) + true))) + (_.cover [/.All] + (let [identity (: (/.All [a] (-> a a)) + (|>>))] + (and (exec + (: Nat + (identity left)) + true) + (exec + (: Text + (identity right)) + true)))) + (_.cover [/.Ex] + (let [hide (: (/.Ex [a] (-> Nat a)) + (|>>))] + (exec + (: /.Any + (hide left)) + true))) + (_.cover [/.is?] + (let [not_left (|> left inc dec)] + (and (/.is? left left) + (and (n.= not_left left) + (not (/.is? not_left left)))))) + ))) + (def: test Test (<| (_.covering /._) ($_ _.and - (<| (_.context "Identity.") - ..identity) (<| (_.context "Prelude macros.") ..prelude_macros) @@ -764,6 +806,7 @@ ..for_slot ..for_associative ..for_expansion + ..for_value ..sub_tests ))) diff --git a/stdlib/source/test/lux/ffi.jvm.lux b/stdlib/source/test/lux/ffi.jvm.lux index b0ae4fc0f..1396e1646 100644 --- a/stdlib/source/test/lux/ffi.jvm.lux +++ b/stdlib/source/test/lux/ffi.jvm.lux @@ -247,10 +247,19 @@ ["#::." (actual3 [] a)]) +(/.interface: test/TestInterface4 + ([] actual4 [long long long] long)) + +(/.import: test/TestInterface4 + ["#::." + (actual4 [long long long] long)]) + (def: for_interface Test (do random.monad [expected random.nat + left random.int + right random.int #let [object/0 (/.object [] [test/TestInterface0] [] (test/TestInterface0 @@ -306,12 +315,26 @@ expected))) example/3! (is? (: Any expected) - (: Any (test/TestInterface3::actual3 object/3)))]] + (: Any (test/TestInterface3::actual3 object/3))) + + example/4! + (let [expected (i.+ left right) + object/4 (/.object [] [test/TestInterface4] + [] + (test/TestInterface4 + [] (actual4 self {actual_left long} {actual_right long} {_ long}) + long + (:as java/lang/Long + (i.+ (:as Int actual_left) + (:as Int actual_right)))))] + (i.= expected + (test/TestInterface4::actual4 left right right object/4)))]] (_.cover [/.interface: /.object] (and example/0! example/1! example/2! - example/3!)))) + example/3! + example/4!)))) (/.class: #final test/TestClass0 [test/TestInterface0] ## Fields @@ -425,10 +448,28 @@ ["#::." (new [])]) +(/.class: #final test/TestClass8 [test/TestInterface4] + ## Constructors + (#public [] (new self) [] + []) + ## Methods + (test/TestInterface4 + [] (actual4 self {actual_left long} {actual_right long} {_ long}) + long + (:as java/lang/Long + (i.+ (:as Int actual_left) + (:as Int actual_right))))) + +(/.import: test/TestClass8 + ["#::." + (new [])]) + (def: for_class Test (do random.monad [expected random.nat + left random.int + right random.int #let [object/0 (test/TestClass0::new (.int expected)) example/0! @@ -474,7 +515,13 @@ object/7 (test/TestClass7::new) example/7! (n.= expected - (.nat (test/TestClass6::actual6 (.int expected) object/7)))]] + (.nat (test/TestClass6::actual6 (.int expected) object/7))) + + example/8! + (let [expected (i.+ left right) + object/8 (test/TestClass8::new)] + (i.= expected + (test/TestInterface4::actual4 left right right object/8)))]] (_.cover [/.class: /.import:] (and example/0! example/1! @@ -482,7 +529,8 @@ example/3! example/4! example/5! - example/7!)))) + example/7! + example/8!)))) (def: #export test (<| (_.covering /._) -- cgit v1.2.3