Got long and double constants to work.

5 files changed, 179 insertions, 90 deletions

diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux
index c157d4abb..0f4aca590 100644
--- a/stdlib/source/lux/target/jvm/constant.lux
+++ b/stdlib/source/lux/target/jvm/constant.lux
@@ -127,6 +127,15 @@
   (#Interface-Method (Reference //descriptor.Method))
   (#Name-And-Type (Name-And-Type Any)))
 
+(def: #export (size constant)
+  (-> Constant Nat)
+  (case constant
+    (^or (#Long _) (#Double _))
+    2
+
+    _
+    1))
+
 (def: #export equivalence
   (Equivalence Constant)
   ## TODO: Delete the explicit "structure" and use the combinator
diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux
index 062f7553b..a03bba71b 100644
--- a/stdlib/source/lux/target/jvm/constant/pool.lux
+++ b/stdlib/source/lux/target/jvm/constant/pool.lux
@@ -29,43 +29,45 @@
     ["#." index (#+ Index)]
     ["#." descriptor (#+ Field Method Descriptor)]]])
 
-(def: offset 1)
-
-(type: #export Pool (Row Constant))
+(type: #export Pool [Index (Row [Index Constant])])
 
 (def: #export equivalence
   (Equivalence Pool)
-  (row.equivalence //.equivalence))
+  (equivalence.product //index.equivalence
+                       (row.equivalence (equivalence.product //index.equivalence
+                                                             //.equivalence))))
 
 (template: (!add <tag> <=> <value>)
-  (function (_ pool)
-    (with-expansions [<index> (as-is (//index.index (//unsigned.u2 (n/+ offset idx))))
-                      <try-again> (as-is (recur (.inc idx)))]
+  (function (_ [next pool])
+    (with-expansions [<try-again> (as-is (recur (.inc idx)))]
       (loop [idx 0]
         (case (row.nth idx pool)
           (#.Some entry)
           (case entry
-            (<tag> reference)
+            [index (<tag> reference)]
             (if (:: <=> = reference <value>)
-              [pool
-               <index>]
+              [[next pool]
+               index]
               <try-again>)
             
             _
             <try-again>)
           
           #.None
-          [(row.add (<tag> <value>) pool)
-           <index>])))))
+          (let [new (<tag> <value>)]
+            [[(|> next
+                  //index.number
+                  (//unsigned.u2/+ (//unsigned.u2 (//.size new)))
+                  //index.index)
+              (row.add [next new] pool)]
+             next]))))))
 
 (template: (!raw-index <index>)
-  (|> <index> //index.number //unsigned.nat .nat))
+  (|> <index> //index.number //unsigned.nat))
 
-(exception: #export (invalid-index {index (Index Any)}
-                                   {maximum Nat})
+(exception: #export (invalid-index {index (Index Any)})
   (exception.report
-   ["Index" (|> index !raw-index %.nat)]
-   ["Maximum" (%.nat maximum)]))
+   ["Index" (|> index !raw-index %.nat)]))
 
 (exception: #export (invalid-constant {index (Index Any)}
                                       {tag Name})
@@ -74,19 +76,30 @@
    ["Expected tag" (%.name tag)]))
 
 (template: (!fetch <tag> <index>)
-  (function (_ pool)
-    (case (row.nth (|> <index> !raw-index (n/- offset))
-                   pool)
-      (#.Some entry)
-      (case entry
-        (<tag> value)
-        [pool (#try.Success value)]
+  (with-expansions [<failure> (as-is [[next pool] (exception.throw ..invalid-index [<index>])])]
+    (function (_ [next pool])
+      (loop [idx 0]
+        (case (row.nth idx pool)
+          (#.Some [index entry])
+          (let [index' (!raw-index index)
+                <index>' (!raw-index <index>)]
+            (cond (n/< index' <index>')
+                  (recur (inc idx))
 
-        _
-        [pool (exception.throw ..invalid-constant [<index> (name-of <tag>)])])
+                  (n/= index' <index>')
+                  (case entry
+                    (<tag> value)
+                    [[next pool] (#try.Success value)]
 
-      #.None
-      [pool (exception.throw ..invalid-index [<index> (row.size pool)])])))
+                    _
+                    [[next pool] (exception.throw ..invalid-constant [<index> (name-of <tag>)])])
+
+                  ## (n/> index' <index>')
+                  <failure>))
+
+          #.None
+          <failure>))
+      )))
 
 (exception: #export (cannot-find {tag Name} {value Text})
   (exception.report
@@ -94,24 +107,23 @@
    ["Value" value]))
 
 (template: (!find <tag> <=> <%> <expected>)
-  (function (_ pool)
-    (with-expansions [<index> (as-is (//index.index (//unsigned.u2 (n/+ offset idx))))
-                      <try-again> (as-is (recur (.inc idx)))]
+  (function (_ [next pool])
+    (with-expansions [<try-again> (as-is (recur (.inc idx)))]
       (loop [idx 0]
         (case (row.nth idx pool)
-          (#.Some entry)
+          (#.Some [index entry])
           (case entry
             (<tag> actual)
             (if (:: <=> = actual <expected>)
-              [pool
-               (#try.Success <index>)]
+              [[next pool]
+               (#try.Success index)]
               <try-again>)
             
             _
             <try-again>)
           
           #.None
-          [pool
+          [[next pool]
            (exception.throw ..cannot-find [(name-of <tag>) (<%> <expected>)])])))))
 
 (type: (Adder of)
@@ -193,12 +205,13 @@
 
 (def: #export writer
   (Writer Pool)
-  (function (_ pool)
-    (row@fold (function (_ post pre)
+  (function (_ [next pool])
+    (row@fold (function (_ [_index post] pre)
                 (specification@compose pre (//.writer post)))
-              (binaryF.bits/16 (n/+ ..offset (row.size pool)))
+              (binaryF.bits/16 (!raw-index next))
               pool)))
 
 (def: #export empty
   Pool
-  row.empty)
+  [(|> 1 //unsigned.u2 //index.index)
+   row.empty])
diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux
index 85f21a152..aeb3e0b0a 100644
--- a/stdlib/source/lux/target/jvm/program.lux
+++ b/stdlib/source/lux/target/jvm/program.lux
@@ -484,12 +484,12 @@
                   (//constant/pool.method class)
                   {#//constant/pool.name method
                    #//constant/pool.descriptor (//descriptor.method inputs output)})]
-       (wrap (/instruction.invokestatic
-              index
-              (|> inputs
-                  (list@map descriptor-size)
-                  (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1))))
-              (descriptor-size output)))))]
+       (..nullary (<instruction>
+                   index
+                   (|> inputs
+                       (list@map descriptor-size)
+                       (list@fold //unsigned.u1/+ (//unsigned.u1 (if <static?> 0 1))))
+                   (descriptor-size output)))))]
 
   [#1 invokestatic /instruction.invokestatic]
   [#0 invokevirtual /instruction.invokevirtual]
diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux
index 07f769082..4f9c43f56 100644
--- a/stdlib/source/lux/target/jvm/program/instruction.lux
+++ b/stdlib/source/lux/target/jvm/program/instruction.lux
@@ -449,8 +449,8 @@
       ["13" ldc-w/integer [[index (Index ///constant.Integer)]] [(///index.number index)] 0 1 []]
       ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///index.number index)] 0 1 []]
       ["13" ldc-w/string [[index (Index ///constant.String)]] [(///index.number index)] 0 1 []]
-      ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 1 []]
-      ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 1 []]
+      ["14" ldc2-w/long [[index (Index ///constant.Long)]] [(///index.number index)] 0 2 []]
+      ["14" ldc2-w/double [[index (Index ///constant.Double)]] [(///index.number index)] 0 2 []]
       <fields>
       ["BB" new [[index (Index Class)]] [(///index.number index)] 0 1 []]
       ["BD" anewarray [[index (Index Class)]] [(///index.number index)] 1 1 []]
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index f044b74d0..8f97645b4 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -1,11 +1,10 @@
 (.module:
   [lux #*
+   ["." host (#+ import:)]
    [abstract/monad (#+ do)]
    [control
     ["." io (#+ IO)]
     ["." try (#+ Try)]
-    [parser
-     ["<2>" binary]]
     [concurrency
      ["." atom]]
     [security
@@ -17,26 +16,32 @@
     [format
      [".F" binary]]
     [collection
+     ["." array]
      ["." dictionary]
      ["." row]]]
    [world
     ["." file (#+ File)]]
    [math
-    ["r" random (#+ Random) ("#@." monad)]]
+    ["." random (#+ Random) ("#@." monad)]]
    ["_" test (#+ Test)]]
   {1
    ["." / #_
-    ["#." program]
-    
     ["#." loader (#+ Library)]
     ["#." version]
     ["#." descriptor (#+ Descriptor Value)]
+    ["#." modifier ("#@." monoid)]
     ["#." field]
+    ["#." method]
     ["#." class]
+    ["#." attribute
+     ["#/." code]]
+    ["#." constant
+     ["#/." pool]]
     [encoding
      ["#." name]]
-    [modifier
-     ["#.M" inner]]]})
+    ["#." program
+     ["#/." condition (#+ Environment)]
+     ["#/." instruction]]]})
 
 ## (def: (write-class! name bytecode)
 ##   (-> Text Binary (IO Text))
@@ -53,64 +58,123 @@
 ##               (#try.Failure error)
 ##               error)))))
 
+(import: #long java/lang/String)
+
+(import: #long java/lang/reflect/Method
+  (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object))
+
+(import: #long (java/lang/Class c)
+  (getDeclaredMethod [java/lang/String [(java/lang/Class java/lang/Object)]] java/lang/reflect/Method))
+
+(import: #long java/lang/Object
+  (getClass [] (java/lang/Class java/lang/Object))
+  (toString [] java/lang/String))
+
+(import: #long java/lang/Long
+  (#static TYPE (java/lang/Class java/lang/Long)))
+
 (def: descriptor
   (Random (Descriptor (Value Any)))
-  (r.rec
+  (random.rec
    (function (_ descriptor)
-     ($_ r.either
-         (r@wrap /descriptor.boolean)
-         (r@wrap /descriptor.byte)
-         (r@wrap /descriptor.short)
-         (r@wrap /descriptor.int)
-         (r@wrap /descriptor.long)
-         (r@wrap /descriptor.float)
-         (r@wrap /descriptor.double)
-         (r@wrap /descriptor.char)
-         (r@map (|>> (text.join-with /name.external-separator)
-                     /name.internal
-                     /descriptor.object)
-                (r.list 3 (r.ascii/upper-alpha 10)))
-         (r@map /descriptor.array descriptor)
+     ($_ random.either
+         (random@wrap /descriptor.boolean)
+         (random@wrap /descriptor.byte)
+         (random@wrap /descriptor.short)
+         (random@wrap /descriptor.int)
+         (random@wrap /descriptor.long)
+         (random@wrap /descriptor.float)
+         (random@wrap /descriptor.double)
+         (random@wrap /descriptor.char)
+         (random@map (|>> (text.join-with /name.external-separator) /descriptor.object)
+                     (random.list 3 (random.ascii/upper-alpha 10)))
+         (random@map /descriptor.array descriptor)
          ))))
 
 (def: field
   (Random [Text (Descriptor (Value Any))])
-  ($_ r.and
-      (r.ascii/lower-alpha 10)
+  ($_ random.and
+      (random.ascii/lower-alpha 10)
       ..descriptor
       ))
 
+(def: class-name
+  (Random Text)
+  (do random.monad
+    [super-package (random.ascii/lower-alpha 10)
+     package (random.ascii/lower-alpha 10)
+     name (random.ascii/upper-alpha 10)]
+    (wrap (format super-package "." package "." name))))
+
+(def: (get-method name class)
+  (-> Text (java/lang/Class java/lang/Object) java/lang/reflect/Method)
+  (java/lang/Class::getDeclaredMethod name
+                                      (host.array (java/lang/Class java/lang/Object) 0)
+                                      class))
+
+(def: method
+  Test
+  (do random.monad
+    [class-name ..class-name
+     method-name (random.ascii/upper-alpha 10)
+     expected random.int
+     #let [inputsJT (list)
+           outputJT (/descriptor.object "java.lang.Object")]]
+    (_.test "Can compile a method."
+            (let [bytecode (|> (/class.class /version.v6_0 /class.public
+                                             (/name.internal class-name)
+                                             (/name.internal "java.lang.Object")
+                                             (list)
+                                             (list)
+                                             (list (/method.method ($_ /modifier@compose
+                                                                       /method.public
+                                                                       /method.static)
+                                                                   method-name
+                                                                   (/descriptor.method inputsJT outputJT)
+                                                                   (list)
+                                                                   (do /program.monad
+                                                                     [_ (/program.ldc/long (/constant.long expected))
+                                                                      _ (/program.invokestatic "java.lang.Long" "valueOf"
+                                                                                               (list /descriptor.long)
+                                                                                               (/descriptor.object "java.lang.Long"))]
+                                                                     /program.areturn)))
+                                             (row.row))
+                               (binaryF.run /class.writer))
+                  loader (/loader.memory (/loader.new-library []))]
+              (case (do try.monad
+                      [_ (/loader.define class-name bytecode loader)
+                       class (io.run (/loader.load class-name loader))
+                       method (host.try (get-method method-name class))
+                       output (java/lang/reflect/Method::invoke (host.null) (host.array java/lang/Object 0) method)]
+                      (wrap (:coerce Int output)))
+                (#try.Success actual)
+                (i/= expected actual)
+                
+                (#try.Failure error)
+                false)))))
+
 (def: class
   Test
-  (do r.monad
-    [_ (wrap [])
-     super-package (r.ascii/lower-alpha 10)
-     package (r.ascii/lower-alpha 10)
-     name (r.ascii/upper-alpha 10)
+  (do random.monad
+    [class-name ..class-name
      [field0 descriptor0] ..field
      [field1 descriptor1] ..field
-     #let [full-name (format super-package "." package "." name)
-           input (/class.class /version.v6_0 /class.public
-                               (/name.internal full-name)
+     #let [input (/class.class /version.v6_0 /class.public
+                               (/name.internal class-name)
                                (/name.internal "java.lang.Object")
                                (list (/name.internal "java.io.Serializable")
                                      (/name.internal "java.lang.Runnable"))
                                (list (/field.field /field.public field0 descriptor0 (row.row))
                                      (/field.field /field.public field1 descriptor1 (row.row)))
-                               (row.row)
+                               (list)
                                (row.row))
            bytecode (binaryF.run /class.writer input)
            loader (/loader.memory (/loader.new-library []))]]
     ($_ _.and
-        (_.test "Can read a generated class."
-                (case (<2>.run /class.parser bytecode)
-                  (#try.Success output)
-                  (:: /class.equivalence = input output)
-                  
-                  (#try.Failure _)
-                  false))
         (_.test "Can generate a class."
-                (case (/loader.define full-name bytecode loader)
+                (case (do try.monad
+                        [_ (/loader.define class-name bytecode loader)]
+                        (io.run (/loader.load class-name loader)))
                   (#try.Success definition)
                   true
                   
@@ -120,5 +184,8 @@
 
 (def: #export test
   Test
-  (<| (_.context "Class")
-      ..class))
+  (<| (_.context (%.name (name-of .._)))
+      ($_ _.and
+          ..class
+          ..method
+          )))