Ported JVM host extension generation to the new JVM bytecode machinery.

4 files changed, 1088 insertions, 4 deletions

diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux
index 49b4c0297..d21cbc1c2 100644
--- a/stdlib/source/lux/target/jvm/type/alias.lux
+++ b/stdlib/source/lux/target/jvm/type/alias.lux
@@ -12,7 +12,6 @@
     ["." text
      ["%" format (#+ format)]]
     [collection
-     [array (#+ Array)]
      ["." dictionary (#+ Dictionary)]]]]
   ["." // (#+ Type)
    [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
index 8202fd101..c4481998e 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -1,5 +1,5 @@
 (.module:
-  [lux (#- Type primitive type char int)
+  [lux (#- Type Module primitive type char int)
    ["." host (#+ import:)]
    ["." macro]
    [abstract
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux
index b7cc9c9fe..d436d1974 100644
--- a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension.lux
@@ -5,7 +5,7 @@
      ["." dictionary]]]]
   ["." / #_
    ["#." common]
-   ## ["#." host]
+   ["#." host]
    [//
     [runtime (#+ Bundle)]]])
 
@@ -13,5 +13,5 @@
   Bundle
   ($_ dictionary.merge
       /common.bundle
-      ## /host.bundle
+      /host.bundle
       ))
diff --git a/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux
new file mode 100644
index 000000000..7b14d2c07
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/generation/jvm/extension/host.lux
@@ -0,0 +1,1085 @@
+(.module:
+  [lux (#- Type)
+   [abstract
+    ["." monad (#+ do)]]
+   [control
+    ["." try]
+    ["." exception (#+ exception:)]
+    ["<>" parser
+     ["<t>" text]
+     ["<s>" synthesis (#+ Parser)]]]
+   [data
+    ["." product]
+    ["." maybe]
+    ["." text ("#@." equivalence)]
+    [number
+     ["." i32]]
+    [collection
+     ["." list ("#@." monad)]
+     ["." dictionary (#+ Dictionary)]
+     ["." set]
+     ["." row]]
+    ["." format #_
+     ["#" binary]]]
+   [target
+    [jvm
+     ["." version]
+     ["." modifier ("#@." monoid)]
+     ["." method (#+ Method)]
+     ["." class (#+ Class)]
+     [constant
+      [pool (#+ Resource)]]
+     [encoding
+      ["." name]]
+     ["_" bytecode (#+ Label Bytecode) ("#@." monad)
+      ["__" instruction (#+ Primitive-Array-Type)]]
+     ["." type (#+ Type Typed Argument)
+      ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)]
+      ["." box]
+      ["." reflection]
+      ["." signature]
+      ["." parser]]]]]
+  ["." // #_
+   [common (#+ custom)]
+   ["/#" //
+    [runtime (#+ Operation Bundle Handler)]
+    ["#." reference]
+    [function
+     [field
+      [variable
+       ["." foreign]]]]
+    ["//#" ///
+     ["." generation
+      [extension (#+ Nullary Unary Binary Trinary Variadic
+                     nullary unary binary trinary variadic)]]
+     [extension
+      ["#." bundle]
+      [analysis
+       ["/" jvm]]]
+     ["/#" //
+      [analysis (#+ Environment)]
+      ["#." reference (#+ Variable)]
+      ["#." synthesis (#+ Synthesis Path %synthesis)]]]]])
+
+(template [<name> <0> <1>]
+  [(def: <name>
+     (Bytecode Any)
+     ($_ _.compose
+         <0>
+         <1>))]
+
+  [l2s _.l2i _.i2s]
+  [l2b _.l2i _.i2b]
+  [l2c _.l2i _.i2c]
+  )
+
+(template [<conversion> <name>]
+  [(def: (<name> inputG)
+     (Unary (Bytecode Any))
+     (if (is? _.nop <conversion>)
+       inputG
+       ($_ _.compose
+           inputG
+           <conversion>)))]
+  
+  [_.d2f conversion::double-to-float]
+  [_.d2i conversion::double-to-int]
+  [_.d2l conversion::double-to-long]
+  [_.f2d conversion::float-to-double]
+  [_.f2i conversion::float-to-int]
+  [_.f2l conversion::float-to-long]
+  [_.i2b conversion::int-to-byte]
+  [_.i2c conversion::int-to-char]
+  [_.i2d conversion::int-to-double]
+  [_.i2f conversion::int-to-float]
+  [_.i2l conversion::int-to-long]
+  [_.i2s conversion::int-to-short]
+  [_.l2d conversion::long-to-double]
+  [_.l2f conversion::long-to-float]
+  [_.l2i conversion::long-to-int]
+  [..l2s conversion::long-to-short]
+  [..l2b conversion::long-to-byte]
+  [..l2c conversion::long-to-char]
+  [_.i2b conversion::char-to-byte]
+  [_.i2s conversion::char-to-short]
+  [_.nop conversion::char-to-int]
+  [_.i2l conversion::char-to-long]
+  [_.i2l conversion::byte-to-long]
+  [_.i2l conversion::short-to-long]
+  )
+
+(def: bundle::conversion
+  Bundle
+  (<| (/////bundle.prefix "conversion")
+      (|> (: Bundle /////bundle.empty)
+          (/////bundle.install "double-to-float" (unary conversion::double-to-float))
+          (/////bundle.install "double-to-int" (unary conversion::double-to-int))
+          (/////bundle.install "double-to-long" (unary conversion::double-to-long))
+          (/////bundle.install "float-to-double" (unary conversion::float-to-double))
+          (/////bundle.install "float-to-int" (unary conversion::float-to-int))
+          (/////bundle.install "float-to-long" (unary conversion::float-to-long))
+          (/////bundle.install "int-to-byte" (unary conversion::int-to-byte))
+          (/////bundle.install "int-to-char" (unary conversion::int-to-char))
+          (/////bundle.install "int-to-double" (unary conversion::int-to-double))
+          (/////bundle.install "int-to-float" (unary conversion::int-to-float))
+          (/////bundle.install "int-to-long" (unary conversion::int-to-long))
+          (/////bundle.install "int-to-short" (unary conversion::int-to-short))
+          (/////bundle.install "long-to-double" (unary conversion::long-to-double))
+          (/////bundle.install "long-to-float" (unary conversion::long-to-float))
+          (/////bundle.install "long-to-int" (unary conversion::long-to-int))
+          (/////bundle.install "long-to-short" (unary conversion::long-to-short))
+          (/////bundle.install "long-to-byte" (unary conversion::long-to-byte))
+          (/////bundle.install "long-to-char" (unary conversion::long-to-char))
+          (/////bundle.install "char-to-byte" (unary conversion::char-to-byte))
+          (/////bundle.install "char-to-short" (unary conversion::char-to-short))
+          (/////bundle.install "char-to-int" (unary conversion::char-to-int))
+          (/////bundle.install "char-to-long" (unary conversion::char-to-long))
+          (/////bundle.install "byte-to-long" (unary conversion::byte-to-long))
+          (/////bundle.install "short-to-long" (unary conversion::short-to-long))
+          )))
+
+(template [<name> <op>]
+  [(def: (<name> [xG yG])
+     (Binary (Bytecode Any))
+     ($_ _.compose
+         xG
+         yG
+         <op>))]
+
+  [int::+ _.iadd]
+  [int::- _.isub]
+  [int::* _.imul]
+  [int::/ _.idiv]
+  [int::% _.irem]
+  [int::and _.iand]
+  [int::or _.ior]
+  [int::xor _.ixor]
+  [int::shl _.ishl]
+  [int::shr _.ishr]
+  [int::ushr _.iushr]
+  
+  [long::+ _.ladd]
+  [long::- _.lsub]
+  [long::* _.lmul]
+  [long::/ _.ldiv]
+  [long::% _.lrem]
+  [long::and _.land]
+  [long::or _.lor]
+  [long::xor _.lxor]
+  [long::shl _.lshl]
+  [long::shr _.lshr]
+  [long::ushr _.lushr]
+
+  [float::+ _.fadd]
+  [float::- _.fsub]
+  [float::* _.fmul]
+  [float::/ _.fdiv]
+  [float::% _.frem]
+  
+  [double::+ _.dadd]
+  [double::- _.dsub]
+  [double::* _.dmul]
+  [double::/ _.ddiv]
+  [double::% _.drem]
+  )
+
+(def: $Boolean (type.class box.boolean (list)))
+(def: falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean))
+(def: trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean))
+
+(template [<name> <op>]
+  [(def: (<name> [xG yG])
+     (Binary (Bytecode Any))
+     (do _.monad
+       [@then _.new-label
+        @end _.new-label]
+       ($_ _.compose
+           xG
+           yG
+           (<op> @then)
+           falseG
+           (_.goto @end)
+           (_.set-label @then)
+           trueG
+           (_.set-label @end))))]
+
+  [int::= _.if-icmpeq]
+  [int::< _.if-icmplt]
+
+  [char::= _.if-icmpeq]
+  [char::< _.if-icmplt]
+  )
+
+(template [<name> <op> <reference>]
+  [(def: (<name> [xG yG])
+     (Binary (Bytecode Any))
+     (do _.monad
+       [@then _.new-label
+        @end _.new-label]
+       ($_ _.compose
+           xG
+           yG
+           <op>
+           (_.int (i32.i32 (.i64 <reference>)))
+           (_.if-icmpeq @then)
+           falseG
+           (_.goto @end)
+           (_.set-label @then)
+           trueG
+           (_.set-label @end))))]
+
+  [long::= _.lcmp +0]
+  [long::< _.lcmp -1]
+  
+  [float::= _.fcmpg +0]
+  [float::< _.fcmpg -1]
+
+  [double::= _.dcmpg +0]
+  [double::< _.dcmpg -1]
+  )
+
+(def: bundle::int
+  Bundle
+  (<| (/////bundle.prefix (reflection.reflection reflection.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: bundle::long
+  Bundle
+  (<| (/////bundle.prefix (reflection.reflection reflection.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: bundle::float
+  Bundle
+  (<| (/////bundle.prefix (reflection.reflection reflection.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: bundle::double
+  Bundle
+  (<| (/////bundle.prefix (reflection.reflection reflection.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: bundle::char
+  Bundle
+  (<| (/////bundle.prefix (reflection.reflection reflection.char))
+      (|> (: Bundle /////bundle.empty)
+          (/////bundle.install "=" (binary char::=))
+          (/////bundle.install "<" (binary char::<))
+          )))
+
+(template [<name> <category> <parser>]
+  [(def: #export <name>
+     (Parser (Type <category>))
+     (<t>.embed <parser> <s>.text))]
+
+  [var Var parser.var]
+  [class category.Class parser.class]
+  [object Object parser.object]
+  [value Value parser.value]
+  [return Return parser.return]
+  )
+
+(exception: #export (not-an-object-array {arrayJT (Type Array)})
+  (exception.report
+   ["JVM Type" (|> arrayJT type.signature signature.signature)]))
+
+(def: #export object-array
+  (Parser (Type Object))
+  (do <>.monad
+    [arrayJT (<t>.embed parser.array <s>.text)]
+    (case (parser.array? arrayJT)
+      (#.Some elementJT)
+      (case (parser.object? elementJT)
+        (#.Some elementJT)
+        (wrap elementJT)
+
+        #.None
+        (<>.fail (exception.construct ..not-an-object-array arrayJT)))
+      
+      #.None
+      (undefined))))
+
+(def: (primitive-array-length-handler jvm-primitive)
+  (-> (Type Primitive) Handler)
+  (..custom
+   [<s>.any
+    (function (_ extension-name generate arrayS)
+      (do /////.monad
+        [arrayG (generate arrayS)]
+        (wrap ($_ _.compose
+                  arrayG
+                  (_.checkcast (type.array jvm-primitive))
+                  _.arraylength))))]))
+
+(def: array::length::object
+  Handler
+  (..custom
+   [($_ <>.and ..object-array <s>.any)
+    (function (_ extension-name generate [elementJT arrayS])
+      (do /////.monad
+        [arrayG (generate arrayS)]
+        (wrap ($_ _.compose
+                  arrayG
+                  (_.checkcast (type.array elementJT))
+                  _.arraylength))))]))
+
+(def: (new-primitive-array-handler jvm-primitive)
+  (-> Primitive-Array-Type Handler)
+  (..custom
+   [<s>.any
+    (function (_ extension-name generate [lengthS])
+      (do /////.monad
+        [lengthG (generate lengthS)]
+        (wrap ($_ _.compose
+                  lengthG
+                  (_.newarray jvm-primitive)))))]))
+
+(def: array::new::object
+  Handler
+  (..custom
+   [($_ <>.and ..object <s>.any)
+    (function (_ extension-name generate [objectJT lengthS])
+      (do /////.monad
+        [lengthG (generate lengthS)]
+        (wrap ($_ _.compose
+                  lengthG
+                  (_.anewarray objectJT)))))]))
+
+(def: (read-primitive-array-handler jvm-primitive loadG)
+  (-> (Type Primitive) (Bytecode Any) Handler)
+  (..custom
+   [($_ <>.and <s>.any <s>.any)
+    (function (_ extension-name generate [idxS arrayS])
+      (do /////.monad
+        [arrayG (generate arrayS)
+         idxG (generate idxS)]
+        (wrap ($_ _.compose
+                  arrayG
+                  (_.checkcast (type.array jvm-primitive))
+                  idxG
+                  loadG))))]))
+
+(def: array::read::object
+  Handler
+  (..custom
+   [($_ <>.and ..object-array <s>.any <s>.any)
+    (function (_ extension-name generate [elementJT idxS arrayS])
+      (do /////.monad
+        [arrayG (generate arrayS)
+         idxG (generate idxS)]
+        (wrap ($_ _.compose
+                  arrayG
+                  (_.checkcast (type.array elementJT))
+                  idxG
+                  _.aaload))))]))
+
+(def: (write-primitive-array-handler jvm-primitive storeG)
+  (-> (Type Primitive) (Bytecode Any) Handler)
+  (..custom
+   [($_ <>.and <s>.any <s>.any <s>.any)
+    (function (_ extension-name generate [idxS valueS arrayS])
+      (do /////.monad
+        [arrayG (generate arrayS)
+         idxG (generate idxS)
+         valueG (generate valueS)]
+        (wrap ($_ _.compose
+                  arrayG
+                  (_.checkcast (type.array jvm-primitive))
+                  _.dup
+                  idxG
+                  valueG
+                  storeG))))]))
+
+(def: array::write::object
+  Handler
+  (..custom
+   [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
+    (function (_ extension-name generate [elementJT idxS valueS arrayS])
+      (do /////.monad
+        [arrayG (generate arrayS)
+         idxG (generate idxS)
+         valueG (generate valueS)]
+        (wrap ($_ _.compose
+                  arrayG
+                  (_.checkcast (type.array elementJT))
+                  _.dup
+                  idxG
+                  valueG
+                  _.aastore))))]))
+
+(def: bundle::array
+  Bundle
+  (<| (/////bundle.prefix "array")
+      (|> /////bundle.empty
+          (dictionary.merge (<| (/////bundle.prefix "length")
+                                (|> /////bundle.empty
+                                    (/////bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler type.boolean))
+                                    (/////bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler type.byte))
+                                    (/////bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler type.short))
+                                    (/////bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler type.int))
+                                    (/////bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler type.long))
+                                    (/////bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler type.float))
+                                    (/////bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler type.double))
+                                    (/////bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler type.char))
+                                    (/////bundle.install "object" array::length::object))))
+          (dictionary.merge (<| (/////bundle.prefix "new")
+                                (|> /////bundle.empty
+                                    (/////bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler __.t-boolean))
+                                    (/////bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler __.t-byte))
+                                    (/////bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler __.t-short))
+                                    (/////bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler __.t-int))
+                                    (/////bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler __.t-long))
+                                    (/////bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler __.t-float))
+                                    (/////bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler __.t-double))
+                                    (/////bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler __.t-char))
+                                    (/////bundle.install "object" array::new::object))))
+          (dictionary.merge (<| (/////bundle.prefix "read")
+                                (|> /////bundle.empty
+                                    (/////bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler type.boolean _.baload))
+                                    (/////bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler type.byte _.baload))
+                                    (/////bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler type.short _.saload))
+                                    (/////bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler type.int _.iaload))
+                                    (/////bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler type.long _.laload))
+                                    (/////bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler type.float _.faload))
+                                    (/////bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler type.double _.daload))
+                                    (/////bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler type.char _.caload))
+                                    (/////bundle.install "object" array::read::object))))
+          (dictionary.merge (<| (/////bundle.prefix "write")
+                                (|> /////bundle.empty
+                                    (/////bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler type.boolean _.bastore))
+                                    (/////bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler type.byte _.bastore))
+                                    (/////bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler type.short _.sastore))
+                                    (/////bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler type.int _.iastore))
+                                    (/////bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler type.long _.lastore))
+                                    (/////bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler type.float _.fastore))
+                                    (/////bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler type.double _.dastore))
+                                    (/////bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler type.char _.castore))
+                                    (/////bundle.install "object" array::write::object))))
+          )))
+
+(def: (object::null _)
+  (Nullary (Bytecode Any))
+  _.aconst-null)
+
+(def: (object::null? objectG)
+  (Unary (Bytecode Any))
+  (do _.monad
+    [@then _.new-label
+     @end _.new-label]
+    ($_ _.compose
+        objectG
+        (_.ifnull @then)
+        ..falseG
+        (_.goto @end)
+        (_.set-label @then)
+        ..trueG
+        (_.set-label @end))))
+
+(def: (object::synchronized [monitorG exprG])
+  (Binary (Bytecode Any))
+  ($_ _.compose
+      monitorG
+      _.dup
+      _.monitorenter
+      exprG
+      _.swap
+      _.monitorexit))
+
+(def: (object::throw exceptionG)
+  (Unary (Bytecode Any))
+  ($_ _.compose
+      exceptionG
+      _.athrow))
+
+(def: $Class (type.class "java.lang.Class" (list)))
+(def: $String (type.class "java.lang.String" (list)))
+
+(def: object::class
+  Handler
+  (..custom
+   [<s>.text
+    (function (_ extension-name generate [class])
+      (do /////.monad
+        []
+        (wrap ($_ _.compose
+                  (_.string class)
+                  (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))]))
+
+(def: object::instance?
+  Handler
+  (..custom
+   [($_ <>.and <s>.text <s>.any)
+    (function (_ extension-name generate [class objectS])
+      (do /////.monad
+        [objectG (generate objectS)]
+        (wrap ($_ _.compose
+                  objectG
+                  (_.instanceof (type.class class (list)))
+                  (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))]))
+
+(def: reflection
+  (All [category]
+    (-> (Type (<| Return' Value' category)) Text))
+  (|>> type.reflection reflection.reflection))
+
+(def: object::cast
+  Handler
+  (..custom
+   [($_ <>.and <s>.text <s>.text <s>.any)
+    (function (_ extension-name generate [from to valueS])
+      (do /////.monad
+        [valueG (generate valueS)]
+        (wrap (`` (cond (~~ (template [<object> <type> <unwrap>]
+                              [(and (text@= (..reflection <type>)
+                                            from)
+                                    (text@= <object>
+                                            to))
+                               (let [$<object> (type.class <object> (list))]
+                                 ($_ _.compose
+                                     valueG
+                                     (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)]))))
+
+                               (and (text@= <object>
+                                            from)
+                                    (text@= (..reflection <type>)
+                                            to))
+                               (let [$<object> (type.class <object> (list))]
+                                 ($_ _.compose
+                                     valueG
+                                     (_.checkcast $<object>)
+                                     (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))]
+                              
+                              [box.boolean type.boolean "booleanValue"]
+                              [box.byte    type.byte    "byteValue"]
+                              [box.short   type.short   "shortValue"]
+                              [box.int     type.int     "intValue"]
+                              [box.long    type.long    "longValue"]
+                              [box.float   type.float   "floatValue"]
+                              [box.double  type.double  "doubleValue"]
+                              [box.char    type.char    "charValue"]))
+                        ## else
+                        valueG)))))]))
+
+(def: bundle::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 (Type Primitive))
+  (|> (list [(reflection.reflection reflection.boolean) type.boolean]
+            [(reflection.reflection reflection.byte) type.byte]
+            [(reflection.reflection reflection.short) type.short]
+            [(reflection.reflection reflection.int) type.int]
+            [(reflection.reflection reflection.long) type.long]
+            [(reflection.reflection reflection.float) type.float]
+            [(reflection.reflection reflection.double) type.double]
+            [(reflection.reflection reflection.char) type.char])
+      (dictionary.from-list text.hash)))
+
+(def: get::static
+  Handler
+  (..custom
+   [($_ <>.and <s>.text <s>.text <s>.text)
+    (function (_ extension-name generate [class field unboxed])
+      (do /////.monad
+        [#let [$class (type.class class (list))]]
+        (case (dictionary.get unboxed ..primitives)
+          (#.Some primitive)
+          (wrap (_.getstatic $class field primitive))
+          
+          #.None
+          (wrap (_.getstatic $class field (type.class unboxed (list)))))))]))
+
+(def: unitG (_.string //////synthesis.unit))
+
+(def: put::static
+  Handler
+  (..custom
+   [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+    (function (_ extension-name generate [class field unboxed valueS])
+      (do /////.monad
+        [valueG (generate valueS)
+         #let [$class (type.class class (list))]]
+        (case (dictionary.get unboxed ..primitives)
+          (#.Some primitive)
+          (wrap ($_ _.compose
+                    valueG
+                    (_.putstatic $class field primitive)
+                    ..unitG))
+          
+          #.None
+          (wrap ($_ _.compose
+                    valueG
+                    (_.checkcast $class)
+                    (_.putstatic $class field $class)
+                    ..unitG)))))]))
+
+(def: get::virtual
+  Handler
+  (..custom
+   [($_ <>.and <s>.text <s>.text <s>.text <s>.any)
+    (function (_ extension-name generate [class field unboxed objectS])
+      (do /////.monad
+        [objectG (generate objectS)
+         #let [$class (type.class class (list))
+               getG (case (dictionary.get unboxed ..primitives)
+                      (#.Some primitive)
+                      (_.getfield $class field primitive)
+                      
+                      #.None
+                      (_.getfield $class field (type.class unboxed (list))))]]
+        (wrap ($_ _.compose
+                  objectG
+                  (_.checkcast $class)
+                  getG))))]))
+
+(def: put::virtual
+  Handler
+  (..custom
+   [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
+    (function (_ extension-name generate [class field unboxed valueS objectS])
+      (do /////.monad
+        [valueG (generate valueS)
+         objectG (generate objectS)
+         #let [$class (type.class class (list))
+               putG (case (dictionary.get unboxed ..primitives)
+                      (#.Some primitive)
+                      (_.putfield $class field primitive)
+                      
+                      #.None
+                      (let [$unboxed (type.class unboxed (list))]
+                        ($_ _.compose
+                            (_.checkcast $unboxed)
+                            (_.putfield $class field $unboxed))))]]
+        (wrap ($_ _.compose
+                  objectG
+                  (_.checkcast $class)
+                  _.dup
+                  valueG
+                  putG))))]))
+
+(type: Input (Typed Synthesis))
+
+(def: input
+  (Parser Input)
+  (<s>.tuple (<>.and ..value <s>.any)))
+
+(def: (generate-input generate [valueT valueS])
+  (-> (-> Synthesis (Operation (Bytecode Any))) Input
+      (Operation (Typed (Bytecode Any))))
+  (do /////.monad
+    [valueG (generate valueS)]
+    (case (type.primitive? valueT)
+      (#.Right valueT)
+      (wrap [valueT valueG])
+      
+      (#.Left valueT)
+      (wrap [valueT ($_ _.compose
+                        valueG
+                        (_.checkcast valueT))]))))
+
+(def: (prepare-output outputT)
+  (-> (Type Return) (Bytecode Any))
+  (case (type.void? outputT)
+    (#.Right outputT)
+    ..unitG
+    
+    (#.Left outputT)
+    (:: _.monad wrap [])))
+
+(def: invoke::static
+  Handler
+  (..custom
+   [($_ <>.and ..class <s>.text ..return (<>.some ..input))
+    (function (_ extension-name generate [class method outputT inputsTS])
+      (do /////.monad
+        [inputsTG (monad.map @ (generate-input generate) inputsTS)]
+        (wrap ($_ _.compose
+                  (monad.map _.monad product.right inputsTG)
+                  (_.invokestatic class method (type.method [(list@map product.left inputsTG) outputT (list)]))
+                  (prepare-output outputT)))))]))
+
+(template [<name> <invoke>]
+  [(def: <name>
+     Handler
+     (..custom
+      [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input))
+       (function (_ extension-name generate [class method outputT objectS inputsTS])
+         (do /////.monad
+           [objectG (generate objectS)
+            inputsTG (monad.map @ (generate-input generate) inputsTS)]
+           (wrap ($_ _.compose
+                     objectG
+                     (_.checkcast class)
+                     (monad.map _.monad product.right inputsTG)
+                     (<invoke> class method (type.method [(list@map product.left inputsTG) outputT (list)]))
+                     (prepare-output outputT)))))]))]
+
+  [invoke::virtual _.invokevirtual]
+  [invoke::special _.invokespecial]
+  [invoke::interface _.invokeinterface]
+  )
+
+(def: invoke::constructor
+  Handler
+  (..custom
+   [($_ <>.and ..class (<>.some ..input))
+    (function (_ extension-name generate [class inputsTS])
+      (do /////.monad
+        [inputsTG (monad.map @ (generate-input generate) inputsTS)]
+        (wrap ($_ _.compose
+                  (_.new class)
+                  _.dup
+                  (monad.map _.monad product.right inputsTG)
+                  (_.invokespecial class "<init>" (type.method [(list@map product.left inputsTG) type.void (list)]))))))]))
+
+(def: bundle::member
+  Bundle
+  (<| (/////bundle.prefix "member")
+      (|> (: Bundle /////bundle.empty)
+          (dictionary.merge (<| (/////bundle.prefix "get")
+                                (|> (: Bundle /////bundle.empty)
+                                    (/////bundle.install "static" get::static)
+                                    (/////bundle.install "virtual" get::virtual))))
+          (dictionary.merge (<| (/////bundle.prefix "put")
+                                (|> (: Bundle /////bundle.empty)
+                                    (/////bundle.install "static" put::static)
+                                    (/////bundle.install "virtual" put::virtual))))
+          (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: annotation-parameter
+  (Parser (/.Annotation-Parameter Synthesis))
+  (<s>.tuple (<>.and <s>.text <s>.any)))
+
+(def: annotation
+  (Parser (/.Annotation Synthesis))
+  (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
+
+(def: argument
+  (Parser Argument)
+  (<s>.tuple (<>.and <s>.text ..value)))
+
+(def: overriden-method-definition
+  (Parser [Environment (/.Overriden-Method Synthesis)])
+  (<s>.tuple (do <>.monad
+               [_ (<s>.text! /.overriden-tag)
+                ownerT ..class
+                name <s>.text
+                strict-fp? <s>.bit
+                annotations (<s>.tuple (<>.some ..annotation))
+                vars (<s>.tuple (<>.some ..var))
+                self-name <s>.text
+                arguments (<s>.tuple (<>.some ..argument))
+                returnT ..return
+                exceptionsT (<s>.tuple (<>.some ..class))
+                [environment body] (<s>.function 1
+                                     (<s>.tuple <s>.any))]
+               (wrap [environment
+                      [ownerT name
+                       strict-fp? annotations vars
+                       self-name arguments returnT exceptionsT
+                       body]]))))
+
+(def: (normalize-path normalize)
+  (-> (-> Synthesis Synthesis)
+      (-> Path Path))
+  (function (recur path)
+    (case path
+      (^ (//////synthesis.path/then bodyS))
+      (//////synthesis.path/then (normalize bodyS))
+
+      (^template [<tag>]
+        (^ (<tag> leftP rightP))
+        (<tag> (recur leftP) (recur rightP)))
+      ([#//////synthesis.Alt]
+       [#//////synthesis.Seq])
+
+      (^template [<tag>]
+        (^ (<tag> value))
+        path)
+      ([#//////synthesis.Pop]
+       [#//////synthesis.Test]
+       [#//////synthesis.Bind]
+       [#//////synthesis.Access]))))
+
+(def: (normalize-method-body mapping)
+  (-> (Dictionary Variable Variable) Synthesis Synthesis)
+  (function (recur body)
+    (case body
+      (^template [<tag>]
+        (^ (<tag> value))
+        body)
+      ([#//////synthesis.Primitive]
+       [//////synthesis.constant])
+
+      (^ (//////synthesis.variant [lefts right? sub]))
+      (//////synthesis.variant [lefts right? (recur sub)])
+
+      (^ (//////synthesis.tuple members))
+      (//////synthesis.tuple (list@map recur members))
+
+      (^ (//////synthesis.variable var))
+      (|> mapping
+          (dictionary.get var)
+          (maybe.default var)
+          //////synthesis.variable)
+
+      (^ (//////synthesis.branch/case [inputS pathS]))
+      (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)])
+
+      (^ (//////synthesis.branch/let [inputS register outputS]))
+      (//////synthesis.branch/let [(recur inputS) register (recur outputS)])
+
+      (^ (//////synthesis.branch/if [testS thenS elseS]))
+      (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)])
+
+      (^ (//////synthesis.loop/scope [offset initsS+ bodyS]))
+      (//////synthesis.loop/scope [offset (list@map recur initsS+) (recur bodyS)])
+
+      (^ (//////synthesis.loop/recur updatesS+))
+      (//////synthesis.loop/recur (list@map recur updatesS+))
+
+      (^ (//////synthesis.function/abstraction [environment arity bodyS]))
+      (//////synthesis.function/abstraction [(|> environment (list@map (function (_ local)
+                                                                         (|> mapping
+                                                                             (dictionary.get local)
+                                                                             (maybe.default local)))))
+                                             arity
+                                             bodyS])
+
+      (^ (//////synthesis.function/apply [functionS inputsS+]))
+      (//////synthesis.function/apply [(recur functionS) (list@map recur inputsS+)])
+
+      (#//////synthesis.Extension [name inputsS+])
+      (#//////synthesis.Extension [name (list@map recur inputsS+)]))))
+
+(def: $Object (type.class "java.lang.Object" (list)))
+
+(def: (anonymous-init-method env)
+  (-> Environment (Type category.Method))
+  (type.method [(list.repeat (list.size env) ..$Object)
+                type.void
+                (list)]))
+
+(def: (with-anonymous-init class env super-class inputsTG)
+  (-> (Type category.Class) Environment (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method))
+  (let [store-capturedG (|> env
+                            list.size
+                            list.indices
+                            (monad.map _.monad (.function (_ register)
+                                                 ($_ _.compose
+                                                     (_.aload 0)
+                                                     (_.aload (inc register))
+                                                     (_.putfield class (///reference.foreign-name register) $Object)))))]
+    (method.method method.public "<init>" (anonymous-init-method env)
+                   (list)
+                   (#.Some ($_ _.compose
+                               (_.aload 0)
+                               (monad.map _.monad product.right inputsTG)
+                               (_.invokespecial super-class "<init>" (type.method [(list@map product.left inputsTG) type.void (list)]))
+                               store-capturedG
+                               _.return)))))
+
+(def: (anonymous-instance class env)
+  (-> (Type category.Class) Environment (Operation (Bytecode Any)))
+  (do /////.monad
+    [captureG+ (monad.map @ ///reference.variable env)]
+    (wrap ($_ _.compose
+              (_.new class)
+              _.dup
+              (monad.seq _.monad captureG+)
+              (_.invokespecial class "<init>" (anonymous-init-method env))))))
+
+(def: (returnG returnT)
+  (-> (Type Return) (Bytecode Any))
+  (case (type.void? returnT)
+    (#.Right returnT)
+    _.return
+
+    (#.Left returnT)
+    (case (type.primitive? returnT)
+      (#.Left returnT)
+      ($_ _.compose
+          (_.checkcast returnT)
+          _.areturn)
+      
+      (#.Right returnT)
+      (cond (or (:: type.equivalence = type.boolean returnT)
+                (:: type.equivalence = type.byte returnT)
+                (:: type.equivalence = type.short returnT)
+                (:: type.equivalence = type.int returnT)
+                (:: type.equivalence = type.char returnT))
+            _.ireturn
+
+            (:: type.equivalence = type.long returnT)
+            _.lreturn
+
+            (:: type.equivalence = type.float returnT)
+            _.freturn
+
+            ## (:: type.equivalence = type.double returnT)
+            _.dreturn))))
+
+(def: class::anonymous
+  Handler
+  (..custom
+   [($_ <>.and
+        <s>.text
+        ..class
+        (<s>.tuple (<>.some ..class))
+        (<s>.tuple (<>.some ..input))
+        (<s>.tuple (<>.some ..overriden-method-definition)))
+    (function (_ extension-name generate [class-name
+                                          super-class super-interfaces
+                                          inputsTS
+                                          overriden-methods])
+      (do /////.monad
+        [#let [class (type.class class-name (list))
+               total-environment (|> overriden-methods
+                                     ## Get all the environments.
+                                     (list@map product.left)
+                                     ## Combine them.
+                                     list@join
+                                     ## Remove duplicates.
+                                     (set.from-list //////reference.hash)
+                                     set.to-list)
+               global-mapping (|> total-environment
+                                  ## Give them names as "foreign" variables.
+                                  list.enumerate
+                                  (list@map (function (_ [id capture])
+                                              [capture (#//////reference.Foreign id)]))
+                                  (dictionary.from-list //////reference.hash))
+               normalized-methods (list@map (function (_ [environment
+                                                          [ownerT name
+                                                           strict-fp? annotations vars
+                                                           self-name arguments returnT exceptionsT
+                                                           body]])
+                                              (let [local-mapping (|> environment
+                                                                      list.enumerate
+                                                                      (list@map (function (_ [foreign-id capture])
+                                                                                  [(#//////reference.Foreign foreign-id)
+                                                                                   (|> global-mapping
+                                                                                       (dictionary.get capture)
+                                                                                       maybe.assume)]))
+                                                                      (dictionary.from-list //////reference.hash))]
+                                                [ownerT name
+                                                 strict-fp? annotations vars
+                                                 self-name arguments returnT exceptionsT
+                                                 (normalize-method-body local-mapping body)]))
+                                            overriden-methods)]
+         inputsTI (monad.map @ (generate-input generate) inputsTS)
+         method-definitions (monad.map @ (function (_ [ownerT name
+                                                       strict-fp? annotations vars
+                                                       self-name arguments returnT exceptionsT
+                                                       bodyS])
+                                           (do @
+                                             [bodyG (generation.with-specific-context class-name
+                                                      (generate bodyS))]
+                                             (wrap (method.method ($_ modifier@compose
+                                                                      method.public
+                                                                      method.final
+                                                                      (if strict-fp?
+                                                                        method.strict
+                                                                        modifier@identity))
+                                                                  name
+                                                                  (type.method [(list@map product.right arguments)
+                                                                                returnT
+                                                                                exceptionsT])
+                                                                  (list)
+                                                                  (#.Some ($_ _.compose
+                                                                              bodyG
+                                                                              (returnG returnT)))))))
+                                       normalized-methods)
+         bytecode (<| (:: @ map (format.run class.writer))
+                      /////.lift
+                      (class.class version.v6_0 ($_ modifier@compose class.public class.final)
+                                   (name.internal class-name)
+                                   (name.internal (..reflection super-class))
+                                   (list@map (|>> ..reflection name.internal) super-interfaces)
+                                   (foreign.variables total-environment)
+                                   (list& (..with-anonymous-init class total-environment super-class inputsTI)
+                                          method-definitions)
+                                   (row.row)))
+         _ (generation.save! true ["" class-name] [class-name bytecode])]
+        (anonymous-instance class total-environment)))]))
+
+(def: bundle::class
+  Bundle
+  (<| (/////bundle.prefix "class")
+      (|> (: Bundle /////bundle.empty)
+          (/////bundle.install "anonymous" class::anonymous)
+          )))
+
+(def: #export bundle
+  Bundle
+  (<| (/////bundle.prefix "jvm")
+      (|> ..bundle::conversion
+          (dictionary.merge ..bundle::int)
+          (dictionary.merge ..bundle::long)
+          (dictionary.merge ..bundle::float)
+          (dictionary.merge ..bundle::double)
+          (dictionary.merge ..bundle::char)
+          (dictionary.merge ..bundle::array)
+          (dictionary.merge ..bundle::object)
+          (dictionary.merge ..bundle::member)
+          (dictionary.merge ..bundle::class)
+          )))