- Re-organized code-generation, and re-named it "translation".

1 files changed, 761 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
new file mode 100644
index 000000000..c222e42cf
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux
@@ -0,0 +1,761 @@
+(;module:
+  lux
+  (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/" Monad<Meta>]
+       (meta [code]
+             ["s" syntax #+ syntax:])
+       [host])
+  (luxc ["&" base]
+        [";L" host]
+        (host ["$" jvm]
+              (jvm ["$t" type]
+                   ["$d" def]
+                   ["$i" inst]))
+        (lang ["la" analysis]
+              (analysis (procedure ["&;" host]))
+              ["ls" synthesis]))
+  ["@" ../common])
+
+(do-template [<name> <inst>]
+  [(def: <name>
+     $;Inst
+     <inst>)]
+
+  [L2S (|>. $i;L2I $i;I2S)]
+  [L2B (|>. $i;L2I $i;I2B)]
+  [L2C (|>. $i;L2I $i;I2C)]
+  )
+
+(do-template [<name> <unwrap> <conversion> <wrap>]
+  [(def: (<name> inputI)
+     @;Unary
+     (if (is $i;NOP <conversion>)
+       (|>. inputI
+            ($i;unwrap <unwrap>)
+            ($i;wrap <wrap>))
+       (|>. inputI
+            ($i;unwrap <unwrap>)
+            <conversion>
+            ($i;wrap <wrap>))))]
+  
+  [convert//double-to-float #$;Double $i;D2F #$;Float]
+  [convert//double-to-int #$;Double $i;D2I #$;Int]
+  [convert//double-to-long #$;Double $i;D2L #$;Long]
+  [convert//float-to-double #$;Float $i;F2D #$;Double]
+  [convert//float-to-int #$;Float $i;F2I #$;Int]
+  [convert//float-to-long #$;Float $i;F2L #$;Long]
+  [convert//int-to-byte #$;Int $i;I2B #$;Byte]
+  [convert//int-to-char #$;Int $i;I2C #$;Char]
+  [convert//int-to-double #$;Int $i;I2D #$;Double]
+  [convert//int-to-float #$;Int $i;I2F #$;Float]
+  [convert//int-to-long #$;Int $i;I2L #$;Long]
+  [convert//int-to-short #$;Int $i;I2S #$;Short]
+  [convert//long-to-double #$;Long $i;L2D #$;Double]
+  [convert//long-to-float #$;Long $i;L2F #$;Float]
+  [convert//long-to-int #$;Long $i;L2I #$;Int]
+  [convert//long-to-short #$;Long L2S #$;Short]
+  [convert//long-to-byte #$;Long L2B #$;Byte]
+  [convert//long-to-char #$;Long L2C #$;Char]
+  [convert//char-to-byte #$;Char $i;I2B #$;Byte]
+  [convert//char-to-short #$;Char $i;I2S #$;Short]
+  [convert//char-to-int #$;Char $i;NOP #$;Int]
+  [convert//char-to-long #$;Char $i;I2L #$;Long]
+  [convert//byte-to-long #$;Byte $i;I2L #$;Long]
+  [convert//short-to-long #$;Short $i;I2L #$;Long]
+  )
+
+(def: conversion-procs
+  @;Bundle
+  (<| (@;prefix "convert")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "double-to-float" (@;unary convert//double-to-float))
+          (@;install "double-to-int" (@;unary convert//double-to-int))
+          (@;install "double-to-long" (@;unary convert//double-to-long))
+          (@;install "float-to-double" (@;unary convert//float-to-double))
+          (@;install "float-to-int" (@;unary convert//float-to-int))
+          (@;install "float-to-long" (@;unary convert//float-to-long))
+          (@;install "int-to-byte" (@;unary convert//int-to-byte))
+          (@;install "int-to-char" (@;unary convert//int-to-char))
+          (@;install "int-to-double" (@;unary convert//int-to-double))
+          (@;install "int-to-float" (@;unary convert//int-to-float))
+          (@;install "int-to-long" (@;unary convert//int-to-long))
+          (@;install "int-to-short" (@;unary convert//int-to-short))
+          (@;install "long-to-double" (@;unary convert//long-to-double))
+          (@;install "long-to-float" (@;unary convert//long-to-float))
+          (@;install "long-to-int" (@;unary convert//long-to-int))
+          (@;install "long-to-short" (@;unary convert//long-to-short))
+          (@;install "long-to-byte" (@;unary convert//long-to-byte))
+          (@;install "long-to-char" (@;unary convert//long-to-char))
+          (@;install "char-to-byte" (@;unary convert//char-to-byte))
+          (@;install "char-to-short" (@;unary convert//char-to-short))
+          (@;install "char-to-int" (@;unary convert//char-to-int))
+          (@;install "char-to-long" (@;unary convert//char-to-long))
+          (@;install "byte-to-long" (@;unary convert//byte-to-long))
+          (@;install "short-to-long" (@;unary convert//short-to-long))
+          )))
+
+(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
+  [(def: (<name> [xI yI])
+     @;Binary
+     (|>. xI ($i;unwrap <unwrapX>)
+          yI ($i;unwrap <unwrapY>)
+          <op> ($i;wrap <wrap>)))]
+
+  [int//+ $i;IADD #$;Int #$;Int #$;Int]
+  [int//- $i;ISUB #$;Int #$;Int #$;Int]
+  [int//* $i;IMUL #$;Int #$;Int #$;Int]
+  [int/// $i;IDIV #$;Int #$;Int #$;Int]
+  [int//% $i;IREM #$;Int #$;Int #$;Int]
+  [int//and $i;IAND #$;Int #$;Int #$;Int]
+  [int//or $i;IOR #$;Int #$;Int #$;Int]
+  [int//xor $i;IXOR #$;Int #$;Int #$;Int]
+  [int//shl $i;ISHL #$;Int #$;Int #$;Int]
+  [int//shr $i;ISHR #$;Int #$;Int #$;Int]
+  [int//ushr $i;IUSHR #$;Int #$;Int #$;Int]
+  
+  [long//+ $i;LADD #$;Long #$;Long #$;Long]
+  [long//- $i;LSUB #$;Long #$;Long #$;Long]
+  [long//* $i;LMUL #$;Long #$;Long #$;Long]
+  [long/// $i;LDIV #$;Long #$;Long #$;Long]
+  [long//% $i;LREM #$;Long #$;Long #$;Long]
+  [long//and $i;LAND #$;Long #$;Long #$;Long]
+  [long//or $i;LOR #$;Long #$;Long #$;Long]
+  [long//xor $i;LXOR #$;Long #$;Long #$;Long]
+  [long//shl $i;LSHL #$;Long #$;Int #$;Long]
+  [long//shr $i;LSHR #$;Long #$;Int #$;Long]
+  [long//ushr $i;LUSHR #$;Long #$;Int #$;Long]
+
+  [float//+ $i;FADD #$;Float #$;Float #$;Float]
+  [float//- $i;FSUB #$;Float #$;Float #$;Float]
+  [float//* $i;FMUL #$;Float #$;Float #$;Float]
+  [float/// $i;FDIV #$;Float #$;Float #$;Float]
+  [float//% $i;FREM #$;Float #$;Float #$;Float]
+  
+  [double//+ $i;DADD #$;Double #$;Double #$;Double]
+  [double//- $i;DSUB #$;Double #$;Double #$;Double]
+  [double//* $i;DMUL #$;Double #$;Double #$;Double]
+  [double/// $i;DDIV #$;Double #$;Double #$;Double]
+  [double//% $i;DREM #$;Double #$;Double #$;Double]
+  )
+
+(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
+  [(def: (<name> [xI yI])
+     @;Binary
+     (<| $i;with-label (function [@then])
+         $i;with-label (function [@end])
+         (|>. xI ($i;unwrap <unwrapX>)
+              yI ($i;unwrap <unwrapY>)
+              (<op> @then)
+              ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
+              ($i;GOTO @end)
+              ($i;label @then)
+              ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
+              ($i;label @end))))]
+
+  [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean]
+  [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean]
+
+  [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean]
+  [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean]
+  )
+
+(do-template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>]
+  [(def: (<name> [xI yI])
+     @;Binary
+     (<| $i;with-label (function [@then])
+         $i;with-label (function [@end])
+         (|>. xI ($i;unwrap <unwrapX>)
+              yI ($i;unwrap <unwrapY>)
+              <op>
+              ($i;int <reference>)
+              ($i;IF_ICMPEQ @then)
+              ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
+              ($i;GOTO @end)
+              ($i;label @then)
+              ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
+              ($i;label @end))))]
+
+  [long//= $i;LCMP  0 #$;Long #$;Long #$;Boolean]
+  [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean]
+  
+  [float//= $i;FCMPG  0 #$;Float #$;Float #$;Boolean]
+  [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean]
+
+  [double//= $i;DCMPG  0 #$;Double #$;Double #$;Boolean]
+  [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean]
+  )
+
+(def: int-procs
+  @;Bundle
+  (<| (@;prefix "int")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary int//+))
+          (@;install "-" (@;binary int//-))
+          (@;install "*" (@;binary int//*))
+          (@;install "/" (@;binary int///))
+          (@;install "%" (@;binary int//%))
+          (@;install "=" (@;binary int//=))
+          (@;install "<" (@;binary int//<))
+          (@;install "and" (@;binary int//and))
+          (@;install "or" (@;binary int//or))
+          (@;install "xor" (@;binary int//xor))
+          (@;install "shl" (@;binary int//shl))
+          (@;install "shr" (@;binary int//shr))
+          (@;install "ushr" (@;binary int//ushr))
+          )))
+
+(def: long-procs
+  @;Bundle
+  (<| (@;prefix "long")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary long//+))
+          (@;install "-" (@;binary long//-))
+          (@;install "*" (@;binary long//*))
+          (@;install "/" (@;binary long///))
+          (@;install "%" (@;binary long//%))
+          (@;install "=" (@;binary long//=))
+          (@;install "<" (@;binary long//<))
+          (@;install "and" (@;binary long//and))
+          (@;install "or" (@;binary long//or))
+          (@;install "xor" (@;binary long//xor))
+          (@;install "shl" (@;binary long//shl))
+          (@;install "shr" (@;binary long//shr))
+          (@;install "ushr" (@;binary long//ushr))
+          )))
+
+(def: float-procs
+  @;Bundle
+  (<| (@;prefix "float")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary float//+))
+          (@;install "-" (@;binary float//-))
+          (@;install "*" (@;binary float//*))
+          (@;install "/" (@;binary float///))
+          (@;install "%" (@;binary float//%))
+          (@;install "=" (@;binary float//=))
+          (@;install "<" (@;binary float//<))
+          )))
+
+(def: double-procs
+  @;Bundle
+  (<| (@;prefix "double")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary double//+))
+          (@;install "-" (@;binary double//-))
+          (@;install "*" (@;binary double//*))
+          (@;install "/" (@;binary double///))
+          (@;install "%" (@;binary double//%))
+          (@;install "=" (@;binary double//=))
+          (@;install "<" (@;binary double//<))
+          )))
+
+(def: char-procs
+  @;Bundle
+  (<| (@;prefix "char")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "=" (@;binary char//=))
+          (@;install "<" (@;binary char//<))
+          )))
+
+(def: (array//length arrayI)
+  @;Unary
+  (|>. arrayI
+       $i;ARRAYLENGTH
+       $i;I2L
+       ($i;wrap #$;Long)))
+
+(def: (array//new proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS))
+    (do meta;Monad<Meta>
+      [lengthI (generate lengthS)
+       #let [arrayJT ($t;array level (case class
+                                       "boolean" $t;boolean
+                                       "byte" $t;byte
+                                       "short" $t;short
+                                       "int" $t;int
+                                       "long" $t;long
+                                       "float" $t;float
+                                       "double" $t;double
+                                       "char" $t;char
+                                       _ ($t;class class (list))))]]
+      (wrap (|>. lengthI
+                 ($i;unwrap #$;Long)
+                 $i;L2I
+                 ($i;array arrayJT))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: (array//read proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)] idxS arrayS))
+    (do meta;Monad<Meta>
+      [arrayI (generate arrayS)
+       idxI (generate idxS)
+       #let [loadI (case class
+                     "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean))
+                     "byte" (|>. $i;BALOAD ($i;wrap #$;Byte))
+                     "short" (|>. $i;SALOAD ($i;wrap #$;Short))
+                     "int" (|>. $i;IALOAD ($i;wrap #$;Int))
+                     "long" (|>. $i;LALOAD ($i;wrap #$;Long))
+                     "float" (|>. $i;FALOAD ($i;wrap #$;Float))
+                     "double" (|>. $i;DALOAD ($i;wrap #$;Double))
+                     "char" (|>. $i;CALOAD ($i;wrap #$;Char))
+                     _ $i;AALOAD)]]
+      (wrap (|>. arrayI
+                 idxI
+                 ($i;unwrap #$;Long)
+                 $i;L2I
+                 loadI)))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: (array//write proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)] idxS valueS arrayS))
+    (do meta;Monad<Meta>
+      [arrayI (generate arrayS)
+       idxI (generate idxS)
+       valueI (generate valueS)
+       #let [storeI (case class
+                      "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE)
+                      "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE)
+                      "short" (|>. ($i;unwrap #$;Short) $i;SASTORE)
+                      "int" (|>. ($i;unwrap #$;Int) $i;IASTORE)
+                      "long" (|>. ($i;unwrap #$;Long) $i;LASTORE)
+                      "float" (|>. ($i;unwrap #$;Float) $i;FASTORE)
+                      "double" (|>. ($i;unwrap #$;Double) $i;DASTORE)
+                      "char" (|>. ($i;unwrap #$;Char) $i;CASTORE)
+                      _ $i;AASTORE)]]
+      (wrap (|>. arrayI
+                 $i;DUP
+                 idxI
+                 ($i;unwrap #$;Long)
+                 $i;L2I
+                 valueI
+                 storeI)))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: array-procs
+  @;Bundle
+  (<| (@;prefix "array")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "length" (@;unary array//length))
+          (@;install "new" array//new)
+          (@;install "read" array//read)
+          (@;install "write" array//write)
+          )))
+
+(def: (object//null _)
+  @;Nullary
+  $i;NULL)
+
+(def: (object//null? objectI)
+  @;Unary
+  (<| $i;with-label (function [@then])
+      $i;with-label (function [@end])
+      (|>. objectI
+           ($i;IFNULL @then)
+           ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
+           ($i;GOTO @end)
+           ($i;label @then)
+           ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
+           ($i;label @end))))
+
+(def: (object//synchronized [monitorI exprI])
+  @;Binary
+  (|>. monitorI
+       $i;DUP
+       $i;MONITORENTER
+       exprI
+       $i;SWAP
+       $i;MONITOREXIT))
+
+(def: (object//throw exceptionI)
+  @;Unary
+  (|>. exceptionI
+       $i;ATHROW))
+
+(def: (object//class proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)]))
+    (do meta;Monad<Meta>
+      []
+      (wrap (|>. ($i;string class)
+                 ($i;INVOKESTATIC "java.lang.Class" "forName"
+                                  ($t;method (list ($t;class "java.lang.String" (list)))
+                                             (#;Some ($t;class "java.lang.Class" (list)))
+                                             (list))
+                                  false))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: (object//instance? proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)] objectS))
+    (do meta;Monad<Meta>
+      [objectI (generate objectS)]
+      (wrap (|>. objectI
+                 ($i;INSTANCEOF class)
+                 ($i;wrap #$;Boolean))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: object-procs
+  @;Bundle
+  (<| (@;prefix "object")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "null" (@;nullary object//null))
+          (@;install "null?" (@;unary object//null?))
+          (@;install "synchronized" (@;binary object//synchronized))
+          (@;install "throw" (@;unary object//throw))
+          (@;install "class" object//class)
+          (@;install "instance?" object//instance?)
+          )))
+
+(def: primitives
+  (Dict Text $;Primitive)
+  (|> (list ["boolean" #$;Boolean]
+            ["byte" #$;Byte]
+            ["short" #$;Short]
+            ["int" #$;Int]
+            ["long" #$;Long]
+            ["float" #$;Float]
+            ["double" #$;Double]
+            ["char" #$;Char])
+      (dict;from-list text;Hash<Text>)))
+
+(def: (static//get proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)]))
+    (do meta;Monad<Meta>
+      []
+      (case (dict;get unboxed primitives)
+        (#;Some primitive)
+        (let [primitive (case unboxed
+                          "boolean" #$;Boolean
+                          "byte" #$;Byte
+                          "short" #$;Short
+                          "int" #$;Int
+                          "long" #$;Long
+                          "float" #$;Float
+                          "double" #$;Double
+                          "char" #$;Char
+                          _ (undefined))]
+          (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive))
+                     ($i;wrap primitive))))
+        
+        #;None
+        (wrap ($i;GETSTATIC class field ($t;class unboxed (list))))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: (static//put proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS))
+    (do meta;Monad<Meta>
+      [valueI (generate valueS)]
+      (case (dict;get unboxed primitives)
+        (#;Some primitive)
+        (let [primitive (case unboxed
+                          "boolean" #$;Boolean
+                          "byte" #$;Byte
+                          "short" #$;Short
+                          "int" #$;Int
+                          "long" #$;Long
+                          "float" #$;Float
+                          "double" #$;Double
+                          "char" #$;Char
+                          _ (undefined))]
+          (wrap (|>. valueI
+                     ($i;unwrap primitive)
+                     ($i;PUTSTATIC class field (#$;Primitive primitive))
+                     ($i;string hostL;unit))))
+        
+        #;None
+        (wrap (|>. valueI
+                   ($i;CHECKCAST class)
+                   ($i;PUTSTATIC class field ($t;class class (list)))
+                   ($i;string hostL;unit)))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: (virtual//get proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS))
+    (do meta;Monad<Meta>
+      [objectI (generate objectS)]
+      (case (dict;get unboxed primitives)
+        (#;Some primitive)
+        (let [primitive (case unboxed
+                          "boolean" #$;Boolean
+                          "byte" #$;Byte
+                          "short" #$;Short
+                          "int" #$;Int
+                          "long" #$;Long
+                          "float" #$;Float
+                          "double" #$;Double
+                          "char" #$;Char
+                          _ (undefined))]
+          (wrap (|>. objectI
+                     ($i;CHECKCAST class)
+                     ($i;GETFIELD class field (#$;Primitive primitive))
+                     ($i;wrap primitive))))
+        
+        #;None
+        (wrap (|>. objectI
+                   ($i;CHECKCAST class)
+                   ($i;GETFIELD class field ($t;class unboxed (list)))))))
+
+    _
+    (&;fail (format "Wrong syntax for '" proc "'."))))
+
+(def: (virtual//put proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS))
+    (do meta;Monad<Meta>
+      [valueI (generate valueS)
+       objectI (generate objectS)]
+      (case (dict;get unboxed primitives)
+        (#;Some primitive)
+        (let [primitive (case unboxed
+                          "boolean" #$;Boolean
+                          "byte" #$;Byte
+                          "short" #$;Short
+                          "int" #$;Int
+                          "long" #$;Long
+                          "float" #$;Float
+                          "double" #$;Double
+                          "char" #$;Char
+                          _ (undefined))]
+          (wrap (|>. objectI
+                     ($i;CHECKCAST class)
+                     $i;DUP
+                     valueI
+                     ($i;unwrap primitive)
+                     ($i;PUTFIELD class field (#$;Primitive primitive)))))
+        
+        #;None
+        (wrap (|>. objectI
+                   ($i;CHECKCAST class)
+                   $i;DUP
+                   valueI
+                   ($i;CHECKCAST unboxed)
+                   ($i;PUTFIELD class field ($t;class unboxed (list)))))))
+
+    _
+    (&;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& [_ (#;Tuple (list [_ (#;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 hostL;unit))
+
+    (#;Some type)
+    (case type
+      (#$;Primitive primitive)
+      (|>. returnI ($i;wrap primitive))
+
+      _
+      returnI)))
+
+(def: (invoke//static proc generate inputs)
+  (-> Text @;Proc)
+  (case inputs
+    (^ (list& [_ (#;Text class)] [_ (#;Text method)]
+              [_ (#;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& [_ (#;Text class)] [_ (#;Text method)]
+                 [_ (#;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& [_ (#;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")
+      (|> (dict;new text;Hash<Text>)
+          (dict;merge (<| (@;prefix "static")
+                          (|> (dict;new text;Hash<Text>)
+                              (@;install "get" static//get)
+                              (@;install "put" static//put))))
+          (dict;merge (<| (@;prefix "virtual")
+                          (|> (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
+  @;Bundle
+  (<| (@;prefix "jvm")
+      (|> (dict;new text;Hash<Text>)
+          (dict;merge conversion-procs)
+          (dict;merge int-procs)
+          (dict;merge long-procs)
+          (dict;merge float-procs)
+          (dict;merge double-procs)
+          (dict;merge char-procs)
+          (dict;merge array-procs)
+          (dict;merge object-procs)
+          (dict;merge member-procs)
+          )))