aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lux-jvm/source/luxc/lang/directive/jvm.lux113
-rw-r--r--lux-jvm/source/luxc/lang/translation/jvm/extension/host.lux222
-rw-r--r--lux-jvm/source/program.lux2
-rw-r--r--stdlib/source/library/lux/target/jvm/type/lux.lux63
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux92
-rw-r--r--stdlib/source/test/lux.lux79
-rw-r--r--stdlib/source/test/lux/ffi.jvm.lux56
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 [<object> <primitive>]
- [(and (text@= (reflection.reflection (type.reflection <primitive>))
+ [(and (text\= (reflection.reflection (type.reflection <primitive>))
from)
- (text@= <object>
+ (text\= <object>
to))
(wrap (|>> valueI (_.wrap <primitive>)))
- (and (text@= <object>
+ (and (text\= <object>
from)
- (text@= (reflection.reflection (type.reflection <primitive>))
+ (text\= (reflection.reflection (type.reflection <primitive>))
to))
(wrap (|>> valueI (_.unwrap <primitive>)))]
@@ -731,10 +733,10 @@
(..custom
[($_ <>.and ..class <synthesis>.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 [<name> <invoke>]
@@ -743,15 +745,15 @@
(..custom
[($_ <>.and ..class <synthesis>.text ..return <synthesis>.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))
(<invoke> 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 "<init>" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))))))]))
+ (_.fuse (list\map product.right inputsTI))
+ (_.INVOKESPECIAL class "<init>" (type.method [(list) (list\map product.left inputsTI) type.void (list)]))))))]))
(def: member_bundle
Bundle
@@ -806,6 +808,37 @@
(Parser Argument)
(<synthesis>.tuple (<>.and <synthesis>.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)])
(<synthesis>.tuple
@@ -820,14 +853,16 @@
arguments (<synthesis>.tuple (<>.some ..argument))
returnT ..return
exceptionsT (<synthesis>.tuple (<>.some ..class))
- [environment _ _ body] (<synthesis>.function 1
- (<synthesis>.loop (<>.exactly 0 <synthesis>.any)
- (<synthesis>.tuple <synthesis>.any)))]
+ [environment _ _ body] (<| (<synthesis>.function 1)
+ (<synthesis>.loop (<>.exactly 0 <synthesis>.any))
+ <synthesis>.tuple
+ (<>.after <synthesis>.any)
+ <synthesis>.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 [<tag>]
[(<tag> [[test then] elses])
(<tag> [[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 "<init>" (anonymous_init_method env)
(|>> (_.ALOAD 0)
- ((_.fuse (list@map product.right inputsTI)))
- (_.INVOKESPECIAL super_class "<init>" (type.method [(list) (list@map product.left inputsTI) type.void (list)]))
+ ((_.fuse (list\map product.right inputsTI)))
+ (_.INVOKESPECIAL super_class "<init>" (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 "<init>" (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 <shift> <load> <type>)
+ [[(n.+ <shift> jvm_register)
+ (|>> (<load> jvm_register)
+ (_.wrap <type>)
+ (_.ASTORE lux_register))]]]
+ (`` (cond (~~ (template [<shift> <load> <type>]
+ [(\ type.equivalence = <type> argumentT)
+ (wrap_primitive <shift> <load> <type>)]
+
+ [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 <return> <type>)
+ [(|>> (_.unwrap <type>)
+ <return>)]]
+ (`` (cond (~~ (template [<return> <type>]
+ [(\ type.equivalence = <type> returnT)
+ (unwrap_primitive <return> <type>)]
+
+ [_.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)
- ["<t>" 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 [<name> <parser> <box>]
+ [(def: <name>
+ (Parser (Check Type))
+ (<>.after <parser>
+ (<>\wrap (check\wrap (#.Primitive <box> #.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 (<t>.this //signature.parameters_start))
- (<>.before (<t>.this //signature.parameters_end))
+ (<>.after (<text>.this //signature.parameters_start))
+ (<>.before (<text>.this //signature.parameters_end))
(<>.default (list)))]
(wrap (do {! check.monad}
[parameters (monad.seq ! parameters)]
(wrap (#.Primitive name parameters)))))
- (<>.after (<t>.this //descriptor.class_prefix))
- (<>.before (<t>.this //descriptor.class_suffix))))
+ (<>.after (<text>.this //descriptor.class_prefix))
+ (<>.before (<text>.this //descriptor.class_suffix))))
(template [<name> <prefix> <constructor>]
[(def: <name>
(-> (Parser (Check Type)) (Parser (Check Type)))
- (|> (<>.after (<t>.this <prefix>))
+ (|> (<>.after (<text>.this <prefix>))
## TODO: Re-enable Lower and Upper, instead of using the simplified limit.
## (<>\map (check\map (|>> <ctor> .type)))
))]
@@ -160,7 +190,7 @@
_
(|> elementT array.Array .type)))))
- (<>.after (<t>.this //descriptor.array_prefix))))
+ (<>.after (<text>.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 (<t>.run operation input)
+ (case (<text>.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 /._)
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-24 17:17:21 +0000