#include "schpriv.h"

#include <math.h>

#include <string.h>

#include <ctype.h>

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

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

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

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

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

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

static Scheme_Object *bytes_to_long_double (int argc, Scheme_Object *argv[]);

static Scheme_Object *long_double_to_bytes (int argc, Scheme_Object *argv[]);

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

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

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

static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv);

static Scheme_Object *current_pseudo_random_generator(int argc, Scheme_Object **argv);

static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object **argv);

static Scheme_Object *pseudo_random_generator_p(int argc, Scheme_Object **argv);

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

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

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

static Scheme_Object *sch_check_pack(int argc, Scheme_Object *argv[]);

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

READ_ONLY static char *infinity_str = "+inf.0";

READ_ONLY static char *minus_infinity_str = "-inf.0";

READ_ONLY static char *not_a_number_str = "+nan.0";

READ_ONLY static char *other_not_a_number_str = "-nan.0";

READ_ONLY static char *long_infinity_str = "+inf.t";

READ_ONLY static char *long_minus_infinity_str = "-inf.t";

READ_ONLY static char *long_not_a_number_str = "+nan.t";

READ_ONLY static char *long_other_not_a_number_str = "-nan.t";

READ_ONLY static char *single_infinity_str = "+inf.f";

READ_ONLY static char *single_minus_infinity_str = "-inf.f";

READ_ONLY static char *single_not_a_number_str = "+nan.f";

READ_ONLY static char *single_other_not_a_number_str = "-nan.f";

#if !defined(SIXTY_FOUR_BIT_INTEGERS) && defined(NO_LONG_LONG_TYPE)

SHARED_OK static Scheme_Object *num_limits[3];

#ifdef SCHEME_BIG_ENDIAN

# define MZ_IS_BIG_ENDIAN 1

# define MZ_IS_BIG_ENDIAN 0

#define TO_DOUBLE scheme_TO_DOUBLE

#define zeroi scheme_exact_zero

void scheme_init_numstr(Scheme_Env *env)

{

scheme_add_global_constant("number->string",

scheme_make_immed_prim(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_immed_prim(bytes_to_integer,

"integer-bytes->integer",

2, 5),

env);

scheme_add_global_constant("integer->integer-bytes",

scheme_make_immed_prim(integer_to_bytes,

"integer->integer-bytes",

3, 6),

env);

scheme_add_global_constant("floating-point-bytes->real",

scheme_make_immed_prim(bytes_to_real,

"floating-point-bytes->real",

1, 4),

env);

scheme_add_global_constant("real->floating-point-bytes",

scheme_make_immed_prim(real_to_bytes,

"real->floating-point-bytes",

2, 5),

env);

scheme_add_global_constant("system-big-endian?",

scheme_make_immed_prim(system_big_endian_p,

"system-big-endian?",

0, 0),

env);

scheme_add_global_constant("random",

scheme_make_immed_prim(sch_random,

"random",

0, 2),

env);

scheme_add_global_constant("random-seed",

scheme_make_immed_prim(random_seed,

"random-seed",

1, 1),

env);

scheme_add_global_constant("make-pseudo-random-generator",

scheme_make_immed_prim(make_pseudo_random_generator,

"make-pseudo-random-generator",

0, 0),

env);

scheme_add_global_constant("vector->pseudo-random-generator",

scheme_make_immed_prim(sch_pack,

"vector->pseudo-random-generator",

1, 1),

env);

scheme_add_global_constant("vector->pseudo-random-generator!",

scheme_make_immed_prim(sch_pack_bang,

"vector->pseudo-random-generator!",

2, 2),

env);

scheme_add_global_constant("pseudo-random-generator->vector",

scheme_make_immed_prim(sch_unpack,

"pseudo-random-generator->vector",

1, 1),

env);

scheme_add_global_constant("pseudo-random-generator-vector?",

scheme_make_immed_prim(sch_check_pack,

"pseudo-random-generator-vector?",

1, 1),

env);

scheme_add_global_constant("pseudo-random-generator?",

scheme_make_immed_prim(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);

#if !defined(SIXTY_FOUR_BIT_INTEGERS) && defined(NO_LONG_LONG_TYPE)

REGISTER_SO(num_limits);

{

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;

}

}

void scheme_init_extfl_numstr(Scheme_Env *env)

{

scheme_add_global_constant("floating-point-bytes->extfl",

scheme_make_immed_prim(bytes_to_long_double,

"floating-point-bytes->extfl",

1, 4),

env);

scheme_add_global_constant("extfl->floating-point-bytes",

scheme_make_immed_prim(long_double_to_bytes,

"extfl->floating-point-bytes",

1, 4),

env);

}

# ifdef SIN_COS_NEED_DEOPTIMIZE

# pragma optimize("g", off)

# define MK_SCH_TRIG(SCH_TRIG, c_trig) static double SCH_TRIG(double d) { return c_trig(d); }

MK_SCH_TRIG(SCH_SIN, sin)

MK_SCH_TRIG(SCH_COS, cos)

# pragma optimize("g", on)

# define SCH_SIN sin

# define SCH_COS cos

#ifndef MZ_LONG_DOUBLE

static Scheme_Object *wrap_as_long_double(const char *s, int radix)

{

Scheme_Long_Double *d;

d = MALLOC_ONE_TAGGED(Scheme_Long_Double);

d->so.type = scheme_long_double_type;

if (radix == 10)

d->printed_form = s;

else {

char *s2;

intptr_t len;

len = strlen(s);

s2 = (char *)scheme_malloc_atomic(len + 3);

memcpy(s2 + 2, s, len+1);

s2[0] = '#';

s2[1] = ((radix == 8)

? 'o'

: ((radix == 2)

? 'b'

: 'x'));

d->printed_form = s2;

}

return (Scheme_Object *)d;

}

Scheme_Object *make_any_long_double()

{

#ifdef MZ_LONG_DOUBLE

return scheme_make_long_double(get_long_double_zero());

return wrap_as_long_double("1t0", 10);

}

static int u_strcmp(mzchar *s, const char *t)

{

int i;

for (i = 0; s[i] && (s[i] == ((unsigned char *)t)[i]); i++) {

}

if (s[i] || t[i])

return 1;

return 0;

}

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

{

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;

return scheme_inf_object;

}

else if (!u_strcmp(s, minus_infinity_str)) {

#ifdef USE_SINGLE_FLOATS_AS_DEFAULT

return scheme_single_minus_inf_object;

return scheme_minus_inf_object;

}

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;

}

else if (!u_strcmp(s, long_infinity_str)) {

#ifdef MZ_LONG_DOUBLE

return scheme_long_inf_object;

return wrap_as_long_double(long_infinity_str, 10);

}

else if (!u_strcmp(s, long_minus_infinity_str)) {

#ifdef MZ_LONG_DOUBLE

return scheme_long_minus_inf_object;

return wrap_as_long_double(long_minus_infinity_str, 10);

}

else if (!u_strcmp(s, long_not_a_number_str)

|| !u_strcmp(s, long_other_not_a_number_str)) {

#ifdef MZ_LONG_DOUBLE

return scheme_long_nan_object;

return wrap_as_long_double(long_not_a_number_str, 10);

}

/* Single-precision specials

else if (!u_strcmp(s, single_infinity_str)) {

#ifdef MZ_USE_SINGLE_FLOATS

return scheme_single_inf_object;

return scheme_inf_object;

}

else if (!u_strcmp(s, single_minus_infinity_str)) {

#ifdef MZ_USE_SINGLE_FLOATS

return scheme_single_minus_inf_object;

return scheme_minus_inf_object;

}

else if (!u_strcmp(s, single_not_a_number_str)

|| !u_strcmp(s, single_other_not_a_number_str)) {

#ifdef MZ_USE_SINGLE_FLOATS

return scheme_single_nan_object;

return scheme_nan_object;

}

}

return NULL;

}

#define CHECK_INF_EXP_THRESHOLD(extfl) (extfl ? 6000 : 400)

#define MAX_FLOATREAD_PRECISION_DIGITS(extfl) CHECK_INF_EXP_THRESHOLD(extfl)

#ifdef USE_EXPLICT_FP_FORM_CHECK

# ifdef MZ_XFORM

END_XFORM_ARITH;

static double STRTOD(const char *orig_c, char **f, int extfl)

{

int neg = 0;

int found_dot = 0, is_infinity = 0, is_zero = 0;

const char *c = orig_c;

*f = (char *)c;

if (*c == '-') {

c++;

neg = 1;

} else if (*c == '+') {

c++;

}

if (!isdigit((unsigned char)*c)) {

if (*c == '.') {

if (!isdigit((unsigned char)c[1]))

return 0; /* no digits - bad! */

} else

return 0; /* no digits - bad! */

}

for (; *c; c++) {

int ch = *c;

if (isdigit(ch)) {

/* ok */

} else if ((ch == 'e') || (ch == 'E')) {

int e = 0, neg_exp = 0;

c++;

if (*c == '-') {

c++;

neg_exp = 1;

} else if (*c == '+') {

c++;

}

if (!isdigit((unsigned char)*c))

return 0; /* no digits - bad! */

for (; *c; c++) {

int ch = *c;

if (!isdigit(ch))

return 0; /* not a digit - bad! */

else {

e = (e * 10) + (ch - '0');

if (e > CHECK_INF_EXP_THRESHOLD(extfl)) {

if (neg_exp)

is_zero = 1;

else

is_infinity = 1;

}

}

}

break;

} else if (ch == '.') {

if (found_dot)

return 0; /* two dots - shouldn't happen */

found_dot = 1;

} else

return 0; /* unknown non-digit - shouldn't happen */

}

*f = (char *)c;

#ifdef MZ_LONG_DOUBLE

if (is_infinity) {

if (neg)

return scheme_long_minus_infinity_val;

else

return scheme_long_infinity_val;

}

if (is_zero) {

if (neg)

return scheme_long_floating_point_nzero;

else

return scheme_long_floating_point_zero;

}

/* It's OK if c is ok: */

return strtold(orig_c, NULL);

if (is_infinity) {

if (neg)

return scheme_minus_infinity_val;

else

return scheme_infinity_val;

}

if (is_zero) {

if (neg)

return scheme_floating_point_nzero;

else

return scheme_floating_point_zero;

}

/* It's OK if c is ok: */

return strtod(orig_c, NULL);

}

# ifdef MZ_XFORM_GC

START_XFORM_ARITH;

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

static Scheme_Object *CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl)

{

if (SCHEME_DBLP(v)) {

#ifdef MZ_USE_SINGLE_FLOATS

if (s)

return scheme_make_float((float)SCHEME_DBL_VAL(v));

}

return v;

}

#define DISALLOW_EXTFLONUM(special, other) \

if ((special && SCHEME_LONG_DBLP(special)) || (other && SCHEME_LONG_DBLP(other))) { \

if (report) \

scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation, \

"read: cannot combine extflonum into complex number: %u", \

str, len); \

return scheme_false; \

}

Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,

Scheme_Object *indentation)

{

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_since_slash, saw_nonzero_digit;

Scheme_Object *o;

#ifdef MZ_USE_SINGLE_FLOATS

int sgl;

int is_long_double = 0;

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: 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: 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: 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: 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: 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] = (SCHEME_DBLP(special) ? '.' : 's');

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] = (SCHEME_DBLP(special) ? '.' : 's');

s2[len - delta - 7 + 3] = '0';

s2[len - delta - 7 + 4] = 'i';

s2[len - delta - 7 + 5] = 0;

if (!SCHEME_LONG_DBLP(special))

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: 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);

DISALLOW_EXTFLONUM(special, other);

if (dbz) {

if (div_by_zero)

*div_by_zero = 1;

if (complain)

scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,

"read: 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: no exact representation for %V",

special);

return scheme_false;

}

DISALLOW_EXTFLONUM(special, special);

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);

DISALLOW_EXTFLONUM(special, other);

if (dbz) {

if (div_by_zero)

*div_by_zero = 1;

if (complain)

scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,

"read: 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') \

|| (ch == 't') || (ch == 'T'))

#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: 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: 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: 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: `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: 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: `@' 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;

}

DISALLOW_EXTFLONUM(n1, n2);

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: 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));

}

second = str + has_at + 1;

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);