/**

Implementation of Z module.

This file is part of the Zarith library

http://forge.ocamlcore.org/projects/zarith .

It is distributed under LGPL 2 licensing, with static linking exception.

See the LICENSE file included in the distribution.

Copyright (c) 2010-2011 Antoine Miné, Abstraction project.

Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),

a joint laboratory by:

CNRS (Centre national de la recherche scientifique, France),

ENS (École normale supérieure, Paris, France),

INRIA Rocquencourt (Institut national de recherche en informatique, France).

*/

/*---------------------------------------------------

INCLUDES

---------------------------------------------------*/

#include <stdio.h>

#include <stdlib.h>

#include <string.h>

#include <math.h>

#include <stdint.h>

#include <limits.h>

#ifdef HAS_GMP

#include <gmp.h>

#endif

#ifdef HAS_MPIR

#include <mpir.h>

#endif

#include "zarith.h"

#ifdef __cplusplus

extern "C" {

#endif

#include <caml/mlvalues.h>

#include <caml/memory.h>

#include <caml/alloc.h>

#include <caml/fail.h>

#include <caml/custom.h>

#include <caml/intext.h>

#include <caml/callback.h>

#include <caml/intext.h>

#include <caml/hash.h>

#define inline __inline

#ifdef _MSC_VER

#include <float.h>

#include <intrin.h>

#endif

/* The "__has_builtin" special macro from Clang */

#ifdef __has_builtin

#define HAS_BUILTIN(x) __has_builtin(x)

#else

#define HAS_BUILTIN(x) 0

#endif

/*---------------------------------------------------

CONFIGURATION

---------------------------------------------------*/

/* Whether to enable native (i.e. non-mpn_) operations and output

ocaml integers when possible.

Highly recommended.

*/

#define Z_FAST_PATH 1

#define Z_USE_NATINT 1

/* Whether the fast path (arguments and result are small integers)

has already be handled in OCaml, so that there is no need to

re-test for it in C functions.

Applies to: neg, abs, add, sub, mul, div, rem, succ, pred,

logand, logor, logxor, lognot, shifts, divexact.

*/

#define Z_FAST_PATH_IN_OCAML 1

/* Sanity checks. */

#define Z_PERFORM_CHECK 0

/* Enable performance counters.

Prints some info on stdout at exit.

*/

/*

#define Z_PERF_COUNTER 0

now set by configure

*/

/* whether to use custom blocks (supporting serialization, comparison &

hashing) instead of abstract tags

*/

#define Z_CUSTOM_BLOCK 1

/*---------------------------------------------------

DATA STRUCTURES

---------------------------------------------------*/

/*

we assume that:

- intnat is a signed integer type

- mp_limb_t is an unsigned integer type

- sizeof(intnat) == sizeof(mp_limb_t) == either 4 or 8

*/

#ifdef _WIN64

#define PRINTF_LIMB "I64"

#else

#define PRINTF_LIMB "l"

#endif

/*

A z object x can be:

- either an ocaml int

- or a block with abstract or custom tag and containing:

. a 1 value header containing the sign Z_SIGN(x) and the size Z_SIZE(x)

. Z_SIZE(x) mp_limb_t

Invariant:

- if the number fits in an int, it is stored in an int, not a block

- if the number is stored in a block, then Z_SIZE(x) >= 1 and

the most significant limb Z_LIMB(x)[Z_SIZE(x)] is not 0

*/

/* a sign is always denoted as 0 (+) or Z_SIGN_MASK (-) */

#ifdef ARCH_SIXTYFOUR

#define Z_SIGN_MASK 0x8000000000000000

#define Z_SIZE_MASK 0x7fffffffffffffff

#else

#define Z_SIGN_MASK 0x80000000

#define Z_SIZE_MASK 0x7fffffff

#endif

#if Z_CUSTOM_BLOCK

#define Z_HEAD(x) (*((value*)Data_custom_val((x))))

#define Z_LIMB(x) ((mp_limb_t*)Data_custom_val((x)) + 1)

#else

#define Z_HEAD(x) (Field((x),0))

#define Z_LIMB(x) ((mp_limb_t*)&(Field((x),1)))

#endif

#define Z_SIGN(x) (Z_HEAD((x)) & Z_SIGN_MASK)

#define Z_SIZE(x) (Z_HEAD((x)) & Z_SIZE_MASK)

/* bounds of an Ocaml int */

#ifdef ARCH_SIXTYFOUR

#define Z_MAX_INT 0x3fffffffffffffff

#define Z_MIN_INT (-0x4000000000000000)

#else

#define Z_MAX_INT 0x3fffffff

#define Z_MIN_INT (-0x40000000)

#endif

#define Z_FITS_INT(v) ((v) >= Z_MIN_INT && (v) <= Z_MAX_INT)

/* greatest/smallest double that can fit in an int */

#ifdef ARCH_SIXTYFOUR

#define Z_MAX_INT_FL 0x3ffffffffffffe00

#define Z_MIN_INT_FL (-0x4000000000000000)

#else

#define Z_MAX_INT_FL Z_MAX_INT

#define Z_MIN_INT_FL Z_MIN_INT

#endif

/* safe bounds to avoid overflow in multiplication */

#ifdef ARCH_SIXTYFOUR

#define Z_MAX_HINT 0x3fffffff

#else

#define Z_MAX_HINT 0x3fff

#endif

#define Z_MIN_HINT (-Z_MAX_HINT)

#define Z_FITS_HINT(v) ((v) >= Z_MIN_HINT && (v) <= Z_MAX_HINT)

/* hi bit of OCaml int32, int64 & nativeint */

#define Z_HI_INT32 0x80000000

#define Z_HI_UINT32 0x100000000LL

#define Z_HI_INT64 0x8000000000000000LL

#ifdef ARCH_SIXTYFOUR

#define Z_HI_INTNAT Z_HI_INT64

#define Z_HI_INT 0x4000000000000000

#else

#define Z_HI_INTNAT Z_HI_INT32

#define Z_HI_INT 0x40000000

#endif

/* safe bounds for the length of a base n string fitting in a native

int. Defined as the result of (n - 2) log_base(2) with n = 64 or

32.

*/

#ifdef ARCH_SIXTYFOUR

#define Z_BASE16_LENGTH_OP 15

#define Z_BASE10_LENGTH_OP 18

#define Z_BASE8_LENGTH_OP 20

#define Z_BASE2_LENGTH_OP 62

#else

#define Z_BASE16_LENGTH_OP 7

#define Z_BASE10_LENGTH_OP 9

#define Z_BASE8_LENGTH_OP 10

#define Z_BASE2_LENGTH_OP 30

#endif

#define Z_LIMB_BITS (8 * sizeof(mp_limb_t))

/* performance counters */

unsigned long ml_z_ops = 0;

unsigned long ml_z_slow = 0;

unsigned long ml_z_ops_as = 0;

#if Z_PERF_COUNTER

#define Z_MARK_OP ml_z_ops++

#define Z_MARK_SLOW ml_z_slow++

#else

#define Z_MARK_OP

#define Z_MARK_SLOW

#endif

/*---------------------------------------------------

UTILITIES

---------------------------------------------------*/

extern struct custom_operations ml_z_custom_ops;

static double ml_z_2p32; /* 2 ^ 32 in double */

#if Z_PERFORM_CHECK

/* for debugging: dump a mp_limb_t array */

static void ml_z_dump(const char* msg, mp_limb_t* p, mp_size_t sz)

{

mp_size_t i;

printf("%s %i: ",msg,(int)sz);

for (i = 0; i < sz; i++)

#ifdef ARCH_SIXTYFOUR

printf("%08" PRINTF_LIMB "x ",p[i]);

#else

printf("%04" PRINTF_LIMB "x ",p[i]);

#endif

printf("\n");

fflush(stdout);

}

#endif

#if Z_PERFORM_CHECK

/* for debugging: check invariant */

void ml_z_check(const char* fn, int line, const char* arg, value v)

{

mp_size_t sz;

if (Is_long(v)) {

#if Z_USE_NATINT

return;

#else

printf("ml_z_check: unexpected tagged integer for %s at %s:%i.\n", arg, fn, line);

exit(1);

#endif

}

#if Z_CUSTOM_BLOCK

if (Custom_ops_val(v) != &ml_z_custom_ops) {

printf("ml_z_check: wrong custom block for %s at %s:%i.\n",

arg, fn, line);

exit(1);

}

sz = Wosize_val(v) - 1;

#else

sz = Wosize_val(v);

#endif

if (Z_SIZE(v) + 2 > sz) {

printf("ml_z_check: invalid block size (%i / %i) for %s at %s:%i.\n",

(int)Z_SIZE(v), (int)sz,

arg, fn, line);

exit(1);

}

if ((mp_size_t) Z_LIMB(v)[sz - 2] != (mp_size_t)(0xDEADBEEF ^ (sz - 2))) {

printf("ml_z_check: corrupted block for %s at %s:%i.\n",

arg, fn, line);

exit(1);

}

if (Z_SIZE(v) && !Z_LIMB(v)[Z_SIZE(v)-1]) {

printf("ml_z_check: unreduced argument for %s at %s:%i.\n", arg, fn, line);

ml_z_dump("offending argument: ", Z_LIMB(v), Z_SIZE(v));

exit(1);

}

#if Z_USE_NATINT

if (Z_SIZE(v) == 0

|| (Z_SIZE(v) <= 1

&& (Z_LIMB(v)[0] <= Z_MAX_INT

|| (Z_LIMB(v)[0] == -Z_MIN_INT && Z_SIGN(v))))) {

printf("ml_z_check: expected a tagged integer for %s at %s:%i.\n", arg, fn, line);

ml_z_dump("offending argument: ", Z_LIMB(v), Z_SIZE(v));

exit(1);

}

#else

if (!Z_SIZE(v) && Z_SIGN(v)) {

printf("ml_z_check: invalid sign of 0 for %s at %s:%i.\n",

arg, fn, line);

exit(1);

}

#endif

}

#endif

/* for debugging */

#if Z_PERFORM_CHECK

#define Z_CHECK(v) ml_z_check(__FUNCTION__, __LINE__, #v, v)

#else

#define Z_CHECK(v)

#endif

/* allocates z object block with space for sz mp_limb_t;

does not set the header

*/

#if !Z_PERFORM_CHECK

/* inlined allocation */

#if Z_CUSTOM_BLOCK

#define ml_z_alloc(sz) \

caml_alloc_custom(&ml_z_custom_ops, (1 + (sz)) * sizeof(value), 0, 1)

#else

#define ml_z_alloc(sz) \

caml_alloc(1 + (sz), Abstract_tag);

#endif

#else

/* out-of-line allocation, inserting a canary after the last limb */

static value ml_z_alloc(mp_size_t sz)

{

value v;

#if Z_CUSTOM_BLOCK

v = caml_alloc_custom(&ml_z_custom_ops, (1 + sz + 1) * sizeof(value), 0, 1);

#else

v = caml_alloc(1 + sz + 1, Abstract_tag);

#endif

Z_LIMB(v)[sz] = 0xDEADBEEF ^ sz;

return v;

}

#endif

/* duplicates the caml block src */

static inline void ml_z_cpy_limb(mp_limb_t* dst, mp_limb_t* src, mp_size_t sz)

{

memcpy(dst, src, sz * sizeof(mp_limb_t));

}

/* duplicates the mp_limb_t array src */

static inline mp_limb_t* ml_z_dup_limb(mp_limb_t* src, mp_size_t sz)

{

mp_limb_t* r = (mp_limb_t*) malloc(sz * sizeof(mp_limb_t));

memcpy(r, src, sz * sizeof(mp_limb_t));

return r;

}

#ifdef _MSC_VER

#define MAYBE_UNUSED

#else

#define MAYBE_UNUSED (void)

#endif

/* given a z object, define:

- ptr_arg: a pointer to the first mp_limb_t

- size_arg: the number of mp-limb_t

- sign_arg: the sign of the number

if arg is an int, it is converted to a 1-limb number

*/

#define Z_DECL(arg) \

mp_limb_t loc_##arg, *ptr_##arg; \

mp_size_t size_##arg; \

intnat sign_##arg; \

MAYBE_UNUSED loc_##arg; \

MAYBE_UNUSED ptr_##arg; \

MAYBE_UNUSED size_##arg; \

MAYBE_UNUSED sign_##arg;

#define Z_ARG(arg) \

if (Is_long(arg)) { \

intnat n = Long_val(arg); \

loc_##arg = n < 0 ? -n : n; \

sign_##arg = n & Z_SIGN_MASK; \

size_##arg = n != 0; \

ptr_##arg = &loc_##arg; \

} \

else { \

size_##arg = Z_SIZE(arg); \

sign_##arg = Z_SIGN(arg); \

ptr_##arg = Z_LIMB(arg); \

}

/* After an allocation, a heap-allocated Z argument may have moved and

its ptr_arg pointer can be invalid. Reset the ptr_arg pointer to

its correct value. */

#define Z_REFRESH(arg) \

if (! Is_long(arg)) ptr_##arg = Z_LIMB(arg);

/* computes the actual size of the z object r and updates its header,

either returns r or, if the number is small enough, an int

*/

static value ml_z_reduce(value r, mp_size_t sz, intnat sign)

{

while (sz > 0 && !Z_LIMB(r)[sz-1]) sz--;

#if Z_USE_NATINT

if (!sz) return Val_long(0);

if (sz <= 1) {

if (Z_LIMB(r)[0] <= Z_MAX_INT) {

if (sign) return Val_long(-Z_LIMB(r)[0]);

else return Val_long(Z_LIMB(r)[0]);

}

if (Z_LIMB(r)[0] == -Z_MIN_INT && sign) {

return Val_long(Z_MIN_INT);

}

}

#else

if (!sz) sign = 0;

#endif

Z_HEAD(r) = sz | sign;

return r;

}

static void ml_z_raise_overflow()

{

caml_raise_constant(*caml_named_value("ml_z_overflow"));

}

#define ml_z_raise_divide_by_zero() \

caml_raise_zero_divide()

/*---------------------------------------------------

CONVERSION FUNCTIONS

---------------------------------------------------*/

CAMLprim value ml_z_of_int(value v)

{

#if Z_USE_NATINT

Z_MARK_OP;

return v;

#else

intnat x;

value r;

Z_MARK_OP;

Z_MARK_SLOW;

x = Long_val(v);

r = ml_z_alloc(1);

if (x > 0) { Z_HEAD(r) = 1; Z_LIMB(r)[0] = x; }

else if (x < 0) { Z_HEAD(r) = 1 | Z_SIGN_MASK; Z_LIMB(r)[0] = -x; }

else Z_HEAD(r) = 0;

Z_CHECK(r);

return r;

#endif

}

CAMLprim value ml_z_of_nativeint(value v)

{

intnat x;

value r;

Z_MARK_OP;

x = Nativeint_val(v);

#if Z_USE_NATINT

if (Z_FITS_INT(x)) return Val_long(x);

#endif

Z_MARK_SLOW;

r = ml_z_alloc(1);

if (x > 0) { Z_HEAD(r) = 1; Z_LIMB(r)[0] = x; }

else if (x < 0) { Z_HEAD(r) = 1 | Z_SIGN_MASK; Z_LIMB(r)[0] = -x; }

else Z_HEAD(r) = 0;

Z_CHECK(r);

return r;

}

CAMLprim value ml_z_of_int32(value v)

{

int32_t x;

Z_MARK_OP;

x = Int32_val(v);

#if Z_USE_NATINT && defined(ARCH_SIXTYFOUR)

return Val_long(x);

#else

#if Z_USE_NATINT

if (Z_FITS_INT(x)) return Val_long(x);

#endif

{

value r;

Z_MARK_SLOW;

r = ml_z_alloc(1);

if (x > 0) { Z_HEAD(r) = 1; Z_LIMB(r)[0] = x; }

else if (x < 0) { Z_HEAD(r) = 1 | Z_SIGN_MASK; Z_LIMB(r)[0] = -(mp_limb_t)x; }

else Z_HEAD(r) = 0;

Z_CHECK(r);

return r;

}

#endif

}

CAMLprim value ml_z_of_int64(value v)

{

int64_t x;

value r;

Z_MARK_OP;

x = Int64_val(v);

#if Z_USE_NATINT

if (Z_FITS_INT(x)) return Val_long(x);

#endif

Z_MARK_SLOW;

#ifdef ARCH_SIXTYFOUR

r = ml_z_alloc(1);

if (x > 0) { Z_HEAD(r) = 1; Z_LIMB(r)[0] = x; }

else if (x < 0) { Z_HEAD(r) = 1 | Z_SIGN_MASK; Z_LIMB(r)[0] = -x; }

else Z_HEAD(r) = 0;

#else

{

mp_limb_t sign;

r = ml_z_alloc(2);

if (x >= 0) { sign = 0; }

else { sign = Z_SIGN_MASK; x = -x; }

Z_LIMB(r)[0] = x;

Z_LIMB(r)[1] = x >> 32;

r = ml_z_reduce(r, 2, sign);

}

#endif

Z_CHECK(r);

return r;

}

CAMLprim value ml_z_of_float(value v)

{

double x;

int exp;

int64_t y, m;

value r;

Z_MARK_OP;

x = Double_val(v);

#if Z_USE_NATINT

if (x >= Z_MIN_INT_FL && x <= Z_MAX_INT_FL) return Val_long((intnat) x);

#endif

Z_MARK_SLOW;

#ifdef ARCH_ALIGN_INT64

memcpy(&y, (void *) v, 8);

#else

y = *((int64_t*)v);

#endif

exp = ((y >> 52) & 0x7ff) - 1023; /* exponent */

if (exp < 0) return(Val_long(0));

if (exp == 1024) ml_z_raise_overflow(); /* NaN or infinity */

m = (y & 0x000fffffffffffffLL) | 0x0010000000000000LL; /* mantissa */

if (exp <= 52) {

m >>= 52-exp;

#ifdef ARCH_SIXTYFOUR

r = Val_long((x >= 0.) ? m : -m);

#else

r = ml_z_alloc(2);

Z_LIMB(r)[0] = m;

Z_LIMB(r)[1] = m >> 32;

r = ml_z_reduce(r, 2, (x >= 0.) ? 0 : Z_SIGN_MASK);

#endif

}

else {

int c1 = (exp-52) / Z_LIMB_BITS;

int c2 = (exp-52) % Z_LIMB_BITS;

mp_size_t i;

#ifdef ARCH_SIXTYFOUR

r = ml_z_alloc(c1 + 2);

for (i = 0; i < c1; i++) Z_LIMB(r)[i] = 0;

Z_LIMB(r)[c1] = m << c2;

Z_LIMB(r)[c1+1] = c2 ? (m >> (64-c2)) : 0;

r = ml_z_reduce(r, c1 + 2, (x >= 0.) ? 0 : Z_SIGN_MASK);

#else

r = ml_z_alloc(c1 + 3);

for (i = 0; i < c1; i++) Z_LIMB(r)[i] = 0;

Z_LIMB(r)[c1] = m << c2;

Z_LIMB(r)[c1+1] = m >> (32-c2);

Z_LIMB(r)[c1+2] = c2 ? (m >> (64-c2)) : 0;

r = ml_z_reduce(r, c1 + 3, (x >= 0.) ? 0 : Z_SIGN_MASK);

#endif

}

Z_CHECK(r);

return r;

}

CAMLprim value ml_z_of_substring_base(value b, value v, value offset, value length)

{

CAMLparam1(v);

CAMLlocal1(r);

intnat ofs = Long_val(offset);

intnat len = Long_val(length);

/* make sure the ofs/length make sense */

if (ofs < 0

|| len < 0

|| (intnat)caml_string_length(v) < ofs + len)

caml_invalid_argument("Z.of_substring_base: invalid offset or length");

/* process the string */

const char *d = String_val(v) + ofs;

const char *end = d + len;

mp_size_t i, j, sz, sz2, num_digits = 0;

mp_limb_t sign = 0;

intnat base = Long_val(b);

/* We allow [d] to advance beyond [end] while parsing the prefix:

sign, base, and/or leading zeros.

This simplifies the code, and reading these locations is safe since

we don't progress beyond a terminating null character.

At the end of the prefix, if we ran past the end, we return 0.

*/

/* get optional sign */

if (*d == '-') { sign ^= Z_SIGN_MASK; d++; }

if (*d == '+') d++;

/* get optional base */

if (!base) {

base = 10;

if (*d == '0') {

d++;

if (*d == 'o' || *d == 'O') { base = 8; d++; }

else if (*d == 'x' || *d == 'X') { base = 16; d++; }

else if (*d == 'b' || *d == 'B') { base = 2; d++; }

else {

/* The leading zero is not part of a base prefix. This is an

important distinction for the check below looking at

leading underscore

*/

d--; }

}

}

if (base < 2 || base > 16)

caml_invalid_argument("Z.of_substring_base: base must be between 2 and 16");

/* we do not allow leading underscore */

if (*d == '_')

caml_invalid_argument("Z.of_substring_base: invalid digit");

while (*d == '0' || *d == '_') d++;

/* sz is the length of the substring that has not been consumed above. */

sz = end - d;

for(i = 0; i < sz; i++){

/* underscores are going to be ignored below. Assuming the string

is well formatted, this will give us the exact number of digits */

if(d[i] != '_') num_digits++;

}

#if Z_USE_NATINT

if (sz <= 0) {

/* "+", "-", "0x" are parsed as 0. */

r = Val_long(0);

}

/* Process common case (fits into a native integer) */

else if ((base == 10 && num_digits <= Z_BASE10_LENGTH_OP)

|| (base == 16 && num_digits <= Z_BASE16_LENGTH_OP)

|| (base == 8 && num_digits <= Z_BASE8_LENGTH_OP)

|| (base == 2 && num_digits <= Z_BASE2_LENGTH_OP)) {

Z_MARK_OP;

intnat ret = 0;

for (i = 0; i < sz; i++) {

int digit = 0;

if (d[i] == '_') continue;

if (d[i] >= '0' && d[i] <= '9') digit = d[i] - '0';

else if (d[i] >= 'a' && d[i] <= 'f') digit = d[i] - 'a' + 10;

else if (d[i] >= 'A' && d[i] <= 'F') digit = d[i] - 'A' + 10;

else caml_invalid_argument("Z.of_substring_base: invalid digit");

if (digit >= base)

caml_invalid_argument("Z.of_substring_base: invalid digit");

ret = ret * base + digit;

}

r = Val_long(ret * (sign ? -1 : 1));

} else

#endif

{

/* converts to sequence of digits */

char* digits = (char*)malloc(num_digits+1);

for (i = 0, j = 0; i < sz; i++) {

if (d[i] == '_') continue;

if (d[i] >= '0' && d[i] <= '9') digits[j] = d[i] - '0';

else if (d[i] >= 'a' && d[i] <= 'f') digits[j] = d[i] - 'a' + 10;

else if (d[i] >= 'A' && d[i] <= 'F') digits[j] = d[i] - 'A' + 10;

else {

free(digits);

caml_invalid_argument("Z.of_substring_base: invalid digit");

}

if (digits[j] >= base) {

free(digits);

caml_invalid_argument("Z.of_substring_base: invalid digit");

}

j++;

}

/* make sure that digits is nul terminated */

digits[j] = 0;

r = ml_z_alloc(1 + j / (2 * sizeof(mp_limb_t)));

sz2 = mpn_set_str(Z_LIMB(r), (unsigned char*)digits, j, base);

r = ml_z_reduce(r, sz2, sign);

free(digits);

}

Z_CHECK(r);

CAMLreturn(r);

}

/* either stores the result in r and returns 0 (no overflow),

or returns 1 and leave r undefined (overflow)

*/

static int ml_to_int(value v, intnat* r)

{

Z_DECL(v);

Z_MARK_OP;

Z_CHECK(v);

if (Is_long(v)) { *r = v; return 0; }

Z_MARK_SLOW;

Z_ARG(v);

if (size_v > 1) return 1;

else if (!size_v) { *r = Val_long(0); return 0; }

else {

intnat x = *ptr_v;

if (sign_v) {

if ((uintnat)x > Z_HI_INT) return 1;

*r = Val_long(-x);

}

else {

if ((uintnat)x >= Z_HI_INT) return 1;

*r = Val_long(x);

}

return 0;

}

}

CAMLprim value ml_z_to_int(value v)

{

value x;

if (ml_to_int(v, &x)) ml_z_raise_overflow();

return x;

}

CAMLprim value ml_z_fits_int(value v)

{

value x;

if (ml_to_int(v, &x)) return Val_false;

return Val_true;

}

static int ml_to_nativeint(value v, intnat* r)

{

Z_DECL(v);

Z_MARK_OP;

Z_CHECK(v);

if (Is_long(v)) { *r = Long_val(v); return 0; }

Z_MARK_SLOW;

Z_ARG(v);

if (size_v > 1) return 1;

if (!size_v) { *r = 0; return 0; }

else {

intnat x;

x = *ptr_v;

if (sign_v) {

if ((uintnat)x > Z_HI_INTNAT) return 1;

*r = -x;

}

else {

if ((uintnat)x >= Z_HI_INTNAT) return 1;

*r = x;

}

return 0;

}

}

CAMLprim value ml_z_to_nativeint(value v)

{

intnat x;

if (ml_to_nativeint(v, &x)) ml_z_raise_overflow();

return caml_copy_nativeint(x);

}

CAMLprim value ml_z_fits_nativeint(value v)

{

intnat x;

if (ml_to_nativeint(v, &x)) return Val_false;

return Val_true;

}

static int ml_to_nativeint_unsigned(value v, uintnat* r)

{

Z_DECL(v);

Z_MARK_OP;

Z_CHECK(v);

if (Is_long(v)) {

intnat x = Long_val(v);

if (x < 0) return 1;

*r = (uintnat)x;

return 0;

}

Z_MARK_SLOW;

Z_ARG(v);

if (!size_v) { *r = 0; return 0; }

else if (sign_v || size_v > 1) return 1;

else {

*r = *ptr_v;

return 0;

}

}

CAMLprim value ml_z_to_nativeint_unsigned(value v)

{

uintnat x;

if (ml_to_nativeint_unsigned(v, &x)) ml_z_raise_overflow();

return caml_copy_nativeint(x);

}

CAMLprim value ml_z_fits_nativeint_unsigned(value v)

{

uintnat x;

if (ml_to_nativeint_unsigned(v, &x)) return Val_false;

return Val_true;

}

static int ml_to_int32(value v, int32_t* r)

{

Z_DECL(v);

Z_MARK_OP;

Z_CHECK(v);

if (Is_long(v)) {

intnat x = Long_val(v);

#ifdef ARCH_SIXTYFOUR

if (x >= (intnat)Z_HI_INT32 || x < -(intnat)Z_HI_INT32)

return 1;

#endif

*r = x;

return 0;

}

else {

Z_ARG(v);

Z_MARK_SLOW;

if (size_v > 1) return 1;

if (!size_v) { *r = 0; return 0; }

else {

uintnat x = *ptr_v;

if (sign_v) {

if (x > Z_HI_INT32) return 1;

*r = -x;

}

else {

if (x >= Z_HI_INT32) return 1;

*r = x;

}

return 0;

}

}

}

CAMLprim value ml_z_to_int32(value v)

{

int32_t x;

if (ml_to_int32(v, &x)) ml_z_raise_overflow();

return caml_copy_int32(x);

}

CAMLprim value ml_z_fits_int32(value v)

{

int32_t x;

if (ml_to_int32(v, &x)) return Val_false;

return Val_true;

}

static int ml_to_int32_unsigned(value v, uint32_t* r)

{

Z_DECL(v);

Z_MARK_OP;

Z_CHECK(v);

if (Is_long(v)) {

intnat x = Long_val(v);

#ifdef ARCH_SIXTYFOUR

if (x < 0 || x >= Z_HI_UINT32)

#else

if (x < 0)

#endif

return 1;

*r = x;

return 0;

}

else {

Z_ARG(v);

Z_MARK_SLOW;

if (!size_v) { *r = 0; return 0; }

else if (sign_v || size_v > 1) return 1;

else {

uintnat x = *ptr_v;

#ifdef ARCH_SIXTYFOUR

if (x >= Z_HI_UINT32) return 1;

#endif

*r = x;

return 0;

}

}

}

CAMLprim value ml_z_to_int32_unsigned(value v)

{

uint32_t x;

if (ml_to_int32_unsigned(v, &x)) ml_z_raise_overflow();

return caml_copy_int32(x);

}

CAMLprim value ml_z_fits_int32_unsigned(value v)

{

uint32_t x;

if (ml_to_int32_unsigned(v, &x)) return Val_false;

return Val_true;

}

static int ml_to_int64(value v, int64_t* r)

{

int64_t x;

Z_DECL(v);

Z_MARK_OP;

Z_CHECK(v);

if (Is_long(v)) { *r = Long_val(v); return 0; }

Z_MARK_SLOW;

Z_ARG(v);

switch (size_v) {

case 0: x = 0; break;

case 1: x = ptr_v[0]; break;

#ifndef ARCH_SIXTYFOUR

case 2: x = ptr_v[0] | ((uint64_t)ptr_v[1] << 32); break;

#endif

default: return 1;

}

if (sign_v) {

if ((uint64_t)x > Z_HI_INT64) return 1;

*r = -x;

}

else {

if ((uint64_t)x >= Z_HI_INT64) return 1;

*r = x;

}

return 0;

}

CAMLprim value ml_z_to_int64(value v)

{

int64_t x;

if (ml_to_int64(v, &x)) ml_z_raise_overflow();

return caml_copy_int64(x);

}

CAMLprim value ml_z_fits_int64(value v)

{

int64_t x;

if (ml_to_int64(v, &x)) return Val_false;

return Val_true;

}

static int ml_to_int64_unsigned(value v, uint64_t* r)

{

Z_DECL(v);

Z_MARK_OP;

Z_CHECK(v);

if (Is_long(v)) {

intnat x = Long_val(v);

if (x < 0) return 1;

*r = x;

return 0;

}

Z_MARK_SLOW;

Z_ARG(v);

if (sign_v) return 1;

switch (size_v) {

case 0: *r = 0; return 0;

case 1: *r = ptr_v[0]; return 0;

#ifndef ARCH_SIXTYFOUR

case 2: *r = ptr_v[0] | ((uint64_t) ptr_v[1] << 32); return 0;

#endif

default: return 1;

}

}

CAMLprim value ml_z_to_int64_unsigned(value v)

{

uint64_t x;

if (ml_to_int64_unsigned(v, &x)) ml_z_raise_overflow();

return caml_copy_int64(x);

}

CAMLprim value ml_z_fits_int64_unsigned(value v)

{

uint64_t x;

if (ml_to_int64_unsigned(v, &x)) return Val_false;

return Val_true;

}

/* XXX: characters that do not belong to the format are ignored, this departs

from the classic printf behavior (it copies them in the output)

*/

CAMLprim value ml_z_format(value f, value v)

{

CAMLparam2(f,v);

Z_DECL(v);

const char tab[2][16] =

{ { '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F' },

{ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f' } };

char* buf, *dst;

mp_size_t i, size_dst, max_size;

value r;

const char* fmt = String_val(f);

int base = 10; /* base */