From 697707d8560a5735be38fd9b1ff91a02c289d48f Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Tue, 16 Apr 2019 20:53:41 -0400
Subject: Made some new-luxc modules "old".

---
 .../luxc/lang/translation/jvm/procedure/host.lux   | 753 +++++++++++++++++++++
 1 file changed, 753 insertions(+)
 create mode 100644 new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux

(limited to 'new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux')

diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
new file mode 100644
index 000000000..45e025d0b
--- /dev/null
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -0,0 +1,753 @@
+(.module:
+  [lux (#- int char)
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["p" parser ("#@." monad)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." product]
+    ["." error]
+    ["." text
+     format
+     ["l" lexer]]
+    [collection
+     ["." list ("#@." functor)]
+     ["." dictionary (#+ Dictionary)]]]
+   [tool
+    [compiler
+     ["." synthesis (#+ Synthesis %synthesis)]
+     ["." phase ("#@." monad)
+      [generation
+       [extension (#+ Nullary Unary Binary
+                      nullary unary binary)]]
+      ["." extension
+       ["." bundle]]]]]
+   [host (#+ import:)]]
+  [luxc
+   [lang
+    [host
+     ["$" jvm (#+ Primitive Label Inst Method Handler Bundle Operation)
+      ["_t" type]
+      ["_" inst]]]]])
+
+(template [<name>]
+  [(exception: #export (<name> {message Text})
+     message)]
+
+  [invalid-syntax-for-jvm-type]
+  [invalid-syntax-for-argument-generation]
+  )
+
+(template [<name> <inst>]
+  [(def: <name>
+     Inst
+     <inst>)]
+
+  [L2S (|>> _.L2I _.I2S)]
+  [L2B (|>> _.L2I _.I2B)]
+  [L2C (|>> _.L2I _.I2C)]
+  )
+
+(template [<name> <unwrap> <conversion> <wrap>]
+  [(def: (<name> inputI)
+     (Unary Inst)
+     (if (is? _.NOP <conversion>)
+       (|>> inputI
+            (_.unwrap <unwrap>)
+            (_.wrap <wrap>))
+       (|>> inputI
+            (_.unwrap <unwrap>)
+            <conversion>
+            (_.wrap <wrap>))))]
+  
+  [convert::double-to-float #$.Double _.D2F #$.Float]
+  [convert::double-to-int #$.Double _.D2I #$.Int]
+  [convert::double-to-long #$.Double _.D2L #$.Long]
+  [convert::float-to-double #$.Float _.F2D #$.Double]
+  [convert::float-to-int #$.Float _.F2I #$.Int]
+  [convert::float-to-long #$.Float _.F2L #$.Long]
+  [convert::int-to-byte #$.Int _.I2B #$.Byte]
+  [convert::int-to-char #$.Int _.I2C #$.Char]
+  [convert::int-to-double #$.Int _.I2D #$.Double]
+  [convert::int-to-float #$.Int _.I2F #$.Float]
+  [convert::int-to-long #$.Int _.I2L #$.Long]
+  [convert::int-to-short #$.Int _.I2S #$.Short]
+  [convert::long-to-double #$.Long _.L2D #$.Double]
+  [convert::long-to-float #$.Long _.L2F #$.Float]
+  [convert::long-to-int #$.Long _.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 _.I2B #$.Byte]
+  [convert::char-to-short #$.Char _.I2S #$.Short]
+  [convert::char-to-int #$.Char _.NOP #$.Int]
+  [convert::char-to-long #$.Char _.I2L #$.Long]
+  [convert::byte-to-long #$.Byte _.I2L #$.Long]
+  [convert::short-to-long #$.Short _.I2L #$.Long]
+  )
+
+(def: conversion
+  Bundle
+  (<| (bundle.prefix "convert")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "double-to-float" (unary convert::double-to-float))
+          (bundle.install "double-to-int" (unary convert::double-to-int))
+          (bundle.install "double-to-long" (unary convert::double-to-long))
+          (bundle.install "float-to-double" (unary convert::float-to-double))
+          (bundle.install "float-to-int" (unary convert::float-to-int))
+          (bundle.install "float-to-long" (unary convert::float-to-long))
+          (bundle.install "int-to-byte" (unary convert::int-to-byte))
+          (bundle.install "int-to-char" (unary convert::int-to-char))
+          (bundle.install "int-to-double" (unary convert::int-to-double))
+          (bundle.install "int-to-float" (unary convert::int-to-float))
+          (bundle.install "int-to-long" (unary convert::int-to-long))
+          (bundle.install "int-to-short" (unary convert::int-to-short))
+          (bundle.install "long-to-double" (unary convert::long-to-double))
+          (bundle.install "long-to-float" (unary convert::long-to-float))
+          (bundle.install "long-to-int" (unary convert::long-to-int))
+          (bundle.install "long-to-short" (unary convert::long-to-short))
+          (bundle.install "long-to-byte" (unary convert::long-to-byte))
+          (bundle.install "long-to-char" (unary convert::long-to-char))
+          (bundle.install "char-to-byte" (unary convert::char-to-byte))
+          (bundle.install "char-to-short" (unary convert::char-to-short))
+          (bundle.install "char-to-int" (unary convert::char-to-int))
+          (bundle.install "char-to-long" (unary convert::char-to-long))
+          (bundle.install "byte-to-long" (unary convert::byte-to-long))
+          (bundle.install "short-to-long" (unary convert::short-to-long))
+          )))
+
+(template [<name> <op> <unwrapX> <unwrapY> <wrap>]
+  [(def: (<name> [xI yI])
+     (Binary Inst)
+     (|>> xI (_.unwrap <unwrapX>)
+          yI (_.unwrap <unwrapY>)
+          <op> (_.wrap <wrap>)))]
+
+  [int::+ _.IADD #$.Int #$.Int #$.Int]
+  [int::- _.ISUB #$.Int #$.Int #$.Int]
+  [int::* _.IMUL #$.Int #$.Int #$.Int]
+  [int::/ _.IDIV #$.Int #$.Int #$.Int]
+  [int::% _.IREM #$.Int #$.Int #$.Int]
+  [int::and _.IAND #$.Int #$.Int #$.Int]
+  [int::or _.IOR #$.Int #$.Int #$.Int]
+  [int::xor _.IXOR #$.Int #$.Int #$.Int]
+  [int::shl _.ISHL #$.Int #$.Int #$.Int]
+  [int::shr _.ISHR #$.Int #$.Int #$.Int]
+  [int::ushr _.IUSHR #$.Int #$.Int #$.Int]
+  
+  [long::+ _.LADD #$.Long #$.Long #$.Long]
+  [long::- _.LSUB #$.Long #$.Long #$.Long]
+  [long::* _.LMUL #$.Long #$.Long #$.Long]
+  [long::/ _.LDIV #$.Long #$.Long #$.Long]
+  [long::% _.LREM #$.Long #$.Long #$.Long]
+  [long::and _.LAND #$.Long #$.Long #$.Long]
+  [long::or _.LOR #$.Long #$.Long #$.Long]
+  [long::xor _.LXOR #$.Long #$.Long #$.Long]
+  [long::shl _.LSHL #$.Long #$.Int #$.Long]
+  [long::shr _.LSHR #$.Long #$.Int #$.Long]
+  [long::ushr _.LUSHR #$.Long #$.Int #$.Long]
+
+  [float::+ _.FADD #$.Float #$.Float #$.Float]
+  [float::- _.FSUB #$.Float #$.Float #$.Float]
+  [float::* _.FMUL #$.Float #$.Float #$.Float]
+  [float::/ _.FDIV #$.Float #$.Float #$.Float]
+  [float::% _.FREM #$.Float #$.Float #$.Float]
+  
+  [double::+ _.DADD #$.Double #$.Double #$.Double]
+  [double::- _.DSUB #$.Double #$.Double #$.Double]
+  [double::* _.DMUL #$.Double #$.Double #$.Double]
+  [double::/ _.DDIV #$.Double #$.Double #$.Double]
+  [double::% _.DREM #$.Double #$.Double #$.Double]
+  )
+
+(def: boolean-class (_t.class "java.lang.Boolean" (list)))
+(def: falseI (_.GETSTATIC "java.lang.Boolean" "FALSE" boolean-class))
+(def: trueI (_.GETSTATIC "java.lang.Boolean" "TRUE" boolean-class))
+
+(template [<name> <op> <unwrap>]
+  [(def: (<name> [xI yI])
+     (Binary Inst)
+     (<| _.with-label (function (_ @then))
+         _.with-label (function (_ @end))
+         (|>> xI (_.unwrap <unwrap>)
+              yI (_.unwrap <unwrap>)
+              (<op> @then)
+              falseI
+              (_.GOTO @end)
+              (_.label @then)
+              trueI
+              (_.label @end))))]
+
+  [int::= _.IF_ICMPEQ #$.Int]
+  [int::< _.IF_ICMPLT #$.Int]
+
+  [char::= _.IF_ICMPEQ #$.Char]
+  [char::< _.IF_ICMPLT #$.Char]
+  )
+
+(template [<name> <op> <reference> <unwrap>]
+  [(def: (<name> [xI yI])
+     (Binary Inst)
+     (<| _.with-label (function (_ @then))
+         _.with-label (function (_ @end))
+         (|>> xI (_.unwrap <unwrap>)
+              yI (_.unwrap <unwrap>)
+              <op>
+              (_.int <reference>)
+              (_.IF_ICMPEQ @then)
+              falseI
+              (_.GOTO @end)
+              (_.label @then)
+              trueI
+              (_.label @end))))]
+
+  [long::= _.LCMP +0 #$.Long]
+  [long::< _.LCMP -1 #$.Long]
+  
+  [float::= _.FCMPG +0 #$.Float]
+  [float::< _.FCMPG -1 #$.Float]
+
+  [double::= _.DCMPG +0 #$.Double]
+  [double::< _.DCMPG -1 #$.Double]
+  )
+
+(def: int
+  Bundle
+  (<| (bundle.prefix "int")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "+" (binary int::+))
+          (bundle.install "-" (binary int::-))
+          (bundle.install "*" (binary int::*))
+          (bundle.install "/" (binary int::/))
+          (bundle.install "%" (binary int::%))
+          (bundle.install "=" (binary int::=))
+          (bundle.install "<" (binary int::<))
+          (bundle.install "and" (binary int::and))
+          (bundle.install "or" (binary int::or))
+          (bundle.install "xor" (binary int::xor))
+          (bundle.install "shl" (binary int::shl))
+          (bundle.install "shr" (binary int::shr))
+          (bundle.install "ushr" (binary int::ushr))
+          )))
+
+(def: long
+  Bundle
+  (<| (bundle.prefix "long")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "+" (binary long::+))
+          (bundle.install "-" (binary long::-))
+          (bundle.install "*" (binary long::*))
+          (bundle.install "/" (binary long::/))
+          (bundle.install "%" (binary long::%))
+          (bundle.install "=" (binary long::=))
+          (bundle.install "<" (binary long::<))
+          (bundle.install "and" (binary long::and))
+          (bundle.install "or" (binary long::or))
+          (bundle.install "xor" (binary long::xor))
+          (bundle.install "shl" (binary long::shl))
+          (bundle.install "shr" (binary long::shr))
+          (bundle.install "ushr" (binary long::ushr))
+          )))
+
+(def: float
+  Bundle
+  (<| (bundle.prefix "float")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "+" (binary float::+))
+          (bundle.install "-" (binary float::-))
+          (bundle.install "*" (binary float::*))
+          (bundle.install "/" (binary float::/))
+          (bundle.install "%" (binary float::%))
+          (bundle.install "=" (binary float::=))
+          (bundle.install "<" (binary float::<))
+          )))
+
+(def: double
+  Bundle
+  (<| (bundle.prefix "double")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "+" (binary double::+))
+          (bundle.install "-" (binary double::-))
+          (bundle.install "*" (binary double::*))
+          (bundle.install "/" (binary double::/))
+          (bundle.install "%" (binary double::%))
+          (bundle.install "=" (binary double::=))
+          (bundle.install "<" (binary double::<))
+          )))
+
+(def: char
+  Bundle
+  (<| (bundle.prefix "char")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "=" (binary char::=))
+          (bundle.install "<" (binary char::<))
+          )))
+
+(def: (array::length arrayD arrayI)
+  (Binary Inst)
+  (|>> arrayI
+       (_.CHECKCAST arrayD)
+       _.ARRAYLENGTH
+       _.I2L
+       (_.wrap #$.Long)))
+
+(def: (array::new proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.i64 level)
+             (synthesis.text class)
+             lengthS))
+    (do phase.monad
+      [lengthI (generate lengthS)
+       #let [arrayJT (_t.array (.nat 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
+                 (_.unwrap #$.Long)
+                 _.L2I
+                 (_.array arrayJT))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (array::read proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class)
+             idxS
+             arrayS))
+    (do phase.monad
+      [arrayI (generate arrayS)
+       idxI (generate idxS)
+       #let [loadI (case class
+                     "boolean" (|>> _.BALOAD (_.wrap #$.Boolean))
+                     "byte" (|>> _.BALOAD (_.wrap #$.Byte))
+                     "short" (|>> _.SALOAD (_.wrap #$.Short))
+                     "int" (|>> _.IALOAD (_.wrap #$.Int))
+                     "long" (|>> _.LALOAD (_.wrap #$.Long))
+                     "float" (|>> _.FALOAD (_.wrap #$.Float))
+                     "double" (|>> _.DALOAD (_.wrap #$.Double))
+                     "char" (|>> _.CALOAD (_.wrap #$.Char))
+                     _ _.AALOAD)]]
+      (wrap (|>> arrayI
+                 idxI
+                 (_.unwrap #$.Long)
+                 _.L2I
+                 loadI)))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (array::write proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class)
+             idxS
+             valueS
+             arrayS))
+    (do phase.monad
+      [arrayI (generate arrayS)
+       idxI (generate idxS)
+       valueI (generate valueS)
+       #let [storeI (case class
+                      "boolean" (|>> (_.unwrap #$.Boolean) _.BASTORE)
+                      "byte" (|>> (_.unwrap #$.Byte) _.BASTORE)
+                      "short" (|>> (_.unwrap #$.Short) _.SASTORE)
+                      "int" (|>> (_.unwrap #$.Int) _.IASTORE)
+                      "long" (|>> (_.unwrap #$.Long) _.LASTORE)
+                      "float" (|>> (_.unwrap #$.Float) _.FASTORE)
+                      "double" (|>> (_.unwrap #$.Double) _.DASTORE)
+                      "char" (|>> (_.unwrap #$.Char) _.CASTORE)
+                      _ _.AASTORE)]]
+      (wrap (|>> arrayI
+                 _.DUP
+                 idxI
+                 (_.unwrap #$.Long)
+                 _.L2I
+                 valueI
+                 storeI)))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: array
+  Bundle
+  (<| (bundle.prefix "array")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "length" (unary array::length))
+          (bundle.install "new" array::new)
+          (bundle.install "read" array::read)
+          (bundle.install "write" array::write)
+          )))
+
+(def: (object::null _)
+  (Nullary Inst)
+  _.NULL)
+
+(def: (object::null? objectI)
+  (Unary Inst)
+  (<| _.with-label (function (_ @then))
+      _.with-label (function (_ @end))
+      (|>> objectI
+           (_.IFNULL @then)
+           falseI
+           (_.GOTO @end)
+           (_.label @then)
+           trueI
+           (_.label @end))))
+
+(def: (object::synchronized [monitorI exprI])
+  (Binary Inst)
+  (|>> monitorI
+       _.DUP
+       _.MONITORENTER
+       exprI
+       _.SWAP
+       _.MONITOREXIT))
+
+(def: (object::throw exceptionI)
+  (Unary Inst)
+  (|>> exceptionI
+       _.ATHROW))
+
+(def: (object::class proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class)))
+    (do phase.monad
+      []
+      (wrap (|>> (_.string class)
+                 (_.INVOKESTATIC "java.lang.Class" "forName"
+                                 (_t.method (list (_t.class "java.lang.String" (list)))
+                                            (#.Some (_t.class "java.lang.Class" (list)))
+                                            (list))
+                                 false))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (object::instance? proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class) objectS))
+    (do phase.monad
+      [objectI (generate objectS)]
+      (wrap (|>> objectI
+                 (_.INSTANCEOF class)
+                 (_.wrap #$.Boolean))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (object::cast proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text from) (synthesis.text to) valueS))
+    (do phase.monad
+      [valueI (generate valueS)]
+      (case [from to]
+        ## Wrap
+        (^template [<primitive> <object> <type>]
+          [<primitive> <object>]
+          (wrap (|>> valueI (_.wrap <type>)))
+
+          [<object> <primitive>]
+          (wrap (|>> valueI (_.unwrap <type>))))
+        (["boolean" "java.lang.Boolean"   #$.Boolean]
+         ["byte"    "java.lang.Byte"      #$.Byte]
+         ["short"   "java.lang.Short"     #$.Short]
+         ["int"     "java.lang.Integer"   #$.Int]
+         ["long"    "java.lang.Long"      #$.Long]
+         ["float"   "java.lang.Float"     #$.Float]
+         ["double"  "java.lang.Double"    #$.Double]
+         ["char"    "java.lang.Character" #$.Char])
+        
+        _
+        (wrap valueI)))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: object
+  Bundle
+  (<| (bundle.prefix "object")
+      (|> (: Bundle bundle.empty)
+          (bundle.install "null" (nullary object::null))
+          (bundle.install "null?" (unary object::null?))
+          (bundle.install "synchronized" (binary object::synchronized))
+          (bundle.install "throw" (unary object::throw))
+          (bundle.install "class" object::class)
+          (bundle.install "instance?" object::instance?)
+          (bundle.install "cast" object::cast)
+          )))
+
+(def: primitives
+  (Dictionary Text Primitive)
+  (|> (list ["boolean" #$.Boolean]
+            ["byte" #$.Byte]
+            ["short" #$.Short]
+            ["int" #$.Int]
+            ["long" #$.Long]
+            ["float" #$.Float]
+            ["double" #$.Double]
+            ["char" #$.Char])
+      (dictionary.from-list text.hash)))
+
+(def: (static::get proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class)
+             (synthesis.text field)
+             (synthesis.text unboxed)))
+    (do phase.monad
+      []
+      (case (dictionary.get unboxed primitives)
+        (#.Some primitive)
+        (wrap (|>> (_.GETSTATIC class field (#$.Primitive primitive))
+                   (_.wrap primitive)))
+        
+        #.None
+        (wrap (_.GETSTATIC class field (_t.class unboxed (list))))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (static::put proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class)
+             (synthesis.text field)
+             (synthesis.text unboxed)
+             valueS))
+    (do phase.monad
+      [valueI (generate valueS)]
+      (case (dictionary.get unboxed primitives)
+        (#.Some primitive)
+        (wrap (|>> valueI
+                   (_.unwrap primitive)
+                   (_.PUTSTATIC class field (#$.Primitive primitive))
+                   (_.string synthesis.unit)))
+        
+        #.None
+        (wrap (|>> valueI
+                   (_.CHECKCAST class)
+                   (_.PUTSTATIC class field (_t.class class (list)))
+                   (_.string synthesis.unit)))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (virtual::get proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class)
+             (synthesis.text field)
+             (synthesis.text unboxed)
+             objectS))
+    (do phase.monad
+      [objectI (generate objectS)]
+      (case (dictionary.get unboxed primitives)
+        (#.Some primitive)
+        (wrap (|>> objectI
+                   (_.CHECKCAST class)
+                   (_.GETFIELD class field (#$.Primitive primitive))
+                   (_.wrap primitive)))
+        
+        #.None
+        (wrap (|>> objectI
+                   (_.CHECKCAST class)
+                   (_.GETFIELD class field (_t.class unboxed (list)))))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: (virtual::put proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list (synthesis.text class)
+             (synthesis.text field)
+             (synthesis.text unboxed)
+             valueS
+             objectS))
+    (do phase.monad
+      [valueI (generate valueS)
+       objectI (generate objectS)]
+      (case (dictionary.get unboxed primitives)
+        (#.Some primitive)
+        (wrap (|>> objectI
+                   (_.CHECKCAST class)
+                   _.DUP
+                   valueI
+                   (_.unwrap primitive)
+                   (_.PUTFIELD class field (#$.Primitive primitive))))
+        
+        #.None
+        (wrap (|>> objectI
+                   (_.CHECKCAST class)
+                   _.DUP
+                   valueI
+                   (_.CHECKCAST unboxed)
+                   (_.PUTFIELD class field (_t.class unboxed (list)))))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: base-type
+  (l.Lexer $.Type)
+  ($_ p.either
+      (p.after (l.this "boolean") (p@wrap _t.boolean))
+      (p.after (l.this "byte") (p@wrap _t.byte))
+      (p.after (l.this "short") (p@wrap _t.short))
+      (p.after (l.this "int") (p@wrap _t.int))
+      (p.after (l.this "long") (p@wrap _t.long))
+      (p.after (l.this "float") (p@wrap _t.float))
+      (p.after (l.this "double") (p@wrap _t.double))
+      (p.after (l.this "char") (p@wrap _t.char))
+      (p@map (function (_ name)
+               (_t.class name (list)))
+             (l.many (l.none-of "[")))
+      ))
+
+(def: java-type
+  (l.Lexer $.Type)
+  (do p.monad
+    [raw base-type
+     nesting (p.some (l.this "[]"))]
+    (wrap (_t.array (list.size nesting) raw))))
+
+(def: (generate-type argD)
+  (-> Text (Operation $.Type))
+  (case (l.run argD java-type)
+    (#error.Failure error)
+    (phase.throw invalid-syntax-for-jvm-type argD)
+
+    (#error.Success type)
+    (phase@wrap type)))
+
+(def: (generate-arg generate argS)
+  (-> (-> Synthesis (Operation Inst)) Synthesis
+      (Operation [$.Type Inst]))
+  (case argS
+    (^ (synthesis.tuple (list (synthesis.text argD) argS)))
+    (do phase.monad
+      [argT (generate-type argD)
+       argI (generate argS)]
+      (wrap [argT argI]))
+
+    _
+    (phase.throw invalid-syntax-for-argument-generation "")))
+
+(def: (method-return-type description)
+  (-> Text (Operation (Maybe $.Type)))
+  (case description
+    "void"
+    (phase@wrap #.None)
+
+    _
+    (phase@map (|>> #.Some) (generate-type description))))
+
+(def: (invoke::static proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list& (synthesis.text class)
+              (synthesis.text method)
+              (synthesis.text unboxed)
+              argsS))
+    (do phase.monad
+      [argsTI (monad.map @ (generate-arg generate) argsS)
+       returnT (method-return-type unboxed)]
+      (wrap (|>> (_.fuse (list@map product.right argsTI))
+                 (_.INVOKESTATIC class method
+                                 (_t.method (list@map product.left argsTI) returnT (list))
+                                 false))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(template [<name> <invoke> <interface?>]
+  [(def: (<name> proc generate inputs)
+     Handler
+     (case inputs
+       (^ (list& (synthesis.text class)
+                 (synthesis.text method)
+                 (synthesis.text unboxed)
+                 objectS
+                 argsS))
+       (do phase.monad
+         [objectI (generate objectS)
+          argsTI (monad.map @ (generate-arg generate) argsS)
+          returnT (method-return-type unboxed)]
+         (wrap (|>> objectI
+                    (_.CHECKCAST class)
+                    (_.fuse (list@map product.right argsTI))
+                    (<invoke> class method
+                              (_t.method (list@map product.left argsTI) returnT (list))
+                              <interface?>))))
+
+       _
+       (phase.throw extension.invalid-syntax [proc %synthesis inputs])))]
+
+  [invoke::virtual _.INVOKEVIRTUAL false]
+  [invoke::special _.INVOKESPECIAL false]
+  [invoke::interface _.INVOKEINTERFACE true]
+  )
+
+(def: (invoke::constructor proc generate inputs)
+  Handler
+  (case inputs
+    (^ (list& (synthesis.text class) argsS))
+    (do phase.monad
+      [argsTI (monad.map @ (generate-arg generate) argsS)]
+      (wrap (|>> (_.NEW class)
+                 _.DUP
+                 (_.fuse (list@map product.right argsTI))
+                 (_.INVOKESPECIAL class "<init>"
+                                  (_t.method (list@map product.left argsTI) #.None (list))
+                                  false))))
+
+    _
+    (phase.throw extension.invalid-syntax [proc %synthesis inputs])))
+
+(def: member
+  Bundle
+  (<| (bundle.prefix "member")
+      (|> (: Bundle bundle.empty)
+          (dictionary.merge (<| (bundle.prefix "static")
+                                (|> (: Bundle bundle.empty)
+                                    (bundle.install "get" static::get)
+                                    (bundle.install "put" static::put))))
+          (dictionary.merge (<| (bundle.prefix "virtual")
+                                (|> (: Bundle bundle.empty)
+                                    (bundle.install "get" virtual::get)
+                                    (bundle.install "put" virtual::put))))
+          (dictionary.merge (<| (bundle.prefix "invoke")
+                                (|> (: Bundle bundle.empty)
+                                    (bundle.install "static" invoke::static)
+                                    (bundle.install "virtual" invoke::virtual)
+                                    (bundle.install "special" invoke::special)
+                                    (bundle.install "interface" invoke::interface)
+                                    (bundle.install "constructor" invoke::constructor))))
+          )))
+
+(def: #export bundle
+  Bundle
+  (<| (bundle.prefix "jvm")
+      (|> ..conversion
+          (dictionary.merge ..int)
+          (dictionary.merge ..long)
+          (dictionary.merge ..float)
+          (dictionary.merge ..double)
+          (dictionary.merge ..char)
+          (dictionary.merge ..array)
+          (dictionary.merge ..object)
+          (dictionary.merge ..member)
+          )))
-- 
cgit v1.2.3