My working unpac space for OCaml projects in development
Merge opam/patches/optint
+1184
+12
vendor/opam/optint/.travis.yml
+12
vendor/opam/optint/.travis.yml
···
1
+
language: c
2
+
install:
3
+
- wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
4
+
script: bash -ex .travis-opam.sh
5
+
env:
6
+
global:
7
+
- PINS="optint.dev:."
8
+
matrix:
9
+
- PACKAGE="optint" OCAML_VERSION=4.08 TESTS=true
10
+
- PACKAGE="optint" OCAML_VERSION=4.09 TESTS=true
11
+
- PACKAGE="optint" OCAML_VERSION=4.10 TESTS=true
12
+
- PACKAGE="optint" OCAML_VERSION=4.11 TESTS=true
+56
vendor/opam/optint/CHANGES.md
+56
vendor/opam/optint/CHANGES.md
···
1
+
### v0.3.0 2022-12-16 Paris (France)
2
+
3
+
- Add infix operators for bitwise operations (@reynir, #23)
4
+
- Add a deprecation about old infix operators
5
+
They will be removed at the next minor release
6
+
7
+
### v0.2.0 2022-04-08 Paris (France)
8
+
9
+
- Fix the README.md (@sidkshatriya, #19)
10
+
- Fix fuzzers (@dinosaure, #20)
11
+
- Add a proof to introspect the type of `Optint.t` (@dinosaure, #21)
12
+
13
+
### v0.1.0 2021-03-30 Paris (France)
14
+
15
+
- Annotate integer types with `[@@immediate64]` (@CraigFe, #13)
16
+
- Move unwrapped module `Int63` to `Optint.Int63` (@CraigFe, #13)
17
+
18
+
### v0.0.5 2021-02-22 Paris (France)
19
+
20
+
- Update the README.md (@CraigFe, #9)
21
+
- Add a representation of 63-bit integers (@CraigFe, #9)
22
+
- Allow to compile fuzzers on 32-bit architectures (@dinosaure, #9)
23
+
- Add encode / decode functions for integers (@CraigFe, #9)
24
+
- Fix `optint` about sign and cast on all architectures (@dinosaure, #9)
25
+
- **breaking changes**, rename and handle properly sign-bit:
26
+
`{of,to}_int` become `{of,to}_unsigned_int`
27
+
`{of,to}_int32` become `{of,to}_unsigned_int32`
28
+
Previous functions handle sign-bit correctly
29
+
30
+
### v0.0.4 2020-03-09 Paris (France)
31
+
32
+
- Fix 32bit backend where we miss to fully apply
33
+
an `invalid_arg`
34
+
- Fix 64bit backend where `Native.unsigned_compare`
35
+
and `Nativeint.unsigned_div` exists (OCaml 4.08.0)
36
+
37
+
### v0.0.3 2010-09-12 Paris (France)
38
+
39
+
- Avoid partial application of function (#2, @dinosaure)
40
+
- Add `[@immediate]` tag (#4, @dinosaure)
41
+
- Fix `select.ml` in 32bit (#5, @IndiscriminateCoding)
42
+
- Fix typo (#6, @hannesm)
43
+
- Add fuzzer (#8, @dinosaure)
44
+
- Fix `lsr` and `asr` in 64bit (#8, @cfcs, @dinosaure)
45
+
- Optimization on `of_int` function (64bit) (#8, @cfcs, @dinosaure)
46
+
- Optimization on `abs` function (64bit) (#8, @cfcs, @dinosaure)
47
+
- Fix 32bit architecture, keep bit-sign in the same place (#8, @dinosaure, review @cfcs)
48
+
49
+
### v0.0.2 2018-10-15 Paris (France)
50
+
51
+
- _Dunify_ project
52
+
- Fix dependencies on `dune` file when we select impl. (@rgrinberg)
53
+
54
+
### v0.0.1 2018-06-28 Paris (France)
55
+
56
+
- First version of `optint`
+20
vendor/opam/optint/LICENSE.md
+20
vendor/opam/optint/LICENSE.md
···
1
+
The MIT License (MIT)
2
+
3
+
Copyright (c) 2018 Romain Calascibetta
4
+
5
+
Permission is hereby granted, free of charge, to any person obtaining a copy of
6
+
this software and associated documentation files (the "Software"), to deal in
7
+
the Software without restriction, including without limitation the rights to
8
+
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
9
+
the Software, and to permit persons to whom the Software is furnished to do so,
10
+
subject to the following conditions:
11
+
12
+
The above copyright notice and this permission notice shall be included in all
13
+
copies or substantial portions of the Software.
14
+
15
+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16
+
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
17
+
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
18
+
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
19
+
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
20
+
CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+40
vendor/opam/optint/README.md
+40
vendor/opam/optint/README.md
···
1
+
Optint - Efficient integer types on 64-bit architectures
2
+
========================================================
3
+
4
+
This library provides two new integer types, `Optint.t` and `Optint.Int63.t`,
5
+
which guarantee efficient representation on 64-bit architectures and provide a
6
+
best-effort boxed representation on 32-bit architectures.
7
+
8
+
## Goal
9
+
10
+
The standard `Int32.t` and `Int64.t` types provided by the standard library have
11
+
the same heap-allocated representation on all architectures. This consistent
12
+
representation has costs in both memory and run-time performance.
13
+
14
+
On 64-bit architectures, it's often more efficient to use the native `int`
15
+
directly.
16
+
This library provides types to do exactly this:
17
+
18
+
- `Optint.t`: an integer containing _at least_ 32 bits. On 64-bit, this is an
19
+
immediate integer; on 32-bit, it is a boxed 32-bit value. The overflow
20
+
behaviour is platform-dependent.
21
+
22
+
- `Optint.Int63.t`: an integer containing _exactly_ 63 bits. On 64-bit, this is
23
+
an immediate integer; on 32-bit, it is a boxed 64-bit integer that is wrapped
24
+
to provide 63-bit two's complement semantics. The two implementations are
25
+
observationally equivalent, modulo use of `Marshal` and `Obj`.
26
+
27
+
In summary:
28
+
29
+
| Integer type | 32-bit representation | 64-bit representation | Semantics |
30
+
| -- | -- | -- | -- |
31
+
| `Stdlib.Int.t` | 31-bit immediate ✅ | 63-bit immediate ✅ | Always immediate |
32
+
| `Stdlib.Nativeint.t` | 32-bit boxed ❌ | 64-bit boxed ❌ | Exactly word size |
33
+
| `Stdlib.Int32.t` | 32-bit boxed ❌ | 32-bit boxed ❌ | Exactly 32 bits |
34
+
| `Stdlib.Int64.t` | 64-bit boxed ❌ | 64-bit boxed ❌ | Exactly 64 bits |
35
+
| `Optint.t` (_new_) | 32-bit boxed ❌ | 63-bit immediate ✅ | _At least_ 32 bits |
36
+
| `Optint.Int63.t` (_new_) | 64-bit boxed ❌ | 63-bit immediate ✅ | Exactly 63 bits |
37
+
38
+
These new types are safe and well-tested, but their architecture-dependent
39
+
implementation makes them unsuitable for use with the `Marshal` module. Use the
40
+
provided encode and decode functions instead.
+19
vendor/opam/optint/fuzz/dune
+19
vendor/opam/optint/fuzz/dune
···
1
+
(executable
2
+
(name fuzz)
3
+
(modules fuzz)
4
+
(libraries fmt crowbar optint))
5
+
6
+
(alias
7
+
(name runtest)
8
+
(deps (:fuzz fuzz.exe))
9
+
(action (run %{fuzz})))
10
+
11
+
(executable
12
+
(name fuzz_int63)
13
+
(modules fuzz_int63)
14
+
(libraries monolith optint))
15
+
16
+
(alias
17
+
(name monolith)
18
+
(deps (:fuzz fuzz_int63.exe))
19
+
(action (run %{fuzz})))
+135
vendor/opam/optint/fuzz/fuzz.ml
+135
vendor/opam/optint/fuzz/fuzz.ml
···
1
+
let max_intl = 0x3fffffff
2
+
3
+
let () =
4
+
Crowbar.add_test ~name:"identity with int32" Crowbar.[ int32 ] @@ fun i32 ->
5
+
let v = Optint.of_int32 i32 in
6
+
let u = Optint.to_int32 v in
7
+
Crowbar.check_eq ~pp:Fmt.int32 ~eq:Int32.equal ~cmp:Int32.compare i32 u
8
+
9
+
let () =
10
+
Crowbar.add_test ~name:"identity with int" Crowbar.[ bool; range max_intl ] @@ fun s i ->
11
+
let i = if s then - i else i in
12
+
let v = Optint.of_int i in
13
+
let u = Optint.to_int v in
14
+
Crowbar.check_eq ~pp:Fmt.int ~eq:(=) ~cmp:compare i u
15
+
16
+
let binary_operator =
17
+
Crowbar.(choose [ const `Add
18
+
; const `Sub
19
+
; const `Mul
20
+
; const `Div
21
+
; const `Rem
22
+
; const `Lor
23
+
; const `Land
24
+
; const `Lxor ])
25
+
let unary_operator =
26
+
Crowbar.(choose [ const `Neg
27
+
; const `Succ
28
+
; const `Pred
29
+
; const `Lnot ])
30
+
31
+
type binary = [ `Add | `Sub | `Mul | `Div | `Rem | `Lor | `Land | `Lxor ]
32
+
type unary = [ `Neg | `Succ | `Pred | `Lnot ]
33
+
34
+
let generate ~of_int =
35
+
let edge = Crowbar.map Crowbar.[ bool; range max_intl ] @@ fun sign v -> match sign with
36
+
| false -> `V (of_int v)
37
+
| true -> `V (of_int (- v)) in
38
+
39
+
let edge_binary = Crowbar.map [ edge; edge; binary_operator ] @@ fun a b o -> [ a; b; o ] in
40
+
let node_binary = Crowbar.map [ edge; binary_operator ] @@ fun x o -> [ x; o ] in
41
+
42
+
let edge_unary = Crowbar.map [ edge; unary_operator ] @@ fun x o -> [ x; o ] in
43
+
let node_unary = Crowbar.map [ unary_operator ] @@ fun o -> [ o ] in
44
+
45
+
let edge = Crowbar.map [ edge ] @@ fun x -> [ x ] in
46
+
let edge = Crowbar.choose [ edge; edge_binary; edge_unary ] in
47
+
let node = Crowbar.choose [ node_binary; node_unary ] in
48
+
49
+
Crowbar.(map [ edge; list node ] @@ fun x r -> List.concat (x :: r))
50
+
51
+
module type ARITHMETIC = sig
52
+
type t
53
+
54
+
val add : t -> t -> t
55
+
val sub : t -> t -> t
56
+
val mul : t -> t -> t
57
+
val div : t -> t -> t
58
+
val rem : t -> t -> t
59
+
val logor : t -> t -> t
60
+
val logand : t -> t -> t
61
+
val logxor : t -> t -> t
62
+
63
+
val abs : t -> t
64
+
val neg : t -> t
65
+
val succ : t -> t
66
+
val pred : t -> t
67
+
val lognot : t -> t
68
+
end
69
+
70
+
type 'v p = [ binary | unary | `V of 'v ]
71
+
72
+
let pp_p ~pp_v ppf = function
73
+
| `Add -> Fmt.string ppf "+" | `Sub -> Fmt.string ppf "-" | `Mul -> Fmt.string ppf "*" | `Div -> Fmt.string ppf "/" | `Rem -> Fmt.string ppf "%"
74
+
| `Lor -> Fmt.string ppf "|" | `Land -> Fmt.string ppf "&" | `Lxor -> Fmt.string ppf "^"
75
+
| `Neg -> Fmt.string ppf "neg" | `Succ -> Fmt.string ppf "succ" | `Pred -> Fmt.string ppf "pred"
76
+
| `Lnot -> Fmt.string ppf "~"
77
+
| `V v -> pp_v ppf v
78
+
79
+
let rec binary
80
+
: type v. (module ARITHMETIC with type t = v) -> v -> v -> binary -> v p list -> v
81
+
= fun (module Arith) a b o r ->
82
+
let open Arith in
83
+
84
+
match o with
85
+
| `Add -> eval (module Arith) (`V (add a b) :: r)
86
+
| `Sub -> eval (module Arith) (`V (sub a b) :: r)
87
+
| `Mul -> eval (module Arith) (`V (mul a b) :: r)
88
+
| `Div -> eval (module Arith) (`V (div a b) :: r)
89
+
| `Rem -> eval (module Arith) (`V (rem a b) :: r)
90
+
| `Lor -> eval (module Arith) (`V (logor a b) :: r)
91
+
| `Land -> eval (module Arith) (`V (logand a b) :: r)
92
+
| `Lxor -> eval (module Arith) (`V (logxor a b) :: r)
93
+
94
+
and unary
95
+
: type v. (module ARITHMETIC with type t = v) -> v -> unary -> v p list -> v
96
+
= fun (module Arith) x o r ->
97
+
let open Arith in
98
+
99
+
match o with
100
+
| `Neg -> eval (module Arith) (`V (neg x) :: r)
101
+
| `Succ -> eval (module Arith) (`V (succ x) :: r)
102
+
| `Pred -> eval (module Arith) (`V (pred x) :: r)
103
+
| `Lnot -> eval (module Arith) (`V (lognot x) :: r)
104
+
105
+
and eval
106
+
: type v. (module ARITHMETIC with type t = v) -> v p list -> v
107
+
= fun arith -> function
108
+
| (`V a) :: (`V b) :: (#binary as o) :: r -> binary arith a b o r
109
+
| (`V x) :: (#unary as o) :: r -> unary arith x o r
110
+
| [ `V v ] -> v
111
+
| _ -> Crowbar.bad_test ()
112
+
113
+
let () =
114
+
Crowbar.add_test ~name:"computation" Crowbar.[ generate ~of_int:(fun x -> x) ] @@ fun l ->
115
+
(* XXX(dinosaure): FIXME even if it's not used. *)
116
+
if Sys.word_size = 32
117
+
then
118
+
let la = List.map
119
+
(function `V x -> `V (Optint.of_int x)
120
+
| (#binary | #unary) as x -> (x :> Optint.t p)) l in
121
+
let lb = List.map
122
+
(function `V x -> `V (Int32.of_int x)
123
+
| (#binary | #unary) as x -> (x :> int32 p)) l in
124
+
125
+
let a = try Some (eval (module Optint) la) with Division_by_zero -> None in
126
+
let b = try Some (eval (module Int32) lb) with Division_by_zero -> None in
127
+
match a, b with
128
+
| None, None -> ()
129
+
| Some _, None | None, Some _ -> Crowbar.bad_test ()
130
+
| Some a, Some b ->
131
+
if (b > 0x3fffffffl || b < -0x3fffffffl) then Crowbar.bad_test () ;
132
+
let a = Optint.to_int a in
133
+
let b = Int32.to_int b in
134
+
135
+
Crowbar.check_eq ~pp:(Fmt.fmt "%x") ~eq:(=) ~cmp:compare a b
+105
vendor/opam/optint/fuzz/fuzz_int63.ml
+105
vendor/opam/optint/fuzz/fuzz_int63.ml
···
1
+
open Monolith
2
+
3
+
let int = le Int.max_int
4
+
5
+
let int32 =
6
+
let gen_random =
7
+
let open Int32 in
8
+
let bits () = of_int (Gen.bits ()) in
9
+
fun () -> logxor (bits ()) (shift_left (bits ()) 30)
10
+
in
11
+
let pos = easily_constructible gen_random PPrint.OCaml.int32 in
12
+
let neg = deconstructible PPrint.OCaml.int32 in
13
+
ifpol pos neg
14
+
15
+
let float = deconstructible PPrint.OCaml.float
16
+
let string = deconstructible PPrint.string
17
+
18
+
module type INTEGER = module type of Optint.Int63.Boxed
19
+
20
+
module Fuzz_integer_equivalence (Reference : INTEGER) (Candidate : INTEGER) =
21
+
struct
22
+
module R = Reference
23
+
module C = Candidate
24
+
25
+
let encoded_string : (string, string) spec =
26
+
let check_valid r c =
27
+
let exception Incorrect_length of string in
28
+
let exception Different of string * string in
29
+
if not (String.length c = R.encoded_size) then raise (Incorrect_length c);
30
+
if not (String.equal r c) then raise (Different (r, c))
31
+
in
32
+
declare_abstract_type
33
+
~check:(fun r -> (check_valid r, document (PPrint.string r)))
34
+
()
35
+
36
+
module Wrap = struct
37
+
let pp f x =
38
+
f Format.str_formatter x;
39
+
Format.flush_str_formatter ()
40
+
41
+
let encode f x =
42
+
let buf = Bytes.create R.encoded_size in
43
+
f buf ~off:0 x;
44
+
Bytes.unsafe_to_string buf
45
+
46
+
let decode f s = f s ~off:0
47
+
end
48
+
49
+
let run t fuel =
50
+
let endo = t ^> t in
51
+
let binop = t ^> t ^> t in
52
+
let binop_exn = t ^> t ^!> t in
53
+
54
+
declare "zero" t R.zero C.zero;
55
+
declare "one" t R.one C.one;
56
+
declare "minus_one" t R.minus_one C.minus_one;
57
+
declare "max_int" t R.max_int C.max_int;
58
+
declare "min_int" t R.min_int C.min_int;
59
+
60
+
declare "succ" endo R.succ C.succ;
61
+
declare "pred" endo R.pred C.pred;
62
+
declare "abs" endo R.abs C.abs;
63
+
declare "neg" endo R.neg C.neg;
64
+
declare "add" binop R.add C.add;
65
+
declare "sub" binop R.sub C.sub;
66
+
declare "mul" binop R.mul C.mul;
67
+
declare "div" binop_exn R.div C.div;
68
+
declare "rem" binop_exn R.rem C.rem;
69
+
declare "logand" binop R.logand C.logand;
70
+
declare "logor" binop R.logor C.logor;
71
+
declare "logxor" binop R.logxor C.logxor;
72
+
declare "lognot" endo R.lognot C.lognot;
73
+
declare "shift_left" (t ^> int ^> t) R.shift_left C.shift_left;
74
+
declare "shift_right" (t ^> int ^> t) R.shift_right C.shift_right;
75
+
declare "shift_right_logical"
76
+
(t ^> int ^> t)
77
+
R.shift_right_logical C.shift_right_logical;
78
+
79
+
declare "compare" (t ^> t ^> int) R.compare C.compare;
80
+
declare "equal" (t ^> t ^> bool) R.equal C.equal;
81
+
82
+
declare "of_int" (int ^> t) R.of_int C.of_int;
83
+
declare "to_int" (t ^> int) R.to_int C.to_int;
84
+
declare "of_int32" (int32 ^> t) R.of_int32 C.of_int32;
85
+
declare "to_int32" (t ^> int32) R.to_int32 C.to_int32;
86
+
declare "to_float" (t ^> float) R.to_float C.to_float;
87
+
declare "to_string" (t ^> string) R.to_string C.to_string;
88
+
89
+
declare "pp" (t ^> string) (Wrap.pp R.pp) (Wrap.pp C.pp);
90
+
declare "encoded_size" int R.encoded_size C.encoded_size;
91
+
declare "encode" (t ^> encoded_string) (Wrap.encode R.encode)
92
+
(Wrap.encode C.encode);
93
+
declare "decode" (encoded_string ^> t) (Wrap.decode R.decode)
94
+
(Wrap.decode C.decode);
95
+
96
+
main fuel
97
+
end
98
+
99
+
module Reference = Optint.Int63
100
+
module Candidate = Optint.Int63.Boxed
101
+
module Int63_equiv = Fuzz_integer_equivalence (Reference) (Candidate)
102
+
103
+
let () =
104
+
let t : (Reference.t, Candidate.t) spec = declare_abstract_type () in
105
+
Int63_equiv.run t 5
+1
vendor/opam/optint/fuzz/fuzz_int63.mli
+1
vendor/opam/optint/fuzz/fuzz_int63.mli
···
1
+
(* Intentionally empty *)
vendor/opam/optint/fuzz/output/crashes/empty
vendor/opam/optint/fuzz/output/crashes/empty
This is a binary file and will not be displayed.
+28
vendor/opam/optint/optint.opam
+28
vendor/opam/optint/optint.opam
···
1
+
opam-version: "2.0"
2
+
maintainer: [ "romain.calascibetta@gmail.com" ]
3
+
authors: "Romain Calascibetta"
4
+
license: "ISC"
5
+
homepage: "https://github.com/mirage/optint"
6
+
bug-reports: "https://github.com/mirage/optint/issues"
7
+
dev-repo: "git+https://github.com/mirage/optint.git"
8
+
doc: "https://mirage.github.io/optint/"
9
+
synopsis: "Efficient integer types on 64-bit architectures"
10
+
description: """
11
+
This library provides two new integer types, `Optint.t` and `Optint.Int63.t`,
12
+
which guarantee efficient representation on 64-bit architectures and provide a
13
+
best-effort boxed representation on 32-bit architectures.
14
+
15
+
Implementation depends on target architecture.
16
+
"""
17
+
18
+
build: ["dune" "build" "-p" name "-j" jobs]
19
+
run-test: [ "dune" "runtest" "-p" name "-j" jobs ]
20
+
21
+
depends: [
22
+
"ocaml" {>= "4.07.0"}
23
+
"dune"
24
+
"crowbar" {with-test & >= "0.2"}
25
+
"monolith" {with-test}
26
+
"fmt" {with-test}
27
+
]
28
+
x-maintenance-intent: [ "(latest)" ]
+152
vendor/opam/optint/src/int63_emul.ml
+152
vendor/opam/optint/src/int63_emul.ml
···
1
+
(* On 32-bit systems, we emulate a 63-bit integer via a boxed 64-bit integer
2
+
with its lowest bit set to 0. The remaining 63 bits are left-shifted by one
3
+
place. This is analogous to the standard encoding of [int], with the bottom
4
+
bit set to 0 rather than 1.
5
+
6
+
See {{:https://github.com/janestreet/base/blob/master/src/int63_emul.ml}[Base.Int63_emul]}
7
+
for a similar encoding that has subtly different guarantees. This
8
+
implementation seeks to be strictly observationally equivalent to the
9
+
unemulated one (on 64-bit architectures), at the cost of performance of
10
+
certain functions.
11
+
*)
12
+
13
+
type t = int64
14
+
15
+
(* The following all preserve semantics under our chosen encoding. *)
16
+
include (Int64 : sig
17
+
val add : t -> t -> t
18
+
val sub : t -> t -> t
19
+
val rem : t -> t -> t
20
+
val neg : t -> t
21
+
val abs : t -> t
22
+
val logand : t -> t -> t
23
+
val logor : t -> t -> t
24
+
val shift_left : t -> int -> t
25
+
val equal : t -> t -> bool
26
+
val compare : t -> t -> int
27
+
end)
28
+
29
+
let invalid_arg fmt = Format.kasprintf invalid_arg fmt
30
+
31
+
module Conv : sig
32
+
val wrap_exn : int64 -> t (* Raises if the [int64] has its topmost bit set. *)
33
+
val wrap_modulo : int64 -> t (* Discards the topmost bit of the [int64]. *)
34
+
35
+
val unwrap : t -> int64 (* Lossless, assuming [t] satisfies the encoding. *)
36
+
end = struct
37
+
let int64_fits_on_int63 =
38
+
let min = Int64.(shift_right min_int) 1 in
39
+
let max = Int64.(shift_right max_int) 1 in
40
+
fun x -> Int64.compare min x <= 0 && Int64.compare x max <= 0
41
+
42
+
let wrap_modulo x = Int64.mul x 2L
43
+
let wrap_exn x =
44
+
if int64_fits_on_int63 x then
45
+
Int64.mul x 2L
46
+
else
47
+
Printf.ksprintf failwith
48
+
"Conversion from int64 to int63 failed: %Ld is out of range" x
49
+
50
+
let unwrap x = Int64.shift_right x 1
51
+
end
52
+
53
+
let unset_bottom_bit =
54
+
let mask = 0xffff_ffff_ffff_fffEL in
55
+
fun x -> Int64.logand x mask
56
+
57
+
let min_int = unset_bottom_bit Int64.min_int
58
+
let max_int = unset_bottom_bit Int64.max_int
59
+
let minus_one = Conv.wrap_exn (-1L)
60
+
let zero = Conv.wrap_exn 0L
61
+
let one = Conv.wrap_exn 1L
62
+
63
+
let succ x = add x one
64
+
let pred x = sub x one
65
+
66
+
let mul x y = Int64.mul x (Conv.unwrap y)
67
+
let div x y =
68
+
let r = Int64.div x y in
69
+
if Int64.equal r 0x4000_0000_0000_0000L then
70
+
(* This case happens when we overflow via [ min_int / 1 ], in which case we
71
+
should wrap back to [ min_int ]. *)
72
+
min_int
73
+
else
74
+
Conv.wrap_modulo r
75
+
76
+
let lognot x = unset_bottom_bit (Int64.lognot x)
77
+
let logxor x y = unset_bottom_bit (Int64.logxor x y)
78
+
let shift_right x i = unset_bottom_bit (Int64.shift_right x i)
79
+
let shift_right_logical x i = unset_bottom_bit (Int64.shift_right_logical x i)
80
+
81
+
let to_int x = Int64.to_int (Conv.unwrap x)
82
+
let of_int x = Conv.wrap_exn (Int64.of_int x)
83
+
let to_int32 x = Int64.to_int32 (Conv.unwrap x)
84
+
let of_int32 x = Conv.wrap_exn (Int64.of_int32 x)
85
+
let to_int64 x = Conv.unwrap x
86
+
let of_int64 x = Conv.wrap_exn x
87
+
let to_float x = Int64.to_float (Conv.unwrap x)
88
+
let of_float x = Conv.wrap_exn (Int64.of_float x)
89
+
90
+
let to_string x = Int64.to_string (Conv.unwrap x)
91
+
let of_string x = Conv.wrap_exn (Int64.of_string x)
92
+
let of_string_opt x = try Some (of_string x) with _ -> None
93
+
94
+
let pp ppf x = Format.fprintf ppf "%Ld" (Conv.unwrap x)
95
+
96
+
let to_unsigned_int x =
97
+
let max_int = of_int Stdlib.max_int in
98
+
if compare zero x <= 0 && compare x max_int <= 0
99
+
then to_int x
100
+
else invalid_arg "Int63.to_unsigned_int: %Lx can not fit into a 31 bits unsigned integer" x
101
+
102
+
let without_bit_sign (x:int) = if x >= 0 then x else x land (lnot 0x40000000)
103
+
104
+
let of_unsigned_int x =
105
+
if x < 0
106
+
then logor 0x40000000L (of_int (without_bit_sign x))
107
+
else of_int x
108
+
109
+
let to_unsigned_int32 x =
110
+
let max_int = of_int32 Int32.max_int in
111
+
if compare zero x <= 0 && compare x max_int <= 0
112
+
then to_int32 x
113
+
else invalid_arg "Int63.to_unsigned_int32: %Lx can not fit into a 32 bits unsigned integer" x
114
+
115
+
let of_unsigned_int32 x =
116
+
if x < 0l
117
+
then logor 0x80000000L (of_int32 (Int32.logand x (Int32.lognot 0x80000000l)))
118
+
else of_int32 x
119
+
120
+
let encoded_size = 8
121
+
122
+
external set_64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u"
123
+
external get_64 : string -> int -> int64 = "%caml_string_get64"
124
+
external swap64 : int64 -> int64 = "%bswap_int64"
125
+
126
+
let encode buf ~off t =
127
+
let t = to_int64 t in
128
+
let t = if not Sys.big_endian then swap64 t else t in
129
+
set_64 buf off t
130
+
131
+
let decode buf ~off =
132
+
let t = get_64 buf off in
133
+
let t = if not Sys.big_endian then swap64 t else t in
134
+
of_int64 t
135
+
136
+
module Infix = struct
137
+
let ( + ) a b = add a b
138
+
let ( - ) a b = sub a b
139
+
let ( * ) a b = mul a b
140
+
let ( % ) a b = rem a b
141
+
let ( / ) a b = div a b
142
+
let ( land ) a b = logand a b
143
+
let ( lor ) a b = logor a b
144
+
let ( lsr ) a b = shift_right a b
145
+
let ( lsl ) a b = shift_left a b
146
+
147
+
let ( && ) = ( land )
148
+
let ( || ) = ( lor )
149
+
let ( >> ) = ( lsr )
150
+
let ( << ) = ( lsl )
151
+
152
+
end
+1
vendor/opam/optint/src/int63_emul.mli
+1
vendor/opam/optint/src/int63_emul.mli
···
1
+
include Integer_interface.S
+95
vendor/opam/optint/src/int63_native.ml
+95
vendor/opam/optint/src/int63_native.ml
···
1
+
type t = int
2
+
3
+
let zero = 0
4
+
let one = 1
5
+
let minus_one = -1
6
+
let neg x = -x
7
+
let add a b = a + b
8
+
let sub a b = a - b
9
+
let mul a b = a * b
10
+
let div a b = a / b
11
+
let rem a b = a mod b
12
+
let succ x = succ x
13
+
let pred x = pred x
14
+
let logand a b = a land b
15
+
let logor a b = a lor b
16
+
let logxor a b = a lxor b
17
+
let lognot x = lnot x
18
+
let shift_left a n = a lsl n
19
+
let shift_right a n = a asr n
20
+
let shift_right_logical a n = a lsr n
21
+
let abs x = abs x
22
+
let max_int = max_int
23
+
let min_int = min_int
24
+
25
+
external of_int : t -> t = "%identity"
26
+
external to_int : t -> t = "%identity"
27
+
28
+
let to_int32 = Stdlib.Int32.of_int
29
+
let of_int32 = Stdlib.Int32.to_int
30
+
let to_int64 = Stdlib.Int64.of_int
31
+
let of_int64 = Stdlib.Int64.to_int
32
+
let of_float x = int_of_float x
33
+
let to_float x = float_of_int x
34
+
let of_string x = int_of_string x
35
+
let of_string_opt x = try Some (of_string x) with Failure _ -> None
36
+
let to_string x = string_of_int x
37
+
let equal : int -> int -> bool = fun a b -> a = b
38
+
let compare : int -> int -> int = fun a b -> compare a b
39
+
let pp = Format.pp_print_int
40
+
41
+
external to_unsigned_int : t -> int = "%identity"
42
+
external of_unsigned_int : int -> t = "%identity"
43
+
44
+
let invalid_arg fmt = Format.kasprintf invalid_arg fmt
45
+
46
+
let to_unsigned_int32 =
47
+
let uint32_mask = (0xffff lsl 16) lor 0xffff in
48
+
fun x ->
49
+
let truncated = x land uint32_mask in
50
+
if x <> truncated
51
+
then invalid_arg "Int63.to_unsigned_int32: %d can not fit into a 32 bits integer" x
52
+
else Int32.of_int truncated
53
+
54
+
let of_unsigned_int32 =
55
+
let int32_sign_mask = 1 lsl 31 in
56
+
let int32_sign_maskl = 0x80000000l in
57
+
fun x ->
58
+
if x < 0l then
59
+
let x = Int32.logand x (Int32.lognot int32_sign_maskl) in
60
+
Int32.to_int x lor int32_sign_mask
61
+
else Int32.to_int x
62
+
63
+
let encoded_size = 8
64
+
65
+
external set_64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u"
66
+
external get_64 : string -> int -> int64 = "%caml_string_get64"
67
+
external swap64 : int64 -> int64 = "%bswap_int64"
68
+
69
+
let encode buf ~off t =
70
+
let t = to_int64 t in
71
+
let t = if not Sys.big_endian then swap64 t else t in
72
+
set_64 buf off t
73
+
74
+
let decode buf ~off =
75
+
let t = get_64 buf off in
76
+
let t = if not Sys.big_endian then swap64 t else t in
77
+
of_int64 t
78
+
79
+
module Infix = struct
80
+
let ( + ) a b = add a b
81
+
let ( - ) a b = sub a b
82
+
let ( * ) a b = mul a b
83
+
let ( % ) a b = rem a b
84
+
let ( / ) a b = div a b
85
+
let ( land ) a b = logand a b
86
+
let ( lor ) a b = logor a b
87
+
let ( lsr ) a b = shift_right a b
88
+
let ( lsl ) a b = shift_left a b
89
+
90
+
let ( && ) = ( land )
91
+
let ( || ) = ( lor )
92
+
let ( >> ) = ( lsr )
93
+
let ( << ) = ( lsl )
94
+
95
+
end
+3
vendor/opam/optint/src/int63_native.mli
+3
vendor/opam/optint/src/int63_native.mli
+175
vendor/opam/optint/src/integer_interface.ml
+175
vendor/opam/optint/src/integer_interface.ml
···
1
+
module type S = sig
2
+
type t
3
+
4
+
val zero : t
5
+
(** Integer 0. *)
6
+
7
+
val one : t
8
+
(** Integer 1. *)
9
+
10
+
val minus_one : t
11
+
(** Integer (-1). *)
12
+
13
+
val neg : t -> t
14
+
(** Unary negation. *)
15
+
16
+
val add : t -> t -> t
17
+
(** Addition. *)
18
+
19
+
val sub : t -> t -> t
20
+
(** Subtraction. *)
21
+
22
+
val mul : t -> t -> t
23
+
(** Mulitplication. *)
24
+
25
+
val div : t -> t -> t
26
+
(** Integer division. Raise [Division_by_zero] if the second argument is zero.
27
+
This division rounds the real quotient of its arguments towrds zero. *)
28
+
29
+
val rem : t -> t -> t
30
+
(** Integer remainder. If [y] is not zero, the result of [rem x y] satisfies
31
+
the following property: [x = add (mul (div x y) y) (rem x y)]. if [y = 0],
32
+
[rem x y] raises [Division_by_zero]. *)
33
+
34
+
val succ : t -> t
35
+
(** Successor. [succ x] is [add x one]. *)
36
+
37
+
val pred : t -> t
38
+
(** Predecessor. [pred x] is [sub x one]. *)
39
+
40
+
val abs : t -> t
41
+
(** Return the absolute value its argument. *)
42
+
43
+
val max_int : t
44
+
(** The greatest representable integer. *)
45
+
46
+
val min_int : t
47
+
(** The smallest representable integer. *)
48
+
49
+
val logand : t -> t -> t
50
+
(** Bitwise logical and. *)
51
+
52
+
val logor : t -> t -> t
53
+
(** Bitwise logical or. *)
54
+
55
+
val logxor : t -> t -> t
56
+
(** Bitwise logical exclusive or. *)
57
+
58
+
val lognot : t -> t
59
+
(** Bitwise logical negation. *)
60
+
61
+
val shift_left : t -> int -> t
62
+
(** [shift_left x y] shifts [x] to the left by [y] bits. The result is
63
+
unspecified if [y < 0] or [y >= (32 || 63)]. *)
64
+
65
+
val shift_right : t -> int -> t
66
+
(** [shift_right x y] shifts [x] to the right by [y] bits. This is an
67
+
arithmetic shift: the sign bit of [x] is replicated and inserted in the
68
+
vacated bits. The result is unspecified if [y < 0] or [y >= (32 || 63)]. *)
69
+
70
+
val shift_right_logical : t -> int -> t
71
+
(** [shift_right_logical x y] shifts [x] to the right by [y] bits. This is a
72
+
logical shift: zeroes are inserted in the vacated bits regardless of the
73
+
sign of [x] / The result is unspecified if [y < 0] or [y >= (32 || 63)]. *)
74
+
75
+
val of_int : int -> t
76
+
(** Convert the given integer (type [int] ) to {!t}. It's an unsafe function
77
+
whose semantic is different from architecture. *)
78
+
79
+
val to_int : t -> int
80
+
(** Convert the given {!t} integer to an integer (type [int] ). On 64-bit
81
+
platforms, the conversion is exact. On 32-bit platforms, the 32-bit
82
+
integer is taken modulo 2 {^ 31}, i.e. the high-order bit is lost during
83
+
the conversion. *)
84
+
85
+
val of_int32 : int32 -> t
86
+
(** Convert the given 32-bit integer (type [int32]) to {!t} integer. It's an
87
+
unsafe function whose semantic is different from architecture. *)
88
+
89
+
val to_int32 : t -> int32
90
+
(** Convert the given {!t} integer to a 32-bit integer. *)
91
+
92
+
val of_int64 : int64 -> t
93
+
(** Convert the given 64-bit integer (type [int64]) to {!t} integer. *)
94
+
95
+
val to_int64 : t -> int64
96
+
(** Covert the given {!t} integer to a 64-bit integer. *)
97
+
98
+
val of_float : float -> t
99
+
(** Convert the given floating-point number to a {!t} integer, discarding the
100
+
fractional part (truncate towards 0). The result of the conversion is
101
+
undefined if, after truncation, the number is outside the range
102
+
{!min_int}, {!max_int}. *)
103
+
104
+
val to_float : t -> float
105
+
(** Convert the given {!t} integer to a floating-point number. *)
106
+
107
+
val of_string : string -> t
108
+
(** Convert the given string to a {!t} integer. The string is read in decimal
109
+
(by default, or if the string begins with [0u]) or in hexadecimal, octal
110
+
or binary if the string begins with [0x], [0o] or [0b] respectively.
111
+
112
+
The [0u] prefix reads the input as an unsigned integer in the range
113
+
[\[0, 2 * max_int + 1\]]. If the input exceeds {!max_int} it is converted
114
+
to the signed integer [min_int + input - max_int - 1].
115
+
116
+
The [_] (underscore) character can appear anywhere in the string is
117
+
ignored. Raise [Failure _] if the given string is not a valid
118
+
representation of an integer, or if the integer represented exceeds the
119
+
range of integer, or if the integer represented exceeds the range of
120
+
integers representable in type {!t}. *)
121
+
122
+
val of_string_opt : string -> t option
123
+
(** Same as [of_string], but return [None] instead of raising. *)
124
+
125
+
val to_string : t -> string
126
+
(** Return the string representation of its argument, in decimal. *)
127
+
128
+
val compare : t -> t -> int
129
+
(** The comparison function for {!t} integers, with the same specification as
130
+
{!Stdlib.compare}. Along with the type [t], this function [compare] allows
131
+
the module [Optint] to be passed as argument to the functors {!Set.Make}
132
+
and {!Map.Make}. *)
133
+
134
+
val equal : t -> t -> bool
135
+
(** The equal function for {!t}. *)
136
+
137
+
val pp : Format.formatter -> t -> unit
138
+
(** The pretty-printer for {!t}. *)
139
+
140
+
(** {2 Encoding functions}
141
+
142
+
Efficient fixed-length big-endian encoding functions for {!t} integers: *)
143
+
144
+
val encode : bytes -> off:int -> t -> unit
145
+
val decode : string -> off:int -> t
146
+
147
+
val encoded_size : int
148
+
(** The number of bytes in the {{!encode} encoded} form of {!t}. *)
149
+
150
+
val to_unsigned_int32 : t -> int32
151
+
val of_unsigned_int32 : int32 -> t
152
+
val to_unsigned_int : t -> int
153
+
val of_unsigned_int : int -> t
154
+
155
+
module Infix : sig
156
+
val ( + ) : t -> t -> t
157
+
val ( - ) : t -> t -> t
158
+
val ( * ) : t -> t -> t
159
+
val ( % ) : t -> t -> t
160
+
val ( / ) : t -> t -> t
161
+
val ( land ) : t -> t -> t
162
+
val ( lor ) : t -> t -> t
163
+
val ( lsr ) : t -> int -> t
164
+
val ( lsl ) : t -> int -> t
165
+
166
+
val ( && ) : t -> t -> t
167
+
[@@ocaml.deprecated "Please use ( land )."]
168
+
val ( || ) : t -> t -> t
169
+
[@@ocaml.deprecated "Please use ( lor )."]
170
+
val ( >> ) : t -> int -> t
171
+
[@@ocaml.deprecated "Please use ( lsr )."]
172
+
val ( << ) : t -> int -> t
173
+
[@@ocaml.deprecated "Please use ( lsl )."]
174
+
end
175
+
end
+77
vendor/opam/optint/src/optint.ml
+77
vendor/opam/optint/src/optint.ml
···
1
+
(** Extraction of [Stdlib.Sys.Immediate64] for pre-4.10 compatibility.
2
+
[Immediate64] was originally authored by Jeremie Dimino <jeremie@dimino.org>,
3
+
and is licensed along with the OCaml compiler system under LGPLv2. See the
4
+
{{:https://github.com/ocaml/ocaml/blob/trunk/LICENSE} compiler license} for
5
+
details.
6
+
7
+
For soundness of the [@@immediate64] annotation, we ensure to use the boxed
8
+
representation only when not on 64-bit platforms, but we need to use The
9
+
Force to convince the type system of this fact. *)
10
+
module Immediate64 = struct
11
+
module type Non_immediate = sig
12
+
type t
13
+
end
14
+
15
+
module type Immediate = sig
16
+
type t [@@immediate]
17
+
end
18
+
19
+
module Make (Immediate : Immediate) (Non_immediate : Non_immediate) = struct
20
+
type t [@@immediate64]
21
+
22
+
type 'a repr =
23
+
| Immediate : Immediate.t repr
24
+
| Non_immediate : Non_immediate.t repr
25
+
26
+
external magic : _ repr -> t repr = "%identity"
27
+
28
+
let repr =
29
+
if Sys.word_size = 64 then magic Immediate else magic Non_immediate
30
+
end
31
+
end
32
+
33
+
module Conditional = struct
34
+
type ('t, 'u, 'v) t =
35
+
| True : ('t, 't, _) t (** therefore ['t] = ['u] *)
36
+
| False : ('t, _, 't) t (** therefore ['t] = ['v] *)
37
+
end
38
+
39
+
module Optint = struct
40
+
include Immediate64.Make (Optint_native) (Optint_emul)
41
+
42
+
module type S = Integer_interface.S with type t := t
43
+
44
+
let impl : (module S) =
45
+
match repr with
46
+
| Immediate -> (module Optint_native : S)
47
+
| Non_immediate -> (module Optint_emul : S)
48
+
49
+
include (val impl : S)
50
+
51
+
let is_immediate : (t, int, int32) Conditional.t =
52
+
match repr with
53
+
| Immediate -> True
54
+
| Non_immediate -> False
55
+
end
56
+
57
+
module Int63 = struct
58
+
include Immediate64.Make (Int63_native) (Int63_emul)
59
+
60
+
module type S = Integer_interface.S with type t := t
61
+
62
+
let impl : (module S) =
63
+
match repr with
64
+
| Immediate -> (module Int63_native : S)
65
+
| Non_immediate -> (module Int63_emul : S)
66
+
67
+
include (val impl : S)
68
+
69
+
module Boxed = Int63_emul
70
+
71
+
let is_immediate : (t, int, Boxed.t) Conditional.t =
72
+
match repr with
73
+
| Immediate -> True
74
+
| Non_immediate -> False
75
+
end
76
+
77
+
include Optint
+36
vendor/opam/optint/src/optint.mli
+36
vendor/opam/optint/src/optint.mli
···
1
+
type t [@@immediate64]
2
+
(** The type of integers with {i at least} 32 bits.
3
+
For 63-bit integers, see {!Int63}. *)
4
+
5
+
include Integer_interface.S with type t := t
6
+
(** @inline *)
7
+
8
+
(** {1 Other modules} *)
9
+
10
+
(** A conditional type equality, used for revealing that a type [t] has one of
11
+
two possible implementation types [u] and [v]. *)
12
+
module Conditional : sig
13
+
type ('t, 'u, 'v) t =
14
+
| True : ('t, 't, _) t (** therefore ['t] = ['u] *)
15
+
| False : ('t, _, 't) t (** therefore ['t] = ['v] *)
16
+
end
17
+
18
+
val is_immediate : (t, int, int32) Conditional.t
19
+
20
+
(** 63-bit integers. *)
21
+
module Int63 : sig
22
+
type t [@@immediate64]
23
+
(** The type of integers with exactly 63-bits. *)
24
+
25
+
include Integer_interface.S with type t := t
26
+
(** @inline *)
27
+
28
+
module Boxed : Integer_interface.S
29
+
(** An implementation of 63-bit integers that always uses a boxed
30
+
representation regardless of word size. *)
31
+
32
+
(** [is_immediate] reveals the implementation of {!t} on the current
33
+
platform, and can be used to build [Int63] operations that behave
34
+
differently depending on the underlying representation, such as FFIs. *)
35
+
val is_immediate : (t, int, Boxed.t) Conditional.t
36
+
end
+89
vendor/opam/optint/src/optint_emul.ml
+89
vendor/opam/optint/src/optint_emul.ml
···
1
+
include Int32
2
+
3
+
external of_int32 : int32 -> t = "%identity"
4
+
external of_unsigned_int32 : int32 -> t = "%identity"
5
+
external to_int32 : t -> int32 = "%identity"
6
+
external to_unsigned_int32 : t -> int32 = "%identity"
7
+
8
+
let to_int64 = Int64.of_int32
9
+
let of_int64 = Int64.to_int32
10
+
11
+
let pp ppf (x:t) = Format.fprintf ppf "%ld" x
12
+
13
+
let without_bit_sign (x:int) = if x >= 0 then x else x land (lnot 0x40000000)
14
+
15
+
let invalid_arg fmt = Format.kasprintf invalid_arg fmt
16
+
17
+
(* XXX(dinosaure): the diff between [to_int] and [to_unsigned_int]
18
+
* is about the sign-bit [0x40000000][int]/[0x80000000][int32].
19
+
*
20
+
* For [to_int], we ensure for a negative number that we use only
21
+
* [0x3fffffff][int32] bits two most significant bits are set to [1].
22
+
* In that case, it safes to cast the [int32] to and [int] (31 bits).
23
+
*
24
+
* For [to_unsigned_int], we don't want to interpret if the value is
25
+
* negative or positive. However, if the number can be interpreted as a
26
+
* negative nnumber, due to the two's complement layout, we are sure
27
+
* to lost, at least, the most significant bit which is a part of unsigned
28
+
* [int32]. So we are able to only accept "positive" numbers.
29
+
*
30
+
* NOTE: we trust on the two's complement! *)
31
+
32
+
let to_int x =
33
+
let max_int = of_int Stdlib.max_int in
34
+
if compare zero x <= 0 && compare x max_int <= 0
35
+
then to_int x (* XXX(dinosaure): positive and can fit into a 31-bit integer. *)
36
+
else if compare zero x > 0 && Int32.logand 0xC0000000l x = 0xC0000000l
37
+
then let x = Int32.logand x 0x7fffffffl in to_int x
38
+
else invalid_arg "Optint.to_int: %lx can not fit into a 31 bits integer" x
39
+
40
+
let to_unsigned_int x =
41
+
let max_int = of_int Stdlib.max_int in
42
+
if compare zero x <= 0 && compare x max_int <= 0
43
+
then to_int x
44
+
else invalid_arg "Optint.to_unsigned_int: %lx can not fit into a 31 bits unsigned integer" x
45
+
46
+
let of_int x =
47
+
if x < 0
48
+
then logor 0xC0000000l (of_int (without_bit_sign x))
49
+
else of_int x
50
+
51
+
let of_unsigned_int x =
52
+
if x < 0
53
+
then logor 0x40000000l (of_int (without_bit_sign x))
54
+
else of_int x
55
+
56
+
let encoded_size = 4
57
+
58
+
external set_32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32u"
59
+
external get_32 : string -> int -> int32 = "%caml_string_get32"
60
+
external swap32 : int32 -> int32 = "%bswap_int32"
61
+
62
+
let encode buf ~off t =
63
+
let t = to_int32 t in
64
+
let t = if not Sys.big_endian then swap32 t else t in
65
+
set_32 buf off t
66
+
67
+
let decode buf ~off =
68
+
let t = get_32 buf off in
69
+
let t = if not Sys.big_endian then swap32 t else t in
70
+
of_int32 t
71
+
72
+
module Infix = struct
73
+
let ( + ) a b = add a b
74
+
let ( - ) a b = sub a b
75
+
let ( * ) a b = mul a b
76
+
let ( % ) a b = rem a b
77
+
let ( / ) a b = div a b
78
+
79
+
let ( land ) a b = logand a b
80
+
let ( lor ) a b = logor a b
81
+
let ( lsr ) a b = shift_right a b
82
+
let ( lsl ) a b = shift_left a b
83
+
84
+
let ( && ) = ( land )
85
+
let ( || ) = ( lor )
86
+
let ( >> ) = ( lsr )
87
+
let ( << ) = ( lsl )
88
+
89
+
end
+1
vendor/opam/optint/src/optint_emul.mli
+1
vendor/opam/optint/src/optint_emul.mli
···
1
+
include Integer_interface.S with type t = int32
+126
vendor/opam/optint/src/optint_native.ml
+126
vendor/opam/optint/src/optint_native.ml
···
1
+
type t = int
2
+
3
+
let zero = 0
4
+
let one = 1
5
+
let minus_one = (-1)
6
+
let neg x = (-x)
7
+
let add a b = a + b
8
+
let sub a b = a - b
9
+
let mul a b = a * b
10
+
11
+
let _unsigned_compare n m =
12
+
let open Nativeint in
13
+
compare (sub n min_int) (sub m min_int)
14
+
15
+
let _unsigned_div n d =
16
+
let open Nativeint in
17
+
if d < zero then
18
+
if _unsigned_compare n d < 0 then zero else one
19
+
else
20
+
let q = shift_left (div (shift_right_logical n 1) d) 1 in
21
+
let r = sub n (mul q d) in
22
+
if _unsigned_compare r d >= 0 then succ q else q
23
+
24
+
let div a b = Nativeint.to_int (_unsigned_div (Nativeint.of_int a) (Nativeint.of_int b))
25
+
let rem a b = a mod b
26
+
let succ x = x + 1
27
+
let pred x = x - 1
28
+
let abs x =
29
+
let mask = x asr Sys.int_size in (* extract sign: -1 if signed, 0 if not signed *)
30
+
(x + mask) lxor mask
31
+
let max_int = Int32.(to_int max_int)
32
+
let min_int = Int32.(to_int min_int)
33
+
let logand a b = a land b
34
+
let logor a b = a lor b
35
+
let logxor a b = a lxor b
36
+
let lognot x = lnot x
37
+
let shift_left a n = a lsl n
38
+
let shift_right a n = a asr n
39
+
let shift_right_logical a n = a lsr n
40
+
external of_int : int -> t = "%identity"
41
+
external of_unsigned_int : int -> t = "%identity"
42
+
external to_int : t -> int = "%identity"
43
+
external to_unsigned_int : t -> int = "%identity"
44
+
let to_int64 = Stdlib.Int64.of_int
45
+
let of_int64 = Stdlib.Int64.to_int
46
+
let of_float x = int_of_float x
47
+
let to_float x = (* allocation *) float_of_int x
48
+
let of_string x = int_of_string x
49
+
let of_string_opt x = try (* allocation *) Some (of_string x) with Failure _ -> None
50
+
let to_string x = string_of_int x
51
+
let compare : int -> int -> int = fun a b -> a - b
52
+
let equal : int -> int -> bool = fun a b -> a = b
53
+
54
+
let invalid_arg fmt = Format.kasprintf invalid_arg fmt
55
+
56
+
let uint32_max = (0xffff lsl 16) lor 0xffff
57
+
let int32_sign_maskl = 0x80000000l
58
+
let int32_sign_mask = 1 lsl 31
59
+
let int32_maxl = 0x7fffffffl
60
+
let int32_max = 0x7fffffff
61
+
62
+
let to_int32 x =
63
+
let truncated = x land uint32_max in
64
+
if x = truncated then Int32.of_int truncated
65
+
else if compare 0 x > 0 && (x lsr 31) = uint32_max
66
+
then Int32.(logor int32_sign_maskl (of_int (x land int32_max)))
67
+
else invalid_arg "Optint.to_int32: %d can not fit into a 32 bits integer" x
68
+
69
+
let to_unsigned_int32 x =
70
+
let truncated = x land uint32_max in
71
+
if x <> truncated
72
+
then invalid_arg "Optint.to_unsigned_int32: %d can not fit into a 32 bits integer" x
73
+
else Int32.of_int truncated
74
+
75
+
let of_int32 =
76
+
let negative_int32_mask = (int32_max lsl 32) lor int32_sign_mask in
77
+
fun x ->
78
+
if x < 0l
79
+
then
80
+
let x = Int32.logand x int32_maxl in
81
+
negative_int32_mask lor (Int32.to_int x)
82
+
else Int32.to_int x
83
+
84
+
let of_unsigned_int32 x =
85
+
if x < 0l
86
+
then
87
+
let x = Int32.logand x (Int32.lognot int32_sign_maskl) in
88
+
(Int32.to_int x) lor int32_sign_mask
89
+
else Int32.to_int x
90
+
91
+
let pp ppf (x:t) = Format.fprintf ppf "%d" x
92
+
93
+
let encoded_size = 4
94
+
95
+
external set_32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32u"
96
+
external get_32 : string -> int -> int32 = "%caml_string_get32"
97
+
external swap32 : int32 -> int32 = "%bswap_int32"
98
+
99
+
let encode buf ~off t =
100
+
let t = to_int32 t in
101
+
let t = if not Sys.big_endian then swap32 t else t in
102
+
set_32 buf off t
103
+
104
+
let decode buf ~off =
105
+
let t = get_32 buf off in
106
+
let t = if not Sys.big_endian then swap32 t else t in
107
+
of_int32 t
108
+
109
+
module Infix = struct
110
+
let ( + ) a b = add a b
111
+
let ( - ) a b = sub a b
112
+
let ( * ) a b = mul a b
113
+
let ( % ) a b = rem a b
114
+
let ( / ) a b = div a b
115
+
116
+
let ( land ) a b = logand a b
117
+
let ( lor ) a b = logor a b
118
+
let ( lsr ) a b = shift_right a b
119
+
let ( lsl ) a b = shift_left a b
120
+
121
+
let ( && ) = ( land )
122
+
let ( || ) = ( lor )
123
+
let ( >> ) = ( lsr )
124
+
let ( << ) = ( lsl )
125
+
126
+
end