From 51a5c28b0f9efd514e3fae7c2634fd5e9bd714e2 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 22 Jul 2021 01:16:40 -0400 Subject: New JVM compiler can now compile JVM classes. --- stdlib/source/library/lux/ffi.jvm.lux | 183 +++++++++++---------- stdlib/source/library/lux/ffi.old.lux | 78 ++++----- .../lux/tool/compiler/language/lux/directive.lux | 14 ++ .../language/lux/phase/extension/analysis/jvm.lux | 40 +++-- 4 files changed, 181 insertions(+), 134 deletions(-) (limited to 'stdlib/source/library') diff --git a/stdlib/source/library/lux/ffi.jvm.lux b/stdlib/source/library/lux/ffi.jvm.lux index fbcd39119..c05a2afe2 100644 --- a/stdlib/source/library/lux/ffi.jvm.lux +++ b/stdlib/source/library/lux/ffi.jvm.lux @@ -187,21 +187,21 @@ #ManualPrM #AutoPrM) -(type: Privacy +(type: #export Privacy #PublicP #PrivateP #ProtectedP #DefaultP) -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) +(type: #export State + #VolatileS + #FinalS + #DefaultS) -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) +(type: #export Inheritance + #FinalI + #AbstractI + #DefaultI) (type: Class_Kind #Class @@ -224,7 +224,7 @@ (type: FieldDecl (#ConstantField (Type Value) Code) - (#VariableField StateModifier (Type Value))) + (#VariableField State (Type Value))) (type: MethodDecl {#method_tvars (List (Type Var)) @@ -397,20 +397,24 @@ _ (.this! (code.identifier ["" dotted_name]))] (wrap (get_static_field class_name field_name)))) -(def: (make_get_var_parser class_name field_name) - (-> Text Text (Parser Code)) +(def: (make_get_var_parser class_name field_name self_name) + (-> Text Text Text (Parser Code)) (do <>.monad [#let [dotted_name (format "::" field_name)] _ (.this! (code.identifier ["" dotted_name]))] - (wrap (get_virtual_field class_name field_name (' _jvm_this))))) + (wrap (get_virtual_field class_name field_name (code.local_identifier self_name))))) -(def: (make_put_var_parser class_name field_name) - (-> Text Text (Parser Code)) +(def: (make_put_var_parser class_name field_name self_name) + (-> Text Text Text (Parser Code)) (do <>.monad [#let [dotted_name (format "::" field_name)] [_ _ value] (: (Parser [Any Any Code]) (.form ($_ <>.and (.this! (' :=)) (.this! (code.identifier ["" dotted_name])) .any)))] - (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value)))))) + (wrap (`' ("jvm member put virtual" + (~ (code.text class_name)) + (~ (code.text field_name)) + (~ value) + (~ (code.local_identifier self_name))))))) (def: (pre_walk_replace f input) (-> (-> Code Code) Code Code) @@ -440,15 +444,15 @@ ast )) -(def: (field->parser class_name [[field_name _ _] field]) - (-> Text [Member_Declaration FieldDecl] (Parser Code)) +(def: (field->parser class_name self_name [[field_name _ _] field]) + (-> Text Text [Member_Declaration FieldDecl] (Parser Code)) (case field (#ConstantField _) (make_get_const_parser class_name field_name) (#VariableField _) - (<>.either (make_get_var_parser class_name field_name) - (make_put_var_parser class_name field_name)))) + (<>.either (make_get_var_parser class_name field_name self_name) + (make_put_var_parser class_name field_name self_name)))) (def: (decorate_input [class value]) (-> [(Type Value) Code] Code) @@ -478,15 +482,15 @@ (list\map ..decorate_input)))))))) (template [ ] - [(def: ( class_name method_name arguments) - (-> Text Text (List Argument) (Parser Code)) + [(def: ( class_name method_name arguments self_name) + (-> Text Text (List Argument) Text (Parser Code)) (do <>.monad [#let [dotted_name (format "::" method_name "!")] args (: (Parser (List Code)) (.form (<>.after (.this! (code.identifier ["" dotted_name])) (.tuple (<>.exactly (list.size arguments) .any)))))] (wrap (` ( (~ (code.text class_name)) (~ (code.text method_name)) - (~' _jvm_this) + (~ (code.local_identifier self_name)) (~+ (|> args (list.zip/2 (list\map product.right arguments)) (list\map ..decorate_input))))))))] @@ -503,16 +507,18 @@ (#StaticMethod strict? type_vars args return_type return_expr exs) (make_static_method_parser class_name method_name args) + + (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs) + (make_virtual_method_parser class_name method_name args self_name) - (^or (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs) - (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs)) - (make_special_method_parser class_name method_name args) + (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs) + (make_special_method_parser class_name method_name args self_name) (#AbstractMethod type_vars args return_type exs) - (make_virtual_method_parser class_name method_name args) + (make_virtual_method_parser class_name method_name args "") (#NativeMethod type_vars args return_type exs) - (make_virtual_method_parser class_name method_name args))) + (make_virtual_method_parser class_name method_name args ""))) (def: privacy_modifier^ (Parser Privacy) @@ -524,7 +530,7 @@ (wrap [])))) (def: inheritance_modifier^ - (Parser InheritanceModifier) + (Parser Inheritance) (let [(^open ".") <>.monad] ($_ <>.or (.this! (' #final)) @@ -732,7 +738,7 @@ #method_exs exs}])))) (def: state_modifier^ - (Parser StateModifier) + (Parser State) ($_ <>.or (.this! (' #volatile)) (.this! (' #final)) @@ -1012,11 +1018,11 @@ #DefaultP (code.text "default"))) (def: (inheritance_modifier$ im) - (-> InheritanceModifier Code) + (-> Inheritance Code) (case im - #FinalIM (code.text "final") - #AbstractIM (code.text "abstract") - #DefaultIM (code.text "default"))) + #FinalI (code.text "final") + #AbstractI (code.text "abstract") + #DefaultI (code.text "default"))) (def: (annotation_parameter$ [name value]) (-> Annotation_Parameter Code) @@ -1054,11 +1060,11 @@ (~ (return$ method_output)))))) (def: (state_modifier$ sm) - (-> StateModifier Code) + (-> State Code) (case sm - #VolatileSM (' "volatile") - #FinalSM (' "final") - #DefaultSM (' "default"))) + #VolatileS (' "volatile") + #FinalS (' "final") + #DefaultS (' "default"))) (def: (field_decl$ [[name pm anns] field]) (-> [Member_Declaration FieldDecl] Code) @@ -1087,44 +1093,53 @@ (-> (Typed Code) Code) (` [(~ (value$ class)) (~ term)])) -(def: (method_def$ replacer super_class [[name pm anns] method_def]) - (-> (-> Code Code) (Type Class) [Member_Declaration Method_Definition] Code) +(def: (method_def$ fully_qualified_class_name method_parser super_class fields [[name pm anns] method_def]) + (-> External (Parser Code) (Type Class) (List [Member_Declaration FieldDecl]) [Member_Declaration Method_Definition] Code) (case method_def (#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs) - (` ("init" - (~ (privacy_modifier$ pm)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - (~ (code.text self_name)) - [(~+ (list\map argument$ arguments))] - [(~+ (list\map constructor_arg$ constructor_args))] - (~ (pre_walk_replace replacer body)) - )) + (let [replacer (|> (list\map (field->parser fully_qualified_class_name self_name) fields) + (list\fold <>.either method_parser) + parser->replacer)] + (` ("init" + (~ (privacy_modifier$ pm)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map class$ exs))] + (~ (code.text self_name)) + [(~+ (list\map argument$ arguments))] + [(~+ (list\map constructor_arg$ constructor_args))] + (~ (pre_walk_replace replacer body)) + ))) (#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs) - (` ("virtual" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - (~ (code.bit final?)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - (~ (code.text self_name)) - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)) - [(~+ (list\map class$ exs))] - (~ (pre_walk_replace replacer body)))) + (let [replacer (|> (list\map (field->parser fully_qualified_class_name self_name) fields) + (list\fold <>.either method_parser) + parser->replacer)] + (` ("virtual" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + (~ (code.bit final?)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + (~ (code.text self_name)) + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)) + [(~+ (list\map class$ exs))] + (~ (pre_walk_replace replacer body))))) (#OverridenMethod strict_fp? declaration type_vars self_name arguments return_type body exs) - (let [super_replacer (parser->replacer (.form (do <>.monad + (let [replacer (|> (list\map (field->parser fully_qualified_class_name self_name) fields) + (list\fold <>.either method_parser) + parser->replacer) + super_replacer (parser->replacer (.form (do <>.monad [_ (.this! (' ::super!)) args (.tuple (<>.exactly (list.size arguments) .any))] (wrap (` ("jvm member invoke special" (~ (code.text (product.left (parser.read_class super_class)))) (~ (code.text name)) - (~' _jvm_this) + (~ (code.local_identifier self_name)) (~+ (|> args (list.zip/2 (list\map product.right arguments)) (list\map ..decorate_input)))))))))] @@ -1144,16 +1159,17 @@ ))) (#StaticMethod strict_fp? type_vars arguments return_type body exs) - (` ("static" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)) - (~ (pre_walk_replace replacer body)))) + (let [replacer (parser->replacer (<>.fail ""))] + (` ("static" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)) + [(~+ (list\map class$ exs))] + (~ (pre_walk_replace replacer body))))) (#AbstractMethod type_vars arguments return_type exs) (` ("abstract" @@ -1161,9 +1177,9 @@ (~ (privacy_modifier$ pm)) [(~+ (list\map annotation$ anns))] [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)))) + (~ (return$ return_type)) + [(~+ (list\map class$ exs))])) (#NativeMethod type_vars arguments return_type exs) (` ("native" @@ -1228,11 +1244,10 @@ )} (do meta.monad [#let [fully_qualified_class_name full_class_name - field_parsers (list\map (field->parser fully_qualified_class_name) fields) - method_parsers (list\map (method->parser fully_qualified_class_name) methods) - replacer (parser->replacer (list\fold <>.either - (<>.fail "") - (list\compose field_parsers method_parsers)))]] + method_parser (: (Parser Code) + (|> methods + (list\map (method->parser fully_qualified_class_name)) + (list\fold <>.either (<>.fail ""))))]] (wrap (list (` ("jvm class" (~ (declaration$ (type.declaration full_class_name class_vars))) (~ (class$ super)) @@ -1240,7 +1255,7 @@ (~ (inheritance_modifier$ im)) [(~+ (list\map annotation$ annotations))] [(~+ (list\map field_decl$ fields))] - [(~+ (list\map (method_def$ replacer super) methods))])))))) + [(~+ (list\map (method_def$ fully_qualified_class_name method_parser super fields) methods))])))))) (syntax: #export (interface: {#let [! <>.monad]} @@ -1282,7 +1297,7 @@ (~ (class$ super)) [(~+ (list\map class$ interfaces))] [(~+ (list\map constructor_arg$ constructor_args))] - [(~+ (list\map (method_def$ function.identity super) methods))]))))) + [(~+ (list\map (method_def$ "" (<>.fail "") super (list)) methods))]))))) (syntax: #export (null) {#.doc (doc "Null object reference." diff --git a/stdlib/source/library/lux/ffi.old.lux b/stdlib/source/library/lux/ffi.old.lux index c8de0eb03..832d3907f 100644 --- a/stdlib/source/library/lux/ffi.old.lux +++ b/stdlib/source/library/lux/ffi.old.lux @@ -89,21 +89,21 @@ #ManualPrM #AutoPrM) -(type: PrivacyModifier - #PublicPM - #PrivatePM - #ProtectedPM - #DefaultPM) - -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) - -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) +(type: #export Privacy + #PublicP + #PrivateP + #ProtectedP + #DefaultP) + +(type: #export State + #VolatileS + #FinalS + #DefaultS) + +(type: #export Inheritance + #FinalI + #AbstractI + #DefaultI) (type: Class_Kind #Class @@ -129,12 +129,12 @@ (type: Member_Declaration {#member_name Text - #member_privacy PrivacyModifier + #member_privacy Privacy #member_anns (List Annotation)}) (type: FieldDecl (#ConstantField GenericType Code) - (#VariableField StateModifier GenericType)) + (#VariableField State GenericType)) (type: MethodDecl {#method_tvars (List Type_Parameter) @@ -502,7 +502,7 @@ ## Parsers (def: privacy_modifier^ - (Parser PrivacyModifier) + (Parser Privacy) (let [(^open ".") <>.monad] ($_ <>.or (.this! (' #public)) @@ -511,7 +511,7 @@ (wrap [])))) (def: inheritance_modifier^ - (Parser InheritanceModifier) + (Parser Inheritance) (let [(^open ".") <>.monad] ($_ <>.or (.this! (' #final)) @@ -661,13 +661,13 @@ inputs (.tuple (<>.some (..generic_type^ type_vars))) output (..generic_type^ type_vars) exs (..throws_decl^ type_vars)] - (wrap [[name #PublicPM anns] {#method_tvars tvars - #method_inputs inputs - #method_output output - #method_exs exs}])))) + (wrap [[name #PublicP anns] {#method_tvars tvars + #method_inputs inputs + #method_output output + #method_exs exs}])))) (def: state_modifier^ - (Parser StateModifier) + (Parser State) ($_ <>.or (.this! (' #volatile)) (.this! (' #final)) @@ -681,7 +681,7 @@ anns ..annotations^ type (..generic_type^ type_vars) body .any] - (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) + (wrap [[name #PublicP anns] (#ConstantField [type body])]))) (.form (do <>.monad [pm privacy_modifier^ sm state_modifier^ @@ -765,7 +765,7 @@ annotations ..annotations^ body .any] (wrap [{#member_name name - #member_privacy #PublicPM + #member_privacy #PublicP #member_anns annotations} (#OverridenMethod strict_fp? owner_class method_vars @@ -952,19 +952,19 @@ (text.join_with " ")) (def: (privacy_modifier$ pm) - (-> PrivacyModifier JVM_Code) + (-> Privacy JVM_Code) (case pm - #PublicPM "public" - #PrivatePM "private" - #ProtectedPM "protected" - #DefaultPM "default")) + #PublicP "public" + #PrivateP "private" + #ProtectedP "protected" + #DefaultP "default")) (def: (inheritance_modifier$ im) - (-> InheritanceModifier JVM_Code) + (-> Inheritance JVM_Code) (case im - #FinalIM "final" - #AbstractIM "abstract" - #DefaultIM "default")) + #FinalI "final" + #AbstractI "abstract" + #DefaultI "default")) (def: (annotation_param$ [name value]) (-> AnnotationParam JVM_Code) @@ -1023,11 +1023,11 @@ )))) (def: (state_modifier$ sm) - (-> StateModifier JVM_Code) + (-> State JVM_Code) (case sm - #VolatileSM "volatile" - #FinalSM "final" - #DefaultSM "default")) + #VolatileS "volatile" + #FinalS "final" + #DefaultS "default")) (def: (field_decl$ [[name pm anns] field]) (-> [Member_Declaration FieldDecl] JVM_Code) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux index 49ab15299..bb8a578bd 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux @@ -3,6 +3,8 @@ [lux (#- Module) [abstract [monad (#+ do)]] + [control + ["." try]] [data [collection ["." list ("#\." monoid)]]]]] @@ -59,6 +61,18 @@ [Bundle extension.Bundle] ) +(template [ ] + [(def: #export + (All [anchor expression directive] + (Operation anchor expression directive )) + (function (_ [bundle state]) + (#try.Success [[bundle state] (get@ [ #..phase] state)])))] + + [analysis #..analysis analysis.Phase] + [synthesis #..synthesis synthesis.Phase] + [generation #..generation (generation.Phase anchor expression directive)] + ) + (template [ ] [(def: #export (All [anchor expression directive output] 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 3c458c041..66f7271db 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 @@ -843,7 +843,7 @@ (/////analysis.throw cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))])) (template [ ] - [(def: ( mapping typeJ) + [(def: #export ( mapping typeJ) (-> Mapping (Type ) (Operation .Type)) (case (|> typeJ ..signature (.run ( mapping))) (#try.Success check) @@ -1043,6 +1043,7 @@ (wrap (<| (#/////analysis.Extension extension_name) (list (/////analysis.text class) (/////analysis.text field) + (/////analysis.text (..reflection fieldJT)) objectA)))))])) (def: (put::virtual class_loader) @@ -1071,6 +1072,7 @@ (wrap (<| (#/////analysis.Extension extension_name) (list (/////analysis.text class) (/////analysis.text field) + (/////analysis.text (..reflection fieldJT)) valueA objectA)))))])) @@ -1919,6 +1921,29 @@ #.None (phase.lift (exception.throw ..unknown_super [parent_name supers]))))) +(def: #export (with_fresh_type_vars vars mapping) + (-> (List (Type Var)) Mapping (Operation Mapping)) + (do {! phase.monad} + [pairings (monad.map ! (function (_ var) + (do ! + [[_ exT] (typeA.with_env + check.existential)] + (wrap [var exT]))) + vars)] + (wrap (list\fold (function (_ [varJ varT] mapping) + (dictionary.put (jvm_parser.name varJ) varT mapping)) + mapping + pairings)))) + +(def: #export (with_override_mapping supers parent_type mapping) + (-> (List (Type Class)) (Type Class) Mapping (Operation Mapping)) + (do phase.monad + [override_mapping (..override_mapping mapping supers parent_type)] + (wrap (list\fold (function (_ [super_var bound_type] mapping) + (dictionary.put super_var bound_type mapping)) + mapping + override_mapping)))) + (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 @@ -1926,15 +1951,8 @@ self_name arguments return exceptions body] method] (do {! phase.monad} - [override_mapping (..override_mapping mapping supers parent_type) - #let [mapping (list\fold (function (_ [super_var bound_type] mapping) - (dictionary.put super_var bound_type mapping)) - mapping - override_mapping) - mapping (list\fold (function (_ varJ mapping) - (dictionary.put (jvm_parser.name varJ) java/lang/Object mapping)) - mapping - vars)] + [mapping (..with_override_mapping supers parent_type mapping) + mapping (..with_fresh_type_vars vars mapping) annotationsA (monad.map ! (function (_ [name parameters]) (do ! [parametersA (monad.map ! (function (_ [name value]) @@ -1944,13 +1962,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (reflection_return mapping return) arguments' (monad.map ! (function (_ [name jvmT]) (do ! [luxT (reflection_type mapping jvmT)] (wrap [name luxT]))) arguments) + returnT (reflection_return mapping return) [scope bodyA] (|> arguments' (#.Cons [self_name selfT]) list.reverse -- cgit v1.2.3