suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- modified floatify_normalize to properly round denormalized results and

Browse Source 
obviated scale_float in the process.
    number.c,
    ieee.ms
- fixed 0eNNNN for large NNNN to produce 0.0 rather than infinity
    strnum.ss,
    5_3.ms
- the reader now raises an exception with condition type implementation
  restriction (among the other usual lexical condition types), and
  string->number now raises #f, for #e<m>@<a>, where <m> and <a> are
  nonzero integers, since Chez Scheme can't represent polar numbers other
  than 0@<a> and <m>@0 exactly.  <m>@<a> still produces an inexact result,
  i.e., we're still extending the set of inexact numeric constants beyond
  what R6RS dictates.  doing this required a rework of $str->num, which
  turned into a fairly extensive rewrite that fixed up a few other minor
  issues (like r6rs:string->number improperly allowing 1/2e10) and
  eliminated the need for consumers to call $str->num twice in cases
  where it actually produces a number.  added some related new tests,
  including several found lacking by profiling.  added a couple of
  checks to number->string whose absence was causing argument errors to
  be reported by other routines.
    strnum.ss, exceptions.ss, read.ss
    5_3.ms, 6.ms, root-experr*, patch*
- added pdtml flag, which if set to t causes profile-dump-html to be
  called at the end of a mat run.
    mats/Mf-base

original commit: 03f2fe86171b0fd096238280b351ce365c701450
This commit is contained in:
dybvig 2016-05-01 16:05:40 -04:00
parent cfe66a259b
commit bf38db8ed9
17 changed files with 1204 additions and 872 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
LOG
View File

@ -59,3 +59,29 @@
object to a time-utc object.
stats.c,
date.ms
- modified floatify_normalize to properly round denormalized results and
obviated scale_float in the process.
number.c,
ieee.ms
- fixed 0eNNNN for large NNNN to produce 0.0 rather than infinity
strnum.ss,
5_3.ms
- the reader now raises an exception with condition type implementation
restriction (among the other usual lexical condition types), and
string->number now raises #f, for #e<m>@<a>, where <m> and <a> are
nonzero integers, since Chez Scheme can't represent polar numbers other
than 0@<a> and <m>@0 exactly. <m>@<a> still produces an inexact result,
i.e., we're still extending the set of inexact numeric constants beyond
what R6RS dictates. doing this required a rework of $str->num, which
turned into a fairly extensive rewrite that fixed up a few other minor
issues (like r6rs:string->number improperly allowing 1/2e10) and
eliminated the need for consumers to call $str->num twice in cases
where it actually produces a number. added some related new tests,
including several found lacking by profiling. added a couple of
checks to number->string whose absence was causing argument errors to
be reported by other routines.
strnum.ss, exceptions.ss, read.ss
5_3.ms, 6.ms, root-experr*, patch*
- added pdtml flag, which if set to t causes profile-dump-html to be
called at the end of a mat run.
mats/Mf-base

121
c/number.c
View File

@ -1037,57 +1037,6 @@ struct dblflt {
#endif
#endif
#if defined(__STDC__) || defined(USE_ANSI_PROTOTYPES)
#include <math.h>
#endif /* defined(__STDC__) || defined(USE_ANSI_PROTOTYPES) */
/* use LDEXP to scale floats if it exists and works properly; otherwise
use our own. scale_float no longer receives negative values, so we
no longer worry if ldexp can't handle negative numbers */
#ifdef LDEXP
#define scale_float ldexp
#else /* LDEXP */
#if defined(__STDC__) || defined(USE_ANSI_PROTOTYPES)
static double scale_float(double d, INT e);
#endif /* defined(__STDC__) || defined(USE_ANSI_PROTOTYPES) */
#ifdef IEEE_DOUBLE
#ifdef BAD_INF_POW
/* pow returns HUGE_VAL instead of infinity when result would overflow */
#define POW xpow
static double xpow(x, y) double x, y; {
double d = pow(x, y);
if (d == +HUGE_VAL)
return 1.0 / 0.0;
else if (d == -HUGE_VAL)
return -1.0 / 0.0;
else return d;
}
#else /* BAD_INF_POW */
#define POW pow
#endif /* BAD_INF_POW */
static double scale_float(d, e) double d; I32 e; {
/* works only for normalized ieee double floats */
union dxunion {
double d;
struct dblflt x;
} dx;
if (d == 0.0 || e == 0) return d;
dx.d = d;
e += dx.x.e - bias;
dx.x.e = bias;
if (dx.d > 1.0 && e == - (bias + bitstoright))
dx.d = POW(2.0,(double)(e+1));
else
dx.d = dx.d * POW(2.0,(double)e);
return dx.d;
}
#endif /* IEEE_DOUBLE */
#endif /* LDEXP */
double S_random_double(m1, m2, m3, m4, scale) U32 m1, m2, m3, m4; double scale; {
/* helper for s_fldouble in prim5.c */
union dxunion {
@ -1104,7 +1053,7 @@ double S_random_double(m1, m2, m3, m4, scale) U32 m1, m2, m3, m4; double scale;
return (dx.d - 1.0) * scale;
}
/* number quotient bigits to guarantee at least 64 bits */
/* number of quotient bigits to guarantee at least 64 bits */
/* +2 since first bigit may be zero and second may not be full */
#define enough (64 / bigit_bits + 2)
@ -1169,17 +1118,17 @@ static double floatify_normalize(p, e, sign, sticky) bigit *p; iptr e; IBOOL sig
U64 mlow;
IBOOL cutbit = 0;
INT n;
/* shift in what we need, plus at least one bit */
/* shift in what we need, plus at least one bit */
mhigh = 0; mlow = 0; n = enough;
while (mhigh == 0 && mlow < hidden_bit * 2) {
mhigh = (bigit)(mlow >> (64-bigit_bits));
mlow = (mlow << bigit_bits) | *p++; /* broken on i3le */
mlow = (mlow << bigit_bits) | *p++;
n -= 1;
e -= bigit_bits;
}
/* back up to align high bit on hidden bit, setting cut bit to last loser */
/* back up to align high bit on hidden bit, setting cut bit to last loser */
do {
sticky = sticky || cutbit;
cutbit = (bigit)(mlow & 1);
@ -1188,32 +1137,54 @@ static double floatify_normalize(p, e, sign, sticky) bigit *p; iptr e; IBOOL sig
e = e + 1;
} while (mhigh != 0 || mlow >= hidden_bit * 2);
/* round if necessary */
if (cutbit) {
IBOOL round;
round = (mlow & 1) || sticky;
while (!round && n-- > 0) round = *p++ != 0;
if (round && (mlow += 1) == hidden_bit * 2) e += 1;
e = e + bitstoright + bias;
/* back up further if denormalized */
if (e <= 0) {
for (;;) {
sticky = sticky || cutbit;
cutbit = (bigit)(mlow & 1);
mlow = mlow >> 1;
if (e == 0 || mlow == 0) break;
e = e + 1;
}
}
/* fill in the fields */
dx.x.sign = 0;
dx.x.e = bias;
if (e < 0) {
e = 0; /* NB: e < 0 => mlow == 0 */
} else {
/* round up if necessary */
if (cutbit) {
IBOOL round;
/* cutbit = 1 => at least half way to next number. round up if odd or
if there are any bits set to the right of cutbit */
round = (mlow & 1) || sticky;
while (!round && n-- > 0) round = *p++ != 0;
if (round) {
mlow += 1;
if (e == 0 && mlow == hidden_bit) {
e = 1; /* squeeking into lowest normalized spot */
} else if (mlow == hidden_bit * 2) {
/* don't bother with mlow = mlow >> 1 since hidden bit and up are ignored after this */
e += 1;
}
}
}
if (e > 2046) { /* infinity */
e = 2047;
mlow = 0;
}
}
/* fill in the fields */
dx.x.sign = sign;
dx.x.e = e;
dx.x.m1 = (UINT)(mlow >> 48 & m1mask);
dx.x.m2 = (UINT)(mlow >> 32 & 0xffff);
dx.x.m3 = (UINT)(mlow >> 16 & 0xffff);
dx.x.m4 = (UINT)(mlow & 0xffff);
e += bitstoright;
#if (ptr_bits > int_bits)
if ((int)e != e) e = e < 0 ? -100000 : 100000;
#endif
dx.d = scale_float(dx.d, (int)e);
/* fat-finger the sign. HPUX cc at least doesn't properly negate 0.0 */
dx.x.sign = sign;
return dx.d;
}

265
mats/5_3.ms
View File

@ -256,15 +256,21 @@
(eqv? (string->number "0/0") #f)
(== (string->number "0/0#") +nan.0)
(eqv? (string->number "0#/0") #f)
(== (string->number "0/0e20") +nan.0)
(== (string->number "0/0#e20") +nan.0)
(== (string->number "0#/0#") +nan.0)
(== (string->number "#i0/0") +nan.0)
(== (string->number "#i0/0#") +nan.0)
(== (string->number "#i0#/0") +nan.0)
(== (string->number "#i0#/0#") +nan.0)
(== (string->number "#i0/0e20") +nan.0)
(== (string->number "#i0/0#e20") +nan.0)
(eqv? (string->number "#e0/0") #f)
(eqv? (string->number "#e0/0#") #f)
(eqv? (string->number "#e0#/0") #f)
(eqv? (string->number "#e0#/0#") #f)
(eqv? (string->number "#e0/0e20") #f)
(eqv? (string->number "#e0/0#e20") #f)
(eqv? (string->number "1/0") #f)
(eqv? (string->number "1/0#") +inf.0)
(eqv? (string->number "1#/0") #f)
@ -374,13 +380,13 @@
(== (string->number "0/0###") +nan.0)
(== (string->number "-0/0###") +nan.0)
(eqv? (string->number "0/0e10") #f)
(== (string->number "0/0e10") +nan.0)
(== (string->number "#i0/0e10") +nan.0)
(== (string->number "0/0###e10") +nan.0)
(eqv? (string->number "1/0e10") #f)
(eqv? (string->number "1/0e10") +inf.0)
(eqv? (string->number "#i1/0e10") +inf.0)
(eqv? (string->number "1/0###e10") +inf.0)
(eqv? (string->number "-1/0e10") #f)
(eqv? (string->number "-1/0e10") -inf.0)
(eqv? (string->number "#i-1/0e10") -inf.0)
(eqv? (string->number "-1/0###e10") -inf.0)
@ -402,6 +408,59 @@
; don't make no sense
(eqv? (string->number "3@4i") #f)
(eqv? (string->number "3@-i") #f)
; zero with large exponent
(eqv? (string->number "0.0e3000") 0.0)
(eqv? (string->number "-0.0e3000") -0.0)
; exact polar complex numbers. r6rs says anything w/o radix point, exponent sign, or precision is exact.
; we also include polar numbers w/o #e prefix that can't be represented exactly
(eqv? (string->number "0@0") 0)
(eqv? (string->number "1@0") 1)
(eqv? (string->number "0@1") 0)
(eqv? (string->number "1@1") (string->number "1.0@1.0"))
(not (string->number "#e1@1"))
(eqv? (string->number "#i1@1") (make-polar 1.0 1.0))
(eqv? (string->number "1.0@1") (make-polar 1.0 1.0))
(eqv? (string->number "1@1.0") (make-polar 1.0 1.0))
(eqv? (string->number "1.0@1.0") (make-polar 1.0 1.0))
; filling in some cases shown missing by profiling
(eqv? (string->number "1e-5000000000") 0.0)
(eqv? (string->number "-1e-5000000000") -0.0)
(eqv? (string->number "#e0e2000") 0)
(eqv? (string->number "#e0e-2000") 0)
(eqv? (string->number "1/0@5") #f)
(eqv? (string->number "1/0+5") #f)
(eqv? (string->number "#e1e20@0") (expt 10 20))
(eqv? (string->number "+1/0+5i") #f)
(eqv? (string->number "-1/0+5i") #f)
(eqv? (string->number "+1/0i") #f)
(eqv? (string->number "-1/0i") #f)
(eqv? (string->number "#e+inf.0+1i") #f)
(eqv? (string->number "1|21") 1.0)
(eqv? (string->number "1.5|21") 1.5)
(eqv? (string->number "1.5e2|21") 150.)
(eqv? (string->number "1.5e2|21+2i") 150.0+2.0i)
(eqv? (string->number "1.5e2|") #f)
(eqv? (string->number "1.5e2@") #f)
(eqv? (string->number "1.5e2@.5") (make-polar 1.5e2 .5))
(eqv? (string->number "1.5e2@+.5") (make-polar 1.5e2 .5))
(eqv? (string->number "1.5e2@-.5") (make-polar 1.5e2 -.5))
(eqv? (string->number "+in") #f)
(eqv? (string->number "+inf") #f)
(eqv? (string->number "+inf.") #f)
(eqv? (string->number "-in") #f)
(eqv? (string->number "-inf") #f)
(eqv? (string->number "-inf.") #f)
(eqv? (string->number "+n") #f)
(eqv? (string->number "+na") #f)
(eqv? (string->number "+nan") #f)
(eqv? (string->number "+nan.") #f)
(eqv? (string->number "-n") #f)
(eqv? (string->number "-na") #f)
(eqv? (string->number "-nan") #f)
(eqv? (string->number "-nan.") #f)
)
(mat r6rs:string->number
@ -505,9 +564,9 @@
(eqv? (r6rs:string->number "2.e3") (string->number "2000."))
(eqv? (r6rs:string->number "2s3") (string->number "2000."))
(eqv? (r6rs:string->number "2.0f3") (string->number "2000."))
(eqv? (r6rs:string->number "2/1E3") (string->number "2000."))
(eqv? (r6rs:string->number "1/5S4") (string->number "2000."))
(eqv? (r6rs:string->number "-1/5F4") (string->number "-2000."))
(eqv? (r6rs:string->number "2/1E3") #f)
(eqv? (r6rs:string->number "1/5S4") #f)
(eqv? (r6rs:string->number "-1/5F4") #f)
(eqv? (r6rs:string->number ".2D4") (string->number "2000."))
(not (r6rs:string->number "2.a"))
(not (r6rs:string->number "21##.321"))
@ -524,7 +583,7 @@
(not (r6rs:string->number "-2/3ex"))
(not (r6rs:string->number "2.1e-"))
(not (r6rs:string->number "2e-i"))
(eqv? (r6rs:string->number "#e2/3e4") (string->number "20000/3"))
(eqv? (r6rs:string->number "#e2/3e4") #f)
(not (r6rs:string->number "2.0e10a"))
; complex cases
(equal? (r6rs:string->number "+i") +i)
@ -594,21 +653,24 @@
(== (r6rs:string->number "#i-0/0000") +nan.0)
(eqv? (r6rs:string->number "0/0e10") #f)
(== (r6rs:string->number "#i0/0e10") +nan.0)
(eqv? (r6rs:string->number "#i0/0e10") #f)
(eqv? (r6rs:string->number "#e0/0e10") #f)
(eqv? (r6rs:string->number "1/0e10") #f)
(eqv? (r6rs:string->number "#i1/0e10") +inf.0)
(eqv? (r6rs:string->number "#i1/0e10") #f)
(eqv? (r6rs:string->number "#e1/0e10") #f)
(eqv? (r6rs:string->number "-1/0e10") #f)
(eqv? (r6rs:string->number "#i-1/0e10") -inf.0)
(eqv? (r6rs:string->number "#i-1/0e10") #f)
(eqv? (r6rs:string->number "#e-1/0e10") #f)
(eqv? (r6rs:string->number "-1/2e10000") -inf.0)
(eqv? (r6rs:string->number "1/2e10000") +inf.0)
(eqv? (r6rs:string->number "#e-1/2e10000") (* -1/2 (expt 10 10000)))
(eqv? (r6rs:string->number "#e1/2e10000") (* 1/2 (expt 10 10000)))
(eqv? (r6rs:string->number "-1/2e10000") #f)
(eqv? (r6rs:string->number "1/2e10000") #f)
(eqv? (r6rs:string->number "#e-1/2e10000") #f)
(eqv? (r6rs:string->number "#e1/2e10000") #f)
(eqv? (r6rs:string->number "0e25") 0.0)
(eqv? (r6rs:string->number "-0e25") -0.0)
(eqv? (r6rs:string->number "0/1e25") 0.0)
(eqv? (r6rs:string->number "-0/1e25") -0.0)
(eqv? (r6rs:string->number "0/1e25") #f)
(eqv? (r6rs:string->number "-0/1e25") #f)
; can't have no exact nans and infinities
(eqv? (r6rs:string->number "#e+nan.0") #f)
@ -618,27 +680,162 @@
; don't make no sense
(eqv? (r6rs:string->number "3@4i") #f)
(eqv? (r6rs:string->number "3@-i") #f)
; filling in some cases shown missing by profiling
(eqv? (r6rs:string->number "1e-5000000000") 0.0)
(eqv? (r6rs:string->number "-1e-5000000000") -0.0)
(eqv? (r6rs:string->number "#e0e2000") 0)
(eqv? (r6rs:string->number "#e0e-2000") 0)
(eqv? (r6rs:string->number "1/0@5") #f)
(eqv? (r6rs:string->number "1/0+5") #f)
(eqv? (r6rs:string->number "#e1e20@0") (expt 10 20))
(eqv? (r6rs:string->number "+1/0+5i") #f)
(eqv? (r6rs:string->number "-1/0+5i") #f)
(eqv? (r6rs:string->number "+1/0i") #f)
(eqv? (r6rs:string->number "-1/0i") #f)
(eqv? (r6rs:string->number "#e+inf.0+1i") #f)
(eqv? (r6rs:string->number "1|21") 1.0)
(eqv? (r6rs:string->number "1.5|21") 1.5)
(eqv? (r6rs:string->number "1.5e2|21") 150.)
(eqv? (r6rs:string->number "1.5e2|21+2i") 150.0+2.0i)
(eqv? (r6rs:string->number "1.5e2|") #f)
(eqv? (r6rs:string->number "1.5e2@") #f)
(eqv? (r6rs:string->number "1.5e2@.5") (make-polar 1.5e2 .5))
(eqv? (r6rs:string->number "1.5e2@+.5") (make-polar 1.5e2 .5))
(eqv? (r6rs:string->number "1.5e2@-.5") (make-polar 1.5e2 -.5))
(eqv? (r6rs:string->number "+in") #f)
(eqv? (r6rs:string->number "+inf") #f)
(eqv? (r6rs:string->number "+inf.") #f)
(eqv? (r6rs:string->number "-in") #f)
(eqv? (r6rs:string->number "-inf") #f)
(eqv? (r6rs:string->number "-inf.") #f)
(eqv? (r6rs:string->number "+n") #f)
(eqv? (r6rs:string->number "+na") #f)
(eqv? (r6rs:string->number "+nan") #f)
(eqv? (r6rs:string->number "+nan.") #f)
(eqv? (r6rs:string->number "-n") #f)
(eqv? (r6rs:string->number "-na") #f)
(eqv? (r6rs:string->number "-nan") #f)
(eqv? (r6rs:string->number "-nan.") #f)
(eqv? (r6rs:string->number "1.0e+5000") +inf.0)
(eqv? (r6rs:string->number "-1.0e+5000") -inf.0)
(eqv? (r6rs:string->number "0@1") 0)
(eqv? (r6rs:string->number "#e1@1") #f)
)
(mat number->string
(equal? (number->string 3) "3")
(equal? (number->string 3/4) "3/4")
(equal? (number->string 3.024) "3.024")
(eqv? (string->number (number->string #i2/3)) #i2/3)
(equal? (number->string 3.000) "3.0")
(equal? (number->string 3.2e20) "3.2e20")
(equal? (number->string 3.2e2) "320.0")
(equal? (number->string 3200000) "3200000")
(equal? (number->string 320000) "320000")
(equal? (number->string 3+4.0i) "3.0+4.0i")
(equal? (number->string 3-4.0i) "3.0-4.0i")
(equal? (number->string 1.003-4i) "1.003-4.0i")
(equal? (number->string 3+4i) "3+4i")
(equal? (number->string 3-4i) "3-4i")
(equal? (number->string (make-rectangular 3.0 4)) "3.0+4.0i")
(equal? (number->string (make-rectangular 3 4.0)) "3.0+4.0i")
(equal? (number->string (make-rectangular 3 4)) "3+4i")
)
(error? ; not a number
(number->string 'a))
(error? ; not a number
(number->string 'a 24))
(error? ; not a number
(number->string 'a 16 24))
(error? ; invalid radix
(number->string 0.0 'a))
(error? ; invalid radix
(number->string 0.0 -1))
(error? ; invalid radix
(number->string 0.0 0))
(error? ; invalid radix
(number->string 0.0 1))
(error? ; invalid radix
(number->string 0.0 'a 24))
(error? ; invalid radix
(number->string 0.0 -1 24))
(error? ; invalid radix
(number->string 0.0 0 24))
(error? ; invalid radix
(number->string 0.0 1 24))
(error? ; invalid precision
(number->string 0.0 10 'a))
(error? ; invalid precision
(number->string 0.0 10 0))
(error? ; invalid precision
(number->string 0.0 10 -24))
(error? ; invalid precision
(number->string 0.0 10 (- (most-negative-fixnum) 1)))
(error? ; precision given w/exact number
(number->string 1 10 24))
(equal? (number->string 3) "3")
(equal? (number->string 3/4) "3/4")
(equal? (number->string 3.024) "3.024")
(eqv? (string->number (number->string #i2/3)) #i2/3)
(equal? (number->string 3.000) "3.0")
(equal? (number->string 3.2e20) "3.2e20")
(equal? (number->string 3.2e2) "320.0")
(equal? (number->string 3200000) "3200000")
(equal? (number->string 320000) "320000")
(equal? (number->string 3+4.0i) "3.0+4.0i")
(equal? (number->string 3-4.0i) "3.0-4.0i")
(equal? (number->string 1.003-4i) "1.003-4.0i")
(equal? (number->string 3+4i) "3+4i")
(equal? (number->string 3-4i) "3-4i")
(equal? (number->string (make-rectangular 3.0 4)) "3.0+4.0i")
(equal? (number->string (make-rectangular 3 4.0)) "3.0+4.0i")
(equal? (number->string (make-rectangular 3 4)) "3+4i")
(equal? (number->string 100.5 10 53) "100.5|53")
(equal? (number->string #x100 16) "100")
(equal? (number->string #x100 8) "400")
(equal? (number->string #x100 16) "100")
)
(mat r6rs:number->string
(error? ; not a number
(r6rs:number->string 'a))
(error? ; not a number
(r6rs:number->string 'a 24))
(error? ; not a number
(r6rs:number->string 'a 16 24))
(error? ; invalid radix
(r6rs:number->string 0.0 'a))
(error? ; invalid radix
(r6rs:number->string 0.0 -1))
(error? ; invalid radix
(r6rs:number->string 0.0 0))
(error? ; invalid radix
(r6rs:number->string 0.0 1))
(error? ; invalid radix
(r6rs:number->string 0.0 'a 24))
(error? ; invalid radix
(r6rs:number->string 0.0 -1 24))
(error? ; invalid radix
(r6rs:number->string 0.0 0 24))
(error? ; invalid radix
(r6rs:number->string 0.0 1 24))
(error? ; invalid precision
(r6rs:number->string 0.0 10 'a))
(error? ; invalid precision
(r6rs:number->string 0.0 10 0))
(error? ; invalid precision
(r6rs:number->string 0.0 10 -24))
(error? ; invalid precision
(r6rs:number->string 0.0 10 (- (most-negative-fixnum) 1)))
(error? ; precision given w/exact number
(r6rs:number->string 1 10 24))
(error? ; precision given radix other than 10
(r6rs:number->string 1 16 24))
(equal? (r6rs:number->string 3) "3")
(equal? (r6rs:number->string 3/4) "3/4")
(equal? (r6rs:number->string 3.024) "3.024")
(eqv? (string->number (r6rs:number->string #i2/3)) #i2/3)
(equal? (r6rs:number->string 3.000) "3.0")
(equal? (r6rs:number->string 3.2e20) "3.2e20")
(equal? (r6rs:number->string 3.2e2) "320.0")
(equal? (r6rs:number->string 3200000) "3200000")
(equal? (r6rs:number->string 320000) "320000")
(equal? (r6rs:number->string 3+4.0i) "3.0+4.0i")
(equal? (r6rs:number->string 3-4.0i) "3.0-4.0i")
(equal? (r6rs:number->string 1.003-4i) "1.003-4.0i")
(equal? (r6rs:number->string 3+4i) "3+4i")
(equal? (r6rs:number->string 3-4i) "3-4i")
(equal? (r6rs:number->string (make-rectangular 3.0 4)) "3.0+4.0i")
(equal? (r6rs:number->string (make-rectangular 3 4.0)) "3.0+4.0i")
(equal? (r6rs:number->string (make-rectangular 3 4)) "3+4i")
(equal? (r6rs:number->string 100.5 10 53) "100.5|53")
(equal? (r6rs:number->string #x100 16) "100")
(equal? (r6rs:number->string #x100 8) "400")
(equal? (r6rs:number->string #x100 16) "100")
)
(mat most-positive-fixnum
(procedure? most-positive-fixnum)

6
mats/6.ms
View File

@ -1700,6 +1700,8 @@
"; Test error \"cannot represent\"\n\n(sqrt #e+inf.0)\n\n"
"; Test error \"cannot represent\"\n\n(sqrt #e-inf.0)\n\n"
"; Test error \"cannot represent\"\n\n(sqrt #e+nan.0)\n\n"
"; Test error \"cannot represent\"\n\n(sqrt #e0/0e20)\n\n"
"; Test error \"cannot represent\"\n\n(sqrt #e1@1)\n\n"
"; Test error \"invalid number syntax\"\n\n(sqrt #e+nan.5)\n\n"
"; Test error \"invalid sharp-sign prefix #~c\"\n\n(if #T #N #T)\n"
"; Test error \"invalid sharp-sign prefix ~a~a\"\n\n(if (optimize-til-it-hurts?) (#7%super-fast+ 1 2) (+ 1 2))\n"
@ -1833,6 +1835,10 @@
"; Test error \"back-slash symbol escape syntax not allowed in #!r6rs mode\"\n\n#!r6rs ab\\ cd\n"
"; Test error \"|...| symbol escape syntax not allowed in #!r6rs mode\"\n\n#!r6rs |ab cd|\n"
"; Test error \"@abc symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs @abc\n"
"; Test error \"123a symbol syntax not allowed in #!r6rs mode\"\n\n#!r6rs 123a\n"
"; Test error \"123# number syntax not allowed in #!r6rs mode\"\n\n#!r6rs 123#\n"
"; Test error \"#x1/2e2 number syntax not allowed in #!r6rs mode\"\n\n#!r6rs 1/2e2\n"
"; Test error \"#x.3 number syntax not allowed in #!r6rs mode\"\n\n#!r6rs #x.3\n"
; following tests adapted from the read0 benchmark distributed by Will
; Clinger, which as of 08/08/2009 appears to be in the public domain,

7
mats/Mf-base
View File

@ -52,6 +52,11 @@ o = 0
defaultp = f
p = $(defaultp)
# pdhtml determines whether profile-dump-html is called at end of a run: f for false, t for true.
# NB: beware of lost profile information due to mats that call profile-clear
defaultpdhtml = f
pdhtml = $(defaultpdhtml)
# cp0 determines whether cp0 is run: f for no, t for yes
defaultcp0 = f
cp0 = $(defaultcp0)
@ -153,6 +158,7 @@ $(objdir)/%.mo : %.ms mat.so
'(set! *scheme* "${Scheme}")'\
'(current-eval ${eval})'\
'(time ((mat-file ".") "$*"))'\
'(parameterize ([source-directories (quote ("." "../s"))]) (when #${pdhtml} (profile-dump-html)))'\
'(unless (= (#%$$check-heap-errors) 0)'\
' (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\
' (abort))'\
@ -305,6 +311,7 @@ script.all$o makescript$o:
'(current-eval ${eval})'\
'(time (for-each (mat-file "$(objdir)")'\
' (quote ($(mats:%="%")))))'\
'(parameterize ([source-directories (quote ("." "../s"))]) (when #${pdhtml} (profile-dump-html)))'\
'(unless (= (#%$$check-heap-errors) 0)'\
' (fprintf (console-error-port) "check heap detected errors---grep standard output for !!!\n")'\
' (abort))'\

23
mats/ieee.ms
View File

@ -83,6 +83,29 @@
#x1000000000000100000000000000000000.0)
(fl= (inexact (* (+ (ash 1 52) 3/2 (expt 2 -80)) (expt 2 80)))
#x1000000000000200000000000000000000.0)
; verify fix for incorrect input of 2.2250738585072011e-308 reported by leppie
; 2.2250738585072011e-308 falls right on the edge between normalized and denormalized numbers,
; and should not be rounded up to a normalized number
(equal?
(number->string (string->number "2.2250738585072011e-308"))
"2.225073858507201e-308|52")
(equal?
(decode-float (string->number "2.2250738585072011e-308"))
'#(#b1111111111111111111111111111111111111111111111111111 -1074 1))
; similar case in binary...
(equal?
(decode-float (string->number "#b1.111111111111111111111111111111111111111111111111111011e-1111111111"))
'#(#b1111111111111111111111111111111111111111111111111111 -1074 1))
(equal?
(number->string (string->number "#b1.111111111111111111111111111111111111111111111111111011e-1111111111"))
"2.225073858507201e-308|52")
; slightly higher number should be rounded up
(equal?
(number->string (string->number "2.2250738585072012e-308"))
"2.2250738585072014e-308")
(equal?
(number->string (string->number "#b1.111111111111111111111111111111111111111111111111111100e-1111111111"))
"2.2250738585072014e-308")
)
(mat exact

28
mats/patch-compile-0-f-t-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f Fri Apr 15 23:13:15 2016
--- errors-compile-0-f-t-f Fri Apr 15 22:44:57 2016
*** errors-compile-0-f-f-f 2016-05-01 13:38:30.812572752 -0400
--- errors-compile-0-f-t-f 2016-05-01 13:17:27.556633016 -0400
***************
*** 125,131 ****
3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a".
@ -58,7 +58,7 @@
3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17".
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
***************
*** 3574,3580 ****
*** 3607,3613 ****
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@ -66,7 +66,7 @@
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
--- 3574,3580 ----
--- 3607,3613 ----
misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable bar".
@ -75,7 +75,7 @@
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable b".
misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable a".
***************
*** 6999,7006 ****
*** 7050,7057 ****
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -84,7 +84,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 6999,7006 ----
--- 7050,7057 ----
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -94,7 +94,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7008,7022 ****
*** 7059,7073 ****
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -110,7 +110,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7008,7022 ----
--- 7059,7073 ----
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -127,7 +127,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7029,7054 ****
*** 7080,7105 ****
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -154,7 +154,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7029,7054 ----
--- 7080,7105 ----
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -182,7 +182,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7160,7198 ****
*** 7221,7259 ****
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -222,7 +222,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7160,7198 ----
--- 7221,7259 ----
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -263,7 +263,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7207,7263 ****
*** 7268,7324 ****
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -321,7 +321,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
--- 7207,7263 ----
--- 7268,7324 ----
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".

591
mats/patch-compile-0-t-f-f
View File

File diff suppressed because it is too large Load Diff

40
mats/patch-interpret-0-f-f-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f Fri Apr 15 23:13:15 2016
--- errors-interpret-0-f-f-f Fri Apr 15 22:57:53 2016
*** errors-compile-0-f-f-f 2016-05-01 13:38:30.812572752 -0400
--- errors-interpret-0-f-f-f 2016-05-01 13:27:13.120817742 -0400
***************
*** 1,7 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
@ -196,7 +196,7 @@
3.mo:Expected error in mat mrvs: "returned two values to single value return context".
3.mo:Expected error in mat mrvs: "cdr: a is not a pair".
***************
*** 3926,3941 ****
*** 3959,3974 ****
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@ -213,9 +213,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 3932,3941 ----
--- 3965,3974 ----
***************
*** 6863,6869 ****
*** 6914,6920 ****
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@ -223,7 +223,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 6863,6869 ----
--- 6914,6920 ----
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@ -232,7 +232,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 7171,7177 ****
*** 7232,7238 ****
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@ -240,7 +240,7 @@
record.mo:Expected error in mat record25: "invalid value 12.0 for foreign type long-long".
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
--- 7171,7177 ----
--- 7232,7238 ----
record.mo:Expected error in mat record25: "invalid value #\9 for foreign type uptr".
record.mo:Expected error in mat record25: "invalid value 10 for foreign type float".
record.mo:Expected error in mat record25: "invalid value 11.0+0.0i for foreign type double".
@ -249,7 +249,7 @@
record.mo:Expected error in mat record25: "invalid value 13.0 for foreign type unsigned-long-long".
record.mo:Expected error in mat record25: "invalid value 3.0 for foreign type int".
***************
*** 8345,8357 ****
*** 8406,8418 ****
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -263,7 +263,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8345,8357 ----
--- 8406,8418 ----
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -278,7 +278,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 9107,9131 ****
*** 9168,9192 ****
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -304,7 +304,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier booleen".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
--- 9107,9131 ----
--- 9168,9192 ----
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle foo".
@ -331,7 +331,7 @@
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure argument type specifier integer-34".
foreign.mo:Expected error in mat foreign-procedure: "invalid foreign-procedure result type specifier chare".
***************
*** 9138,9169 ****
*** 9199,9230 ****
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -364,7 +364,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
--- 9138,9169 ----
--- 9199,9230 ----
foreign.mo:Expected error in mat foreign-sizeof: "incorrect argument count in call (foreign-sizeof (quote int) (quote int))".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type".
foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1".
@ -398,7 +398,7 @@
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
***************
*** 9171,9196 ****
*** 9232,9257 ****
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -425,7 +425,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
--- 9171,9196 ----
--- 9232,9257 ----
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
foreign.mo:Expected error in mat foreign-strings: "foreign-callable: invalid return value ("ello" 4) from #<procedure>".
@ -453,7 +453,7 @@
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
***************
*** 9201,9235 ****
*** 9262,9296 ****
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -489,7 +489,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
--- 9201,9235 ----
--- 9262,9296 ----
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
foreign.mo:Expected error in mat foreign-fixed-types: "foreign-callable: invalid return value (- x 7) from #<procedure>".
@ -526,7 +526,7 @@
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
foreign.mo:Expected error in mat foreign-C-types: "foreign-callable: invalid return value (73 74) from #<procedure>".
***************
*** 9815,9824 ****
*** 9876,9885 ****
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@ -537,7 +537,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 9815,9824 ----
--- 9876,9885 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

40
mats/patch-interpret-0-f-t-f
View File

@ -1,5 +1,5 @@
*** errors-compile-0-f-t-f Fri Apr 15 22:44:57 2016
--- errors-interpret-0-f-t-f Fri Apr 15 23:05:00 2016
*** errors-compile-0-f-t-f 2016-05-01 13:17:27.556633016 -0400
--- errors-interpret-0-f-t-f 2016-05-01 13:32:19.876348905 -0400
***************
*** 1,7 ****
primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure".
@ -169,7 +169,7 @@
3.mo:Expected error in mat letrec: "variable f is not bound".
3.mo:Expected error in mat letrec: "attempt to reference undefined variable a".
***************
*** 3926,3941 ****
*** 3959,3974 ****
6.mo:Expected error in mat pretty-print: "incorrect argument count in call (pretty-format (quote foo) (quote x) (quote x))".
6.mo:Expected error in mat pretty-print: "pretty-format: 3 is not a symbol".
6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)".
@ -186,9 +186,9 @@
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too few arguments for control string "abc~s" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected warning in mat cp1in-verify-format-warnings: "compile: too many arguments for control string "~%~abc~adef~ag~s~~~%" in call to fprintf at line 1, char 29 of testfile.ss".
6.mo:Expected error in mat print-parameters: "write: cycle detected; proceeding with (print-graph #t)".
--- 3932,3941 ----
--- 3965,3974 ----
***************
*** 6863,6869 ****
*** 6914,6920 ****
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@ -196,7 +196,7 @@
7.mo:Expected error in mat eval: "interpret: 7 is not an environment".
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
--- 6863,6869 ----
--- 6914,6920 ----
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for testfile-mc-1a.ss: no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: failed for "testfile-mc-1a.ss": no such file or directory
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in maybe-compile-library: file "testfile-mc-1a.ss" not found in source directories
@ -205,7 +205,7 @@
7.mo:Expected error in mat eval: "compile: 7 is not an environment".
7.mo:Expected error in mat expand: "sc-expand: 7 is not an environment".
***************
*** 6999,7006 ****
*** 7050,7057 ****
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -214,7 +214,7 @@
record.mo:Expected error in mat record2: "invalid value 3 for foreign type double-float".
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
--- 6999,7006 ----
--- 7050,7057 ----
7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu".
7.mo:Expected error in mat error: "a: hit me!".
7.mo:Expected error in mat error: "f: n is 0".
@ -224,7 +224,7 @@
record.mo:Expected error in mat record2: "3 is not of type #<record type fudge>".
record.mo:Expected error in mat record2: "make-record-type: invalid field list ((immutable double-float a) . b)".
***************
*** 7008,7022 ****
*** 7059,7073 ****
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -240,7 +240,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid input #f".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
--- 7008,7022 ----
--- 7059,7073 ----
record.mo:Expected error in mat type-descriptor: "invalid syntax (type-descriptor 3)".
record.mo:Expected error in mat type-descriptor: "type-descriptor: unrecognized record car".
record.mo:Expected error in mat record3: "variable set-fudge-a! is not bound".
@ -257,7 +257,7 @@
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
record.mo:Expected error in mat record9: "record-reader: invalid second argument fudge".
***************
*** 7029,7054 ****
*** 7080,7105 ****
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -284,7 +284,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: 0 is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
--- 7029,7054 ----
--- 7080,7105 ----
record.mo:Expected error in mat record10: "read: unresolvable cycle constructing record of type #<record type bar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
record.mo:Expected error in mat record16: "read: unresolvable cycle constructing record of type #<record type bazar> at char 3 of #<input port string>".
@ -312,7 +312,7 @@
record.mo:Expected error in mat foreign-data: "foreign-alloc: <int> is not a positive fixnum".
record.mo:Expected error in mat foreign-data: "foreign-alloc: -5 is not a positive fixnum".
***************
*** 7160,7198 ****
*** 7221,7259 ****
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -352,7 +352,7 @@
record.mo:Expected error in mat record?: "record?: 4 is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
--- 7160,7198 ----
--- 7221,7259 ----
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record22: "invalid field specifier (immutable creepy q)".
record.mo:Expected error in mat record23: "make-record-type: cannot extend sealed record type #<record type foo>".
@ -393,7 +393,7 @@
record.mo:Expected error in mat record?: "record?: a is not a record type descriptor".
record.mo:Expected error in mat record?: "record?: #(1) is not a record type descriptor".
***************
*** 7207,7263 ****
*** 7268,7324 ****
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -451,7 +451,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
--- 7207,7263 ----
--- 7268,7324 ----
record.mo:Expected error in mat r6rs-records-procedural: "make-record-constructor-descriptor: invalid protocol flimflam".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure not-a-procedure".
record.mo:Expected error in mat r6rs-records-procedural: "attempt to apply non-procedure spam".
@ -510,7 +510,7 @@
record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent".
record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat".
***************
*** 8345,8357 ****
*** 8406,8418 ****
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -524,7 +524,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
--- 8345,8357 ----
--- 8406,8418 ----
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum".
fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum".
@ -539,7 +539,7 @@
fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum".
fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum".
***************
*** 9815,9824 ****
*** 9876,9885 ****
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".
@ -550,7 +550,7 @@
oop.mo:Expected error in mat oop: "m1: not applicable to 17".
oop.mo:Expected error in mat oop: "variable <a>-x1 is not bound".
oop.mo:Expected error in mat oop: "variable <a>-x1-set! is not bound".
--- 9815,9824 ----
--- 9876,9885 ----
exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))".
exceptions.mo:Expected error in mat assert: "failed assertion (q ...)".
exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))".

4
mats/patch-interpret-3-f-f-f
View File

@ -1,5 +1,5 @@
*** errors-compile-3-f-f-f Fri Apr 15 22:41:40 2016
--- errors-interpret-3-f-f-f Fri Apr 15 23:18:26 2016
*** errors-compile-3-f-f-f 2016-05-01 13:15:04.367323263 -0400
--- errors-interpret-3-f-f-f 2016-05-01 13:42:18.210493401 -0400
***************
*** 1,3 ****
--- 1,9 ----

4
mats/patch-interpret-3-f-t-f
View File

@ -1,5 +1,5 @@
*** errors-compile-3-f-t-f Fri Apr 15 22:47:53 2016
--- errors-interpret-3-f-t-f Fri Apr 15 23:08:32 2016
*** errors-compile-3-f-t-f 2016-05-01 13:19:46.141964962 -0400
--- errors-interpret-3-f-t-f 2016-05-01 13:34:49.880630639 -0400
***************
*** 1,3 ****
--- 1,9 ----

51
mats/root-experr-compile-0-f-f-f
View File

@ -785,6 +785,39 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
5_3.mo:Expected error in mat r6rs:string->number: "string->number: 36 is not a valid radix".
5_3.mo:Expected error in mat r6rs:string->number: "string->number: a is not a valid radix".
5_3.mo:Expected error in mat r6rs:string->number: "incorrect argument count in call (string->number "a" 10 10)".
5_3.mo:Expected error in mat number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: a is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: 0 is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: -24 is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: <-int> is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: a precision is specified and 1 is not inexact".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 0 is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: -24 is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: <-int> is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a precision is specified and 1 is not inexact".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a precision is specified and radix 16 is not 10".
5_3.mo:Expected error in mat exact?: "exact?: a is not a number".
5_3.mo:Expected error in mat inexact?: "inexact?: () is not a number".
5_3.mo:Expected error in mat =: "incorrect argument count in call (=)".
@ -3997,6 +4030,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat read-test: "read: cannot represent #e+inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e-inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e+nan.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e0/0e20 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e1@1 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: invalid number syntax #e+nan.5 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: invalid sharp-sign prefix #N at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: invalid sharp-sign prefix #7% at line 3, char 31 of testfile.ss".
@ -4130,6 +4165,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat read-test: "read: non-hex back-slash symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: |...| symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: @abc symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: 123a symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
@ -4774,6 +4813,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat load-test: "read: cannot represent #e+inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e-inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e+nan.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e0/0e20 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e1@1 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: invalid number syntax #e+nan.5 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: invalid sharp-sign prefix #N at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: invalid sharp-sign prefix #7% at line 3, char 31 of testfile.ss".
@ -4907,6 +4948,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat load-test: "read: non-hex back-slash symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: |...| symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: @abc symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: 123a symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
@ -5551,6 +5596,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat compile-test: "read: cannot represent #e+inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e-inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e+nan.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e0/0e20 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e1@1 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: invalid number syntax #e+nan.5 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: invalid sharp-sign prefix #N at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: invalid sharp-sign prefix #7% at line 3, char 31 of testfile.ss".
@ -5684,6 +5731,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat compile-test: "read: non-hex back-slash symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: |...| symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: @abc symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: 123a symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".

51
mats/root-experr-compile-2-f-f-f
View File

@ -785,6 +785,39 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
5_3.mo:Expected error in mat r6rs:string->number: "string->number: 36 is not a valid radix".
5_3.mo:Expected error in mat r6rs:string->number: "string->number: a is not a valid radix".
5_3.mo:Expected error in mat r6rs:string->number: "incorrect argument count in call (string->number "a" 10 10)".
5_3.mo:Expected error in mat number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat number->string: "number->string: a is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: 0 is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: -24 is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: <-int> is not a valid precision".
5_3.mo:Expected error in mat number->string: "number->string: a precision is specified and 1 is not inexact".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a number".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: -1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 0 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 1 is not a valid radix".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: 0 is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: -24 is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: <-int> is not a valid precision".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a precision is specified and 1 is not inexact".
5_3.mo:Expected error in mat r6rs:number->string: "number->string: a precision is specified and radix 16 is not 10".
5_3.mo:Expected error in mat exact?: "exact?: a is not a number".
5_3.mo:Expected error in mat inexact?: "inexact?: () is not a number".
5_3.mo:Expected error in mat =: "incorrect argument count in call (=)".
@ -3997,6 +4030,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat read-test: "read: cannot represent #e+inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e-inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e+nan.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e0/0e20 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: cannot represent #e1@1 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: invalid number syntax #e+nan.5 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat read-test: "read: invalid sharp-sign prefix #N at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: invalid sharp-sign prefix #7% at line 3, char 31 of testfile.ss".
@ -4130,6 +4165,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat read-test: "read: non-hex back-slash symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: |...| symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: @abc symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: 123a symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat read-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
@ -4774,6 +4813,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat load-test: "read: cannot represent #e+inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e-inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e+nan.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e0/0e20 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: cannot represent #e1@1 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: invalid number syntax #e+nan.5 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat load-test: "read: invalid sharp-sign prefix #N at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: invalid sharp-sign prefix #7% at line 3, char 31 of testfile.ss".
@ -4907,6 +4948,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat load-test: "read: non-hex back-slash symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: |...| symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: @abc symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: 123a symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat load-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
@ -5551,6 +5596,8 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat compile-test: "read: cannot represent #e+inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e-inf.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e+nan.0 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e0/0e20 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: cannot represent #e1@1 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: invalid number syntax #e+nan.5 at line 3, char 7 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: invalid sharp-sign prefix #N at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: invalid sharp-sign prefix #7% at line 3, char 31 of testfile.ss".
@ -5684,6 +5731,10 @@ cp0.mo:Expected error in mat expand/optimize-output: "expand/optimize-output: #<
6.mo:Expected error in mat compile-test: "read: non-hex back-slash symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: |...| symbol escape syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: @abc symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: 123a symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: 123# number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: 1/2e2 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: #x.3 number syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: U+488 symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: @ symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".
6.mo:Expected error in mat compile-test: "read: @b symbol syntax is not allowed in #!r6rs mode at line 3, char 8 of testfile.ss".

12
s/exceptions.ss
View File

@ -601,8 +601,10 @@ TODO:
(define favcond (condition avcond fcond))
(define fecond (condition econd fcond))
(define fwcond (condition wcond fcond))
(define fimpcond (condition (make-implementation-restriction-violation) fcond))
(define ircond (make-implementation-restriction-violation))
(define fimpcond (condition ircond fcond))
(define flexcond (condition (make-lexical-violation) (make-i/o-read-error) fcond))
(define flexcond/ir (condition ircond (make-lexical-violation) (make-i/o-read-error) fcond))
(define (error-help warning? who whoarg message irritants basecond)
(unless (or (eq? whoarg #f) (string? whoarg) (symbol? whoarg))
@ -704,16 +706,16 @@ TODO:
(set-who! $lexical-error
(case-lambda
[(whoarg msg args port)
[(whoarg msg args port ir?)
(error-help #f who whoarg msg args
(condition
(make-i/o-port-error port)
flexcond))]
[(whoarg msg args port src start?)
(if ir? flexcond/ir flexcond)))]
[(whoarg msg args port src start? ir?)
(error-help #f who whoarg msg args
(condition
(make-i/o-port-error port)
flexcond
(if ir? flexcond/ir flexcond)
($make-src-condition src start?)))]))
(set-who! $source-violation

170
s/read.ss
View File

@ -255,21 +255,21 @@
((fx= i n) new)
(string-set! new i (string-ref old i))))))))
(xdefine (rd-error start? msg . args)
(xdefine (rd-error ir? start? msg . args)
(cond
[(eq? ip (console-input-port)) ($lexical-error who msg args ip)]
[(not fp) ($lexical-error who "~? on ~s" (list msg args ip) ip)]
[sfd ($lexical-error who msg args ip (make-source sfd bfp fp) start?)]
[else ($lexical-error who "~? at char ~a of ~s" (list msg args (if start? bfp fp) ip) ip)]))
[(eq? ip (console-input-port)) ($lexical-error who msg args ip ir?)]
[(not fp) ($lexical-error who "~? on ~s" (list msg args ip) ip ir?)]
[sfd ($lexical-error who msg args ip (make-source sfd bfp fp) start? ir?)]
[else ($lexical-error who "~? at char ~a of ~s" (list msg args (if start? bfp fp) ip) ip ir?)]))
(xdefine (rd-eof-error s)
(xcall rd-error #t "unexpected end-of-file reading ~a" s))
(xcall rd-error #f #t "unexpected end-of-file reading ~a" s))
(xdefine (rd-delimiter-error c what)
(xcall rd-error #t "invalid delimiter ~a for ~a" c what))
(xcall rd-error #f #t "invalid delimiter ~a for ~a" c what))
(xdefine (rd-nonstandard-error s)
(xcall rd-error #t "~a syntax is not allowed in #!r6rs mode" s))
(xcall rd-error #f #t "~a syntax is not allowed in #!r6rs mode" s))
(define-syntax nonstandard
(lambda (x)
@ -280,7 +280,7 @@
(xcall rd-nonstandard-error str)))])))
(xdefine (rd-nonstandard-delimiter-error c)
(xcall rd-error #t "delimiter ~a is not allowed in #!r6rs mode" c))
(xcall rd-error #f #t "delimiter ~a is not allowed in #!r6rs mode" c))
(define-syntax nonstandard-delimiter
(lambda (x)
@ -449,7 +449,7 @@
(state-lambda (n slashed?)
(state-return atomic (maybe-fold/gensym ip tb n slashed?)))))]
[#\| (*state rd-token-block-comment 0)]
[else (xcall rd-error #t "invalid sharp-sign prefix #~c" c)])))
[else (xcall rd-error #f #t "invalid sharp-sign prefix #~c" c)])))
(define-state (rd-token-delimiter x what)
(with-peek-char c
@ -480,7 +480,7 @@
[eof (xcall rd-eof-error "gensym")]
[(#\}) (state-return atomic (maybe-fold/intern ip tb n m slashed1? slashed2?))]
[else (with-unread-char c
(xcall rd-error #f
(xcall rd-error #f #f
"expected close brace terminating gensym syntax"))]))))])))))])))
(define-state (rd-token-block-comment depth)
@ -515,13 +515,13 @@
(nonstandard "#<n>r number prefix")
(with-stretch-buffer i c
(*state rd-token-number (fx+ i 1)))]
[(#\q #\Q) (xcall rd-error #t "outdated object file format")]
[(#\q #\Q) (xcall rd-error #f #t "outdated object file format")]
[#\# (nonstandard "#<n># insert") (*state rd-token-insert n)]
[#\= (nonstandard "#<n>= mark") (*state rd-token-mark n)]
[#\v (*state rd-token-hash-num-v i n)]
[#\%
(unless (memv n '(2 3))
(xcall rd-error #t "invalid sharp-sign prefix ~a~a"
(xcall rd-error #f #t "invalid sharp-sign prefix ~a~a"
(substring tb 0 i)
c))
(nonstandard "#<n>% primitive")
@ -529,7 +529,7 @@
(*state rd-token-symbol c 0 #f
(state-lambda (m slashed?)
(state-return atomic (list '$primitive n (maybe-fold/intern ip tb m slashed?))))))]
[else (xcall rd-error #t "invalid sharp-sign prefix ~a~a"
[else (xcall rd-error #f #t "invalid sharp-sign prefix ~a~a"
(substring tb 0 i)
c)])))
@ -575,9 +575,9 @@
(fx* (digit-value c1 8) 8)
(digit-value c2 8))])
(when (fx> v 255)
(xcall rd-error #t "invalid character #\\~a~a~a" c c1 c2))
(xcall rd-error #f #t "invalid character #\\~a~a~a" c c1 c2))
(xcall rd-token-delimiter (integer->char v) "character"))]
[else (xcall rd-error #t "invalid character #\\~a~a" c c1)])))]
[else (xcall rd-error #f #t "invalid character #\\~a~a" c c1)])))]
[else (xcall rd-token-delimiter c "character")]))]
[else (xcall rd-token-delimiter c "character")])))
@ -585,7 +585,7 @@
(define (int->char n)
(if (and (fixnum? n) (or (fx<= n #xD7FF) (fx<= #xE000 n #x10FFFF)))
(integer->char n)
(xcall rd-error #t "invalid hex character escape ~a" (substring tb 0 i))))
(xcall rd-error #f #t "invalid hex character escape ~a" (substring tb 0 i))))
(with-read-char c
(state-case c
[eof (with-unread-char c (state-return atomic (int->char n)))]
@ -626,7 +626,7 @@
(let-values ([(keys vals) (hashtable-entries char-name-table)])
(apply append (vector->list vals)))))))
(xcall rd-eof-error "character")
(xcall rd-error #t "invalid character name #\\~a" s)))))))
(xcall rd-error #f #t "invalid character name #\\~a" s)))))))
(module (valid-prefix?)
(define string-prefix?
@ -665,7 +665,7 @@
($set-port-flags! ip (constant port-flag-no-fold-case))
(*state rd-token)]
[(chezscheme) ($reset-port-flags! ip (constant port-flag-r6rs)) (*state rd-token)]
[else (xcall rd-error #t "unexpected #!~s" (car a))]))]
[else (xcall rd-error #f #t "unexpected #!~s" (car a))]))]
[else
(with-read-char c
(state-case c
@ -688,7 +688,7 @@
(state-return atomic #!base-rtd)]
[(and (eof-object? c) (valid-prefix? s '("eof" "bwp" "base-rtd")))
(xcall rd-eof-error "#! syntax")]
[else (xcall rd-error #t "invalid syntax #!~a" s)])))))
[else (xcall rd-error #f #t "invalid syntax #!~a" s)])))))
(with-stretch-buffer i c
(*state rd-token-hash-bang2 (fx+ i 1) undelimited*))))]))]))
@ -702,16 +702,16 @@
(with-unread-char c
(if (valid-prefix? s '("fx" "u8"))
(xcall rd-eof-error "#v prefix")
(xcall rd-error #t "invalid syntax #v~a" s)))]
(xcall rd-error #f #t "invalid syntax #v~a" s)))]
[#\( ;)
(cond
[(string=? s "fx") (nonstandard "#vfx(...) fxvector") (state-return vfxparen #f)]
[(string=? s "u8") (state-return vu8paren #f)]
[else (xcall rd-error #t "invalid syntax #v~a(" s)])] ;)
[else (xcall rd-error #f #t "invalid syntax #v~a(" s)])] ;)
[else
(if (valid-prefix? s '("fx" "u8"))
(xcall rd-error #t "expected left paren after #v~a prefix" s)
(xcall rd-error #t "invalid syntax #v~a~a" s c))]))))))
(xcall rd-error #f #t "expected left paren after #v~a prefix" s)
(xcall rd-error #f #t "invalid syntax #v~a~a" s c))]))))))
(define-state (rd-token-hash-num-v preflen nelts)
(with-read-char c
@ -723,16 +723,16 @@
(with-unread-char c
(if (valid-prefix? s '("fx" "u8"))
(xcall rd-eof-error "#v prefix")
(xcall rd-error #t "invalid syntax #~v,'0dv~a" (- preflen 1) nelts s)))]
(xcall rd-error #f #t "invalid syntax #~v,'0dv~a" (- preflen 1) nelts s)))]
[#\( ;)
(cond
[(string=? s "fx") (nonstandard "#<n>vfx(...) fxvector") (state-return vfxnparen nelts)]
[(string=? s "u8") (nonstandard "#<n>vu8(...) bytevector") (state-return vu8nparen nelts)]
[else (xcall rd-error #t "invalid syntax #~v,'0dv~a(" (- preflen 1) nelts s)])] ;)
[else (xcall rd-error #f #t "invalid syntax #~v,'0dv~a(" (- preflen 1) nelts s)])] ;)
[else
(if (valid-prefix? s '("fx" "u8"))
(xcall rd-error #t "expected left paren after #~v,'0dv~a prefix" (- preflen 1) nelts s)
(xcall rd-error #t "invalid syntax #~v,'0dv~a~a" (- preflen 1) nelts s c))]))))))
(xcall rd-error #f #t "expected left paren after #~v,'0dv~a prefix" (- preflen 1) nelts s)
(xcall rd-error #f #t "invalid syntax #~v,'0dv~a~a" (- preflen 1) nelts s c))]))))))
(define-state (rd-token-to-delimiter n c next)
(state-case c
@ -788,23 +788,23 @@
(digit-value c2 8))])
(when (fx> v 255)
(let ([bfp char-bfp])
(xcall rd-error #t "invalid string character \\~c~c~c" c c1 c2)))
(xcall rd-error #f #t "invalid string character \\~c~c~c" c c1 c2)))
(with-stretch-buffer i (integer->char v)
(*state rd-token-string (fx+ i 1))))]
[else
(with-unread-char c2
(let ([bfp char-bfp])
(xcall rd-error #t "invalid string character \\~c~c" c c1)))]))]
(xcall rd-error #f #t "invalid string character \\~c~c" c c1)))]))]
[else
(with-unread-char c1
(let ([bfp char-bfp])
(xcall rd-error #t "invalid string character \\~c" c)))]))]
(xcall rd-error #f #t "invalid string character \\~c" c)))]))]
[(#\')
(nonstandard "\\' string character")
(with-stretch-buffer i c
(*state rd-token-string (fx+ i 1)))]
[else (let ([bfp char-bfp])
(xcall rd-error #t "invalid string character \\~c" c))]))]
(xcall rd-error #f #t "invalid string character \\~c" c))]))]
[(#\newline #\nel #\ls)
(with-stretch-buffer i #\newline
(*state rd-token-string (fx+ i 1)))]
@ -836,7 +836,7 @@
(with-read-char c (*state rd-token-string-skipwhite i))]
[else (*state rd-token-string-skipwhite i)]))]
[intraline-whitespace? (with-read-char c (xcall rd-token-string-whitespace i c))]
[else (xcall rd-error #t "unexpected character ~c after \\<intraline whitespace> in string" c)]))
[else (xcall rd-error #f #t "unexpected character ~c after \\<intraline whitespace> in string" c)]))
(define-state (rd-token-string-skipwhite i)
(with-peek-char c
@ -856,24 +856,20 @@
(with-stretch-buffer i (integer->char n)
(*state rd-token-string (fx+ i 1)))
(let ([bfp char-bfp])
(xcall rd-error #t "invalid code point value ~s in string hex escape" n)))]
(xcall rd-error #f #t "invalid code point value ~s in string hex escape" n)))]
[else
(with-unread-char c1
(let ([bfp char-bfp])
(xcall rd-error #t "invalid character ~c in string hex escape" c1)))])))
(xcall rd-error #f #t "invalid character ~c in string hex escape" c1)))])))
(xdefine (rd-make-number-or-symbol n)
(let ([x ($str->num 'cool tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))])
(let ([z ($str->num tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))])
(cond
[(eq? x 'cool) ($str->num #f tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))]
[(eq? x 'norep) (xcall rd-error #t "cannot represent ~a" (substring tb 0 n))]
[(number? z) z]
[(eq? z 'norep) (xcall rd-error #t #t "cannot represent ~a" (substring tb 0 n))]
[(eq? z '!r6rs) (xcall rd-nonstandard-error (format "~a number" (substring tb 0 n)))]
[else
(nonstandard
(format "~a ~s"
(substring tb 0 n)
(if (eq? ($str->num 'cool tb n 10 #f #f) 'cool)
'number
'symbol)))
(nonstandard (format "~a symbol" (substring tb 0 n)))
(maybe-fold/intern ip tb n #f)])))
(define-state (rd-token-number-or-symbol i)
@ -900,13 +896,13 @@
[else (*state rd-token-symbol c i #f rd-token-intern-nonstandard)])))
(xdefine (rd-make-number n)
(let ([x ($str->num 'cool tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))])
(let ([z ($str->num tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))])
(cond
[(eq? x 'cool) ($str->num #f tb n 10 #f ($port-flags-set? ip (constant port-flag-r6rs)))]
[(and (eq? x #f) (with-peek-char c (eof-object? c)))
(xcall rd-eof-error "number")]
[(eq? x 'norep) (xcall rd-error #t "cannot represent ~a" (substring tb 0 n))]
[else (xcall rd-error #t "invalid number syntax ~a" (substring tb 0 n))])))
[(number? z) z]
[(and (eq? z #f) (with-peek-char c (eof-object? c))) (xcall rd-eof-error "number")]
[(eq? z '!r6rs) (xcall rd-nonstandard-error (format "~a number" (substring tb 0 n)))]
[(eq? z 'norep) (xcall rd-error #t #t "cannot represent ~a" (substring tb 0 n))]
[else (xcall rd-error #f #t "invalid number syntax ~a" (substring tb 0 n))])))
(define-state (rd-token-number i)
(with-read-char c
@ -998,11 +994,11 @@
(with-read-char c
(*state rd-token-symbol c (fx+ i 1) slashed? next)))
(let ([bfp char-bfp])
(xcall rd-error #t "invalid code point value ~s in symbol hex escape" n)))]
(xcall rd-error #f #t "invalid code point value ~s in symbol hex escape" n)))]
[else
(with-unread-char c1
(let ([bfp char-bfp])
(xcall rd-error #t "invalid character ~c in symbol hex escape" c1)))])))
(xcall rd-error #f #t "invalid character ~c in symbol hex escape" c1)))])))
(define-state (rd-token-symbol-bar i next)
(with-read-char c
@ -1054,7 +1050,7 @@
(let loop ([x x])
(unless (insert-seen x)
(let ([bfp (insert-bfp x)] [fp (insert-efp x)])
(xcall rd-error #t "mark #~s= missing" (insert-n x))))
(xcall rd-error #f #t "mark #~s= missing" (insert-n x))))
(let ((z (insert-obj x)))
(if (insert-visited x)
(if (insert? z)
@ -1110,7 +1106,7 @@
(loop rwl '() #f)
(let ([bfp (delayed-record-bfp (car rwl))]
[fp (delayed-record-efp (car rwl))])
(xcall rd-error #t
(xcall rd-error #f #t
"unresolvable cycle constructing record of type ~s"
(delayed-record-rtd (car rwl))))))
(let* ((dr (car wl))
@ -1160,24 +1156,24 @@
[(vu8nparen) (xmvlet ((v) (xcall rd-sized-bytevector value)) (xvalues v v))]
[(box) (xcall rd-box)]
[(fasl)
(xcall rd-error #t
(xcall rd-error #f #t
"unsupported old fasl format detected---use new format with binary i/o")]
[(mark) (xcall rd-mark value)]
[(insert) (xcall rd-insert value)]
[(record-brack) (xcall rd-record)]
[(rparen) (xcall rd-error #t "unexpected close parenthesis")]
[(rbrack) (xcall rd-error #t "unexpected close bracket")]
[(dot) (xcall rd-error #t "unexpected dot (.)")]
[(rparen) (xcall rd-error #f #t "unexpected close parenthesis")]
[(rbrack) (xcall rd-error #f #t "unexpected close bracket")]
[(dot) (xcall rd-error #f #t "unexpected dot (.)")]
; eof should be caught elsewhere, but just in case ...
[(eof) (xcall rd-error #f "unexpected end-of-file")]
[else (xcall rd-error #f "unexpected internal token type ~s" type)]))
[(eof) (xcall rd-error #f #f "unexpected end-of-file")]
[else (xcall rd-error #f #f "unexpected internal token type ~s" type)]))
(xdefine (rd-paren-list)
(let ([expr-bfp bfp])
(with-token (type value)
(case type
[(rparen) (xvalues '() '())]
[(rbrack) (let ([bfp expr-bfp]) (xcall rd-error #f "parenthesized list terminated by bracket"))]
[(rbrack) (let ([bfp expr-bfp]) (xcall rd-error #f #f "parenthesized list terminated by bracket"))]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "list"))]
[else
(xmvlet ((first stripped-first) (xcall rd type value))
@ -1190,22 +1186,22 @@
(with-token (type value)
(case type
[(rparen) (xvalues '() '())]
[(rbrack) (let ([bfp expr-bfp]) (xcall rd-error #f "parenthesized list terminated by bracket"))]
[(rbrack) (let ([bfp expr-bfp]) (xcall rd-error #f #f "parenthesized list terminated by bracket"))]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "list"))]
[(dot)
(with-token (type value)
(case type
[(rparen) (xcall rd-error #f "expected one item after dot (.)")]
[(rparen) (xcall rd-error #f #f "expected one item after dot (.)")]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "list"))]
[else
(xmvlet ((x stripped-x) (xcall rd type value))
(with-token (type value)
(case type
[(rparen) (xvalues x stripped-x)]
[(rbrack) (let ([bfp expr-bfp]) (xcall rd-error #f "parenthesized list terminated by bracket"))]
[(dot) (xcall rd-error #t "unexpected dot")]
[(rbrack) (let ([bfp expr-bfp]) (xcall rd-error #f #f "parenthesized list terminated by bracket"))]
[(dot) (xcall rd-error #f #t "unexpected dot")]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "list"))]
[else (xcall rd-error #t "more than one item found after dot (.)")])))]))]
[else (xcall rd-error #f #t "more than one item found after dot (.)")])))]))]
[else
(xmvlet ((first stripped-first) (xcall rd type value))
(xmvlet ((rest stripped-rest) (xcall rd-paren-tail expr-bfp))
@ -1218,7 +1214,7 @@
(with-token (type value)
(case type
[(rbrack) (xvalues '() '())]
[(rparen) (let ([bfp expr-bfp]) (xcall rd-error #f "bracketed list terminated by parenthesis"))]
[(rparen) (let ([bfp expr-bfp]) (xcall rd-error #f #f "bracketed list terminated by parenthesis"))]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "bracketed list"))]
[else
(xmvlet ((first stripped-first) (xcall rd type value))
@ -1231,22 +1227,22 @@
(with-token (type value)
(case type
[(rbrack) (xvalues '() '())]
[(rparen) (let ([bfp expr-bfp]) (xcall rd-error #f "bracketed list terminated by parenthesis"))]
[(rparen) (let ([bfp expr-bfp]) (xcall rd-error #f #f "bracketed list terminated by parenthesis"))]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "bracketed list"))]
[(dot)
(with-token (type value)
(case type
[(rbrack) (xcall rd-error #f "expected one item after dot (.)")]
[(rbrack) (xcall rd-error #f #f "expected one item after dot (.)")]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "bracketed list"))]
[else
(xmvlet ((x stripped-x) (xcall rd type value))
(with-token (type value)
(case type
[(rbrack) (xvalues x stripped-x)]
[(rparen) (let ([bfp expr-bfp]) (xcall rd-error #f "bracketed list terminated by parenthesis"))]
[(dot) (xcall rd-error #t "unexpected dot")]
[(rparen) (let ([bfp expr-bfp]) (xcall rd-error #f #f "bracketed list terminated by parenthesis"))]
[(dot) (xcall rd-error #f #t "unexpected dot")]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "bracketed list"))]
[else (xcall rd-error #t "more than one item found after dot (.)")])))]))]
[else (xcall rd-error #f #t "more than one item found after dot (.)")])))]))]
[else
(xmvlet ((first stripped-first) (xcall rd type value))
(xmvlet ((rest stripped-rest) (xcall rd-brack-tail expr-bfp))
@ -1272,7 +1268,7 @@
[else
(cond
[(or (not (eq? type 'atomic)) (not (symbol? name)))
(xcall rd-error #t "non-symbol found after #[")] ;]
(xcall rd-error #f #t "non-symbol found after #[")] ;]
[(or (record-reader (symbol->string name))
(let ((x ($sgetprop name '*rtd* #f)))
(and (record-type-descriptor? x)
@ -1306,7 +1302,7 @@
(make-delayed-record rtd vals expr-bfp fp)
(and a? (make-delayed-record rtd stripped-vals expr-bfp fp)))
(loop (cdr fds) (cdr vs)))))))))]
[else (xcall rd-error #t "unrecognized record name ~s" name)])]))))
[else (xcall rd-error #f #t "unrecognized record name ~s" name)])]))))
(xdefine (rd-record-tail expr-bfp n name)
(with-token (type value)
@ -1315,13 +1311,13 @@
(if (= n 0)
(xvalues '() '())
(let ([bfp expr-bfp])
(xcall rd-error #t "too few fields supplied for record ~s" name)))]
(xcall rd-error #f #t "too few fields supplied for record ~s" name)))]
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "record"))]
[else
(xmvlet ((first stripped-first) (xcall rd type value))
(if (= n 0)
(let ([bfp expr-bfp])
(xcall rd-error #t "too many fields supplied for record ~s" name))
(xcall rd-error #f #t "too many fields supplied for record ~s" name))
(xmvlet ((rest stripped-rest) (xcall rd-record-tail expr-bfp (- n 1) name))
(xvalues
(cons first rest)
@ -1342,7 +1338,7 @@
(xdefine (rd-sized-vector n)
(unless (and (fixnum? n) (fxnonnegative? n))
(let ([bfp (and bfp (+ bfp 1))] [fp (and fp (- fp 1))])
(xcall rd-error #t "invalid vector length ~s" n)))
(xcall rd-error #f #t "invalid vector length ~s" n)))
(xcall rd-fill-vector bfp (make-vector n) (and a? (make-vector n)) 0 n))
(xdefine (rd-fill-vector expr-bfp v stripped-v i n)
@ -1365,7 +1361,7 @@
(xmvlet ((x stripped-x) (xcall rd type value))
(unless (fx< i n)
(let ([bfp expr-bfp])
(xcall rd-error #t "too many vector elements supplied")))
(xcall rd-error #f #t "too many vector elements supplied")))
(vector-set! v i x)
(and stripped-v (vector-set! stripped-v i stripped-x))
(xcall rd-fill-vector expr-bfp v stripped-v (fx+ i 1) n))])))
@ -1381,7 +1377,7 @@
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "fxvector"))]
[else
(unless (and (eq? type 'atomic) (fixnum? value))
(xcall rd-error #t "non-fixnum found in fxvector"))
(xcall rd-error #f #t "non-fixnum found in fxvector"))
(xmvlet ((v) (xcall rd-fxvector expr-bfp (fx+ i 1)))
(fxvector-set! v i value)
(xvalues v))])))
@ -1389,7 +1385,7 @@
(xdefine (rd-sized-fxvector n)
(unless (and (fixnum? n) (fxnonnegative? n))
(let ([bfp (and bfp (+ bfp 1))] [fp (and fp (- fp 1))])
(xcall rd-error #t "invalid fxvector length ~s" n)))
(xcall rd-error #f #t "invalid fxvector length ~s" n)))
(xcall rd-fill-fxvector bfp (make-fxvector n) 0 n))
(xdefine (rd-fill-fxvector expr-bfp v i n)
@ -1405,10 +1401,10 @@
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "fxvector"))]
[else
(unless (and (eq? type 'atomic) (fixnum? value))
(xcall rd-error #t "non-fixnum found in fxvector"))
(xcall rd-error #f #t "non-fixnum found in fxvector"))
(unless (fx< i n)
(let ([bfp expr-bfp])
(xcall rd-error #t "too many fxvector elements supplied")))
(xcall rd-error #f #t "too many fxvector elements supplied")))
(fxvector-set! v i value)
(xcall rd-fill-fxvector expr-bfp v (fx+ i 1) n)])))
@ -1423,7 +1419,7 @@
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "bytevector"))]
[else
(unless (and (eq? type 'atomic) (fixnum? value) (fx<= 0 value 255))
(xcall rd-error #t "invalid value ~s found in bytevector" value))
(xcall rd-error #f #t "invalid value ~s found in bytevector" value))
(xmvlet ((v) (xcall rd-bytevector expr-bfp (fx+ i 1)))
(bytevector-u8-set! v i value)
(xvalues v))])))
@ -1431,7 +1427,7 @@
(xdefine (rd-sized-bytevector n)
(unless (and (fixnum? n) (fxnonnegative? n))
(let ([bfp (and bfp (+ bfp 1))] [fp (and fp (- fp 1))])
(xcall rd-error #t "invalid bytevector length ~s" n)))
(xcall rd-error #f #t "invalid bytevector length ~s" n)))
(xcall rd-fill-bytevector bfp (make-bytevector n) 0 n))
(xdefine (rd-fill-bytevector expr-bfp v i n)
@ -1447,10 +1443,10 @@
[(eof) (let ([bfp expr-bfp]) (xcall rd-eof-error "bytevector"))]
[else
(unless (and (eq? type 'atomic) (fixnum? value) (fx<= 0 value 255))
(xcall rd-error #t "invalid value ~s found in bytevector" value))
(xcall rd-error #f #t "invalid value ~s found in bytevector" value))
(unless (fx< i n)
(let ([bfp expr-bfp])
(xcall rd-error #t "too many bytevector elements supplied")))
(xcall rd-error #f #t "too many bytevector elements supplied")))
(bytevector-u8-set! v i value)
(xcall rd-fill-bytevector expr-bfp v (fx+ i 1) n)])))
@ -1468,7 +1464,7 @@
; set up insert(s) if not already present
(unless (cdr a) (set-cdr! a (cons (make-insert n bfp fp) (and a? (make-insert n bfp fp)))))
; check for duplicate marks
(when (insert-seen (cadr a)) (xcall rd-error #t "duplicate mark #~s= seen" n))
(when (insert-seen (cadr a)) (xcall rd-error #f #t "duplicate mark #~s= seen" n))
; mark seen before reading so that error comes from second duplicate
(insert-seen-set! (cadr a) #t)
(when a? (insert-seen-set! (cddr a) #t))

637
s/strnum.ss
View File

@ -14,29 +14,16 @@
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(define $str->num)
(eval-when (compile)
(define-constant max-float-exponent
(float-type-case
[(ieee) 1023]))
(define-constant min-float-exponent
(float-type-case
[(ieee) -1023]))
)
#|
R5RS Section 6.2.4 (Syntax of numerical constants) says
R6RS Section 4.2.8 (Numbers) says:
A numerical constant may be specified to be either exact or inexact
by a prefix. The prefixes are #e for exact, and #i for inexact.
An exactness prefix may appear before or after any radix prefix that
is used. If the written representation of a number has no exactness
prefix, the constant may be either inexact or exact. It is inexact
if it contains a decimal point, an exponent, or a ``#'' character in
the place of a digit, otherwise it is exact.
A representation of a number object may be specified to be either
exact or inexact by a prefix. The prefixes are #e for exact, and #i
for inexact. An exactness prefix may appear before or after any radix
prefix that is used. If the representation of a number object has
no exactness prefix, the constant is inexact if it contains a decimal
point, an exponent, or a nonempty mantissa width; otherwise it is exact.
This specifies the exactness of the result. It doesn't specify precisely
the number produced when there is a mix of exact and inexact subparts
@ -47,7 +34,7 @@ Possible options include:
(A) Treat each subpart as inexact if the #i prefix is specified or the
#e prefix is not specified and any subpart is inexact, i.e.,
contains a decimal point, exponent, or # character. Treat each
contains a decimal point, exponent, or mantissa width. Treat each
subpart as exact if the #e prefix is specified or if the #i prefix
is not specified and each subpart is exact.
@ -58,58 +45,30 @@ Possible options include:
(C) If #e and #i are not present, treat each subpart as exact or inexact
in isolation and use the usual rules for preserving inexactness when
combining the subparts. If #e is present, treat each subpart as
exact, with # digits treated as zeros. If #i is present, treat each
subpart as inexact.
combining the subparts. If #e is present, treat each subpart
as exact. If #i is present, treat each subpart as inexact.
Also, the R5RS description of string->number says:
Also, the R6RS description of string->number says:
Returns a number of the maximally precise representation expressed
by the given string. Radix must be an exact integer, either 2,
8, 10, or 16. If supplied, radix is a default radix that may be
overridden by an explicit radix prefix in string (e.g. "#o177").
If radix is not supplied, then the default radix is 10. If string is
not a syntactically valid notation for a number, then string->number
returns #f.
If string is not a syntactically valid notation for a number object
or a notation for a rational number object with a zero denominator,
then string->number returns #f.
This raises an additional question, which is whether string->number
should signal an error or return #f whenever a "syntactically valid"
number (or subpart thereof, with option B), such as 1/0 or #e1/0#
(or 1/0+1.0i) cannot be represented.
We take "zero denomintor" here to mean "exact zero denominator", and
treat, e.g., #i1/0, as +inf.0.
A B C
0/0 #f #f #f
0/0# nan 0 0
0#/0 nan #f #f
0#/0# nan nan nan
#i0/0 nan #f nan
#i0/0# nan 0.0 nan
#i0#/0 nan #f nan
#i0#/0# nan nan nan
#e0/0 #f #f #f
#e0/0# #f 0 #f
#e0#/0 #f #f #f
#e0#/0# #f #f #f
1/0 #f #f #f
1/0# inf inf inf
1#/0 inf #f #f
1#/0# inf inf inf
#i1/0 inf #f inf
#i1/0# inf inf inf
#i1#/0 inf #f inf
#i1#/0# inf inf inf
#e1/0 #f #f #f
#e1/0# #f #f #f
#e1#/0 #f #f #f
#e1#/0# #f #f #f
#i1/0 +inf.0 #f +inf.0
1/0+1.0i +nan.0+1.0i #f #f
1.0+1/0i 1.0+nan.0i #f #f
#e1e1000 (expt 10 1000) #f (expt 10 1000)
#e1#e1000 (expt 10 1001) #f (expt 10 1001)
This code implements Option C and returns #f instead of signaling an
error whenever a syntactically valid number cannot be represented.
@ -121,9 +80,23 @@ Rationale for Option C: B and C adhere most closely to the semantics of
the individual / and make-rectangular operators, and neither requires that
we scan the entire number first (as with A) to determine the (in)exactness
of the result. C takes into account the known (in)exactness of the
result to represent some useful values that B cannot, such as #e1e1000.
|#
result to represent some useful values that B cannot, such as #i1/0 and
#e1e1000.
R6RS doesn't say is what string->number should return for syntactically
valid numbers (other than exact numbers with a zero denominator) for
which the implementation has no representation, such as exact 1@1 in
an implementation that represents complex numbers in rectangular form.
Options include returning an approximation represented as an inexact
number (so that the result, which should be exact, isn't exact),
returning an approximation represented as an exact number (so that the
approximation misleadingly represents itself as exact), or to admit an
implementation restriction. We choose the to return an inexact result
for 1@1 (extending the set of situations where numeric constants are
implicitly inexact) and treat #e1@1 as an implementation restriction,
with string->number returning #f and the reader raising an exception
with condition type &implementation-restriction.
|#
(let ()
;; (mknum-state <state name>
@ -133,85 +106,93 @@ result to represent some useful values that B cannot, such as #e1e1000.
(define-syntax mknum-state
(lambda (e)
(syntax-case e ()
((_key name (id ...) exp clause ...)
(with-implicit (_key z x k i r6rs? c d)
[(_key name (id ...) efinal clause ...)
(with-implicit (_key str k i r6rs? !r6rs x1 c d)
(let ()
(define mknum-state-test
(lambda (key)
(syntax-case key (-)
(char
(char? (datum char))
#'(char=? c char))
((char1 - char2)
#'(char<=? char1 c char2))
((key ...)
`(,#'or ,@(map mknum-state-test #'(key ...)))))))
[char
(char? (datum char))
#'(char=? c char)]
[(char1 - char2)
#'(char<=? char1 c char2)]
[(key ...)
`(,#'or ,@(map mknum-state-test #'(key ...)))])))
(define mknum-call
(lambda (incr? call)
(syntax-case call (let)
[(let ([x e] ...) call)
(with-syntax ([call (mknum-call incr? #'call)])
#'(let ([x e] ...) call))]
[(x1 x2 ...)
[(e1 e2 ...)
(if incr?
#'(x1 z x k (fx+ i 1) r6rs? x2 ...)
#'(x1 z x k i r6rs? x2 ...))])))
#'(e1 str k (fx+ i 1) r6rs? !r6rs x1 e2 ...)
#'(e1 str k i r6rs? !r6rs x1 e2 ...))])))
(define mknum-state-help
(lambda (ls)
(syntax-case ls (else)
(() #''bogus)
(((else call)) (mknum-call #f #'call))
(stuff
(with-syntax ((rest (mknum-state-help (cdr ls))))
(syntax-case (car ls) (digit)
(((digit r) call)
(with-syntax ([call (mknum-call #t #'call)])
#'(let ((d (ascii-digit-value c r)))
(if d call rest))))
(((digit r) fender call)
(with-syntax ([call (mknum-call #t #'call)])
#'(let ((d (ascii-digit-value c r)))
(if (and d fender) call rest))))
((key call)
(with-syntax ([test (mknum-state-test #'key)]
[call (mknum-call #t #'call)])
#'(if test call rest)))
((key fender call)
(with-syntax ([test (mknum-state-test #'key)]
[call (mknum-call #t #'call)])
#'(if (and test fender) call rest)))))))))
(with-syntax ((rest (mknum-state-help #'(clause ...))))
[() #''bogus]
[((else call)) (mknum-call #f #'call)]
[_ (with-syntax ((rest (mknum-state-help (cdr ls))))
(syntax-case (car ls) (digit)
[((digit r) call)
(with-syntax ([call (mknum-call #t #'call)])
#'(let ((d (ascii-digit-value c r)))
(if d call rest)))]
[((digit r) fender call)
(with-syntax ([call (mknum-call #t #'call)])
#'(let ((d (ascii-digit-value c r)))
(if (and d fender) call rest)))]
[(key call)
(with-syntax ([test (mknum-state-test #'key)]
[call (mknum-call #t #'call)])
#'(if test call rest))]
[(key fender call)
(with-syntax ([test (mknum-state-test #'key)]
[call (mknum-call #t #'call)])
#'(if (and test fender) call rest))]))])))
(with-syntax ([rest (mknum-state-help #'(clause ...))]
[efinal (syntax-case #'efinal ()
[#f #'efinal]
[_ #'(if (and r6rs? !r6rs) '!r6rs efinal)])])
#'(define name
(lambda (z x k i r6rs? id ...)
(lambda (str k i r6rs? !r6rs x1 id ...)
(if (= i k)
exp
(let ([c (char-downcase (string-ref x i))])
rest)))))))))))
efinal
(let ([c (char-downcase (string-ref str i))])
rest)))))))])))
(define ascii-digit-value
(lambda (c r)
(let ([v (cond
[(char<=? #\0 c #\9) (char- c #\0)]
[(char<=? #\a c #\z) (char- c #\W)]
[else 36])])
(and (fx< v r) v))))
(lambda (c r)
(let ([v (cond
[(char<=? #\0 c #\9) (char- c #\0)]
[(char<=? #\a c #\z) (char- c #\W)]
[else 36])])
(and (fx< v r) v))))
; variables automatically maintained and passed by the mknum macro:
; z: if #f, return number or #f else return z or #f
; x: string
; str: string
; k: string length
; i: index into string, 0 <= i < k
; r6rs?: if #t, reject non-r6rs features
; r6rs?: if #t, return !r6rs for well-formed non-r6rs features
; !r6rs: if #t, seen non-r6rs feature
; x1: first part of complex number when ms = imag or angle: number, thunk, or norep
; variables automatically created by the mknum macro:
; c: holds current character
; d: holds digit value of c in a digit clause
; other "interesting" variables:
; r: radix, 0 < r < 37
; ex: exactness: 'i, 'e, or #f (from prefix)
; e: strict exactness: 'i or 'e
; r: radix, 2 <= r <= 36 (can be outside this range while constructing #<r>r prefix)
; ex: exactness: 'i, 'e, or #f
; s: function to add sign to number
; ms: meta-state: ureal, real, real@
; n,m: number or z
; ms: meta-state: real, imag, angle
; n: exact integer
; m: exact or inexact integer
; w: exact or inexact integer or norep
; x: number, thunk, or norep
; e: exact integer exponent
; i?: #t if number should be made inexact
; invariant: (thunk) != exact 0.
; The sign of the mantissa cannot be put on until a number has
; been made inexact (if necessary) to make sure zero gets the right sign.
@ -221,277 +202,284 @@ result to represent some useful values that B cannot, such as #e1e1000.
(define plus (lambda (x) x))
(define minus -)
(define-record-type state
(fields (immutable type) (immutable part))
(nongenerative)
(sealed #t))
(define make-part
(lambda (i? s n)
(s (if i? (inexact n) n))))
(define make-part ; never turns inexact number exact
(case-lambda
[(e s m) (s (if (eq? e 'i) (inexact m) m))]
[(e s m r n)
(define make-part/exponent
(lambda (i? s w r e)
; get out quick for really large/small exponents, like 1e1000000000
; no need for great precision here; using 2x the min/max base two
; exponent, which should be conservative for all bases. 1x should
; actually work for positive n, but for negative n we need something
; actually work for positive n, but for negative e we need something
; smaller than 1x to allow denormalized numbers.
; s must be the actual sign of the result, with m >= 0
(s (if (eq? e 'i)
(if (or (> n (* (constant max-float-exponent) 2))
(< n (* (constant min-float-exponent) 2)))
(if (< n 0) 0.0 +inf.0)
(inexact (* m (expt r n))))
(* m (expt r n))))]))
; s must be the actual sign of the result, with w >= 0
(define max-float-exponent
(float-type-case
[(ieee) 1023]))
(define min-float-exponent
(float-type-case
[(ieee) -1023]))
(cond
[(eq? w 'norep) 'norep]
[i? (s (if (eqv? w 0)
0.0
(if (<= (* min-float-exponent 2) e (* max-float-exponent 2))
(inexact (* w (expt r e)))
(if (< e 0) 0.0 +inf.0))))]
[(eqv? w 0) 0]
[else (lambda () (s (* w (expt r e))))])))
(define (thaw x) (if (procedure? x) (x) x))
(define finish-number
(lambda (z ms n)
(if (or (eq? ms 'ureal) (eq? ms 'real))
(or z n)
(and (eq? (state-type ms) 'real@)
(or z (make-polar (state-part ms) n))))))
(lambda (ms ex x1 x)
(case ms
[(real ureal) (if (procedure? x) (x) x)]
[(angle)
(cond
[(or (eq? x1 'norep) (eq? x 'norep)) 'norep]
[(eqv? x1 0) 0]
[(eqv? x 0) (thaw x1)]
[(eq? ex 'e) 'norep]
[else (make-polar (thaw x1) (thaw x))])]
[else #f])))
(define finish-rectangular-number
(lambda (z ms n)
(if (or (eq? ms 'ureal) (eq? ms 'real))
(or z (make-rectangular 0 n))
(and (eq? (state-type ms) 'real)
(or z (make-rectangular (state-part ms) n))))))
(lambda (ms x1 x)
(case ms
[(real ureal)
(if (eq? x 'norep)
'norep
(make-rectangular 0 (thaw x)))]
[(imag)
(if (or (eq? x1 'norep) (eq? x 'norep))
'norep
(make-rectangular (thaw x1) (thaw x)))]
[else #f])))
(mknum-state prefix0 (r ex) ; start state
#f
[#\# (prefix1 r ex)]
[else (num0 r ex)])
#f
[#\# (prefix1 r ex)]
[else (num0 r ex)])
(mknum-state prefix1 (r ex) ; saw leading #
#f
[(digit 10) (not r6rs?) (prefix2 d ex)]
[#\e (prefix3 r 'e)]
[#\i (prefix3 r 'i)]
[#\b (prefix6 2 ex)]
[#\o (prefix6 8 ex)]
[#\d (prefix6 10 ex)]
[#\x (prefix6 16 ex)])
#f
[(digit 10) (let ([!r6rs #t]) (prefix2 d ex))]
[#\e (prefix3 r 'e)]
[#\i (prefix3 r 'i)]
[#\b (prefix6 2 ex)]
[#\o (prefix6 8 ex)]
[#\d (prefix6 10 ex)]
[#\x (prefix6 16 ex)])
(mknum-state prefix2 (r ex) ; saw digit after #
#f
[(digit 10) (fx< r 37) (prefix2 (+ (* r 10) d) ex)]
[#\r (fx< 1 r 37) (prefix6 r ex)])
#f
[(digit 10) (fx< r 37) (prefix2 (+ (* r 10) d) ex)]
[#\r (fx< 1 r 37) (prefix6 r ex)])
(mknum-state prefix3 (r ex) ; saw exactness prefix
#f
[#\# (prefix4 ex)]
[else (num0 r ex)])
#f
[#\# (prefix4 ex)]
[else (num0 r ex)])
(mknum-state prefix4 (ex) ; saw # after exactness
#f
[(digit 10) (not r6rs?) (prefix5 d ex)]
[#\b (num0 2 ex)]
[#\o (num0 8 ex)]
[#\d (num0 10 ex)]
[#\x (num0 16 ex)])
#f
[(digit 10) (let ([!r6rs #t]) (prefix5 d ex))]
[#\b (num0 2 ex)]
[#\o (num0 8 ex)]
[#\d (num0 10 ex)]
[#\x (num0 16 ex)])
(mknum-state prefix5 (r ex) ; saw # digit after exactness
#f
[(digit 10) (fx< r 37) (prefix5 (+ (* r 10) d) ex)]
[#\r (fx< 1 r 37) (num0 r ex)])
#f
[(digit 10) (fx< r 37) (prefix5 (+ (* r 10) d) ex)]
[#\r (fx< 1 r 37) (num0 r ex)])
(mknum-state prefix6 (r ex) ; saw radix prefix
#f
[#\# (prefix7 r)]
[else (num0 r ex)])
#f
[#\# (prefix7 r)]
[else (num0 r ex)])
(mknum-state prefix7 (r) ; saw # after radix
#f
[#\e (num0 r 'e)]
[#\i (num0 r 'i)])
#f
[#\e (num0 r 'e)]
[#\i (num0 r 'i)])
(mknum-state num0 (r ex) ; saw prefix, if any
#f
[(digit r) (num2 'ureal r ex plus d)]
[#\. (or (not r6rs?) (fx= r 10)) (float0 'ureal r ex plus)]
[#\+ (num1 'real r ex plus)]
[#\- (num1 'real r ex minus)])
#f
[(digit r) (num2 r ex 'ureal plus d)]
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float0 r ex 'ureal plus))]
[#\+ (num1 r ex 'real plus)]
[#\- (num1 r ex 'real minus)])
(mknum-state num1 (ms r ex s) ; saw sign
#f
[(digit r) (num2 ms r ex s d)]
[#\. (or (not r6rs?) (fx= r 10)) (float0 ms r ex s)]
[#\i (num3 ms r ex s)]
[#\n (let ([z (if (eq? ex 'e) 'norep z)]) (nan0 ms r ex s))])
(mknum-state num1 (r ex ms s) ; saw sign
#f
[(digit r) (num2 r ex ms s d)]
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float0 r ex ms s))]
[#\i (num3 r ex ms s)]
[#\n (nan0 r ex ms s)])
(mknum-state num2 (ms r ex s n) ; saw digit
(finish-number z ms (or z (make-part (or ex 'e) s n)))
[(digit r) (num2 ms r ex s (or z (+ (* n r) d)))]
[#\/ (rat0 ms r ex s (or z (make-part (or ex 'e) plus n)))]
[#\| (mwidth0 ms r ex (or z (make-part (or ex 'i) s n)))]
[#\. (or (not r6rs?) (fx= r 10)) (float1 ms r ex s n (fx+ i 1) 0)]
[#\# (not r6rs?) (numhash ms r ex s (or z (* n r)))]
[(#\e #\s #\f #\d #\l) (or (not r6rs?) (fx= r 10)) (exp0 ms r ex s n)]
[else (complex0 ms r ex (or z (make-part (or ex 'e) s n)))])
(mknum-state num2 (r ex ms s n) ; saw digit
(finish-number ms ex x1 (make-part (eq? ex 'i) s n))
[(digit r) (num2 r ex ms s (+ (* n r) d))]
[#\/ (rat0 r ex ms s (make-part (eq? ex 'i) plus n))]
[#\| (mwidth0 r ex ms (make-part (not (eq? ex 'e)) s n))]
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float1 r ex ms s n (fx+ i 1) 0))]
[#\# (let ([!r6rs #t]) (numhash r ex ms s (* n r)))]
[(#\e #\s #\f #\d #\l) (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (exp0 r ex ms s n))]
[else (complex0 r ex ms (make-part (eq? ex 'i) s n))])
(mknum-state num3 (ms r ex s) ; saw "i" after sign
(finish-rectangular-number z ms (or z (make-part (or ex 'e) s 1)))
[#\n (let ([z (if (eq? ex 'e) 'norep z)]) (inf0 ms r ex s))])
(mknum-state num3 (r ex ms s) ; saw "i" after sign
(finish-rectangular-number ms x1 (make-part (eq? ex 'i) s 1))
[#\n (inf0 r ex ms s)])
(mknum-state inf0 (ms r ex s) ; saw "in" after sign
#f
[#\f (inf1 ms r ex s)])
(mknum-state inf0 (r ex ms s) ; saw "in" after sign
#f
[#\f (inf1 r ex ms s)])
(mknum-state inf1 (ms r ex s) ; saw "inf" after sign
#f
[#\. (inf2 ms r ex s)])
(mknum-state inf1 (r ex ms s) ; saw "inf" after sign
#f
[#\. (inf2 r ex ms s)])
(mknum-state inf2 (ms r ex s) ; saw "inf." after sign
#f
[#\0 (inf3 ms r ex s)])
(mknum-state inf2 (r ex ms s) ; saw "inf." after sign
#f
[#\0 (inf3 r ex ms s)])
(mknum-state inf3 (ms r ex s) ; saw "inf.0" after sign
(finish-number z ms (or z (s +inf.0)))
[else (complex0 ms r ex (or z (s +inf.0)))])
(mknum-state inf3 (r ex ms s) ; saw "inf.0" after sign
(finish-number ms ex x1 (if (eq? ex 'e) 'norep (s +inf.0)))
[else (complex0 r ex ms (if (eq? ex 'e) 'norep (s +inf.0)))])
(mknum-state nan0 (ms r ex s) ; saw "n" after sign
#f
[#\a (nan1 ms r ex s)])
(mknum-state nan0 (r ex ms s) ; saw "n" after sign
#f
[#\a (nan1 r ex ms s)])
(mknum-state nan1 (ms r ex s) ; saw "na" after sign
#f
[#\n (nan2 ms r ex s)])
(mknum-state nan1 (r ex ms s) ; saw "na" after sign
#f
[#\n (nan2 r ex ms s)])
(mknum-state nan2 (ms r ex s) ; saw "nan" after sign
#f
[#\. (nan3 ms r ex s)])
(mknum-state nan2 (r ex ms s) ; saw "nan" after sign
#f
[#\. (nan3 r ex ms s)])
(mknum-state nan3 (ms r ex s) ; saw "nan." after sign
#f
[#\0 (nan4 ms r ex s)])
(mknum-state nan3 (r ex ms s) ; saw "nan." after sign
#f
[#\0 (nan4 r ex ms s)])
(mknum-state nan4 (ms r ex s) ; saw "nan.0" after sign
(finish-number z ms +nan.0)
[else (complex0 ms r ex +nan.0)])
(mknum-state nan4 (r ex ms s) ; saw "nan.0" after sign
(finish-number ms ex x1 (if (eq? ex 'e) 'norep +nan.0))
[else (complex0 r ex ms +nan.0)])
(mknum-state numhash (ms r ex s n) ; saw # after integer
(finish-number z ms (or z (make-part (or ex 'i) s n)))
[#\/ (rat0 ms r ex s (or z (make-part (or ex 'i) plus n)))]
[#\. (floathash ms r ex s n (fx+ i 1) 0)]
[#\# (numhash ms r ex s (or z (* n r)))]
[(#\e #\s #\f #\d #\l) (exp0 ms r ex s n)]
[else (complex0 ms r ex (or z (make-part (or ex 'i) s n)))])
(mknum-state numhash (r ex ms s n) ; saw # after integer
(finish-number ms ex x1 (make-part (not (eq? ex 'e)) s n))
[#\/ (rat0 r ex ms s (make-part (not (eq? ex 'e)) plus n))]
[#\. (floathash r ex ms s n (fx+ i 1) 0)]
[#\# (numhash r ex ms s (* n r))]
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s n)]
[else (complex0 r ex ms (make-part (not (eq? ex 'e)) s n))])
; can't embed sign in m since we might end up in exp0 and then on
; to make-part, which counts on sign being separate
(mknum-state rat0 (ms r ex s m) ; saw slash
#f
[#\0 (not (eq? ex 'i))
(rat1a ms r ex s m)]
[(digit r) (rat1 ms r ex s m d)])
(mknum-state rat0 (r ex ms s m) ; saw slash
#f
[(digit r) (rat1 r ex ms s m d)])
(mknum-state rat1a (ms r ex s m) ; exact zero denominator so far
'norep
[#\0 (not (eq? ex 'i))
(rat1a ms r ex s m)]
[(digit r) (rat1 ms r ex s m d)]
[#\# (not r6rs?) (let ([z (if (eq? ex 'e) 'norep z)]) (rathash ms r ex s m 0))]
[(#\e #\s #\f #\d #\l) (or (not r6rs?) (fx= r 10)) (let ([z 'norep]) (exp0 ms r ex s z))]
[else (let ([z 'norep]) (complex0 ms r ex z))])
(define (mkrat p q) (if (eqv? q 0) 'norep (/ p q)))
(mknum-state rat1 (ms r ex s m n) ; saw denominator digit
(finish-number z ms (or z (/ m (make-part (or ex 'e) s n))))
[(digit r) (rat1 ms r ex s m (or z (+ (* n r) d)))]
[#\# (not r6rs?) (rathash ms r ex s m (or z (* n r)))]
[(#\e #\s #\f #\d #\l) (or (not r6rs?) (fx= r 10)) (exp0 ms r ex s (or z (/ m (make-part (or ex 'e) plus n))))]
[else (complex0 ms r ex (or z (/ m (make-part (or ex 'e) s n))))])
(mknum-state rat1 (r ex ms s m n) ; saw denominator digit
(finish-number ms ex x1 (mkrat m (make-part (eq? ex 'i) s n)))
[(digit r) (rat1 r ex ms s m (+ (* n r) d))]
[#\# (let ([!r6rs #t]) (rathash r ex ms s m (* n r)))]
[(#\e #\s #\f #\d #\l) (let ([!r6rs #t]) (exp0 r ex ms s (mkrat m (make-part (not (eq? ex 'e)) plus n))))]
[else (complex0 r ex ms (mkrat m (make-part (eq? ex 'i) s n)))])
(mknum-state rathash (ms r ex s m n) ; saw # after denominator
(finish-number z ms (or z (/ m (make-part (or ex 'i) s n))))
[#\# (rathash ms r ex s m (or z (* n r)))]
[(#\e #\s #\f #\d #\l) (exp0 ms r ex s (or z (/ m (make-part (or ex 'i) plus n))))]
[else (complex0 ms r ex (or z (/ m (make-part (or ex 'i) s n))))])
(mknum-state rathash (r ex ms s m n) ; saw # after denominator
(finish-number ms ex x1 (mkrat m (make-part (not (eq? ex 'e)) s n)))
[#\# (rathash r ex ms s m (* n r))]
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s (mkrat m (make-part (not (eq? ex 'e)) plus n)))]
[else (complex0 r ex ms (mkrat m (make-part (not (eq? ex 'e)) s n)))])
(mknum-state float0 (ms r ex s) ; saw leading decimal point
#f
[(digit r) (float1 ms r ex s 0 i d)])
(mknum-state float0 (r ex ms s) ; saw leading decimal point
#f
[(digit r) (float1 r ex ms s 0 i d)])
(mknum-state float1 (ms r ex s m j n) ; saw fraction digit at j
(finish-number z ms (or z (make-part (or ex 'i) s (+ m (* n (expt r (- j i)))))))
[(digit r) (float1 ms r ex s m j (or z (+ (* n r) d)))]
[#\| (mwidth0 ms r ex (or z (make-part (or ex 'i) s (+ m (* n (expt r (- j i)))))))]
[#\# (not r6rs?) (floathash ms r ex s m j (or z (* n r)))]
[(#\e #\s #\f #\d #\l) (exp0 ms r ex s (or z (+ m (* n (expt r (- j i))))))]
[else (complex0 ms r ex (or z (make-part (or ex 'i) s (+ m (* n (expt r (- j i)))))))])
(mknum-state float1 (r ex ms s m j n) ; saw fraction digit at j
(finish-number ms ex x1 (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))
[(digit r) (float1 r ex ms s m j (+ (* n r) d))]
[#\| (mwidth0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))]
[#\# (let ([!r6rs #t]) (floathash r ex ms s m j (* n r)))]
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s (+ m (* n (expt r (- j i)))))]
[else (complex0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))])
(mknum-state floathash (ms r ex s m j n) ; seen hash(es), now in fraction
(finish-number z ms (or z (make-part (or ex 'i) s (+ m (* n (expt r (- j i)))))))
[#\# (floathash ms r ex s m j (or z (* n r)))]
[(#\e #\s #\f #\d #\l) (exp0 ms r ex s (or z (+ m (* n (expt r (- j i))))))]
[else (complex0 ms r ex (or z (make-part (or ex 'i) s (+ m (* n (expt r (- j i)))))))])
(mknum-state floathash (r ex ms s m j n) ; seen hash(es), now in fraction
(finish-number ms ex x1 (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))
[#\# (floathash r ex ms s m j (* n r))]
[(#\e #\s #\f #\d #\l) (exp0 r ex ms s (+ m (* n (expt r (- j i)))))]
[else (complex0 r ex ms (make-part (not (eq? ex 'e)) s (+ m (* n (expt r (- j i))))))])
(mknum-state exp0 (ms r ex s m) ; saw exponent flag
#f
[(digit r) (exp2 ms r ex s m plus d)]
[#\+ (exp1 ms r ex s m plus)]
[#\- (exp1 ms r ex s m minus)])
(mknum-state exp0 (r ex ms s w) ; saw exponent flag
#f
[(digit r) (exp2 r ex ms s w plus d)]
[#\+ (exp1 r ex ms s w plus)]
[#\- (exp1 r ex ms s w minus)])
(mknum-state exp1 (ms r ex sm m s) ; saw exponent sign
#f
[(digit r) (exp2 ms r ex sm m s d)])
(mknum-state exp1 (r ex ms sm w s) ; saw exponent sign
#f
[(digit r) (exp2 r ex ms sm w s d)])
(mknum-state exp2 (ms r ex sm m s n) ; saw exponent digit
(finish-number z ms (or z (make-part (or ex 'i) sm m r (s n))))
[(digit r) (exp2 ms r ex sm m s (or z (+ (* n r) d)))]
[#\| (mwidth0 ms r ex (or z (make-part (or ex 'i) sm m r (s n))))]
[else (complex0 ms r ex (or z (make-part (or ex 'i) sm m r (s n))))])
(mknum-state exp2 (r ex ms sm w s e) ; saw exponent digit(s)
(finish-number ms ex x1 (make-part/exponent (not (eq? ex 'e)) sm w r (s e)))
[(digit r) (exp2 r ex ms sm w s (+ (* e r) d))]
[#\| (mwidth0 r ex ms (make-part/exponent (not (eq? ex 'e)) sm w r (s e)))]
[else (complex0 r ex ms (make-part/exponent (not (eq? ex 'e)) sm w r (s e)))])
(mknum-state mwidth0 (ms r ex n) ; saw vertical bar
#f
[(digit 10) (mwidth1 ms r ex n)])
(mknum-state mwidth0 (r ex ms x) ; saw vertical bar
#f
[(digit 10) (mwidth1 r ex ms x)])
(mknum-state mwidth1 (ms r ex n) ; saw digit after vertical bar
(finish-number z ms n)
[(digit 10) (mwidth1 ms r ex n)]
[else (complex0 ms r ex n)])
(mknum-state mwidth1 (r ex ms x) ; saw digit after vertical bar
(finish-number ms ex x1 x)
[(digit 10) (mwidth1 r ex ms x)]
[else (complex0 r ex ms x)])
(mknum-state complex0 (ms r ex n)
#f
[#\@ (or (eq? ms 'real) (eq? ms 'ureal))
(complex1 (make-state 'real@ n) r ex)]
[#\+ (or (eq? ms 'real) (eq? ms 'ureal))
(num1 (make-state 'real n) r ex plus)]
[#\- (or (eq? ms 'real) (eq? ms 'ureal))
(num1 (make-state 'real n) r ex minus)]
[#\i (or (eq? ms 'real) (and (state? ms) (eq? (state-type ms) 'real)))
(complex2 ms n)])
(mknum-state complex0 (r ex ms x) ; saw end of real part before end of string
(assert #f) ; should arrive here only from else clauses, thus not at the end of the string
[#\@ (memq ms '(real ureal)) (let ([x1 x]) (complex1 r ex 'angle))]
[#\+ (memq ms '(real ureal)) (let ([x1 x]) (num1 r ex 'imag plus))]
[#\- (memq ms '(real ureal)) (let ([x1 x]) (num1 r ex 'imag minus))]
[#\i (memq ms '(real imag)) (complex2 ms x)])
(mknum-state complex1 (ms r ex) ; like num0 but knows ms already
#f
[(digit r) (num2 ms r ex plus d)]
[#\. (float0 ms r ex plus)]
[#\+ (num1 ms r ex plus)]
[#\- (num1 ms r ex minus)])
(mknum-state complex1 (r ex ms) ; seen @. like num0 but knows ms already
#f
[(digit r) (num2 r ex ms plus d)]
[#\. (let ([!r6rs (or !r6rs (not (fx= r 10)))]) (float0 r ex ms plus))]
[#\+ (num1 r ex ms plus)]
[#\- (num1 r ex ms minus)])
(mknum-state complex2 (ms n)
(finish-rectangular-number z ms n))
(mknum-state complex2 (ms x) ; saw i after real or imag
(finish-rectangular-number ms x1 x))
; str->num returns
; (or z <number>) valid number
; norep syntactically valid but cannot represent
; #f valid prefix (eof/end-of-string)
; bogus invalid prefix
; <number> syntactically valid, representable number
; !r6rs syntactically valid non-r6rs syntax in #!r6rs mode
; norep syntactically valid but cannot represent
; #f syntactically valid prefix (eof/end-of-string)
; bogus syntactically invalid prefix
(set! $str->num
(lambda (z x k r ex r6rs?)
(prefix0 z x k 0 r6rs? r ex)))
(lambda (str k r ex r6rs?)
(prefix0 str k 0 r6rs? #f #f r ex)))
)) ; let
(define string->number
(case-lambda
[(x) (string->number x 10)]
[(x r)
(unless (string? x)
($oops 'string->number "~s is not a string" x))
(unless (and (fixnum? r) (fx< 1 r 37))
($oops 'string->number "~s is not a valid radix" r))
(and (eq? ($str->num 'cool x (string-length x) r #f #f) 'cool)
($str->num #f x (string-length x) r #f #f))]))
(case-lambda
[(x) (string->number x 10)]
[(x r)
(unless (string? x)
($oops 'string->number "~s is not a string" x))
(unless (and (fixnum? r) (fx< 1 r 37))
($oops 'string->number "~s is not a valid radix" r))
(let ([z ($str->num x (string-length x) r #f #f)])
(and (number? z) z))]))
(define-who #(r6rs: string->number)
(case-lambda
@ -499,8 +487,8 @@ result to represent some useful values that B cannot, such as #e1e1000.
[(x r)
(unless (string? x) ($oops who "~s is not a string" x))
(unless (memq r '(2 8 10 16)) ($oops who "~s is not a valid radix" r))
(and (eq? ($str->num 'cool x (string-length x) r #f #t) 'cool)
($str->num #f x (string-length x) r #f #t))]))
(let ([z ($str->num x (string-length x) r #f #t)])
(and (number? z) z))]))
(define-who number->string
(case-lambda
@ -513,6 +501,9 @@ result to represent some useful values that B cannot, such as #e1e1000.
($oops who "~s is not a valid radix" r))
(parameterize ([print-radix r]) (format "~a" x))]
[(x r m)
(unless (number? x) ($oops who "~s is not a number" x))
(unless (and (fixnum? r) (fx< 1 r 37))
($oops who "~s is not a valid radix" r))
(unless (or (and (fixnum? m) (fx> m 0))
(and (bignum? m) (> m 0)))
($oops who "~s is not a valid precision" m))
@ -532,7 +523,7 @@ result to represent some useful values that B cannot, such as #e1e1000.
(parameterize ([print-radix r]) (format "~a" x))]
[(x r m)
(unless (number? x) ($oops who "~s is not a number" x))
(unless (eq? r 10)
(unless (eqv? r 10)
(if (memq r '(2 8 16))
($oops who "a precision is specified and radix ~s is not 10" r)
($oops who "~s is not a valid radix" r)))