#include "libguile/root.h"
#include "libguile/smob.h"
#include "libguile/strings.h"
-#include "libguile/vectors.h"
#include "libguile/validate.h"
#include "libguile/numbers.h"
#if (SCM_DEBUG_DEPRECATED == 1) /* not defined in header yet? */
-/* SCM_FIXABLE is non-0 if its long argument can be encoded in an SCM_INUM.
- */
-#define SCM_POSFIXABLE(n) ((n) <= SCM_MOST_POSITIVE_FIXNUM)
-#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
-#define SCM_UNEGFIXABLE(n) ((n) <= -SCM_MOST_NEGATIVE_FIXNUM)
-#define SCM_FIXABLE(n) (SCM_POSFIXABLE(n) && SCM_NEGFIXABLE(n))
-
/* SCM_FLOBUFLEN is the maximum number of characters neccessary for the
* printed or scm_string representation of an inexact number.
*/
#define SCM_FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
-#endif
+
+#endif /* SCM_DEBUG_DEPRECATED == 1 */
/* IS_INF tests its floating point number for infiniteness
\f
+static SCM abs_most_negative_fixnum;
+
+\f
+
SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0,
(SCM x),
}
}
} else if (SCM_BIGP (y)) {
- return SCM_INUM0;
+ if (SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM
+ && scm_bigcomp (abs_most_negative_fixnum, y) == 0)
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ return SCM_MAKINUM (-1);
+ }
+ else
+ return SCM_MAKINUM (0);
} else {
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
}
if (yy == 0) {
scm_num_overflow (s_remainder);
} else {
-#if (__TURBOC__ == 1)
- long z = SCM_INUM (x) % (yy < 0 ? -yy : yy);
-#else
long z = SCM_INUM (x) % yy;
-#endif
return SCM_MAKINUM (z);
}
} else if (SCM_BIGP (y)) {
- return x;
+ if (SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM
+ && scm_bigcomp (abs_most_negative_fixnum, y) == 0)
+ {
+ /* Special case: x == fixnum-min && y == abs (fixnum-min) */
+ return SCM_MAKINUM (0);
+ }
+ else
+ return x;
} else {
SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
}
if (yy == 0) {
scm_num_overflow (s_modulo);
} else {
-#if (__TURBOC__ == 1)
- long z = ((yy < 0) ? -xx : xx) % yy;
-#else
long z = xx % yy;
-#endif
return SCM_MAKINUM (((yy < 0) ? (z > 0) : (z < 0)) ? z + yy : z);
}
} else if (SCM_BIGP (y)) {
if (!num) return scm_normbig(z);
}
}
- else if (xsgn) do {
- num += x[i];
- if (num < 0) {zds[i] &= num + SCM_BIGRAD; num = -1;}
- else {zds[i] &= ~SCM_BIGLO(num); num = 0;}
- } while (++i < nx);
- else do zds[i] = zds[i] & x[i]; while (++i < nx);
+ else if (xsgn) {
+ unsigned long int carry = 1;
+ do {
+ unsigned long int mask = (SCM_BIGDIG) ~x[i] + carry;
+ zds[i] = zds[i] & (SCM_BIGDIG) mask;
+ carry = (mask >= SCM_BIGRAD) ? 1 : 0;
+ } while (++i < nx);
+ } else do zds[i] = zds[i] & x[i]; while (++i < nx);
return scm_normbig(z);
}
"Example:\n"
"@lisp\n"
"(number->string (logand #b1100 #b1010) 2)\n"
- " @result{} \"1000\"")
+ " @result{} \"1000\"\n"
+ "@end lisp")
#define FUNC_NAME s_scm_logand
{
long int nn1;
(SCM n, SCM cnt),
"The function ash performs an arithmetic shift left by CNT bits\n"
"(or shift right, if CNT is negative). 'Arithmetic' means, that\n"
- "the function does not guarantee to keep the bit structure of N,\n"
- "but rather guarantees that the result will always be rounded\n"
+ "the function does not guarantee to keep the bit structure of N,\n"
+ "but rather guarantees that the result will always be rounded\n"
"towards minus infinity. Therefore, the results of ash and a\n"
"corresponding bitwise shift will differ if N is negative.\n\n"
"Formally, the function returns an integer equivalent to\n"
"Example:\n"
"@lisp\n"
"(number->string (ash #b1 3) 2)\n"
- " @result{} \"1000\""
- "(number->string (ash #b1010 -1) 2)"
- " @result{} \"101\""
+ " @result{} \"1000\"\n"
+ "(number->string (ash #b1010 -1) 2)\n"
+ " @result{} \"101\"\n"
"@end lisp")
#define FUNC_NAME s_scm_ash
{
"@end lisp")
#define FUNC_NAME s_scm_bit_extract
{
- int istart, iend;
+ unsigned long int istart, iend;
SCM_VALIDATE_INUM_MIN_COPY (2,start,0,istart);
SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
SCM_ASSERT_RANGE (3, end, (iend >= istart));
if (SCM_INUMP (n)) {
- return SCM_MAKINUM ((SCM_INUM (n) >> istart) & ((1L << (iend - istart)) - 1));
+ long int in = SCM_INUM (n);
+ unsigned long int bits = iend - istart;
+
+ if (in < 0 && bits >= SCM_FIXNUM_BIT)
+ {
+ /* Since we emulate two's complement encoded numbers, this special
+ * case requires us to produce a result that has more bits than can be
+ * stored in a fixnum. Thus, we fall back to the more general
+ * algorithm that is used for bignums.
+ */
+ goto generalcase;
+ }
+
+ if (istart < SCM_FIXNUM_BIT)
+ {
+ in = in >> istart;
+ if (bits < SCM_FIXNUM_BIT)
+ return SCM_MAKINUM (in & ((1L << bits) - 1));
+ else /* we know: in >= 0 */
+ return SCM_MAKINUM (in);
+ }
+ else if (in < 0)
+ {
+ return SCM_MAKINUM (-1L & ((1L << bits) - 1));
+ }
+ else
+ {
+ return SCM_MAKINUM (0);
+ }
} else if (SCM_BIGP (n)) {
- SCM num1 = SCM_MAKINUM (1L);
- SCM num2 = SCM_MAKINUM (2L);
- SCM bits = SCM_MAKINUM (iend - istart);
- SCM mask = scm_difference (scm_integer_expt (num2, bits), num1);
- return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));
+ generalcase:
+ {
+ SCM num1 = SCM_MAKINUM (1L);
+ SCM num2 = SCM_MAKINUM (2L);
+ SCM bits = SCM_MAKINUM (iend - istart);
+ SCM mask = scm_difference (scm_integer_expt (num2, bits), num1);
+ return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));
+ }
} else {
SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
}
/* Cast to long int to avoid signed/unsigned comparison warnings. */
if ((( ((long int) nlen) << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD)
!= (long int) nlen)
- scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum);
+ scm_memory_error (s_bignum);
SCM_NEWCELL (v);
SCM_DEFER_INTS;
- SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)),
- s_bignum));
+ SCM_SET_BIGNUM_BASE (v, scm_must_malloc (nlen * sizeof (SCM_BIGDIG), s_bignum));
SCM_SETNUMDIGS (v, nlen, sign);
SCM_ALLOW_INTS;
return v;
if (SCM_POSFIXABLE (num))
return SCM_MAKINUM (num);
}
- else if (SCM_UNEGFIXABLE (num))
+ else if (num <= -SCM_MOST_NEGATIVE_FIXNUM)
return SCM_MAKINUM (-num);
return b;
}
{
scm_sizet nsiz = nlen;
if (((nsiz << SCM_BIGSIZEFIELD) >> SCM_BIGSIZEFIELD) != nlen)
- scm_wta (scm_ulong2num (nsiz), (char *) SCM_NALLOC, s_adjbig);
+ scm_memory_error (s_adjbig);
SCM_DEFER_INTS;
{
SCM_BIGDIG *digits
= ((SCM_BIGDIG *)
- scm_must_realloc ((char *) SCM_CHARS (b),
+ scm_must_realloc ((char *) SCM_BDIGITS (b),
(long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)),
(long) (nsiz * sizeof (SCM_BIGDIG)), s_bignum));
- SCM_SETCHARS (b, digits);
+ SCM_SET_BIGNUM_BASE (b, digits);
SCM_SETNUMDIGS (b, nsiz, SCM_BIGSIGN (b));
}
SCM_ALLOW_INTS;
}
return ans;
}
-#endif
+#endif /* HAVE_LONG_LONGS */
SCM
: (SCM_BITSPERDIG * i) + 2;
scm_sizet k = 0;
scm_sizet radct = 0;
- scm_sizet ch; /* jeh */
SCM_BIGDIG radpow = 1, radmod = 0;
SCM ss = scm_makstr ((long) j, 0);
- char *s = SCM_CHARS (ss), c;
+ char *s = SCM_STRING_CHARS (ss), c;
while ((long) radpow * radix < SCM_BIGRAD)
{
radpow *= radix;
radct++;
}
- s[0] = SCM_BIGSIGN (b) ? '-' : '+';
while ((i || radmod) && j)
{
if (k == 0)
k--;
s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
}
- ch = s[0] == '-' ? 1 : 0; /* jeh */
- if (ch < j)
- { /* jeh */
- for (i = j; j < SCM_LENGTH (ss); j++)
- s[ch + j - i] = s[j]; /* jeh */
- scm_vector_set_length_x (ss, /* jeh */
- SCM_MAKINUM (ch + SCM_LENGTH (ss) - i));
+
+ if (SCM_BIGSIGN (b))
+ s[--j] = '-';
+
+ if (j > 0)
+ {
+ /* The pre-reserved string length was too large. */
+ unsigned long int length = SCM_STRING_LENGTH (ss);
+ ss = scm_substring (ss, SCM_MAKINUM (j), SCM_MAKINUM (length));
}
return scm_return_first (ss, t);
{
#ifdef SCM_BIGDIG
exp = big2str (exp, (unsigned int) 10);
- scm_lfwrite (SCM_CHARS (exp), (scm_sizet) SCM_LENGTH (exp), port);
+ scm_lfwrite (SCM_STRING_CHARS (exp), (scm_sizet) SCM_STRING_LENGTH (exp), port);
#else
scm_ipruk ("bignum", exp, port);
#endif
case DIGITS:
expon = expon * 10 + c - '0';
if (expon > SCM_MAXEXP)
- return SCM_BOOL_F; /* exponent too large */
+ scm_out_of_range ("string->number", SCM_MAKINUM (expon));
break;
default:
goto out4;
{
SCM answer;
int base;
- SCM_VALIDATE_ROSTRING (1,string);
+ SCM_VALIDATE_STRING (1, string);
SCM_VALIDATE_INUM_MIN_DEF_COPY (2,radix,2,10,base);
- answer = scm_istring2number (SCM_ROCHARS (string),
- SCM_ROLENGTH (string),
+ answer = scm_istring2number (SCM_STRING_CHARS (string),
+ SCM_STRING_LENGTH (string),
base);
return scm_return_first (answer, string);
}
}
-SCM_DEFINE1 (scm_gr_p, ">", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return #t if the list of parameters is monotonically\n"
- "increasing.")
+SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
+/* "Return #t if the list of parameters is monotonically\n"
+ * "increasing."
+ */
#define FUNC_NAME s_scm_gr_p
+SCM
+scm_gr_p (SCM x, SCM y)
{
- return scm_less_p (y, x);
+ if (!SCM_NUMBERP (x))
+ SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
+ else if (!SCM_NUMBERP (y))
+ SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
+ else
+ return scm_less_p (y, x);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_leq_p, "<=", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return #t if the list of parameters is monotonically\n"
- "non-decreasing.")
+SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
+/* "Return #t if the list of parameters is monotonically\n"
+ * "non-decreasing."
+ */
#define FUNC_NAME s_scm_leq_p
+SCM
+scm_leq_p (SCM x, SCM y)
{
- return SCM_BOOL_NOT (scm_less_p (y, x));
+ if (!SCM_NUMBERP (x))
+ SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
+ else if (!SCM_NUMBERP (y))
+ SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
+ else
+ return SCM_BOOL_NOT (scm_less_p (y, x));
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_geq_p, ">=", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return #t if the list of parameters is monotonically\n"
- "non-increasing.")
+SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
+/* "Return #t if the list of parameters is monotonically\n"
+ * "non-increasing."
+ */
#define FUNC_NAME s_scm_geq_p
+SCM
+scm_geq_p (SCM x, SCM y)
{
+ if (!SCM_NUMBERP (x))
+ SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
+ else if (!SCM_NUMBERP (y))
+ SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
+ else
return SCM_BOOL_NOT (scm_less_p (x, y));
}
#undef FUNC_NAME
}
}
-#endif
+#endif /* HAVE_LONG_LONGS */
SCM
}
}
-#endif
+#endif /* HAVE_LONG_LONGS */
unsigned long
void
scm_init_numbers ()
{
+ abs_most_negative_fixnum = scm_long2big (- SCM_MOST_NEGATIVE_FIXNUM);
+ scm_permanent_object (abs_most_negative_fixnum);
+
+ /* It may be possible to tune the performance of some algorithms by using
+ * the following constants to avoid the creation of bignums. Please, before
+ * using these values, remember the two rules of program optimization:
+ * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
+ scm_sysintern ("most-positive-fixnum", SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
+ scm_sysintern ("most-negative-fixnum", SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
+
scm_add_feature ("complex");
scm_add_feature ("inexact");
scm_flo0 = scm_make_real (0.0);
scm_dblprec = scm_dblprec - 1;
}
#endif /* DBL_DIG */
+#ifndef SCM_MAGIC_SNARFER
#include "libguile/numbers.x"
+#endif
}
/*
HCoop / bpt / guile.git / blobdiff