Back to index

plt-scheme  4.2.1
numstr.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 2000-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 /* The bulk of this file is the number parser, an insane bit of code
00027    that would probably be better off implemented via lex+yacc, except
00028    the error messages are better this way.
00029 
00030    Also, for no particularly good reason, random-number support is
00031    here, though the real work is in random.inc (from FreeBSD). */
00032 
00033 #include "schpriv.h"
00034 #include <math.h>
00035 #include <string.h>
00036 #include <ctype.h>
00037 
00038 static Scheme_Object *number_to_string (int argc, Scheme_Object *argv[]);
00039 static Scheme_Object *string_to_number (int argc, Scheme_Object *argv[]);
00040 
00041 static Scheme_Object *bytes_to_integer (int argc, Scheme_Object *argv[]);
00042 static Scheme_Object *integer_to_bytes (int argc, Scheme_Object *argv[]);
00043 static Scheme_Object *bytes_to_real (int argc, Scheme_Object *argv[]);
00044 static Scheme_Object *real_to_bytes (int argc, Scheme_Object *argv[]);
00045 static Scheme_Object *system_big_endian_p (int argc, Scheme_Object *argv[]);
00046 
00047 static Scheme_Object *random_seed(int argc, Scheme_Object *argv[]);
00048 static Scheme_Object *sch_random(int argc, Scheme_Object *argv[]);
00049 static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv);
00050 static Scheme_Object *current_pseudo_random_generator(int argc, Scheme_Object **argv);
00051 static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object **argv);
00052 static Scheme_Object *pseudo_random_generator_p(int argc, Scheme_Object **argv);
00053 static Scheme_Object *sch_unpack(int argc, Scheme_Object *argv[]);
00054 static Scheme_Object *sch_pack(int argc, Scheme_Object *argv[]);
00055 static Scheme_Object *sch_pack_bang(int argc, Scheme_Object *argv[]);
00056 
00057 static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc);
00058 
00059 static char *infinity_str = "+inf.0";
00060 static char *minus_infinity_str = "-inf.0";
00061 static char *not_a_number_str = "+nan.0";
00062 static char *other_not_a_number_str = "-nan.0";
00063 
00064 static Scheme_Object *num_limits[3];
00065 
00066 #ifdef SCHEME_BIG_ENDIAN
00067 # define MZ_IS_BIG_ENDIAN 1
00068 #else
00069 # define MZ_IS_BIG_ENDIAN 0
00070 #endif
00071 
00072 #define TO_DOUBLE scheme_TO_DOUBLE
00073 
00074 #define zeroi scheme_exact_zero
00075 
00076 void scheme_init_numstr(Scheme_Env *env)
00077 {
00078   scheme_add_global_constant("number->string", 
00079                           scheme_make_prim_w_arity(number_to_string,
00080                                                 "number->string",
00081                                                 1, 2),
00082                           env);
00083   scheme_add_global_constant("string->number", 
00084                           scheme_make_folding_prim(string_to_number,
00085                                                 "string->number", 
00086                                                 1, 2, 1),
00087                           env);
00088 
00089   scheme_add_global_constant("integer-bytes->integer", 
00090                           scheme_make_prim_w_arity(bytes_to_integer,
00091                                                 "integer-bytes->integer", 
00092                                                 2, 5),
00093                           env);
00094   scheme_add_global_constant("integer->integer-bytes", 
00095                           scheme_make_prim_w_arity(integer_to_bytes,
00096                                                 "integer->integer-bytes", 
00097                                                 3, 6),
00098                           env);
00099   scheme_add_global_constant("floating-point-bytes->real", 
00100                           scheme_make_prim_w_arity(bytes_to_real,
00101                                                 "floating-point-bytes->real",
00102                                                 1, 4),
00103                           env);
00104   scheme_add_global_constant("real->floating-point-bytes",
00105                           scheme_make_prim_w_arity(real_to_bytes,
00106                                                 "real->floating-point-bytes",
00107                                                 2, 5),
00108                           env);
00109   scheme_add_global_constant("system-big-endian?",
00110                           scheme_make_prim_w_arity(system_big_endian_p,
00111                                                 "system-big-endian?",
00112                                                 0, 0),
00113                           env);
00114 
00115   scheme_add_global_constant("random", 
00116                           scheme_make_prim_w_arity(sch_random,
00117                                                 "random",
00118                                                 0, 2),
00119                           env);
00120   scheme_add_global_constant("random-seed", 
00121                           scheme_make_prim_w_arity(random_seed,
00122                                                 "random-seed",
00123                                                 1, 1),
00124                           env);
00125   scheme_add_global_constant("make-pseudo-random-generator", 
00126                           scheme_make_prim_w_arity(make_pseudo_random_generator,
00127                                                 "make-pseudo-random-generator", 
00128                                                 0, 0), 
00129                           env);
00130   scheme_add_global_constant("vector->pseudo-random-generator",
00131                           scheme_make_prim_w_arity(sch_pack,
00132                                                 "vector->pseudo-random-generator", 
00133                                                 1, 1), 
00134                           env);
00135   scheme_add_global_constant("vector->pseudo-random-generator!",
00136                           scheme_make_prim_w_arity(sch_pack_bang,
00137                                                 "vector->pseudo-random-generator!", 
00138                                                 2, 2), 
00139                           env);
00140   scheme_add_global_constant("pseudo-random-generator->vector",
00141                           scheme_make_prim_w_arity(sch_unpack,
00142                                                 "pseudo-random-generator->vector", 
00143                                                 1, 1), 
00144                           env);
00145   scheme_add_global_constant("pseudo-random-generator?", 
00146                           scheme_make_prim_w_arity(pseudo_random_generator_p,
00147                                                 "pseudo-random-generator?", 
00148                                                 1, 1), 
00149                           env);
00150   scheme_add_global_constant("current-pseudo-random-generator", 
00151                           scheme_register_parameter(current_pseudo_random_generator,
00152                                                  "current-pseudo-random-generator",
00153                                                  MZCONFIG_RANDOM_STATE),
00154                           env);
00155   scheme_add_global_constant("current-evt-pseudo-random-generator", 
00156                           scheme_register_parameter(current_sched_pseudo_random_generator,
00157                                                  "current-evt-pseudo-random-generator",
00158                                                  MZCONFIG_SCHEDULER_RANDOM_STATE),
00159                           env);
00160 
00161   REGISTER_SO(num_limits);
00162 }
00163 
00164 # ifdef SIN_COS_NEED_DEOPTIMIZE
00165 #  pragma optimize("g", off)
00166 #  define MK_SCH_TRIG(SCH_TRIG, c_trig) static double SCH_TRIG(double d) { return c_trig(d); }
00167 MK_SCH_TRIG(SCH_SIN, sin)
00168 MK_SCH_TRIG(SCH_COS, cos)
00169 #  pragma optimize("g", on)
00170 # else
00171 #  define SCH_SIN sin
00172 #  define SCH_COS cos
00173 # endif
00174 
00175 /*========================================================================*/
00176 /*                           number parsing                               */
00177 /*========================================================================*/
00178 
00179 static int u_strcmp(mzchar *s, char *t)
00180 {
00181   int i;
00182 
00183   for (i = 0; s[i] && (s[i] == ((unsigned char *)t)[i]); i++) {
00184   }
00185   if (s[i] || t[i])
00186     return 1;
00187   return 0;
00188 }
00189 
00190 static Scheme_Object *read_special_number(const mzchar *str, int pos)
00191 {
00192   if ((str[pos] == '-' || str[pos] == '+') && scheme_isalpha(str[pos + 1])) {
00193     mzchar s[7];
00194     int i;
00195 
00196     for (i = 0; i < 6; i++) {
00197       s[i] = scheme_tolower(str[i + pos]);
00198     }
00199     s[i] = 0;
00200 
00201     if (!u_strcmp(s, infinity_str)) {
00202 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
00203       return scheme_single_inf_object;
00204 #else
00205       return scheme_inf_object;
00206 #endif
00207     }
00208     else if (!u_strcmp(s, minus_infinity_str)) {
00209 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
00210       return scheme_single_minus_inf_object;
00211 #else
00212       return scheme_minus_inf_object;
00213 #endif
00214     }
00215     else if (!u_strcmp(s, not_a_number_str)
00216             || !u_strcmp(s, other_not_a_number_str)) {
00217 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
00218       return scheme_single_nan_object;
00219 #else      
00220       return scheme_nan_object;
00221 #endif
00222     }
00223   }
00224 
00225   return NULL;
00226 }
00227 
00228 /* Don't bother reading more than the following number of digits in a
00229    floating-point mantissa: */
00230 #define MAX_FLOATREAD_PRECISION_DIGITS 50
00231 
00232 /* We'd like to use strtod() for the common case, but we don't trust
00233    it entirely. */
00234 #define MAX_FAST_FLOATREAD_LEN 50
00235 static char ffl_buf[MAX_FAST_FLOATREAD_LEN + 1];
00236 
00237 /* Exponent threshold for obvious infinity. Must be at least
00238    max(MAX_FAST_FLOATREAD_LEN, MAX_FLOATREAD_PRECISION_DIGITS) more
00239    than the larget possible FP exponent. */
00240 #define CHECK_INF_EXP_THRESHOLD 400
00241 
00242 #ifdef USE_EXPLICT_FP_FORM_CHECK
00243 
00244 /* Fixes Linux problem of 0e...  => non-number (0 with ptr at e...) */
00245 /* Fixes SunOS problem with numbers like .3e2666666666666 => 0.0 */
00246 /* Fixes HP/UX problem with numbers like .3e2666666666666 => non-number */
00247 
00248 # ifdef MZ_XFORM
00249 END_XFORM_ARITH;
00250 # endif
00251 
00252 static double STRTOD(const char *orig_c, char **f)
00253 {
00254   int neg = 0;
00255   int found_dot = 0, is_infinity = 0, is_zero = 0;
00256   const char *c = orig_c;
00257 
00258   *f = (char *)c;
00259 
00260   if (*c == '-') {
00261     c++;
00262     neg = 1;
00263   } else if (*c == '+') {
00264     c++;
00265   }
00266 
00267   if (!isdigit((unsigned char)*c)) {
00268     if (*c == '.') {
00269       if (!isdigit((unsigned char)c[1]))
00270        return 0; /* no digits - bad! */
00271     } else
00272       return 0; /* no digits - bad! */
00273   }
00274 
00275   for (; *c; c++) {
00276     int ch = *c;
00277 
00278     if (isdigit(ch)) {
00279       /* ok */
00280     } else if ((ch == 'e') || (ch == 'E')) {
00281       int e = 0, neg_exp = 0;
00282 
00283       c++;
00284       if (*c == '-') {
00285        c++;
00286        neg_exp = 1;
00287       } else if (*c == '+') {
00288        c++;
00289       }
00290       if (!isdigit((unsigned char)*c))
00291        return 0; /* no digits - bad! */
00292 
00293       for (; *c; c++) {
00294        int ch = *c;
00295        if (!isdigit(ch))
00296          return 0; /* not a digit - bad! */
00297        else {
00298          e = (e * 10) + (ch - '0');
00299          if (e > CHECK_INF_EXP_THRESHOLD) {
00300            if (neg_exp)
00301              is_zero  = 1;
00302            else
00303              is_infinity  = 1;
00304          }
00305        }
00306       }
00307 
00308       break;
00309     } else if (ch == '.') {
00310       if (found_dot)
00311        return 0; /* two dots - shouldn't happen */
00312       found_dot = 1;
00313     } else
00314       return 0; /* unknown non-digit - shouldn't happen */
00315   }
00316   
00317   *f = (char *)c;
00318 
00319   if (is_infinity) {
00320     if (neg)
00321       return scheme_minus_infinity_val;
00322     else
00323       return scheme_infinity_val;
00324   }
00325 
00326   if (is_zero) {
00327     if (neg)
00328       return scheme_floating_point_nzero;
00329     else
00330       return scheme_floating_point_zero;
00331   }
00332 
00333   /* It's OK if c is ok: */
00334   return strtod(orig_c, NULL);
00335 }
00336 # ifdef MZ_XFORM_GC
00337 START_XFORM_ARITH;
00338 # endif
00339 #else
00340 #define STRTOD(x, y) strtod(x, y)
00341 #endif
00342 
00343 #ifdef MZ_USE_SINGLE_FLOATS
00344 static Scheme_Object *CHECK_SINGLE(Scheme_Object *v, int s)
00345 {
00346   if (s && SCHEME_DBLP(v))
00347     return scheme_make_float((float)SCHEME_DBL_VAL(v));
00348   else
00349     return v;
00350 }
00351 #else
00352 # define CHECK_SINGLE(v, s) v
00353 #endif
00354 
00355 Scheme_Object *scheme_read_number(const mzchar *str, long len,
00356                               int is_float, 
00357                               int is_not_float,
00358                               int decimal_means_float,
00359                               int radix, int radix_set, 
00360                               Scheme_Object *complain,
00361                               int *div_by_zero,
00362                               int test_only,
00363                               Scheme_Object *stxsrc, long line, long col, long pos, long span,
00364                               Scheme_Object *indentation)
00365 {
00366   int i, has_decimal, must_parse, has_slash;
00367   int report, delta;
00368   Scheme_Object *next_complain;
00369   int has_hash, has_expt, has_i, has_sign, has_at, has_hash_since_slash;
00370   int saw_digit, saw_digit_since_slash, saw_nonzero_digit;
00371   Scheme_Object *o;
00372 #ifdef MZ_USE_SINGLE_FLOATS
00373   int single;
00374 #endif
00375 
00376   if (len < 0)
00377     len = scheme_char_strlen(str);
00378 
00379   delta = 0;
00380 
00381   while (str[delta] == '#') {
00382     if (str[delta+1] != 'E' && str[delta+1] != 'e' && str[delta+1] != 'I' && str[delta+1] != 'i') {
00383       if (radix_set) {
00384        if (complain)
00385          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00386                        "read-number: bad radix specification: %u",
00387                        str, len);
00388        else
00389          return scheme_false;
00390       }
00391       radix_set = 1;
00392     } else {
00393       if (is_float || is_not_float) {
00394        if (complain)
00395          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00396                        "read-number: bad exactness specification: %u", 
00397                        str, len);
00398        else
00399          return scheme_false;
00400       }
00401     }
00402 
00403     switch (str[delta+1]) {
00404     case 'B':
00405     case 'b':
00406       radix = 2;
00407       break;
00408     case 'O':
00409     case 'o':
00410       radix = 8;
00411       break;
00412     case 'D':
00413     case 'd':
00414       radix = 10;
00415       break;
00416     case 'X':
00417     case 'x':
00418       radix = 16;
00419       break;
00420     case 'I':
00421     case 'i':
00422       is_float = 1;
00423       break;
00424     case 'E':
00425     case 'e':
00426       is_not_float = 1;
00427       break;
00428     default:
00429       if (complain)
00430        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00431                      "read-number: bad `#' indicator `%c': %u",
00432                      str[delta+1], str, len);
00433       return scheme_false;
00434     }
00435     delta += 2;
00436   }
00437 
00438   must_parse = (radix_set || is_float || is_not_float);
00439 
00440   report = complain && must_parse;
00441   next_complain = must_parse ? complain : NULL;
00442 
00443   if (!(len - delta)) {
00444     if (report)
00445       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00446                     "read-number: no digits");
00447     return scheme_false;
00448   }
00449 
00450   /* look for +inf.0, etc: */
00451   if (len -delta == 6) {
00452     Scheme_Object *special;
00453     special = read_special_number(str, delta);
00454     if (special) {
00455       if (!is_not_float)
00456        return special;
00457       if (report)
00458        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00459                      "read-number: no exact representation for %V",
00460                      special);
00461       return scheme_false;
00462     }
00463   }
00464 
00465   /* Look for <special>+...i and ...<special>i */
00466   if ((len-delta > 7) && str[len-1] == 'i') {
00467     Scheme_Object *special;
00468     mzchar *s2;
00469     
00470     /* Try <special>+...i */
00471     special = read_special_number(str, delta);
00472     if (special) {
00473       s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6 + 4 + 1) * sizeof(mzchar));
00474       s2[0] = '+';
00475       s2[1] = '0';
00476       s2[2] = '.';
00477       s2[3] = '0';
00478       memcpy(s2 + 4, str + delta + 6, (len - delta - 5) * sizeof(mzchar));
00479     } else {
00480       /* Try ...<special>i: */
00481       special = read_special_number(str, len - 7);
00482       if (special) {
00483        s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6 + 4 + 1) * sizeof(mzchar));
00484        memcpy(s2, str + delta, (len - delta - 7) * sizeof(mzchar));
00485        s2[len - delta - 7] = '+';
00486        s2[len - delta - 7 + 1] = '0';
00487        s2[len - delta - 7 + 2] = '.';
00488        s2[len - delta - 7 + 3] = '0';
00489        s2[len - delta - 7 + 4] = 'i';
00490        s2[len - delta - 7 + 5] = 0;
00491        special = scheme_bin_mult(special, scheme_plus_i);
00492       } else
00493        s2 = NULL;
00494     }
00495 
00496     if (special) {
00497       Scheme_Object *other;
00498       int dbz = 0;
00499 
00500       if (is_not_float) {
00501        if (report)
00502          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00503                        "read-number: no exact representation for %V",
00504                        special);
00505        return scheme_false;
00506       }
00507 
00508       other = scheme_read_number(s2, len - delta - 6 + 4,
00509                              is_float, is_not_float, 1,
00510                              radix, 1, 0,
00511                              &dbz, test_only,
00512                              stxsrc, line, col, pos, span,
00513                              indentation);
00514 
00515       if (dbz) {
00516        if (div_by_zero)
00517          *div_by_zero = 1;
00518        if (complain)
00519          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00520                        "read-number: division by zero: %u",
00521                        str, len);
00522        return scheme_false;
00523       }
00524 
00525       if (!SCHEME_FALSEP(other))
00526        return scheme_bin_plus(special, other);
00527       
00528       if (!complain)
00529        return scheme_false;
00530     }
00531   } else if ((len-delta == 7) && str[len-1] == 'i') {
00532     /* Try <special>i */
00533     Scheme_Object *special;
00534     special = read_special_number(str, delta);
00535     if (special) {
00536       special = scheme_make_complex(scheme_make_integer(0), special);
00537 
00538       if (is_not_float) {
00539        if (report)
00540          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00541                        "read-number: no exact representation for %V",
00542                        special);
00543        return scheme_false;
00544       }
00545 
00546       return special;
00547     }
00548   }
00549 
00550   /* Look for <special>@... and ...@<special> */
00551   if ((len - delta > 7) && ((str[delta+6] == '@') || (str[len - 7] == '@'))) {
00552     Scheme_Object *special;
00553     mzchar *s2;
00554     int spec_mag = 0;
00555 
00556     /* Try <special>@... */
00557     if (str[delta+6] == '@')
00558       special = read_special_number(str, delta);
00559     else
00560       special = NULL;
00561     if (special) {
00562       s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6) * sizeof(mzchar));
00563       memcpy(s2, str + delta + 7, (len - delta - 6) * sizeof(mzchar));
00564       spec_mag = 1;
00565     } else {
00566       if (str[len - 7] == '@')
00567        special = read_special_number(str, len - 6);
00568       else
00569        special = NULL;
00570       
00571       if (special) {
00572        s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6) * sizeof(mzchar));
00573        memcpy(s2, str + delta, (len - delta - 7) * sizeof(mzchar));
00574        s2[len - delta - 7] = 0;
00575       } else
00576        s2 = NULL;
00577     }
00578 
00579     if (special) {
00580       Scheme_Object *other;
00581       int dbz = 0;
00582 
00583       /* s2 can't contain @: */
00584       for (i = 0; s2[i]; i++) {
00585        if (s2[i] == '@')
00586          break;
00587       }
00588 
00589       if (s2[i])
00590        other = scheme_false;
00591       else
00592        other = scheme_read_number(s2, len - delta - 7,
00593                                is_float, is_not_float, 1,
00594                                radix, 1, 0,
00595                                &dbz, test_only,
00596                                stxsrc, line, col, pos, span,
00597                                indentation);
00598 
00599       if (dbz) {
00600        if (div_by_zero)
00601          *div_by_zero = 1;
00602        if (complain)
00603          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00604                        "read-number: division by zero: %u", 
00605                        str, len);
00606        return scheme_false;
00607       }
00608 
00609       if (!SCHEME_FALSEP(other)) {
00610        /* If string is complex, not well-formed: */
00611        if (!SCHEME_COMPLEXP(other)) {
00612          Scheme_Object *a[2];
00613          if (spec_mag) {
00614            a[0] = special;
00615            a[1] = other;
00616          } else {
00617            a[0] = other;
00618            a[1] = special;
00619          }
00620 
00621          return scheme_make_polar(2, a);
00622        }
00623       }
00624 
00625       if (!complain)
00626        return scheme_false;
00627     }
00628   }
00629       
00630 #define isinexactmark(ch) ((ch == 'e') || (ch == 'E') \
00631                         || (ch == 's') || (ch == 'S') \
00632                         || (ch == 'f') || (ch == 'F') \
00633                         || (ch == 'd') || (ch == 'D') \
00634                         || (ch == 'l') || (ch == 'L'))
00635 
00636 #define isAdigit(ch) ((ch >= '0') && (ch <= '9'))
00637 
00638 
00639 #define isbaseNdigit(N, ch) (((ch >= 'a') && (ch <= (mzchar)('a' + N - 11))) \
00640                              || ((ch >= 'A') && (ch <= (mzchar)('A' + N - 11))))
00641 
00642   has_i = 0;
00643   has_at = 0;
00644   has_sign = delta-1;
00645   for (i = delta; i < len; i++) {
00646     mzchar ch = str[i];
00647     if (!ch) {
00648       if (report)
00649        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00650                      "read-number: embedded null character: %u",
00651                      str, len);
00652       return scheme_false;
00653     } else if (isinexactmark(ch) && ((radix <= 10) || !isbaseNdigit(radix, ch))) {
00654       /* If a sign follows, don't count it */
00655       if (str[i+1] == '+' || str[i+1] == '-')
00656        i++;
00657     } else if ((ch == '+') || (ch == '-')) {
00658       if ((has_sign > delta) || ((has_sign == delta) && (i == delta+1))) {
00659        if (report)
00660          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00661                         "read-number: too many signs: %u", 
00662                         str, len);
00663        return scheme_false;
00664       }
00665       has_sign = i;
00666     } else if (((ch == 'I') || (ch == 'i')) && (has_sign >= delta)) {
00667       if (has_at) {
00668        if (report)
00669          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00670                        "read-number: cannot mix `@' and `i': %u", 
00671                        str, len);
00672        return scheme_false;
00673       }
00674       if (i + 1 < len) {
00675        if (report)
00676          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00677                        "read-number: `i' must be at the end: %u", 
00678                        str, len);
00679        return scheme_false;
00680       }
00681       has_i = i;
00682     } else if (ch == '@') {
00683       if (has_at) {
00684        if (report)
00685          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00686                        "read-number: too many `@'s: %u", 
00687                        str, len);
00688        return scheme_false;
00689       }
00690       if (i == delta) {
00691        if (report)
00692          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00693                        "read-number: `@' cannot be at start: %u", 
00694                        str, len);
00695        return scheme_false;
00696       }
00697       has_at = i;
00698       if (has_sign >= delta)
00699        has_sign = delta-1;
00700     }
00701   }
00702 
00703   if (has_i) {
00704     Scheme_Object *n1, *n2;
00705     mzchar *first, *second;
00706     int fdbz = 0, sdbz = 0;
00707 
00708     if (has_sign != delta) {
00709       first = (mzchar *)scheme_malloc_atomic((has_sign - delta + 1) * sizeof(mzchar));
00710       memcpy(first, str + delta, (has_sign - delta) * sizeof(mzchar));
00711       first[has_sign - delta] = 0;
00712     } else
00713       first = NULL;
00714 
00715     if (has_i - has_sign > 1) {
00716       second = (mzchar *)scheme_malloc_atomic((has_i - has_sign + 1) * sizeof(mzchar));
00717       memcpy(second, str + has_sign, (has_i - has_sign) * sizeof(mzchar));
00718       second[has_i - has_sign] = 0;
00719     } else
00720       second = NULL;
00721 
00722     if (first)
00723       n1 = scheme_read_number(first, has_sign - delta,
00724                            is_float, is_not_float, decimal_means_float,
00725                            radix, 1, next_complain,
00726                            &fdbz, test_only,
00727                            stxsrc, line, col, pos, span,
00728                            indentation);
00729     else
00730       n1 = zeroi;
00731 
00732     if (SAME_OBJ(n1, scheme_false) && !fdbz)
00733       return scheme_false;
00734     /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
00735     else if (SCHEME_FLOATP(n1)) {
00736       double d = SCHEME_FLOAT_VAL(n1);
00737       if (MZ_IS_NAN(d))
00738        return scheme_false;
00739     }
00740     
00741     if (second)
00742       n2 = scheme_read_number(second, has_i - has_sign,
00743                            is_float, is_not_float, decimal_means_float,
00744                            radix, 1, next_complain,
00745                            &sdbz, test_only,
00746                            stxsrc, line, col, pos, span,
00747                            indentation);
00748     else if (str[has_sign] == '-')
00749       n2 = scheme_make_integer(-1);
00750     else
00751       n2 = scheme_make_integer(1);
00752     
00753     if (SAME_OBJ(n2, scheme_false) && !sdbz)
00754       return scheme_false;
00755     /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
00756     else if (SCHEME_FLOATP(n2)) {
00757       double d = SCHEME_FLOAT_VAL(n2);
00758       if (MZ_IS_NAN(d))
00759        return scheme_false;
00760     }
00761 
00762     if (fdbz || sdbz) {
00763       if (div_by_zero)
00764        *div_by_zero = 1;
00765       if (complain)
00766        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00767                       "read-number: division by zero: %u", 
00768                       str, len);
00769       return scheme_false;
00770     }
00771 
00772     if (!is_not_float && ((SCHEME_FLOATP(n1) && (n2 != zeroi)) || is_float))
00773       n2 = scheme_exact_to_inexact(1, &n2);  /* uses default conversion: float or double */
00774     else if (is_not_float)
00775       n2 = scheme_inexact_to_exact(1, &n2);
00776 
00777     if (!is_not_float && ((SCHEME_FLOATP(n2) && (n1 != zeroi)) || is_float))
00778       n1 = scheme_exact_to_inexact(1, &n1); /* uses default conversion: float or double */
00779     else if (is_not_float)
00780       n1 = scheme_inexact_to_exact(1, &n1);
00781 
00782     return scheme_make_complex(n1, n2);
00783   }
00784 
00785   if (has_at) {
00786     Scheme_Object *n1, *n2;
00787     double d1, d2, r1, r2;
00788     mzchar *first;
00789     const mzchar *second;
00790     int fdbz = 0, sdbz = 0;
00791 
00792     first = (mzchar *)scheme_malloc_atomic((has_at - delta + 1) * sizeof(mzchar));
00793     memcpy(first, str + delta, (has_at - delta) * sizeof(mzchar));
00794     first[has_at - delta] = 0;
00795 
00796 #ifdef MZ_PRECISE_GC
00797     {
00798       /* Can't pass mis-aligned pointer to scheme_read_number. */
00799       int slen = len - (has_at + 1) + 1;
00800       second = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
00801       memcpy((mzchar *)second, str + has_at + 1, slen * sizeof(mzchar));
00802     }
00803 #else
00804     second = str + has_at + 1;
00805 #endif
00806 
00807     n2 = scheme_read_number(second, len - has_at - 1,
00808                          is_float, is_not_float, decimal_means_float,
00809                          radix, 1, next_complain,
00810                          &fdbz, test_only,
00811                          stxsrc, line, col, pos, span,
00812                          indentation);
00813 
00814     if (!fdbz) {
00815       if (SCHEME_FALSEP(n2))
00816        return scheme_false;
00817 
00818       /* Special case: angle is zero => real number */
00819       if (n2 == zeroi)
00820        return scheme_read_number(first, has_at - delta,
00821                               is_float, is_not_float, decimal_means_float,
00822                               radix, 1, complain,
00823                               div_by_zero,
00824                               test_only,
00825                               stxsrc, line, col, pos, span,
00826                               indentation);
00827 
00828       n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */
00829 
00830       d2 = SCHEME_FLOAT_VAL(n2);
00831       
00832       /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
00833       if (MZ_IS_NAN(d2))
00834        return scheme_false;
00835 
00836       n1 = scheme_read_number(first, has_at - delta, 
00837                            is_float, is_not_float, decimal_means_float,
00838                            radix, 1, next_complain,
00839                            &sdbz,
00840                            test_only,
00841                            stxsrc, line, col, pos, span,
00842                            indentation);
00843 
00844       /* Special case: magnitude is zero => zero */
00845       if (n1 == zeroi)
00846        return zeroi;
00847 
00848       if (!SCHEME_FALSEP(n1))
00849        n1 = scheme_exact_to_inexact(1, &n1); /* uses default conversion: float or double */
00850     } else {
00851       n1 = NULL;
00852       d2 = 0;
00853     }
00854 
00855     if (fdbz || sdbz) {
00856       if (div_by_zero)
00857        *div_by_zero = 1;
00858       if (complain)
00859        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00860                      "read-number: division by zero in %u", 
00861                      str, len);
00862       return scheme_false;
00863     }
00864 
00865     if (SCHEME_FALSEP(n1))
00866       return scheme_false;
00867 
00868     d1 = SCHEME_FLOAT_VAL(n1);
00869 
00870     /* This +nan.0 test looks unnecessary  -- Matthew, 08/14/01 */
00871     if (MZ_IS_NAN(d1))
00872       return scheme_false;
00873 
00874     r1 = d1 * SCH_COS(d2);
00875     r2 = d1 * SCH_SIN(d2);
00876 
00877 #ifdef MZ_USE_SINGLE_FLOATS
00878     if (SCHEME_FLTP(n1) && SCHEME_FLTP(n2))
00879       n1 = scheme_make_complex(scheme_make_float((float)r1),
00880                                scheme_make_float((float)r2));
00881     else
00882 #endif
00883       n1 = scheme_make_complex(scheme_make_double(r1),
00884                                scheme_make_double(r2));
00885 
00886     if (is_not_float)
00887       n1 = scheme_inexact_to_exact(1, &n1);
00888 
00889     return n1;
00890   }
00891 
00892   has_decimal = has_slash = has_hash = has_hash_since_slash = has_expt = 0;
00893   saw_digit = saw_digit_since_slash = saw_nonzero_digit = 0;
00894   for (i = delta; i < len; i++) {
00895     mzchar ch = str[i];
00896     if (ch == '.') {
00897       if (has_decimal) {
00898        if (report)
00899          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00900                        "read-number: multiple decimal points: %u", 
00901                        str, len);
00902        return scheme_false;
00903       }
00904       if (has_slash) {
00905        if (report)
00906          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00907                        "read-number: decimal points and fractions "
00908                        "cannot be mixed: %u", 
00909                        str, len);
00910        return scheme_false;
00911       }
00912       has_decimal = 1;
00913     } else if (isinexactmark(ch)
00914               && ((radix <= 10) || !isbaseNdigit(radix, ch))) {
00915       if (i == delta) {
00916        if (report)
00917          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00918                        "read-number: cannot begin with `%c' in %u", 
00919                        ch, str, len);
00920        return scheme_false;
00921       }
00922       has_expt = i;
00923       break;
00924     } else if (ch == '/') {
00925       if (i == delta) {
00926        if (report)
00927          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00928                        "read-number: cannot have slash at start: %u", 
00929                        str, len);
00930        return scheme_false;
00931       }
00932       if (has_slash) {
00933        if (report)
00934          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00935                        "read-number: multiple slashes: %u", 
00936                        str, len);
00937        return scheme_false;
00938       }
00939       if (has_decimal) {
00940        if (report)
00941          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00942                        "read-number: decimal points and fractions "
00943                        "cannot be mixed: %u", 
00944                        str, len);
00945        return scheme_false;
00946       }
00947       has_slash = i;
00948       saw_digit_since_slash = 0;
00949       has_hash_since_slash = 0;
00950     } else if ((ch == '-') || (ch == '+')) {
00951       if (has_slash || has_decimal || has_hash) {
00952        if (report)
00953          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00954                        "read-number: misplaced sign: %u", 
00955                        str, len);
00956        return scheme_false;
00957       }
00958     } else if (ch == '#') {
00959       if (!saw_digit_since_slash) {
00960        if (report)
00961          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00962                        "read-number: misplaced hash: %u", 
00963                        str, len);
00964        return scheme_false;
00965       }
00966       has_hash = 1;
00967       has_hash_since_slash = 1;
00968     } else if (!isAdigit(ch) && !((radix > 10) && isbaseNdigit(radix, ch))) {
00969       if (has_decimal) {
00970        if (report)
00971          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00972                        "read-number: bad decimal number: %u", 
00973                        str, len);
00974        return scheme_false;
00975       }
00976       if (has_hash) {
00977        if (report)
00978          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00979                        "read-number: misplaced hash: %u", 
00980                        str, len);
00981        return scheme_false;
00982       }
00983       break;
00984     } else {
00985       saw_digit = 1;
00986       saw_digit_since_slash = 1;
00987       if (ch != '0')
00988        saw_nonzero_digit = 1;
00989       if (has_hash_since_slash) {
00990        if (report)
00991          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
00992                        "read-number: misplaced hash: %u", 
00993                        str, len);
00994        return scheme_false;
00995       }
00996     }
00997   }
00998 
00999 #ifdef MZ_USE_SINGLE_FLOATS
01000   if (has_expt && str[has_expt]) {
01001     single = str[has_expt];
01002     single = ((single == 'f') || (single == 'F')
01003 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01004              || (single == 'e') || (single == 'E')
01005 #endif
01006              || (single == 's') || (single == 'S'));
01007   } else {
01008 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01009     single = 1;
01010 # else
01011     single = 0;
01012 # endif
01013   }
01014 #endif
01015 
01016 
01017   /* When possible, use the standard floating-point parser */
01018   if (!is_not_float && (is_float || decimal_means_float) 
01019       && !has_slash && !has_hash && (radix == 10) 
01020       && (has_decimal || has_expt)
01021       && (len <= MAX_FAST_FLOATREAD_LEN)) {
01022     double d;
01023     GC_CAN_IGNORE char *ptr;
01024 
01025     if (has_expt && !(str[has_expt + 1])) {
01026       if (report)
01027        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01028                      "read-number: no digits after \"%c\": %u",
01029                      str[has_expt], str, len);
01030       return scheme_false;
01031     }
01032 
01033     {
01034       int k;
01035       for (k = delta; k < len; k++) {
01036        if (str[k] > 127)
01037          ffl_buf[k - delta] = '?';
01038        else
01039          ffl_buf[k - delta] = str[k];
01040       }
01041       ffl_buf[len - delta] = 0;
01042     }
01043 
01044     if (has_expt && (str[has_expt] != 'e' && str[has_expt] != 'E')) {
01045       ffl_buf[has_expt - delta] = 'e';
01046     }
01047     d = STRTOD(ffl_buf, &ptr);
01048 
01049     if ((ptr XFORM_OK_MINUS ffl_buf) < (len - delta)) {
01050       if (report)
01051        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01052                      "read-number: bad decimal number %u",
01053                      str, len);
01054       return scheme_false;
01055     } 
01056 
01057     if (!saw_nonzero_digit) {
01058       /* Assert: d = 0.0 or -0.0 */
01059       if (str[delta] == '-') {
01060        /* Make sure it's -0.0 */
01061 #ifdef MZ_USE_SINGLE_FLOATS
01062        if (single) return scheme_nzerof;
01063 #endif
01064        return scheme_nzerod;
01065       }
01066     }
01067 
01068     if (!d) {
01069       if (str[delta] == '-') {
01070        /* Make sure it's -0.0 */
01071 #ifdef MZ_USE_SINGLE_FLOATS
01072        if (single) return scheme_nzerof;
01073 #endif
01074        return scheme_nzerod;
01075       }
01076     }
01077 
01078 #ifdef MZ_USE_SINGLE_FLOATS
01079     if (single)
01080       return scheme_make_float((float)d);
01081 #endif
01082     return scheme_make_double(d);
01083   }
01084 
01085   if (has_decimal || has_expt || (has_hash && !has_slash)) {
01086     Scheme_Object *mantissa, *exponent, *power, *n;
01087     Scheme_Object *args[2];
01088     int result_is_float= (is_float || (!is_not_float && decimal_means_float));
01089 
01090     if (has_expt) {
01091       mzchar *substr;
01092 
01093       if (!str[has_expt + 1]) {
01094        if (report)
01095          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01096                        "read-number: no digits after \"%c\": %u",
01097                        str[has_expt], str, len);
01098        return scheme_false;
01099       }
01100 
01101 #ifdef MZ_PRECISE_GC
01102       {
01103        /* Can't pass misaligned pointer to scheme_read_bignum: */
01104        int slen = len - (has_expt + 1) + 1;
01105        substr = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
01106        memcpy(substr, str + has_expt + 1, slen * sizeof(mzchar));
01107       }
01108 #else
01109       substr = (mzchar *)str + has_expt + 1;
01110 #endif
01111 
01112       exponent = scheme_read_bignum(substr, 0, radix);
01113       if (SCHEME_FALSEP(exponent)) {
01114        if (report)
01115          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01116                        "read-number: bad exponent: %u", 
01117                        str, len);
01118        return scheme_false;
01119       }
01120     } else
01121       exponent = zeroi;
01122 
01123     if (!has_expt)
01124       has_expt = len;
01125 
01126     if (has_slash) {
01127       /* Mantissa is a fraction. */
01128       mzchar *s;
01129       int dbz;
01130       
01131       s = (mzchar *)scheme_malloc_atomic((has_expt - delta + 1) * sizeof(mzchar));
01132       memcpy(s, str + delta, (has_expt - delta) * sizeof(mzchar));
01133       s[has_expt - delta] = 0;
01134       
01135       mantissa = scheme_read_number(s, has_expt - delta, 
01136                                 is_float, is_not_float, 1,
01137                                 radix, 1, next_complain,
01138                                 &dbz,
01139                                 test_only,
01140                                 stxsrc, line, col, pos, span,
01141                                 indentation);
01142 
01143       if (SCHEME_FALSEP(mantissa)) {
01144        if (dbz) {
01145          if (div_by_zero)
01146            *div_by_zero = 1;
01147          if (complain)
01148            scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01149                          "read-number: division by zero: %u", 
01150                          str, len);
01151        }
01152        if (report)
01153          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01154                        "read-number: bad number: %u", 
01155                        str, len);
01156        return scheme_false;
01157       }
01158     } else {
01159       /* Mantissa is not a fraction. */
01160       mzchar *digits;
01161       int extra_power = 0, dcp = 0, num_ok;
01162 
01163       digits = (mzchar *)scheme_malloc_atomic((has_expt - delta + 1) * sizeof(mzchar));
01164 
01165       i = delta;
01166       if (str[i] == '+' || str[i] == '-')
01167        digits[dcp++] = str[i++];
01168 
01169       for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) {
01170        digits[dcp++] = str[i];
01171       }
01172 
01173       if (str[i] == '#') {
01174        for (; str[i] == '#'; i++) {
01175          digits[dcp++] = '0';
01176        }
01177        num_ok = 0;
01178       } else
01179        num_ok = 1;
01180        
01181       if (str[i] == '.') {
01182        i++;
01183        if (num_ok)
01184          for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) {
01185            digits[dcp++] = str[i];
01186            extra_power++;
01187          }
01188 
01189        for (; str[i] == '#'; i++) {
01190          digits[dcp++] = '0';  
01191          extra_power++;
01192        }
01193       }
01194 
01195       if ((str[i] && (!has_expt || i != has_expt))
01196          || !dcp || (dcp == 1 && !(isAdigit(digits[0])
01197                                 || ((radix > 10) && isbaseNdigit(radix, digits[0]))))) {
01198        if (report)
01199          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01200                        "read-number: bad decimal number %u", 
01201                        str, len);
01202        return scheme_false;
01203       }
01204 
01205       /* Reduce unnecessary mantissa-reading work for inexact results.
01206          This is also necessary to make the range check on `exponent'
01207          correct. */
01208       if (result_is_float && (dcp > MAX_FLOATREAD_PRECISION_DIGITS)) {
01209        extra_power -= (dcp - MAX_FLOATREAD_PRECISION_DIGITS);
01210        dcp = MAX_FLOATREAD_PRECISION_DIGITS;
01211       }
01212 
01213       digits[dcp] = 0;
01214       mantissa = scheme_read_bignum(digits, 0, radix);
01215       if (SCHEME_FALSEP(mantissa)) {
01216        /* can get here with bad radix */
01217        if (report)
01218          scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01219                         "read-number: bad number: %u", 
01220                         str, len);
01221        return scheme_false;
01222       }
01223 
01224       if (extra_power)
01225        exponent = scheme_bin_minus(exponent, scheme_make_integer(extra_power));
01226     
01227       /* Don't calculate a huge exponential if we're returning a float: */
01228       if (result_is_float) {
01229        if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD))) {
01230          if (scheme_is_negative(mantissa))
01231            return CHECK_SINGLE(scheme_minus_inf_object, single);
01232          else
01233            return CHECK_SINGLE(scheme_inf_object, single);
01234        } else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD))) {
01235          if (scheme_is_negative(mantissa))
01236            return CHECK_SINGLE(scheme_nzerod, single);
01237          else
01238            return CHECK_SINGLE(scheme_zerod, single);
01239        }
01240       }
01241     }
01242 
01243     /* This is the important use of test_only, because it's the one
01244        place where the read calculation is not linear in the input. */
01245     if (test_only)
01246       return scheme_make_integer(1);
01247 
01248     args[0] = scheme_make_integer(radix);
01249     args[1] = exponent;
01250     power = scheme_expt(2, args);
01251 
01252     n = scheme_bin_mult(mantissa, power);
01253 
01254     if (result_is_float)
01255       n = CHECK_SINGLE(TO_DOUBLE(n), single);
01256     else
01257       n = CHECK_SINGLE(n, single);
01258 
01259     if (SCHEME_FLOATP(n) && str[delta] == '-') {
01260       if (SCHEME_FLOAT_VAL(n) == 0.0) {
01261        /* 0.0 => -0.0 */
01262 #ifdef MZ_USE_SINGLE_FLOATS
01263        if (SCHEME_FLTP(n)) {
01264          n = scheme_make_float(-SCHEME_FLT_VAL(n));
01265        } else
01266 #endif
01267          n = scheme_make_double(-SCHEME_DBL_VAL(n));
01268       }
01269     }
01270 
01271     return n;
01272   }
01273   
01274   if (has_slash) {
01275     Scheme_Object *n1, *n2;
01276     mzchar *first;
01277 
01278     first = (mzchar *)scheme_malloc_atomic((has_slash - delta + 1) * sizeof(mzchar));
01279     memcpy(first, str + delta, (has_slash - delta) * sizeof(mzchar));
01280     first[has_slash - delta] = 0;
01281 
01282     n1 = scheme_read_number(first, has_slash - delta,
01283                          is_float, is_not_float, 1,
01284                          radix, 1, next_complain,
01285                          div_by_zero,
01286                          test_only,
01287                          stxsrc, line, col, pos, span,
01288                          indentation);
01289     if (SAME_OBJ(n1, scheme_false))
01290       return scheme_false;
01291 
01292     {
01293       mzchar *substr;
01294 
01295 #ifdef MZ_PRECISE_GC
01296       {
01297        /* Can't pass misaligned pointer to scheme_read_bignum: */
01298        int slen = len - (has_slash + 1) + 1;
01299        substr = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
01300        memcpy(substr, str + has_slash + 1, slen * sizeof(mzchar));
01301       }
01302 #else
01303       substr = (mzchar *)str + has_slash + 1;
01304 #endif
01305 
01306       n2 = scheme_read_number(substr, len - has_slash - 1,
01307                            is_float, is_not_float, 1,
01308                            radix, 1, next_complain,
01309                            div_by_zero,
01310                            test_only,
01311                            stxsrc, line, col, pos, span,
01312                            indentation);
01313     }
01314 
01315     if (SAME_OBJ(n2, scheme_false))
01316       return scheme_false;
01317 
01318     if (SCHEME_EXACT_REALP(n2) && scheme_is_zero(n2)) {
01319       if (complain)
01320        scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01321                      "read-number: division by zero: %u", 
01322                      str, len);
01323       if (div_by_zero)
01324        *div_by_zero = 1;
01325       return scheme_false;
01326     }
01327 
01328     if (test_only)
01329       return scheme_make_integer(1);
01330 
01331     n1 = scheme_bin_div(n1, n2);
01332 
01333     if (is_not_float) {
01334       if (SCHEME_FLOATP(n1)) {
01335        if (!scheme_check_double(NULL, SCHEME_FLOAT_VAL(n1), NULL)) {
01336          if (complain)
01337            scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01338                          "read-number: no exact representation for %V", 
01339                          n1);
01340          return scheme_false;
01341        }
01342       }
01343       n1 = scheme_inexact_to_exact(1, &n1);
01344     } else if (is_float)
01345       n1 = TO_DOUBLE(n1);
01346 
01347     return CHECK_SINGLE(n1, single);
01348   }
01349 
01350   o = scheme_read_bignum(str, delta, radix);
01351   if (SAME_OBJ(o, scheme_false)) {
01352     if (report)
01353       scheme_read_err(complain, stxsrc, line, col, pos, span, 0, indentation,
01354                     "read-number: bad number: %u", 
01355                     str, len);
01356   } else if (is_float) {
01357     /* Special case: "#i-0" => -0. */
01358     if ((o == zeroi) && str[delta] == '-') {
01359 #ifdef MZ_USE_SINGLE_FLOATS
01360       if (single) return scheme_nzerof;
01361 #endif
01362       return scheme_nzerod;
01363     }
01364 
01365     return CHECK_SINGLE(TO_DOUBLE(o), single);
01366   }
01367 
01368   return o;
01369 }
01370 
01371 /*========================================================================*/
01372 /*                           scheme functions                             */
01373 /*========================================================================*/
01374 
01375 static Scheme_Object *
01376 number_to_string (int argc, Scheme_Object *argv[])
01377 {
01378   Scheme_Object *o = argv[0];
01379   long radix;
01380 
01381   if (!SCHEME_NUMBERP(o))
01382     scheme_wrong_type("number->string", "number", 0, argc, argv);
01383   
01384   if (argc == 2) {
01385     if (!SCHEME_INTP(argv[1]))
01386       radix = 0;
01387     else
01388       radix = SCHEME_INT_VAL(argv[1]);
01389 
01390     if ((radix != 2) && (radix != 8) && (radix != 10)  && (radix != 16)) {
01391       scheme_wrong_type("number->string", "2, 8, 10, or 16", 1, argc, argv);
01392       ESCAPED_BEFORE_HERE;
01393     }
01394     
01395     radix = SCHEME_INT_VAL(argv[1]);
01396   } else
01397     radix = 10;
01398 
01399   if (SCHEME_INTP(o) && ((radix == 10) || (radix == 16))) {
01400     /* Fast path for common case. */
01401     mzchar num[32];
01402     int pos = 32;
01403     long v = SCHEME_INT_VAL(o);
01404     if (v) {
01405       int neg, digit;
01406       if (v < 0) {
01407        neg = 1;
01408        v = -v;
01409       } else
01410        neg = 0;
01411       while (v) {
01412        digit = (v % radix);
01413        if (digit < 10)
01414          num[--pos] = digit + '0';
01415        else
01416          num[--pos] = (digit - 10) + 'a';
01417        v = v / radix;
01418       }
01419       if (neg)
01420        num[--pos] = '-';
01421     } else {
01422       num[--pos] = '0';
01423     }
01424     return scheme_make_sized_offset_char_string(num, pos, 32 - pos, 1);
01425   }
01426 
01427   return scheme_make_utf8_string/*_without_copying*/(number_to_allocated_string(radix, o, 1));
01428 }
01429 
01430 
01431 static Scheme_Object *
01432 string_to_number (int argc, Scheme_Object *argv[])
01433 {
01434   long radix;
01435   long len;
01436   mzchar *mzstr;
01437   int decimal_inexact, div_by_zero = 0;
01438   Scheme_Object *v;
01439 
01440   if (!SCHEME_CHAR_STRINGP(argv[0]))
01441     scheme_wrong_type("string->number", "string", 0, argc, argv);
01442 
01443   if (argc > 1) {
01444     if (SCHEME_INTP(argv[1]))
01445       radix = SCHEME_INT_VAL(argv[1]);
01446     else
01447       radix = 0;
01448     
01449     if ((radix < 2) || (radix > 16)) {
01450       scheme_wrong_type("string->number", "exact integer in [2, 16]", 1, argc, argv);
01451       ESCAPED_BEFORE_HERE;
01452     }
01453   } else
01454     radix = 10;
01455 
01456   decimal_inexact = SCHEME_TRUEP(scheme_get_param(scheme_current_config(), 
01457                                             MZCONFIG_READ_DECIMAL_INEXACT));
01458 
01459   mzstr = SCHEME_CHAR_STR_VAL(argv[0]);
01460   len = SCHEME_CHAR_STRTAG_VAL(argv[0]);
01461 
01462   v = scheme_read_number(mzstr, len, 
01463                       0, 0, decimal_inexact,
01464                       radix, 0, NULL, &div_by_zero,
01465                       0, NULL, 0, 0, 0, 0,
01466                       NULL);
01467 
01468   return v;
01469 }
01470 
01471 
01472 static char *double_to_string (double d, int alloc)
01473 {
01474   char buffer[100], *s;
01475   int l, i, digits;
01476 
01477   if (MZ_IS_NAN(d))
01478     s = not_a_number_str;
01479   else if (MZ_IS_POS_INFINITY(d))
01480     s = infinity_str;
01481   else if (MZ_IS_NEG_INFINITY(d))
01482     s = minus_infinity_str;
01483   else if (d == 0.0) {
01484     /* Check for -0.0, since some printers get it wrong. */
01485     if (scheme_minus_zero_p(d))
01486       s = "-0.0";
01487     else
01488       s = "0.0";
01489   } else {
01490     /* Initial count for significant digits is 14. That's big enough to
01491        get most right, small enough to avoid nonsense digits. But we'll
01492         loop in case it's not precise enough to get read-write invariance: */
01493     digits = 14;
01494     while (digits < 30) {
01495       double check;
01496       GC_CAN_IGNORE char *ptr;
01497 
01498       sprintf(buffer, "%.*g", digits, d);
01499 
01500       /* Did we get read-write invariance, yet? */
01501       check = strtod(buffer, &ptr);
01502       if (check == d)
01503        break;
01504 
01505       digits++;
01506     }
01507     
01508     l = strlen(buffer);
01509     for (i = 0; i < l; i++) {
01510       if (buffer[i] == '.' || isalpha((unsigned char)buffer[i]))
01511        break;
01512     }
01513     if (i == l) {
01514       buffer[i] = '.';
01515       buffer[i + 1] = '0';
01516       buffer[i + 2] = 0;
01517       l += 2;
01518     }
01519     
01520     s = (char *)scheme_malloc_atomic(strlen(buffer) + 1);
01521     strcpy(s, buffer);
01522     alloc = 0;
01523   }
01524 
01525   if (alloc) {
01526     char *s2;
01527     l = strlen(s) + 1;
01528     s2 = (char *)scheme_malloc_atomic(l);
01529     memcpy(s2, s, l);
01530     s = s2;
01531   }
01532 
01533   return s;
01534 }
01535 
01536 static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc)
01537 {
01538   char *s;
01539 
01540   if (SCHEME_FLOATP(obj)) {
01541     if (radix != 10)
01542       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01543                      "number->string: "
01544                      "inexact numbers can only be printed in base 10");
01545     s = double_to_string(SCHEME_FLOAT_VAL(obj), alloc);
01546   } else if (SCHEME_RATIONALP(obj)) {
01547     Scheme_Object *n, *d;
01548     char *ns, *ds;
01549     int nlen, dlen;
01550 
01551     n = scheme_rational_numerator(obj);
01552     d = scheme_rational_denominator(obj);
01553 
01554     ns = number_to_allocated_string(radix, n, 0);
01555     ds = number_to_allocated_string(radix, d, 0);
01556 
01557     nlen = strlen(ns);
01558     dlen = strlen(ds);
01559 
01560     s = (char *)scheme_malloc_atomic(nlen + dlen + 2);
01561     memcpy(s, ns, nlen);
01562     s[nlen] = '/';
01563     strcpy(s + nlen + 1, ds);
01564   } else if (SCHEME_COMPLEXP(obj)) {
01565     Scheme_Object *r, *i;
01566     char *rs, *is;
01567     int rlen, ilen, offset = 0;
01568 
01569     r = _scheme_complex_real_part(obj);
01570     i = _scheme_complex_imaginary_part(obj);
01571 
01572     rs = number_to_allocated_string(radix, r, 0);
01573     is = number_to_allocated_string(radix, i, 0);
01574 
01575     rlen = strlen(rs);
01576     ilen = strlen(is);
01577     s = (char *)scheme_malloc_atomic(rlen + ilen + 3);
01578     memcpy(s, rs, rlen);
01579     if ((is[0] != '-') && (is[0] != '+')) {
01580       offset = 1;
01581       s[rlen] = '+';
01582     }
01583     memcpy(s + rlen + offset, is, ilen);
01584     s[rlen + offset + ilen] = 'i';
01585     s[rlen + offset + ilen + 1] = 0;
01586   } else {
01587     if (SCHEME_INTP(obj))
01588       obj = scheme_make_bignum(SCHEME_INT_VAL(obj));
01589 
01590     s = scheme_bignum_to_allocated_string(obj, radix, alloc);
01591   }
01592 
01593   return s;
01594 }
01595 
01596 char *scheme_number_to_string(int radix, Scheme_Object *obj)
01597 {
01598   return number_to_allocated_string(radix, obj, 0);
01599 }
01600 
01601 int scheme_check_double(const char *where, double d, const char *dest)
01602 {
01603   if (MZ_IS_INFINITY(d)
01604       || MZ_IS_NAN(d)) {
01605     if (where)
01606       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01607                      "%s: no %s representation for %s",
01608                      where, 
01609                      dest,
01610                      double_to_string(d, 0));
01611     return 0;
01612   }
01613 
01614   return 1;
01615 }
01616 
01617 /*========================================================================*/
01618 /*                      native representations                            */
01619 /*========================================================================*/
01620 
01621 static Scheme_Object *bytes_to_integer (int argc, Scheme_Object *argv[])
01622 {
01623   long strlen, slen;
01624   int sgned;
01625   char *str;
01626   int buf[2], i;
01627   int bigend = MZ_IS_BIG_ENDIAN, offset = 0;
01628 
01629   if (!SCHEME_BYTE_STRINGP(argv[0]))
01630     scheme_wrong_type("integer-bytes->integer", "byte string", 0, argc, argv);
01631   strlen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
01632 
01633   str = SCHEME_BYTE_STR_VAL(argv[0]);
01634 
01635   sgned = SCHEME_TRUEP(argv[1]);
01636   if (argc > 2)
01637     bigend = SCHEME_TRUEP(argv[2]);
01638 
01639   if (argc > 3) {
01640     long start, finish;
01641 
01642     scheme_get_substring_indices("integer-bytes->integer", argv[0],
01643                                  argc, argv,
01644                                  3, 4, &start, &finish);
01645 
01646     offset = start;
01647     slen = finish - start;
01648   } else {
01649     offset = 0;
01650     slen = strlen;
01651   }
01652 
01653   if ((slen != 2)  && (slen != 4) && (slen != 8)) {
01654     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01655                      "integer-bytes->integer: length is not 2, 4, or 8 bytes: %ld",
01656                      slen);
01657     return NULL;
01658   }
01659 
01660   if (offset + slen > strlen) {
01661     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01662                      
01663                      slen);
01664     return NULL;
01665   }
01666 
01667   if (bigend != MZ_IS_BIG_ENDIAN) {
01668     for (i = 0; i < slen; i++) {
01669       ((char *)buf)[slen - i - 1] = str[i + offset];
01670     }
01671     str = (char *)buf;
01672   } else {
01673     memcpy(&buf, str + offset, slen);
01674     str = (char *)buf;
01675   }
01676 
01677   switch(slen) {
01678   case 2:
01679     if (sgned)
01680       return scheme_make_integer(((short *)str)[0]);
01681     else
01682       return scheme_make_integer(((unsigned short *)str)[0]);
01683     break;
01684   case 4:
01685     if (sgned)
01686       return scheme_make_integer_value(((int *)str)[0]);
01687     else
01688       return scheme_make_integer_value_from_unsigned(((unsigned int *)str)[0]);
01689     break;
01690   default:
01691 #ifdef SIXTY_FOUR_BIT_INTEGERS
01692     if (sgned)
01693       return scheme_make_integer_value(((long *)str)[0]);
01694     else
01695       return scheme_make_integer_value_from_unsigned(((unsigned long *)str)[0]);
01696     break;
01697 #else
01698 # ifndef NO_LONG_LONG_TYPE
01699     {
01700       mzlonglong lv;
01701       memcpy(&lv, str, sizeof(mzlonglong));
01702       if (sgned)
01703        return scheme_make_integer_value_from_long_long(lv);
01704       else
01705        return scheme_make_integer_value_from_unsigned_long_long((umzlonglong)lv);
01706       break;
01707     }
01708 # else
01709     {
01710       Scheme_Object *h, *l, *a[2];
01711 
01712 #  if MZ_IS_BIG_ENDIAN
01713       /* make little-endian at int level: */
01714       {
01715        int v;
01716        v = ((int *)str)[0];
01717        buf[0] = ((int *)str)[1];
01718        buf[1] = v;
01719        str = (char *)buf;
01720       }
01721 #  endif
01722 
01723       if (sgned)
01724        h = scheme_make_integer_value(((int *)str)[1]);
01725       else
01726        h = scheme_make_integer_value_from_unsigned(((unsigned int *)str)[1]);
01727       l = scheme_make_integer_value_from_unsigned(((unsigned int *)str)[0]);
01728       a[0] = h;
01729       a[1] = scheme_make_integer(32);
01730       h = scheme_bitwise_shift(2, a);
01731       return scheme_bin_plus(h, l);
01732     }
01733 # endif
01734 #endif
01735     break;
01736   }
01737 }
01738 
01739 #define MZ_U8HI 0
01740 #define MZ_S8HI 1
01741 #define MZ_S8LO 2
01742 
01743 static Scheme_Object *integer_to_bytes(int argc, Scheme_Object *argv[])
01744 {
01745   Scheme_Object *n, *s;
01746   char *str;
01747   int size, sgned;
01748   long val, offset, buf[2];
01749 #if !defined(NO_LONG_LONG_TYPE) && !defined(SIXTY_FOUR_BIT_INTEGERS)
01750   mzlonglong llval;
01751 #endif
01752   int bigend = MZ_IS_BIG_ENDIAN, bad;
01753 
01754   n = argv[0];
01755   if (!SCHEME_INTP(n) && !SCHEME_BIGNUMP(n))
01756     scheme_wrong_type("integer->integer-bytes", "exact integer", 0, argc, argv);
01757 
01758   if (SCHEME_INTP(argv[1]))
01759     size = SCHEME_INT_VAL(argv[1]);
01760   else
01761     size = 0;
01762   if ((size != 2) && (size != 4) &&(size != 8))
01763     scheme_wrong_type("integer->integer-bytes", "exact 2, 4, or 8", 1, argc, argv);
01764 
01765   sgned = SCHEME_TRUEP(argv[2]);
01766   if (argc > 3)
01767     bigend = SCHEME_TRUEP(argv[3]);
01768   
01769   if (argc > 4)
01770     s = argv[4];
01771   else
01772     s = scheme_make_sized_byte_string("12345678", size, 1);
01773   
01774   if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
01775     scheme_wrong_type("integer->integer-bytes", "mutable byte string", 4, argc, argv);
01776 
01777   if (argc > 5) {
01778     long start, finish;
01779     
01780     scheme_get_substring_indices("integer-bytes->integer", s,
01781                                  argc, argv,
01782                                  5, 6, &start, &finish);
01783 
01784     offset = start;
01785   } else
01786     offset = 0;
01787   
01788   if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
01789     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01790                      "integer-bytes->integer: byte string is %ld bytes,"
01791                      " which is shorter than starting position %ld plus size %ld",
01792                      SCHEME_BYTE_STRLEN_VAL(s), offset, size);
01793     return NULL;
01794   }
01795 
01796   /* Check for mismatch: number doesn't fit */
01797   if (size == 2) {
01798     if (SCHEME_BIGNUMP(n))
01799       bad = 1;
01800     else {
01801       val = SCHEME_INT_VAL(n);
01802       if (sgned) {
01803        bad = ((val < -32768) || (val > 32767));
01804       } else {
01805        bad = ((val < 0) || (val > 65535));
01806       }
01807     }
01808   } else if (size ==4) {
01809     if (sgned)
01810       bad = !scheme_get_int_val(n, &val);
01811     else
01812       bad = !scheme_get_unsigned_int_val(n, (unsigned long *)&val);
01813 #ifdef SIXTY_FOUR_BIT_INTEGERS
01814     if (!bad) {
01815       if (sgned)
01816        bad = ((val > (long)0x7fffffff) || (val < -(long)0x80000000));
01817       else
01818        bad = (val > (long)0xffffffff);
01819     }
01820 #endif
01821   } else  {
01822 #ifdef SIXTY_FOUR_BIT_INTEGERS
01823     if (sgned)
01824       bad = !scheme_get_int_val(n, &val);
01825     else
01826       bad = !scheme_get_unsigned_int_val(n, (unsigned long *)&val);
01827 #else
01828 # ifndef NO_LONG_LONG_TYPE
01829     if (sgned)
01830       bad = !scheme_get_long_long_val(n, &llval);
01831     else
01832       bad = !scheme_get_unsigned_long_long_val(n, (umzlonglong *)&llval);
01833 # else
01834     if (!num_limits[MZ_U8HI]) {
01835       Scheme_Object *a[2], *v;
01836 
01837       a[0] = scheme_make_integer(1);
01838       a[1] = scheme_make_integer(64);
01839       a[0] = scheme_bitwise_shift(2, a);
01840       v = scheme_sub1(1, a);
01841       num_limits[MZ_U8HI] = v;
01842       a[0] = v;
01843       a[1] = scheme_make_integer(-1);
01844       v = scheme_bitwise_shift(2, a);
01845       num_limits[MZ_S8HI] = v;
01846       a[0] = v;
01847       v = scheme_bin_minus(scheme_make_integer(0), scheme_add1(1, a));
01848       num_limits[MZ_S8LO] = v;
01849     }
01850 
01851     if (sgned)
01852       bad = (scheme_bin_lt(n, num_limits[MZ_S8LO])
01853             || scheme_bin_lt(num_limits[MZ_S8HI], n));
01854     else
01855       bad = (!scheme_nonneg_exact_p(n)
01856             || scheme_bin_lt(num_limits[MZ_U8HI], n));
01857 
01858     val = 0;
01859 # endif
01860 #endif
01861   }
01862 
01863   if (bad) {
01864     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01865                    "integer->integer-bytes: integer does not fit into %d %ssigned bytes: %V",
01866                    size, (sgned ? "" : "un"), n);
01867     return NULL;
01868   }
01869 
01870   /* Finally, do the work */
01871   str = (char *)buf;
01872   switch (size) {
01873   case 2:
01874     {
01875       if (sgned) {
01876        *(unsigned short *)str = (unsigned short)(val);
01877       } else {
01878        *(short *)str = (short)(val);
01879       }
01880     }
01881     break;
01882   case 4:
01883     if (sgned) {
01884       unsigned int sv = val;
01885       *(unsigned int *)str = sv;
01886     } else {
01887       int sv = val;
01888       *(int *)str = sv;
01889     }
01890     break;
01891   default:
01892 #ifdef SIXTY_FOUR_BIT_INTEGERS
01893     *(long *)str = val;
01894 #else
01895 # ifndef NO_LONG_LONG_TYPE
01896     memcpy(str, &llval, sizeof(mzlonglong));
01897 # else
01898     {
01899       Scheme_Object *hi, *lo, *a[2];
01900       unsigned long ul;
01901       
01902       a[0] = n;
01903       a[1] = scheme_make_integer_value_from_unsigned((unsigned long)-1);
01904       lo = scheme_bitwise_and(2, a);
01905       a[1] = scheme_make_integer(-32);
01906       hi = scheme_bitwise_shift(2, a);
01907 
01908       scheme_get_unsigned_int_val(lo, &ul);
01909       
01910       ((unsigned int *)str)[0] = ul;
01911       if (sgned) {
01912        scheme_get_int_val(hi, &val);
01913        ((unsigned int *)str)[1] = val;
01914       } else {
01915        scheme_get_unsigned_int_val(hi, &ul);
01916        ((unsigned int *)str)[1] = ul;
01917       }
01918 
01919 #if MZ_IS_BIG_ENDIAN
01920       {
01921        /* We've assumed little endian so far */
01922        val = ((int *)str)[0];
01923        ((int *)str)[0] = ((int *)str)[1];
01924        ((int *)str)[1] = val;
01925       }
01926 #endif
01927 
01928     }
01929 # endif
01930 #endif
01931     break;
01932   }
01933 
01934   str = SCHEME_BYTE_STR_VAL(s);
01935   if (bigend != MZ_IS_BIG_ENDIAN) {
01936     int i;
01937     for (i = 0; i < size; i++) {
01938       str[i + offset] = ((char *)buf)[size - i - 1];
01939     }
01940   } else {
01941     int i;
01942     for (i = 0; i < size; i++) {
01943       str[i + offset] = ((char *)buf)[i];
01944     }
01945   }
01946 
01947   return s;
01948 }
01949 
01950 static Scheme_Object *bytes_to_real (int argc, Scheme_Object *argv[])
01951 {
01952   long offset = 0, slen;
01953   char *str, buf[8];
01954   int bigend = MZ_IS_BIG_ENDIAN;
01955 
01956   if (!SCHEME_BYTE_STRINGP(argv[0]))
01957     scheme_wrong_type("integer-bytes->integer", "byte string", 0, argc, argv);
01958 
01959   if (argc > 2) {
01960     long start, finish;
01961 
01962     scheme_get_substring_indices("integer-bytes->integer", argv[0],
01963                                  argc, argv,
01964                                  2, 3, &start, &finish);
01965 
01966     offset = start;
01967     slen = finish - start;
01968   } else {
01969     offset = 0;
01970     slen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
01971   }
01972 
01973   if ((slen != 4) && (slen != 8))
01974     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01975                      "floating-point-bytes->real: length is not 2, 4, or 8 bytes: %ld",
01976                      slen);
01977 
01978   str = SCHEME_BYTE_STR_VAL(argv[0]);
01979 
01980   if (argc > 1)
01981     bigend = SCHEME_TRUEP(argv[1]);
01982 
01983   if (bigend != MZ_IS_BIG_ENDIAN) {
01984     int i;
01985     for (i = 0; i < slen; i++) {
01986       buf[slen - i - 1] = str[offset + i];
01987     }
01988   } else {
01989     memcpy(buf, str + offset, slen);
01990   }
01991   str = buf;
01992 
01993   switch(slen) {
01994   case 4:
01995     {
01996       float f;
01997       memcpy(&f, buf, sizeof(float));
01998 #ifdef MZ_USE_SINGLE_FLOATS
01999       return scheme_make_float(f);
02000 #else
02001       return scheme_make_double(f);
02002 #endif
02003     }
02004     break;
02005   default:
02006     {
02007       double d;
02008       memcpy(&d, str, sizeof(double));
02009       return scheme_make_double(d);
02010     }
02011     break;
02012   }
02013 }
02014 
02015 static Scheme_Object *real_to_bytes (int argc, Scheme_Object *argv[])
02016 {
02017   Scheme_Object *n, *s;
02018   int size;
02019   int bigend = MZ_IS_BIG_ENDIAN;
02020   double d;
02021   long offset = 0;
02022 
02023   n = argv[0];
02024   if (!SCHEME_REALP(n))
02025     scheme_wrong_type("real->floating-point-bytes", "real number", 0, argc, argv);
02026 
02027   if (SCHEME_INTP(argv[1]))
02028     size = SCHEME_INT_VAL(argv[1]);
02029   else
02030     size = 0;
02031   if ((size != 4) && (size != 8))
02032     scheme_wrong_type("real->floating-point-bytes", "exact 4 or 8", 1, argc, argv);
02033 
02034   if (argc > 2)
02035     bigend = SCHEME_TRUEP(argv[2]);
02036 
02037   if (argc > 3) {
02038     s = argv[3];
02039 
02040     if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
02041       scheme_wrong_type("real->floating-point-bytes", "mutable byte string", 3, argc, argv);
02042     
02043     if (argc > 4) {
02044       long start, finish;
02045       
02046       scheme_get_substring_indices("real->floating-point-bytes", s,
02047                                    argc, argv,
02048                                    4, 5, &start, &finish);
02049       
02050       offset = start;
02051     } else
02052       offset = 0;
02053   } else
02054     s = scheme_make_sized_byte_string("12345678", size, 1);
02055   
02056   if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
02057     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02058                      "real->floating-point-bytes: byte string is %ld bytes,"
02059                      " which is shorter than starting position %ld plus size %ld",
02060                      SCHEME_BYTE_STRLEN_VAL(s), offset, size);
02061     return NULL;
02062   }
02063 
02064   d = scheme_get_val_as_double(n);
02065   
02066   if (size == 4) {
02067     float f = (float) d;
02068     memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &f, sizeof(float));
02069   } else {
02070     memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &d, sizeof(double));
02071   }
02072 
02073   if (bigend != MZ_IS_BIG_ENDIAN) {
02074     int i;
02075     char buf[8], *str;
02076 
02077     str = SCHEME_BYTE_STR_VAL(s);
02078     
02079     for (i = 0; i < size; i++) {
02080       buf[size - i - 1] = str[offset + i];
02081     }
02082     for (i = 0; i < size; i++) {
02083       str[offset + i] = buf[i];
02084     }
02085   }
02086 
02087   return s;
02088 }
02089 
02090 static Scheme_Object *system_big_endian_p (int argc, Scheme_Object *argv[])
02091 {
02092 #if MZ_IS_BIG_ENDIAN
02093   return scheme_true;
02094 #else
02095   return scheme_false;
02096 #endif
02097 }
02098 
02099 /*========================================================================*/
02100 /*                       random number generator                          */
02101 /*========================================================================*/
02102 
02103 #ifdef MZ_BSD_RANDOM_GENERATOR
02104 # include "random.inc"
02105 #else
02106 # include "newrandom.inc"
02107 #endif
02108 
02109 long scheme_rand(Scheme_Random_State *rs)
02110 {
02111   return sch_int_rand(2147483647, rs);
02112 }
02113 
02114 static Scheme_Object *
02115 random_seed(int argc, Scheme_Object *argv[])
02116 {
02117   long i = -1;
02118   Scheme_Object *o = argv[0], *rand_state;
02119 
02120   if (scheme_get_int_val(o,  &i)) {
02121     if (i > 2147483647)
02122       i = -1;
02123   }
02124 
02125   if (i < 0)
02126     scheme_wrong_type("random-seed", "exact integer in [0, 2147483647]", 0, argc, argv);
02127 
02128   rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
02129   sch_srand(i, (Scheme_Random_State *)rand_state);
02130 
02131   return scheme_void;
02132 }
02133 
02134 static Scheme_Object *
02135 sch_random(int argc, Scheme_Object *argv[])
02136 {
02137   if (!argc) {
02138     double v;
02139     Scheme_Object *rand_state;
02140     
02141     rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
02142     v = sch_double_rand((Scheme_Random_State *)rand_state);
02143     return scheme_make_double(v);
02144   } else if ((argc == 1)
02145              && SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type)) {
02146     double v;
02147     Scheme_Object *rand_state;
02148     
02149     rand_state = argv[0];
02150     v = sch_double_rand((Scheme_Random_State *)rand_state);
02151     return scheme_make_double(v);
02152   } else {
02153     unsigned long i, v;
02154     Scheme_Object *o, *rand_state;
02155 
02156     o = argv[0];
02157     if (scheme_get_unsigned_int_val(o,  &i)) {
02158       if (i > 4294967087UL)
02159        i = 0;
02160     } else
02161       i = 0;
02162     
02163     if (!i) {
02164       scheme_wrong_type("random", 
02165                         ((argc == 1)
02166                          ? "exact integer in [1, 4294967087] or pseudo-random-generator"
02167                          : "exact integer in [1, 4294967087]"), 
02168                         0, argc, argv);
02169       return NULL;
02170     }
02171 
02172     if (argc == 2) {
02173       rand_state = argv[1];
02174       if (!SAME_TYPE(SCHEME_TYPE(rand_state), scheme_random_state_type)) {
02175         scheme_wrong_type("random", "pseudo-random-generator", 1, argc, argv);
02176         return NULL;
02177       }
02178     } else {
02179       rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
02180     }
02181 
02182     v = sch_int_rand(i, (Scheme_Random_State *)rand_state);
02183     
02184     return scheme_make_integer_value_from_unsigned(v);
02185   }
02186 }
02187 
02188 static Scheme_Object *
02189 do_pack(const char *name, int argc, Scheme_Object *argv[], int set)
02190 {
02191   Scheme_Object *s;
02192   GC_CAN_IGNORE Scheme_Random_State rs;
02193 
02194   if (set) {
02195     s = argv[0];
02196     if (!SAME_TYPE(SCHEME_TYPE(s), scheme_random_state_type)) {
02197       scheme_wrong_type(name, "pseudo-random-generator", 0, argc, argv);
02198     }
02199   }
02200 
02201   if (SCHEME_VECTORP(argv[set]))
02202     s = pack_rand_state(argv[set], (set ? &rs : NULL));
02203   else
02204     s = NULL;
02205 
02206   if (!s)
02207     scheme_wrong_type(name,
02208                     "vector of six elements, three in [0, 4294967086] and three in [0, 4294944442], "
02209                     "at least one non-zero in each set of three",
02210                     set, argc, argv);
02211 
02212   if (set) {
02213     s = argv[0];
02214     ((Scheme_Random_State *)s)->x10 = rs.x10;
02215     ((Scheme_Random_State *)s)->x11 = rs.x11;
02216     ((Scheme_Random_State *)s)->x12 = rs.x12;
02217     ((Scheme_Random_State *)s)->x20 = rs.x20;
02218     ((Scheme_Random_State *)s)->x21 = rs.x21;
02219     ((Scheme_Random_State *)s)->x22 = rs.x22;
02220 
02221     return scheme_void;
02222   } else {
02223     return s;
02224   }
02225 }
02226 
02227 static Scheme_Object *
02228 sch_pack(int argc, Scheme_Object *argv[])
02229 {
02230   return do_pack("vector->pseudo-random-generator", argc, argv, 0);
02231 }
02232 
02233 static Scheme_Object *
02234 sch_pack_bang(int argc, Scheme_Object *argv[])
02235 {
02236   return do_pack("vector->pseudo-random-generator!", argc, argv, 1);
02237 }
02238 
02239 static Scheme_Object *
02240 sch_unpack(int argc, Scheme_Object *argv[])
02241 {
02242   if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type))
02243     scheme_wrong_type("pseudo-random-generator->vector", "pseudo-random-generator",
02244                     0, argc, argv);
02245 
02246   return unpack_rand_state((Scheme_Random_State *)argv[0]);
02247 }
02248 
02249 static Scheme_Object *current_pseudo_random_generator(int argc, Scheme_Object *argv[])
02250 {
02251   return scheme_param_config("current-pseudo-random-generator", 
02252                           scheme_make_integer(MZCONFIG_RANDOM_STATE),
02253                           argc, argv,
02254                           -1, pseudo_random_generator_p, "pseudo-random-generator", 0);
02255 }
02256 
02257 static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object *argv[])
02258 {
02259   return scheme_param_config("current-evt-pseudo-random-generator", 
02260                           scheme_make_integer(MZCONFIG_SCHEDULER_RANDOM_STATE),
02261                           argc, argv,
02262                           -1, pseudo_random_generator_p, "pseudo-random-generator", 0);
02263 }
02264 
02265 static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv)
02266 {
02267   return scheme_make_random_state(scheme_get_milliseconds());
02268 }
02269 
02270 static Scheme_Object *pseudo_random_generator_p(int argc, Scheme_Object **argv)
02271 {
02272   return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type)) 
02273          ? scheme_true 
02274          : scheme_false);
02275 }
02276