mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Support for x86_64-w64-mingw32.

Browse source 
On x86-64-MinGW the size of long is 4.  As long is used for
SCM_FIXNUM_BIT, that would mean incompatible .go files, and waste of
cell space.  So we would like to use long long, but the GMP interface
uses long.

To get around this, the x86-64-MinGW port now requires the use of
mini-GMP.  Mini-GMP has been changed to use intptr_t and uintptr_t.

Likewise, "integers.{h,c}" and "numbers.{h,c}" now use intptr_t instead
of scm_t_inum or long, and uintptr_t instead of unsigned long.

* configure.ac: When x86_64-w64-mingw32, require mini-GMP.
* libguile/mini-gmp.h: Use intptr_t instead of long, uintptr_t instead
of unsigned long throughout.
* libguile/mini-gmp.c: Likewise.
* libguile/scm.h (SCM_INTPTR_T_BIT): New define.
* libguile/numbers.h (SCM_FIXNUM_BIT): Use it.
* libguile/numbers.c (L1, UL1): New macros.  Use them thoughout instead
of 1L, 1UL.
(verify): Use SCM_INTPTR_T_BIT.
(verify): Use SCM_INTPTR_T_MAX and SCM_INTPTR_T_MIN.
(scm_from_inum): Remove macro.
Use intptr_t and uintptr_t instead of scm_t_inum or long, and unsigned
long.
* libguile/numbers.h (scm_from_intptr, scm_from_uintptr, scm_to_intptr,
scm_to_uintptr): New defines.
* libguile/integers.h: Use intptr_t and uintptr_t instead of scm_t_inum
and unsigned long.
* libguile/integers.c (L1) : New macro.  Use it thoughout instead of 1L.
Use intptr_t and uintptr_t instead of long and unsigned long.
(long_magnitude): Rename to...
(intptr_t_magnitude): ...this.  Use intptr_t, uintptr_t.
(negative_long): Rename to...
(negative_t_intptr): ...this.  Use uintptr_t, INTPTR_MIN.
(inum_magnitude): Use intptr_t.
(ulong_to_bignum): Rename to...
(uintptr_t_to_bignum): ...this.  Use uintptr_t.
(long_to_bignum): Rename to...
(intptr_t_to_bignum): ...this.  Use intptr_t.
(long_to_scm): Rename to...
(intptr_t_to_scm): ...this.  Use intptr_to_bignum.
(ulong_to_scm): Rename to...
(uintptr_t_to_scm): ...this.  Use uintptr_to_bignum.
(long_sign): Rename to..
(intptr_t_sign): ...this.  Use SCM_SIZEOF_INTPTR_T.
(bignum_cmp_long): Rename to...
(bignum_cmp_intptr_t): ...this.  Use uintptr_t.
* libguile/array-map.c (array_compare): Use uintptr_t instead of
unsigned long and intptr_t instead of long.
* libguile/arrays.c (make-shared-array): Use ssize_t instead of long.
* libguile/bytevectors.c (is_signed_int32, is_unsigned_int32)
[MINGW32 && __x86_64__]: Use ULL.
(twos_complement): Use uintptr_t instead of unsigned long.
* libguile/hash.c (JENKINS_LOOKUP3_HASHWORD2): Likewise.
(narrow_string_hash, wide_string_hash, scm_i_string_hash,
scm_i_locale_string_hash, scm_i_latin1_string_hash,
scm_i_utf8_string_hash, scm_i_struct_hash, scm_raw_ihashq,
scm_raw_ihash): Use and return uintptr_t instead of unsigned long.
(scm_hashv, scm_hash): Use SCM_UINTPTR_T_MAX.
* libguile/hash.h (scm_i_locale_string_hash, scm_i_latin1_string_hash,
scm_i_utf8_string_hash): update prototypes.
* libguile/scmsigs.c (sigaction): Use intptr_t instead of long.
* libguile/strings.c (scm_i_make_symbol, (scm_i_c_make_symbol): Use
uintptr_t instead of unsigned long.
* libguile/strings.h (scm_i_make_symbol, (scm_i_c_make_symbol): Update
declacations.
* libguile/srfi-60.c: Use scm_to_uintptr, scm_from_intptr and variants
throughout.
* libguile/symbols.c (symbol-hash): Use scm_from_uintptr.

Co-authored-by: Mike Gran <spk121@yahoo.com>
Co-authored-by: Andy Wingo <wingo@pobox.com>
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2021-03-16 12:10:36 +01:00 • committed by Michael Gran
parent d58c9411ae
commit 76950b4281
19 changed files with 623 additions and 597 deletions
Download patch file Download diff file Expand all files Collapse all files

6
configure.ac
View file

@ -693,6 +693,12 @@ AC_ARG_ENABLE(mini-gmp,
if test "x$enable_mini_gmp" = xyes || test "x$enable_mini_gmp" = xy; then
SCM_I_GSC_ENABLE_MINI_GMP=1
else
case $host in
x86_64-*-mingw*)
AC_MSG_ERROR([mini-gmp is required; use --enable-mini-gmp])
;;
*) ;;
esac
AC_LIB_HAVE_LINKFLAGS([gmp],[],[#include <gmp.h>], [mpz_import (0,0,0,0,0,0,0);])
if test "x$HAVE_LIBGMP" != "xyes"; then
AC_MSG_ERROR([GNU MP 4.1 or greater not found; either install it, or pass '--enable-mini-gmp' to use included less-optimal arbitrary-precision integer support.])

4
libguile/array-map.c
View file

@ -576,14 +576,14 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
static int
array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
size_t dim, unsigned long posx, unsigned long posy)
size_t dim, uintptr_t posx, uintptr_t posy)
{
if (dim == scm_array_handle_rank (hx))
return scm_is_true (scm_equal_p (scm_array_handle_ref (hx, posx),
scm_array_handle_ref (hy, posy)));
else
{
long incx, incy;
intptr_t incx, incy;
size_t i;
if (hx->dims[dim].lbnd != hy->dims[dim].lbnd

14
libguile/arrays.c
View file

@ -240,11 +240,11 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
for (k = 0; k < ndim; k++)
{
long ind;
intptr_t ind;
if (!scm_is_pair (args))
SCM_WRONG_NUM_ARGS ();
ind = scm_to_long (SCM_CAR (args));
ind = scm_to_intptr_t (SCM_CAR (args));
args = SCM_CDR (args);
if (ind < s[k].lbnd || ind > s[k].ubnd)
@ -377,14 +377,14 @@ SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
static SCM
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
array_to_list (scm_t_array_handle *h, size_t dim, uintptr_t pos)
{
if (dim == scm_array_handle_rank (h))
return scm_array_handle_ref (h, pos);
else
{
SCM res = SCM_EOL;
long inc;
intptr_t inc;
size_t i;
i = h->dims[dim].ubnd - h->dims[dim].lbnd + 1;
@ -620,7 +620,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
SCM imap;
size_t k;
ssize_t i;
long old_base, old_min, new_min, old_max, new_max;
ssize_t old_base, old_min, new_min, old_max, new_max;
scm_t_array_dim *s;
SCM_VALIDATE_REST_ARGUMENT (dims);
@ -1023,8 +1023,8 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
return SCM_BOOL_F;
if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
&& (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
len % SCM_LONG_BIT))
SCM_I_ARRAY_BASE (ra) % SCM_INTPTR_T_BIT ||
len % SCM_INTPTR_T_BIT))
return SCM_BOOL_F;
}

15
libguile/bytevectors.c
View file

@ -75,8 +75,13 @@
#define is_unsigned_int8(_x) ((_x) <= 255UL)
#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
#define is_unsigned_int16(_x) ((_x) <= 65535UL)
#if !(__MINGW32__ && __x86_64__)
#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
#define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
#else /* (__MINGW32__ && __x86_64__) */
#define is_signed_int32(_x) (((_x) >= -2147483648LL) && ((_x) <= 2147483647LL))
#define is_unsigned_int32(_x) ((_x) <= 4294967295ULL)
#endif /* (__MINGW32__ && __x86_64__) */
#define SIGNEDNESS_signed 1
#define SIGNEDNESS_unsigned 0
@ -825,14 +830,14 @@ SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
static inline void
twos_complement (mpz_t value, size_t size)
{
unsigned long bit_count;
uintptr_t bit_count;
/* We expect BIT_COUNT to fit in a unsigned long thanks to the range
/* We expect BIT_COUNT to fit in a uintptr_t thanks to the range
checking on SIZE performed earlier. */
bit_count = (unsigned long) size << 3UL;
bit_count = (uintptr_t) size << 3ULL;
if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
mpz_ui_sub (value, 1UL << bit_count, value);
if (SCM_LIKELY (bit_count < sizeof (uintptr_t)))
mpz_ui_sub (value, 1ULL << bit_count, value);
else
{
mpz_t max;

2
libguile/deprecated.c
View file

@ -823,7 +823,7 @@ scm_i_normbig (SCM b)
/* presume b is a bignum */
if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
{
scm_t_inum val = mpz_get_si (SCM_I_BIG_MPZ (b));
intptr_t val = mpz_get_si (SCM_I_BIG_MPZ (b));
if (SCM_FIXABLE (val))
b = SCM_I_MAKINUM (val);
}

46
libguile/hash.c
View file

@ -112,31 +112,31 @@ extern double floor();
the hash on a 64-bit system are equal to the hash on a 32-bit \
system. The low 32 bits just add more entropy. */ \
if (sizeof (ret) == 8) \
ret = (((unsigned long) c) << 32) | b; \
ret = (((uintptr_t) c) << 32) | b; \
else \
ret = c; \
} while (0)
static unsigned long
static uintptr_t
narrow_string_hash (const uint8_t *str, size_t len)
{
unsigned long ret;
uintptr_t ret;
JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
ret >>= 2; /* Ensure that it fits in a fixnum. */
return ret;
}
static unsigned long
static uintptr_t
wide_string_hash (const scm_t_wchar *str, size_t len)
{
unsigned long ret;
uintptr_t ret;
JENKINS_LOOKUP3_HASHWORD2 (str, len, ret);
ret >>= 2; /* Ensure that it fits in a fixnum. */
return ret;
}
unsigned long
uintptr_t
scm_i_string_hash (SCM str)
{
size_t len = scm_i_string_length (str);
@ -148,13 +148,13 @@ scm_i_string_hash (SCM str)
return wide_string_hash (scm_i_string_wide_chars (str), len);
}
unsigned long
uintptr_t
scm_i_locale_string_hash (const char *str, size_t len)
{
return scm_i_string_hash (scm_from_locale_stringn (str, len));
}
unsigned long
uintptr_t
scm_i_latin1_string_hash (const char *str, size_t len)
{
if (len == (size_t) -1)
@ -164,11 +164,11 @@ scm_i_latin1_string_hash (const char *str, size_t len)
}
/* A tricky optimization, but probably worth it. */
unsigned long
uintptr_t
scm_i_utf8_string_hash (const char *str, size_t len)
{
const uint8_t *end, *ustr = (const uint8_t *) str;
unsigned long ret;
uintptr_t ret;
/* The length of the string in characters. This name corresponds to
Jenkins' original name. */
@ -219,8 +219,8 @@ scm_i_utf8_string_hash (const char *str, size_t len)
final (a, b, c);
if (sizeof (unsigned long) == 8)
ret = (((unsigned long) c) << 32) | b;
if (sizeof (uintptr_t) == 8)
ret = (((uintptr_t) c) << 32) | b;
else
ret = c;
@ -228,16 +228,16 @@ scm_i_utf8_string_hash (const char *str, size_t len)
return ret;
}
static unsigned long scm_raw_ihashq (scm_t_bits key);
static unsigned long scm_raw_ihash (SCM obj, size_t depth);
static uintptr_t scm_raw_ihashq (scm_t_bits key);
static uintptr_t scm_raw_ihash (SCM obj, size_t depth);
/* Return the hash of struct OBJ. Traverse OBJ's fields to compute the
result, unless DEPTH is zero. Assumes that OBJ is a struct. */
static unsigned long
static uintptr_t
scm_i_struct_hash (SCM obj, size_t depth)
{
size_t struct_size, field_num;
unsigned long hash;
uintptr_t hash;
struct_size = SCM_STRUCT_SIZE (obj);
@ -257,7 +257,7 @@ scm_i_struct_hash (SCM obj, size_t depth)
/* Thomas Wang's integer hasher, from
http://www.cris.com/~Ttwang/tech/inthash.htm. */
static unsigned long
static uintptr_t
scm_raw_ihashq (scm_t_bits key)
{
if (sizeof (key) < 8)
@ -283,7 +283,7 @@ scm_raw_ihashq (scm_t_bits key)
}
/* `depth' is used to limit recursion. */
static unsigned long
static uintptr_t
scm_raw_ihash (SCM obj, size_t depth)
{
if (SCM_IMP (obj))
@ -318,7 +318,7 @@ scm_raw_ihash (SCM obj, size_t depth)
{
size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj);
size_t i = depth / 2;
unsigned long h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
uintptr_t h = scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
if (len)
while (i--)
h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i);
@ -326,7 +326,7 @@ scm_raw_ihash (SCM obj, size_t depth)
}
case scm_tc7_syntax:
{
unsigned long h;
uintptr_t h;
h = scm_raw_ihash (scm_syntax_expression (obj), depth);
h ^= scm_raw_ihash (scm_syntax_wrap (obj), depth);
h ^= scm_raw_ihash (scm_syntax_module (obj), depth);
@ -386,7 +386,7 @@ SCM_DEFINE (scm_hashq, "hashq", 2, 0, 0,
"different values, since @code{foo} will be garbage collected.")
#define FUNC_NAME s_scm_hashq
{
unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
uintptr_t sz = scm_to_unsigned_integer (size, 1, UINTPTR_MAX);
return scm_from_ulong (scm_ihashq (key, sz));
}
#undef FUNC_NAME
@ -419,7 +419,7 @@ SCM_DEFINE (scm_hashv, "hashv", 2, 0, 0,
"different values, since @code{foo} will be garbage collected.")
#define FUNC_NAME s_scm_hashv
{
unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
uintptr_t sz = scm_to_unsigned_integer (size, 1, UINTPTR_MAX);
return scm_from_ulong (scm_ihashv (key, sz));
}
#undef FUNC_NAME
@ -442,7 +442,7 @@ SCM_DEFINE (scm_hash, "hash", 2, 0, 0,
"integer in the range 0 to @var{size} - 1.")
#define FUNC_NAME s_scm_hash
{
unsigned long sz = scm_to_unsigned_integer (size, 1, ULONG_MAX);
uintptr_t sz = scm_to_unsigned_integer (size, 1, UINTPTR_MAX);
return scm_from_ulong (scm_ihash (key, sz));
}
#undef FUNC_NAME

12
libguile/hash.h
View file

@ -23,17 +23,15 @@
#include "libguile/scm.h"
#include "libguile/numbers.h"
SCM_INTERNAL unsigned long scm_i_locale_string_hash (const char *str,
size_t len);
SCM_INTERNAL unsigned long scm_i_latin1_string_hash (const char *str,
size_t len);
SCM_INTERNAL unsigned long scm_i_utf8_string_hash (const char *str,
size_t len);
SCM_INTERNAL uintptr_t scm_i_locale_string_hash (const char *str, size_t len);
SCM_INTERNAL uintptr_t scm_i_latin1_string_hash (const char *str, size_t len);
SCM_INTERNAL uintptr_t scm_i_utf8_string_hash (const char *str, size_t len);
SCM_INTERNAL unsigned long scm_i_string_hash (SCM str);
SCM_INTERNAL uintptr_t scm_i_string_hash (SCM str);
SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n);
SCM_API SCM scm_hashq (SCM obj, SCM n);
SCM_API unsigned long scm_ihashv (SCM obj, unsigned long n);

478
libguile/integers.c
View file

File diff suppressed because it is too large Load diff

136
libguile/integers.h
View file

@ -36,41 +36,41 @@ SCM_INTERNAL SCM scm_integer_from_mpz (const mpz_t n);
SCM_INTERNAL void scm_integer_set_mpz_z (struct scm_bignum *z, mpz_t n);
SCM_INTERNAL void scm_integer_init_set_mpz_z (struct scm_bignum *z, mpz_t n);
SCM_INTERNAL int scm_is_integer_odd_i (scm_t_inum i);
SCM_INTERNAL int scm_is_integer_odd_i (intptr_t i);
SCM_INTERNAL int scm_is_integer_odd_z (struct scm_bignum *z);
SCM_INTERNAL SCM scm_integer_abs_i (scm_t_inum i);
SCM_INTERNAL SCM scm_integer_abs_i (intptr_t i);
SCM_INTERNAL SCM scm_integer_abs_z (struct scm_bignum *z);
#define DECLARE_QUOTIENT_OPERATORS(stem) \
SCM_INTERNAL SCM scm_integer_##stem##_quotient_ii (scm_t_inum x, \
scm_t_inum y); \
SCM_INTERNAL SCM scm_integer_##stem##_quotient_iz (scm_t_inum x, \
SCM_INTERNAL SCM scm_integer_##stem##_quotient_ii (intptr_t x, \
intptr_t y); \
SCM_INTERNAL SCM scm_integer_##stem##_quotient_iz (intptr_t x, \
struct scm_bignum *y); \
SCM_INTERNAL SCM scm_integer_##stem##_quotient_zi (struct scm_bignum *x, \
scm_t_inum y); \
intptr_t y); \
SCM_INTERNAL SCM scm_integer_##stem##_quotient_zz (struct scm_bignum *x, \
struct scm_bignum *y);
#define DECLARE_REMAINDER_OPERATORS(stem) \
SCM_INTERNAL SCM scm_integer_##stem##_remainder_ii (scm_t_inum x, \
scm_t_inum y); \
SCM_INTERNAL SCM scm_integer_##stem##_remainder_iz (scm_t_inum x, \
SCM_INTERNAL SCM scm_integer_##stem##_remainder_ii (intptr_t x, \
intptr_t y); \
SCM_INTERNAL SCM scm_integer_##stem##_remainder_iz (intptr_t x, \
struct scm_bignum *y); \
SCM_INTERNAL SCM scm_integer_##stem##_remainder_zi (struct scm_bignum *x, \
scm_t_inum y); \
intptr_t y); \
SCM_INTERNAL SCM scm_integer_##stem##_remainder_zz (struct scm_bignum *x, \
struct scm_bignum *y);
#define DECLARE_DIVIDE_OPERATORS(stem) \
SCM_INTERNAL void scm_integer_##stem##_divide_ii (scm_t_inum x, \
scm_t_inum y, \
SCM_INTERNAL void scm_integer_##stem##_divide_ii (intptr_t x, \
intptr_t y, \
SCM *qp, SCM *rp); \
SCM_INTERNAL void scm_integer_##stem##_divide_iz (scm_t_inum x, \
SCM_INTERNAL void scm_integer_##stem##_divide_iz (intptr_t x, \
struct scm_bignum *y, \
SCM *qp, SCM *rp); \
SCM_INTERNAL void scm_integer_##stem##_divide_zi (struct scm_bignum *x, \
scm_t_inum y, \
intptr_t y, \
SCM *qp, SCM *rp); \
SCM_INTERNAL void scm_integer_##stem##_divide_zz (struct scm_bignum *x, \
struct scm_bignum *y, \
@ -87,75 +87,75 @@ DECLARE_DIVISION_OPERATORS(truncate);
DECLARE_DIVISION_OPERATORS(centered);
DECLARE_DIVISION_OPERATORS(round);
SCM_INTERNAL SCM scm_integer_gcd_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_gcd_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_gcd_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_gcd_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_gcd_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_lcm_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_lcm_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_lcm_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_lcm_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_lcm_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_logand_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_logand_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_logand_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_logand_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_logand_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_logior_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_logior_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_logior_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_logior_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_logior_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_logxor_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_logxor_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_logxor_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_logxor_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_logxor_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL int scm_integer_logtest_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL int scm_integer_logtest_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL int scm_integer_logtest_ii (intptr_t x, intptr_t y);
SCM_INTERNAL int scm_integer_logtest_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL int scm_integer_logtest_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL int scm_integer_logbit_ui (unsigned long bit, scm_t_inum n);
SCM_INTERNAL int scm_integer_logbit_uz (unsigned long bit,
SCM_INTERNAL int scm_integer_logbit_ui (uintptr_t bit, intptr_t n);
SCM_INTERNAL int scm_integer_logbit_uz (uintptr_t bit,
struct scm_bignum *n);
SCM_INTERNAL SCM scm_integer_lognot_i (scm_t_inum n);
SCM_INTERNAL SCM scm_integer_lognot_i (intptr_t n);
SCM_INTERNAL SCM scm_integer_lognot_z (struct scm_bignum *n);
SCM_INTERNAL SCM scm_integer_expt_ii (scm_t_inum n, scm_t_inum k);
SCM_INTERNAL SCM scm_integer_expt_zi (struct scm_bignum *n, scm_t_inum k);
SCM_INTERNAL SCM scm_integer_expt_ii (intptr_t n, intptr_t k);
SCM_INTERNAL SCM scm_integer_expt_zi (struct scm_bignum *n, intptr_t k);
SCM_INTERNAL SCM scm_integer_modulo_expt_nnn (SCM n, SCM k, SCM m);
SCM_INTERNAL SCM scm_integer_lsh_iu (scm_t_inum n, unsigned long count);
SCM_INTERNAL SCM scm_integer_lsh_iu (intptr_t n, uintptr_t count);
SCM_INTERNAL SCM scm_integer_lsh_zu (struct scm_bignum *n,
unsigned long count);
SCM_INTERNAL SCM scm_integer_floor_rsh_iu (scm_t_inum n, unsigned long count);
uintptr_t count);
SCM_INTERNAL SCM scm_integer_floor_rsh_iu (intptr_t n, uintptr_t count);
SCM_INTERNAL SCM scm_integer_floor_rsh_zu (struct scm_bignum *n,
unsigned long count);
SCM_INTERNAL SCM scm_integer_round_rsh_iu (scm_t_inum n, unsigned long count);
uintptr_t count);
SCM_INTERNAL SCM scm_integer_round_rsh_iu (intptr_t n, uintptr_t count);
SCM_INTERNAL SCM scm_integer_round_rsh_zu (struct scm_bignum *n,
unsigned long count);
uintptr_t count);
SCM_INTERNAL SCM scm_integer_bit_extract_i (scm_t_inum n, unsigned long start,
unsigned long bits);
SCM_INTERNAL SCM scm_integer_bit_extract_i (intptr_t n, uintptr_t start,
uintptr_t bits);
SCM_INTERNAL SCM scm_integer_bit_extract_z (struct scm_bignum *n,
unsigned long start,
unsigned long bits);
uintptr_t start,
uintptr_t bits);
SCM_INTERNAL SCM scm_integer_logcount_i (scm_t_inum n);
SCM_INTERNAL SCM scm_integer_logcount_i (intptr_t n);
SCM_INTERNAL SCM scm_integer_logcount_z (struct scm_bignum *n);
SCM_INTERNAL SCM scm_integer_length_i (scm_t_inum n);
SCM_INTERNAL SCM scm_integer_length_i (intptr_t n);
SCM_INTERNAL SCM scm_integer_length_z (struct scm_bignum *n);
SCM_INTERNAL SCM scm_integer_to_string_i (scm_t_inum n, int base);
SCM_INTERNAL SCM scm_integer_to_string_i (intptr_t n, int base);
SCM_INTERNAL SCM scm_integer_to_string_z (struct scm_bignum *n, int base);
SCM_INTERNAL int scm_is_integer_equal_ir (scm_t_inum x, double y);
SCM_INTERNAL int scm_is_integer_equal_ic (scm_t_inum x,
SCM_INTERNAL int scm_is_integer_equal_ir (intptr_t x, double y);
SCM_INTERNAL int scm_is_integer_equal_ic (intptr_t x,
double real, double imag);
SCM_INTERNAL int scm_is_integer_equal_zz (struct scm_bignum *x,
struct scm_bignum *y);
@ -163,8 +163,8 @@ SCM_INTERNAL int scm_is_integer_equal_zr (struct scm_bignum *x, double y);
SCM_INTERNAL int scm_is_integer_equal_zc (struct scm_bignum *x,
double real, double imag);
SCM_INTERNAL int scm_is_integer_less_than_ir (scm_t_inum x, double y);
SCM_INTERNAL int scm_is_integer_less_than_ri (double x, scm_t_inum y);
SCM_INTERNAL int scm_is_integer_less_than_ir (intptr_t x, double y);
SCM_INTERNAL int scm_is_integer_less_than_ri (double x, intptr_t y);
SCM_INTERNAL int scm_is_integer_less_than_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL int scm_is_integer_less_than_zr (struct scm_bignum *x, double y);
@ -173,41 +173,41 @@ SCM_INTERNAL int scm_is_integer_less_than_rz (double y, struct scm_bignum *x);
SCM_INTERNAL int scm_is_integer_positive_z (struct scm_bignum *x);
SCM_INTERNAL int scm_is_integer_negative_z (struct scm_bignum *x);
SCM_INTERNAL double scm_integer_frexp_z (struct scm_bignum *x, long *exp);
SCM_INTERNAL double scm_integer_frexp_z (struct scm_bignum *x, intptr_t *exp);
SCM_INTERNAL double scm_integer_to_double_z (struct scm_bignum *x);
SCM_INTERNAL SCM scm_integer_from_double (double val);
SCM_INTERNAL SCM scm_integer_add_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_add_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_add_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_add_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_add_zz (struct scm_bignum *x, struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_negate_i (scm_t_inum x);
SCM_INTERNAL SCM scm_integer_negate_i (intptr_t x);
SCM_INTERNAL SCM scm_integer_negate_z (struct scm_bignum *x);
SCM_INTERNAL SCM scm_integer_sub_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_sub_iz (scm_t_inum x, struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_sub_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_sub_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_sub_iz (intptr_t x, struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_sub_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_sub_zz (struct scm_bignum *x, struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_mul_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_mul_zi (struct scm_bignum *x, scm_t_inum y);
SCM_INTERNAL SCM scm_integer_mul_ii (intptr_t x, intptr_t y);
SCM_INTERNAL SCM scm_integer_mul_zi (struct scm_bignum *x, intptr_t y);
SCM_INTERNAL SCM scm_integer_mul_zz (struct scm_bignum *x, struct scm_bignum *y);
SCM_INTERNAL int scm_is_integer_divisible_ii (scm_t_inum x, scm_t_inum y);
SCM_INTERNAL int scm_is_integer_divisible_ii (intptr_t x, intptr_t y);
SCM_INTERNAL int scm_is_integer_divisible_zi (struct scm_bignum *x,
scm_t_inum y);
intptr_t y);
SCM_INTERNAL int scm_is_integer_divisible_zz (struct scm_bignum *x,
struct scm_bignum *y);
SCM_INTERNAL SCM scm_integer_exact_quotient_ii (scm_t_inum n, scm_t_inum d);
SCM_INTERNAL SCM scm_integer_exact_quotient_iz (scm_t_inum n,
SCM_INTERNAL SCM scm_integer_exact_quotient_ii (intptr_t n, intptr_t d);
SCM_INTERNAL SCM scm_integer_exact_quotient_iz (intptr_t n,
struct scm_bignum *d);
SCM_INTERNAL SCM scm_integer_exact_quotient_zi (struct scm_bignum *n,
scm_t_inum d);
intptr_t d);
SCM_INTERNAL SCM scm_integer_exact_quotient_zz (struct scm_bignum *n,
struct scm_bignum *d);
#if SCM_SIZEOF_LONG == 4
#if SCM_SIZEOF_INTPTR_T == 4
SCM_INTERNAL SCM scm_integer_from_int32 (int32_t n);
SCM_INTERNAL SCM scm_integer_from_uint32 (uint32_t n);
SCM_INTERNAL int scm_integer_to_int32_z (struct scm_bignum *z, int32_t *val);
@ -219,18 +219,18 @@ SCM_INTERNAL int scm_integer_to_uint64_z (struct scm_bignum *z, uint64_t *val);
SCM_INTERNAL SCM scm_integer_from_int64 (int64_t n);
SCM_INTERNAL SCM scm_integer_from_uint64 (uint64_t n);
SCM_INTERNAL void scm_integer_exact_sqrt_i (scm_t_inum k, SCM *s, SCM *r);
SCM_INTERNAL void scm_integer_exact_sqrt_i (intptr_t k, SCM *s, SCM *r);
SCM_INTERNAL void scm_integer_exact_sqrt_z (struct scm_bignum *k,
SCM *s, SCM *r);
SCM_INTERNAL int scm_is_integer_perfect_square_i (scm_t_inum k);
SCM_INTERNAL int scm_is_integer_perfect_square_i (intptr_t k);
SCM_INTERNAL int scm_is_integer_perfect_square_z (struct scm_bignum *k);
SCM_INTERNAL SCM scm_integer_floor_sqrt_i (scm_t_inum k);
SCM_INTERNAL SCM scm_integer_floor_sqrt_i (intptr_t k);
SCM_INTERNAL SCM scm_integer_floor_sqrt_z (struct scm_bignum *k);
SCM_INTERNAL double scm_integer_inexact_sqrt_i (scm_t_inum k);
SCM_INTERNAL double scm_integer_inexact_sqrt_i (intptr_t k);
SCM_INTERNAL double scm_integer_inexact_sqrt_z (struct scm_bignum *k);
SCM_INTERNAL SCM scm_integer_scan1_i (scm_t_inum n);
SCM_INTERNAL SCM scm_integer_scan1_i (intptr_t n);
SCM_INTERNAL SCM scm_integer_scan1_z (struct scm_bignum *n);

173
libguile/mini-gmp.c
View file

@ -2,7 +2,7 @@
Contributed to the GNU project by Niels Möller
Copyright 1991-1997, 1999-2019 Free Software Foundation, Inc.
Copyright 1991-1997, 1999-2019,2021 Free Software Foundation, Inc.
This file is part of the GNU MP Library.
@ -48,6 +48,7 @@ see https://www.gnu.org/licenses/. */
#include <assert.h>
#include <ctype.h>
#include <limits.h>
#include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
@ -68,8 +69,8 @@ see https://www.gnu.org/licenses/. */
#define GMP_HLIMB_BIT ((mp_limb_t) 1 << (GMP_LIMB_BITS / 2))
#define GMP_LLIMB_MASK (GMP_HLIMB_BIT - 1)
#define GMP_ULONG_BITS (sizeof(unsigned long) * CHAR_BIT)
#define GMP_ULONG_HIGHBIT ((unsigned long) 1 << (GMP_ULONG_BITS - 1))
#define GMP_ULONG_BITS (sizeof(uintptr_t) * CHAR_BIT)
#define GMP_ULONG_HIGHBIT ((uintptr_t) 1 << (GMP_ULONG_BITS - 1))
#define GMP_ABS(x) ((x) >= 0 ? (x) : -(x))
#define GMP_NEG_CAST(T,x) (-((T)((x) + 1) - 1))
@ -144,7 +145,7 @@ see https://www.gnu.org/licenses/. */
} \
else if (GMP_ULONG_BITS >= 2 * GMP_LIMB_BITS) \
{ \
unsigned long int __ww = (unsigned long int) (u) * (v); \
uintptr_t __ww = (uintptr_t) (u) * (v); \
w0 = (mp_limb_t) __ww; \
w1 = (mp_limb_t) (__ww >> LOCAL_GMP_LIMB_BITS); \
} \
@ -1466,25 +1467,25 @@ mpz_realloc (mpz_t r, mp_size_t size)
/* MPZ assignment and basic conversions. */
void
mpz_set_si (mpz_t r, signed long int x)
mpz_set_si (mpz_t r, intptr_t x)
{
if (x >= 0)
mpz_set_ui (r, x);
else /* (x < 0) */
if (GMP_LIMB_BITS < GMP_ULONG_BITS)
{
mpz_set_ui (r, GMP_NEG_CAST (unsigned long int, x));
mpz_set_ui (r, GMP_NEG_CAST (uintptr_t, x));
mpz_neg (r, r);
}
else
{
r->_mp_size = -1;
MPZ_REALLOC (r, 1)[0] = GMP_NEG_CAST (unsigned long int, x);
MPZ_REALLOC (r, 1)[0] = GMP_NEG_CAST (uintptr_t, x);
}
}
void
mpz_set_ui (mpz_t r, unsigned long int x)
mpz_set_ui (mpz_t r, uintptr_t x)
{
if (x > 0)
{
@ -1522,14 +1523,14 @@ mpz_set (mpz_t r, const mpz_t x)
}
void
mpz_init_set_si (mpz_t r, signed long int x)
mpz_init_set_si (mpz_t r, intptr_t x)
{
mpz_init (r);
mpz_set_si (r, x);
}
void
mpz_init_set_ui (mpz_t r, unsigned long int x)
mpz_init_set_ui (mpz_t r, uintptr_t x)
{
mpz_init (r);
mpz_set_ui (r, x);
@ -1545,8 +1546,8 @@ mpz_init_set (mpz_t r, const mpz_t x)
int
mpz_fits_slong_p (const mpz_t u)
{
return (LONG_MAX + LONG_MIN == 0 || mpz_cmp_ui (u, LONG_MAX) <= 0) &&
mpz_cmpabs_ui (u, GMP_NEG_CAST (unsigned long int, LONG_MIN)) <= 0;
return (INTPTR_MAX + INTPTR_MIN == 0 || mpz_cmp_ui (u, INTPTR_MAX) <= 0) &&
mpz_cmpabs_ui (u, GMP_NEG_CAST (uintptr_t, INTPTR_MIN)) <= 0;
}
static int
@ -1569,26 +1570,26 @@ mpz_fits_ulong_p (const mpz_t u)
return us >= 0 && mpn_absfits_ulong_p (u->_mp_d, us);
}
long int
intptr_t
mpz_get_si (const mpz_t u)
{
unsigned long r = mpz_get_ui (u);
unsigned long c = -LONG_MAX - LONG_MIN;
uintptr_t r = mpz_get_ui (u);
uintptr_t c = -INTPTR_MAX - INTPTR_MIN;
if (u->_mp_size < 0)
/* This expression is necessary to properly handle -LONG_MIN */
return -(long) c - (long) ((r - c) & LONG_MAX);
/* This expression is necessary to properly handle -INTPTR_MIN */
return -(intptr_t) c - (intptr_t) ((r - c) & INTPTR_MAX);
else
return (long) (r & LONG_MAX);
return (intptr_t) (r & INTPTR_MAX);
}
unsigned long int
uintptr_t
mpz_get_ui (const mpz_t u)
{
if (GMP_LIMB_BITS < GMP_ULONG_BITS)
{
int LOCAL_GMP_LIMB_BITS = GMP_LIMB_BITS;
unsigned long r = 0;
uintptr_t r = 0;
mp_size_t n = GMP_ABS (u->_mp_size);
n = GMP_MIN (n, 1 + (mp_size_t) (GMP_ULONG_BITS - 1) / GMP_LIMB_BITS);
while (--n >= 0)
@ -1831,7 +1832,7 @@ mpz_sgn (const mpz_t u)
}
int
mpz_cmp_si (const mpz_t u, long v)
mpz_cmp_si (const mpz_t u, intptr_t v)
{
mp_size_t usize = u->_mp_size;
@ -1840,11 +1841,11 @@ mpz_cmp_si (const mpz_t u, long v)
else if (usize >= 0)
return 1;
else
return - mpz_cmpabs_ui (u, GMP_NEG_CAST (unsigned long int, v));
return - mpz_cmpabs_ui (u, GMP_NEG_CAST (uintptr_t, v));
}
int
mpz_cmp_ui (const mpz_t u, unsigned long v)
mpz_cmp_ui (const mpz_t u, uintptr_t v)
{
mp_size_t usize = u->_mp_size;
@ -1869,7 +1870,7 @@ mpz_cmp (const mpz_t a, const mpz_t b)
}
int
mpz_cmpabs_ui (const mpz_t u, unsigned long v)
mpz_cmpabs_ui (const mpz_t u, uintptr_t v)
{
mp_size_t un = GMP_ABS (u->_mp_size);
@ -1877,7 +1878,7 @@ mpz_cmpabs_ui (const mpz_t u, unsigned long v)
return 1;
else
{
unsigned long uu = mpz_get_ui (u);
uintptr_t uu = mpz_get_ui (u);
return GMP_CMP(uu, v);
}
}
@ -1916,7 +1917,7 @@ mpz_swap (mpz_t u, mpz_t v)
void
mpz_add_ui (mpz_t r, const mpz_t a, unsigned long b)
mpz_add_ui (mpz_t r, const mpz_t a, uintptr_t b)
{
mpz_t bb;
mpz_init_set_ui (bb, b);
@ -1925,14 +1926,14 @@ mpz_add_ui (mpz_t r, const mpz_t a, unsigned long b)
}
void
mpz_sub_ui (mpz_t r, const mpz_t a, unsigned long b)
mpz_sub_ui (mpz_t r, const mpz_t a, uintptr_t b)
{
mpz_ui_sub (r, b, a);
mpz_neg (r, r);
}
void
mpz_ui_sub (mpz_t r, unsigned long a, const mpz_t b)
mpz_ui_sub (mpz_t r, uintptr_t a, const mpz_t b)
{
mpz_neg (r, b);
mpz_add_ui (r, r, a);
@ -2014,11 +2015,11 @@ mpz_sub (mpz_t r, const mpz_t a, const mpz_t b)
/* MPZ multiplication */
void
mpz_mul_si (mpz_t r, const mpz_t u, long int v)
mpz_mul_si (mpz_t r, const mpz_t u, intptr_t v)
{
if (v < 0)
{
mpz_mul_ui (r, u, GMP_NEG_CAST (unsigned long int, v));
mpz_mul_ui (r, u, GMP_NEG_CAST (uintptr_t, v));
mpz_neg (r, r);
}
else
@ -2026,7 +2027,7 @@ mpz_mul_si (mpz_t r, const mpz_t u, long int v)
}
void
mpz_mul_ui (mpz_t r, const mpz_t u, unsigned long int v)
mpz_mul_ui (mpz_t r, const mpz_t u, uintptr_t v)
{
mpz_t vv;
mpz_init_set_ui (vv, v);
@ -2108,7 +2109,7 @@ mpz_mul_2exp (mpz_t r, const mpz_t u, mp_bitcnt_t bits)
}
void
mpz_addmul_ui (mpz_t r, const mpz_t u, unsigned long int v)
mpz_addmul_ui (mpz_t r, const mpz_t u, uintptr_t v)
{
mpz_t t;
mpz_init_set_ui (t, v);
@ -2118,7 +2119,7 @@ mpz_addmul_ui (mpz_t r, const mpz_t u, unsigned long int v)
}
void
mpz_submul_ui (mpz_t r, const mpz_t u, unsigned long int v)
mpz_submul_ui (mpz_t r, const mpz_t u, uintptr_t v)
{
mpz_t t;
mpz_init_set_ui (t, v);
@ -2514,11 +2515,11 @@ mpz_congruent_p (const mpz_t a, const mpz_t b, const mpz_t m)
return res;
}
static unsigned long
static uintptr_t
mpz_div_qr_ui (mpz_t q, mpz_t r,
const mpz_t n, unsigned long d, enum mpz_div_round_mode mode)
const mpz_t n, uintptr_t d, enum mpz_div_round_mode mode)
{
unsigned long ret;
uintptr_t ret;
mpz_t rr, dd;
mpz_init (rr);
@ -2534,90 +2535,90 @@ mpz_div_qr_ui (mpz_t q, mpz_t r,
return ret;
}
unsigned long
mpz_cdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d)
uintptr_t
mpz_cdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (q, r, n, d, GMP_DIV_CEIL);
}
unsigned long
mpz_fdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d)
uintptr_t
mpz_fdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (q, r, n, d, GMP_DIV_FLOOR);
}
unsigned long
mpz_tdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, unsigned long d)
uintptr_t
mpz_tdiv_qr_ui (mpz_t q, mpz_t r, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (q, r, n, d, GMP_DIV_TRUNC);
}
unsigned long
mpz_cdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d)
uintptr_t
mpz_cdiv_q_ui (mpz_t q, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_CEIL);
}
unsigned long
mpz_fdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d)
uintptr_t
mpz_fdiv_q_ui (mpz_t q, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_FLOOR);
}
unsigned long
mpz_tdiv_q_ui (mpz_t q, const mpz_t n, unsigned long d)
uintptr_t
mpz_tdiv_q_ui (mpz_t q, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC);
}
unsigned long
mpz_cdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d)
uintptr_t
mpz_cdiv_r_ui (mpz_t r, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_CEIL);
}
unsigned long
mpz_fdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d)
uintptr_t
mpz_fdiv_r_ui (mpz_t r, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR);
}
unsigned long
mpz_tdiv_r_ui (mpz_t r, const mpz_t n, unsigned long d)
uintptr_t
mpz_tdiv_r_ui (mpz_t r, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_TRUNC);
}
unsigned long
mpz_cdiv_ui (const mpz_t n, unsigned long d)
uintptr_t
mpz_cdiv_ui (const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_CEIL);
}
unsigned long
mpz_fdiv_ui (const mpz_t n, unsigned long d)
uintptr_t
mpz_fdiv_ui (const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_FLOOR);
}
unsigned long
mpz_tdiv_ui (const mpz_t n, unsigned long d)
uintptr_t
mpz_tdiv_ui (const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC);
}
unsigned long
mpz_mod_ui (mpz_t r, const mpz_t n, unsigned long d)
uintptr_t
mpz_mod_ui (mpz_t r, const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, r, n, d, GMP_DIV_FLOOR);
}
void
mpz_divexact_ui (mpz_t q, const mpz_t n, unsigned long d)
mpz_divexact_ui (mpz_t q, const mpz_t n, uintptr_t d)
{
gmp_assert_nocarry (mpz_div_qr_ui (q, NULL, n, d, GMP_DIV_TRUNC));
}
int
mpz_divisible_ui_p (const mpz_t n, unsigned long d)
mpz_divisible_ui_p (const mpz_t n, uintptr_t d)
{
return mpz_div_qr_ui (NULL, NULL, n, d, GMP_DIV_TRUNC) == 0;
}
@ -2667,8 +2668,8 @@ mpn_gcd_11 (mp_limb_t u, mp_limb_t v)
return u << shift;
}
unsigned long
mpz_gcd_ui (mpz_t g, const mpz_t u, unsigned long v)
uintptr_t
mpz_gcd_ui (mpz_t g, const mpz_t u, uintptr_t v)
{
mpz_t t;
mpz_init_set_ui(t, v);
@ -2770,7 +2771,7 @@ mpz_gcdext (mpz_t g, mpz_t s, mpz_t t, const mpz_t u, const mpz_t v)
if (u->_mp_size == 0)
{
/* g = 0 u + sgn(v) v */
signed long sign = mpz_sgn (v);
intptr_t sign = mpz_sgn (v);
mpz_abs (g, v);
if (s)
s->_mp_size = 0;
@ -2782,7 +2783,7 @@ mpz_gcdext (mpz_t g, mpz_t s, mpz_t t, const mpz_t u, const mpz_t v)
if (v->_mp_size == 0)
{
/* g = sgn(u) u + 0 v */
signed long sign = mpz_sgn (u);
intptr_t sign = mpz_sgn (u);
mpz_abs (g, u);
if (s)
mpz_set_si (s, sign);
@ -2965,7 +2966,7 @@ mpz_lcm (mpz_t r, const mpz_t u, const mpz_t v)
}
void
mpz_lcm_ui (mpz_t r, const mpz_t u, unsigned long v)
mpz_lcm_ui (mpz_t r, const mpz_t u, uintptr_t v)
{
if (v == 0 || u->_mp_size == 0)
{
@ -3015,9 +3016,9 @@ mpz_invert (mpz_t r, const mpz_t u, const mpz_t m)
/* Higher level operations (sqrt, pow and root) */
void
mpz_pow_ui (mpz_t r, const mpz_t b, unsigned long e)
mpz_pow_ui (mpz_t r, const mpz_t b, uintptr_t e)
{
unsigned long bit;
uintptr_t bit;
mpz_t tr;
mpz_init_set_ui (tr, 1);
@ -3036,7 +3037,7 @@ mpz_pow_ui (mpz_t r, const mpz_t b, unsigned long e)
}
void
mpz_ui_pow_ui (mpz_t r, unsigned long blimb, unsigned long e)
mpz_ui_pow_ui (mpz_t r, uintptr_t blimb, uintptr_t e)
{
mpz_t b;
@ -3151,7 +3152,7 @@ mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m)
}
void
mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m)
mpz_powm_ui (mpz_t r, const mpz_t b, uintptr_t elimb, const mpz_t m)
{
mpz_t e;
@ -3162,7 +3163,7 @@ mpz_powm_ui (mpz_t r, const mpz_t b, unsigned long elimb, const mpz_t m)
/* x=trunc(y^(1/z)), r=y-x^z */
void
mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, unsigned long z)
mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, uintptr_t z)
{
int sgn;
mpz_t t, u;
@ -3222,7 +3223,7 @@ mpz_rootrem (mpz_t x, mpz_t r, const mpz_t y, unsigned long z)
}
int
mpz_root (mpz_t x, const mpz_t y, unsigned long z)
mpz_root (mpz_t x, const mpz_t y, uintptr_t z)
{
int res;
mpz_t r;
@ -3293,7 +3294,7 @@ mpn_sqrtrem (mp_ptr sp, mp_ptr rp, mp_srcptr p, mp_size_t n)
/* Combinatorics */
void
mpz_mfac_uiui (mpz_t x, unsigned long n, unsigned long m)
mpz_mfac_uiui (mpz_t x, uintptr_t n, uintptr_t m)
{
mpz_set_ui (x, n + (n == 0));
if (m + 1 < 2) return;
@ -3302,19 +3303,19 @@ mpz_mfac_uiui (mpz_t x, unsigned long n, unsigned long m)
}
void
mpz_2fac_ui (mpz_t x, unsigned long n)
mpz_2fac_ui (mpz_t x, uintptr_t n)
{
mpz_mfac_uiui (x, n, 2);
}
void
mpz_fac_ui (mpz_t x, unsigned long n)
mpz_fac_ui (mpz_t x, uintptr_t n)
{
mpz_mfac_uiui (x, n, 1);
}
void
mpz_bin_uiui (mpz_t r, unsigned long n, unsigned long k)
mpz_bin_uiui (mpz_t r, uintptr_t n, uintptr_t k)
{
mpz_t t;
@ -3393,10 +3394,10 @@ gmp_lucas_step_k_2k (mpz_t V, mpz_t Qk, const mpz_t n)
/* Computes V_k, Q^k (mod n) for the Lucas' sequence */
/* with P=1, Q=Q; k = (n>>b0)|1. */
/* Requires an odd n > 4; b0 > 0; -2*Q must not overflow a long */
/* Requires an odd n > 4; b0 > 0; -2*Q must not overflow a intptr_t */
/* Returns (U_k == 0) and sets V=V_k and Qk=Q^k. */
static int
gmp_lucas_mod (mpz_t V, mpz_t Qk, long Q,
gmp_lucas_mod (mpz_t V, mpz_t Qk, intptr_t Q,
mp_bitcnt_t b0, const mpz_t n)
{
mp_bitcnt_t bs;
@ -3404,8 +3405,8 @@ gmp_lucas_mod (mpz_t V, mpz_t Qk, long Q,
int res;
assert (b0 > 0);
assert (Q <= - (LONG_MIN / 2));
assert (Q >= - (LONG_MAX / 2));
assert (Q <= - (INTPTR_MIN / 2));
assert (Q >= - (INTPTR_MAX / 2));
assert (mpz_cmp_ui (n, 4) > 0);
assert (mpz_odd_p (n));
@ -3459,7 +3460,7 @@ gmp_stronglucas (const mpz_t x, mpz_t Qk)
mp_bitcnt_t b0;
mpz_t V, n;
mp_limb_t maxD, D; /* The absolute value is stored. */
long Q;
intptr_t Q;
mp_limb_t tl;
/* Test on the absolute value. */
@ -3494,7 +3495,7 @@ gmp_stronglucas (const mpz_t x, mpz_t Qk)
b0 = mpz_scan0 (n, 0);
/* D= P^2 - 4Q; P = 1; Q = (1-D)/4 */
Q = (D & 2) ? (long) (D >> 2) + 1 : -(long) (D >> 2);
Q = (D & 2) ? (intptr_t) (D >> 2) + 1 : -(intptr_t) (D >> 2);
if (! gmp_lucas_mod (V, Qk, Q, b0, n)) /* If Ud != 0 */
while (V->_mp_size != 0 && --b0 != 0) /* while Vk != 0 */
@ -3588,7 +3589,7 @@ mpz_probab_prime_p (const mpz_t n, int reps)
for (j = 0; is_prime & (j < reps); j++)
{
mpz_set_ui (y, (unsigned long) j*j+j+41);
mpz_set_ui (y, (uintptr_t) j*j+j+41);
if (mpz_cmp (y, nm1) >= 0)
{
/* Don't try any further bases. This "early" break does not affect

93
libguile/mini-gmp.h
View file

@ -1,6 +1,6 @@
/* mini-gmp, a minimalistic implementation of a GNU GMP subset.
Copyright 2011-2015, 2017, 2019-2020 Free Software Foundation, Inc.
Copyright 2011-2015, 2017, 2019-2021 Free Software Foundation, Inc.
This file is part of the GNU MP Library.
@ -53,17 +53,14 @@ void mp_get_memory_functions (void *(**) (size_t),
void *(**) (void *, size_t, size_t),
void (**) (void *, size_t));
#ifndef MINI_GMP_LIMB_TYPE
#define MINI_GMP_LIMB_TYPE long
#endif
typedef unsigned MINI_GMP_LIMB_TYPE mp_limb_t;
typedef uintptr_t mp_limb_t;
typedef long mp_size_t;
typedef unsigned long mp_bitcnt_t;
typedef mp_limb_t *mp_ptr;
typedef const mp_limb_t *mp_srcptr;
typedef struct
{
int _mp_alloc; /* Number of *limbs* allocated and pointed
@ -131,10 +128,10 @@ void mpz_clear (mpz_t);
#define mpz_even_p(z) (! mpz_odd_p (z))
int mpz_sgn (const mpz_t);
int mpz_cmp_si (const mpz_t, long);
int mpz_cmp_ui (const mpz_t, unsigned long);
int mpz_cmp_si (const mpz_t, intptr_t);
int mpz_cmp_ui (const mpz_t, uintptr_t);
int mpz_cmp (const mpz_t, const mpz_t);
int mpz_cmpabs_ui (const mpz_t, unsigned long);
int mpz_cmpabs_ui (const mpz_t, uintptr_t);
int mpz_cmpabs (const mpz_t, const mpz_t);
int mpz_cmp_d (const mpz_t, double);
int mpz_cmpabs_d (const mpz_t, double);
@ -143,19 +140,19 @@ void mpz_abs (mpz_t, const mpz_t);
void mpz_neg (mpz_t, const mpz_t);
void mpz_swap (mpz_t, mpz_t);
void mpz_add_ui (mpz_t, const mpz_t, unsigned long);
void mpz_add_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_add (mpz_t, const mpz_t, const mpz_t);
void mpz_sub_ui (mpz_t, const mpz_t, unsigned long);
void mpz_ui_sub (mpz_t, unsigned long, const mpz_t);
void mpz_sub_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_ui_sub (mpz_t, uintptr_t, const mpz_t);
void mpz_sub (mpz_t, const mpz_t, const mpz_t);
void mpz_mul_si (mpz_t, const mpz_t, long int);
void mpz_mul_ui (mpz_t, const mpz_t, unsigned long int);
void mpz_mul_si (mpz_t, const mpz_t, intptr_t);
void mpz_mul_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_mul (mpz_t, const mpz_t, const mpz_t);
void mpz_mul_2exp (mpz_t, const mpz_t, mp_bitcnt_t);
void mpz_addmul_ui (mpz_t, const mpz_t, unsigned long int);
void mpz_addmul_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_addmul (mpz_t, const mpz_t, const mpz_t);
void mpz_submul_ui (mpz_t, const mpz_t, unsigned long int);
void mpz_submul_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_submul (mpz_t, const mpz_t, const mpz_t);
void mpz_cdiv_qr (mpz_t, mpz_t, const mpz_t, const mpz_t);
@ -182,29 +179,29 @@ void mpz_divexact (mpz_t, const mpz_t, const mpz_t);
int mpz_divisible_p (const mpz_t, const mpz_t);
int mpz_congruent_p (const mpz_t, const mpz_t, const mpz_t);
unsigned long mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
unsigned long mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
unsigned long mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, unsigned long);
unsigned long mpz_cdiv_q_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_fdiv_q_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_tdiv_q_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_cdiv_r_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_fdiv_r_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_tdiv_r_ui (mpz_t, const mpz_t, unsigned long);
unsigned long mpz_cdiv_ui (const mpz_t, unsigned long);
unsigned long mpz_fdiv_ui (const mpz_t, unsigned long);
unsigned long mpz_tdiv_ui (const mpz_t, unsigned long);
uintptr_t mpz_cdiv_qr_ui (mpz_t, mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_fdiv_qr_ui (mpz_t, mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_tdiv_qr_ui (mpz_t, mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_cdiv_q_ui (mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_fdiv_q_ui (mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_tdiv_q_ui (mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_cdiv_r_ui (mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_fdiv_r_ui (mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_tdiv_r_ui (mpz_t, const mpz_t, uintptr_t);
uintptr_t mpz_cdiv_ui (const mpz_t, uintptr_t);
uintptr_t mpz_fdiv_ui (const mpz_t, uintptr_t);
uintptr_t mpz_tdiv_ui (const mpz_t, uintptr_t);
unsigned long mpz_mod_ui (mpz_t, const mpz_t, unsigned long);
uintptr_t mpz_mod_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_divexact_ui (mpz_t, const mpz_t, unsigned long);
void mpz_divexact_ui (mpz_t, const mpz_t, uintptr_t);
int mpz_divisible_ui_p (const mpz_t, unsigned long);
int mpz_divisible_ui_p (const mpz_t, uintptr_t);
unsigned long mpz_gcd_ui (mpz_t, const mpz_t, unsigned long);
uintptr_t mpz_gcd_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_gcd (mpz_t, const mpz_t, const mpz_t);
void mpz_gcdext (mpz_t, mpz_t, mpz_t, const mpz_t, const mpz_t);
void mpz_lcm_ui (mpz_t, const mpz_t, unsigned long);
void mpz_lcm_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_lcm (mpz_t, const mpz_t, const mpz_t);
int mpz_invert (mpz_t, const mpz_t, const mpz_t);
@ -212,18 +209,18 @@ void mpz_sqrtrem (mpz_t, mpz_t, const mpz_t);
void mpz_sqrt (mpz_t, const mpz_t);
int mpz_perfect_square_p (const mpz_t);
void mpz_pow_ui (mpz_t, const mpz_t, unsigned long);
void mpz_ui_pow_ui (mpz_t, unsigned long, unsigned long);
void mpz_pow_ui (mpz_t, const mpz_t, uintptr_t);
void mpz_ui_pow_ui (mpz_t, uintptr_t, uintptr_t);
void mpz_powm (mpz_t, const mpz_t, const mpz_t, const mpz_t);
void mpz_powm_ui (mpz_t, const mpz_t, unsigned long, const mpz_t);
void mpz_powm_ui (mpz_t, const mpz_t, uintptr_t, const mpz_t);
void mpz_rootrem (mpz_t, mpz_t, const mpz_t, unsigned long);
int mpz_root (mpz_t, const mpz_t, unsigned long);
void mpz_rootrem (mpz_t, mpz_t, const mpz_t, uintptr_t);
int mpz_root (mpz_t, const mpz_t, uintptr_t);
void mpz_fac_ui (mpz_t, unsigned long);
void mpz_2fac_ui (mpz_t, unsigned long);
void mpz_mfac_uiui (mpz_t, unsigned long, unsigned long);
void mpz_bin_uiui (mpz_t, unsigned long, unsigned long);
void mpz_fac_ui (mpz_t, uintptr_t);
void mpz_2fac_ui (mpz_t, uintptr_t);
void mpz_mfac_uiui (mpz_t, uintptr_t, uintptr_t);
void mpz_bin_uiui (mpz_t, uintptr_t, uintptr_t);
int mpz_probab_prime_p (const mpz_t, int);
@ -244,8 +241,8 @@ mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t);
int mpz_fits_slong_p (const mpz_t);
int mpz_fits_ulong_p (const mpz_t);
long int mpz_get_si (const mpz_t);
unsigned long int mpz_get_ui (const mpz_t);
intptr_t mpz_get_si (const mpz_t);
uintptr_t mpz_get_ui (const mpz_t);
double mpz_get_d (const mpz_t);
size_t mpz_size (const mpz_t);
mp_limb_t mpz_getlimbn (const mpz_t, mp_size_t);
@ -259,13 +256,13 @@ mpz_srcptr mpz_roinit_n (mpz_t, mp_srcptr, mp_size_t);
#define MPZ_ROINIT_N(xp, xs) {{0, (xs),(xp) }}
void mpz_set_si (mpz_t, signed long int);
void mpz_set_ui (mpz_t, unsigned long int);
void mpz_set_si (mpz_t, intptr_t);
void mpz_set_ui (mpz_t, uintptr_t);
void mpz_set (mpz_t, const mpz_t);
void mpz_set_d (mpz_t, double);
void mpz_init_set_si (mpz_t, signed long int);
void mpz_init_set_ui (mpz_t, unsigned long int);
void mpz_init_set_si (mpz_t, intptr_t);
void mpz_init_set_ui (mpz_t, uintptr_t);
void mpz_init_set (mpz_t, const mpz_t);
void mpz_init_set_d (mpz_t, double);

98
libguile/numbers.c
View file

@ -91,27 +91,33 @@
/* FIXME: We assume that FLT_RADIX is 2 */
verify (FLT_RADIX == 2);
/* Make sure that scm_t_inum fits within a SCM value. */
verify (sizeof (scm_t_inum) <= sizeof (scm_t_bits));
/* Make sure that intptr_t fits within a SCM value. */
verify (sizeof (intptr_t) <= sizeof (scm_t_bits));
#if !(__MINGW32__ && __x86_64__)
#define L1 1L
#define UL1 1UL
#else /* (__MINGW32__ && __x86_64__) */
#define L1 1LL
#define UL1 1ULL
#endif /* (__MINGW32__ && __x86_64__) */
/* Several functions below assume that fixnums fit within a long, and
furthermore that there is some headroom to spare for other operations
without overflowing. */
verify (SCM_I_FIXNUM_BIT <= SCM_LONG_BIT - 2);
verify (SCM_I_FIXNUM_BIT <= SCM_INTPTR_T_BIT - 2);
/* Some functions that use GMP's mpn functions assume that a
non-negative fixnum will always fit in a 'mp_limb_t'. */
verify (SCM_MOST_POSITIVE_FIXNUM <= (mp_limb_t) -1);
#define scm_from_inum(x) (scm_from_signed_integer (x))
/* Test an inum to see if it can be converted to a double without loss
of precision. Note that this will sometimes return 0 even when 1
could have been returned, e.g. for large powers of 2. It is designed
to be a fast check to optimize common cases. */
#define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
(SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
|| ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
|| ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (L1 << DBL_MANT_DIG))
#if (! HAVE_DECL_MPZ_INITS) || SCM_ENABLE_MINI_GMP
@ -2854,8 +2860,8 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_logbit_p
{
unsigned long int iindex;
iindex = scm_to_ulong (index);
uintptr_t iindex;
iindex = scm_to_uintptr_t (index);
if (SCM_I_INUMP (j))
return scm_from_bool (scm_integer_logbit_ui (iindex, SCM_I_INUM (j)));
@ -3030,13 +3036,13 @@ lsh (SCM n, SCM count, const char *fn)
{
if (scm_is_eq (n, SCM_INUM0))
return n;
if (!scm_is_unsigned_integer (count, 0, ULONG_MAX))
if (!scm_is_unsigned_integer (count, 0, UINTPTR_MAX))
scm_num_overflow (fn);
unsigned long ucount = scm_to_ulong (count);
uintptr_t ucount = scm_to_uintptr_t (count);
if (ucount == 0)
return n;
if (ucount / (sizeof (int) * 8) >= (unsigned long) INT_MAX)
if (ucount / (sizeof (int) * 8) >= (uintptr_t) INT_MAX)
scm_num_overflow (fn);
if (SCM_I_INUMP (n))
return scm_integer_lsh_iu (SCM_I_INUM (n), ucount);
@ -3046,10 +3052,10 @@ lsh (SCM n, SCM count, const char *fn)
static SCM
floor_rsh (SCM n, SCM count)
{
if (!scm_is_unsigned_integer (count, 0, ULONG_MAX))
if (!scm_is_unsigned_integer (count, 0, UINTPTR_MAX))
return scm_is_false (scm_negative_p (n)) ? SCM_INUM0 : SCM_I_MAKINUM (-1);
unsigned long ucount = scm_to_ulong (count);
uintptr_t ucount = scm_to_uintptr_t (count);
if (ucount == 0)
return n;
if (SCM_I_INUMP (n))
@ -3060,10 +3066,10 @@ floor_rsh (SCM n, SCM count)
static SCM
round_rsh (SCM n, SCM count)
{
if (!scm_is_unsigned_integer (count, 0, ULONG_MAX))
if (!scm_is_unsigned_integer (count, 0, UINTPTR_MAX))
return SCM_INUM0;
unsigned long ucount = scm_to_ulong (count);
uintptr_t ucount = scm_to_uintptr_t (count);
if (ucount == 0)
return n;
if (SCM_I_INUMP (n))
@ -3153,10 +3159,10 @@ SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
if (!scm_is_exact_integer (n))
SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
unsigned long istart = scm_to_ulong (start);
unsigned long iend = scm_to_ulong (end);
uintptr_t istart = scm_to_uintptr_t (start);
uintptr_t iend = scm_to_uintptr_t (end);
SCM_ASSERT_RANGE (3, end, (iend >= istart));
unsigned long bits = iend - istart;
uintptr_t bits = iend - istart;
if (SCM_I_INUMP (n))
return scm_integer_bit_extract_i (SCM_I_INUM (n), istart, bits);
@ -5308,7 +5314,7 @@ scm_product (SCM x, SCM y)
if (SCM_UNBNDP (y))
{
if (SCM_UNBNDP (x))
return SCM_I_MAKINUM (1L);
return SCM_I_MAKINUM (L1);
else if (SCM_NUMBERP (x))
return x;
else
@ -5436,7 +5442,7 @@ divide (SCM x, SCM y)
return scm_i_make_ratio (x, y);
else if (SCM_REALP (y))
/* FIXME: Precision may be lost here due to:
(1) The cast from 'scm_t_inum' to 'double'
(1) The cast from 'intptr_t' to 'double'
(2) Double rounding */
return scm_i_from_double ((double) SCM_I_INUM (x) / SCM_REAL_VALUE (y));
else if (SCM_COMPLEXP (y))
@ -5476,7 +5482,7 @@ divide (SCM x, SCM y)
double rx = SCM_REAL_VALUE (x);
if (SCM_I_INUMP (y))
/* FIXME: Precision may be lost here due to:
(1) The cast from 'scm_t_inum' to 'double'
(1) The cast from 'intptr_t' to 'double'
(2) Double rounding */
return scm_i_from_double (rx / (double) SCM_I_INUM (y));
else if (SCM_BIGP (y))
@ -5500,7 +5506,7 @@ divide (SCM x, SCM y)
if (SCM_I_INUMP (y))
{
/* FIXME: Precision may be lost here due to:
(1) The conversion from 'scm_t_inum' to double
(1) The conversion from 'intptr_t' to double
(2) Double rounding */
double d = SCM_I_INUM (y);
return scm_c_make_rectangular (rx / d, ix / d);
@ -6616,18 +6622,18 @@ range_error (SCM bad_val, SCM min, SCM max)
}
#define scm_i_range_error range_error
static scm_t_inum
inum_in_range (SCM x, scm_t_inum min, scm_t_inum max)
static intptr_t
inum_in_range (SCM x, intptr_t min, intptr_t max)
{
if (SCM_LIKELY (SCM_I_INUMP (x)))
{
scm_t_inum val = SCM_I_INUM (x);
intptr_t val = SCM_I_INUM (x);
if (min <= val && val <= max)
return val;
}
else if (!SCM_BIGP (x))
scm_wrong_type_arg_msg (NULL, 0, x, "exact integer");
range_error (x, scm_from_long (min), scm_from_long (max));
range_error (x, scm_from_intptr_t (min), scm_from_intptr_t (max));
}
SCM
@ -6667,7 +6673,7 @@ scm_to_unsigned_integer (SCM arg, uintmax_t min, uintmax_t max)
uint64_t ret;
if (SCM_I_INUMP (arg))
{
scm_t_inum n = SCM_I_INUM (arg);
intptr_t n = SCM_I_INUM (arg);
if (n < 0)
goto out_of_range;
ret = n;
@ -6736,7 +6742,7 @@ scm_from_uint16 (uint16_t arg)
int32_t
scm_to_int32 (SCM arg)
{
#if SCM_SIZEOF_LONG == 4
#if SCM_SIZEOF_INTPTR_T == 4
if (SCM_I_INUMP (arg))
return SCM_I_INUM (arg);
else if (!SCM_BIGP (arg))
@ -6746,7 +6752,7 @@ scm_to_int32 (SCM arg)
return ret;
range_error (arg, scm_integer_from_int32 (INT32_MIN),
scm_integer_from_int32 (INT32_MAX));
#elif SCM_SIZEOF_LONG == 8
#elif SCM_SIZEOF_INTPTR_T == 8
return inum_in_range (arg, INT32_MIN, INT32_MAX);
#else
#error bad inum size
@ -6756,9 +6762,9 @@ scm_to_int32 (SCM arg)
SCM
scm_from_int32 (int32_t arg)
{
#if SCM_SIZEOF_LONG == 4
#if SCM_SIZEOF_INTPTR_T == 4
return scm_integer_from_int32 (arg);
#elif SCM_SIZEOF_LONG == 8
#elif SCM_SIZEOF_INTPTR_T == 8
return SCM_I_MAKINUM (arg);
#else
#error bad inum size
@ -6768,7 +6774,7 @@ scm_from_int32 (int32_t arg)
uint32_t
scm_to_uint32 (SCM arg)
{
#if SCM_SIZEOF_LONG == 4
#if SCM_SIZEOF_INTPTR_T == 4
if (SCM_I_INUMP (arg))
{
if (SCM_I_INUM (arg) >= 0)
@ -6783,7 +6789,7 @@ scm_to_uint32 (SCM arg)
else
scm_wrong_type_arg_msg (NULL, 0, arg, "exact integer");
range_error (arg, scm_integer_from_uint32 (0), scm_integer_from_uint32 (UINT32_MAX));
#elif SCM_SIZEOF_LONG == 8
#elif SCM_SIZEOF_INTPTR_T == 8
return inum_in_range (arg, 0, UINT32_MAX);
#else
#error bad inum size
@ -6793,9 +6799,9 @@ scm_to_uint32 (SCM arg)
SCM
scm_from_uint32 (uint32_t arg)
{
#if SCM_SIZEOF_LONG == 4
#if SCM_SIZEOF_INTPTR_T == 4
return scm_integer_from_uint32 (arg);
#elif SCM_SIZEOF_LONG == 8
#elif SCM_SIZEOF_INTPTR_T == 8
return SCM_I_MAKINUM (arg);
#else
#error bad inum size
@ -6965,7 +6971,7 @@ scm_is_number (SCM z)
/* Returns log(x * 2^shift) */
static SCM
log_of_shifted_double (double x, long shift)
log_of_shifted_double (double x, intptr_t shift)
{
/* cf scm_log10 */
double ans = log (fabs (x)) + shift * M_LN2;
@ -6983,7 +6989,7 @@ log_of_exact_integer (SCM n)
return log_of_shifted_double (SCM_I_INUM (n), 0);
else if (SCM_BIGP (n))
{
long expon;
intptr_t expon;
double signif = scm_integer_frexp_z (scm_bignum (n), &expon);
return log_of_shifted_double (signif, expon);
}
@ -6995,8 +7001,8 @@ log_of_exact_integer (SCM n)
static SCM
log_of_fraction (SCM n, SCM d)
{
long n_size = scm_to_long (scm_integer_length (n));
long d_size = scm_to_long (scm_integer_length (d));
intptr_t n_size = scm_to_intptr_t (scm_integer_length (n));
intptr_t d_size = scm_to_intptr_t (scm_integer_length (d));
if (labs (n_size - d_size) > 1)
return (scm_difference (log_of_exact_integer (n),
@ -7152,7 +7158,7 @@ scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
{
if (SCM_I_INUMP (k))
{
scm_t_inum kk = SCM_I_INUM (k);
intptr_t kk = SCM_I_INUM (k);
if (kk >= 0)
return scm_integer_exact_sqrt_i (kk, sp, rp);
}
@ -7183,7 +7189,7 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
{
if (SCM_I_INUMP (z))
{
scm_t_inum i = SCM_I_INUM (z);
intptr_t i = SCM_I_INUM (z);
if (scm_is_integer_perfect_square_i (i))
return scm_integer_floor_sqrt_i (i);
double root = scm_integer_inexact_sqrt_i (i);
@ -7232,16 +7238,16 @@ SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
double xx = scm_i_divide2double (n, d);
double abs_xx = fabs (xx);
long shift = 0;
intptr_t shift = 0;
if (abs_xx > DBL_MAX || abs_xx < DBL_MIN)
{
shift = (scm_to_long (scm_integer_length (n))
- scm_to_long (scm_integer_length (d))) / 2;
shift = (scm_to_intptr_t (scm_integer_length (n))
- scm_to_intptr_t (scm_integer_length (d))) / 2;
if (shift > 0)
d = lsh (d, scm_from_long (2 * shift), FUNC_NAME);
d = lsh (d, scm_from_intptr_t (2 * shift), FUNC_NAME);
else
n = lsh (n, scm_from_long (-2 * shift), FUNC_NAME);
n = lsh (n, scm_from_intptr_t (-2 * shift), FUNC_NAME);
xx = scm_i_divide2double (n, d);
}

19
libguile/numbers.h
View file

@ -54,10 +54,17 @@ extern "C++" {
* (along with two tagging bits).
*
* In the current implementation, Inums must also fit within a long
* because that's what GMP's mpz_*_si functions accept. */
typedef long scm_t_inum;
#define SCM_I_FIXNUM_BIT (SCM_LONG_BIT - 2)
* because that's what GMP's mpz_*_si functions accept.
*
* When using mini-gmp, we use intptr_t instead.
*/
#define SCM_I_FIXNUM_BIT (SCM_INTPTR_T_BIT - 2)
#if !(__MINGW32__ && __x86_64__)
#define SCM_MOST_NEGATIVE_FIXNUM (-1L << (SCM_I_FIXNUM_BIT - 1))
#else /* __MINGW32__ && __x86_64__ */
#define SCM_MOST_NEGATIVE_FIXNUM (-1LL << (SCM_I_FIXNUM_BIT - 1))
#endif /* __MINGW32__ && __x86_64__ */
#define SCM_MOST_POSITIVE_FIXNUM (- (SCM_MOST_NEGATIVE_FIXNUM + 1))
/* SCM_SRS (X, Y) is signed right shift, defined as floor (X / 2^Y),
@ -85,12 +92,12 @@ typedef long scm_t_inum;
NOTE: X must not perform side effects. */
#ifdef __GNUC__
# define SCM_I_INUM(x) (SCM_SRS ((scm_t_inum) SCM_UNPACK (x), 2))
# define SCM_I_INUM(x) (SCM_SRS ((intptr_t) SCM_UNPACK (x), 2))
#else
# define SCM_I_INUM(x) \
(SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \
? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> 2) \
: (scm_t_inum) (SCM_UNPACK (x) >> 2))
? -1 - (intptr_t) (~SCM_UNPACK (x) >> 2) \
: (intptr_t) (SCM_UNPACK (x) >> 2))
#endif
#define SCM_I_INUMP(x) (2 & SCM_UNPACK (x))

6
libguile/scm.h
View file

@ -837,10 +837,8 @@ typedef struct scm_thread scm_thread;
# define SCM_CHAR_BIT 8
#endif
#ifdef LONG_BIT
# define SCM_LONG_BIT LONG_BIT
#else
# define SCM_LONG_BIT (SCM_SIZEOF_LONG * 8)
#ifndef INTPTR_T_BIT
# define SCM_INTPTR_T_BIT (SCM_SIZEOF_INTPTR_T * 8)
#endif

14
libguile/scmsigs.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2002,2004,2006-2009,2011,2013-2014,2017-2018
/* Copyright 1995-2002,2004,2006-2009,2011,2013-2014,2017-2018,2021
Free Software Foundation, Inc.
This file is part of Guile.
@ -344,9 +344,9 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
query_only = 1;
else if (scm_is_integer (handler))
{
long handler_int = scm_to_long (handler);
intptr_t handler_int = scm_to_intptr_t (handler);
if (handler_int == (long) SIG_DFL || handler_int == (long) SIG_IGN)
if (handler_int == (intptr_t) SIG_DFL || handler_int == (intptr_t) SIG_IGN)
{
#ifdef HAVE_SIGACTION
action.sa_handler = (void (*) (int)) handler_int;
@ -442,7 +442,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
orig_handlers[csig] = old_action;
}
if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN)
old_handler = scm_from_long ((long) old_action.sa_handler);
old_handler = scm_from_intptr_t ((intptr_t) old_action.sa_handler);
scm_dynwind_end ();
@ -463,7 +463,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
orig_handlers[csig] = old_chandler;
}
if (old_chandler == SIG_DFL || old_chandler == SIG_IGN)
old_handler = scm_from_long ((long) old_chandler);
old_handler = scm_from_intptr_t ((intptr_t) old_chandler);
scm_dynwind_end ();
@ -727,8 +727,8 @@ scm_init_scmsigs ()
}
scm_c_define ("NSIG", scm_from_long (NSIG));
scm_c_define ("SIG_IGN", scm_from_long ((long) SIG_IGN));
scm_c_define ("SIG_DFL", scm_from_long ((long) SIG_DFL));
scm_c_define ("SIG_IGN", scm_from_intptr_t ((intptr_t) SIG_IGN));
scm_c_define ("SIG_DFL", scm_from_intptr_t ((intptr_t) SIG_DFL));
#ifdef SA_NOCLDSTOP
scm_c_define ("SA_NOCLDSTOP", scm_from_long (SA_NOCLDSTOP));
#endif

87
libguile/srfi-60.c
View file

@ -1,6 +1,6 @@
/* srfi-60.c --- Integers as Bits
Copyright 2005-2006,2008,2010,2014,2018,2022
Copyright 2005-2006,2008,2010,2014,2018,2021,2022
Free Software Foundation, Inc.
This file is part of Guile.
@ -76,10 +76,10 @@ SCM_DEFINE (scm_srfi60_copy_bit, "copy-bit", 3, 0, 0,
"@end example")
#define FUNC_NAME s_scm_srfi60_copy_bit
{
unsigned long ii;
uintptr_t ii;
int bb;
ii = scm_to_ulong (index);
ii = scm_to_uintptr_t (index);
bb = scm_to_bool (newbit);
if (SCM_I_INUMP (n))
@ -113,9 +113,9 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0,
"@end example")
#define FUNC_NAME s_scm_srfi60_rotate_bit_field
{
unsigned long ss = scm_to_ulong (start);
unsigned long ee = scm_to_ulong (end);
unsigned long ww, cc;
uintptr_t ss = scm_to_uintptr_t (start);
uintptr_t ee = scm_to_uintptr_t (end);
uintptr_t ww, cc;
SCM_ASSERT_RANGE (3, end, (ee >= ss));
ww = ee - ss;
@ -125,45 +125,46 @@ SCM_DEFINE (scm_srfi60_rotate_bit_field, "rotate-bit-field", 4, 0, 0,
if (ww <= 1)
cc = 0;
else
cc = scm_to_ulong (scm_modulo (count, scm_difference (end, start)));
cc = scm_to_uintptr_t (scm_modulo (count, scm_difference (end, start)));
mpz_t zn;
if (SCM_I_INUMP (n))
{
long nn = SCM_I_INUM (n);
intptr_t nn = SCM_I_INUM (n);
if (ee <= SCM_LONG_BIT-1)
if (ee <= SCM_INTPTR_T_BIT-1)
{
/* Everything fits within a long. To avoid undefined behavior
when shifting negative numbers, we do all operations using
unsigned values, and then convert to signed at the end. */
unsigned long unn = nn;
unsigned long below = unn & ((1UL << ss) - 1); /* below start */
unsigned long above = unn & ~((1UL << ee) - 1); /* above end */
unsigned long fmask = ((1UL << ww) - 1) << ss; /* field mask */
unsigned long ff = unn & fmask; /* field */
unsigned long uresult = (above
/* Everything fits within a intptr_t. To avoid undefined
behavior when shifting negative numbers, we do all
operations using unsigned values, and then convert to
signed at the end. */
uintptr_t unn = nn;
uintptr_t below = unn & ((1UL << ss) - 1); /* below start */
uintptr_t above = unn & ~((1UL << ee) - 1); /* above end */
uintptr_t fmask = ((1UL << ww) - 1) << ss; /* field mask */
uintptr_t ff = unn & fmask; /* field */
uintptr_t uresult = (above
| ((ff << cc) & fmask)
| ((ff >> (ww-cc)) & fmask)
| below);
long result;
intptr_t result;
if (uresult > LONG_MAX)
if (uresult > INTPTR_MAX)
/* The high bit is set in uresult, so the result is
negative. We have to handle the conversion to signed
integer carefully, to avoid undefined behavior. First we
compute ~uresult, equivalent to (ULONG_MAX - uresult),
which will be between 0 and LONG_MAX (inclusive): exactly
the set of numbers that can be represented as both signed
and unsigned longs and thus convertible between them. We
the set of numbers that can be represented as both intptr_t
and uintptr_p and thus convertible between them. We
cast that difference to a signed long and then substract
it from -1. */
result = -1 - (long) ~uresult;
result = -1 - (intptr_t) ~uresult;
else
result = (long) uresult;
result = (intptr_t) uresult;
return scm_from_long (result);
return scm_from_intptr_t (result);
}
else
{
@ -230,31 +231,31 @@ SCM_DEFINE (scm_srfi60_reverse_bit_field, "reverse-bit-field", 3, 0, 0,
"@end example")
#define FUNC_NAME s_scm_srfi60_reverse_bit_field
{
long ss = scm_to_long (start);
long ee = scm_to_long (end);
long swaps = (ee - ss) / 2; /* number of swaps */
intptr_t ss = scm_to_intptr_t (start);
intptr_t ee = scm_to_intptr_t (end);
intptr_t swaps = (ee - ss) / 2; /* number of swaps */
mpz_t b;
if (SCM_I_INUMP (n))
{
long nn = SCM_I_INUM (n);
intptr_t nn = SCM_I_INUM (n);
if (ee <= SCM_LONG_BIT-1)
if (ee <= SCM_INTPTR_T_BIT-1)
{
/* all within a long */
long smask = 1L << ss;
long emask = 1L << (ee-1);
/* all within a intptr_t */
intptr_t smask = 1L << ss;
intptr_t emask = 1L << (ee-1);
for ( ; swaps > 0; swaps--)
{
long sbit = nn & smask;
long ebit = nn & emask;
intptr_t sbit = nn & smask;
intptr_t ebit = nn & emask;
nn ^= sbit ^ (ebit ? smask : 0) /* zap sbit, put ebit value */
^ ebit ^ (sbit ? emask : 0); /* zap ebit, put sbit value */
smask <<= 1;
emask >>= 1;
}
return scm_from_long (nn);
return scm_from_intptr_t (nn);
}
else
{
@ -319,22 +320,22 @@ SCM_DEFINE (scm_srfi60_integer_to_list, "integer->list", 1, 1, 0,
#define FUNC_NAME s_scm_srfi60_integer_to_list
{
SCM ret = SCM_EOL;
unsigned long ll;
uintptr_t ll;
if (SCM_UNBNDP (len))
len = scm_integer_length (n);
ll = scm_to_ulong (len);
ll = scm_to_uintptr_t (len);
if (SCM_I_INUMP (n))
{
scm_t_inum nn = SCM_I_INUM (n);
for (unsigned long i = 0; i < ll; i++)
intptr_t nn = SCM_I_INUM (n);
for (uintptr_t i = 0; i < ll; i++)
ret = scm_cons (scm_from_bool (scm_integer_logbit_ui (i, nn)), ret);
}
else if (SCM_BIGP (n))
{
struct scm_bignum *nn = scm_bignum (n);
for (unsigned long i = 0; i < ll; i++)
for (uintptr_t i = 0; i < ll; i++)
ret = scm_cons (scm_from_bool (scm_integer_logbit_uz (i, nn)), ret);
}
else
@ -357,7 +358,7 @@ SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0,
"@end example")
#define FUNC_NAME s_scm_srfi60_list_to_integer
{
long len;
intptr_t len;
/* strip high zero bits from lst; after this the length tells us whether
an inum or bignum is required */
@ -369,7 +370,7 @@ SCM_DEFINE (scm_srfi60_list_to_integer, "list->integer", 1, 0, 0,
if (len <= SCM_I_FIXNUM_BIT - 1)
{
/* fits an inum (a positive inum) */
long n = 0;
intptr_t n = 0;
while (scm_is_pair (lst))
{
n <<= 1;

8
libguile/strings.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-1996,1998,2000-2001,2004,2006,2008-2016,2018-2019
/* Copyright 1995-1996,1998,2000-2001,2004,2006,2008-2016,2018-2019,2021
Free Software Foundation, Inc.
This file is part of Guile.
@ -760,7 +760,7 @@ scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
#define SYMBOL_STRINGBUF SCM_CELL_OBJECT_1
SCM
scm_i_make_symbol (SCM name, scm_t_bits flags, unsigned long hash)
scm_i_make_symbol (SCM name, scm_t_bits flags, uintptr_t hash)
{
SCM buf, symbol;
size_t start, length = STRING_LENGTH (name);
@ -1219,7 +1219,7 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
#define FUNC_NAME s_scm_string_ref
{
size_t len;
unsigned long idx;
uintptr_t idx;
SCM_VALIDATE_STRING (1, str);
@ -1256,7 +1256,7 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
#define FUNC_NAME s_scm_string_set_x
{
size_t len;
unsigned long idx;
uintptr_t idx;
SCM_VALIDATE_STRING (1, str);

5
libguile/strings.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
/* Copyright 1995-1998,2000-2001,2004-2006,2008-2011,2013,2015-2019,2022
/* Copyright 1995-1998,2000-2001,2004-2006,2008-2011,2013,2015-2019,2021,2022
Free Software Foundation, Inc.
This file is part of Guile.
@ -26,6 +26,7 @@
#include <libguile/error.h>
#include "libguile/inline.h"
#include <libguile/snarf.h>
#include "libguile/numbers.h"
@ -250,7 +251,7 @@ SCM_INTERNAL void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr);
/* internal functions related to symbols. */
SCM_INTERNAL SCM scm_i_make_symbol (SCM name, scm_t_bits flags,
unsigned long hash);
uintptr_t hash);
SCM_INTERNAL const char *scm_i_symbol_chars (SCM sym);
SCM_INTERNAL const scm_t_wchar *scm_i_symbol_wide_chars (SCM sym);
SCM_INTERNAL size_t scm_i_symbol_length (SCM sym);

4
libguile/symbols.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-1998,2000-2001,2003-2004,2006,2009,2011,2013,2015,2018,2022
/* Copyright 1995-1998,2000-2001,2003-2004,2006,2009,2011,2013,2015,2018
Free Software Foundation, Inc.
This file is part of Guile.
@ -415,7 +415,7 @@ SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0,
#define FUNC_NAME s_scm_symbol_hash
{
SCM_VALIDATE_SYMBOL (1, symbol);
return scm_from_ulong (scm_i_symbol_hash (symbol));
return scm_from_uintptr_t (scm_i_symbol_hash (symbol));
}
#undef FUNC_NAME