- Compilation and tests for arithmetic, bit-wise operations and order.

5 files changed, 322 insertions, 26 deletions

diff --git a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
index 1dba7a5f8..e21281984 100644
--- a/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/analyser/procedure/host.jvm.lux
@@ -92,7 +92,6 @@
              (@;install "%" (@;binary <type> <type> <type>))
              (@;install "=" (@;binary <type> <type> Boolean))
              (@;install "<" (@;binary <type> <type> Boolean))
-             (@;install ">" (@;binary <type> <type> Boolean))
              (@;install "and" (@;binary <type> <type> <type>))
              (@;install "or" (@;binary <type> <type> <type>))
              (@;install "xor" (@;binary <type> <type> <type>))
@@ -117,7 +116,6 @@
              (@;install "%" (@;binary <type> <type> <type>))
              (@;install "=" (@;binary <type> <type> Boolean))
              (@;install "<" (@;binary <type> <type> Boolean))
-             (@;install ">" (@;binary <type> <type> Boolean))
              )))]
 
   [float-procs  "float"  Float]
@@ -130,7 +128,6 @@
       (|> (dict;new text;Hash<Text>)
           (@;install "=" (@;binary Character Character Boolean))
           (@;install "<" (@;binary Character Character Boolean))
-          (@;install ">" (@;binary Character Character Boolean))
           )))
 
 (def: #export boxes
@@ -825,13 +822,11 @@
           (dict;merge (<| (@;prefix "static")
                           (|> (dict;new text;Hash<Text>)
                               (@;install "get" static-get)
-                              (@;install "put" static-put)
-                              )))
+                              (@;install "put" static-put))))
           (dict;merge (<| (@;prefix "virtual")
                           (|> (dict;new text;Hash<Text>)
                               (@;install "get" virtual-get)
-                              (@;install "put" virtual-put)
-                              )))
+                              (@;install "put" virtual-put))))
           )))
 
 (def: #export procedures
diff --git a/new-luxc/source/luxc/generator/host/jvm/inst.lux b/new-luxc/source/luxc/generator/host/jvm/inst.lux
index ebf12023f..7a6215804 100644
--- a/new-luxc/source/luxc/generator/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/generator/host/jvm/inst.lux
@@ -36,11 +36,12 @@
                                   GOTO)
                   <var> (declare ILOAD LLOAD DLOAD ALOAD
                                  ISTORE LSTORE ASTORE)
-                  <arithmethic> (declare IADD ISUB
-                                         LADD LSUB LMUL LDIV LREM
-                                         LCMP
-                                         DADD DSUB DMUL DDIV DREM
-                                         DCMPG DCMPL)
+                  <arithmethic> (declare IADD ISUB IMUL IDIV IREM
+                                         LADD LSUB LMUL LDIV LREM LCMP
+                                         FADD FSUB FMUL FDIV FREM FCMPG FCMPL
+                                         DADD DSUB DMUL DDIV DREM DCMPG DCMPL)
+                  <bit-wise> (declare IAND IOR IXOR ISHL ISHR IUSHR
+                                      LAND LOR LXOR LSHL LSHR LUSHR)
                   <return> (declare RETURN IRETURN LRETURN DRETURN ARETURN)]
   (host;import org.objectweb.asm.Opcodes
     (#static NOP int)
@@ -60,14 +61,8 @@
     
     <var>
     
-    (#static LAND int)
-    (#static LOR int)
-    (#static LXOR int)
-    (#static LSHL int)
-    (#static LSHR int)
-    (#static LUSHR int)
-
     <arithmethic>
+    <bit-wise>
 
     (#static AALOAD int)
     (#static AASTORE int)
@@ -161,17 +156,23 @@
   [F2D] [F2I] [F2L]
   [I2B] [I2C] [I2D] [I2F] [I2L] [I2S]
   [L2D] [L2F] [L2I]
-  
-  ## Long bitwise
-  [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
 
   ## Integer arithmetic
-  [IADD] [ISUB]
+  [IADD] [ISUB] [IMUL] [IDIV] [IREM]
+
+  ## Integer bitwise
+  [IAND] [IOR] [IXOR] [ISHL] [ISHR] [IUSHR]
   
   ## Long arithmethic
   [LADD] [LSUB] [LMUL] [LDIV] [LREM]
   [LCMP]
 
+  ## Long bitwise
+  [LAND] [LOR] [LXOR] [LSHL] [LSHR] [LUSHR]
+
+  ## Float arithmetic
+  [FADD] [FSUB] [FMUL] [FDIV] [FREM] [FCMPG] [FCMPL]
+
   ## Double arithmetic
   [DADD] [DSUB] [DMUL] [DDIV] [DREM]
   [DCMPG] [DCMPL]
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
index 66b7bc77e..c99c23385 100644
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
@@ -98,9 +98,177 @@
           (@;install "short-to-long" (@;unary convert//short-to-long))
           )))
 
+(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
+  [(def: (<name> [xI yI])
+     @;Binary
+     (|>. xI ($i;unwrap <unwrapX>)
+          yI ($i;unwrap <unwrapY>)
+          <op> ($i;wrap <wrap>)))]
+
+  [int//+ $i;IADD #$;Int #$;Int #$;Int]
+  [int//- $i;ISUB #$;Int #$;Int #$;Int]
+  [int//* $i;IMUL #$;Int #$;Int #$;Int]
+  [int/// $i;IDIV #$;Int #$;Int #$;Int]
+  [int//% $i;IREM #$;Int #$;Int #$;Int]
+  [int//and $i;IAND #$;Int #$;Int #$;Int]
+  [int//or $i;IOR #$;Int #$;Int #$;Int]
+  [int//xor $i;IXOR #$;Int #$;Int #$;Int]
+  [int//shl $i;ISHL #$;Int #$;Int #$;Int]
+  [int//shr $i;ISHR #$;Int #$;Int #$;Int]
+  [int//ushr $i;IUSHR #$;Int #$;Int #$;Int]
+  
+  [long//+ $i;LADD #$;Long #$;Long #$;Long]
+  [long//- $i;LSUB #$;Long #$;Long #$;Long]
+  [long//* $i;LMUL #$;Long #$;Long #$;Long]
+  [long/// $i;LDIV #$;Long #$;Long #$;Long]
+  [long//% $i;LREM #$;Long #$;Long #$;Long]
+  [long//and $i;LAND #$;Long #$;Long #$;Long]
+  [long//or $i;LOR #$;Long #$;Long #$;Long]
+  [long//xor $i;LXOR #$;Long #$;Long #$;Long]
+  [long//shl $i;LSHL #$;Long #$;Int #$;Long]
+  [long//shr $i;LSHR #$;Long #$;Int #$;Long]
+  [long//ushr $i;LUSHR #$;Long #$;Int #$;Long]
+
+  [float//+ $i;FADD #$;Float #$;Float #$;Float]
+  [float//- $i;FSUB #$;Float #$;Float #$;Float]
+  [float//* $i;FMUL #$;Float #$;Float #$;Float]
+  [float/// $i;FDIV #$;Float #$;Float #$;Float]
+  [float//% $i;FREM #$;Float #$;Float #$;Float]
+  
+  [double//+ $i;DADD #$;Double #$;Double #$;Double]
+  [double//- $i;DSUB #$;Double #$;Double #$;Double]
+  [double//* $i;DMUL #$;Double #$;Double #$;Double]
+  [double/// $i;DDIV #$;Double #$;Double #$;Double]
+  [double//% $i;DREM #$;Double #$;Double #$;Double]
+  )
+
+(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
+  [(def: (<name> [xI yI])
+     @;Binary
+     (<| $i;with-label (function [@then])
+         $i;with-label (function [@end])
+         (|>. xI ($i;unwrap <unwrapX>)
+              yI ($i;unwrap <unwrapY>)
+              (<op> @then)
+              ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
+              ($i;GOTO @end)
+              ($i;label @then)
+              ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
+              ($i;label @end))))]
+
+  [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean]
+  [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean]
+
+  [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean]
+  [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean]
+  )
+
+(do-template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>]
+  [(def: (<name> [xI yI])
+     @;Binary
+     (<| $i;with-label (function [@then])
+         $i;with-label (function [@end])
+         (|>. xI ($i;unwrap <unwrapX>)
+              yI ($i;unwrap <unwrapY>)
+              <op>
+              ($i;int <reference>)
+              ($i;IF_ICMPEQ @then)
+              ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
+              ($i;GOTO @end)
+              ($i;label @then)
+              ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
+              ($i;label @end))))]
+
+  [long//= $i;LCMP  0 #$;Long #$;Long #$;Boolean]
+  [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean]
+  
+  [float//= $i;FCMPG  0 #$;Float #$;Float #$;Boolean]
+  [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean]
+
+  [double//= $i;DCMPG  0 #$;Double #$;Double #$;Boolean]
+  [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean]
+  )
+
+(def: int-procs
+  @;Bundle
+  (<| (@;prefix "int")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary int//+))
+          (@;install "-" (@;binary int//-))
+          (@;install "*" (@;binary int//*))
+          (@;install "/" (@;binary int///))
+          (@;install "%" (@;binary int//%))
+          (@;install "=" (@;binary int//=))
+          (@;install "<" (@;binary int//<))
+          (@;install "and" (@;binary int//and))
+          (@;install "or" (@;binary int//or))
+          (@;install "xor" (@;binary int//xor))
+          (@;install "shl" (@;binary int//shl))
+          (@;install "shr" (@;binary int//shr))
+          (@;install "ushr" (@;binary int//ushr))
+          )))
+
+(def: long-procs
+  @;Bundle
+  (<| (@;prefix "long")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary long//+))
+          (@;install "-" (@;binary long//-))
+          (@;install "*" (@;binary long//*))
+          (@;install "/" (@;binary long///))
+          (@;install "%" (@;binary long//%))
+          (@;install "=" (@;binary long//=))
+          (@;install "<" (@;binary long//<))
+          (@;install "and" (@;binary long//and))
+          (@;install "or" (@;binary long//or))
+          (@;install "xor" (@;binary long//xor))
+          (@;install "shl" (@;binary long//shl))
+          (@;install "shr" (@;binary long//shr))
+          (@;install "ushr" (@;binary long//ushr))
+          )))
+
+(def: float-procs
+  @;Bundle
+  (<| (@;prefix "float")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary float//+))
+          (@;install "-" (@;binary float//-))
+          (@;install "*" (@;binary float//*))
+          (@;install "/" (@;binary float///))
+          (@;install "%" (@;binary float//%))
+          (@;install "=" (@;binary float//=))
+          (@;install "<" (@;binary float//<))
+          )))
+
+(def: double-procs
+  @;Bundle
+  (<| (@;prefix "double")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "+" (@;binary double//+))
+          (@;install "-" (@;binary double//-))
+          (@;install "*" (@;binary double//*))
+          (@;install "/" (@;binary double///))
+          (@;install "%" (@;binary double//%))
+          (@;install "=" (@;binary double//=))
+          (@;install "<" (@;binary double//<))
+          )))
+
+(def: char-procs
+  @;Bundle
+  (<| (@;prefix "char")
+      (|> (dict;new text;Hash<Text>)
+          (@;install "=" (@;binary char//=))
+          (@;install "<" (@;binary char//<))
+          )))
+
 (def: #export procedures
   @;Bundle
   (<| (@;prefix "jvm")
       (|> (dict;new text;Hash<Text>)
           (dict;merge conversion-procs)
+          (dict;merge int-procs)
+          (dict;merge long-procs)
+          (dict;merge float-procs)
+          (dict;merge double-procs)
+          (dict;merge char-procs)
           )))
diff --git a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
index c45143d5b..49d51eb3c 100644
--- a/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/analyser/procedure/host.jvm.lux
@@ -148,7 +148,6 @@
 
                                         [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean]
                                         [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean]
-                                        [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean]
                                         )]
        ($_ seq
            <instructions>
@@ -207,7 +206,6 @@
 
                                         [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean]
                                         [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean]
-                                        [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean]
                                         )]
        ($_ seq
            <instructions>
@@ -229,7 +227,6 @@
 
                                         [(format "jvm " <domain> " =") <boxed> <boxed> @host;Boolean]
                                         [(format "jvm " <domain> " <") <boxed> <boxed> @host;Boolean]
-                                        [(format "jvm " <domain> " >") <boxed> <boxed> @host;Boolean]
                                         )]
        ($_ seq
            <instructions>
diff --git a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
index 1dd60bc76..67fbbceda 100644
--- a/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
+++ b/new-luxc/test/test/luxc/generator/procedure/host.jvm.lux
@@ -4,6 +4,8 @@
        (control [monad #+ do]
                 pipe)
        (data ["R" result]
+             [bit]
+             [bool "bool/" Eq<Bool>]
              [number "int/" Number<Int>]
              text/format)
        ["r" math/random "r/" Monad<Random>]
@@ -98,3 +100,136 @@
         <3step>
         <4step>
         )))
+
+(def: gen-nat
+  (r;Random Nat)
+  (|> r;nat
+      (r/map (n.% +128))
+      (r;filter (|>. (n.= +0) not))))
+
+(def: gen-int
+  (r;Random Int)
+  (|> gen-nat (r/map nat-to-int)))
+
+(def: gen-frac
+  (r;Random Frac)
+  (|> gen-int (r/map int-to-frac)))
+
+(do-template [<domain> <generator> <tag> <type> <test> <augmentation> <+> <-> <*> </> <%> <pre> <post>]
+  [(context: (format "Arithmetic [" <domain> "]")
+     [param <generator>
+      #let [subject (<augmentation> param)]]
+     (with-expansions [<tests> (do-template [<procedure> <reference>]
+                                 [(test <procedure>
+                                        (|> (do macro;Monad<Lux>
+                                              [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<pre> (<tag> subject))
+                                                                                                            (<pre> (<tag> param))))))]
+                                              (@eval;eval sampleI))
+                                            (macro;run (init-compiler []))
+                                            (case> (#R;Success valueG)
+                                                   (<test> (<reference> param subject)
+                                                           (:! <type> valueG))
+
+                                                   (#R;Error error)
+                                                   false)))]
+
+                                 [(format "jvm " <domain> " +") <+>]
+                                 [(format "jvm " <domain> " -") <->]
+                                 [(format "jvm " <domain> " *") <*>]
+                                 [(format "jvm " <domain> " /") </>]
+                                 [(format "jvm " <domain> " %") <%>]
+                                 )]
+       ($_ seq
+           <tests>
+           )))]
+
+  ["int" gen-int #ls;Int Int i.= (i.* 10) i.+ i.- i.* i./ i.% (|>. (list) (#ls;Procedure "jvm convert long-to-int")) (|>. (list) (#ls;Procedure "jvm convert int-to-long"))]
+  ["long" gen-int #ls;Int Int i.= (i.* 10) i.+ i.- i.* i./ i.% id id]
+  ["float" gen-frac #ls;Frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% (|>. (list) (#ls;Procedure "jvm convert double-to-float")) (|>. (list) (#ls;Procedure "jvm convert float-to-double"))]
+  ["double" gen-frac #ls;Frac Frac f.= (f.* 10.0) f.+ f.- f.* f./ f.% id id]
+  )
+
+(do-template [<domain> <post> <convert>]
+  [(context: (format "Bit-wise [" <domain> "]")
+     [param gen-nat
+      subject gen-nat
+      #let [shift (n.% +10 param)]]
+     (with-expansions [<combiners> (do-template [<procedure> <reference>]
+                                     [(test <procedure>
+                                            (|> (do macro;Monad<Lux>
+                                                  [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (#ls;Nat subject))
+                                                                                                                (<convert> (#ls;Nat param))))))]
+                                                  (@eval;eval sampleI))
+                                                (macro;run (init-compiler []))
+                                                (case> (#R;Success valueG)
+                                                       (n.= (<reference> param subject)
+                                                            (:! Nat valueG))
+
+                                                       (#R;Error error)
+                                                       false)))]
+
+                                     [(format "jvm " <domain> " and") bit;and]
+                                     [(format "jvm " <domain> " or") bit;or]
+                                     [(format "jvm " <domain> " xor") bit;xor]
+                                     )
+                       <shifters> (do-template [<procedure> <reference> <type> <test> <pre-subject> <pre>]
+                                    [(test <procedure>
+                                           (|> (do macro;Monad<Lux>
+                                                 [sampleI (@;generate (<post> (#ls;Procedure <procedure> (list (<convert> (<pre> subject))
+                                                                                                               (|> (#ls;Nat shift)
+                                                                                                                   (list)
+                                                                                                                   (#ls;Procedure "jvm convert long-to-int"))))))]
+                                                 (@eval;eval sampleI))
+                                               (macro;run (init-compiler []))
+                                               (case> (#R;Success valueG)
+                                                      (<test> (<reference> shift (<pre-subject> subject))
+                                                              (:! <type> valueG))
+
+                                                      (#R;Error error)
+                                                      false)))]
+
+                                    [(format "jvm " <domain> " shl") bit;shift-left Nat n.= id #ls;Nat]
+                                    [(format "jvm " <domain> " shr") bit;signed-shift-right Int i.= nat-to-int (|>. nat-to-int #ls;Int)]
+                                    [(format "jvm " <domain> " ushr") bit;shift-right Nat n.= id #ls;Nat]
+                                    )]
+       ($_ seq
+           <combiners>
+           <shifters>
+           )))]
+
+  ["int" (|>. (list) (#ls;Procedure "jvm convert int-to-long")) (|>. (list) (#ls;Procedure "jvm convert long-to-int"))]
+  ["long" id id]
+  )
+
+(do-template [<domain> <generator> <tag> <=> <<> <pre>]
+  [(context: (format "Order [" <domain> "]")
+     [param <generator>
+      subject <generator>]
+     (with-expansions [<tests> (do-template [<procedure> <reference>]
+                                 [(test <procedure>
+                                        (|> (do macro;Monad<Lux>
+                                              [sampleI (@;generate (#ls;Procedure <procedure> (list (<pre> (<tag> subject))
+                                                                                                    (<pre> (<tag> param)))))]
+                                              (@eval;eval sampleI))
+                                            (macro;run (init-compiler []))
+                                            (case> (#R;Success valueG)
+                                                   (bool/= (<reference> param subject)
+                                                           (:! Bool valueG))
+
+                                                   (#R;Error error)
+                                                   false)))]
+
+                                 [(format "jvm " <domain> " =") <=>]
+                                 [(format "jvm " <domain> " <") <<>]
+                                 )]
+       ($_ seq
+           <tests>
+           )))]
+
+  ["int" gen-int #ls;Int i.= i.< (|>. (list) (#ls;Procedure "jvm convert long-to-int"))]
+  ["long" gen-int #ls;Int i.= i.< id]
+  ["float" gen-frac #ls;Frac f.= f.< (|>. (list) (#ls;Procedure "jvm convert double-to-float"))]
+  ["double" gen-frac #ls;Frac f.= f.< id]
+  ["char" gen-int #ls;Int i.= i.< (|>. (list) (#ls;Procedure "jvm convert long-to-int")
+                                       (list) (#ls;Procedure "jvm convert int-to-char"))]
+  )