New JVM compiler can now compile JVM classes.

4 files changed, 181 insertions, 134 deletions

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 @@
      _ (<code>.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)]
      _ (<code>.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])
                     (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.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 [<name> <jvm_op>]
-  [(def: (<name> class_name method_name arguments)
-     (-> Text Text (List Argument) (Parser Code))
+  [(def: (<name> 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))
                 (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name]))
                                        (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))]
        (wrap (` (<jvm_op> (~ (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
         (<code>.this! (' #final))
@@ -732,7 +738,7 @@
                                               #method_exs exs}]))))
 
 (def: state_modifier^
-  (Parser StateModifier)
+  (Parser State)
   ($_ <>.or
       (<code>.this! (' #volatile))
       (<code>.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 (<code>.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 (<code>.form (do <>.monad
                                                           [_ (<code>.this! (' ::super!))
                                                            args (<code>.tuple (<>.exactly (list.size arguments) <code>.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
         (<code>.this! (' #public))
@@ -511,7 +511,7 @@
         (wrap []))))
 
 (def: inheritance_modifier^
-  (Parser InheritanceModifier)
+  (Parser Inheritance)
   (let [(^open ".") <>.monad]
     ($_ <>.or
         (<code>.this! (' #final))
@@ -661,13 +661,13 @@
                   inputs (<code>.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
       (<code>.this! (' #volatile))
       (<code>.this! (' #final))
@@ -681,7 +681,7 @@
                              anns ..annotations^
                              type (..generic_type^ type_vars)
                              body <code>.any]
-                            (wrap [[name #PublicPM anns] (#ConstantField [type body])])))
+                            (wrap [[name #PublicP anns] (#ConstantField [type body])])))
              (<code>.form (do <>.monad
                             [pm privacy_modifier^
                              sm state_modifier^
@@ -765,7 +765,7 @@
                   annotations ..annotations^
                   body <code>.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 [<name> <component> <phase>]
+  [(def: #export <name>
+     (All [anchor expression directive]
+       (Operation anchor expression directive <phase>))
+     (function (_ [bundle state])
+       (#try.Success [[bundle state] (get@ [<component> #..phase] state)])))]
+
+  [analysis   #..analysis   analysis.Phase]
+  [synthesis  #..synthesis  synthesis.Phase]
+  [generation #..generation (generation.Phase anchor expression directive)]
+  )
+
 (template [<name> <component> <operation>]
   [(def: #export <name>
      (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 [<name> <category> <parser>]
-  [(def: (<name> mapping typeJ)
+  [(def: #export (<name> mapping typeJ)
      (-> Mapping (Type <category>) (Operation .Type))
      (case (|> typeJ ..signature (<text>.run (<parser> 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