-/* this file is #include'd (many times) by numbers.c */
-
-#if HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#ifndef UNSIGNED_ITYPE
-# if UNSIGNED
-# define UNSIGNED_ITYPE ITYPE
-# else
-# define UNSIGNED_ITYPE unsigned ITYPE
-# endif
-#endif
-
-#define UNSIGNED_ITYPE_MAX (~((UNSIGNED_ITYPE)0))
-
-#ifndef SIZEOF_ITYPE
-#error SIZEOF_ITYPE must be defined.
-#endif
-
-#if UNSIGNED
-# if SIZEOF_ITYPE == SIZEOF_UNSIGNED_SHORT
-# define BIGMPZ_FITSP mpz_fits_ushort_p
-# elif SIZEOF_ITYPE == SIZEOF_UNSIGNED_INT
-# define BIGMPZ_FITSP mpz_fits_uint_p
-# elif SIZEOF_ITYPE == SIZEOF_UNSIGNED_LONG
-# define BIGMPZ_FITSP mpz_fits_ulong_p
-# else
-# define BIGMPZ_FITSP ((int (*)(void *)) 0)
-# endif /* sizeof checks */
-#else
-/* UNSIGNED is not defined */
-# if SIZEOF_ITYPE == SIZEOF_SHORT
-# define BIGMPZ_FITSP mpz_fits_sshort_p
-# elif SIZEOF_ITYPE == SIZEOF_INT
-# define BIGMPZ_FITSP mpz_fits_sint_p
-# elif SIZEOF_ITYPE == SIZEOF_LONG
-# define BIGMPZ_FITSP mpz_fits_slong_p
-# else
-# define BIGMPZ_FITSP ((int (*)(void *)) 0)
-# endif /* sizeof checks */
-#endif /* UNSIGNED check */
-
-/* We rely heavily on the compiler's optimizer to remove branches that
- have constant value guards. */
-
-ITYPE
-NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller)
-{
- if (SCM_INUMP (num))
- { /* immediate */
- scm_t_signed_bits n = SCM_INUM (num);
-
- if (UNSIGNED && (n < 0))
- scm_out_of_range (s_caller, num);
-
- if (SIZEOF_ITYPE >= SIZEOF_SCM_T_BITS)
- /* the target type is large enough to hold any possible inum */
- return (ITYPE) n;
- else
- {
-#if SIZEOF_SCM_T_BITS > SIZEOF_ITYPE
- /* an inum can be out of range, so check */
- if (UNSIGNED) /* n is known to be >= 0 */
- {
- if (((scm_t_bits) n) > UNSIGNED_ITYPE_MAX)
- scm_out_of_range (s_caller, num);
- }
- else if (((ITYPE) n) != n)
- scm_out_of_range (s_caller, num);
-#endif
- return (ITYPE) n;
- }
- }
- else if (SCM_BIGP (num))
- { /* bignum */
- if (SIZEOF_ITYPE < SIZEOF_SCM_T_BITS)
- scm_out_of_range (s_caller, num);
- else
- {
- /* make sure the result will fit */
- if (BIGMPZ_FITSP != 0)
- {
- int fits_p = BIGMPZ_FITSP (SCM_I_BIG_MPZ (num));
- scm_remember_upto_here_1 (num);
- if (!fits_p)
- scm_out_of_range (s_caller, num);
- }
- else
- {
- size_t itype_bits = sizeof (ITYPE) * SCM_CHAR_BIT;
- int sgn = mpz_sgn (SCM_I_BIG_MPZ (num));
- size_t numbits;
-
- if (UNSIGNED)
- {
- if (sgn < 0)
- scm_out_of_range (s_caller, num);
- }
-
- numbits = mpz_sizeinbase (SCM_I_BIG_MPZ (num), 2);
-
- if (UNSIGNED)
- {
- if (numbits > itype_bits)
- scm_out_of_range (s_caller, num);
- }
- else
- {
- if (sgn >= 0)
- {
- /* positive, require num < 2^(itype_bits-1) */
- if (numbits > itype_bits-1)
- scm_out_of_range (s_caller, num);
- }
- else
- {
- /* negative, require abs(num) < 2^(itype_bits-1), but
- also allow num == -2^(itype_bits-1), the latter
- detected by numbits==itype_bits plus the lowest
- (and only) 1 bit at position itype_bits-1 */
- if (numbits > itype_bits
- || (numbits == itype_bits
- && (mpz_scan1 (SCM_I_BIG_MPZ (num), 0)
- != itype_bits - 1)))
- scm_out_of_range (s_caller, num);
- }
- }
- }
-
- if (UNSIGNED && (SIZEOF_ITYPE <= SIZEOF_UNSIGNED_LONG))
- {
- ITYPE result = (ITYPE) mpz_get_ui (SCM_I_BIG_MPZ (num));
- scm_remember_upto_here_1 (num);
- return result;
- }
- else if ((!UNSIGNED) && (SIZEOF_ITYPE <= SIZEOF_LONG))
- {
- ITYPE result = (ITYPE) mpz_get_si (SCM_I_BIG_MPZ (num));
- scm_remember_upto_here_1 (num);
- return result;
- }
- else
- {
- int sgn = mpz_sgn (SCM_I_BIG_MPZ (num));
- ITYPE result = 0;
- size_t count;
-
- mpz_export (&result,
- &count,
-#ifdef WORDS_BIGENDIAN
- 1,
-#else
- -1,
-#endif
- SIZEOF_ITYPE,
- 0,
- 0,
- SCM_I_BIG_MPZ (num));
- /* mpz_export doesn't handle sign */
- if (sgn < 0) result = - result;
- scm_remember_upto_here_1 (num);
- return result;
- }
- }
- }
- else
- scm_wrong_type_arg (s_caller, pos, num);
-}
-
-
-SCM
-INTEGRAL2NUM (ITYPE n)
-{
- /* If we know the size of the type, determine at compile time
- whether we need to perform the FIXABLE test or not. This is not
- done to get more optimal code out of the compiler (it can figure
- this out on its own already), but to avoid a spurious warning.
- If we don't know the size, assume that the test must be done.
- */
-
- /* have to use #if here rather than if because of gcc warnings about
- limited range */
-#if SIZEOF_ITYPE < SIZEOF_SCM_T_BITS
- return SCM_I_MAKINUM ((scm_t_signed_bits) n);
-#else /* not SIZEOF_ITYPE < SIZEOF_SCM_T_BITS */
- if (UNSIGNED)
- {
- if (SCM_POSFIXABLE (n))
- return SCM_I_MAKINUM ((scm_t_signed_bits) n);
- }
- else
- {
- if (SCM_FIXABLE (n))
- return SCM_I_MAKINUM ((scm_t_signed_bits) n);
- }
- return INTEGRAL2BIG (n);
-#endif /* not SIZEOF_ITYPE < SIZEOF_SCM_T_BITS */
-}
-
-SCM
-INTEGRAL2BIG (ITYPE n)
-{
- if (UNSIGNED && (SIZEOF_ITYPE <= SIZEOF_LONG))
- {
- SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
- mpz_init_set_ui (SCM_I_BIG_MPZ (z), n);
- return z;
- }
- else if ((!UNSIGNED) && (SIZEOF_ITYPE <= SIZEOF_UNSIGNED_LONG))
- {
- SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
- mpz_init_set_si (SCM_I_BIG_MPZ (z), n);
- return z;
- }
- else
- {
- int neg_input = 0;
- SCM result = scm_i_mkbig ();
-
- /* mpz_import doesn't handle sign -- have to use #if here rather
- than if b/c gcc warnings for ushort, etc. */
-#if !UNSIGNED
- if (n < 0)
- {
- neg_input = 1;
- n = - n;
- }
-#endif
-
- mpz_import (SCM_I_BIG_MPZ (result),
- 1, /* one word */
- 1, /* word order irrelevant when just one word */
- SIZEOF_ITYPE, /* word size */
- 0, /* native endianness within word */
- 0, /* no nails */
- &n);
-
- /* mpz_import doesn't handle sign */
- if (!UNSIGNED)
- {
- if (neg_input)
- mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
- }
- return result;
- }
-}
-
-/* clean up */
-#undef INTEGRAL2NUM
-#undef INTEGRAL2BIG
-#undef NUM2INTEGRAL
-#undef UNSIGNED
-#undef ITYPE
-#undef SIZEOF_ITYPE
-#undef UNSIGNED_ITYPE
-#undef UNSIGNED_ITYPE_MAX
-#undef BIGMPZ_FITSP
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
HCoop / bpt / guile.git / blobdiff