- Compilation and tests for arrays.

6 files changed, 132 insertions, 22 deletions

diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index e21281984..a4cc20400 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -193,7 +193,7 @@
                                    (&;fail (invalid-array-type expectedT)))))
          _ (&;assert "Must have at least 1 level of nesting in array type."
                      (n.> +0 level))]
-        (wrap (#la;Procedure proc (list (#la;Nat level) (#la;Text elem-class) lengthA))))
+        (wrap (#la;Procedure proc (list (#la;Nat (n.dec level)) (#la;Text elem-class) lengthA))))
 
       _
       (&;fail (@;wrong-arity proc +1 (list;size args))))))
@@ -271,7 +271,7 @@
              idxA (&;with-expected-type Nat
                     (analyse idxC))
              _ (&;infer elemT)]
-            (wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA))))
+            (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA arrayA))))
 
           _
           (&;fail (@;wrong-arity proc +2 (list;size args))))))))
@@ -294,7 +294,7 @@
              valueA (&;with-expected-type valueT
                       (analyse valueC))
              _ (&;infer (type (Array elemT)))]
-            (wrap (#la;Procedure proc (list (#la;Text elem-class) arrayA idxA valueA))))
+            (wrap (#la;Procedure proc (list (#la;Text elem-class) idxA valueA arrayA))))
 
           _
           (&;fail (@;wrong-arity proc +3 (list;size args))))))))
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index 7a6215804..efc66f130 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -42,6 +42,15 @@
                                          DADD DSUB DMUL DDIV DREM DCMPG DCMPL)
                   <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR
                                       LAND LOR LXOR LSHL LSHR LUSHR)
+                  <array> (declare ARRAYLENGTH NEWARRAY ANEWARRAY
+                                   AALOAD AASTORE
+                                   BALOAD BASTORE
+                                   SALOAD SASTORE
+                                   IALOAD IASTORE
+                                   LALOAD LASTORE
+                                   FALOAD FASTORE
+                                   DALOAD DASTORE
+                                   CALOAD CASTORE)
                   <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
   (host;import org.objectweb.asm.Opcodes
     (#static NOP int)
@@ -51,8 +60,6 @@
 
     (#static CHECKCAST int)
     (#static NEW int)
-    (#static NEWARRAY int)
-    (#static ANEWARRAY int)
     
     <stack>
     <jump>
@@ -64,9 +71,7 @@
     <arithmethic>
     <bit-wise>
 
-    (#static AALOAD int)
-    (#static AASTORE int)
-    (#static ARRAYLENGTH int)
+    <array>
     
     (#static GETSTATIC int)
     (#static PUTSTATIC int)
@@ -178,7 +183,15 @@
   [DCMPG] [DCMPL]
 
   ## Array
-  [AALOAD] [AASTORE] [ARRAYLENGTH]
+  [ARRAYLENGTH]
+  [AALOAD] [AASTORE]
+  [BALOAD] [BASTORE]
+  [SALOAD] [SASTORE]
+  [IALOAD] [IASTORE]
+  [LALOAD] [LASTORE]
+  [FALOAD] [FASTORE]
+  [DALOAD] [DASTORE]
+  [CALOAD] [CASTORE]
 
   ## Exceptions
   [ATHROW]
@@ -230,7 +243,7 @@
     (do-to visitor
       (MethodVisitor.visitIntInsn [Opcodes.NEWARRAY (case type
                                                       #$;Boolean Opcodes.T_BOOLEAN
-                                                      #$;Byte    Opcodes.T_SHORT
+                                                      #$;Byte    Opcodes.T_BYTE
                                                       #$;Short   Opcodes.T_SHORT
                                                       #$;Int     Opcodes.T_INT
                                                       #$;Long    Opcodes.T_LONG
@@ -289,12 +302,11 @@
     (do-to visitor
       (MethodVisitor.visitLabel [@label]))))
 
-(def: #export (array type size)
-  (-> $;Type Nat $;Inst)
+(def: #export (array type)
+  (-> $;Type $;Inst)
   (case type
     (#$;Primitive prim)
-    (|>. (int (nat-to-int size))
-         (NEWARRAY prim))
+    (NEWARRAY prim)
 
     (#$;Generic generic)
     (let [elem-class (case generic
@@ -303,12 +315,10 @@
 
                        _
                        ($t;binary-name "java.lang.Object"))]
-      (|>. (int (nat-to-int size))
-           (ANEWARRAY elem-class)))
+      (ANEWARRAY elem-class))
 
     _
-    (|>. (int (nat-to-int size))
-         (ANEWARRAY ($t;descriptor type)))))
+    (ANEWARRAY ($t;descriptor type))))
 
 (def: (primitive-wrapper type)
   (-> $;Primitive Text)
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
index 70f38f962..e3a46a9ea 100644
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
@@ -81,8 +81,8 @@
     (do @
       [g!input+ (monad;seq @ (list;repeat arity (macro;gensym "input")))]
       (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc))
-                       (-> (-> (Vector (~ (code;nat arity)) $;Inst) $;Inst)
-                           (-> Text Proc))
+                       (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst)
+                           (-> Text ;;Proc))
                        (function [(~ g!name)]
                          (function [(~ g!generate) (~ g!inputs)]
                            (case (~ g!inputs)
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index c99c23385..128e8b517 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -261,6 +261,102 @@
           (@;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 (#ls;Nat level) (#ls;Text class) lengthS))
+    (do macro;Monad<Lux>
+      [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 (#ls;Text class) idxS arrayS))
+    (do macro;Monad<Lux>
+      [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 (#ls;Text class) idxS valueS arrayS))
+    (do macro;Monad<Lux>
+      [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: #export procedures
   @;Bundle
   (<| (@;prefix "jvm")
@@ -271,4 +367,5 @@
           (dict;merge float-procs)
           (dict;merge double-procs)
           (dict;merge char-procs)
+          (dict;merge array-procs)
           )))
diff --git a/new-luxc/source/luxc/generator/runtime.jvm.lux b/new-luxc/source/luxc/generator/runtime.jvm.lux
index c073e7da0..4c8784364 100644
--- a/new-luxc/source/luxc/generator/runtime.jvm.lux
+++ b/new-luxc/source/luxc/generator/runtime.jvm.lux
@@ -94,7 +94,8 @@
                     ($t;method (list $t;int $Object $Object)
                                (#;Some $Variant)
                                (list))
-                    (|>. ($i;array $Object +3)
+                    (|>. ($i;int 3)
+                         ($i;array $Object)
                          store-tagI
                          store-flagI
                          store-valueI
diff --git a/new-luxc/source/luxc/generator/structure.jvm.lux b/new-luxc/source/luxc/generator/structure.jvm.lux
index a89f3083f..6aca0dca1 100644
--- a/new-luxc/source/luxc/generator/structure.jvm.lux
+++ b/new-luxc/source/luxc/generator/structure.jvm.lux
@@ -36,7 +36,9 @@
                                               memberI
                                               $i;AASTORE)))))
                   (:: @ map $i;fuse))]
-    (wrap (|>. ($i;array $Object size) membersI))))
+    (wrap (|>. ($i;int (nat-to-int size))
+               ($i;array $Object)
+               membersI))))
 
 (def: (flagI tail?)
   (-> Bool $;Inst)