From c842140f744a5e4d99da0c1cf62ee4b0c5a12cdf Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= <gregoire.henry@ocamlpro.com>
Date: Thu, 17 Nov 2016 14:56:27 +0100
Subject: [PATCH] Shell: introduce `Compare.Uint{32,64}`

---
 src/proto/bootstrap/script_int_repr.ml | 31 +++++++++++---------------
 src/proto/environment/compare.mli      |  2 ++
 src/utils/compare.ml                   | 26 +++++++++++++++++++++
 src/utils/compare.mli                  |  2 ++
 4 files changed, 43 insertions(+), 18 deletions(-)

diff --git a/src/proto/bootstrap/script_int_repr.ml b/src/proto/bootstrap/script_int_repr.ml
index 37a44ff16..e97e2ae66 100644
--- a/src/proto/bootstrap/script_int_repr.ml
+++ b/src/proto/bootstrap/script_int_repr.ml
@@ -141,23 +141,18 @@ let logsr _ (Int va) (Int vb) =
   Int (Int64.shift_right_logical va (Int64.to_int vb))
 
 (* sign aware comparison *)
-let signed_compare va vb =
-  Compare.Int64.(if va = vb then 0 else if va > vb then 1 else -1)
-let unsigned_compare va vb =
-  Compare.Int64.(if va >= 0L then if vb >= 0L then signed_compare va vb else -1
-                 else if vb >= 0L then 1 else signed_compare va vb)
 let compare
   : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (signed, sixtyfour) int_val
   = fun kind (Int va) (Int vb) ->
     let cmp = match kind with
-      | Int8 -> signed_compare va vb
-      | Uint8 -> unsigned_compare va vb
-      | Int16 -> signed_compare va vb
-      | Uint16 -> unsigned_compare va vb
-      | Int32 -> signed_compare va vb
-      | Uint32 -> unsigned_compare va vb
-      | Int64 -> signed_compare va vb
-      | Uint64 -> unsigned_compare va vb in
+      | Int8 -> Compare.Int64.compare va vb
+      | Uint8 -> Compare.Uint64.compare va vb
+      | Int16 -> Compare.Int64.compare va vb
+      | Uint16 -> Compare.Uint64.compare va vb
+      | Int32 -> Compare.Int64.compare va vb
+      | Uint32 -> Compare.Uint64.compare va vb
+      | Int64 -> Compare.Int64.compare va vb
+      | Uint64 -> Compare.Uint64.compare va vb in
     Int Compare.Int.(if cmp = 0 then 0L else if cmp > 0 then 1L else -1L)
 
 let equal kind va vb =
@@ -172,9 +167,9 @@ let checked_add : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val
     | Uint16 -> checked_of_int64 Uint16 r
     | Int32 -> checked_of_int64 Int32 r
     | Uint32 -> checked_of_int64 Uint32 r
-    | Int64 when Compare.Int.(signed_compare r va < 0) -> None
+    | Int64 when Compare.Int.(Compare.Int64.compare r va < 0) -> None
     | Int64 -> Some (Int r)
-    | Uint64 when Compare.Int.(unsigned_compare r va < 0) -> None
+    | Uint64 when Compare.Int.(Compare.Uint64.compare r va < 0) -> None
     | Uint64 -> Some (Int r)
 
 let checked_sub : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val -> (s, l) int_val option
@@ -186,10 +181,10 @@ let checked_sub : type s l. (s, l) int_kind -> (s, l) int_val -> (s, l) int_val
     | Int32 -> checked_of_int64 Int32 r
     | Uint32 -> checked_of_int64 Uint32 r
     | Int64 when Compare.Int64.(vb >= 0L) ->
-        if Compare.Int.(signed_compare r va <= 0) then Some (Int r) else None
+        if Compare.Int.(Compare.Int64.compare r va <= 0) then Some (Int r) else None
     | Int64 ->
-        if Compare.Int.(signed_compare r va >= 0) then Some (Int r) else None
-    | Uint64 when Compare.Int.(unsigned_compare r va > 0) -> None
+        if Compare.Int.(Compare.Int64.compare r va >= 0) then Some (Int r) else None
+    | Uint64 when Compare.Int.(Compare.Uint64.compare r va > 0) -> None
     | Uint64 -> Some (Int r)
 
 let checked_neg : type l. (signed, l) int_kind -> (signed, l) int_val -> (signed, l) int_val option
diff --git a/src/proto/environment/compare.mli b/src/proto/environment/compare.mli
index e288ddb52..c743b4d76 100644
--- a/src/proto/environment/compare.mli
+++ b/src/proto/environment/compare.mli
@@ -16,7 +16,9 @@ module Char : S with type t = char
 module Bool : S with type t = bool
 module Int : S with type t = int
 module Int32 : S with type t = int32
+module Uint32 : S with type t = int32
 module Int64 : S with type t = int64
+module Uint64 : S with type t = int64
 module Float : S with type t = float
 module String : S with type t = string
 module List(P : S) : S with type t = P.t list
diff --git a/src/utils/compare.ml b/src/utils/compare.ml
index f528f22d5..d63cd9cd9 100644
--- a/src/utils/compare.ml
+++ b/src/utils/compare.ml
@@ -85,6 +85,32 @@ module Int64 = struct
   let min x y = if x <= y then x else y
 end
 
+module MakeUnsigned(Int : S)(Z : sig val zero : Int.t end) = struct
+  type t = Int.t
+  let compare va vb =
+    Int.(if va >= Z.zero then if vb >= Z.zero then compare va vb else -1
+           else if vb >= Z.zero then 1 else compare va vb)
+  let (=) = ((=) : t -> t -> bool)
+  let (<>) = ((<>) : t -> t -> bool)
+  let (<) a b =
+    Int.(if Z.zero <= a then
+             (a < b || b < Z.zero)
+           else
+             (b < Z.zero && a < b))
+  let (<=) a b =
+    Int.(if Z.zero <= a then
+             (a <= b || b < Z.zero)
+           else
+             (b < Z.zero && a <= b))
+  let (>=) a b = (<=) b a
+  let (>) a b = (<) b a
+  let max x y = if x >= y then x else y
+  let min x y = if x <= y then x else y
+end
+
+module Uint32 = MakeUnsigned(Int32)(struct let zero = 0l end)
+module Uint64 = MakeUnsigned(Int64)(struct let zero = 0L end)
+
 module Float = struct
   type t = float
   let (=) = ((=) : t -> t -> bool)
diff --git a/src/utils/compare.mli b/src/utils/compare.mli
index 887131002..05894db96 100644
--- a/src/utils/compare.mli
+++ b/src/utils/compare.mli
@@ -24,7 +24,9 @@ module Char : S with type t = char
 module Bool : S with type t = bool
 module Int : S with type t = int
 module Int32 : S with type t = int32
+module Uint32 : S with type t = int32
 module Int64 : S with type t = int64
+module Uint64 : S with type t = int64
 module Float : S with type t = float
 module String : S with type t = string
 module List(P : S) : S with type t = P.t list