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.
---
stdlib/source/library/lux/target/jvm/type/lux.lux | 63 +++++++++++++--
.../language/lux/phase/extension/analysis/jvm.lux | 92 +++++++++++++++-------
2 files changed, 120 insertions(+), 35 deletions(-)
(limited to 'stdlib/source/library')
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))
--
cgit v1.2.3