- Heavy refactoring.

3 files changed, 475 insertions, 0 deletions

diff --git a/new-luxc/source/luxc/generator/host/jvm/def.lux b/new-luxc/source/luxc/generator/host/jvm/def.lux
new file mode 100644
index 000000000..1fd87caea
--- /dev/null
+++ b/new-luxc/source/luxc/generator/host/jvm/def.lux
@@ -0,0 +1,142 @@
+(;module:
+  lux
+  (lux (data (coll ["a" array]
+                   [list "L/" Functor<List>]))
+       [host #+ jvm-import do-to])
+  ["$" ..]
+  (.. ["$t" type]))
+
+## [Host]
+(jvm-import #long java.lang.Object)
+(jvm-import #long java.lang.String)
+
+(jvm-import org.objectweb.asm.Opcodes
+  (#static ACC_PUBLIC int)
+  (#static ACC_PROTECTED int)
+  (#static ACC_PRIVATE int)
+
+  (#static ACC_ABSTRACT int)
+  (#static ACC_FINAL int)
+  (#static ACC_STATIC int)
+  (#static ACC_SYNCHRONIZED int)
+
+  (#static ACC_TRANSIENT int)
+  (#static ACC_VOLATILE int))
+
+(jvm-import org.objectweb.asm.FieldVisitor
+  (visitEnd [] void))
+
+(jvm-import org.objectweb.asm.MethodVisitor
+  (visitCode [] void)
+  (visitMaxs [int int] void)
+  (visitEnd [] void))
+
+(jvm-import org.objectweb.asm.ClassWriter
+  (#static COMPUTE_MAXS int)
+  (new [int])
+  (visit [int int String String String (Array String)] void)
+  (visitEnd [] void)
+  (visitField [int String String String Object] FieldVisitor)
+  (visitMethod [int String String String (Array String)] MethodVisitor)
+  (toByteArray [] Byte-Array))
+
+## [Defs]
+(def: (exceptions-array type)
+  (-> $;Method (a;Array Text))
+  (let [exs (|> type (get@ #$;exceptions) (L/map (|>. #$;Generic $t;descriptor)))
+        output (host;array String (list;size exs))]
+    (exec (L/map (function [[idx value]]
+                   (host;array-store idx value output))
+                 (list;enumerate exs))
+      output)))
+
+(def: (visibility-flag visibility)
+  (-> $;Visibility Int)
+  (case visibility
+    #$;Public    Opcodes.ACC_PUBLIC
+    #$;Protected Opcodes.ACC_PROTECTED
+    #$;Private   Opcodes.ACC_PRIVATE
+    #$;Default   0))
+
+(def: (method-flag config)
+  (-> $;Method-Config Int)
+  ($_ i.+
+      (if (get@ #$;staticM config) Opcodes.ACC_STATIC 0)
+      (if (get@ #$;finalM config) Opcodes.ACC_FINAL 0)
+      (if (get@ #$;synchronizedM config) Opcodes.ACC_SYNCHRONIZED 0)))
+
+(def: (field-flag config)
+  (-> $;Field-Config Int)
+  ($_ i.+
+      (if (get@ #$;staticF config) Opcodes.ACC_STATIC 0)
+      (if (get@ #$;finalF config) Opcodes.ACC_FINAL 0)
+      (if (get@ #$;transientF config) Opcodes.ACC_TRANSIENT 0)
+      (if (get@ #$;volatileF config) Opcodes.ACC_VOLATILE 0)))
+
+(def: #export (method visibility config name type then)
+  (-> $;Visibility $;Method-Config Text $;Method $;Inst
+      $;Def)
+  (function [writer]
+    (let [=method (ClassWriter.visitMethod [($_ i.+
+                                                (visibility-flag visibility)
+                                                (method-flag config))
+                                            name
+                                            ($t;method-descriptor type)
+                                            ($t;method-signature type)
+                                            (exceptions-array type)]
+                                           writer)
+          _ (MethodVisitor.visitCode [] =method)
+          _ (then =method)
+          _ (MethodVisitor.visitMaxs [0 0] =method)
+          _ (MethodVisitor.visitEnd [] =method)]
+      writer)))
+
+(def: #export (abstract-method visibility config name type)
+  (-> $;Visibility $;Method-Config Text $;Method
+      $;Def)
+  (function [writer]
+    (let [=method (ClassWriter.visitMethod [($_ i.+
+                                                (visibility-flag visibility)
+                                                (method-flag config)
+                                                Opcodes.ACC_ABSTRACT)
+                                            name
+                                            ($t;method-descriptor type)
+                                            ($t;method-signature type)
+                                            (exceptions-array type)]
+                                           writer)
+          _ (MethodVisitor.visitEnd [] =method)]
+      writer)))
+
+(def: #export (field visibility config name type)
+  (-> $;Visibility $;Field-Config Text $;Type $;Def)
+  (function [writer]
+    (let [=field (do-to (ClassWriter.visitField [($_ i.+
+                                                     (visibility-flag visibility)
+                                                     (field-flag config))
+                                                 name ($t;descriptor type) ($t;signature type) (host;null)] writer)
+                   (FieldVisitor.visitEnd []))]
+      writer)))
+
+(do-template [<name> <lux-type> <jvm-type> <prepare>]
+  [(def: #export (<name> visibility config name value)
+     (-> $;Visibility $;Field-Config Text <lux-type> $;Def)
+     (function [writer]
+       (let [=field (do-to (ClassWriter.visitField [($_ i.+
+                                                        (visibility-flag visibility)
+                                                        (field-flag config))
+                                                    name ($t;descriptor <jvm-type>) ($t;signature <jvm-type>)
+                                                    (<prepare> value)]
+                                                   writer)
+                      (FieldVisitor.visitEnd []))]
+         writer)))]
+
+  [boolean-field Bool $t;boolean id]
+  [byte-field    Int  $t;byte    host;l2b]
+  [short-field   Int  $t;short   host;l2s]
+  [int-field     Int  $t;int     host;l2i]
+  [long-field    Int  $t;long    id]
+  [float-field   Real $t;float   host;d2f]
+  [double-field  Real $t;double  id]
+  [char-field    Char $t;char    id]
+  [string-field  Text ($t;class "java.lang.String" (list)) id]
+  )
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
new file mode 100644
index 000000000..f340be055
--- /dev/null
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -0,0 +1,195 @@
+(;module:
+  lux
+  (lux [host #+ jvm-import do-to])
+  ["$" ..]
+  (.. ["$t" type]))
+
+## [Host]
+(jvm-import #long java.lang.Object)
+(jvm-import #long java.lang.String)
+
+(jvm-import org.objectweb.asm.Opcodes
+  (#static T_BOOLEAN int)
+  (#static T_CHAR int)
+  (#static T_FLOAT int)
+  (#static T_DOUBLE int)
+  (#static T_BYTE int)
+  (#static T_SHORT int)
+  (#static T_INT int)
+  (#static T_LONG int)
+
+  (#static DUP int)
+  (#static RETURN int)
+  (#static ARETURN int)
+  (#static ACONST_NULL int)
+  (#static ILOAD int)
+  (#static ALOAD int)
+  (#static NEWARRAY int)
+  (#static ANEWARRAY int)
+  (#static AASTORE int)
+  (#static PUTSTATIC int)
+  (#static GETFIELD int)
+  (#static INVOKESTATIC int)
+  (#static INVOKEVIRTUAL int)
+  (#static INVOKESPECIAL int)
+  (#static CHECKCAST int))
+
+(jvm-import org.objectweb.asm.FieldVisitor
+  (visitEnd [] void))
+
+(jvm-import org.objectweb.asm.MethodVisitor
+  (visitCode [] void)
+  (visitMaxs [int int] void)
+  (visitEnd [] void)
+  (visitInsn [int] void)
+  (visitLdcInsn [Object] void)
+  (visitFieldInsn [int String String String] void)
+  (visitTypeInsn [int String] void)
+  (visitVarInsn [int int] void)
+  (visitIntInsn [int int] void)
+  (visitMethodInsn [int String String String boolean] void))
+
+## [Insts]
+(do-template [<name> <type> <prepare>]
+  [(def: #export (<name> value)
+     (-> <type> $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitLdcInsn [(<prepare> value)]))))]
+
+  [boolean Bool id]
+  [int     Int  host;l2i]
+  [long    Int  id]
+  [double  Real id]
+  [char    Char id]
+  [string  Text id]
+  )
+
+(do-template [<name> <inst>]
+  [(def: #export <name>
+     $;Inst
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitInsn [<inst>]))))]
+
+  [RETURN  Opcodes.RETURN]
+  [ARETURN Opcodes.ARETURN]
+  [NULL    Opcodes.ACONST_NULL]
+  [DUP     Opcodes.DUP]
+  [AASTORE Opcodes.AASTORE]
+  )
+
+(do-template [<name> <inst>]
+  [(def: #export (<name> register)
+     (-> Nat $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitVarInsn [<inst> (nat-to-int register)]))))]
+
+  [ALOAD Opcodes.ALOAD]
+  [ILOAD Opcodes.ILOAD]
+  )
+
+(do-template [<name> <inst>]
+  [(def: #export (<name> class field type)
+     (-> Text Text $;Type $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitFieldInsn [<inst> ($t;binary-name class) field ($t;descriptor type)]))))]
+
+  [PUTSTATIC Opcodes.PUTSTATIC]
+  )
+
+(do-template [<name> <inst>]
+  [(def: #export (<name> class)
+     (-> Text $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitTypeInsn [<inst> ($t;binary-name class)]))))]
+
+  [ANEWARRAY Opcodes.ANEWARRAY]
+  [CHECKCAST Opcodes.CHECKCAST]
+  )
+
+(def: #export (NEWARRAY type)
+  (-> $;Primitive $;Inst)
+  (function [visitor]
+    (do-to visitor
+      (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type
+                                                      #$;Boolean Opcodes.T_BOOLEAN
+                                                      #$;Byte    Opcodes.T_SHORT
+                                                      #$;Short   Opcodes.T_SHORT
+                                                      #$;Int     Opcodes.T_INT
+                                                      #$;Long    Opcodes.T_LONG
+                                                      #$;Float   Opcodes.T_FLOAT
+                                                      #$;Double  Opcodes.T_DOUBLE
+                                                      #$;Char    Opcodes.T_CHAR)]))))
+
+(do-template [<name> <inst>]
+  [(def: #export (<name> class method-name method-signature interface?)
+     (-> Text Text $;Method Bool $;Inst)
+     (function [visitor]
+       (do-to visitor
+         (MethodVisitor.visitMethodInsn [<inst> ($t;binary-name class) method-name ($t;method-descriptor method-signature) interface?]))))]
+
+  [INVOKESTATIC  Opcodes.INVOKESTATIC]
+  [INVOKEVIRTUAL Opcodes.INVOKEVIRTUAL]
+  )
+
+(def: #export (array type size)
+  (-> $;Type Nat $;Inst)
+  (case type
+    (#$;Primitive prim)
+    (|>. (int (nat-to-int size))
+         (NEWARRAY prim))
+
+    (#$;Generic generic)
+    (let [elem-class (case generic
+                       (#$;Class class params)
+                       ($t;binary-name class)
+
+                       _
+                       ($t;binary-name "java.lang.Object"))]
+      (|>. (int (nat-to-int size))
+           (ANEWARRAY elem-class)))
+
+    _
+    (|>. (int (nat-to-int size))
+         (ANEWARRAY ($t;descriptor type)))))
+
+(do-template [<wrap> <unwrap> <class> <unwrap-method> <prim>]
+  [(def: #export <wrap>
+     $;Inst
+     (|>. (INVOKESTATIC <class> "valueOf"
+                        ($t;method (list <prim>)
+                                   (#;Some ($t;class <class> (list)))
+                                   (list))
+                        false)))
+   (def: #export <unwrap>
+     $;Inst
+     (|>. (CHECKCAST <class>)
+          (INVOKEVIRTUAL <class> <unwrap-method>
+                         ($t;method (list) (#;Some <prim>) (list))
+                         false)))]
+
+  [wrap-boolean unwrap-boolean "java.lang.Boolean"   "booleanValue" $t;boolean]
+  [wrap-byte    unwrap-byte    "java.lang.Byte"      "byteValue"    $t;byte]
+  [wrap-short   unwrap-short   "java.lang.Short"     "shortValue"   $t;short]
+  [wrap-int     unwrap-int     "java.lang.Integer"   "intValue"     $t;int]
+  [wrap-long    unwrap-long    "java.lang.Long"      "longValue"    $t;long]
+  [wrap-float   unwrap-float   "java.lang.Float"     "floatValue"   $t;float]
+  [wrap-double  unwrap-double  "java.lang.Double"    "doubleValue"  $t;double]
+  [wrap-char    unwrap-char    "java.lang.Character" "charValue"    $t;char]
+  )
+
+(def: #export (fuse insts)
+  (-> (List $;Inst) $;Inst)
+  (case insts
+    #;Nil
+    id
+
+    (#;Cons singleton #;Nil)
+    singleton
+
+    (#;Cons head tail)
+    (. head (fuse tail))))
diff --git a/new-luxc/source/luxc/generator/host/jvm/type.lux b/new-luxc/source/luxc/generator/host/jvm/type.lux
new file mode 100644
index 000000000..b457ac636
--- /dev/null
+++ b/new-luxc/source/luxc/generator/host/jvm/type.lux
@@ -0,0 +1,138 @@
+(;module:
+  lux
+  (lux (data [text]
+             text/format
+             (coll [list "L/" Functor<List>])))
+  ["$" ..])
+
+## Types
+(do-template [<name> <primitive>]
+  [(def: #export <name> $;Type (#$;Primitive <primitive>))]
+
+  [boolean #$;Boolean]
+  [byte    #$;Byte]
+  [short   #$;Short]
+  [int     #$;Int]
+  [long    #$;Long]
+  [float   #$;Float]
+  [double  #$;Double]
+  [char    #$;Char]
+  )
+
+(def: #export (class name params)
+  (-> Text (List $;Generic) $;Type)
+  (#$;Generic (#$;Class name params)))
+
+(def: #export (var name)
+  (-> Text $;Type)
+  (#$;Generic (#$;Var name)))
+
+(def: #export (wildcard bound)
+  (-> (Maybe [$;Bound $;Generic]) $;Type)
+  (#$;Generic (#$;Wildcard bound)))
+
+(def: #export (array depth elemT)
+  (-> Nat $;Type $;Type)
+  (case depth
+    +0 elemT
+    _ (#$;Array (array (n.dec depth) elemT))))
+
+(def: #export (binary-name class)
+  (-> Text Text)
+  (text;replace-all "." "/" class))
+
+(def: #export (descriptor type)
+  (-> $;Type Text)
+  (case type
+    (#$;Primitive prim)
+    (case prim
+      #$;Boolean "Z"
+      #$;Byte    "B"
+      #$;Short   "S"
+      #$;Int     "I"
+      #$;Long    "J"
+      #$;Float   "F"
+      #$;Double  "D"
+      #$;Char    "C")
+
+    (#$;Array sub)
+    (format "[" (descriptor sub))
+
+    (#$;Generic generic)
+    (case generic
+      (#$;Class class params)
+      (format "L" (binary-name class) ";")
+
+      (^or (#$;Var name) (#$;Wildcard ?bound))
+      (descriptor (#$;Generic (#$;Class "java.lang.Object" (list)))))
+    ))
+
+(def: #export (signature type)
+  (-> $;Type Text)
+  (case type
+    (#$;Primitive prim)
+    (case prim
+      #$;Boolean "Z"
+      #$;Byte    "B"
+      #$;Short   "S"
+      #$;Int     "I"
+      #$;Long    "J"
+      #$;Float   "F"
+      #$;Double  "D"
+      #$;Char    "C")
+
+    (#$;Array sub)
+    (format "[" (signature sub))
+
+    (#$;Generic generic)
+    (case generic
+      (#$;Class class params)
+      (let [=params (if (list;empty? params)
+                      ""
+                      (format "<"
+                              (|> params
+                                  (L/map (|>. #$;Generic signature))
+                                  (text;join-with ""))
+                              ">"))]
+        (format "L" (binary-name class) =params ";"))
+
+      (#$;Var name)
+      (format "T" name ";")
+
+      (#$;Wildcard #;None)
+      "*"
+
+      (^template [<tag> <prefix>]
+        (#$;Wildcard (#;Some [<tag> bound]))
+        (format <prefix> (signature (#$;Generic bound))))
+      ([#$;Upper "+"]
+       [#$;Lower "-"]))
+    ))
+
+## Methods
+(def: #export (method args return exceptions)
+  (-> (List $;Type) (Maybe $;Type) (List $;Generic) $;Method)
+  {#$;args args #$;return return #$;exceptions exceptions})
+
+(def: #export (method-descriptor method)
+  (-> $;Method Text)
+  (format "(" (text;join-with "" (L/map descriptor (get@ #$;args method))) ")"
+          (case (get@ #$;return method)
+            #;None
+            "V"
+
+            (#;Some return)
+            (descriptor return))))
+
+(def: #export (method-signature method)
+  (-> $;Method Text)
+  (format "(" (|> (get@ #$;args method) (L/map signature) (text;join-with "")) ")"
+          (case (get@ #$;return method)
+            #;None
+            "V"
+
+            (#;Some return)
+            (signature return))
+          (|> (get@ #$;exceptions method)
+              (L/map (|>. #$;Generic signature (format "^")))
+              (text;join-with ""))))