Added signed numbers of different sizes.

4 files changed, 119 insertions, 54 deletions

diff --git a/stdlib/source/lux/target/jvm/encoding/signed.lux b/stdlib/source/lux/target/jvm/encoding/signed.lux
new file mode 100644
index 000000000..7765d4402
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/encoding/signed.lux
@@ -0,0 +1,81 @@
+(.module:
+  [lux (#- int)
+   [abstract
+    [equivalence (#+ Equivalence)]
+    [order (#+ Order)]]
+   [control
+    ["<>" parser ("#@." functor)
+     ["<2>" binary (#+ Parser)]]]
+   [data
+    [number
+     ["." i64]]
+    [format
+     [".F" binary (#+ Writer)]]]
+   [macro
+    ["." template]]
+   [type
+    abstract]])
+
+(abstract: #export (Signed brand)
+  {}
+  Int
+
+  (def: #export int
+    (-> (Signed Any) Int)
+    (|>> :representation))
+
+  (structure: #export equivalence
+    (All [brand] (Equivalence (Signed brand)))
+    (def: (= reference sample)
+      (i/= (:representation reference) (:representation sample))))
+
+  (structure: #export order
+    (All [brand] (Order (Signed brand)))
+    
+    (def: &equivalence ..equivalence)
+    (def: (< reference sample)
+      (i/< (:representation reference) (:representation sample))))
+
+  (template [<bytes> <name> <size> <constructor> <max> <+>]
+    [(with-expansions [<raw> (template.identifier [<name> "'"])]
+       (abstract: #export <raw> {} Any)
+       (type: #export <name> (Signed <raw>)))
+
+     (def: #export <size> Nat <bytes>)
+     
+     (def: #export <max>
+       <name>
+       (|> <bytes> (n/* i64.bits-per-byte) dec i64.mask :abstraction))
+     
+     (def: #export <constructor>
+       (-> Int <name>)
+       (let [limit (|> <bytes> (n/* i64.bits-per-byte) i64.mask .nat)]
+         (|>> (i64.and limit) :abstraction)))
+
+     (def: #export (<+> parameter subject)
+       (-> <name> <name> <name>)
+       (let [limit (|> <bytes> (n/* i64.bits-per-byte) i64.mask .nat)]
+         (:abstraction
+          (i64.and limit
+                   (i/+ (:representation parameter)
+                        (:representation subject))))))]
+
+    [1 S1 s1-bytes s1 max-s1 s1/+]
+    [2 S2 s2-bytes s2 max-s2 s2/+]
+    [4 S4 s4-bytes s4 max-s4 s4/+]
+    )
+  )
+
+(template [<parser-name> <writer-name> <type> <parser> <writer> <post-read>]
+  [(def: #export <parser-name>
+     (Parser <type>)
+     (<>@map (|>> .int <post-read>) <parser>))
+
+   (def: #export <writer-name>
+     (Writer <type>)
+     (|>> ..int <writer>))]
+
+  [s1-parser s1-writer S1 <2>.bits/8 binaryF.bits/8  ..s1]
+  [s2-parser s2-writer S2 <2>.bits/16 binaryF.bits/16 ..s2]
+  [s4-parser s4-writer S4 <2>.bits/32 binaryF.bits/32 ..s4]
+  )
diff --git a/stdlib/source/lux/target/jvm/program.lux b/stdlib/source/lux/target/jvm/program.lux
index 774094c5b..61e5a9046 100644
--- a/stdlib/source/lux/target/jvm/program.lux
+++ b/stdlib/source/lux/target/jvm/program.lux
@@ -23,7 +23,8 @@
    ["/#" // #_
     ["#." index]
     [encoding
-     ["#." unsigned (#+ U1 U2)]]
+     ["#." unsigned (#+ U1 U2)]
+     ["#." signed]]
     ["#." constant (#+ UTF8)
      ["#/."pool (#+ Pool)]]]])
 
@@ -343,7 +344,7 @@
   (exception.report
    ["Label" (%.nat label)]
    ["Start" (%.nat @from)]
-   ["Target" (|> jump //unsigned.nat .int %.int)]))
+   ["Target" (|> jump //signed.int %.int)]))
 
 (def: (jump @from @to)
   (-> Address Address (Either Jump Big-Jump))
@@ -354,8 +355,8 @@
                                -1)
                              jump)))]
     (if big?
-      (#.Right (//unsigned.u4 (.nat jump)))
-      (#.Left (//unsigned.u2 (.nat jump))))))
+      (#.Right (//signed.s4 jump))
+      (#.Left (//signed.s2 jump)))))
 
 (template [<name> <instruction>]
   [(def: #export (<name> label)
diff --git a/stdlib/source/lux/target/jvm/program/instruction.lux b/stdlib/source/lux/target/jvm/program/instruction.lux
index 83efb98b7..375204cc8 100644
--- a/stdlib/source/lux/target/jvm/program/instruction.lux
+++ b/stdlib/source/lux/target/jvm/program/instruction.lux
@@ -26,7 +26,8 @@
     ["#." descriptor (#+ Field Method)]
     ["#." constant (#+ Class Reference)]
     [encoding
-     ["#." unsigned (#+ U1 U2 U4)]]]])
+     ["#." unsigned (#+ U1 U2 U4)]
+     ["#." signed (#+ S2 S4)]]]])
 
 (type: #export Size Nat)
 
@@ -56,47 +57,27 @@
   [(n/+ 1 size)
    (|>> mutation ((nullary' code)))])
 
-(def: (unary/1' code input0)
-  (-> Code U1 Mutation)
-  (function (_ [offset binary])
-    [(n/+ 2 offset)
-     (try.assume
-      (do try.monad
-        [_ (binary.write/8 offset code binary)]
-        (binary.write/8 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
-
-(def: (unary/1 code input0 [size mutation])
-  (-> Code U1 (-> Specification Specification))
-  [(n/+ 2 size)
-   (|>> mutation ((unary/1' code input0)))])
-
-(def: (unary/2' code input0)
-  (-> Code U2 Mutation)
-  (function (_ [offset binary])
-    [(n/+ 3 offset)
-     (try.assume
-      (do try.monad
-        [_ (binary.write/8 offset code binary)]
-        (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
-
-(def: (unary/2 code input0 [size mutation])
-  (-> Code U2 (-> Specification Specification))
-  [(n/+ 3 size)
-   (|>> mutation ((unary/2' code input0)))])
-
-(def: (unary/4' code input0)
-  (-> Code U4 Mutation)
-  (function (_ [offset binary])
-    [(n/+ 5 offset)
-     (try.assume
-      (do try.monad
-        [_ (binary.write/8 offset code binary)]
-        (binary.write/16 (n/+ 1 offset) (///unsigned.nat input0) binary)))]))
-
-(def: (unary/4 code input0 [size mutation])
-  (-> Code U4 (-> Specification Specification))
-  [(n/+ 5 size)
-   (|>> mutation ((unary/4' code input0)))])
+(template [<shift> <name> <inputT> <writer> <unwrap>]
+  [(with-expansions [<private> (template.identifier [<name> "'"])]
+     (def: (<private> code input0)
+       (-> Code <inputT> Mutation)
+       (function (_ [offset binary])
+         [(n/+ <shift> offset)
+          (try.assume
+           (do try.monad
+             [_ (binary.write/8 offset code binary)]
+             (<writer> (n/+ 1 offset) (<unwrap> input0) binary)))]))
+
+     (def: (<name> code input0 [size mutation])
+       (-> Code <inputT> (-> Specification Specification))
+       [(n/+ <shift> size)
+        (|>> mutation ((<private> code input0)))]))]
+
+  [2 unary/1 U1 binary.write/8 ///unsigned.nat]
+  [3 unary/2 U2 binary.write/16 ///unsigned.nat]
+  [3 jump/2 S2 binary.write/16 ///signed.int]
+  [5 jump/4 S4 binary.write/32 ///signed.int]
+  )
 
 (def: (binary/11' code input0 input1)
   (-> Code U1 U1 Mutation)
@@ -464,7 +445,6 @@
       ["13" ldc-w/float [[index (Index ///constant.Float)]] [(///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 []]
-      <jumps>
       <fields>
       ["BB" new [[index (Index Class)]] [(///index.number index)] 0 1 []]
       ["BD" anewarray [[index (Index Class)]] [(///index.number index)] 1 1 []]
@@ -474,7 +454,10 @@
       ["B7" invokespecial [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]
       ["B8" invokestatic [[index (Index (Reference Method))] [count U1] [output-count U1]] [(///index.number index)] (///unsigned.nat count) (///unsigned.nat output-count) []]]]
 
-    [..unary/4 5
+    [..jump/2 3
+     [<jumps>]]
+
+    [..jump/4 5
      [["C8" goto-w [[jump Big-Jump]] [jump] 0 0 []]
       ["C9" jsr-w [[jump Big-Jump]] [jump] 0 1 []]]]
 
diff --git a/stdlib/source/lux/target/jvm/program/jump.lux b/stdlib/source/lux/target/jvm/program/jump.lux
index 49a4e42ea..00b66bede 100644
--- a/stdlib/source/lux/target/jvm/program/jump.lux
+++ b/stdlib/source/lux/target/jvm/program/jump.lux
@@ -4,17 +4,17 @@
     [equivalence (#+ Equivalence)]]]
   ["." /// #_
    [encoding
-    ["#." unsigned (#+ U2 U4)]]])
+    ["#." signed (#+ S2 S4)]]])
 
-(type: #export Jump U2)
+(type: #export Jump S2)
 
 (def: #export equivalence
-  ///unsigned.equivalence)
+  ///signed.equivalence)
 
 (def: #export parser
-  ///unsigned.u2-parser)
+  ///signed.s2-parser)
 
 (def: #export writer
-  ///unsigned.u2-writer)
+  ///signed.s2-writer)
 
-(type: #export Big-Jump U4)
+(type: #export Big-Jump S4)