1 /* The bulk of this file is the number parser, an insane bit of code
2 that would probably be better off implemented via lex+yacc, except
3 the error messages are better this way.
4
5 Also, for no particularly good reason, random-number support is
6 here, though the real work is in newrandom.inc. */
7
8 #include "schpriv.h"
9 #include <math.h>
10 #include <string.h>
11 #include <ctype.h>
12
13 static Scheme_Object *decimal_as_inexact_symbol;
14 static Scheme_Object *decimal_as_exact_symbol;
15 static Scheme_Object *read_symbol;
16 static Scheme_Object *number_or_false_symbol;
17
18 static Scheme_Object *number_to_string (int argc, Scheme_Object *argv[]);
19 static Scheme_Object *string_to_number (int argc, Scheme_Object *argv[]);
20
21 static Scheme_Object *bytes_to_integer (int argc, Scheme_Object *argv[]);
22 static Scheme_Object *integer_to_bytes (int argc, Scheme_Object *argv[]);
23 static Scheme_Object *bytes_to_real (int argc, Scheme_Object *argv[]);
24 static Scheme_Object *real_to_bytes (int argc, Scheme_Object *argv[]);
25 static Scheme_Object *bytes_to_long_double (int argc, Scheme_Object *argv[]);
26 static Scheme_Object *long_double_to_bytes (int argc, Scheme_Object *argv[]);
27 static Scheme_Object *system_big_endian_p (int argc, Scheme_Object *argv[]);
28
29 static Scheme_Object *random_seed(int argc, Scheme_Object *argv[]);
30 static Scheme_Object *sch_random(int argc, Scheme_Object *argv[]);
31 static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv);
32 static Scheme_Object *current_pseudo_random_generator(int argc, Scheme_Object **argv);
33 static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object **argv);
34 static Scheme_Object *pseudo_random_generator_p(int argc, Scheme_Object **argv);
35 static Scheme_Object *sch_unpack(int argc, Scheme_Object *argv[]);
36 static Scheme_Object *sch_pack(int argc, Scheme_Object *argv[]);
37 static Scheme_Object *sch_pack_bang(int argc, Scheme_Object *argv[]);
38 static Scheme_Object *sch_check_pack(int argc, Scheme_Object *argv[]);
39
40 static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc);
41
42 static void init_double_fixnum_extremes(void);
43
44 READ_ONLY static char *infinity_str = "+inf.0";
45 READ_ONLY static char *minus_infinity_str = "-inf.0";
46 READ_ONLY static char *not_a_number_str = "+nan.0";
47 READ_ONLY static char *other_not_a_number_str = "-nan.0";
48
49 READ_ONLY static char *long_infinity_str = "+inf.t";
50 READ_ONLY static char *long_minus_infinity_str = "-inf.t";
51 READ_ONLY static char *long_not_a_number_str = "+nan.t";
52 READ_ONLY static char *long_other_not_a_number_str = "-nan.t";
53
54 /* Single-precision float literals.
55 Due to the structure of the reader, they have to be exactly 6
56 characters long. */
57 READ_ONLY static char *single_infinity_str = "+inf.f";
58 READ_ONLY static char *single_minus_infinity_str = "-inf.f";
59 READ_ONLY static char *single_not_a_number_str = "+nan.f";
60 READ_ONLY static char *single_other_not_a_number_str = "-nan.f";
61
62 #if !defined(SIXTY_FOUR_BIT_INTEGERS) && defined(NO_LONG_LONG_TYPE)
63 SHARED_OK static Scheme_Object *num_limits[3];
64 #endif
65
66 READ_ONLY double scheme_double_too_positive_for_fixnum, scheme_double_too_negative_for_fixnum;
67 #ifdef MZ_LONG_DOUBLE
68 READ_ONLY long_double scheme_extfl_too_positive_for_fixnum, scheme_extfl_too_negative_for_fixnum;
69 #endif
70
71 #ifdef SCHEME_BIG_ENDIAN
72 # define MZ_IS_BIG_ENDIAN 1
73 #else
74 # define MZ_IS_BIG_ENDIAN 0
75 #endif
76
77 #define TO_DOUBLE scheme_TO_DOUBLE
78
79 #define zeroi scheme_exact_zero
80
scheme_init_numstr(Scheme_Startup_Env * env)81 void scheme_init_numstr(Scheme_Startup_Env *env)
82 {
83 REGISTER_SO(decimal_as_inexact_symbol);
84 REGISTER_SO(decimal_as_exact_symbol);
85 REGISTER_SO(read_symbol);
86 REGISTER_SO(number_or_false_symbol);
87
88 decimal_as_inexact_symbol = scheme_intern_symbol("decimal-as-inexact");
89 decimal_as_exact_symbol = scheme_intern_symbol("decimal-as-exact");
90 read_symbol = scheme_intern_symbol("read");
91 number_or_false_symbol = scheme_intern_symbol("number-or-false");
92
93 scheme_addto_prim_instance("number->string",
94 scheme_make_immed_prim(number_to_string,
95 "number->string",
96 1, 2),
97 env);
98 scheme_addto_prim_instance("string->number",
99 scheme_make_folding_prim(string_to_number,
100 "string->number",
101 1, 4, 1),
102 env);
103
104 scheme_addto_prim_instance("integer-bytes->integer",
105 scheme_make_immed_prim(bytes_to_integer,
106 "integer-bytes->integer",
107 2, 5),
108 env);
109 scheme_addto_prim_instance("integer->integer-bytes",
110 scheme_make_immed_prim(integer_to_bytes,
111 "integer->integer-bytes",
112 3, 6),
113 env);
114 scheme_addto_prim_instance("floating-point-bytes->real",
115 scheme_make_immed_prim(bytes_to_real,
116 "floating-point-bytes->real",
117 1, 4),
118 env);
119 scheme_addto_prim_instance("real->floating-point-bytes",
120 scheme_make_immed_prim(real_to_bytes,
121 "real->floating-point-bytes",
122 2, 5),
123 env);
124 scheme_addto_prim_instance("system-big-endian?",
125 scheme_make_immed_prim(system_big_endian_p,
126 "system-big-endian?",
127 0, 0),
128 env);
129
130 scheme_addto_prim_instance("random",
131 scheme_make_immed_prim(sch_random,
132 "random",
133 0, 2),
134 env);
135 scheme_addto_prim_instance("random-seed",
136 scheme_make_immed_prim(random_seed,
137 "random-seed",
138 1, 1),
139 env);
140 scheme_addto_prim_instance("make-pseudo-random-generator",
141 scheme_make_immed_prim(make_pseudo_random_generator,
142 "make-pseudo-random-generator",
143 0, 0),
144 env);
145 scheme_addto_prim_instance("vector->pseudo-random-generator",
146 scheme_make_immed_prim(sch_pack,
147 "vector->pseudo-random-generator",
148 1, 1),
149 env);
150 scheme_addto_prim_instance("vector->pseudo-random-generator!",
151 scheme_make_immed_prim(sch_pack_bang,
152 "vector->pseudo-random-generator!",
153 2, 2),
154 env);
155 scheme_addto_prim_instance("pseudo-random-generator->vector",
156 scheme_make_immed_prim(sch_unpack,
157 "pseudo-random-generator->vector",
158 1, 1),
159 env);
160 scheme_addto_prim_instance("pseudo-random-generator-vector?",
161 scheme_make_immed_prim(sch_check_pack,
162 "pseudo-random-generator-vector?",
163 1, 1),
164 env);
165 scheme_addto_prim_instance("pseudo-random-generator?",
166 scheme_make_immed_prim(pseudo_random_generator_p,
167 "pseudo-random-generator?",
168 1, 1),
169 env);
170 scheme_addto_prim_instance("current-pseudo-random-generator",
171 scheme_register_parameter(current_pseudo_random_generator,
172 "current-pseudo-random-generator",
173 MZCONFIG_RANDOM_STATE),
174 env);
175 scheme_addto_prim_instance("current-evt-pseudo-random-generator",
176 scheme_register_parameter(current_sched_pseudo_random_generator,
177 "current-evt-pseudo-random-generator",
178 MZCONFIG_SCHEDULER_RANDOM_STATE),
179 env);
180
181 #if !defined(SIXTY_FOUR_BIT_INTEGERS) && defined(NO_LONG_LONG_TYPE)
182 REGISTER_SO(num_limits);
183 {
184 Scheme_Object *a[2], *v;
185
186 a[0] = scheme_make_integer(1);
187 a[1] = scheme_make_integer(64);
188 a[0] = scheme_bitwise_shift(2, a);
189 v = scheme_sub1(1, a);
190 num_limits[MZ_U8HI] = v;
191 a[0] = v;
192 a[1] = scheme_make_integer(-1);
193 v = scheme_bitwise_shift(2, a);
194 num_limits[MZ_S8HI] = v;
195 a[0] = v;
196 v = scheme_bin_minus(scheme_make_integer(0), scheme_add1(1, a));
197 num_limits[MZ_S8LO] = v;
198 }
199 #endif
200
201 init_double_fixnum_extremes();
202 }
203
scheme_init_extfl_numstr(Scheme_Startup_Env * env)204 void scheme_init_extfl_numstr(Scheme_Startup_Env *env)
205 {
206 scheme_addto_prim_instance("floating-point-bytes->extfl",
207 scheme_make_immed_prim(bytes_to_long_double,
208 "floating-point-bytes->extfl",
209 1, 4),
210 env);
211 scheme_addto_prim_instance("extfl->floating-point-bytes",
212 scheme_make_immed_prim(long_double_to_bytes,
213 "extfl->floating-point-bytes",
214 1, 4),
215 env);
216 }
217
218 # ifdef SIN_COS_NEED_DEOPTIMIZE
219 # pragma optimize("g", off)
220 # define MK_SCH_TRIG(SCH_TRIG, c_trig) static double SCH_TRIG(double d) { return c_trig(d); }
MK_SCH_TRIG(SCH_SIN,sin)221 MK_SCH_TRIG(SCH_SIN, sin)
222 MK_SCH_TRIG(SCH_COS, cos)
223 # pragma optimize("g", on)
224 # else
225 # define SCH_SIN sin
226 # define SCH_COS cos
227 # endif
228
229 /*========================================================================*/
230 /* number parsing */
231 /*========================================================================*/
232
233 #ifndef MZ_LONG_DOUBLE
234 static Scheme_Object *wrap_as_long_double(const char *s, int radix)
235 {
236 Scheme_Long_Double *d;
237
238 d = MALLOC_ONE_TAGGED(Scheme_Long_Double);
239 d->so.type = scheme_long_double_type;
240
241 if (radix == 10)
242 d->printed_form = s;
243 else {
244 char *s2;
245 intptr_t len;
246 len = strlen(s);
247 s2 = (char *)scheme_malloc_atomic(len + 3);
248 memcpy(s2 + 2, s, len+1);
249 s2[0] = '#';
250 s2[1] = ((radix == 8)
251 ? 'o'
252 : ((radix == 2)
253 ? 'b'
254 : 'x'));
255 d->printed_form = s2;
256 }
257
258 return (Scheme_Object *)d;
259 }
260 #endif
261
make_any_long_double()262 Scheme_Object *make_any_long_double()
263 {
264 #ifdef MZ_LONG_DOUBLE
265 return scheme_make_long_double(get_long_double_zero());
266 #else
267 return wrap_as_long_double("1t0", 10);
268 #endif
269 }
270
u_strcmp(mzchar * s,const char * t)271 static int u_strcmp(mzchar *s, const char *t)
272 {
273 int i;
274
275 for (i = 0; s[i] && (s[i] == ((unsigned char *)t)[i]); i++) {
276 }
277 if (s[i] || t[i])
278 return 1;
279 return 0;
280 }
281
read_special_number(const mzchar * str,int pos)282 static Scheme_Object *read_special_number(const mzchar *str, int pos)
283 {
284 if ((str[pos] == '-' || str[pos] == '+') && scheme_isalpha(str[pos + 1])) {
285 mzchar s[7];
286 int i;
287
288 for (i = 0; i < 6; i++) {
289 s[i] = scheme_tolower(str[i + pos]);
290 }
291 s[i] = 0;
292
293 if (!u_strcmp(s, infinity_str)) {
294 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
295 return scheme_single_inf_object;
296 #else
297 return scheme_inf_object;
298 #endif
299 }
300 else if (!u_strcmp(s, minus_infinity_str)) {
301 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
302 return scheme_single_minus_inf_object;
303 #else
304 return scheme_minus_inf_object;
305 #endif
306 }
307 else if (!u_strcmp(s, not_a_number_str)
308 || !u_strcmp(s, other_not_a_number_str)) {
309 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
310 return scheme_single_nan_object;
311 #else
312 return scheme_nan_object;
313 #endif
314 }
315 else if (!u_strcmp(s, long_infinity_str)) {
316 #ifdef MZ_LONG_DOUBLE
317 return scheme_long_inf_object;
318 #else
319 return wrap_as_long_double(long_infinity_str, 10);
320 #endif
321 }
322 else if (!u_strcmp(s, long_minus_infinity_str)) {
323 #ifdef MZ_LONG_DOUBLE
324 return scheme_long_minus_inf_object;
325 #else
326 return wrap_as_long_double(long_minus_infinity_str, 10);
327 #endif
328 }
329 else if (!u_strcmp(s, long_not_a_number_str)
330 || !u_strcmp(s, long_other_not_a_number_str)) {
331 #ifdef MZ_LONG_DOUBLE
332 return scheme_long_nan_object;
333 #else
334 return wrap_as_long_double(long_not_a_number_str, 10);
335 #endif
336 }
337 /* Single-precision specials
338 If single-precision float support is disabled, promote. */
339 else if (!u_strcmp(s, single_infinity_str)) {
340 #ifdef MZ_USE_SINGLE_FLOATS
341 return scheme_single_inf_object;
342 #else
343 return scheme_inf_object;
344 #endif
345 }
346 else if (!u_strcmp(s, single_minus_infinity_str)) {
347 #ifdef MZ_USE_SINGLE_FLOATS
348 return scheme_single_minus_inf_object;
349 #else
350 return scheme_minus_inf_object;
351 #endif
352 }
353 else if (!u_strcmp(s, single_not_a_number_str)
354 || !u_strcmp(s, single_other_not_a_number_str)) {
355 #ifdef MZ_USE_SINGLE_FLOATS
356 return scheme_single_nan_object;
357 #else
358 return scheme_nan_object;
359 #endif
360 }
361 }
362
363 return NULL;
364 }
365
366 /* Exponent threshold for obvious infinity. Must be at least
367 max(MAX_FAST_FLOATREAD_LEN, MAX_FLOATREAD_PRECISION_DIGITS) more
368 than the largest possible FP exponent. */
369 #define CHECK_INF_EXP_THRESHOLD(extfl) (extfl ? 32768 : 2048)
370
371 /* Don't bother reading more than the following number of digits in a
372 floating-point mantissa: */
373 #define MAX_FLOATREAD_PRECISION_DIGITS(extfl) CHECK_INF_EXP_THRESHOLD(extfl)
374
375 #ifdef USE_EXPLICT_FP_FORM_CHECK
376
377 /* Fixes Linux problem of 0e... => non-number (0 with ptr at e...) */
378 /* Fixes SunOS problem with numbers like .3e2666666666666 => 0.0 */
379 /* Fixes HP/UX problem with numbers like .3e2666666666666 => non-number */
380
381 # ifdef MZ_XFORM
382 END_XFORM_ARITH;
383 # endif
384
STRTOD(const char * orig_c,char ** f)385 static double STRTOD(const char *orig_c, char **f)
386 {
387 int neg = 0;
388 int found_dot = 0, is_infinity = 0, is_zero = 0, is_nonzero = 0;
389 const char *c = orig_c;
390
391 *f = (char *)c;
392
393 if (*c == '-') {
394 c++;
395 neg = 1;
396 } else if (*c == '+') {
397 c++;
398 }
399
400 if (!isdigit((unsigned char)*c)) {
401 if (*c == '.') {
402 if (!isdigit((unsigned char)c[1]))
403 return 0; /* no digits - bad! */
404 } else
405 return 0; /* no digits - bad! */
406 }
407
408 for (; *c; c++) {
409 int ch = *c;
410
411 if (isdigit(ch)) {
412 if (ch != '0')
413 is_nonzero = 1;
414 } else if ((ch == 'e') || (ch == 'E')) {
415 int e = 0, neg_exp = 0;
416
417 c++;
418 if (*c == '-') {
419 c++;
420 neg_exp = 1;
421 } else if (*c == '+') {
422 c++;
423 }
424 if (!isdigit((unsigned char)*c))
425 return 0; /* no digits - bad! */
426
427 for (; *c; c++) {
428 int ch = *c;
429 if (!isdigit(ch))
430 return 0; /* not a digit - bad! */
431 else {
432 /* only increment e until we know if it is
433 infinity or zero to avoid overflow on e */
434 if (!is_zero && !is_infinity)
435 e = (e * 10) + (ch - '0');
436 if (e > CHECK_INF_EXP_THRESHOLD(0)) {
437 if (neg_exp || !is_nonzero)
438 is_zero = 1;
439 else
440 is_infinity = 1;
441 }
442 }
443 }
444
445 break;
446 } else if (ch == '.') {
447 if (found_dot)
448 return 0; /* two dots - shouldn't happen */
449 found_dot = 1;
450 } else
451 return 0; /* unknown non-digit - shouldn't happen */
452 }
453
454 *f = (char *)c;
455
456 if (is_infinity) {
457 if (neg)
458 return scheme_minus_infinity_val;
459 else
460 return scheme_infinity_val;
461 }
462
463 if (is_zero) {
464 if (neg)
465 return scheme_floating_point_nzero;
466 else
467 return scheme_floating_point_zero;
468 }
469
470 /* It's OK if c is ok: */
471 return strtod(orig_c, NULL);
472 }
473
474 # ifdef MZ_XFORM_GC
475 START_XFORM_ARITH;
476 # endif
477 #else
478 # define STRTOD(x, y) strtod(x, y)
479 #endif
480
481 #ifdef MZ_LONG_DOUBLE
482 # define CHECK_SINGLE(v, s, il, l, str, len, radix) do_CHECK_SINGLE(v, s, il, l, NULL, 0, 0)
483 #else
484 # define CHECK_SINGLE(v, s, il, l, str, len, radix) do_CHECK_SINGLE(v, s, il, NULL, str, len, radix)
485 #endif
486
do_CHECK_SINGLE(Scheme_Object * v,int s,int long_dbl,Scheme_Object * lv,const mzchar * str,intptr_t len,int radix)487 static Scheme_Object *do_CHECK_SINGLE(Scheme_Object *v, int s, int long_dbl,
488 Scheme_Object *lv, const mzchar *str, intptr_t len, int radix)
489 {
490 if (SCHEME_DBLP(v)) {
491 #ifdef MZ_USE_SINGLE_FLOATS
492 if (s)
493 return scheme_make_float((float)SCHEME_DBL_VAL(v));
494 #endif
495 if (long_dbl) {
496 #ifdef MZ_LONG_DOUBLE
497 return lv;
498 #else
499 return wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix);
500 #endif
501 }
502 }
503
504 return v;
505 }
506
507 #define DISALLOW_EXTFLONUM(special, other) \
508 if ((special && SCHEME_LONG_DBLP(special)) || (other && SCHEME_LONG_DBLP(other))) { \
509 if (report) \
510 return scheme_numr_err(complain, \
511 "cannot combine extflonum into complex number: %u", \
512 str, len); \
513 return scheme_false; \
514 }
515
516 /*
517 The scheme_read-number() parser could be simplified somewhat,
518 because it only has to work for:
519
520 - `string->number` when called on a well-formed fixnum, bignum,
521 {double-,single-,ext}flonum;
522
523 - reading S-expression literals from bytes, where numbers will be
524 in a canonical form (no `#`), but where symbols still must be
525 distinguished from numbers; and
526
527 - printing symbols, to detect when they need to be escaped.
528
529 For those purposes, it doesn't need to provide good error messages,
530 deal with non-default exactness, or handle non-base-10
531 representations for non-real numbers.
532 */
scheme_read_number(const mzchar * str,intptr_t len,int is_float,int is_not_float,int decimal_means_float,int radix,int radix_set,Scheme_Object * complain,int * div_by_zero,int test_only)533 Scheme_Object *scheme_read_number(const mzchar *str, intptr_t len,
534 int is_float,
535 int is_not_float,
536 int decimal_means_float,
537 int radix, int radix_set,
538 Scheme_Object *complain,
539 int *div_by_zero,
540 int test_only)
541 {
542 int i, has_decimal, must_parse, has_slash;
543 int report, delta;
544 Scheme_Object *next_complain;
545 int has_hash, has_expt, has_i, has_sign, has_at, has_hash_since_slash;
546 int saw_digit_since_slash, saw_nonzero_digit;
547 Scheme_Object *o;
548 #ifdef MZ_USE_SINGLE_FLOATS
549 int sgl;
550 #endif
551 int is_long_double = 0;
552
553 if (len < 0)
554 len = scheme_char_strlen(str);
555
556 delta = 0;
557
558 while (str[delta] == '#') {
559 if (str[delta+1] != 'E' && str[delta+1] != 'e' && str[delta+1] != 'I' && str[delta+1] != 'i') {
560 if (radix_set) {
561 if (complain)
562 return scheme_numr_err(complain,
563 "bad radix specification in `%u`",
564 str, len);
565 else
566 return scheme_false;
567 }
568 radix_set = 1;
569 } else {
570 if (is_float || is_not_float) {
571 if (complain)
572 return scheme_numr_err(complain,
573 "bad exactness specification in `%u`",
574 str, len);
575 else
576 return scheme_false;
577 }
578 }
579
580 switch (str[delta+1]) {
581 case 'B':
582 case 'b':
583 radix = 2;
584 break;
585 case 'O':
586 case 'o':
587 radix = 8;
588 break;
589 case 'D':
590 case 'd':
591 radix = 10;
592 break;
593 case 'X':
594 case 'x':
595 radix = 16;
596 break;
597 case 'I':
598 case 'i':
599 is_float = 1;
600 break;
601 case 'E':
602 case 'e':
603 is_not_float = 1;
604 break;
605 default:
606 if (complain)
607 return scheme_numr_err(complain,
608 "bad `#` indicator `%c` in `%u`",
609 str[delta+1], str, len);
610 return scheme_false;
611 }
612 delta += 2;
613 }
614
615 must_parse = (radix_set || is_float || is_not_float);
616
617 report = complain && must_parse;
618 next_complain = must_parse ? complain : NULL;
619
620 if (!(len - delta)) {
621 if (report)
622 return scheme_numr_err(complain, "no digits");
623 return scheme_false;
624 }
625
626 /* look for +inf.0, etc: */
627 if (len - delta == 6) {
628 Scheme_Object *special;
629 special = read_special_number(str, delta);
630 if (special) {
631 if (!is_not_float)
632 return special;
633 if (report)
634 return scheme_numr_err(complain,
635 "no exact representation for %V",
636 special);
637 return scheme_false;
638 }
639 }
640
641 /* Look for <special>+...i and ...<special>i */
642 if ((len-delta > 7) && str[len-1] == 'i') {
643 Scheme_Object *special;
644 mzchar *s2;
645
646 /* Try <special>+...i */
647 special = read_special_number(str, delta);
648 if (special) {
649 s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6 + 4 + 1) * sizeof(mzchar));
650 s2[0] = '+';
651 s2[1] = '0';
652 s2[2] = (SCHEME_DBLP(special) ? '.' : 's');
653 s2[3] = '0';
654 memcpy(s2 + 4, str + delta + 6, (len - delta - 5) * sizeof(mzchar));
655 } else {
656 /* Try ...<special>i: */
657 special = read_special_number(str, len - 7);
658 if (special) {
659 s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6 + 4 + 1) * sizeof(mzchar));
660 memcpy(s2, str + delta, (len - delta - 7) * sizeof(mzchar));
661 s2[len - delta - 7] = '+';
662 s2[len - delta - 7 + 1] = '0';
663 s2[len - delta - 7 + 2] = (SCHEME_DBLP(special) ? '.' : 's');
664 s2[len - delta - 7 + 3] = '0';
665 s2[len - delta - 7 + 4] = 'i';
666 s2[len - delta - 7 + 5] = 0;
667 if (!SCHEME_LONG_DBLP(special))
668 special = scheme_bin_mult(special, scheme_plus_i);
669 } else
670 s2 = NULL;
671 }
672
673 if (special) {
674 Scheme_Object *other;
675 int dbz = 0;
676
677 if (is_not_float) {
678 if (report)
679 return scheme_numr_err(complain,
680 "no exact representation for %V",
681 special);
682 return scheme_false;
683 }
684
685 other = scheme_read_number(s2, len - delta - 6 + 4,
686 is_float, is_not_float, 1,
687 radix, 1, 0,
688 &dbz, test_only);
689
690 if (SCHEME_CHAR_STRINGP(other))
691 return other;
692
693 DISALLOW_EXTFLONUM(special, other);
694
695 if (dbz) {
696 if (div_by_zero)
697 *div_by_zero = 1;
698 if (complain)
699 return scheme_numr_err(complain,
700 "division by zero in `%u`",
701 str, len);
702 return scheme_false;
703 }
704
705 if (!SCHEME_FALSEP(other))
706 return scheme_bin_plus(special, other);
707
708 if (!complain)
709 return scheme_false;
710 }
711 } else if ((len-delta == 7) && str[len-1] == 'i') {
712 /* Try <special>i */
713 Scheme_Object *special;
714 special = read_special_number(str, delta);
715 if (special) {
716 special = scheme_make_complex(scheme_make_integer(0), special);
717
718 if (is_not_float) {
719 if (report)
720 return scheme_numr_err(complain,
721 "no exact representation for %V",
722 special);
723 return scheme_false;
724 }
725
726 DISALLOW_EXTFLONUM(special, special);
727
728 return special;
729 }
730 }
731
732 /* Look for <special>@... and ...@<special> */
733 if ((len - delta > 7) && ((str[delta+6] == '@') || (str[len - 7] == '@'))) {
734 Scheme_Object *special;
735 mzchar *s2;
736 int spec_mag = 0;
737
738 /* Try <special>@... */
739 if (str[delta+6] == '@')
740 special = read_special_number(str, delta);
741 else
742 special = NULL;
743 if (special) {
744 s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6) * sizeof(mzchar));
745 memcpy(s2, str + delta + 7, (len - delta - 6) * sizeof(mzchar));
746 spec_mag = 1;
747 } else {
748 if (str[len - 7] == '@')
749 special = read_special_number(str, len - 6);
750 else
751 special = NULL;
752
753 if (special) {
754 s2 = (mzchar *)scheme_malloc_atomic((len - delta - 6) * sizeof(mzchar));
755 memcpy(s2, str + delta, (len - delta - 7) * sizeof(mzchar));
756 s2[len - delta - 7] = 0;
757 } else
758 s2 = NULL;
759 }
760
761 if (special) {
762 Scheme_Object *other;
763 int dbz = 0;
764
765 /* s2 can't contain @: */
766 for (i = 0; s2[i]; i++) {
767 if (s2[i] == '@')
768 break;
769 }
770
771 if (s2[i])
772 other = scheme_false;
773 else
774 other = scheme_read_number(s2, len - delta - 7,
775 is_float, is_not_float, 1,
776 radix, 1, 0,
777 &dbz, test_only);
778
779 if (SCHEME_CHAR_STRINGP(other))
780 return other;
781
782 DISALLOW_EXTFLONUM(special, other);
783
784 if (dbz) {
785 if (div_by_zero)
786 *div_by_zero = 1;
787 if (complain)
788 return scheme_numr_err(complain,
789 "division by zero in `%u`",
790 str, len);
791 return scheme_false;
792 }
793
794 if (!SCHEME_FALSEP(other)) {
795 /* If string is complex, not well-formed: */
796 if (!SCHEME_COMPLEXP(other)) {
797 Scheme_Object *a[2];
798 if (spec_mag) {
799 a[0] = special;
800 a[1] = other;
801 } else {
802 a[0] = other;
803 a[1] = special;
804 }
805
806 return scheme_make_polar(2, a);
807 }
808 }
809
810 if (!complain)
811 return scheme_false;
812 }
813 }
814
815 #define isinexactmark(ch) ((ch == 'e') || (ch == 'E') \
816 || (ch == 's') || (ch == 'S') \
817 || (ch == 'f') || (ch == 'F') \
818 || (ch == 'd') || (ch == 'D') \
819 || (ch == 'l') || (ch == 'L') \
820 || (ch == 't') || (ch == 'T'))
821
822 #define isAdigit(ch) ((ch >= '0') && (ch <= '9'))
823
824
825 #define isbaseNdigit(N, ch) (((ch >= 'a') && (ch <= (mzchar)('a' + N - 11))) \
826 || ((ch >= 'A') && (ch <= (mzchar)('A' + N - 11))))
827
828 has_i = 0;
829 has_at = 0;
830 has_sign = delta-1;
831 for (i = delta; i < len; i++) {
832 mzchar ch = str[i];
833 if (!ch) {
834 if (report)
835 return scheme_numr_err(complain,
836 "embedded null character in `%u`",
837 str, len);
838 return scheme_false;
839 } else if (isinexactmark(ch) && ((radix <= 10) || !isbaseNdigit(radix, ch))) {
840 /* If a sign follows, don't count it */
841 if (str[i+1] == '+' || str[i+1] == '-')
842 i++;
843 } else if ((ch == '+') || (ch == '-')) {
844 if ((has_sign > delta) || ((has_sign == delta) && (i == delta+1))) {
845 if (report)
846 return scheme_numr_err(complain,
847 "too many signs in `%u`",
848 str, len);
849 return scheme_false;
850 }
851 has_sign = i;
852 } else if (((ch == 'I') || (ch == 'i')) && (has_sign >= delta)) {
853 if (has_at) {
854 if (report)
855 return scheme_numr_err(complain,
856 "cannot mix `@` and `i` in `%u`",
857 str, len);
858 return scheme_false;
859 }
860 if (i + 1 < len) {
861 if (report)
862 return scheme_numr_err(complain,
863 "`i' must be at the end in `%u`",
864 str, len);
865 return scheme_false;
866 }
867 has_i = i;
868 } else if (ch == '@') {
869 if (has_at) {
870 if (report)
871 return scheme_numr_err(complain,
872 "too many `@`s in `%u`",
873 str, len);
874 return scheme_false;
875 }
876 if (i == delta) {
877 if (report)
878 return scheme_numr_err(complain,
879 "`@` cannot be at start in `%u`",
880 str, len);
881 return scheme_false;
882 }
883 has_at = i;
884 if (has_sign >= delta)
885 has_sign = delta-1;
886 }
887 }
888
889 if (has_i) {
890 Scheme_Object *n1, *n2;
891 mzchar *first, *second;
892 int fdbz = 0, sdbz = 0;
893
894 if (has_sign != delta) {
895 first = (mzchar *)scheme_malloc_atomic((has_sign - delta + 1) * sizeof(mzchar));
896 memcpy(first, str + delta, (has_sign - delta) * sizeof(mzchar));
897 first[has_sign - delta] = 0;
898 } else
899 first = NULL;
900
901 if (has_i - has_sign > 1) {
902 second = (mzchar *)scheme_malloc_atomic((has_i - has_sign + 1) * sizeof(mzchar));
903 memcpy(second, str + has_sign, (has_i - has_sign) * sizeof(mzchar));
904 second[has_i - has_sign] = 0;
905 } else
906 second = NULL;
907
908 if (first) {
909 n1 = scheme_read_number(first, has_sign - delta,
910 is_float, is_not_float, decimal_means_float,
911 radix, 1, next_complain,
912 &fdbz, test_only);
913 if (SCHEME_CHAR_STRINGP(n1))
914 return n1;
915 } else
916 n1 = zeroi;
917
918 if (SAME_OBJ(n1, scheme_false) && !fdbz)
919 return scheme_false;
920 /* This +nan.0 test looks unnecessary -- Matthew, 08/14/01 */
921 else if (SCHEME_FLOATP(n1)) {
922 double d = SCHEME_FLOAT_VAL(n1);
923 if (MZ_IS_NAN(d))
924 return scheme_false;
925 }
926
927 if (second) {
928 n2 = scheme_read_number(second, has_i - has_sign,
929 is_float, is_not_float, decimal_means_float,
930 radix, 1, next_complain,
931 &sdbz, test_only);
932 if (SCHEME_CHAR_STRINGP(n2))
933 return n2;
934 } else if (str[has_sign] == '-')
935 n2 = scheme_make_integer(-1);
936 else
937 n2 = scheme_make_integer(1);
938
939 if (SAME_OBJ(n2, scheme_false) && !sdbz)
940 return scheme_false;
941 /* This +nan.0 test looks unnecessary -- Matthew, 08/14/01 */
942 else if (SCHEME_FLOATP(n2)) {
943 double d = SCHEME_FLOAT_VAL(n2);
944 if (MZ_IS_NAN(d))
945 return scheme_false;
946 }
947
948 DISALLOW_EXTFLONUM(n1, n2);
949
950 if (fdbz || sdbz) {
951 if (div_by_zero)
952 *div_by_zero = 1;
953 if (complain)
954 return scheme_numr_err(complain,
955 "division by zero in `%u`",
956 str, len);
957 return scheme_false;
958 }
959
960 if (!is_not_float && ((SCHEME_FLOATP(n1) && (n2 != zeroi)) || is_float))
961 n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */
962 else if (is_not_float)
963 n2 = scheme_inexact_to_exact(1, &n2);
964
965 if (!is_not_float && ((SCHEME_FLOATP(n2) && (n1 != zeroi)) || is_float))
966 n1 = scheme_exact_to_inexact(1, &n1); /* uses default conversion: float or double */
967 else if (is_not_float)
968 n1 = scheme_inexact_to_exact(1, &n1);
969
970 return scheme_make_complex(n1, n2);
971 }
972
973 if (has_at) {
974 Scheme_Object *n1, *n2;
975 double d1, d2, r1, r2;
976 mzchar *first;
977 const mzchar *second;
978 int fdbz = 0, sdbz = 0;
979
980 first = (mzchar *)scheme_malloc_atomic((has_at - delta + 1) * sizeof(mzchar));
981 memcpy(first, str + delta, (has_at - delta) * sizeof(mzchar));
982 first[has_at - delta] = 0;
983
984 #ifdef MZ_PRECISE_GC
985 {
986 /* Can't pass mis-aligned pointer to scheme_read_number. */
987 int slen = len - (has_at + 1) + 1;
988 second = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
989 memcpy((mzchar *)second, str + has_at + 1, slen * sizeof(mzchar));
990 }
991 #else
992 second = str + has_at + 1;
993 #endif
994
995 n2 = scheme_read_number(second, len - has_at - 1,
996 is_float, is_not_float, decimal_means_float,
997 radix, 1, next_complain,
998 &fdbz, test_only);
999
1000 if (SCHEME_CHAR_STRINGP(n2))
1001 return n2;
1002
1003 if (!fdbz) {
1004 if (SCHEME_FALSEP(n2))
1005 return scheme_false;
1006
1007 /* Special case: angle is zero => real number */
1008 if (n2 == zeroi)
1009 return scheme_read_number(first, has_at - delta,
1010 is_float, is_not_float, decimal_means_float,
1011 radix, 1, complain,
1012 div_by_zero,
1013 test_only);
1014
1015 if (!SCHEME_LONG_DBLP(n2)) {
1016 n2 = scheme_exact_to_inexact(1, &n2); /* uses default conversion: float or double */
1017
1018 d2 = SCHEME_FLOAT_VAL(n2);
1019
1020 /* This +nan.0 test looks unnecessary -- Matthew, 08/14/01 */
1021 if (MZ_IS_NAN(d2))
1022 return scheme_false;
1023 } else
1024 d2 = 0.0; /* not used; will signal error later */
1025
1026 n1 = scheme_read_number(first, has_at - delta,
1027 is_float, is_not_float, decimal_means_float,
1028 radix, 1, next_complain,
1029 &sdbz,
1030 test_only);
1031
1032 if (SCHEME_CHAR_STRINGP(n1))
1033 return n1;
1034
1035 /* Special case: magnitude is zero => zero */
1036 if (n1 == zeroi)
1037 return zeroi;
1038
1039 if (!SCHEME_FALSEP(n1) && !SCHEME_LONG_DBLP(n1))
1040 n1 = scheme_exact_to_inexact(1, &n1); /* uses default conversion: float or double */
1041 } else {
1042 n1 = NULL;
1043 d2 = 0;
1044 }
1045
1046 DISALLOW_EXTFLONUM(n1, n2);
1047
1048 if (fdbz || sdbz) {
1049 if (div_by_zero)
1050 *div_by_zero = 1;
1051 if (complain)
1052 return scheme_numr_err(complain,
1053 "division by zero in `%u`",
1054 str, len);
1055 return scheme_false;
1056 }
1057
1058 if (SCHEME_FALSEP(n1))
1059 return scheme_false;
1060
1061 d1 = SCHEME_FLOAT_VAL(n1);
1062
1063 /* This +nan.0 test looks unnecessary -- Matthew, 08/14/01 */
1064 if (MZ_IS_NAN(d1))
1065 return scheme_false;
1066
1067 r1 = d1 * SCH_COS(d2);
1068 r2 = d1 * SCH_SIN(d2);
1069
1070 #ifdef MZ_USE_SINGLE_FLOATS
1071 if (SCHEME_FLTP(n1) && SCHEME_FLTP(n2))
1072 n1 = scheme_make_complex(scheme_make_float((float)r1),
1073 scheme_make_float((float)r2));
1074 else
1075 #endif
1076 n1 = scheme_make_complex(scheme_make_double(r1),
1077 scheme_make_double(r2));
1078
1079 if (is_not_float)
1080 n1 = scheme_inexact_to_exact(1, &n1);
1081
1082 return n1;
1083 }
1084
1085 has_decimal = has_slash = has_hash = has_hash_since_slash = has_expt = 0;
1086 saw_digit_since_slash = saw_nonzero_digit = 0;
1087 for (i = delta; i < len; i++) {
1088 mzchar ch = str[i];
1089 if (ch == '.') {
1090 if (has_decimal) {
1091 if (report)
1092 return scheme_numr_err(complain,
1093 "multiple decimal points in `%u`",
1094 str, len);
1095 return scheme_false;
1096 }
1097 if (has_slash) {
1098 if (report)
1099 return scheme_numr_err(complain,
1100 "decimal points and fractions "
1101 "cannot be mixed in `%u`",
1102 str, len);
1103 return scheme_false;
1104 }
1105 has_decimal = 1;
1106 } else if (isinexactmark(ch)
1107 && ((radix <= 10) || !isbaseNdigit(radix, ch))) {
1108 if (i == delta) {
1109 if (report)
1110 return scheme_numr_err(complain,
1111 "cannot begin with `%c` in `%u`",
1112 ch, str, len);
1113 return scheme_false;
1114 }
1115 has_expt = i;
1116 break;
1117 } else if (ch == '/') {
1118 if (i == delta) {
1119 if (report)
1120 return scheme_numr_err(complain,
1121 "cannot have slash at start in `%u`",
1122 str, len);
1123 return scheme_false;
1124 }
1125 if (has_slash) {
1126 if (report)
1127 return scheme_numr_err(complain,
1128 "multiple slashes in `%u`",
1129 str, len);
1130 return scheme_false;
1131 }
1132 if (has_decimal) {
1133 if (report)
1134 return scheme_numr_err(complain,
1135 "decimal points and fractions "
1136 "cannot be mixed in `%u`",
1137 str, len);
1138 return scheme_false;
1139 }
1140 has_slash = i;
1141 saw_digit_since_slash = 0;
1142 has_hash_since_slash = 0;
1143 } else if ((ch == '-') || (ch == '+')) {
1144 if (has_slash || has_decimal || has_hash) {
1145 if (report)
1146 return scheme_numr_err(complain,
1147 "misplaced sign in `%u`",
1148 str, len);
1149 return scheme_false;
1150 }
1151 } else if (ch == '#') {
1152 if (!saw_digit_since_slash) {
1153 if (report)
1154 return scheme_numr_err(complain,
1155 "misplaced hash in `%u`",
1156 str, len);
1157 return scheme_false;
1158 }
1159 has_hash = 1;
1160 has_hash_since_slash = 1;
1161 } else if (!isAdigit(ch) && !((radix > 10) && isbaseNdigit(radix, ch))) {
1162 if (has_decimal) {
1163 if (report)
1164 return scheme_numr_err(complain,
1165 "bad decimal number in `%u`",
1166 str, len);
1167 return scheme_false;
1168 }
1169 if (has_hash) {
1170 if (report)
1171 return scheme_numr_err(complain,
1172 "misplaced hash in `%u`",
1173 str, len);
1174 return scheme_false;
1175 }
1176 break;
1177 } else {
1178 saw_digit_since_slash = 1;
1179 if (ch != '0')
1180 saw_nonzero_digit = 1;
1181 if (has_hash_since_slash) {
1182 if (report)
1183 return scheme_numr_err(complain,
1184 "misplaced hash in `%u`",
1185 str, len);
1186 return scheme_false;
1187 }
1188 }
1189 }
1190
1191 #ifdef MZ_USE_SINGLE_FLOATS
1192 if (has_expt && str[has_expt]) {
1193 sgl = str[has_expt];
1194 sgl = ((sgl == 'f') || (sgl == 'F')
1195 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
1196 || (sgl == 'e') || (sgl == 'E')
1197 #endif
1198 || (sgl == 's') || (sgl == 'S'));
1199 } else {
1200 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
1201 sgl = 1;
1202 # else
1203 sgl = 0;
1204 # endif
1205 }
1206 #endif
1207
1208 if (has_expt && str[has_expt]) {
1209 is_long_double = str[has_expt];
1210 is_long_double = ((is_long_double == 't') || (is_long_double == 'T'));
1211 } else {
1212 is_long_double = 0;
1213 }
1214
1215 #define MAX_FAST_FLOATREAD_LEN 50
1216 /* When possible, use the standard floating-point parser */
1217 if (!is_not_float && (is_float || decimal_means_float)
1218 && !has_slash && !has_hash && (radix == 10)
1219 && (has_decimal || has_expt)
1220 && (len <= MAX_FAST_FLOATREAD_LEN)
1221 && (!is_long_double || MZ_LONG_DOUBLE_AND(1))) {
1222 double d = 1.0;
1223 #ifdef MZ_LONG_DOUBLE
1224 mz_long_double ld;
1225 #endif
1226 GC_CAN_IGNORE char *ptr;
1227
1228 #ifdef MZ_LONG_DOUBLE
1229 memset(&ld, 0, sizeof(ld)); /* avoid a compiler warning */
1230 #endif
1231
1232 if (has_expt && !(str[has_expt + 1])) {
1233 if (report)
1234 return scheme_numr_err(complain,
1235 "no digits after `%c` in `%u`",
1236 str[has_expt], str, len);
1237 return scheme_false;
1238 }
1239
1240 {
1241 /* We'd like to use strtod() for the common case, but we don't trust it entirely. */
1242 char ffl_buf[MAX_FAST_FLOATREAD_LEN + 1];
1243 GC_CAN_IGNORE char *loc;
1244
1245 {
1246 int k;
1247 for (k = delta; k < len; k++) {
1248 if (str[k] > 127)
1249 ffl_buf[k - delta] = '?';
1250 else
1251 ffl_buf[k - delta] = str[k];
1252 }
1253 ffl_buf[len - delta] = 0;
1254 }
1255
1256 if (has_expt && (str[has_expt] != 'e' && str[has_expt] != 'E')) {
1257 ffl_buf[has_expt - delta] = 'e';
1258 }
1259
1260 loc = scheme_push_c_numeric_locale();
1261
1262 #ifdef MZ_LONG_DOUBLE
1263 if (is_long_double)
1264 ld = long_double_from_string(ffl_buf, &ptr);
1265 else
1266 #endif
1267 d = STRTOD(ffl_buf, &ptr);
1268
1269 scheme_pop_c_numeric_locale(loc);
1270
1271 if ((ptr XFORM_OK_MINUS ffl_buf) < (len - delta)) {
1272 if (report)
1273 return scheme_numr_err(complain,
1274 "bad decimal number `%u`",
1275 str, len);
1276 return scheme_false;
1277 }
1278 }
1279
1280 if (is_long_double && is_float) {
1281 if (report)
1282 return scheme_numr_err(complain,
1283 "cannot convert extflonum to inexact in `%u`",
1284 str, len);
1285 return scheme_false;
1286 }
1287
1288 if (!saw_nonzero_digit) {
1289 /* Assert: d = 0.0 or -0.0 */
1290 if (str[delta] == '-') {
1291 /* Make sure it's -0.0 */
1292 #ifdef MZ_USE_SINGLE_FLOATS
1293 if (sgl) return scheme_nzerof;
1294 #endif
1295 #ifdef MZ_LONG_DOUBLE
1296 if (is_long_double) return scheme_nzerol;
1297 #endif
1298 return scheme_nzerod;
1299 }
1300 }
1301
1302 if (!d) {
1303 if (str[delta] == '-') {
1304 /* Make sure it's -0.0 */
1305 #ifdef MZ_USE_SINGLE_FLOATS
1306 if (sgl) return scheme_nzerof;
1307 #endif
1308 return scheme_nzerod;
1309 }
1310 }
1311
1312 #ifdef MZ_LONG_DOUBLE
1313 if (is_long_double && long_double_is_zero(ld)) {
1314 if (str[delta] == '-') {
1315 /* Make sure it's -0.0 */
1316 return scheme_nzerol;
1317 }
1318 }
1319 #endif
1320
1321 #ifdef MZ_USE_SINGLE_FLOATS
1322 if (sgl)
1323 return scheme_make_float((float)d);
1324
1325 #endif
1326 #ifdef MZ_LONG_DOUBLE
1327 if (is_long_double) return scheme_make_long_double(ld);
1328 #endif
1329 return scheme_make_double(d);
1330 }
1331
1332 if (has_decimal || has_expt || (has_hash && !has_slash)) {
1333 Scheme_Object *mantissa, *exponent, *power, *n;
1334 Scheme_Object *args[2];
1335 int result_is_float = (is_float || (!is_not_float && (decimal_means_float
1336 || is_long_double)));
1337
1338 if (has_expt) {
1339 mzchar *substr;
1340
1341 if (!str[has_expt + 1]) {
1342 if (report)
1343 return scheme_numr_err(complain,
1344 "no digits after `%c` in `%u`",
1345 str[has_expt], str, len);
1346 return scheme_false;
1347 }
1348
1349 #ifdef MZ_PRECISE_GC
1350 {
1351 /* Can't pass misaligned pointer to scheme_read_bignum: */
1352 int slen = len - (has_expt + 1) + 1;
1353 substr = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
1354 memcpy(substr, str + has_expt + 1, slen * sizeof(mzchar));
1355 }
1356 #else
1357 substr = (mzchar *)str + has_expt + 1;
1358 #endif
1359
1360 exponent = scheme_read_bignum(substr, 0, radix);
1361 if (SCHEME_FALSEP(exponent)) {
1362 if (report)
1363 return scheme_numr_err(complain,
1364 "bad exponent in `%u`",
1365 str, len);
1366 return scheme_false;
1367 }
1368 } else
1369 exponent = zeroi;
1370
1371 if (!has_expt)
1372 has_expt = len;
1373
1374 if (has_slash) {
1375 /* Mantissa is a fraction. */
1376 mzchar *s;
1377 int dbz;
1378
1379 s = (mzchar *)scheme_malloc_atomic((has_expt - delta + 1) * sizeof(mzchar));
1380 memcpy(s, str + delta, (has_expt - delta) * sizeof(mzchar));
1381 s[has_expt - delta] = 0;
1382
1383 mantissa = scheme_read_number(s, has_expt - delta,
1384 is_float, is_not_float, 1,
1385 radix, 1, next_complain,
1386 &dbz,
1387 test_only);
1388
1389 if (SCHEME_CHAR_STRINGP(mantissa))
1390 return mantissa;
1391
1392 if (SCHEME_FALSEP(mantissa)) {
1393 if (dbz) {
1394 if (div_by_zero)
1395 *div_by_zero = 1;
1396 if (complain)
1397 return scheme_numr_err(complain,
1398 "division by zero in `%u`",
1399 str, len);
1400 }
1401 if (report)
1402 return scheme_numr_err(complain,
1403 "bad number `%u`",
1404 str, len);
1405 return scheme_false;
1406 }
1407 } else {
1408 /* Mantissa is not a fraction. */
1409 mzchar *digits;
1410 int extra_power = 0, dcp = 0, non_zero = 0, num_ok;
1411
1412 digits = (mzchar *)scheme_malloc_atomic((has_expt - delta + 1) * sizeof(mzchar));
1413
1414 i = delta;
1415 if (str[i] == '+' || str[i] == '-')
1416 digits[dcp++] = str[i++];
1417
1418 for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) {
1419 if ((radix < 10) && ((str[i] - '0') >= radix))
1420 break;
1421 digits[dcp++] = str[i];
1422 if (str[i] != '0')
1423 non_zero = 1;
1424 }
1425
1426 if (str[i] == '#') {
1427 for (; str[i] == '#'; i++) {
1428 digits[dcp++] = '0';
1429 }
1430 num_ok = 0;
1431 } else
1432 num_ok = 1;
1433
1434 if (str[i] == '.') {
1435 i++;
1436 if (num_ok)
1437 for (; isAdigit(str[i]) || ((radix > 10) && isbaseNdigit(radix, str[i])); i++) {
1438 if ((radix < 10) && ((str[i] - '0') >= radix))
1439 break;
1440 digits[dcp++] = str[i];
1441 extra_power++;
1442 if (str[i] != '0')
1443 non_zero = 1;
1444 }
1445
1446 for (; str[i] == '#'; i++) {
1447 digits[dcp++] = '0';
1448 extra_power++;
1449 }
1450 }
1451
1452 if ((str[i] && (!has_expt || i != has_expt))
1453 || !dcp || (dcp == 1 && !(isAdigit(digits[0])
1454 || ((radix > 10) && isbaseNdigit(radix, digits[0]))))) {
1455 if (report)
1456 return scheme_numr_err(complain,
1457 "bad decimal number `%u`",
1458 str, len);
1459 return scheme_false;
1460 }
1461
1462 if (is_long_double && is_float) {
1463 if (report)
1464 return scheme_numr_err(complain,
1465 "cannot convert extflonum to inexact in `%u`",
1466 str, len);
1467 return scheme_false;
1468 }
1469
1470 /* Zero mantissa => zero inexact result */
1471 if (!non_zero && result_is_float) {
1472 if (dcp && (digits[0] == '-'))
1473 return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double, scheme_nzerol, str, len, radix);
1474 else
1475 return CHECK_SINGLE(scheme_zerod, sgl, is_long_double, scheme_zerol, str, len, radix);
1476 }
1477
1478 /* Reduce unnecessary mantissa-reading work for inexact results. */
1479 if (result_is_float) {
1480 Scheme_Object *max_useful;
1481
1482 max_useful = scheme_bin_plus(scheme_make_integer(MAX_FLOATREAD_PRECISION_DIGITS(is_long_double)),
1483 exponent);
1484 if (scheme_bin_lt(max_useful, scheme_make_integer(2))) {
1485 /* will definitely underflow */
1486 if (dcp > 2)
1487 dcp = 2; /* leave room for a sign and a digit */
1488 } else if (SCHEME_INTP(max_useful)) {
1489 if (result_is_float && (dcp > SCHEME_INT_VAL(max_useful))) {
1490 extra_power -= (dcp - SCHEME_INT_VAL(max_useful));
1491 dcp = SCHEME_INT_VAL(max_useful);
1492 }
1493 }
1494 }
1495
1496 digits[dcp] = 0;
1497 mantissa = scheme_read_bignum(digits, 0, radix);
1498 if (SCHEME_FALSEP(mantissa)) {
1499 scheme_signal_error("internal error parsing mantissa: %s", digits);
1500 return scheme_false;
1501 }
1502
1503 if (extra_power)
1504 exponent = scheme_bin_minus(exponent, scheme_make_integer(extra_power));
1505
1506 /* Don't calculate a huge exponential if we're returning a float: */
1507 if (result_is_float) {
1508 if (scheme_bin_gt(exponent, scheme_make_integer(CHECK_INF_EXP_THRESHOLD(is_long_double)))) {
1509 if (scheme_is_negative(mantissa))
1510 return CHECK_SINGLE(scheme_minus_inf_object, sgl, is_long_double, scheme_long_minus_inf_object, str, len, radix);
1511 else
1512 return CHECK_SINGLE(scheme_inf_object, sgl, is_long_double, scheme_long_inf_object, str, len, radix);
1513 } else if (scheme_bin_lt(exponent, scheme_make_integer(-CHECK_INF_EXP_THRESHOLD(is_long_double)))) {
1514 if (scheme_is_negative(mantissa))
1515 return CHECK_SINGLE(scheme_nzerod, sgl, is_long_double, scheme_nzerol, str, len, radix);
1516 else
1517 return CHECK_SINGLE(scheme_zerod, sgl, is_long_double, scheme_zerol, str, len, radix);
1518 }
1519 }
1520 }
1521
1522 /* This is the important use of test_only, because it's the one
1523 place where the read calculation is not linear in the input. */
1524 if (test_only) {
1525 if (is_long_double) return make_any_long_double();
1526 return scheme_make_integer(1);
1527 }
1528
1529 args[0] = scheme_make_integer(radix);
1530 args[1] = exponent;
1531 power = scheme_expt(2, args);
1532
1533 n = scheme_bin_mult(mantissa, power);
1534
1535 if (result_is_float) {
1536 if (is_long_double) {
1537 #ifdef MZ_LONG_DOUBLE
1538 n = scheme_TO_LONG_DOUBLE(n);
1539 if ((str[delta] == '-') && (long_double_is_zero(SCHEME_LONG_DBL_VAL(n))))
1540 n = scheme_make_long_double(long_double_neg(SCHEME_LONG_DBL_VAL(n)));
1541 #else
1542 /* simply preserve the printable format */
1543 n = wrap_as_long_double(scheme_utf8_encode_to_buffer(str, len, NULL, 0), radix);
1544 #endif
1545 } else {
1546 n = CHECK_SINGLE(TO_DOUBLE(n), sgl, 0, NULL, NULL, 0, 0);
1547 }
1548 } else {
1549 if (is_long_double) {
1550 if (report)
1551 return scheme_numr_err(complain,
1552 "cannot convert extflonum to exact in `%u`",
1553 str, len);
1554 return scheme_false;
1555 }
1556 n = CHECK_SINGLE(n, sgl, 0, NULL, NULL, 0, 0);
1557 }
1558
1559 if (SCHEME_FLOATP(n) && str[delta] == '-') {
1560 if (SCHEME_FLOAT_VAL(n) == 0.0) {
1561 /* 0.0 => -0.0 */
1562 #ifdef MZ_USE_SINGLE_FLOATS
1563 if (SCHEME_FLTP(n)) {
1564 n = scheme_nzerof;
1565 }
1566 #endif
1567 if (SCHEME_DBLP(n)) {
1568 n = scheme_nzerod;
1569 }
1570 }
1571 }
1572
1573 return n;
1574 }
1575
1576 if (has_slash) {
1577 Scheme_Object *n1, *n2;
1578 mzchar *first;
1579
1580 first = (mzchar *)scheme_malloc_atomic((has_slash - delta + 1) * sizeof(mzchar));
1581 memcpy(first, str + delta, (has_slash - delta) * sizeof(mzchar));
1582 first[has_slash - delta] = 0;
1583
1584 n1 = scheme_read_number(first, has_slash - delta,
1585 /* recur without is_float to keep all precision */
1586 0, is_not_float, 1,
1587 radix, 1, next_complain,
1588 div_by_zero,
1589 test_only);
1590 if (SCHEME_CHAR_STRINGP(n1))
1591 return n1;
1592 if (SAME_OBJ(n1, scheme_false))
1593 return scheme_false;
1594
1595 {
1596 mzchar *substr;
1597
1598 #ifdef MZ_PRECISE_GC
1599 {
1600 /* Can't pass misaligned pointer to scheme_read_bignum: */
1601 int slen = len - (has_slash + 1) + 1;
1602 substr = (mzchar *)scheme_malloc_atomic(slen * sizeof(mzchar));
1603 memcpy(substr, str + has_slash + 1, slen * sizeof(mzchar));
1604 }
1605 #else
1606 substr = (mzchar *)str + has_slash + 1;
1607 #endif
1608
1609 n2 = scheme_read_number(substr, len - has_slash - 1,
1610 /* recur without is_float to keep all precision */
1611 0, is_not_float, 1,
1612 radix, 1, next_complain,
1613 div_by_zero,
1614 test_only);
1615 }
1616
1617 if (SCHEME_CHAR_STRINGP(n2))
1618 return n2;
1619 if (SAME_OBJ(n2, scheme_false))
1620 return scheme_false;
1621
1622 if (SCHEME_EXACT_REALP(n2) && scheme_is_zero(n2)) {
1623 if (complain)
1624 return scheme_numr_err(complain,
1625 "division by zero in `%u`",
1626 str, len);
1627 if (div_by_zero)
1628 *div_by_zero = 1;
1629 return scheme_false;
1630 }
1631
1632 if (test_only) {
1633 if (is_long_double) return make_any_long_double();
1634 return scheme_make_integer(1);
1635 }
1636
1637 n1 = scheme_bin_div(n1, n2);
1638
1639 if (is_not_float) {
1640 if (SCHEME_FLOATP(n1)) {
1641 if (!scheme_check_double(NULL, SCHEME_FLOAT_VAL(n1), NULL)) {
1642 if (complain)
1643 return scheme_numr_err(complain,
1644 "no exact representation for %V",
1645 n1);
1646 return scheme_false;
1647 }
1648 }
1649 n1 = scheme_inexact_to_exact(1, &n1);
1650 } else if (is_float)
1651 n1 = TO_DOUBLE(n1);
1652
1653 return CHECK_SINGLE(n1, sgl, 0, NULL, NULL, 0, 0);
1654 }
1655
1656 o = scheme_read_bignum(str, delta, radix);
1657 if (SAME_OBJ(o, scheme_false)) {
1658 if (report)
1659 return scheme_numr_err(complain,
1660 "bad number `%u`",
1661 str, len);
1662 } else if (is_float) {
1663 /* Special case: "#i-0" => -0. */
1664 if ((o == zeroi) && str[delta] == '-') {
1665 #ifdef MZ_USE_SINGLE_FLOATS
1666 if (sgl) return scheme_nzerof;
1667 #endif
1668 return scheme_nzerod;
1669 }
1670
1671 return CHECK_SINGLE(TO_DOUBLE(o), sgl, 0, NULL, NULL, 0, 0);
1672 }
1673
1674 return o;
1675 }
1676
1677 /*========================================================================*/
1678 /* Racket functions */
1679 /*========================================================================*/
1680
1681 static Scheme_Object *
number_to_string(int argc,Scheme_Object * argv[])1682 number_to_string (int argc, Scheme_Object *argv[])
1683 {
1684 Scheme_Object *o = argv[0];
1685 intptr_t radix;
1686
1687 if (!SCHEME_NUMBERP(o))
1688 scheme_wrong_contract("number->string", "number?", 0, argc, argv);
1689
1690 if (argc == 2) {
1691 if (!SCHEME_INTP(argv[1]))
1692 radix = 0;
1693 else
1694 radix = SCHEME_INT_VAL(argv[1]);
1695
1696 if ((radix != 2) && (radix != 8) && (radix != 10) && (radix != 16)) {
1697 scheme_wrong_contract("number->string", "(or/c 2 8 10 16)", 1, argc, argv);
1698 ESCAPED_BEFORE_HERE;
1699 }
1700
1701 radix = SCHEME_INT_VAL(argv[1]);
1702 } else
1703 radix = 10;
1704
1705 if (SCHEME_INTP(o) && ((radix == 10) || (radix == 16))) {
1706 /* Fast path for common case. */
1707 mzchar num[32];
1708 int pos = 32;
1709 intptr_t v = SCHEME_INT_VAL(o);
1710 if (v) {
1711 int neg, digit;
1712 if (v < 0) {
1713 neg = 1;
1714 v = -v;
1715 } else
1716 neg = 0;
1717 while (v) {
1718 digit = (v % radix);
1719 if (digit < 10)
1720 num[--pos] = digit + '0';
1721 else
1722 num[--pos] = (digit - 10) + 'a';
1723 v = v / radix;
1724 }
1725 if (neg)
1726 num[--pos] = '-';
1727 } else {
1728 num[--pos] = '0';
1729 }
1730 return scheme_make_sized_offset_char_string(num, pos, 32 - pos, 1);
1731 }
1732
1733 return scheme_make_utf8_string/*_without_copying*/(number_to_allocated_string(radix, o, 1));
1734 }
1735
1736
1737 static Scheme_Object *
string_to_number(int argc,Scheme_Object * argv[])1738 string_to_number (int argc, Scheme_Object *argv[])
1739 {
1740 intptr_t radix;
1741 intptr_t len;
1742 mzchar *mzstr;
1743 int decimal_inexact, div_by_zero = 0;
1744 Scheme_Object *v, *reader_mode;
1745
1746 if (!SCHEME_CHAR_STRINGP(argv[0]))
1747 scheme_wrong_contract("string->number", "string?", 0, argc, argv);
1748
1749 if (argc > 1) {
1750 if (SCHEME_INTP(argv[1]))
1751 radix = SCHEME_INT_VAL(argv[1]);
1752 else
1753 radix = 0;
1754
1755 if ((radix < 2) || (radix > 16)) {
1756 scheme_wrong_contract("string->number", "(integer-in 2 16)", 1, argc, argv);
1757 ESCAPED_BEFORE_HERE;
1758 }
1759 } else
1760 radix = 10;
1761
1762 if (argc > 2) {
1763 if (SAME_OBJ(argv[2], read_symbol))
1764 reader_mode = scheme_false; /* false in place of port triggers a string return from scheme_read_number() */
1765 else if (SAME_OBJ(argv[2], number_or_false_symbol))
1766 reader_mode = NULL;
1767 else {
1768 scheme_wrong_contract("string->number", "(or/c 'read 'number-or-false)", 2, argc, argv);
1769 ESCAPED_BEFORE_HERE;
1770 }
1771 } else
1772 reader_mode = NULL;
1773
1774 if (argc > 3) {
1775 if (SAME_OBJ(argv[3], decimal_as_inexact_symbol))
1776 decimal_inexact = 1;
1777 else if (SAME_OBJ(argv[3], decimal_as_exact_symbol))
1778 decimal_inexact = 0;
1779 else {
1780 scheme_wrong_contract("string->number", "(or/c 'decimal-as-inexact 'decimal-as-exact)", 3, argc, argv);
1781 ESCAPED_BEFORE_HERE;
1782 }
1783 } else {
1784 decimal_inexact = 1;
1785 }
1786
1787 mzstr = SCHEME_CHAR_STR_VAL(argv[0]);
1788 len = SCHEME_CHAR_STRTAG_VAL(argv[0]);
1789
1790 v = scheme_read_number(mzstr, len,
1791 0, 0, decimal_inexact,
1792 radix, 0, reader_mode, &div_by_zero,
1793 0);
1794
1795 if (!reader_mode && SCHEME_LONG_DBLP(v))
1796 return scheme_false;
1797
1798 return v;
1799 }
1800
scheme_X_double_to_string(double d,char * s,int slen,int was_single,int extfl,int * used_buffer,long_double ld)1801 char *scheme_X_double_to_string (double d, char* s, int slen, int was_single, int extfl, int *used_buffer, long_double ld)
1802 {
1803 #ifdef MZ_LONG_DOUBLE
1804 if (extfl && MZ_IS_LONG_NAN(ld)) {
1805 return long_not_a_number_str;
1806 } else if (extfl && MZ_IS_LONG_POS_INFINITY(ld)) {
1807 return long_infinity_str;
1808 } else if (extfl && MZ_IS_LONG_NEG_INFINITY(ld)) {
1809 return long_minus_infinity_str;
1810 } else if (extfl && long_double_is_zero(ld)) {
1811 if (scheme_long_minus_zero_p(ld))
1812 return "-0.0t0";
1813 else
1814 return "0.0t0";
1815 }
1816 #endif
1817 if (!extfl && MZ_IS_NAN(d)) {
1818 #ifdef MZ_USE_SINGLE_FLOATS
1819 if (was_single) return single_not_a_number_str;
1820 #endif
1821 return not_a_number_str;
1822 } else if (!extfl && MZ_IS_POS_INFINITY(d)) {
1823 #ifdef MZ_USE_SINGLE_FLOATS
1824 if (was_single) return single_infinity_str;
1825 #endif
1826 return infinity_str;
1827 } else if (!extfl && MZ_IS_NEG_INFINITY(d)) {
1828 #ifdef MZ_USE_SINGLE_FLOATS
1829 if (was_single) return single_minus_infinity_str;
1830 #endif
1831 return minus_infinity_str;
1832 } else if (!extfl && d == 0.0) {
1833 /* Check for -0.0, since some printers get it wrong. */
1834 if (scheme_minus_zero_p(d)) {
1835 #ifdef MZ_USE_SINGLE_FLOATS
1836 if (was_single) return "-0.0f0";
1837 #endif
1838 return "-0.0";
1839 }
1840 #ifdef MZ_USE_SINGLE_FLOATS
1841 if (was_single) return "0.0f0";
1842 #endif
1843 return "0.0";
1844 }
1845 else {
1846 /* Initial count for significant digits is 14 (double), 6 digits
1847 (single), or 18 (extended). That's big enough to get most
1848 right, small enough to avoid nonsense digits. But we'll loop in
1849 case it's not precise enough to get read-write invariance: */
1850 int i, l, digits;
1851 GC_CAN_IGNORE char *loc;
1852 char *buffer = s;
1853 if (was_single)
1854 digits = 6;
1855 else if (extfl)
1856 digits = 18;
1857 else
1858 digits = 14;
1859 loc = scheme_push_c_numeric_locale();
1860 while (digits < 30 && digits < slen) {
1861 double check = 0.0;
1862 #ifdef MZ_LONG_DOUBLE
1863 long_double long_check;
1864 #endif
1865 GC_CAN_IGNORE char *ptr;
1866
1867 #ifdef MZ_LONG_DOUBLE
1868 memset(&long_check, 0, sizeof(long_check)); /* avoid a compiler warning */
1869 if (extfl)
1870 long_double_sprint(buffer, digits, ld);
1871 else
1872 #endif
1873 sprintf(buffer, "%.*g", digits, d);
1874
1875 /* Did we get read-write invariance, yet? */
1876 #ifdef MZ_LONG_DOUBLE
1877 if (extfl)
1878 long_check = long_double_from_string(buffer, &ptr);
1879 else
1880 #endif
1881 check = strtod(buffer, &ptr);
1882
1883 if (0)
1884 break;
1885 #ifdef MZ_USE_SINGLE_FLOATS
1886 else if (was_single) {
1887 if ((float)check == (float)d)
1888 break;
1889 #endif
1890 #ifdef MZ_LONG_DOUBLE
1891 } else if (extfl) {
1892 if (long_double_eqv(long_check, ld))
1893 break;
1894 #endif
1895 } else
1896 if (check == d)
1897 break;
1898
1899 digits++;
1900 }
1901 scheme_pop_c_numeric_locale(loc);
1902
1903 l = strlen(buffer);
1904 for (i = 0; i < l; i++) {
1905 if (buffer[i] == '.' || isalpha((unsigned char)buffer[i]))
1906 break;
1907 }
1908 if (i == l) {
1909 buffer[i] = '.';
1910 buffer[i + 1] = '0';
1911 buffer[i + 2] = 0;
1912 l += 2;
1913 }
1914 #if defined(MZ_USE_SINGLE_FLOATS) || defined(MZ_LONG_DOUBLE)
1915 if (was_single || extfl) {
1916 /* In case of a single-precision or extend-prevision float, add
1917 the f0 or t0 suffix, or replace the existing e exponent
1918 separator. */
1919 for (i = 0; i < l; i++) {
1920 if (buffer[i] == 'e')
1921 break;
1922 }
1923 if (i == l) {
1924 buffer[l] = (was_single ? 'f' : 't');
1925 buffer[l + 1] = '0';
1926 buffer[l + 2] = 0;
1927 l += 2;
1928 } else {
1929 buffer[i] = (was_single ? 'f' : 't');
1930 }
1931 }
1932 #endif
1933 *used_buffer = 1;
1934 }
1935
1936 return s;
1937 }
1938
scheme_double_to_string(double d,char * s,int slen,int was_single,int * used_buffer)1939 char *scheme_double_to_string (double d, char* s, int slen, int was_single, int *used_buffer)
1940 {
1941 long_double stub;
1942 memset(&stub, 0, sizeof(long_double));
1943 return scheme_X_double_to_string(d, s, slen, was_single, 0, used_buffer, stub);
1944 }
1945
double_to_string(double d,int alloc,int was_single,int extfl,long_double ld)1946 static char *double_to_string (double d, int alloc, int was_single, int extfl, long_double ld)
1947 {
1948 char buffer[100];
1949 char *s;
1950 int used_buffer = 0;
1951
1952 s = scheme_X_double_to_string(d, buffer, 100, was_single, extfl, &used_buffer, ld);
1953
1954 if (used_buffer) {
1955 s = (char *)scheme_malloc_atomic(strlen(buffer) + 1);
1956 strcpy(s, buffer);
1957 alloc = 0;
1958 }
1959
1960 if (alloc) {
1961 char *s2;
1962 int l;
1963 l = strlen(s) + 1;
1964 s2 = (char *)scheme_malloc_atomic(l);
1965 memcpy(s2, s, l);
1966 s = s2;
1967 }
1968
1969 return s;
1970 }
1971
1972 #ifdef MZ_LONG_DOUBLE
scheme_long_double_to_string(long_double ld,char * s,int slen,int * used_buffer)1973 char *scheme_long_double_to_string (long_double ld, char* s, int slen, int *used_buffer)
1974 {
1975 return scheme_X_double_to_string(0.0, s, slen, 0, 1, used_buffer, ld);
1976 }
1977 #endif
1978
number_to_allocated_string(int radix,Scheme_Object * obj,int alloc)1979 static char *number_to_allocated_string(int radix, Scheme_Object *obj, int alloc)
1980 {
1981 char *s;
1982 long_double stub;
1983 if (SCHEME_FLOATP(obj)) {
1984 if (radix != 10)
1985 scheme_contract_error("number->string",
1986 "inexact numbers can only be printed in base 10",
1987 "number", 1, obj,
1988 "requested base", 1, scheme_make_integer(radix),
1989 NULL);
1990 memset(&stub, 0, sizeof(long_double));
1991 s = double_to_string(SCHEME_FLOAT_VAL(obj), alloc, SCHEME_FLTP(obj), 0, stub);
1992 } else if (SCHEME_LONG_DBLP(obj)) {
1993 if (radix != 10)
1994 scheme_contract_error("number->string",
1995 "extflonum numbers can only be printed in base 10",
1996 "number", 1, obj,
1997 "requested base", 1, scheme_make_integer(radix),
1998 NULL);
1999 #ifdef MZ_LONG_DOUBLE
2000 s = double_to_string(0.0, alloc, 0, 1, SCHEME_LONG_DBL_VAL(obj));
2001 #else
2002 s = (char *)((Scheme_Long_Double *)obj)->printed_form;
2003 #endif
2004 } else if (SCHEME_RATIONALP(obj)) {
2005 Scheme_Object *n, *d;
2006 char *ns, *ds;
2007 int nlen, dlen;
2008
2009 n = scheme_rational_numerator(obj);
2010 d = scheme_rational_denominator(obj);
2011
2012 ns = number_to_allocated_string(radix, n, 0);
2013 ds = number_to_allocated_string(radix, d, 0);
2014
2015 nlen = strlen(ns);
2016 dlen = strlen(ds);
2017
2018 s = (char *)scheme_malloc_atomic(nlen + dlen + 2);
2019 memcpy(s, ns, nlen);
2020 s[nlen] = '/';
2021 strcpy(s + nlen + 1, ds);
2022 } else if (SCHEME_COMPLEXP(obj)) {
2023 Scheme_Object *r, *i;
2024 char *rs, *is;
2025 int rlen, ilen, offset = 0;
2026
2027 r = _scheme_complex_real_part(obj);
2028 i = _scheme_complex_imaginary_part(obj);
2029
2030 rs = number_to_allocated_string(radix, r, 0);
2031 is = number_to_allocated_string(radix, i, 0);
2032
2033 rlen = strlen(rs);
2034 ilen = strlen(is);
2035 s = (char *)scheme_malloc_atomic(rlen + ilen + 3);
2036 memcpy(s, rs, rlen);
2037 if ((is[0] != '-') && (is[0] != '+')) {
2038 offset = 1;
2039 s[rlen] = '+';
2040 }
2041 memcpy(s + rlen + offset, is, ilen);
2042 s[rlen + offset + ilen] = 'i';
2043 s[rlen + offset + ilen + 1] = 0;
2044 } else {
2045 if (SCHEME_INTP(obj))
2046 obj = scheme_make_bignum(SCHEME_INT_VAL(obj));
2047
2048 s = scheme_bignum_to_allocated_string(obj, radix, alloc);
2049 }
2050
2051 return s;
2052 }
2053
scheme_number_to_string(int radix,Scheme_Object * obj)2054 char *scheme_number_to_string(int radix, Scheme_Object *obj)
2055 {
2056 return number_to_allocated_string(radix, obj, 0);
2057 }
2058
scheme_check_double(const char * where,double d,const char * dest)2059 int scheme_check_double(const char *where, double d, const char *dest)
2060 {
2061 if (MZ_IS_INFINITY(d)
2062 || MZ_IS_NAN(d)) {
2063 if (where) {
2064 char buf[32];
2065 sprintf(buf, "no %s representation", dest);
2066 scheme_contract_error(where,
2067 buf,
2068 "number", 1, scheme_make_double(d),
2069 NULL);
2070 }
2071 return 0;
2072 }
2073
2074 return 1;
2075 }
2076
2077 #ifdef MZ_USE_SINGLE_FLOATS
scheme_check_float(const char * where,float f,const char * dest)2078 int scheme_check_float(const char *where, float f, const char *dest)
2079 {
2080 if (MZ_IS_INFINITY(f)
2081 || MZ_IS_NAN(f)) {
2082 if (where) {
2083 char buf[32];
2084 sprintf(buf, "no %s representation", dest);
2085 scheme_contract_error(where,
2086 buf,
2087 "number", 1, scheme_make_float(f),
2088 NULL);
2089 }
2090 return 0;
2091 }
2092
2093 return 1;
2094 }
2095 #endif
2096
2097
2098 #ifdef MZ_LONG_DOUBLE
scheme_check_long_double(const char * where,long_double d,const char * dest)2099 int scheme_check_long_double(const char *where, long_double d, const char *dest)
2100 {
2101 if (MZ_IS_LONG_INFINITY(d)
2102 || MZ_IS_LONG_NAN(d)) {
2103 if (where) {
2104 char buf[36]; /* What is the length? */
2105 sprintf(buf, "no %s representation", dest);
2106 scheme_contract_error(where,
2107 buf,
2108 "number", 1, scheme_make_long_double(d),
2109 NULL);
2110 }
2111 return 0;
2112 }
2113
2114 return 1;
2115 }
2116 #endif
2117
2118 /*========================================================================*/
2119 /* native representations */
2120 /*========================================================================*/
2121
scheme_bytes_to_integer(char * str,int slen,int sgned,int rshft,int mask)2122 Scheme_Object *scheme_bytes_to_integer(char *str, int slen, int sgned, int rshft, int mask)
2123 {
2124 switch(slen) {
2125 case 1:
2126 if (sgned) {
2127 signed char val;
2128 memcpy(&val, str, sizeof(char));
2129 return scheme_make_integer(val);
2130 } else {
2131 unsigned char val;
2132 memcpy(&val, str, sizeof(unsigned char));
2133 val >>= rshft;
2134 if (mask < 8) { val &= (((unsigned char)1 << mask) - 1); }
2135 return scheme_make_integer(val);
2136 }
2137 break;
2138 case 2:
2139 if (sgned) {
2140 short val;
2141 memcpy(&val, str, sizeof(short));
2142 return scheme_make_integer(val);
2143 } else {
2144 unsigned short val;
2145 memcpy(&val, str, sizeof(unsigned short));
2146 val >>= rshft;
2147 if (mask < 16) { val &= (((unsigned short)1 << mask) - 1); }
2148 return scheme_make_integer(val);
2149 }
2150 break;
2151 case 4:
2152 if (sgned) {
2153 int val;
2154 memcpy(&val, str, sizeof(int));
2155 return scheme_make_integer_value(val);
2156 } else {
2157 unsigned int val;
2158 memcpy(&val, str, sizeof(unsigned int));
2159 val >>= rshft;
2160 if (mask < 32) { val &= (((unsigned int)1 << mask) - 1); }
2161 return scheme_make_integer_value_from_unsigned(val);
2162 }
2163 break;
2164 default:
2165 #ifdef SIXTY_FOUR_BIT_INTEGERS
2166 if (sgned) {
2167 intptr_t val;
2168 memcpy(&val, str, sizeof(intptr_t));
2169 return scheme_make_integer_value(val);
2170 }
2171 else {
2172 uintptr_t val;
2173 memcpy(&val, str, sizeof(uintptr_t));
2174 val >>= rshft;
2175 if (mask < 64) { val &= (((uintptr_t)1 << mask) - 1); }
2176 return scheme_make_integer_value_from_unsigned(val);
2177 }
2178 break;
2179 #else
2180 # ifndef NO_LONG_LONG_TYPE
2181 {
2182 if (sgned) {
2183 mzlonglong lv;
2184 memcpy(&lv, str, sizeof(mzlonglong));
2185 return scheme_make_integer_value_from_long_long(lv);
2186 } else {
2187 umzlonglong lv;
2188 memcpy(&lv, str, sizeof(umzlonglong));
2189 lv >>= rshft;
2190 if (mask < 64) { lv &= (((umzlonglong)1 << mask) - 1); }
2191 return scheme_make_integer_value_from_unsigned_long_long(lv);
2192 }
2193 break;
2194 }
2195 # else
2196 {
2197 Scheme_Object *h, *l, *a[2];
2198 unsigned int val;
2199
2200 # if MZ_IS_BIG_ENDIAN
2201 /* make little-endian at int level: */
2202 {
2203 int v;
2204 v = ((int *)str)[0];
2205 buf[0] = ((int *)str)[1];
2206 buf[1] = v;
2207 str = (char *)buf;
2208 }
2209 # endif
2210
2211 if (rshft >= 32) {
2212
2213 }
2214
2215 if (sgned)
2216 h = scheme_make_integer_value(((int *)str)[1]);
2217 else {
2218 memcpy(&val, str + sizeof(unsigned int), sizeof(unsigned int));
2219 if (rshft >= 32) {
2220 rshft -= 32;
2221 val >>= rshft;
2222 if (mask < 64) { val &= (((umzlonglong)1 << mask) - 1); }
2223 return scheme_make_integer_value_from_unsigned(val);
2224 } else {
2225 h = scheme_make_integer_value_from_unsigned(val);
2226 }
2227 }
2228
2229 memcpy(&val, str, sizeof(unsigned int));
2230 val >>= rshft;
2231 l = scheme_make_integer_value_from_unsigned(val);
2232
2233 a[0] = h;
2234 a[1] = scheme_make_integer(32-rshft);
2235 h = scheme_bitwise_shift(2, a);
2236
2237 l = scheme_bin_plus(h, l);
2238
2239 if (mask < 64) {
2240 a[0] = scheme_make_integer(1);
2241 a[1] = scheme_make_integer(mask);
2242 h = scheme_bitwise_shift(2, a);
2243 h = scheme_bin_minus(h, scheme_make_integer(1));
2244 a[0] = h;
2245 a[1] = l;
2246 l = scheme_bitwise_and(2, a);
2247 }
2248
2249 return l;
2250 }
2251 # endif
2252 #endif
2253 break;
2254 }
2255
2256 ESCAPED_BEFORE_HERE;
2257 }
2258
bytes_to_integer(int argc,Scheme_Object * argv[])2259 static Scheme_Object *bytes_to_integer (int argc, Scheme_Object *argv[])
2260 {
2261 intptr_t strlen, slen;
2262 int sgned;
2263 char *str;
2264 int buf[2], i;
2265 int bigend = MZ_IS_BIG_ENDIAN, offset = 0;
2266
2267 if (!SCHEME_BYTE_STRINGP(argv[0]))
2268 scheme_wrong_contract("integer-bytes->integer", "bytes?", 0, argc, argv);
2269 strlen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
2270
2271 str = SCHEME_BYTE_STR_VAL(argv[0]);
2272
2273 sgned = SCHEME_TRUEP(argv[1]);
2274 if (argc > 2)
2275 bigend = SCHEME_TRUEP(argv[2]);
2276
2277 if (argc > 3) {
2278 intptr_t start, finish;
2279
2280 scheme_get_substring_indices("integer-bytes->integer", argv[0],
2281 argc, argv,
2282 3, 4, &start, &finish);
2283
2284 offset = start;
2285 slen = finish - start;
2286 } else {
2287 offset = 0;
2288 slen = strlen;
2289 }
2290
2291 if ((slen != 1) && (slen != 2) && (slen != 4) && (slen != 8)) {
2292 scheme_contract_error("integer-bytes->integer",
2293 "length is not 1, 2, 4, or 8 bytes",
2294 "length", 1, scheme_make_integer(slen),
2295 NULL);
2296 return NULL;
2297 }
2298
2299 if (bigend != MZ_IS_BIG_ENDIAN) {
2300 for (i = 0; i < slen; i++) {
2301 ((char *)buf)[slen - i - 1] = str[i + offset];
2302 }
2303 str = (char *)buf;
2304 } else {
2305 memcpy(&buf, str + offset, slen);
2306 str = (char *)buf;
2307 }
2308
2309 return scheme_bytes_to_integer(str, slen, sgned, 0, slen*8);
2310 }
2311
2312 #define MZ_U8HI 0
2313 #define MZ_S8HI 1
2314 #define MZ_S8LO 2
2315
integer_to_bytes(int argc,Scheme_Object * argv[])2316 static Scheme_Object *integer_to_bytes(int argc, Scheme_Object *argv[])
2317 {
2318 Scheme_Object *n, *s;
2319 char *str;
2320 int size, sgned;
2321 intptr_t val, offset, buf[2];
2322 #if !defined(NO_LONG_LONG_TYPE) && !defined(SIXTY_FOUR_BIT_INTEGERS)
2323 mzlonglong llval;
2324 #endif
2325 int bigend = MZ_IS_BIG_ENDIAN, bad;
2326
2327 n = argv[0];
2328 if (!SCHEME_INTP(n) && !SCHEME_BIGNUMP(n))
2329 scheme_wrong_contract("integer->integer-bytes", "exact-integer?", 0, argc, argv);
2330
2331 if (SCHEME_INTP(argv[1]))
2332 size = SCHEME_INT_VAL(argv[1]);
2333 else
2334 size = 0;
2335 if ((size != 1) && (size != 2) && (size != 4) && (size != 8))
2336 scheme_wrong_contract("integer->integer-bytes", "(or/c 1 2 4 8)", 1, argc, argv);
2337
2338 sgned = SCHEME_TRUEP(argv[2]);
2339 if (argc > 3)
2340 bigend = SCHEME_TRUEP(argv[3]);
2341
2342 if (argc > 4)
2343 s = argv[4];
2344 else
2345 s = scheme_make_sized_byte_string("12345678", size, 1);
2346
2347 if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
2348 scheme_wrong_contract("integer->integer-bytes", "(and/c bytes? (not/c immutable?))", 4, argc, argv);
2349
2350 if (argc > 5) {
2351 intptr_t start, finish;
2352
2353 scheme_get_substring_indices("integer-bytes->integer", s,
2354 argc, argv,
2355 5, 6, &start, &finish);
2356
2357 offset = start;
2358 } else
2359 offset = 0;
2360
2361 if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
2362 scheme_contract_error("integer->integer-bytes",
2363 "byte string length is shorter than starting position plus size",
2364 "byte string length", 1, scheme_make_integer(SCHEME_BYTE_STRLEN_VAL(s)),
2365 "starting position", 1, scheme_make_integer(offset),
2366 "size", 1, scheme_make_integer(size),
2367 NULL);
2368 return NULL;
2369 }
2370
2371 /* Check for mismatch: number doesn't fit */
2372 if (size == 1) {
2373 if (SCHEME_BIGNUMP(n))
2374 bad = 1;
2375 else {
2376 val = SCHEME_INT_VAL(n);
2377 if (sgned) {
2378 bad = ((val < -128) || (val > 127));
2379 } else {
2380 bad = ((val < 0) || (val > 255));
2381 }
2382 }
2383 } else if (size == 2) {
2384 if (SCHEME_BIGNUMP(n))
2385 bad = 1;
2386 else {
2387 val = SCHEME_INT_VAL(n);
2388 if (sgned) {
2389 bad = ((val < -32768) || (val > 32767));
2390 } else {
2391 bad = ((val < 0) || (val > 65535));
2392 }
2393 }
2394 } else if (size == 4) {
2395 if (sgned)
2396 bad = !scheme_get_int_val(n, &val);
2397 else
2398 bad = !scheme_get_unsigned_int_val(n, (uintptr_t *)&val);
2399 #ifdef SIXTY_FOUR_BIT_INTEGERS
2400 if (!bad) {
2401 if (sgned)
2402 bad = ((val > (intptr_t)0x7fffffff) || (val < -(intptr_t)0x80000000));
2403 else
2404 bad = (val > (intptr_t)0xffffffff);
2405 }
2406 #endif
2407 } else {
2408 #ifdef SIXTY_FOUR_BIT_INTEGERS
2409 if (sgned)
2410 bad = !scheme_get_int_val(n, &val);
2411 else
2412 bad = !scheme_get_unsigned_int_val(n, (uintptr_t *)&val);
2413 #else
2414 # ifndef NO_LONG_LONG_TYPE
2415 if (sgned)
2416 bad = !scheme_get_long_long_val(n, &llval);
2417 else
2418 bad = !scheme_get_unsigned_long_long_val(n, (umzlonglong *)&llval);
2419 # else
2420 if (sgned)
2421 bad = (scheme_bin_lt(n, num_limits[MZ_S8LO])
2422 || scheme_bin_lt(num_limits[MZ_S8HI], n));
2423 else
2424 bad = (!scheme_nonneg_exact_p(n)
2425 || scheme_bin_lt(num_limits[MZ_U8HI], n));
2426
2427 val = 0;
2428 # endif
2429 #endif
2430 }
2431
2432 if (bad) {
2433 scheme_contract_error("integer->integer-bytes",
2434 (sgned
2435 ? "integer does not fit into requested signed bytes"
2436 : "integer does not fit into requested unsigned bytes"),
2437 "integer", 1, n,
2438 "requested bytes", 1, scheme_make_integer(size),
2439 NULL);
2440 return NULL;
2441 }
2442
2443 /* Finally, do the work */
2444 str = (char *)buf;
2445 switch (size) {
2446 case 1:
2447 {
2448 if (sgned) {
2449 char value = val;
2450 memcpy(str, &value, sizeof(char));
2451 } else {
2452 unsigned char value = val;
2453 memcpy(str, &value, sizeof(unsigned char));
2454 }
2455 }
2456 break;
2457 case 2:
2458 {
2459 if (sgned) {
2460 short value = val;
2461 memcpy(str, &value, sizeof(short));
2462 } else {
2463 unsigned short value = val;
2464 memcpy(str, &value, sizeof(unsigned short));
2465 }
2466 }
2467 break;
2468 case 4:
2469 if (sgned) {
2470 int value = val;
2471 memcpy(str, &value, sizeof(int));
2472 } else {
2473 unsigned int value = val;
2474 memcpy(str, &value, sizeof(unsigned int));
2475 }
2476 break;
2477 default:
2478 #ifdef SIXTY_FOUR_BIT_INTEGERS
2479 *(intptr_t *)str = val;
2480 #else
2481 # ifndef NO_LONG_LONG_TYPE
2482 memcpy(str, &llval, sizeof(mzlonglong));
2483 # else
2484 {
2485 Scheme_Object *hi, *lo, *a[2];
2486 uintptr_t ul;
2487
2488 a[0] = n;
2489 a[1] = scheme_make_integer_value_from_unsigned((uintptr_t)-1);
2490 lo = scheme_bitwise_and(2, a);
2491 a[1] = scheme_make_integer(-32);
2492 hi = scheme_bitwise_shift(2, a);
2493
2494 scheme_get_unsigned_int_val(lo, &ul);
2495
2496 ((unsigned int *)str)[0] = ul;
2497 if (sgned) {
2498 scheme_get_int_val(hi, &val);
2499 ((unsigned int *)str)[1] = val;
2500 } else {
2501 scheme_get_unsigned_int_val(hi, &ul);
2502 ((unsigned int *)str)[1] = ul;
2503 }
2504
2505 #if MZ_IS_BIG_ENDIAN
2506 {
2507 /* We've assumed little endian so far */
2508 val = ((int *)str)[0];
2509 ((int *)str)[0] = ((int *)str)[1];
2510 ((int *)str)[1] = val;
2511 }
2512 #endif
2513
2514 }
2515 # endif
2516 #endif
2517 break;
2518 }
2519
2520 str = SCHEME_BYTE_STR_VAL(s);
2521 if (bigend != MZ_IS_BIG_ENDIAN) {
2522 int i;
2523 for (i = 0; i < size; i++) {
2524 str[i + offset] = ((char *)buf)[size - i - 1];
2525 }
2526 } else {
2527 int i;
2528 for (i = 0; i < size; i++) {
2529 str[i + offset] = ((char *)buf)[i];
2530 }
2531 }
2532
2533 return s;
2534 }
2535
bytes_to_real(int argc,Scheme_Object * argv[])2536 static Scheme_Object *bytes_to_real (int argc, Scheme_Object *argv[])
2537 {
2538 intptr_t offset = 0, slen;
2539 char *str, buf[8];
2540 int bigend = MZ_IS_BIG_ENDIAN;
2541
2542 if (!SCHEME_BYTE_STRINGP(argv[0]))
2543 scheme_wrong_contract("integer-bytes->integer", "bytes?", 0, argc, argv);
2544
2545 if (argc > 2) {
2546 intptr_t start, finish;
2547
2548 scheme_get_substring_indices("integer-bytes->integer", argv[0],
2549 argc, argv,
2550 2, 3, &start, &finish);
2551
2552 offset = start;
2553 slen = finish - start;
2554 } else {
2555 offset = 0;
2556 slen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
2557 }
2558
2559 if ((slen != 4) && (slen != 8))
2560 scheme_contract_error("floating-point-bytes->real",
2561 "length is not 4 or 8 bytes",
2562 "length", 1, scheme_make_integer(slen),
2563 NULL);
2564
2565 str = SCHEME_BYTE_STR_VAL(argv[0]);
2566
2567 if (argc > 1)
2568 bigend = SCHEME_TRUEP(argv[1]);
2569
2570 if (bigend != MZ_IS_BIG_ENDIAN) {
2571 int i;
2572 for (i = 0; i < slen; i++) {
2573 buf[slen - i - 1] = str[offset + i];
2574 }
2575 } else {
2576 memcpy(buf, str + offset, slen);
2577 }
2578 str = buf;
2579
2580 switch(slen) {
2581 case 4:
2582 {
2583 float f;
2584 memcpy(&f, buf, sizeof(float));
2585 #ifdef MZ_USE_SINGLE_FLOATS_AS_DEFAULT
2586 return scheme_make_float(f);
2587 #else
2588 return scheme_make_double(f);
2589 #endif
2590 }
2591 break;
2592 default:
2593 {
2594 double d;
2595 memcpy(&d, str, sizeof(double));
2596 return scheme_make_double(d);
2597 }
2598 break;
2599 }
2600 }
2601
real_to_bytes(int argc,Scheme_Object * argv[])2602 static Scheme_Object *real_to_bytes (int argc, Scheme_Object *argv[])
2603 {
2604 Scheme_Object *n, *s;
2605 int size;
2606 int bigend = MZ_IS_BIG_ENDIAN;
2607 double d;
2608 intptr_t offset = 0;
2609
2610 n = argv[0];
2611 if (!SCHEME_REALP(n))
2612 scheme_wrong_contract("real->floating-point-bytes", "real?", 0, argc, argv);
2613
2614 if (SCHEME_INTP(argv[1]))
2615 size = SCHEME_INT_VAL(argv[1]);
2616 else
2617 size = 0;
2618 if ((size != 4) && (size != 8))
2619 scheme_wrong_contract("real->floating-point-bytes", "(or/c 4 8)", 1, argc, argv);
2620
2621 if (argc > 2)
2622 bigend = SCHEME_TRUEP(argv[2]);
2623
2624 if (argc > 3) {
2625 s = argv[3];
2626
2627 if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
2628 scheme_wrong_contract("real->floating-point-bytes", "(and/c bytes? (not/c immutable?))", 3, argc, argv);
2629
2630 if (argc > 4) {
2631 intptr_t start, finish;
2632
2633 scheme_get_substring_indices("real->floating-point-bytes", s,
2634 argc, argv,
2635 4, 5, &start, &finish);
2636
2637 offset = start;
2638 } else
2639 offset = 0;
2640 } else
2641 s = scheme_make_sized_byte_string("12345678", size, 1);
2642
2643 if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
2644 scheme_contract_error("real->floating-point-bytes",
2645 "byte string length is shorter than starting position plus size",
2646 "byte string length", 1, scheme_make_integer(SCHEME_BYTE_STRLEN_VAL(s)),
2647 "starting position", 1, scheme_make_integer(offset),
2648 "size", 1, scheme_make_integer(size),
2649 NULL);
2650 return NULL;
2651 }
2652
2653 d = scheme_get_val_as_double(n);
2654
2655 if (size == 4) {
2656 float f = (float) d;
2657 memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &f, sizeof(float));
2658 } else {
2659 memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &d, sizeof(double));
2660 }
2661
2662 if (bigend != MZ_IS_BIG_ENDIAN) {
2663 int i;
2664 char buf[8], *str;
2665
2666 str = SCHEME_BYTE_STR_VAL(s);
2667
2668 for (i = 0; i < size; i++) {
2669 buf[size - i - 1] = str[offset + i];
2670 }
2671 for (i = 0; i < size; i++) {
2672 str[offset + i] = buf[i];
2673 }
2674 }
2675
2676 return s;
2677 }
2678
bytes_to_long_double(int argc,Scheme_Object * argv[])2679 static Scheme_Object *bytes_to_long_double (int argc, Scheme_Object *argv[])
2680 {
2681 #ifdef MZ_LONG_DOUBLE
2682 intptr_t offset = 0, slen;
2683 char *str, buf[sizeof(long_double)];
2684 int bigend = MZ_IS_BIG_ENDIAN;
2685 long_double d;
2686
2687 if (!SCHEME_BYTE_STRINGP(argv[0]))
2688 scheme_wrong_contract("floating-point-bytes->extfl", "bytes?", 0, argc, argv);
2689
2690 if (argc > 2) {
2691 intptr_t start, finish;
2692
2693 scheme_get_substring_indices("floating-point-bytes->extfl", argv[0],
2694 argc, argv,
2695 2, 3, &start, &finish);
2696
2697 offset = start;
2698 slen = finish - start;
2699 } else {
2700 offset = 0;
2701 slen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
2702 }
2703
2704 if (slen != LONG_DOUBLE_BYTE_LEN)
2705 scheme_contract_error("floating-point-bytes->extfl",
2706 "length is not 10 bytes",
2707 "length", 1, scheme_make_integer(slen),
2708 NULL);
2709
2710 str = SCHEME_BYTE_STR_VAL(argv[0]);
2711
2712 if (argc > 1)
2713 bigend = SCHEME_TRUEP(argv[1]);
2714
2715 if (bigend != MZ_IS_BIG_ENDIAN) {
2716 int i;
2717 for (i = 0; i < slen; i++) {
2718 buf[slen - i - 1] = str[offset + i];
2719 }
2720 } else {
2721 memcpy(buf, str + offset, slen);
2722 }
2723 str = buf;
2724
2725 memcpy(&d, str, LONG_DOUBLE_BYTE_LEN);
2726 return scheme_make_long_double(d);
2727 #else
2728 scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
2729 "floating-point-bytes->extfl: " NOT_SUPPORTED_STR);
2730
2731 return NULL;
2732 #endif
2733 }
2734
long_double_to_bytes(int argc,Scheme_Object * argv[])2735 static Scheme_Object *long_double_to_bytes (int argc, Scheme_Object *argv[])
2736 {
2737 #ifdef MZ_LONG_DOUBLE
2738 Scheme_Object *n, *s;
2739 int size = LONG_DOUBLE_BYTE_LEN;
2740 int bigend = MZ_IS_BIG_ENDIAN;
2741 long_double d;
2742 intptr_t offset = 0;
2743
2744 n = argv[0];
2745 if (!SCHEME_LONG_DBLP(n))
2746 scheme_wrong_contract("extfl->floating-point-bytes", "extflonum?", 0, argc, argv);
2747
2748 if (argc > 1)
2749 bigend = SCHEME_TRUEP(argv[1]);
2750
2751 if (argc > 2) {
2752 s = argv[2];
2753
2754 if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
2755 scheme_wrong_contract("extfl->floating-point-bytes", "(and/c bytes? (not/c immutable?))", 2, argc, argv);
2756
2757 if (argc > 3) {
2758 intptr_t start, finish;
2759
2760 scheme_get_substring_indices("extfl->floating-point-bytes", s,
2761 argc, argv,
2762 3, 4, &start, &finish);
2763
2764 offset = start;
2765 } else
2766 offset = 0;
2767 } else
2768 s = scheme_make_sized_byte_string("1234567890", size, 1);
2769
2770 if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
2771 scheme_contract_error("extfl->floating-point-bytes",
2772 "byte string length is shorter than starting position plus size",
2773 "byte string length", 1, scheme_make_integer(SCHEME_BYTE_STRLEN_VAL(s)),
2774 "starting position", 1, scheme_make_integer(offset),
2775 "size", 1, scheme_make_integer(size),
2776 NULL);
2777 return NULL;
2778 }
2779
2780 d = SCHEME_LONG_DBL_VAL(n);
2781
2782 memcpy(SCHEME_BYTE_STR_VAL(s) + offset, &d, LONG_DOUBLE_BYTE_LEN);
2783
2784 if (bigend != MZ_IS_BIG_ENDIAN) {
2785 int i;
2786 char buf[LONG_DOUBLE_BYTE_LEN], *str;
2787
2788 str = SCHEME_BYTE_STR_VAL(s);
2789
2790 for (i = 0; i < size; i++) {
2791 buf[size - i - 1] = str[offset + i];
2792 }
2793 for (i = 0; i < size; i++) {
2794 str[offset + i] = buf[i];
2795 }
2796 }
2797
2798 return s;
2799 #else
2800 scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
2801 "extfl->floating-point-bytes: " NOT_SUPPORTED_STR);
2802
2803 return NULL;
2804 #endif
2805 }
2806
system_big_endian_p(int argc,Scheme_Object * argv[])2807 static Scheme_Object *system_big_endian_p (int argc, Scheme_Object *argv[])
2808 {
2809 #if MZ_IS_BIG_ENDIAN
2810 return scheme_true;
2811 #else
2812 return scheme_false;
2813 #endif
2814 }
2815
2816 /*========================================================================*/
2817 /* random number generator */
2818 /*========================================================================*/
2819
2820 #ifdef MZ_BSD_RANDOM_GENERATOR
2821 # include "random.inc"
2822 #else
2823 # include "newrandom.inc"
2824 #endif
2825
scheme_rand(Scheme_Random_State * rs)2826 intptr_t scheme_rand(Scheme_Random_State *rs)
2827 {
2828 return sch_int_rand(2147483647, rs);
2829 }
2830
2831 static Scheme_Object *
random_seed(int argc,Scheme_Object * argv[])2832 random_seed(int argc, Scheme_Object *argv[])
2833 {
2834 intptr_t i = -1;
2835 Scheme_Object *o = argv[0], *rand_state;
2836
2837 if (scheme_get_int_val(o, &i)) {
2838 if (i > 2147483647)
2839 i = -1;
2840 }
2841
2842 if (i < 0)
2843 scheme_wrong_contract("random-seed", "(integer-in 0 2147483647)", 0, argc, argv);
2844
2845 rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
2846 sch_srand(i, (Scheme_Random_State *)rand_state);
2847
2848 return scheme_void;
2849 }
2850
2851 static Scheme_Object *
sch_random(int argc,Scheme_Object * argv[])2852 sch_random(int argc, Scheme_Object *argv[])
2853 {
2854 if (!argc) {
2855 double v;
2856 Scheme_Object *rand_state;
2857
2858 rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
2859 v = sch_double_rand((Scheme_Random_State *)rand_state);
2860 return scheme_make_double(v);
2861 } else if ((argc == 1)
2862 && SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type)) {
2863 double v;
2864 Scheme_Object *rand_state;
2865
2866 rand_state = argv[0];
2867 v = sch_double_rand((Scheme_Random_State *)rand_state);
2868 return scheme_make_double(v);
2869 } else {
2870 uintptr_t i, v;
2871 Scheme_Object *o, *rand_state;
2872
2873 o = argv[0];
2874 #ifdef SIXTY_FOUR_BIT_INTEGERS
2875 if (SCHEME_INTP(o)) {
2876 i = (uintptr_t)SCHEME_INT_VAL(o);
2877 if (i > 4294967087UL)
2878 i = 0;
2879 } else
2880 i = 0;
2881 #else
2882 if (scheme_get_unsigned_int_val(o, &i)) {
2883 if (i > 4294967087UL)
2884 i = 0;
2885 } else
2886 i = 0;
2887 #endif
2888
2889 if (!i) {
2890 scheme_wrong_contract("random",
2891 ((argc == 1)
2892 ? "(or/c (integer-in 1 4294967087) pseudo-random-generator?)"
2893 : "(integer-in 1 4294967087)"),
2894 0, argc, argv);
2895 return NULL;
2896 }
2897
2898 if (argc == 2) {
2899 rand_state = argv[1];
2900 if (!SAME_TYPE(SCHEME_TYPE(rand_state), scheme_random_state_type)) {
2901 scheme_wrong_contract("random", "pseudo-random-generator?", 1, argc, argv);
2902 return NULL;
2903 }
2904 } else {
2905 rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_RANDOM_STATE);
2906 }
2907
2908 v = sch_int_rand(i, (Scheme_Random_State *)rand_state);
2909
2910 #ifdef SIXTY_FOUR_BIT_INTEGERS
2911 return scheme_make_integer(v);
2912 #else
2913 return scheme_make_integer_value_from_unsigned(v);
2914 #endif
2915 }
2916 }
2917
scheme_double_random(Scheme_Object * rand_state)2918 double scheme_double_random(Scheme_Object *rand_state)
2919 {
2920 return sch_double_rand((Scheme_Random_State *)rand_state);
2921 }
2922
2923 static Scheme_Object *
do_pack(const char * name,int argc,Scheme_Object * argv[],int set,int check)2924 do_pack(const char *name, int argc, Scheme_Object *argv[], int set, int check)
2925 {
2926 Scheme_Object *s, *vec;
2927 GC_CAN_IGNORE Scheme_Random_State rs;
2928
2929 if (set) {
2930 s = argv[0];
2931 if (!SAME_TYPE(SCHEME_TYPE(s), scheme_random_state_type)) {
2932 scheme_wrong_contract(name, "pseudo-random-generator?", 0, argc, argv);
2933 }
2934 }
2935
2936 vec = argv[set];
2937 if (SCHEME_NP_CHAPERONEP(vec))
2938 vec = SCHEME_CHAPERONE_VAL(vec);
2939
2940 if (SCHEME_VECTORP(vec) && (SCHEME_VEC_SIZE(vec) == 6))
2941 s = pack_rand_state(argv[set], ((set || check) ? &rs : NULL));
2942 else
2943 s = NULL;
2944
2945 if (check)
2946 return (s ? scheme_true : scheme_false);
2947
2948 if (!s)
2949 scheme_wrong_contract(name,
2950 "pseudo-random-generator-vector?",
2951 set, argc, argv);
2952
2953 if (set) {
2954 s = argv[0];
2955 ((Scheme_Random_State *)s)->x10 = rs.x10;
2956 ((Scheme_Random_State *)s)->x11 = rs.x11;
2957 ((Scheme_Random_State *)s)->x12 = rs.x12;
2958 ((Scheme_Random_State *)s)->x20 = rs.x20;
2959 ((Scheme_Random_State *)s)->x21 = rs.x21;
2960 ((Scheme_Random_State *)s)->x22 = rs.x22;
2961
2962 return scheme_void;
2963 } else {
2964 return s;
2965 }
2966 }
2967
2968 static Scheme_Object *
sch_pack(int argc,Scheme_Object * argv[])2969 sch_pack(int argc, Scheme_Object *argv[])
2970 {
2971 return do_pack("vector->pseudo-random-generator", argc, argv, 0, 0);
2972 }
2973
2974 static Scheme_Object *
sch_pack_bang(int argc,Scheme_Object * argv[])2975 sch_pack_bang(int argc, Scheme_Object *argv[])
2976 {
2977 return do_pack("vector->pseudo-random-generator!", argc, argv, 1, 0);
2978 }
2979
2980 static Scheme_Object *
sch_check_pack(int argc,Scheme_Object * argv[])2981 sch_check_pack(int argc, Scheme_Object *argv[])
2982 {
2983 return do_pack("pseudo-random-generator-vector?", argc, argv, 0, 1);
2984 }
2985
2986 static Scheme_Object *
sch_unpack(int argc,Scheme_Object * argv[])2987 sch_unpack(int argc, Scheme_Object *argv[])
2988 {
2989 if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type))
2990 scheme_wrong_contract("pseudo-random-generator->vector", "pseudo-random-generator?",
2991 0, argc, argv);
2992
2993 return unpack_rand_state((Scheme_Random_State *)argv[0]);
2994 }
2995
current_pseudo_random_generator(int argc,Scheme_Object * argv[])2996 static Scheme_Object *current_pseudo_random_generator(int argc, Scheme_Object *argv[])
2997 {
2998 return scheme_param_config2("current-pseudo-random-generator",
2999 scheme_make_integer(MZCONFIG_RANDOM_STATE),
3000 argc, argv,
3001 -1, pseudo_random_generator_p, "pseudo-random-generator?", 0);
3002 }
3003
current_sched_pseudo_random_generator(int argc,Scheme_Object * argv[])3004 static Scheme_Object *current_sched_pseudo_random_generator(int argc, Scheme_Object *argv[])
3005 {
3006 return scheme_param_config2("current-evt-pseudo-random-generator",
3007 scheme_make_integer(MZCONFIG_SCHEDULER_RANDOM_STATE),
3008 argc, argv,
3009 -1, pseudo_random_generator_p, "pseudo-random-generator?", 0);
3010 }
3011
make_pseudo_random_generator(int argc,Scheme_Object ** argv)3012 static Scheme_Object *make_pseudo_random_generator(int argc, Scheme_Object **argv)
3013 {
3014 return scheme_make_random_state(scheme_get_milliseconds());
3015 }
3016
pseudo_random_generator_p(int argc,Scheme_Object ** argv)3017 static Scheme_Object *pseudo_random_generator_p(int argc, Scheme_Object **argv)
3018 {
3019 return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_random_state_type))
3020 ? scheme_true
3021 : scheme_false);
3022 }
3023
3024 /* Just to make sure there are no C compiler number issues, we
3025 record floting-point values just outside of the fixnum
3026 range as little-endian byte sequences: */
3027
3028 #ifdef SIXTY_FOUR_BIT_INTEGERS
3029
3030 #if MZ_IS_BIG_ENDIAN
3031 # define double_too_positive_for_fixnum_bytes "C\320\0\0\0\0\0\0" /* 4.611686018427388e+18 */
3032 # define double_too_negative_for_fixnum_bytes "\303\320\0\0\0\0\0\1" /* -4.611686018427389e+18 */
3033 #else
3034 # define double_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\320C" /* 4.611686018427388e+18 */
3035 # define double_too_negative_for_fixnum_bytes "\1\0\0\0\0\0\320\303" /* -4.611686018427389e+18 */
3036 #endif
3037
3038 /* always little-endian: */
3039 #define extfl_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\0\200=@" /* 4611686018427387904.0t0 */
3040 #define extfl_too_negative_for_fixnum_bytes "\2\0\0\0\0\0\0\200=\300" /* -4611686018427387905.0t0 */
3041
3042 #else
3043
3044 #if MZ_IS_BIG_ENDIAN
3045 # define double_too_positive_for_fixnum_bytes "A\320\0\0\0\0\0\0" /* 1073741824.0 */
3046 # define double_too_negative_for_fixnum_bytes "\301\320\0\0\0@\0\0" /* -1073741825.0 */
3047 #else
3048 # define double_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\320A" /* 1073741824.0 */
3049 # define double_too_negative_for_fixnum_bytes "\0\0@\0\0\0\320\301" /* -1073741825.0 */
3050 #endif
3051
3052 /* always little-endian: */
3053 #define extfl_too_positive_for_fixnum_bytes "\0\0\0\0\0\0\0\200\35@" /* 1073741824.0 */
3054 #define extfl_too_negative_for_fixnum_bytes "\0\0\0\0\2\0\0\200\35\300" /* -1073741825.0 */
3055
3056 #endif
3057
init_double_fixnum_extremes(void)3058 static void init_double_fixnum_extremes(void)
3059 {
3060 memcpy(&scheme_double_too_positive_for_fixnum, double_too_positive_for_fixnum_bytes, sizeof(double));
3061 memcpy(&scheme_double_too_negative_for_fixnum, double_too_negative_for_fixnum_bytes, sizeof(double));
3062 #ifdef MZ_LONG_DOUBLE
3063 memcpy(&scheme_extfl_too_positive_for_fixnum, extfl_too_positive_for_fixnum_bytes, 10);
3064 memcpy(&scheme_extfl_too_negative_for_fixnum, extfl_too_negative_for_fixnum_bytes, 10);
3065 #endif
3066 }
3067