Back to index

plt-scheme  4.2.1
Defines | Functions | Variables
numstr.c File Reference
#include "schpriv.h"
#include <math.h>
#include <string.h>
#include <ctype.h>
#include "newrandom.inc"

Go to the source code of this file.

Defines

#define MZ_IS_BIG_ENDIAN   0
#define TO_DOUBLE   scheme_TO_DOUBLE
#define zeroi   scheme_exact_zero
#define SCH_SIN   sin
#define SCH_COS   cos
#define MAX_FLOATREAD_PRECISION_DIGITS   50
#define MAX_FAST_FLOATREAD_LEN   50
#define CHECK_INF_EXP_THRESHOLD   400
#define STRTOD(x, y)   strtod(x, y)
#define CHECK_SINGLE(v, s)   v
#define isinexactmark(ch)
#define isAdigit(ch)   ((ch >= '0') && (ch <= '9'))
#define isbaseNdigit(N, ch)
#define MZ_U8HI   0
#define MZ_S8HI   1
#define MZ_S8LO   2

Functions

static Scheme_Objectnumber_to_string (int argc, Scheme_Object *argv[])
static Scheme_Objectstring_to_number (int argc, Scheme_Object *argv[])
static Scheme_Objectbytes_to_integer (int argc, Scheme_Object *argv[])
static Scheme_Objectinteger_to_bytes (int argc, Scheme_Object *argv[])
static Scheme_Objectbytes_to_real (int argc, Scheme_Object *argv[])
static Scheme_Objectreal_to_bytes (int argc, Scheme_Object *argv[])
static Scheme_Objectsystem_big_endian_p (int argc, Scheme_Object *argv[])
static Scheme_Objectrandom_seed (int argc, Scheme_Object *argv[])
static Scheme_Objectsch_random (int argc, Scheme_Object *argv[])
static Scheme_Objectmake_pseudo_random_generator (int argc, Scheme_Object **argv)
static Scheme_Objectcurrent_pseudo_random_generator (int argc, Scheme_Object **argv)
static Scheme_Objectcurrent_sched_pseudo_random_generator (int argc, Scheme_Object **argv)
static Scheme_Objectpseudo_random_generator_p (int argc, Scheme_Object **argv)
static Scheme_Objectsch_unpack (int argc, Scheme_Object *argv[])
static Scheme_Objectsch_pack (int argc, Scheme_Object *argv[])
static Scheme_Objectsch_pack_bang (int argc, Scheme_Object *argv[])
static char * number_to_allocated_string (int radix, Scheme_Object *obj, int alloc)
void scheme_init_numstr (Scheme_Env *env)
static int u_strcmp (mzchar *s, char *t)
static Scheme_Objectread_special_number (const mzchar *str, int pos)
Scheme_Objectscheme_read_number (const mzchar *str, long len, int is_float, int is_not_float, int decimal_means_float, int radix, int radix_set, Scheme_Object *complain, int *div_by_zero, int test_only, Scheme_Object *stxsrc, long line, long col, long pos, long span, Scheme_Object *indentation)
static char * double_to_string (double d, int alloc)
char * scheme_number_to_string (int radix, Scheme_Object *obj)
int scheme_check_double (const char *where, double d, const char *dest)
long scheme_rand (Scheme_Random_State *rs)
static Scheme_Objectdo_pack (const char *name, int argc, Scheme_Object *argv[], int set)
static Scheme_Objectcurrent_pseudo_random_generator (int argc, Scheme_Object *argv[])
static Scheme_Objectcurrent_sched_pseudo_random_generator (int argc, Scheme_Object *argv[])

Variables

static char * infinity_str = "+inf.0"
static char * minus_infinity_str = "-inf.0"
static char * not_a_number_str = "+nan.0"
static char * other_not_a_number_str = "-nan.0"
static Scheme_Objectnum_limits [3]
static char ffl_buf [MAX_FAST_FLOATREAD_LEN+1]

Define Documentation

#define CHECK_INF_EXP_THRESHOLD   400

Definition at line 240 of file numstr.c.

#define CHECK_SINGLE (   v,
 
)    v

Definition at line 352 of file numstr.c.

#define isAdigit (   ch)    ((ch >= '0') && (ch <= '9'))
#define isbaseNdigit (   N,
  ch 
)
Value:
(((ch >= 'a') && (ch <= (mzchar)('a' + N - 11))) \
                             || ((ch >= 'A') && (ch <= (mzchar)('A' + N - 11))))
#define isinexactmark (   ch)
Value:
((ch == 'e') || (ch == 'E') \
                        || (ch == 's') || (ch == 'S') \
                        || (ch == 'f') || (ch == 'F') \
                        || (ch == 'd') || (ch == 'D') \
                        || (ch == 'l') || (ch == 'L'))
#define MAX_FAST_FLOATREAD_LEN   50

Definition at line 234 of file numstr.c.

Definition at line 230 of file numstr.c.

#define MZ_IS_BIG_ENDIAN   0

Definition at line 69 of file numstr.c.

#define MZ_S8HI   1

Definition at line 1740 of file numstr.c.

#define MZ_S8LO   2

Definition at line 1741 of file numstr.c.

#define MZ_U8HI   0

Definition at line 1739 of file numstr.c.

#define SCH_COS   cos

Definition at line 172 of file numstr.c.

#define SCH_SIN   sin

Definition at line 171 of file numstr.c.

#define STRTOD (   x,
  y 
)    strtod(x, y)

Definition at line 340 of file numstr.c.

Definition at line 72 of file numstr.c.

#define zeroi   scheme_exact_zero

Definition at line 74 of file numstr.c.


Function Documentation

static Scheme_Object * bytes_to_integer ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1621 of file numstr.c.

{
  long strlen, slen;
  int sgned;
  char *str;
  int buf[2], i;
  int bigend = MZ_IS_BIG_ENDIAN, offset = 0;

  if (!SCHEME_BYTE_STRINGP(argv[0]))
    scheme_wrong_type("integer-bytes->integer", "byte string", 0, argc, argv);
  strlen = SCHEME_BYTE_STRLEN_VAL(argv[0]);

  str = SCHEME_BYTE_STR_VAL(argv[0]);

  sgned = SCHEME_TRUEP(argv[1]);
  if (argc > 2)
    bigend = SCHEME_TRUEP(argv[2]);

  if (argc > 3) {
    long start, finish;

    scheme_get_substring_indices("integer-bytes->integer", argv[0],
                                 argc, argv,
                                 3, 4, &start, &finish);

    offset = start;
    slen = finish - start;
  } else {
    offset = 0;
    slen = strlen;
  }

  if ((slen != 2)  && (slen != 4) && (slen != 8)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "integer-bytes->integer: length is not 2, 4, or 8 bytes: %ld",
                     slen);
    return NULL;
  }

  if (offset + slen > strlen) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     
                     slen);
    return NULL;
  }

  if (bigend != MZ_IS_BIG_ENDIAN) {
    for (i = 0; i < slen; i++) {
      ((char *)buf)[slen - i - 1] = str[i + offset];
    }
    str = (char *)buf;
  } else {
    memcpy(&buf, str + offset, slen);
    str = (char *)buf;
  }

  switch(slen) {
  case 2:
    if (sgned)
      return scheme_make_integer(((short *)str)[0]);
    else
      return scheme_make_integer(((unsigned short *)str)[0]);
    break;
  case 4:
    if (sgned)
      return scheme_make_integer_value(((int *)str)[0]);
    else
      return scheme_make_integer_value_from_unsigned(((unsigned int *)str)[0]);
    break;
  default:
#ifdef SIXTY_FOUR_BIT_INTEGERS
    if (sgned)
      return scheme_make_integer_value(((long *)str)[0]);
    else
      return scheme_make_integer_value_from_unsigned(((unsigned long *)str)[0]);
    break;
#else
# ifndef NO_LONG_LONG_TYPE
    {
      mzlonglong lv;
      memcpy(&lv, str, sizeof(mzlonglong));
      if (sgned)
       return scheme_make_integer_value_from_long_long(lv);
      else
       return scheme_make_integer_value_from_unsigned_long_long((umzlonglong)lv);
      break;
    }
# else
    {
      Scheme_Object *h, *l, *a[2];

#  if MZ_IS_BIG_ENDIAN
      /* make little-endian at int level: */
      {
       int v;
       v = ((int *)str)[0];
       buf[0] = ((int *)str)[1];
       buf[1] = v;
       str = (char *)buf;
      }
#  endif

      if (sgned)
       h = scheme_make_integer_value(((int *)str)[1]);
      else
       h = scheme_make_integer_value_from_unsigned(((unsigned int *)str)[1]);
      l = scheme_make_integer_value_from_unsigned(((unsigned int *)str)[0]);
      a[0] = h;
      a[1] = scheme_make_integer(32);
      h = scheme_bitwise_shift(2, a);
      return scheme_bin_plus(h, l);
    }
# endif
#endif
    break;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * bytes_to_real ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1950 of file numstr.c.

{
  long offset = 0, slen;
  char *str, buf[8];
  int bigend = MZ_IS_BIG_ENDIAN;

  if (!SCHEME_BYTE_STRINGP(argv[0]))
    scheme_wrong_type("integer-bytes->integer", "byte string", 0, argc, argv);

  if (argc > 2) {
    long start, finish;

    scheme_get_substring_indices("integer-bytes->integer", argv[0],
                                 argc, argv,
                                 2, 3, &start, &finish);

    offset = start;
    slen = finish - start;
  } else {
    offset = 0;
    slen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
  }

  if ((slen != 4) && (slen != 8))
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "floating-point-bytes->real: length is not 2, 4, or 8 bytes: %ld",
                     slen);

  str = SCHEME_BYTE_STR_VAL(argv[0]);

  if (argc > 1)
    bigend = SCHEME_TRUEP(argv[1]);

  if (bigend != MZ_IS_BIG_ENDIAN) {
    int i;
    for (i = 0; i < slen; i++) {
      buf[slen - i - 1] = str[offset + i];
    }
  } else {
    memcpy(buf, str + offset, slen);
  }
  str = buf;

  switch(slen) {
  case 4:
    {
      float f;
      memcpy(&f, buf, sizeof(float));
#ifdef MZ_USE_SINGLE_FLOATS
      return scheme_make_float(f);
#else
      return scheme_make_double(f);
#endif
    }
    break;
  default:
    {
      double d;
      memcpy(&d, str, sizeof(double));
      return scheme_make_double(d);
    }
    break;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* current_pseudo_random_generator ( int  argc,
Scheme_Object **  argv 
) [static]

Here is the caller graph for this function:

static Scheme_Object* current_pseudo_random_generator ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2249 of file numstr.c.

{
  return scheme_param_config("current-pseudo-random-generator", 
                          scheme_make_integer(MZCONFIG_RANDOM_STATE),
                          argc, argv,
                          -1, pseudo_random_generator_p, "pseudo-random-generator", 0);
}

Here is the call graph for this function:

static Scheme_Object* current_sched_pseudo_random_generator ( int  argc,
Scheme_Object **  argv 
) [static]

Here is the caller graph for this function:

static Scheme_Object* current_sched_pseudo_random_generator ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2257 of file numstr.c.

{
  return scheme_param_config("current-evt-pseudo-random-generator", 
                          scheme_make_integer(MZCONFIG_SCHEDULER_RANDOM_STATE),
                          argc, argv,
                          -1, pseudo_random_generator_p, "pseudo-random-generator", 0);
}

Here is the call graph for this function:

static Scheme_Object* do_pack ( const char *  name,
int  argc,
Scheme_Object argv[],
int  set 
) [static]

Definition at line 2189 of file numstr.c.

{
  Scheme_Object *s;
  GC_CAN_IGNORE Scheme_Random_State rs;

  if (set) {
    s = argv[0];
    if (!SAME_TYPE(SCHEME_TYPE(s), scheme_random_state_type)) {
      scheme_wrong_type(name, "pseudo-random-generator", 0, argc, argv);
    }
  }

  if (SCHEME_VECTORP(argv[set]))
    s = pack_rand_state(argv[set], (set ? &rs : NULL));
  else
    s = NULL;

  if (!s)
    scheme_wrong_type(name,
                    "vector of six elements, three in [0, 4294967086] and three in [0, 4294944442], "
                    "at least one non-zero in each set of three",
                    set, argc, argv);

  if (set) {
    s = argv[0];
    ((Scheme_Random_State *)s)->x10 = rs.x10;
    ((Scheme_Random_State *)s)->x11 = rs.x11;
    ((Scheme_Random_State *)s)->x12 = rs.x12;
    ((Scheme_Random_State *)s)->x20 = rs.x20;
    ((Scheme_Random_State *)s)->x21 = rs.x21;
    ((Scheme_Random_State *)s)->x22 = rs.x22;

    return scheme_void;
  } else {
    return s;
  }
}

Here is the caller graph for this function:

static char* double_to_string ( double  d,
int  alloc 
) [static]

Definition at line 1472 of file numstr.c.

{
  char buffer[100], *s;
  int l, i, digits;

  if (MZ_IS_NAN(d))
    s = not_a_number_str;
  else if (MZ_IS_POS_INFINITY(d))
    s = infinity_str;
  else if (MZ_IS_NEG_INFINITY(d))
    s = minus_infinity_str;
  else if (d == 0.0) {
    /* Check for -0.0, since some printers get it wrong. */
    if (scheme_minus_zero_p(d))
      s = "-0.0";
    else
      s = "0.0";
  } else {
    /* Initial count for significant digits is 14. That's big enough to
       get most right, small enough to avoid nonsense digits. But we'll
        loop in case it's not precise enough to get read-write invariance: */
    digits = 14;
    while (digits < 30) {
      double check;
      GC_CAN_IGNORE char *ptr;

      sprintf(buffer, "%.*g", digits, d);

      /* Did we get read-write invariance, yet? */
      check = strtod(buffer, &ptr);
      if (check == d)
       break;

      digits++;
    }
    
    l = strlen(buffer);
    for (i = 0; i < l; i++) {
      if (buffer[i] == '.' || isalpha((unsigned char)buffer[i]))
       break;
    }
    if (i == l) {
      buffer[i] = '.';
      buffer[i + 1] = '0';
      buffer[i + 2] = 0;
      l += 2;
    }
    
    s = (char *)scheme_malloc_atomic(strlen(buffer) + 1);
    strcpy(s, buffer);
    alloc = 0;
  }

  if (alloc) {
    char *s2;
    l = strlen(s) + 1;
    s2 = (char *)scheme_malloc_atomic(l);
    memcpy(s2, s, l);
    s = s2;
  }

  return s;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * integer_to_bytes ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1743 of file numstr.c.

{
  Scheme_Object *n, *s;
  char *str;
  int size, sgned;
  long val, offset, buf[2];
#if !defined(NO_LONG_LONG_TYPE) && !defined(SIXTY_FOUR_BIT_INTEGERS)
  mzlonglong llval;
#endif
  int bigend = MZ_IS_BIG_ENDIAN, bad;

  n = argv[0];
  if (!SCHEME_INTP(n) && !SCHEME_BIGNUMP(n))
    scheme_wrong_type("integer->integer-bytes", "exact integer", 0, argc, argv);

  if (SCHEME_INTP(argv[1]))
    size = SCHEME_INT_VAL(argv[1]);
  else
    size = 0;
  if ((size != 2) && (size != 4) &&(size != 8))
    scheme_wrong_type("integer->integer-bytes", "exact 2, 4, or 8", 1, argc, argv);

  sgned = SCHEME_TRUEP(argv[2]);
  if (argc > 3)
    bigend = SCHEME_TRUEP(argv[3]);
  
  if (argc > 4)
    s = argv[4];
  else
    s = scheme_make_sized_byte_string("12345678", size, 1);
  
  if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
    scheme_wrong_type("integer->integer-bytes", "mutable byte string", 4, argc, argv);

  if (argc > 5) {
    long start, finish;
    
    scheme_get_substring_indices("integer-bytes->integer", s,
                                 argc, argv,
                                 5, 6, &start, &finish);

    offset = start;
  } else
    offset = 0;
  
  if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "integer-bytes->integer: byte string is %ld bytes,"
                     " which is shorter than starting position %ld plus size %ld",
                     SCHEME_BYTE_STRLEN_VAL(s), offset, size);
    return NULL;
  }

  /* Check for mismatch: number doesn't fit */
  if (size == 2) {
    if (SCHEME_BIGNUMP(n))
      bad = 1;
    else {
      val = SCHEME_INT_VAL(n);
      if (sgned) {
       bad = ((val < -32768) || (val > 32767));
      } else {
       bad = ((val < 0) || (val > 65535));
      }
    }
  } else if (size ==4) {
    if (sgned)
      bad = !scheme_get_int_val(n, &val);
    else
      bad = !scheme_get_unsigned_int_val(n, (unsigned long *)&val);
#ifdef SIXTY_FOUR_BIT_INTEGERS
    if (!bad) {
      if (sgned)
       bad = ((val > (long)0x7fffffff) || (val < -(long)0x80000000));
      else
       bad = (val > (long)0xffffffff);
    }
#endif
  } else  {
#ifdef SIXTY_FOUR_BIT_INTEGERS
    if (sgned)
      bad = !scheme_get_int_val(n, &val);
    else
      bad = !scheme_get_unsigned_int_val(n, (unsigned long *)&val);
#else
# ifndef NO_LONG_LONG_TYPE
    if (sgned)
      bad = !scheme_get_long_long_val(n, &llval);
    else
      bad = !scheme_get_unsigned_long_long_val(n, (umzlonglong *)&llval);
# else
    if (!num_limits[MZ_U8HI]) {
      Scheme_Object *a[2], *v;

      a[0] = scheme_make_integer(1);
      a[1] = scheme_make_integer(64);
      a[0] = scheme_bitwise_shift(2, a);
      v = scheme_sub1(1, a);
      num_limits[MZ_U8HI] = v;
      a[0] = v;
      a[1] = scheme_make_integer(-1);
      v = scheme_bitwise_shift(2, a);
      num_limits[MZ_S8HI] = v;
      a[0] = v;
      v = scheme_bin_minus(scheme_make_integer(0), scheme_add1(1, a));
      num_limits[MZ_S8LO] = v;
    }

    if (sgned)
      bad = (scheme_bin_lt(n, num_limits[MZ_S8LO])
            || scheme_bin_lt(num_limits[MZ_S8HI], n));
    else
      bad = (!scheme_nonneg_exact_p(n)
            || scheme_bin_lt(num_limits[MZ_U8HI], n));

    val = 0;
# endif
#endif
  }

  if (bad) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                   "integer->integer-bytes: integer does not fit into %d %ssigned bytes: %V",
                   size, (sgned ? "" : "un"), n);
    return NULL;
  }

  /* Finally, do the work */
  str = (char *)buf;
  switch (size) {
  case 2:
    {
      if (sgned) {
       *(unsigned short *)str = (unsigned short)(val);
      } else {
       *(short *)str = (short)(val);
      }
    }
    break;
  case 4:
    if (sgned) {
      unsigned int sv = val;
      *(unsigned int *)str = sv;
    } else {
      int sv = val;
      *(int *)str = sv;
    }
    break;
  default:
#ifdef SIXTY_FOUR_BIT_INTEGERS
    *(long *)str = val;
#else
# ifndef NO_LONG_LONG_TYPE
    memcpy(str, &llval, sizeof(mzlonglong));
# else
    {
      Scheme_Object *hi, *lo, *a[2];
      unsigned long ul;
      
      a[0] = n;
      a[1] = scheme_make_integer_value_from_unsigned((unsigned long)-1);
      lo = scheme_bitwise_and(2, a);
      a[1] = scheme_make_integer(-32);
      hi = scheme_bitwise_shift(2, a);

      scheme_get_unsigned_int_val(lo, &ul);
      
      ((unsigned int *)str)[0] = ul;
      if (sgned) {
       scheme_get_int_val(hi, &val);
       ((unsigned int *)str)[1] = val;
      } else {
       scheme_get_unsigned_int_val(hi, &ul);
       ((unsigned int *)str)[1] = ul;
      }

#if MZ_IS_BIG_ENDIAN
      {
       /* We've assumed little endian so far */
       val = ((int *)str)[0];
       ((int *)str)[0] = ((int *)str)[1];
       ((int *)str)[1] = val;
      }
#endif

    }
# endif
#endif
    break;
  }

  str = SCHEME_BYTE_STR_VAL(s);
  if (bigend != MZ_IS_BIG_ENDIAN) {
    int i;
    for (i = 0; i < size; i++) {
      str[i + offset] = ((char *)buf)[size - i - 1];
    }
  } else {
    int i;
    for (i = 0; i < size; i++) {
      str[i + offset] = ((char *)buf)[i];
    }
  }

  return s;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * make_pseudo_random_generator ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 2265 of file numstr.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static char * number_to_allocated_string ( int  radix,
Scheme_Object obj,
int  alloc 
) [static]

Definition at line 1536 of file numstr.c.

{
  char *s;

  if (SCHEME_FLOATP(obj)) {
    if (radix != 10)
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "number->string: "
                     "inexact numbers can only be printed in base 10");
    s = double_to_string(SCHEME_FLOAT_VAL(obj), alloc);
  } else if (SCHEME_RATIONALP(obj)) {
    Scheme_Object *n, *d;
    char *ns, *ds;
    int nlen, dlen;

    n = scheme_rational_numerator(obj);
    d = scheme_rational_denominator(obj);

    ns = number_to_allocated_string(radix, n, 0);
    ds = number_to_allocated_string(radix, d, 0);

    nlen = strlen(ns);
    dlen = strlen(ds);

    s = (char *)scheme_malloc_atomic(nlen + dlen + 2);
    memcpy(s, ns, nlen);
    s[nlen] = '/';
    strcpy(s + nlen + 1, ds);
  } else if (SCHEME_COMPLEXP(obj)) {
    Scheme_Object *r, *i;
    char *rs, *is;
    int rlen, ilen, offset = 0;

    r = _scheme_complex_real_part(obj);
    i = _scheme_complex_imaginary_part(obj);

    rs = number_to_allocated_string(radix, r, 0);
    is = number_to_allocated_string(radix, i, 0);

    rlen = strlen(rs);
    ilen = strlen(is);
    s = (char *)scheme_malloc_atomic(rlen + ilen + 3);
    memcpy(s, rs, rlen);
    if ((is[0] != '-') && (is[0] != '+')) {
      offset = 1;
      s[rlen] = '+';
    }
    memcpy(s + rlen + offset, is, ilen);
    s[rlen + offset + ilen] = 'i';
    s[rlen + offset + ilen + 1] = 0;
  } else {
    if (SCHEME_INTP(obj))
      obj = scheme_make_bignum(SCHEME_INT_VAL(obj));

    s = scheme_bignum_to_allocated_string(obj, radix, alloc);
  }

  return s;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * number_to_string ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1376 of file numstr.c.

{
  Scheme_Object *o = argv[0];
  long radix;

  if (!SCHEME_NUMBERP(o))
    scheme_wrong_type("number->string", "number", 0, argc, argv);
  
  if (argc == 2) {
    if (!SCHEME_INTP(argv[1]))
      radix = 0;
    else
      radix = SCHEME_INT_VAL(argv[1]);

    if ((radix != 2) && (radix != 8) && (radix != 10)  && (radix != 16)) {
      scheme_wrong_type("number->string", "2, 8, 10, or 16", 1, argc, argv);
      ESCAPED_BEFORE_HERE;
    }
    
    radix = SCHEME_INT_VAL(argv[1]);
  } else
    radix = 10;

  if (SCHEME_INTP(o) && ((radix == 10) || (radix == 16))) {
    /* Fast path for common case. */
    mzchar num[32];
    int pos = 32;
    long v = SCHEME_INT_VAL(o);
    if (v) {
      int neg, digit;
      if (v < 0) {
       neg = 1;
       v = -v;
      } else
       neg = 0;
      while (v) {
       digit = (v % radix);
       if (digit < 10)
         num[--pos] = digit + '0';
       else
         num[--pos] = (digit - 10) + 'a';
       v = v / radix;
      }
      if (neg)
       num[--pos] = '-';
    } else {
      num[--pos] = '0';
    }
    return scheme_make_sized_offset_char_string(num, pos, 32 - pos, 1);
  }

  return scheme_make_utf8_string/*_without_copying*/(number_to_allocated_string(radix, o, 1));
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * pseudo_random_generator_p ( int  argc,
Scheme_Object **  argv 
) [static]

Definition at line 2270 of file numstr.c.

Here is the caller graph for this function:

static Scheme_Object * random_seed ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2115 of file numstr.c.

{
  long i = -1;
  Scheme_Object *o = argv[0], *rand_state;

  if (scheme_get_int_val(o,  &i)) {
    if (i > 2147483647)
      i = -1;
  }

  if (i < 0)
    scheme_wrong_type("random-seed", "exact integer in [0, 2147483647]", 0, argc, argv);

  rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
  sch_srand(i, (Scheme_Random_State *)rand_state);

  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object* read_special_number ( const mzchar str,
int  pos 
) [static]

Definition at line 190 of file numstr.c.

{
  if ((str[pos] == '-' || str[pos] == '+') && scheme_isalpha(str[pos + 1])) {
    mzchar s[7];
    int i;

    for (i = 0; i < 6; i++) {
      s[i] = scheme_tolower(str[i + pos]);
    }
    s[i] = 0;

    if (!u_strcmp(s, infinity_str)) {
#ifdef USE_SINGLE_FLOATS_AS_DEFAULT
      return scheme_single_inf_object;
#else
      return scheme_inf_object;
#endif
    }
    else if (!u_strcmp(s, minus_infinity_str)) {
#ifdef USE_SINGLE_FLOATS_AS_DEFAULT
      return scheme_single_minus_inf_object;
#else
      return scheme_minus_inf_object;
#endif
    }
    else if (!u_strcmp(s, not_a_number_str)
            || !u_strcmp(s, other_not_a_number_str)) {
#ifdef USE_SINGLE_FLOATS_AS_DEFAULT
      return scheme_single_nan_object;
#else      
      return scheme_nan_object;
#endif
    }
  }

  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * real_to_bytes ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2015 of file numstr.c.

{
  Scheme_Object *n, *s;
  int size;
  int bigend = MZ_IS_BIG_ENDIAN;
  double d;
  long offset = 0;

  n = argv[0];
  if (!SCHEME_REALP(n))
    scheme_wrong_type("real->floating-point-bytes", "real number", 0, argc, argv);

  if (SCHEME_INTP(argv[1]))
    size = SCHEME_INT_VAL(argv[1]);
  else
    size = 0;
  if ((size != 4) && (size != 8))
    scheme_wrong_type("real->floating-point-bytes", "exact 4 or 8", 1, argc, argv);

  if (argc > 2)
    bigend = SCHEME_TRUEP(argv[2]);

  if (argc > 3) {
    s = argv[3];

    if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
      scheme_wrong_type("real->floating-point-bytes", "mutable byte string", 3, argc, argv);
    
    if (argc > 4) {
      long start, finish;
      
      scheme_get_substring_indices("real->floating-point-bytes", s,
                                   argc, argv,
                                   4, 5, &start, &finish);
      
      offset = start;
    } else
      offset = 0;
  } else
    s = scheme_make_sized_byte_string("12345678", size, 1);
  
  if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
    scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "real->floating-point-bytes: byte string is %ld bytes,"
                     " which is shorter than starting position %ld plus size %ld",
                     SCHEME_BYTE_STRLEN_VAL(s), offset, size);
    return NULL;
  }

  d = scheme_get_val_as_double(n);
  
  if (size == 4) {
    float f = (float) d;
    memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &f, sizeof(float));
  } else {
    memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &d, sizeof(double));
  }

  if (bigend != MZ_IS_BIG_ENDIAN) {
    int i;
    char buf[8], *str;

    str = SCHEME_BYTE_STR_VAL(s);
    
    for (i = 0; i < size; i++) {
      buf[size - i - 1] = str[offset + i];
    }
    for (i = 0; i < size; i++) {
      str[offset + i] = buf[i];
    }
  }

  return s;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * sch_pack ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2228 of file numstr.c.

{
  return do_pack("vector->pseudo-random-generator", argc, argv, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * sch_pack_bang ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2234 of file numstr.c.

{
  return do_pack("vector->pseudo-random-generator!", argc, argv, 1);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * sch_random ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2135 of file numstr.c.

{
  if (!argc) {
    double v;
    Scheme_Object *rand_state;
    
    rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
    v = sch_double_rand((Scheme_Random_State *)rand_state);
    return scheme_make_double(v);
  } else if ((argc == 1)
             && SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type)) {
    double v;
    Scheme_Object *rand_state;
    
    rand_state = argv[0];
    v = sch_double_rand((Scheme_Random_State *)rand_state);
    return scheme_make_double(v);
  } else {
    unsigned long i, v;
    Scheme_Object *o, *rand_state;

    o = argv[0];
    if (scheme_get_unsigned_int_val(o,  &i)) {
      if (i > 4294967087UL)
       i = 0;
    } else
      i = 0;
    
    if (!i) {
      scheme_wrong_type("random", 
                        ((argc == 1)
                         ? "exact integer in [1, 4294967087] or pseudo-random-generator"
                         : "exact integer in [1, 4294967087]"), 
                        0, argc, argv);
      return NULL;
    }

    if (argc == 2) {
      rand_state = argv[1];
      if (!SAME_TYPE(SCHEME_TYPE(rand_state), scheme_random_state_type)) {
        scheme_wrong_type("random", "pseudo-random-generator", 1, argc, argv);
        return NULL;
      }
    } else {
      rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
    }

    v = sch_int_rand(i, (Scheme_Random_State *)rand_state);
    
    return scheme_make_integer_value_from_unsigned(v);
  }
}

Here is the caller graph for this function:

static Scheme_Object * sch_unpack ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2240 of file numstr.c.

{
  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type))
    scheme_wrong_type("pseudo-random-generator->vector", "pseudo-random-generator",
                    0, argc, argv);

  return unpack_rand_state((Scheme_Random_State *)argv[0]);
}

Here is the caller graph for this function:

int scheme_check_double ( const char *  where,
double  d,
const char *  dest 
)

Definition at line 1601 of file numstr.c.

{
  if (MZ_IS_INFINITY(d)
      || MZ_IS_NAN(d)) {
    if (where)
      scheme_raise_exn(MZEXN_FAIL_CONTRACT,
                     "%s: no %s representation for %s",
                     where, 
                     dest,
                     double_to_string(d, 0));
    return 0;
  }

  return 1;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 76 of file numstr.c.

{
  scheme_add_global_constant("number->string", 
                          scheme_make_prim_w_arity(number_to_string,
                                                "number->string",
                                                1, 2),
                          env);
  scheme_add_global_constant("string->number", 
                          scheme_make_folding_prim(string_to_number,
                                                "string->number", 
                                                1, 2, 1),
                          env);

  scheme_add_global_constant("integer-bytes->integer", 
                          scheme_make_prim_w_arity(bytes_to_integer,
                                                "integer-bytes->integer", 
                                                2, 5),
                          env);
  scheme_add_global_constant("integer->integer-bytes", 
                          scheme_make_prim_w_arity(integer_to_bytes,
                                                "integer->integer-bytes", 
                                                3, 6),
                          env);
  scheme_add_global_constant("floating-point-bytes->real", 
                          scheme_make_prim_w_arity(bytes_to_real,
                                                "floating-point-bytes->real",
                                                1, 4),
                          env);
  scheme_add_global_constant("real->floating-point-bytes",
                          scheme_make_prim_w_arity(real_to_bytes,
                                                "real->floating-point-bytes",
                                                2, 5),
                          env);
  scheme_add_global_constant("system-big-endian?",
                          scheme_make_prim_w_arity(system_big_endian_p,
                                                "system-big-endian?",
                                                0, 0),
                          env);

  scheme_add_global_constant("random", 
                          scheme_make_prim_w_arity(sch_random,
                                                "random",
                                                0, 2),
                          env);
  scheme_add_global_constant("random-seed", 
                          scheme_make_prim_w_arity(random_seed,
                                                "random-seed",
                                                1, 1),
                          env);
  scheme_add_global_constant("make-pseudo-random-generator", 
                          scheme_make_prim_w_arity(make_pseudo_random_generator,
                                                "make-pseudo-random-generator", 
                                                0, 0), 
                          env);
  scheme_add_global_constant("vector->pseudo-random-generator",
                          scheme_make_prim_w_arity(sch_pack,
                                                "vector->pseudo-random-generator", 
                                                1, 1), 
                          env);
  scheme_add_global_constant("vector->pseudo-random-generator!",
                          scheme_make_prim_w_arity(sch_pack_bang,
                                                "vector->pseudo-random-generator!", 
                                                2, 2), 
                          env);
  scheme_add_global_constant("pseudo-random-generator->vector",
                          scheme_make_prim_w_arity(sch_unpack,
                                                "pseudo-random-generator->vector", 
                                                1, 1), 
                          env);
  scheme_add_global_constant("pseudo-random-generator?", 
                          scheme_make_prim_w_arity(pseudo_random_generator_p,
                                                "pseudo-random-generator?", 
                                                1, 1), 
                          env);
  scheme_add_global_constant("current-pseudo-random-generator", 
                          scheme_register_parameter(current_pseudo_random_generator,
                                                 "current-pseudo-random-generator",
                                                 MZCONFIG_RANDOM_STATE),
                          env);
  scheme_add_global_constant("current-evt-pseudo-random-generator", 
                          scheme_register_parameter(current_sched_pseudo_random_generator,
                                                 "current-evt-pseudo-random-generator",
                                                 MZCONFIG_SCHEDULER_RANDOM_STATE),
                          env);

  REGISTER_SO(num_limits);
}

Here is the call graph for this function:

Here is the caller graph for this function:

char* scheme_number_to_string ( int  radix,
Scheme_Object obj 
)

Definition at line 1596 of file numstr.c.

{
  return number_to_allocated_string(radix, obj, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 2109 of file numstr.c.

{
  return sch_int_rand(2147483647, rs);
}

Here is the caller graph for this function:

Scheme_Object* scheme_read_number ( const mzchar str,
long  len,
int  is_float,
int  is_not_float,
int  decimal_means_float,
int  radix,
int  radix_set,
Scheme_Object complain,
int div_by_zero,
int  test_only,
Scheme_Object stxsrc,
long  line,
long  col,
long  pos,
long  span,
Scheme_Object indentation 
)

Definition at line 355 of file numstr.c.

{
  int i, has_decimal, must_parse, has_slash;
  int report, delta;
  Scheme_Object *next_complain;
  int has_hash, has_expt, has_i, has_sign, has_at, has_hash_since_slash;
  int saw_digit, saw_digit_since_slash, saw_nonzero_digit;
  Scheme_Object *o;
#ifdef MZ_USE_SINGLE_FLOATS
  int single;
#endif

  if (len < 0)
    len = scheme_char_strlen(str);

  delta = 0;

  while (str[delta] == '#') {
    if (str[delta+1] != 'E' && str[delta+1] != 'e' && str[delta+1] != 'I' && str[delta+1] != 'i') {
      if (radix_set) {
       if (complain)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: bad radix specification: %u",
                       str, len);
       else
         return scheme_false;
      }
      radix_set = 1;
    } else {
      if (is_float || is_not_float) {
       if (complain)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: bad exactness specification: %u", 
                       str, len);
       else
         return scheme_false;
      }
    }

    switch (str[delta+1]) {
    case 'B':
    case 'b':
      radix = 2;
      break;
    case 'O':
    case 'o':
      radix = 8;
      break;
    case 'D':
    case 'd':
      radix = 10;
      break;
    case 'X':
    case 'x':
      radix = 16;
      break;
    case 'I':
    case 'i':
      is_float = 1;
      break;
    case 'E':
    case 'e':
      is_not_float = 1;
      break;
    default:
      if (complain)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                     "read-number: bad `#' indicator `%c': %u",
                     str[delta+1], str, len);
      return scheme_false;
    }
    delta += 2;
  }

  must_parse = (radix_set || is_float || is_not_float);

  report = complain && must_parse;
  next_complain = must_parse ? complain : NULL;

  if (!(len - delta)) {
    if (report)
      scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                    "read-number: no digits");
    return scheme_false;
  }

  /* look for +inf.0, etc: */
  if (len -delta == 6) {
    Scheme_Object *special;
    special = read_special_number(str, delta);
    if (special) {
      if (!is_not_float)
       return special;
      if (report)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                     "read-number: no exact representation for %V",
                     special);
      return scheme_false;
    }
  }

  /* Look for <special>+...i and ...<special>i */
  if ((len-delta > 7) && str[len-1] == 'i') {
    Scheme_Object *special;
    mzchar *s2;
    
    /* Try <special>+...i */
    special = read_special_number(str, delta);
    if (special) {
      s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6 + 4 + 1) * sizeof(mzchar));
      s2[0] = '+';
      s2[1] = '0';
      s2[2] = '.';
      s2[3] = '0';
      memcpy(s2 + 4, str + delta + 6, (len - delta - 5) * sizeof(mzchar));
    } else {
      /* Try ...<special>i: */
      special = read_special_number(str, len - 7);
      if (special) {
       s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6 + 4 + 1) * sizeof(mzchar));
       memcpy(s2, str + delta, (len - delta - 7) * sizeof(mzchar));
       s2[len - delta - 7] = '+';
       s2[len - delta - 7 + 1] = '0';
       s2[len - delta - 7 + 2] = '.';
       s2[len - delta - 7 + 3] = '0';
       s2[len - delta - 7 + 4] = 'i';
       s2[len - delta - 7 + 5] = 0;
       special = scheme_bin_mult(special, scheme_plus_i);
      } else
       s2 = NULL;
    }

    if (special) {
      Scheme_Object *other;
      int dbz = 0;

      if (is_not_float) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: no exact representation for %V",
                       special);
       return scheme_false;
      }

      other = scheme_read_number(s2, len - delta - 6 + 4,
                             is_float, is_not_float, 1,
                             radix, 1, 0,
                             &dbz, test_only,
                             stxsrc, line, col, pos, span,
                             indentation);

      if (dbz) {
       if (div_by_zero)
         *div_by_zero = 1;
       if (complain)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: division by zero: %u",
                       str, len);
       return scheme_false;
      }

      if (!SCHEME_FALSEP(other))
       return scheme_bin_plus(special, other);
      
      if (!complain)
       return scheme_false;
    }
  } else if ((len-delta == 7) && str[len-1] == 'i') {
    /* Try <special>i */
    Scheme_Object *special;
    special = read_special_number(str, delta);
    if (special) {
      special = scheme_make_complex(scheme_make_integer(0), special);

      if (is_not_float) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: no exact representation for %V",
                       special);
       return scheme_false;
      }

      return special;
    }
  }

  /* Look for <special>@... and ...@<special> */
  if ((len - delta > 7) && ((str[delta+6] == '@') || (str[len - 7] == '@'))) {
    Scheme_Object *special;
    mzchar *s2;
    int spec_mag = 0;

    /* Try <special>@... */
    if (str[delta+6] == '@')
      special = read_special_number(str, delta);
    else
      special = NULL;
    if (special) {
      s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6) * sizeof(mzchar));
      memcpy(s2, str + delta + 7, (len - delta - 6) * sizeof(mzchar));
      spec_mag = 1;
    } else {
      if (str[len - 7] == '@')
       special = read_special_number(str, len - 6);
      else
       special = NULL;
      
      if (special) {
       s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6) * sizeof(mzchar));
       memcpy(s2, str + delta, (len - delta - 7) * sizeof(mzchar));
       s2[len - delta - 7] = 0;
      } else
       s2 = NULL;
    }

    if (special) {
      Scheme_Object *other;
      int dbz = 0;

      /* s2 can't contain @: */
      for (i = 0; s2[i]; i++) {
       if (s2[i] == '@')
         break;
      }

      if (s2[i])
       other = scheme_false;
      else
       other = scheme_read_number(s2, len - delta - 7,
                               is_float, is_not_float, 1,
                               radix, 1, 0,
                               &dbz, test_only,
                               stxsrc, line, col, pos, span,
                               indentation);

      if (dbz) {
       if (div_by_zero)
         *div_by_zero = 1;
       if (complain)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: division by zero: %u", 
                       str, len);
       return scheme_false;
      }

      if (!SCHEME_FALSEP(other)) {
       /* If string is complex, not well-formed: */
       if (!SCHEME_COMPLEXP(other)) {
         Scheme_Object *a[2];
         if (spec_mag) {
           a[0] = special;
           a[1] = other;
         } else {
           a[0] = other;
           a[1] = special;
         }

         return scheme_make_polar(2, a);
       }
      }

      if (!complain)
       return scheme_false;
    }
  }
      
#define isinexactmark(ch) ((ch == 'e') || (ch == 'E') \
                        || (ch == 's') || (ch == 'S') \
                        || (ch == 'f') || (ch == 'F') \
                        || (ch == 'd') || (ch == 'D') \
                        || (ch == 'l') || (ch == 'L'))

#define isAdigit(ch) ((ch >= '0') && (ch <= '9'))


#define isbaseNdigit(N, ch) (((ch >= 'a') && (ch <= (mzchar)('a' + N - 11))) \
                             || ((ch >= 'A') && (ch <= (mzchar)('A' + N - 11))))

  has_i = 0;
  has_at = 0;
  has_sign = delta-1;
  for (i = delta; i < len; i++) {
    mzchar ch = str[i];
    if (!ch) {
      if (report)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                     "read-number: embedded null character: %u",
                     str, len);
      return scheme_false;
    } else if (isinexactmark(ch) && ((radix <= 10) || !isbaseNdigit(radix, ch))) {
      /* If a sign follows, don't count it */
      if (str[i+1] == '+' || str[i+1] == '-')
       i++;
    } else if ((ch == '+') || (ch == '-')) {
      if ((has_sign > delta) || ((has_sign == delta) && (i == delta+1))) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                        "read-number: too many signs: %u", 
                        str, len);
       return scheme_false;
      }
      has_sign = i;
    } else if (((ch == 'I') || (ch == 'i')) && (has_sign >= delta)) {
      if (has_at) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: cannot mix `@' and `i': %u", 
                       str, len);
       return scheme_false;
      }
      if (i + 1 < len) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: `i' must be at the end: %u", 
                       str, len);
       return scheme_false;
      }
      has_i = i;
    } else if (ch == '@') {
      if (has_at) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: too many `@'s: %u", 
                       str, len);
       return scheme_false;
      }
      if (i == delta) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: `@' cannot be at start: %u", 
                       str, len);
       return scheme_false;
      }
      has_at = i;
      if (has_sign >= delta)
       has_sign = delta-1;
    }
  }

  if (has_i) {
    Scheme_Object *n1, *n2;
    mzchar *first, *second;
    int fdbz = 0, sdbz = 0;

    if (has_sign != delta) {
      first = (mzchar *)scheme_malloc_atomic((has_sign - delta + 1) * sizeof(mzchar));
      memcpy(first, str + delta, (has_sign - delta) * sizeof(mzchar));
      first[has_sign - delta] = 0;
    } else
      first = NULL;

    if (has_i - has_sign > 1) {
      second = (mzchar *)scheme_malloc_atomic((has_i - has_sign + 1) * sizeof(mzchar));
      memcpy(second, str + has_sign, (has_i - has_sign) * sizeof(mzchar));
      second[has_i - has_sign] = 0;
    } else
      second = NULL;

    if (first)
      n1 = scheme_read_number(first, has_sign - delta,
                           is_float, is_not_float, decimal_means_float,
                           radix, 1, next_complain,
                           &fdbz, test_only,
                           stxsrc, line, col, pos, span,
                           indentation);
    else
      n1 = zeroi;

    if (SAME_OBJ(n1, scheme_false) && !fdbz)
      return scheme_false;
    /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
    else if (SCHEME_FLOATP(n1)) {
      double d = SCHEME_FLOAT_VAL(n1);
      if (MZ_IS_NAN(d))
       return scheme_false;
    }
    
    if (second)
      n2 = scheme_read_number(second, has_i - has_sign,
                           is_float, is_not_float, decimal_means_float,
                           radix, 1, next_complain,
                           &sdbz, test_only,
                           stxsrc, line, col, pos, span,
                           indentation);
    else if (str[has_sign] == '-')
      n2 = scheme_make_integer(-1);
    else
      n2 = scheme_make_integer(1);
    
    if (SAME_OBJ(n2, scheme_false) && !sdbz)
      return scheme_false;
    /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
    else if (SCHEME_FLOATP(n2)) {
      double d = SCHEME_FLOAT_VAL(n2);
      if (MZ_IS_NAN(d))
       return scheme_false;
    }

    if (fdbz || sdbz) {
      if (div_by_zero)
       *div_by_zero = 1;
      if (complain)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                      "read-number: division by zero: %u", 
                      str, len);
      return scheme_false;
    }

    if (!is_not_float && ((SCHEME_FLOATP(n1) && (n2 != zeroi)) || is_float))
      n2 = scheme_exact_to_inexact(1, &n2);  /* uses default conversion: float or double */
    else if (is_not_float)
      n2 = scheme_inexact_to_exact(1, &n2);

    if (!is_not_float && ((SCHEME_FLOATP(n2) && (n1 != zeroi)) || is_float))
      n1 = scheme_exact_to_inexact(1, &n1); /* uses default conversion: float or double */
    else if (is_not_float)
      n1 = scheme_inexact_to_exact(1, &n1);

    return scheme_make_complex(n1, n2);
  }

  if (has_at) {
    Scheme_Object *n1, *n2;
    double d1, d2, r1, r2;
    mzchar *first;
    const mzchar *second;
    int fdbz = 0, sdbz = 0;

    first = (mzchar *)scheme_malloc_atomic((has_at - delta + 1) * sizeof(mzchar));
    memcpy(first, str + delta, (has_at - delta) * sizeof(mzchar));
    first[has_at - delta] = 0;

#ifdef MZ_PRECISE_GC
    {
      /* Can't pass mis-aligned pointer to scheme_read_number. */
      int slen = len - (has_at + 1) + 1;
      second = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
      memcpy((mzchar *)second, str + has_at + 1, slen * sizeof(mzchar));
    }
#else
    second = str + has_at + 1;
#endif

    n2 = scheme_read_number(second, len - has_at - 1,
                         is_float, is_not_float, decimal_means_float,
                         radix, 1, next_complain,
                         &fdbz, test_only,
                         stxsrc, line, col, pos, span,
                         indentation);

    if (!fdbz) {
      if (SCHEME_FALSEP(n2))
       return scheme_false;

      /* Special case: angle is zero => real number */
      if (n2 == zeroi)
       return scheme_read_number(first, has_at - delta,
                              is_float, is_not_float, decimal_means_float,
                              radix, 1, complain,
                              div_by_zero,
                              test_only,
                              stxsrc, line, col, pos, span,
                              indentation);

      n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */

      d2 = SCHEME_FLOAT_VAL(n2);
      
      /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
      if (MZ_IS_NAN(d2))
       return scheme_false;

      n1 = scheme_read_number(first, has_at - delta, 
                           is_float, is_not_float, decimal_means_float,
                           radix, 1, next_complain,
                           &sdbz,
                           test_only,
                           stxsrc, line, col, pos, span,
                           indentation);

      /* Special case: magnitude is zero => zero */
      if (n1 == zeroi)
       return zeroi;

      if (!SCHEME_FALSEP(n1))
       n1 = scheme_exact_to_inexact(1, &n1); /* uses default conversion: float or double */
    } else {
      n1 = NULL;
      d2 = 0;
    }

    if (fdbz || sdbz) {
      if (div_by_zero)
       *div_by_zero = 1;
      if (complain)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                     "read-number: division by zero in %u", 
                     str, len);
      return scheme_false;
    }

    if (SCHEME_FALSEP(n1))
      return scheme_false;

    d1 = SCHEME_FLOAT_VAL(n1);

    /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
    if (MZ_IS_NAN(d1))
      return scheme_false;

    r1 = d1 * SCH_COS(d2);
    r2 = d1 * SCH_SIN(d2);

#ifdef MZ_USE_SINGLE_FLOATS
    if (SCHEME_FLTP(n1) && SCHEME_FLTP(n2))
      n1 = scheme_make_complex(scheme_make_float((float)r1),
                               scheme_make_float((float)r2));
    else
#endif
      n1 = scheme_make_complex(scheme_make_double(r1),
                               scheme_make_double(r2));

    if (is_not_float)
      n1 = scheme_inexact_to_exact(1, &n1);

    return n1;
  }

  has_decimal = has_slash = has_hash = has_hash_since_slash = has_expt = 0;
  saw_digit = saw_digit_since_slash = saw_nonzero_digit = 0;
  for (i = delta; i < len; i++) {
    mzchar ch = str[i];
    if (ch == '.') {
      if (has_decimal) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: multiple decimal points: %u", 
                       str, len);
       return scheme_false;
      }
      if (has_slash) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: decimal points and fractions "
                       "cannot be mixed: %u", 
                       str, len);
       return scheme_false;
      }
      has_decimal = 1;
    } else if (isinexactmark(ch)
              && ((radix <= 10) || !isbaseNdigit(radix, ch))) {
      if (i == delta) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: cannot begin with `%c' in %u", 
                       ch, str, len);
       return scheme_false;
      }
      has_expt = i;
      break;
    } else if (ch == '/') {
      if (i == delta) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: cannot have slash at start: %u", 
                       str, len);
       return scheme_false;
      }
      if (has_slash) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: multiple slashes: %u", 
                       str, len);
       return scheme_false;
      }
      if (has_decimal) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: decimal points and fractions "
                       "cannot be mixed: %u", 
                       str, len);
       return scheme_false;
      }
      has_slash = i;
      saw_digit_since_slash = 0;
      has_hash_since_slash = 0;
    } else if ((ch == '-') || (ch == '+')) {
      if (has_slash || has_decimal || has_hash) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: misplaced sign: %u", 
                       str, len);
       return scheme_false;
      }
    } else if (ch == '#') {
      if (!saw_digit_since_slash) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: misplaced hash: %u", 
                       str, len);
       return scheme_false;
      }
      has_hash = 1;
      has_hash_since_slash = 1;
    } else if (!isAdigit(ch) && !((radix > 10) && isbaseNdigit(radix, ch))) {
      if (has_decimal) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: bad decimal number: %u", 
                       str, len);
       return scheme_false;
      }
      if (has_hash) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: misplaced hash: %u", 
                       str, len);
       return scheme_false;
      }
      break;
    } else {
      saw_digit = 1;
      saw_digit_since_slash = 1;
      if (ch != '0')
       saw_nonzero_digit = 1;
      if (has_hash_since_slash) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: misplaced hash: %u", 
                       str, len);
       return scheme_false;
      }
    }
  }

#ifdef MZ_USE_SINGLE_FLOATS
  if (has_expt && str[has_expt]) {
    single = str[has_expt];
    single = ((single == 'f') || (single == 'F')
# ifdef USE_SINGLE_FLOATS_AS_DEFAULT
             || (single == 'e') || (single == 'E')
#endif
             || (single == 's') || (single == 'S'));
  } else {
# ifdef USE_SINGLE_FLOATS_AS_DEFAULT
    single = 1;
# else
    single = 0;
# endif
  }
#endif


  /* When possible, use the standard floating-point parser */
  if (!is_not_float && (is_float || decimal_means_float) 
      && !has_slash && !has_hash && (radix == 10) 
      && (has_decimal || has_expt)
      && (len <= MAX_FAST_FLOATREAD_LEN)) {
    double d;
    GC_CAN_IGNORE char *ptr;

    if (has_expt && !(str[has_expt + 1])) {
      if (report)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                     "read-number: no digits after \"%c\": %u",
                     str[has_expt], str, len);
      return scheme_false;
    }

    {
      int k;
      for (k = delta; k < len; k++) {
       if (str[k] > 127)
         ffl_buf[k - delta] = '?';
       else
         ffl_buf[k - delta] = str[k];
      }
      ffl_buf[len - delta] = 0;
    }

    if (has_expt && (str[has_expt] != 'e' && str[has_expt] != 'E')) {
      ffl_buf[has_expt - delta] = 'e';
    }
    d = STRTOD(ffl_buf, &ptr);

    if ((ptr XFORM_OK_MINUS ffl_buf) < (len - delta)) {
      if (report)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                     "read-number: bad decimal number %u",
                     str, len);
      return scheme_false;
    } 

    if (!saw_nonzero_digit) {
      /* Assert: d = 0.0 or -0.0 */
      if (str[delta] == '-') {
       /* Make sure it's -0.0 */
#ifdef MZ_USE_SINGLE_FLOATS
       if (single) return scheme_nzerof;
#endif
       return scheme_nzerod;
      }
    }

    if (!d) {
      if (str[delta] == '-') {
       /* Make sure it's -0.0 */
#ifdef MZ_USE_SINGLE_FLOATS
       if (single) return scheme_nzerof;
#endif
       return scheme_nzerod;
      }
    }

#ifdef MZ_USE_SINGLE_FLOATS
    if (single)
      return scheme_make_float((float)d);
#endif
    return scheme_make_double(d);
  }

  if (has_decimal || has_expt || (has_hash && !has_slash)) {
    Scheme_Object *mantissa, *exponent, *power, *n;
    Scheme_Object *args[2];
    int result_is_float= (is_float || (!is_not_float && decimal_means_float));

    if (has_expt) {
      mzchar *substr;

      if (!str[has_expt + 1]) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: no digits after \"%c\": %u",
                       str[has_expt], str, len);
       return scheme_false;
      }

#ifdef MZ_PRECISE_GC
      {
       /* Can't pass misaligned pointer to scheme_read_bignum: */
       int slen = len - (has_expt + 1) + 1;
       substr = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
       memcpy(substr, str + has_expt + 1, slen * sizeof(mzchar));
      }
#else
      substr = (mzchar *)str + has_expt + 1;
#endif

      exponent = scheme_read_bignum(substr, 0, radix);
      if (SCHEME_FALSEP(exponent)) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: bad exponent: %u", 
                       str, len);
       return scheme_false;
      }
    } else
      exponent = zeroi;

    if (!has_expt)
      has_expt = len;

    if (has_slash) {
      /* Mantissa is a fraction. */
      mzchar *s;
      int dbz;
      
      s = (mzchar *)scheme_malloc_atomic((has_expt - delta + 1) * sizeof(mzchar));
      memcpy(s, str + delta, (has_expt - delta) * sizeof(mzchar));
      s[has_expt - delta] = 0;
      
      mantissa = scheme_read_number(s, has_expt - delta, 
                                is_float, is_not_float, 1,
                                radix, 1, next_complain,
                                &dbz,
                                test_only,
                                stxsrc, line, col, pos, span,
                                indentation);

      if (SCHEME_FALSEP(mantissa)) {
       if (dbz) {
         if (div_by_zero)
           *div_by_zero = 1;
         if (complain)
           scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                         "read-number: division by zero: %u", 
                         str, len);
       }
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: bad number: %u", 
                       str, len);
       return scheme_false;
      }
    } else {
      /* Mantissa is not a fraction. */
      mzchar *digits;
      int extra_power = 0, dcp = 0, num_ok;

      digits = (mzchar *)scheme_malloc_atomic((has_expt - delta + 1) * sizeof(mzchar));

      i = delta;
      if (str[i] == '+' || str[i] == '-')
       digits[dcp++] = str[i++];

      for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) {
       digits[dcp++] = str[i];
      }

      if (str[i] == '#') {
       for (; str[i] == '#'; i++) {
         digits[dcp++] = '0';
       }
       num_ok = 0;
      } else
       num_ok = 1;
       
      if (str[i] == '.') {
       i++;
       if (num_ok)
         for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) {
           digits[dcp++] = str[i];
           extra_power++;
         }

       for (; str[i] == '#'; i++) {
         digits[dcp++] = '0';  
         extra_power++;
       }
      }

      if ((str[i] && (!has_expt || i != has_expt))
         || !dcp || (dcp == 1 && !(isAdigit(digits[0])
                                || ((radix > 10) && isbaseNdigit(radix, digits[0]))))) {
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                       "read-number: bad decimal number %u", 
                       str, len);
       return scheme_false;
      }

      /* Reduce unnecessary mantissa-reading work for inexact results.
         This is also necessary to make the range check on `exponent'
         correct. */
      if (result_is_float && (dcp > MAX_FLOATREAD_PRECISION_DIGITS)) {
       extra_power -= (dcp - MAX_FLOATREAD_PRECISION_DIGITS);
       dcp = MAX_FLOATREAD_PRECISION_DIGITS;
      }

      digits[dcp] = 0;
      mantissa = scheme_read_bignum(digits, 0, radix);
      if (SCHEME_FALSEP(mantissa)) {
       /* can get here with bad radix */
       if (report)
         scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                        "read-number: bad number: %u", 
                        str, len);
       return scheme_false;
      }

      if (extra_power)
       exponent = scheme_bin_minus(exponent, scheme_make_integer(extra_power));
    
      /* Don't calculate a huge exponential if we're returning a float: */
      if (result_is_float) {
       if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD))) {
         if (scheme_is_negative(mantissa))
           return CHECK_SINGLE(scheme_minus_inf_object, single);
         else
           return CHECK_SINGLE(scheme_inf_object, single);
       } else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD))) {
         if (scheme_is_negative(mantissa))
           return CHECK_SINGLE(scheme_nzerod, single);
         else
           return CHECK_SINGLE(scheme_zerod, single);
       }
      }
    }

    /* This is the important use of test_only, because it's the one
       place where the read calculation is not linear in the input. */
    if (test_only)
      return scheme_make_integer(1);

    args[0] = scheme_make_integer(radix);
    args[1] = exponent;
    power = scheme_expt(2, args);

    n = scheme_bin_mult(mantissa, power);

    if (result_is_float)
      n = CHECK_SINGLE(TO_DOUBLE(n), single);
    else
      n = CHECK_SINGLE(n, single);

    if (SCHEME_FLOATP(n) && str[delta] == '-') {
      if (SCHEME_FLOAT_VAL(n) == 0.0) {
       /* 0.0 => -0.0 */
#ifdef MZ_USE_SINGLE_FLOATS
       if (SCHEME_FLTP(n)) {
         n = scheme_make_float(-SCHEME_FLT_VAL(n));
       } else
#endif
         n = scheme_make_double(-SCHEME_DBL_VAL(n));
      }
    }

    return n;
  }
  
  if (has_slash) {
    Scheme_Object *n1, *n2;
    mzchar *first;

    first = (mzchar *)scheme_malloc_atomic((has_slash - delta + 1) * sizeof(mzchar));
    memcpy(first, str + delta, (has_slash - delta) * sizeof(mzchar));
    first[has_slash - delta] = 0;

    n1 = scheme_read_number(first, has_slash - delta,
                         is_float, is_not_float, 1,
                         radix, 1, next_complain,
                         div_by_zero,
                         test_only,
                         stxsrc, line, col, pos, span,
                         indentation);
    if (SAME_OBJ(n1, scheme_false))
      return scheme_false;

    {
      mzchar *substr;

#ifdef MZ_PRECISE_GC
      {
       /* Can't pass misaligned pointer to scheme_read_bignum: */
       int slen = len - (has_slash + 1) + 1;
       substr = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
       memcpy(substr, str + has_slash + 1, slen * sizeof(mzchar));
      }
#else
      substr = (mzchar *)str + has_slash + 1;
#endif

      n2 = scheme_read_number(substr, len - has_slash - 1,
                           is_float, is_not_float, 1,
                           radix, 1, next_complain,
                           div_by_zero,
                           test_only,
                           stxsrc, line, col, pos, span,
                           indentation);
    }

    if (SAME_OBJ(n2, scheme_false))
      return scheme_false;

    if (SCHEME_EXACT_REALP(n2) && scheme_is_zero(n2)) {
      if (complain)
       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                     "read-number: division by zero: %u", 
                     str, len);
      if (div_by_zero)
       *div_by_zero = 1;
      return scheme_false;
    }

    if (test_only)
      return scheme_make_integer(1);

    n1 = scheme_bin_div(n1, n2);

    if (is_not_float) {
      if (SCHEME_FLOATP(n1)) {
       if (!scheme_check_double(NULL, SCHEME_FLOAT_VAL(n1), NULL)) {
         if (complain)
           scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                         "read-number: no exact representation for %V", 
                         n1);
         return scheme_false;
       }
      }
      n1 = scheme_inexact_to_exact(1, &n1);
    } else if (is_float)
      n1 = TO_DOUBLE(n1);

    return CHECK_SINGLE(n1, single);
  }

  o = scheme_read_bignum(str, delta, radix);
  if (SAME_OBJ(o, scheme_false)) {
    if (report)
      scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
                    "read-number: bad number: %u", 
                    str, len);
  } else if (is_float) {
    /* Special case: "#i-0" => -0. */
    if ((o == zeroi) && str[delta] == '-') {
#ifdef MZ_USE_SINGLE_FLOATS
      if (single) return scheme_nzerof;
#endif
      return scheme_nzerod;
    }

    return CHECK_SINGLE(TO_DOUBLE(o), single);
  }

  return o;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * string_to_number ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 1432 of file numstr.c.

{
  long radix;
  long len;
  mzchar *mzstr;
  int decimal_inexact, div_by_zero = 0;
  Scheme_Object *v;

  if (!SCHEME_CHAR_STRINGP(argv[0]))
    scheme_wrong_type("string->number", "string", 0, argc, argv);

  if (argc > 1) {
    if (SCHEME_INTP(argv[1]))
      radix = SCHEME_INT_VAL(argv[1]);
    else
      radix = 0;
    
    if ((radix < 2) || (radix > 16)) {
      scheme_wrong_type("string->number", "exact integer in [2, 16]", 1, argc, argv);
      ESCAPED_BEFORE_HERE;
    }
  } else
    radix = 10;

  decimal_inexact = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), 
                                            MZCONFIG_READ_DECIMAL_INEXACT));

  mzstr = SCHEME_CHAR_STR_VAL(argv[0]);
  len = SCHEME_CHAR_STRTAG_VAL(argv[0]);

  v = scheme_read_number(mzstr, len, 
                      0, 0, decimal_inexact,
                      radix, 0, NULL, &div_by_zero,
                      0, NULL, 0, 0, 0, 0,
                      NULL);

  return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * system_big_endian_p ( int  argc,
Scheme_Object argv[] 
) [static]

Definition at line 2090 of file numstr.c.

{
#if MZ_IS_BIG_ENDIAN
  return scheme_true;
#else
  return scheme_false;
#endif
}

Here is the caller graph for this function:

static int u_strcmp ( mzchar s,
char *  t 
) [static]

Definition at line 179 of file numstr.c.

{
  int i;

  for (i = 0; s[i] && (s[i] == ((unsigned char *)t)[i]); i++) {
  }
  if (s[i] || t[i])
    return 1;
  return 0;
}

Here is the caller graph for this function:


Variable Documentation

char ffl_buf[MAX_FAST_FLOATREAD_LEN+1] [static]

Definition at line 235 of file numstr.c.

char* infinity_str = "+inf.0" [static]

Definition at line 59 of file numstr.c.

char* minus_infinity_str = "-inf.0" [static]

Definition at line 60 of file numstr.c.

char* not_a_number_str = "+nan.0" [static]

Definition at line 61 of file numstr.c.

Scheme_Object* num_limits[3] [static]

Definition at line 64 of file numstr.c.

char* other_not_a_number_str = "-nan.0" [static]

Definition at line 62 of file numstr.c.