- Compilation for method invocation.

3 files changed, 191 insertions, 26 deletions

diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index d4029b15b..63931c6f2 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -1128,10 +1128,16 @@
       (do meta;Monad<Meta>
         [#let [argsT (list/map product;left argsTC)]
          [methodT exceptionsT] (methods class method #Virtual argsT)
-         [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+         [outputT allA] (&inference;apply-function (sub-type-analyser analyse) methodT (list& objectC (list/map product;right argsTC)))
+         #let [[objectA argsA] (case allA
+                                 (#;Cons objectA argsA)
+                                 [objectA argsA]
+
+                                 _
+                                 (undefined))]
          [unboxed castT] (infer-out outputT)]
         (wrap (#la;Procedure proc (list& (#la;Text class) (#la;Text method)
-                                         (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+                                         (#la;Text unboxed) objectA (decorate-inputs argsT argsA)))))
 
       _
       (&;fail (format "Wrong syntax for '" proc "'.")))))
@@ -1186,8 +1192,7 @@
          [methodT exceptionsT] (constructor-methods class argsT)
          [outputT argsA] (&inference;apply-function (sub-type-analyser analyse) methodT (list/map product;right argsTC))
          [unboxed castT] (infer-out outputT)]
-        (wrap (#la;Procedure proc (list& (#la;Text class)
-                                         (#la;Text unboxed) (decorate-inputs argsT argsA)))))
+        (wrap (#la;Procedure proc (list& (#la;Text class) (decorate-inputs argsT argsA)))))
 
       _
       (&;fail (format "Wrong syntax for '" proc "'.")))))
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index 1951076c3..f515e86ac 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -9,7 +9,7 @@
        [host #+ do-to]
        [meta]
        (meta [code]
-              ["s" syntax #+ syntax:]))
+             ["s" syntax #+ syntax:]))
   ["$" ..]
   (.. ["$t" type]))
 
@@ -29,6 +29,8 @@
                   <primitive> (declare T_BOOLEAN T_CHAR T_FLOAT T_DOUBLE
                                        T_BYTE T_SHORT T_INT T_LONG)
                   <class> (declare CHECKCAST NEW INSTANCEOF)
+                  <member> (declare GETSTATIC PUTSTATIC GETFIELD PUTFIELD
+                                    INVOKESTATIC INVOKESPECIAL INVOKEVIRTUAL INVOKEINTERFACE)
                   <stack> (declare DUP DUP2 DUP2_X1 DUP2_X2
                                    POP POP2
                                    SWAP)
@@ -37,10 +39,10 @@
                                   GOTO)
                   <var> (declare ILOAD LLOAD DLOAD ALOAD
                                  ISTORE LSTORE ASTORE)
-                  <arithmethic> (declare IADD ISUB IMUL IDIV IREM
-                                         LADD LSUB LMUL LDIV LREM LCMP
-                                         FADD FSUB FMUL FDIV FREM FCMPG FCMPL
-                                         DADD DSUB DMUL DDIV DREM DCMPG DCMPL)
+                  <arithmetic> (declare IADD ISUB IMUL IDIV IREM
+                                        LADD LSUB LMUL LDIV LREM LCMP
+                                        FADD FSUB FMUL FDIV FREM FCMPG FCMPL
+                                        DADD DSUB DMUL DDIV DREM DCMPG DCMPL)
                   <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR
                                       LAND LOR LXOR LSHL LSHR LUSHR)
                   <array> (declare ARRAYLENGTH NEWARRAY ANEWARRAY
@@ -69,19 +71,12 @@
     
     <var>
     
-    <arithmethic>
+    <arithmetic>
     <bit-wise>
 
     <array>
     
-    (#static GETSTATIC int)
-    (#static PUTSTATIC int)
-    (#static GETFIELD int)
-    (#static PUTFIELD int)
-    
-    (#static INVOKESTATIC int)
-    (#static INVOKESPECIAL int)
-    (#static INVOKEVIRTUAL int)
+    <member>
 
     (#static ATHROW int)
 
@@ -171,7 +166,7 @@
   ## Integer bitwise
   [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
   
-  ## Long arithmethic
+  ## Long arithmetic
   [LADD] [LSUB] [LMUL] [LDIV] [LREM]
   [LCMP]
 
@@ -265,9 +260,10 @@
        (do-to visitor
          (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))]
 
-  [INVOKESTATIC  Opcodes.INVOKESTATIC]
-  [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL]
-  [INVOKESPECIAL Opcodes.INVOKESPECIAL]
+  [INVOKESTATIC    Opcodes.INVOKESTATIC]
+  [INVOKEVIRTUAL   Opcodes.INVOKEVIRTUAL]
+  [INVOKESPECIAL   Opcodes.INVOKESPECIAL]
+  [INVOKEINTERFACE Opcodes.INVOKEINTERFACE]
   )
 
 (do-template [<name>]
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index f754422c3..a25c67feb 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -1,11 +1,16 @@
 (;module:
   lux
-  (lux (control [monad #+ do])
-       (data [text "text/" Eq<Text>]
-             text/format
+  (lux (control [monad #+ do]
+                ["p" parser "parser/" Monad<Parser>]
+                ["ex" exception #+ exception:])
+       (data [product]
+             ["e" error]
+             [text "text/" Eq<Text>]
+             (text format
+                   ["l" lexer])
              (coll [list "list/" Functor<List>]
                    [dict #+ Dict]))
-       [meta #+ with-gensyms]
+       [meta #+ with-gensyms "meta/" Monad<Meta>]
        (meta [code]
              ["s" syntax #+ syntax:])
        [host])
@@ -568,6 +573,157 @@
     _
     (&;fail (format "Wrong syntax for '" proc "'."))))
 
+(exception: #export Invalid-Syntax-For-Argument-Generation)
+
+(def: base-type
+  (l;Lexer $;Type)
+  ($_ p;either
+      (p;after (l;this "boolean") (parser/wrap $t;boolean))
+      (p;after (l;this "byte") (parser/wrap $t;byte))
+      (p;after (l;this "short") (parser/wrap $t;short))
+      (p;after (l;this "int") (parser/wrap $t;int))
+      (p;after (l;this "long") (parser/wrap $t;long))
+      (p;after (l;this "float") (parser/wrap $t;float))
+      (p;after (l;this "double") (parser/wrap $t;double))
+      (p;after (l;this "char") (parser/wrap $t;char))
+      (parser/map (function [name]
+                    ($t;class name (list)))
+                  (l;many (l;none-of "[")))
+      ))
+
+(def: java-type
+  (l;Lexer $;Type)
+  (do p;Monad<Parser>
+    [raw base-type
+     nesting (p;some (l;this "[]"))]
+    (wrap ($t;array (list;size nesting) raw))))
+
+(def: (generate-type argD)
+  (-> Text (Meta $;Type))
+  (case (l;run argD java-type)
+    (#e;Error error)
+    (&;fail error)
+
+    (#e;Success type)
+    (meta/wrap type)))
+
+(def: (prepare-input inputT inputI)
+  (-> $;Type $;Inst $;Inst)
+  (case inputT
+    (#$;Primitive primitive)
+    (|>. inputI ($i;unwrap primitive))
+
+    (#$;Generic generic)
+    (case generic
+      (^or (#$;Var _) (#$;Wildcard _))
+      (|>. inputI ($i;CHECKCAST "java.lang.Object"))
+      
+      (#$;Class class-name _)
+      (|>. inputI ($i;CHECKCAST class-name)))
+
+    _
+    (|>. inputI ($i;CHECKCAST ($t;descriptor inputT)))))
+
+(def: (generate-args generate argsS)
+  (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis)
+      (Meta (List [$;Type $;Inst])))
+  (case argsS
+    #;Nil
+    (meta/wrap #;Nil)
+
+    (^ (list& [(#ls;Tuple (list (#ls;Text argD) argS))] tail))
+    (do meta;Monad<Meta>
+      [argT (generate-type argD)
+       argI (:: @ map (prepare-input argT) (generate argS))
+       =tail (generate-args generate tail)]
+      (wrap (list& [argT argI] =tail)))
+
+    _
+    (&;throw Invalid-Syntax-For-Argument-Generation "")))
+
+(def: (method-return-type description)
+  (-> Text (Meta (Maybe $;Type)))
+  (case description
+    "void"
+    (meta/wrap #;None)
+
+    _
+    (:: meta;Monad<Meta> map (|>. #;Some) (generate-type description))))
+
+(def: (prepare-return returnT returnI)
+  (-> (Maybe $;Type) $;Inst $;Inst)
+  (case returnT
+    #;None
+    (|>. returnI
+         ($i;string &runtime;unit))
+
+    (#;Some type)
+    (case type
+      (#$;Primitive primitive)
+      (|>. returnI ($i;wrap primitive))
+
+      _
+      returnI)))
+
+(def: (invoke//static proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list& (#ls;Text class) (#ls;Text method)
+              (#ls;Text unboxed) argsS))
+    (do meta;Monad<Meta>
+      [argsTI (generate-args generate argsS)
+       returnT (method-return-type unboxed)
+       #let [callI (|>. ($i;fuse (list/map product;right argsTI))
+                        ($i;INVOKESTATIC class method
+                                         ($t;method (list/map product;left argsTI) returnT (list))
+                                         false))]]
+      (wrap (prepare-return returnT callI)))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(do-template [<name> <invoke> <interface?>]
+  [(def: (<name> proc generate inputs)
+     (-> Text @;Proc)
+     (case inputs
+       (^ (list& (#ls;Text class) (#ls;Text method)
+                 (#ls;Text unboxed) objectS argsS))
+       (do meta;Monad<Meta>
+         [objectI (generate objectS)
+          argsTI (generate-args generate argsS)
+          returnT (method-return-type unboxed)
+          #let [callI (|>. objectI
+                           ($i;CHECKCAST class)
+                           ($i;fuse (list/map product;right argsTI))
+                           (<invoke> class method
+                                     ($t;method (list/map product;left argsTI) returnT (list))
+                                     <interface?>))]]
+         (wrap (prepare-return returnT callI)))
+
+       _
+       (&;fail (format "Wrong syntax for '" proc "'."))))]
+
+  [invoke//virtual $i;INVOKEVIRTUAL false]
+  [invoke//special $i;INVOKESPECIAL false]
+  [invoke//interface $i;INVOKEINTERFACE true]
+  )
+
+(def: (invoke//constructor proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list& (#ls;Text class) argsS))
+    (do meta;Monad<Meta>
+      [argsTI (generate-args generate argsS)]
+      (wrap (|>. ($i;NEW class)
+                 $i;DUP
+                 ($i;fuse (list/map product;right argsTI))
+                 ($i;INVOKESPECIAL class "<init>"
+                                   ($t;method (list/map product;left argsTI) #;None (list))
+                                   false))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
 (def: member-procs
   @;Bundle
   (<| (@;prefix "member")
@@ -580,6 +736,14 @@
                           (|> (dict;new text;Hash<Text>)
                               (@;install "get" virtual//get)
                               (@;install "put" virtual//put))))
+          (dict;merge (<| (@;prefix "invoke")
+                          (|> (dict;new text;Hash<Text>)
+                              (@;install "static" invoke//static)
+                              (@;install "virtual" invoke//virtual)
+                              (@;install "special" invoke//special)
+                              (@;install "interface" invoke//interface)
+                              (@;install "constructor" invoke//constructor)
+                              )))
           )))
 
 (def: #export procedures