Skip to content

Commit

Permalink
Merge pull request #49 from rixed/master
Browse files Browse the repository at this point in the history 
Fix various bugs in signed integers related to sign-extension
  • Loading branch information
@rgrinberg
rgrinberg authored Oct 27, 2020
2 parents 48f97cd + 8b58e6b commit b280abd
Show file tree
Hide file tree
Showing 5 changed files with 92 additions and 18 deletions.
7 changes: 7 additions & 0 deletions lib/int40_stubs.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,13 @@

static const int64_t mask = 0xFFFFFFFFFF000000LL;

CAMLprim value
int40_mul(value v1, value v2)
{
CAMLparam2(v1, v2);
CAMLreturn (copy_int40(Int40_val(v1) * Int64_val(v2)));
}

CAMLprim value
int40_div(value v1, value v2)
{
Expand Down
7 changes: 7 additions & 0 deletions lib/int48_stubs.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,13 @@

static const int64_t mask = 0xFFFFFFFFFFFF0000LL;

CAMLprim value
int48_mul(value v1, value v2)
{
CAMLparam2(v1, v2);
CAMLreturn (copy_int48(Int48_val(v1) * Int64_val(v2)));
}

CAMLprim value
int48_div(value v1, value v2)
{
Expand Down
7 changes: 7 additions & 0 deletions lib/int56_stubs.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,13 @@

static const int64_t mask = 0xFFFFFFFFFFFFFF00LL;

CAMLprim value
int56_mul(value v1, value v2)
{
CAMLparam2(v1, v2);
CAMLreturn (copy_int56(Int56_val(v1) * Int64_val(v2)));
}

CAMLprim value
int56_div(value v1, value v2)
{
Expand Down
18 changes: 9 additions & 9 deletions lib/stdint.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -432,11 +432,11 @@ module Int40 = struct
let fmt = "ll"
let name = "Int40"

external mul : int40 -> int40 -> int40 = "uint40_mul"
external mul : int40 -> int40 -> int40 = "int40_mul"
external div : int40 -> int40 -> int40 = "int40_div"
external logxor : int40 -> int40 -> int40 = "uint40_xor"
external shift_right : int40 -> int -> int40 = "uint40_shift_right"
external shift_right_logical : int40 -> int -> int40 = "int40_shift_right"
external shift_right : int40 -> int -> int40 = "int40_shift_right"
external shift_right_logical : int40 -> int -> int40 = "uint40_shift_right"

external of_int : int -> int40 = "int40_of_int"
external of_nativeint : nativeint -> int40 = "int40_of_nativeint"
Expand Down Expand Up @@ -516,11 +516,11 @@ module Int48 = struct
let fmt = "ll"
let name = "Int48"

external mul : int48 -> int48 -> int48 = "uint48_mul"
external mul : int48 -> int48 -> int48 = "int48_mul"
external div : int48 -> int48 -> int48 = "int48_div"
external logxor : int48 -> int48 -> int48 = "uint48_xor"
external shift_right : int48 -> int -> int48 = "uint48_shift_right"
external shift_right_logical : int48 -> int -> int48 = "int48_shift_right"
external shift_right : int48 -> int -> int48 = "int48_shift_right"
external shift_right_logical : int48 -> int -> int48 = "uint48_shift_right"

external of_int : int -> int48 = "int48_of_int"
external of_nativeint : nativeint -> int48 = "int48_of_nativeint"
Expand Down Expand Up @@ -600,11 +600,11 @@ module Int56 = struct
let fmt = "ll"
let name = "Int56"

external mul : int56 -> int56 -> int56 = "uint56_mul"
external mul : int56 -> int56 -> int56 = "int56_mul"
external div : int56 -> int56 -> int56 = "int56_div"
external logxor : int56 -> int56 -> int56 = "uint56_xor"
external shift_right : int56 -> int -> int56 = "uint56_shift_right"
external shift_right_logical : int56 -> int -> int56 = "int56_shift_right"
external shift_right : int56 -> int -> int56 = "int56_shift_right"
external shift_right_logical : int56 -> int -> int56 = "uint56_shift_right"

external of_int : int -> int56 = "int56_of_int"
external of_nativeint : nativeint -> int56 = "int56_of_nativeint"
Expand Down
71 changes: 62 additions & 9 deletions tests/stdint_test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ end
let skip name = QCheck.Test.make ~count:0 ~name
let test name = QCheck.Test.make ~count:10 ~name

module Tester (I : Stdint.Int) : TESTER =
module IntBounds (I : Stdint.Int) =
struct
let mini, maxi =
if I.(to_int max_int) = -1 then
Expand All @@ -25,6 +25,13 @@ struct
let pos_int = QCheck.map_same_type abs in_range
let in_range_float =
QCheck.float_range (float_of_int mini) (float_of_int maxi)
end

module Tester (I : Stdint.Int) : TESTER =
struct
include IntBounds (I)

let ( *** ) = ( * ) (* Preserve int mul for later use *)

open I

Expand All @@ -38,29 +45,39 @@ struct
test "An integer should not modify strings when converted"
in_range (fun x -> to_string (of_int x) = string_of_int x) ;

test "An unsigned integer should perform logical and correctly"
test "An integer should perform logical-and correctly"
(QCheck.pair pos_int pos_int) (fun (x, y) ->
to_int (logand (of_int x) (of_int y)) = x land y) ;

test "An unsigned integer should perform logical or correctly"
test "An integer should perform logical-or correctly"
(QCheck.pair pos_int pos_int) (fun (x, y) ->
to_int (logor (of_int x) (of_int y)) = x lor y) ;

test "An unsigned integer should perform logical xor correctly"
test "An integer should perform logical-xor correctly"
(QCheck.pair pos_int pos_int) (fun (x, y) ->
to_int (logxor (of_int x) (of_int y)) = x lxor y) ;

test "An unsigned integer should perform logical not correctly"
test "An integer should perform logical-not correctly"
pos_int (fun x -> lognot (of_int x) = of_int (lnot x)) ;

test "An unsigned integer should perform left-shifts correctly"
test "An integer should perform left-shifts correctly"
QCheck.(pair in_range (int_bound 31)) (fun (x, y) ->
shift_left (of_int x) y = of_int (x lsl y)) ;

test "An integer should perform right-shifts correctly"
QCheck.(pair in_range (int_bound 31)) (fun (x, y) ->
shift_right (of_int x) y = of_int (x asr y)) ;

test "Arithmetic shifts must sign-extend"
QCheck.(int_range 0 200) (fun i ->
let v = shift_right min_int i in
(compare min_int zero) *** (compare v zero) >= 0) ;

test "Logical shifts must not sign-extend"
QCheck.(int_range 0 200) (fun i ->
let v = shift_right_logical min_int i in
compare v zero >= 0) ;

test "An integer should perform float conversions correctly"
in_range_float (fun x ->
to_float (of_float x) = float_of_int (int_of_float x)) ;
Expand Down Expand Up @@ -135,6 +152,24 @@ struct
]
end

module SignTester (I : Stdint.Int) =
struct
include IntBounds (I)

open I

let tests = [
test "A signed integer should perform negation correctly"
pos_int (fun x -> neg (of_int x) = of_int (~- x)) ;

test "Neg is like multiply by minus one"
in_range (fun x -> neg (of_int x) = mul (neg one) (of_int x)) ;

test "One can print after neg"
in_range (fun x -> mul (neg one) (of_int x) |> to_string = string_of_int ~-x) ;
]
end

let () =
let ok = ref 0 and ko = ref 0 in

Expand Down Expand Up @@ -242,12 +277,30 @@ let () =
"Int8 strings", (module OfStringTester (Stdint.Int8) : TESTER) ;
"Uint16 strings", (module OfStringTester (Stdint.Uint16) : TESTER) ;
"Int16 strings", (module OfStringTester (Stdint.Int16) : TESTER) ;
"Int32 strings", (module OfStringTester (Stdint.Int32) : TESTER) ;
"Uint24 strings", (module OfStringTester (Stdint.Uint24) : TESTER) ;
"Int24 strings", (module OfStringTester (Stdint.Int24) : TESTER) ;
"Uint32 strings", (module OfStringTester (Stdint.Uint32) : TESTER) ;
"Int64 strings", (module OfStringTester (Stdint.Int64) : TESTER) ;
"Int32 strings", (module OfStringTester (Stdint.Int32) : TESTER) ;
"Uint40 strings", (module OfStringTester (Stdint.Uint40) : TESTER) ;
"Int40 strings", (module OfStringTester (Stdint.Int40) : TESTER) ;
"Uint48 strings", (module OfStringTester (Stdint.Uint48) : TESTER) ;
"Int48 strings", (module OfStringTester (Stdint.Int48) : TESTER) ;
"Uint56 strings", (module OfStringTester (Stdint.Uint56) : TESTER) ;
"Int56 strings", (module OfStringTester (Stdint.Int56) : TESTER) ;
"Uint64 strings", (module OfStringTester (Stdint.Uint64) : TESTER) ;
"Int128 strings", (module OfStringTester (Stdint.Int128) : TESTER) ;
"Int64 strings", (module OfStringTester (Stdint.Int64) : TESTER) ;
"Uint128 strings", (module OfStringTester (Stdint.Uint128) : TESTER) ;
"Int128 strings", (module OfStringTester (Stdint.Int128) : TESTER) ;

"Int8 sign ops", (module SignTester (Stdint.Int8) : TESTER) ;
"Int16 sign ops", (module SignTester (Stdint.Int16) : TESTER) ;
"Int24 sign ops", (module SignTester (Stdint.Int24) : TESTER) ;
"Int32 sign ops", (module SignTester (Stdint.Int32) : TESTER) ;
"Int40 sign ops", (module SignTester (Stdint.Int40) : TESTER) ;
"Int48 sign ops", (module SignTester (Stdint.Int48) : TESTER) ;
"Int56 sign ops", (module SignTester (Stdint.Int56) : TESTER) ;
"Int64 sign ops", (module SignTester (Stdint.Int64) : TESTER) ;
"Int128 sign ops", (module SignTester (Stdint.Int128) : TESTER) ;
] in

List.iter (fun (n, m) ->
Expand Down

0 comments on commit b280abd

Please sign in to comment.