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