diff options
Diffstat (limited to 'libguile/num2integral.i.c')
-rw-r--r-- | libguile/num2integral.i.c | 165 |
1 files changed, 165 insertions, 0 deletions
diff --git a/libguile/num2integral.i.c b/libguile/num2integral.i.c new file mode 100644 index 000000000..3e5d65389 --- /dev/null +++ b/libguile/num2integral.i.c @@ -0,0 +1,165 @@ +/* this file is #include'd (many times) by numbers.c */ + +ITYPE +NUM2INTEGRAL (SCM num, unsigned long int pos, const char *s_caller) +{ + if (SCM_INUMP (num)) + { /* immediate */ + + scm_bits_t n = SCM_INUM (num); + +#ifdef UNSIGNED + if (n < 0) + scm_out_of_range (s_caller, num); +#endif + + if (sizeof (ITYPE) >= sizeof (scm_bits_t)) + /* can't fit anything too big for this type in an inum + anyway */ + return (ITYPE) n; + else + { /* an inum can be out of range, so check */ + if (n > (scm_bits_t)MAX_VALUE +#ifndef UNSIGNED + || n < (scm_bits_t)MIN_VALUE +#endif + ) + scm_out_of_range (s_caller, num); + else + return (ITYPE) n; + } + } + else if (SCM_BIGP (num)) + { /* bignum */ + + ITYPE res = 0; + size_t l; + + for (l = SCM_NUMDIGS (num); l--;) + { + ITYPE new = SCM_I_BIGUP (ITYPE, res) + SCM_BDIGITS (num)[l]; + if (new < res +#ifndef UNSIGNED + && !(new == MIN_VALUE && l == 0) +#endif + ) + scm_out_of_range (s_caller, num); + res = new; + } + +#ifndef UNSIGNED + if (SCM_BIGSIGN (num)) + { + res = -res; + if (res <= 0) + return res; + else + scm_out_of_range (s_caller, num); + } + else + { + if (res >= 0) + return res; + else + scm_out_of_range (s_caller, num); + } +#endif + + return res; + } + else if (SCM_REALP (num)) + { /* inexact */ + + double u = SCM_REAL_VALUE (num); + ITYPE res = u; + if ((double) res == u) + return res; + else + scm_out_of_range (s_caller, num); + } + else + scm_wrong_type_arg (s_caller, pos, num); +} + +SCM +INTEGRAL2NUM (ITYPE n) +{ + if (sizeof (ITYPE) < sizeof (scm_bits_t) + || +#ifndef UNSIGNED + SCM_FIXABLE (n) +#else + SCM_POSFIXABLE (n) +#endif + ) + return SCM_MAKINUM (n); + +#ifdef SCM_BIGDIG + return INTEGRAL2BIG (n); +#else + return scm_make_real ((double) n); +#endif +} + +#ifdef SCM_BIGDIG + +SCM +INTEGRAL2BIG (ITYPE n) +{ + SCM res; + int neg_p; + int n_digits; + size_t i; + SCM_BIGDIG *digits; + +#ifndef UNSIGNED + neg_p = (n < 0); + if (neg_p) n = -n; +#else + neg_p = 0; +#endif + +#ifndef UNSIGNED + if (n == MIN_VALUE) + /* special case */ + n_digits = + (sizeof (ITYPE) + sizeof (SCM_BIGDIG) - 1) / sizeof (SCM_BIGDIG); + else +#endif + { + ITYPE tn; + for (tn = n, n_digits = 0; + tn; + ++n_digits, tn = SCM_BIGDN (tn)) + ; + } + + i = 0; + res = scm_i_mkbig (n_digits, neg_p); + digits = SCM_BDIGITS (res); + + while (i < n_digits) + { + digits[i++] = SCM_BIGLO (n); + n = SCM_BIGDN (n); + } + + return res; +} + +#endif + +/* clean up */ +#undef INTEGRAL2NUM +#undef INTEGRAL2BIG +#undef NUM2INTEGRAL +#undef UNSIGNED +#undef ITYPE +#undef MIN_VALUE +#undef MAX_VALUE + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ |