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

library-manager, numeric, and bytevector-compres improvements

Browse Source 
- added invoke-library
    syntax.ss, primdata.ss,
    8.ms, root-experr*,
    libraries.stex, release_notes.stex
- updated the date
    release_notes.stex
- libraries contained within a whole program or library are now
  marked pending before their invoke code is run so that invoke
  cycles are reported as such rather than as attempts to invoke
  while still loading.
    compile.ss, syntax.ss, primdata.ss,
    7.ms, root-experr*
- the library manager now protects against unbound references
  from separately compiled libraries or programs to identifiers
  ostensibly but not actually exported by (invisible) libraries
  that exist only locally within a whole program.  this is done by
  marking the invisibility of the library in the library-info and
  propagating it to libdesc records; the latter is checked upon
  library import, visit, and invoke as well as by verify-loadability.
  the import and visit code of each invisible no longer complains
  about invisibility since it shouldn't be reachable.
    syntax.ss, compile.ss, expand-lang.ss,
    7.ms, 8.ms, root-experr*, patch*
- documented that compile-whole-xxx's linearization of the
  library initialization code based on static dependencies might
  not work for dynamic dependencies.
    system.stex
- optimized bignum right shifts so the code (1) doesn't look at
  shifted-off bigits if the bignum is positive, since it doesn't
  need to know in that case if any bits are set; (2) doesn't look
  at shifted-off bigits if the bignum is negative if it determines
  that at least one bit is set in the bits shifted off the low-order
  partially retained bigit; (3) quits looking, if it must look, for
  one bits as soon as it finds one; (4) looks from both ends under
  the assumption that set bits, if any, are most likely to be found
  toward the high or low end of the bignum rather than just in the
  middle; and (5) doesn't copy the retained bigits and then shift;
  rather shifts as it copies.  This leads to dramatic improvements
  when the shift count is large and often significant improvements
  otherwise.
    number.c,
    5_3.ms,
    release_notes.stex
- threaded tc argument through to all calls to S_bignum and
  S_trunc_rem so they don't have to call get_thread_context()
  when it might already have been called.
    alloc.c, number.c, fasl.c, print.c, prim5.c, externs.h
- added an expand-primitive handler to partially inline integer?.
    cpnanopass.ss
- added some special cases for basic arithmetic operations (+, -, *,
  /, quotient, remainder, and the div/div0/mod/mod0 operations) to
  avoid doing unnecessary work for large bignums when the result
  will be zero (e.g,. multiplying by 0), the same as one of the
  inputs (e.g., adding 0 or multiplying by 1), or the additive
  inverse of one of the inputs (e.g., subtracting from 0, dividing
  by -1).  This can have a major beneficial affect when operating
  on large bignums in the cases handled.  also converted some uses
  of / into integer/ where going through the former would just add
  overhead without the possibility of optimization.
    5_3.ss,
    number.c, externs.h, prim5.c,
    5_3.ms, root-experr, patch*,
    release_notes.stex
- added a queue to hold pending signals for which handlers have
  been registered via register-signal-handler so up to 63 (configurable
  in the source code) unhandled signals are buffered before the
  handler has to start dropping them.
    cmacros.ss, library.ss, prims.ss, primdata.ss,
    schsig.c, externs.h, prim5.c, thread.c, gc.c,
    unix.ms,
    system.stex, release_notes.stex
- bytevector-compress now selects the level of compression based
  on the compress-level parameter.  Prior to this it always used a
  default setting for compression.  the compress-level parameter
  can now take on the new minimum in addition to low, medium, high,
  and maximum.  minimum is presently treated the same as low
  except in the case of lz4 bytevector compression, where it
  results in the use of LZ4_compress_default rather than the
  slower but more effective LZ4_compress_HC.
    cmacros,ss, back.ss,
    compress_io.c, new_io.c, externs.h,
    bytevector.ms, mats/Mf-base, root-experr*
    io.stex, objects.stex, release_notes.stex

original commit: 72d90e4c67849908da900d0b6249a1dedb5f8c7f
This commit is contained in:
dybvig 2020-02-21 13:48:47 -08:00
parent 8457bfe57a
commit d0b405ac8b
41 changed files with 2597 additions and 870 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
LOG
View File

@ -1862,3 +1862,86 @@
compile.ss, primdata.ss
7.ms, root-experr*
system.stex, use.stex, release_notes.stex
- added invoke-library
syntax.ss, primdata.ss,
8.ms, root-experr*,
libraries.stex, release_notes.stex
- updated the date
release_notes.stex
- libraries contained within a whole program or library are now
marked pending before their invoke code is run so that invoke
cycles are reported as such rather than as attempts to invoke
while still loading.
compile.ss, syntax.ss, primdata.ss,
7.ms, root-experr*
- the library manager now protects against unbound references
from separately compiled libraries or programs to identifiers
ostensibly but not actually exported by (invisible) libraries
that exist only locally within a whole program. this is done by
marking the invisibility of the library in the library-info and
propagating it to libdesc records; the latter is checked upon
library import, visit, and invoke as well as by verify-loadability.
the import and visit code of each invisible no longer complains
about invisibility since it shouldn't be reachable.
syntax.ss, compile.ss, expand-lang.ss,
7.ms, 8.ms, root-experr*, patch*
- documented that compile-whole-xxx's linearization of the
library initialization code based on static dependencies might
not work for dynamic dependencies.
system.stex
- optimized bignum right shifts so the code (1) doesn't look at
shifted-off bigits if the bignum is positive, since it doesn't
need to know in that case if any bits are set; (2) doesn't look
at shifted-off bigits if the bignum is negative if it determines
that at least one bit is set in the bits shifted off the low-order
partially retained bigit; (3) quits looking, if it must look, for
one bits as soon as it finds one; (4) looks from both ends under
the assumption that set bits, if any, are most likely to be found
toward the high or low end of the bignum rather than just in the
middle; and (5) doesn't copy the retained bigits and then shift;
rather shifts as it copies. This leads to dramatic improvements
when the shift count is large and often significant improvements
otherwise.
number.c,
5_3.ms,
release_notes.stex
- threaded tc argument through to all calls to S_bignum and
S_trunc_rem so they don't have to call get_thread_context()
when it might already have been called.
alloc.c, number.c, fasl.c, print.c, prim5.c, externs.h
- added an expand-primitive handler to partially inline integer?.
cpnanopass.ss
- added some special cases for basic arithmetic operations (+, -, *,
/, quotient, remainder, and the div/div0/mod/mod0 operations) to
avoid doing unnecessary work for large bignums when the result
will be zero (e.g,. multiplying by 0), the same as one of the
inputs (e.g., adding 0 or multiplying by 1), or the additive
inverse of one of the inputs (e.g., subtracting from 0, dividing
by -1). This can have a major beneficial affect when operating
on large bignums in the cases handled. also converted some uses
of / into integer/ where going through the former would just add
overhead without the possibility of optimization.
5_3.ss,
number.c, externs.h, prim5.c,
5_3.ms, root-experr, patch*,
release_notes.stex
- added a queue to hold pending signals for which handlers have
been registered via register-signal-handler so up to 63 (configurable
in the source code) unhandled signals are buffered before the
handler has to start dropping them.
cmacros.ss, library.ss, prims.ss, primdata.ss,
schsig.c, externs.h, prim5.c, thread.c, gc.c,
unix.ms,
system.stex, release_notes.stex
- bytevector-compress now selects the level of compression based
on the compress-level parameter. Prior to this it always used a
default setting for compression. the compress-level parameter
can now take on the new minimum in addition to low, medium, high,
and maximum. minimum is presently treated the same as low
except in the case of lz4 bytevector compression, where it
results in the use of LZ4_compress_default rather than the
slower but more effective LZ4_compress_HC.
cmacros,ss, back.ss,
compress_io.c, new_io.c, externs.h,
bytevector.ms, mats/Mf-base, root-experr*
io.stex, objects.stex, release_notes.stex

3
c/alloc.c
View File

@ -816,8 +816,7 @@ ptr Sstring_utf8(s, n) const char *s; iptr n; {
return p;
}
ptr S_bignum(n, sign) iptr n; IBOOL sign; {
ptr tc = get_thread_context();
ptr S_bignum(tc, n, sign) ptr tc; iptr n; IBOOL sign; {
ptr p; iptr d;
if ((uptr)n > (uptr)maximum_bignum_length)

72
c/compress-io.c
View File

@ -91,6 +91,23 @@ static INT glzread_lz4(lz4File_in *lz4, void *buffer, UINT count);
static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count);
static INT glzwrite_lz4(lz4File_out *lz4, void *buffer, UINT count);
INT S_zlib_compress_level(INT compress_level) {
switch (compress_level) {
case COMPRESS_MIN:
case COMPRESS_LOW:
return Z_BEST_SPEED;
case COMPRESS_MEDIUM:
return (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2;
case COMPRESS_HIGH:
return (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4;
case COMPRESS_MAX:
return Z_BEST_COMPRESSION;
default:
S_error1("S_zlib_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
return 0;
}
}
static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
gzFile gz;
glzFile glz;
@ -105,24 +122,7 @@ static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
if ((gz = gzdopen(fd, as_append ? "ab" : "wb")) == Z_NULL) return Z_NULL;
switch (compress_level) {
case COMPRESS_LOW:
level = Z_BEST_SPEED;
break;
case COMPRESS_MEDIUM:
level = (Z_BEST_SPEED + Z_BEST_COMPRESSION) / 2;
break;
case COMPRESS_HIGH:
level = (Z_BEST_SPEED + (3 * Z_BEST_COMPRESSION)) / 4;
break;
case COMPRESS_MAX:
level = Z_BEST_COMPRESSION;
break;
default:
S_error1("glzdopen_output_gz", "unexpected compress level ~s", Sinteger(compress_level));
level = 0;
break;
}
level = S_zlib_compress_level(compress_level);
gzsetparams(gz, level, Z_DEFAULT_STRATEGY);
@ -137,29 +137,29 @@ static glzFile glzdopen_output_gz(INT fd, INT compress_level) {
return glz;
}
INT S_lz4_compress_level(INT compress_level) {
switch (compress_level) {
case COMPRESS_MIN:
case COMPRESS_LOW:
return 1;
case COMPRESS_MEDIUM:
return LZ4HC_CLEVEL_MIN;
case COMPRESS_HIGH:
return (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2;
case COMPRESS_MAX:
return LZ4HC_CLEVEL_MAX;
default:
S_error1("S_lz4_compress_level", "unexpected compress level ~s", Sinteger(compress_level));
return 0;
}
}
static glzFile glzdopen_output_lz4(INT fd, INT compress_level) {
glzFile glz;
lz4File_out *lz4;
INT level;
switch (compress_level) {
case COMPRESS_LOW:
level = 1;
break;
case COMPRESS_MEDIUM:
level = LZ4HC_CLEVEL_MIN;
break;
case COMPRESS_HIGH:
level = (LZ4HC_CLEVEL_MIN + LZ4HC_CLEVEL_MAX) / 2;
break;
case COMPRESS_MAX:
level = LZ4HC_CLEVEL_MAX;
break;
default:
S_error1("glzdopen_output_lz4", "unexpected compress level ~s", Sinteger(compress_level));
level = 0;
break;
}
level = S_lz4_compress_level(compress_level);
if ((lz4 = malloc(sizeof(lz4File_out))) == NULL) return Z_NULL;
memset(&lz4->preferences, 0, sizeof(LZ4F_preferences_t));

9
c/externs.h
View File

@ -90,7 +90,7 @@ extern ptr S_inexactnum PROTO((double rp, double ip));
extern ptr S_exactnum PROTO((ptr a, ptr b));
extern ptr S_thread PROTO((ptr tc));
extern ptr S_string PROTO((const char *s, iptr n));
extern ptr S_bignum PROTO((iptr n, IBOOL sign));
extern ptr S_bignum PROTO((ptr tc, iptr n, IBOOL sign));
extern ptr S_code PROTO((ptr tc, iptr type, iptr n));
extern ptr S_relocation_table PROTO((iptr n));
extern ptr S_weak_cons PROTO((ptr car, ptr cdr));
@ -175,6 +175,8 @@ extern wchar_t *S_malloc_wide_pathname PROTO((const char *inpath));
extern IBOOL S_fixedpathp PROTO((const char *inpath));
/* compress-io.c */
extern INT S_zlib_compress_level PROTO((INT compress_level));
extern INT S_lz4_compress_level PROTO((INT compress_level));
extern glzFile S_glzdopen_output PROTO((INT fd, INT compress_format, INT compress_level));
extern glzFile S_glzdopen_input PROTO((INT fd));
extern glzFile S_glzopen_input PROTO((const char *path));
@ -260,13 +262,14 @@ extern iptr S_integer_value PROTO((const char *who, ptr x));
extern I64 S_int64_value PROTO((char *who, ptr x));
extern IBOOL S_big_eq PROTO((ptr x, ptr y));
extern IBOOL S_big_lt PROTO((ptr x, ptr y));
extern ptr S_big_negate PROTO((ptr x));
extern ptr S_add PROTO((ptr x, ptr y));
extern ptr S_sub PROTO((ptr x, ptr y));
extern ptr S_mul PROTO((ptr x, ptr y));
extern ptr S_div PROTO((ptr x, ptr y));
extern ptr S_rem PROTO((ptr x, ptr y));
extern ptr S_trunc PROTO((ptr x, ptr y));
extern void S_trunc_rem PROTO((ptr x, ptr y, ptr *q, ptr *r));
extern void S_trunc_rem PROTO((ptr tc, ptr x, ptr y, ptr *q, ptr *r));
extern ptr S_gcd PROTO((ptr x, ptr y));
extern ptr S_ash PROTO((ptr x, ptr n));
extern ptr S_big_positive_bit_field PROTO((ptr x, ptr fxstart, ptr fxend));
@ -322,6 +325,8 @@ extern void S_handle_arg_error PROTO((void));
extern void S_handle_nonprocedure_symbol PROTO((void));
extern void S_handle_values_error PROTO((void));
extern void S_handle_mvlet_error PROTO((void));
extern ptr S_allocate_scheme_signal_queue PROTO((void));
extern ptr S_dequeue_scheme_signals PROTO((ptr tc));
extern void S_register_scheme_signal PROTO((iptr sig));
extern void S_fire_collector PROTO((void));
extern NORETURN void S_noncontinuable_interrupt PROTO((void));

2
c/fasl.c
View File

@ -904,7 +904,7 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) {
IBOOL sign; iptr n; ptr t; bigit *p;
sign = bytein(f);
n = uptrin(f);
t = S_bignum(n, sign);
t = S_bignum(tc, n, sign);
p = &BIGIT(t, 0);
while (n--) *p++ = (bigit)uptrin(f);
*x = S_normalize_bignum(t);

1
c/gc.c
View File

@ -1494,6 +1494,7 @@ static void sweep_thread(p) ptr p; {
/* immediate TIMERTICKS */
/* immediate DISABLE_COUNT */
/* immediate SIGNALINTERRUPTPENDING */
/* void* SIGNALINTERRUPTQUEUE(tc) */
/* immediate KEYBOARDINTERRUPTPENDING */
relocate(&THREADNO(tc))
relocate(&CURRENTINPUT(tc))

12
c/new-io.c
View File

@ -28,6 +28,7 @@
#include <fcntl.h>
#include "zlib.h"
#include "lz4.h"
#include "lz4hc.h"
/* !!! UNLESS you enjoy spending endless days tracking down race conditions
!!! involving the garbage collector, please note: DEACTIVATE and
@ -814,6 +815,9 @@ uptr S_bytevector_compress_size(iptr s_count, INT compress_format) {
ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
ptr src_bv, iptr s_start, iptr s_count,
INT compress_format) {
ptr tc = get_thread_context();
int compress_level = (INT)UNFIX(COMPRESSLEVEL(tc));
/* On error, an message-template string with ~s for the bytevector */
switch (compress_format) {
case COMPRESS_GZIP:
@ -826,7 +830,7 @@ ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
destLen = (uLong)d_count;
r = compress(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count);
r = compress2(&BVIT(dest_bv, d_start), &destLen, &BVIT(src_bv, s_start), (uLong)s_count, S_zlib_compress_level(compress_level));
if (r == Z_OK)
return FIX(destLen);
@ -842,7 +846,11 @@ ptr S_bytevector_compress(ptr dest_bv, iptr d_start, iptr d_count,
if (!is_valid_lz4_length(s_count))
return Sstring("source bytevector ~s is too large");
destLen = LZ4_compress_default((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
if (compress_level == COMPRESS_MIN) {
destLen = LZ4_compress_default((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count);
} else {
destLen = LZ4_compress_HC((char *)&BVIT(src_bv, s_start), (char *)&BVIT(dest_bv, d_start), (int)s_count, (int)d_count, S_lz4_compress_level(compress_level));
}
if (destLen > 0)
return Sfixnum(destLen);

335
c/number.c
View File

@ -25,9 +25,10 @@
#include "system.h"
/* locally defined functions */
static ptr copy_normalize PROTO((bigit *p, iptr len, IBOOL sign));
static ptr copy_normalize PROTO((ptr tc, const bigit *p, iptr len, IBOOL sign));
static IBOOL abs_big_lt PROTO((ptr x, ptr y, iptr xl, iptr yl));
static IBOOL abs_big_eq PROTO((ptr x, ptr y, iptr xl, iptr yl));
static ptr big_negate PROTO((ptr tc, ptr x));
static ptr big_add_pos PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign));
static ptr big_add_neg PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL sign));
static ptr big_add PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys));
@ -37,7 +38,7 @@ static void big_trunc PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL qs, I
static INT normalize PROTO((bigit *xp, bigit *yp, iptr xl, iptr yl));
static bigit quotient_digit PROTO((bigit *xp, bigit *yp, iptr yl));
static bigit qhat PROTO((bigit *xp, bigit *yp));
static ptr big_short_gcd PROTO((ptr x, bigit y, iptr xl));
static ptr big_short_gcd PROTO((ptr tc, ptr x, bigit y, iptr xl));
static ptr big_gcd PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl));
static ptr s_big_ash PROTO((ptr tc, bigit *xp, iptr xl, IBOOL sign, iptr cnt));
static double big_short_floatify PROTO((ptr tc, ptr x, bigit s, iptr xl, IBOOL sign));
@ -53,27 +54,27 @@ static ptr big_logor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IB
static ptr big_logxor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, IBOOL ys));
/* use w/o trailing semicolon */
#define PREPARE_BIGNUM(x,l)\
{if (x == FIX(0) || BIGLEN(x) < (l)) x = S_bignum((l)*2, 0);}
#define PREPARE_BIGNUM(tc,x,l)\
{if (x == FIX(0) || BIGLEN(x) < (l)) x = S_bignum(tc, (l)*2, 0);}
#define bigit_mask (~(bigit)0)
#define IBIGIT_TO_BIGNUM(B,x,cnt,sign) {\
#define IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\
ibigit _i_ = x;\
PREPARE_BIGNUM(B, 1)\
PREPARE_BIGNUM(tc, B, 1)\
*cnt = 1;\
BIGIT(B,0) = (*sign = (_i_ < 0)) ? -_i_ : _i_;\
}
#define UBIGIT_TO_BIGNUM(B,u,cnt) {\
PREPARE_BIGNUM(B, 1)\
#define UBIGIT_TO_BIGNUM(tc,B,u,cnt) {\
PREPARE_BIGNUM(tc, B, 1)\
*cnt = 1;\
BIGIT(B,0) = u;\
}
#define IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign) {\
#define IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign) {\
ibigitbigit _i_ = x; bigitbigit _u_; bigit _b_;\
PREPARE_BIGNUM(B, 2)\
PREPARE_BIGNUM(tc, B, 2)\
_u_ = (*sign = (_i_ < 0)) ? -_i_ : _i_;\
if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\
*cnt = 1;\
@ -85,9 +86,9 @@ static ptr big_logxor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, I
}\
}
#define UBIGITBIGIT_TO_BIGNUM(B,x,cnt) {\
#define UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt) {\
bigitbigit _u_ = x; bigit _b_;\
PREPARE_BIGNUM(B, 2)\
PREPARE_BIGNUM(tc, B, 2)\
if ((_b_ = (_u_ & (bigitbigit)bigit_mask)) == _u_) {\
*cnt = 1;\
BIGIT(B,0) = (bigit)_u_;\
@ -101,20 +102,20 @@ static ptr big_logxor PROTO((ptr tc, ptr x, ptr y, iptr xl, iptr yl, IBOOL xs, I
#define U32_bigits (32 / bigit_bits)
#if (U32_bigits == 1)
#define I32_TO_BIGNUM(B,x,cnt,sign) IBIGIT_TO_BIGNUM(B,x,cnt,sign)
#define U32_TO_BIGNUM(B,x,cnt) UBIGIT_TO_BIGNUM(B,x,cnt)
#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt)
#endif
#if (U32_bigits == 2)
#define I32_TO_BIGNUM(B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign)
#define U32_TO_BIGNUM(B,x,cnt) UBIGITBIGIT_TO_BIGNUM(B,x,cnt)
#define I32_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
#define U32_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
#endif
#define U64_bigits (64 / bigit_bits)
#if (U64_bigits == 2)
#define I64_TO_BIGNUM(B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign)
#define U64_TO_BIGNUM(B,x,cnt) UBIGITBIGIT_TO_BIGNUM(B,x,cnt)
#define I64_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
#define U64_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
#endif
#if (U64_bigits == 4)
@ -124,16 +125,16 @@ see v7.4 number.c for U64_TO_BIGNUM w/U64_bigits == 4
#define ptr_bigits (ptr_bits / bigit_bits)
#if (ptr_bigits == 1)
#define IPTR_TO_BIGNUM(B,x,cnt,sign) IBIGIT_TO_BIGNUM(B,x,cnt,sign)
#define UPTR_TO_BIGNUM(B,x,cnt) UBIGIT_TO_BIGNUM(B,x,cnt)
#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGIT_TO_BIGNUM(tc,B,x,cnt)
#endif
#if (ptr_bigits == 2)
#define IPTR_TO_BIGNUM(B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(B,x,cnt,sign)
#define UPTR_TO_BIGNUM(B,x,cnt) UBIGITBIGIT_TO_BIGNUM(B,x,cnt)
#define IPTR_TO_BIGNUM(tc,B,x,cnt,sign) IBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt,sign)
#define UPTR_TO_BIGNUM(tc,B,x,cnt) UBIGITBIGIT_TO_BIGNUM(tc,B,x,cnt)
#endif
#define FIXNUM_TO_BIGNUM(B,p,cnt,sign) IPTR_TO_BIGNUM(B,UNFIX(p),cnt,sign)
#define FIXNUM_TO_BIGNUM(tc,B,p,cnt,sign) IPTR_TO_BIGNUM(tc,B,UNFIX(p),cnt,sign)
ptr S_normalize_bignum(ptr x) {
uptr n = BIGIT(x, 0); iptr len = BIGLEN(x); IBOOL sign = BIGSIGN(x);
@ -163,7 +164,7 @@ ptr S_normalize_bignum(ptr x) {
return x;
}
static ptr copy_normalize(p,len,sign) bigit *p; iptr len; IBOOL sign; {
static ptr copy_normalize(tc, p, len, sign) ptr tc; const bigit *p; iptr len; IBOOL sign; {
bigit *p1; uptr n; ptr b;
for (;;) {
@ -196,7 +197,7 @@ static ptr copy_normalize(p,len,sign) bigit *p; iptr len; IBOOL sign; {
}
#endif
b = S_bignum(len, sign);
b = S_bignum(tc, len, sign);
for (p1 = &BIGIT(b, 0); len--;) *p1++ = *p++;
return b;
}
@ -337,7 +338,7 @@ ptr Sunsigned(u) uptr u; { /* convert arg to Scheme integer */
return FIX(u);
else {
ptr x = FIX(0); iptr xl;
UPTR_TO_BIGNUM(x, u, &xl)
UPTR_TO_BIGNUM(get_thread_context(), x, u, &xl)
SETBIGLENANDSIGN(x, xl, 0);
return x;
}
@ -348,7 +349,7 @@ ptr Sinteger(i) iptr i; { /* convert arg to Scheme integer */
return FIX(i);
else {
ptr x = FIX(0); iptr xl; IBOOL xs;
IPTR_TO_BIGNUM(x, i, &xl, &xs)
IPTR_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
SETBIGLENANDSIGN(x, xl, xs);
return x;
}
@ -362,7 +363,7 @@ ptr Sunsigned32(u) U32 u; { /* convert arg to Scheme integer */
return FIX((uptr)u);
else {
ptr x = FIX(0); iptr xl;
U32_TO_BIGNUM(x, u, &xl)
U32_TO_BIGNUM(get_thread_context(), x, u, &xl)
SETBIGLENANDSIGN(x, xl, 0);
return x;
}
@ -377,7 +378,7 @@ ptr Sinteger32(i) I32 i; { /* convert arg to Scheme integer */
return FIX((iptr)i);
else {
ptr x = FIX(0); iptr xl; IBOOL xs;
I32_TO_BIGNUM(x, i, &xl, &xs)
I32_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
SETBIGLENANDSIGN(x, xl, xs);
return x;
}
@ -389,7 +390,7 @@ ptr Sunsigned64(u) U64 u; { /* convert arg to Scheme integer */
return FIX((uptr)u);
else {
ptr x = FIX(0); iptr xl;
U64_TO_BIGNUM(x, u, &xl)
U64_TO_BIGNUM(get_thread_context(), x, u, &xl)
SETBIGLENANDSIGN(x, xl, 0);
return x;
}
@ -400,7 +401,7 @@ ptr Sinteger64(i) I64 i; { /* convert arg to Scheme integer */
return FIX((iptr)i);
else {
ptr x = FIX(0); iptr xl; IBOOL xs;
I64_TO_BIGNUM(x, i, &xl, &xs)
I64_TO_BIGNUM(get_thread_context(), x, i, &xl, &xs)
SETBIGLENANDSIGN(x, xl, xs);
return x;
}
@ -417,6 +418,11 @@ ptr Sinteger64(i) I64 i; { /* convert arg to Scheme integer */
*(x) = _b_>>_n_ | *(k);\
*(k) = _newk_;}
#define ERSH2(n,x,y,k) { /* undefined when n == 0 */\
INT _n_ = (INT)(n); bigit _b_ = (x), _newk_ = _b_<<(bigit_bits-_n_);\
*(y) = _b_>>_n_ | *(k);\
*(k) = _newk_;}
#define EADDC(a1, a2, sum, k) {\
bigit _tmp1_, _tmp2_, _tmpk_;\
_tmp1_ = (a1);\
@ -505,13 +511,21 @@ addition/subtraction
***
*/
static ptr big_negate(tc, x) ptr tc, x; {
return copy_normalize(tc, &BIGIT(x,0),BIGLEN(x),!BIGSIGN(x));
}
ptr S_big_negate(x) ptr x; {
return big_negate(get_thread_context(), x);
}
/* assumptions: BIGLEN(x) >= BIGLEN(y) */
static ptr big_add_pos(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign; {
iptr i;
bigit *xp, *yp, *zp;
bigit k = 0;
PREPARE_BIGNUM(W(tc),xl+1)
PREPARE_BIGNUM(tc, W(tc),xl+1)
xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl);
@ -524,7 +538,7 @@ static ptr big_add_pos(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
*zp = k;
return copy_normalize(zp,xl+1,sign);
return copy_normalize(tc, zp,xl+1,sign);
}
/* assumptions: x >= y */
@ -533,7 +547,7 @@ static ptr big_add_neg(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
bigit *xp, *yp, *zp;
bigit b = 0;
PREPARE_BIGNUM(W(tc),xl)
PREPARE_BIGNUM(tc, W(tc),xl)
xp = &BIGIT(x,xl-1); yp = &BIGIT(y,yl-1); zp = &BIGIT(W(tc),xl-1);
@ -544,7 +558,7 @@ static ptr big_add_neg(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL
for (; i-- > 0; )
*zp-- = *xp--;
return copy_normalize(zp+1,xl,sign);
return copy_normalize(tc, zp+1,xl,sign);
}
static ptr big_add(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL xs, ys; {
@ -570,13 +584,13 @@ ptr S_add(x, y) ptr x, y; {
return FIXRANGE(n) ? FIX(n) : Sinteger(n);
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, BIGSIGN(y));
}
} else {
if (Sfixnump(y)) {
iptr yl; IBOOL ys;
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
} else {
return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), BIGSIGN(y));
@ -594,13 +608,13 @@ ptr S_sub(x, y) ptr x, y; {
return FIXRANGE(n) ? FIX(n) : Sinteger(n);
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
return big_add(tc, X(tc), y, xl, BIGLEN(y), xs, !BIGSIGN(y));
}
} else {
if (Sfixnump(y)) {
iptr yl; IBOOL ys;
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
return big_add(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), !ys);
} else {
return big_add(tc, x, y, BIGLEN(x), BIGLEN(y), BIGSIGN(x), !BIGSIGN(y));
@ -619,7 +633,7 @@ static ptr big_mul(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign
bigit *xp, *yp, *zp, *zpa;
bigit k, k1, prod;
PREPARE_BIGNUM(W(tc),xl+yl)
PREPARE_BIGNUM(tc, W(tc),xl+yl)
for (xi = xl, zp = &BIGIT(W(tc),xl+yl-1); xi-- > 0; ) *zp-- = 0;
for (yi=yl,yp= &BIGIT(y,yl-1),zp= &BIGIT(W(tc),xl+yl-1); yi-- > 0; yp--, zp--)
@ -634,7 +648,7 @@ static ptr big_mul(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IBOOL sign
*zpa = k;
}
return copy_normalize(&BIGIT(W(tc),0),xl+yl,sign);
return copy_normalize(tc, &BIGIT(W(tc),0),xl+yl,sign);
}
/* SHORTRANGE is -floor(sqrt(most_positive_fixnum))..floor(sqrt(most_positive_fixnum)).
@ -657,17 +671,17 @@ ptr S_mul(x, y) ptr x, y; {
if (SHORTRANGE(xn) && SHORTRANGE(yn))
return FIX(xn * yn);
else {
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
}
} else {
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs) x = X(tc);
yl = BIGLEN(y); ys = BIGSIGN(y);
}
} else {
if (Sfixnump(y)) {
xl = BIGLEN(x); xs = BIGSIGN(x);
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys) y = Y(tc);
} else {
xl = BIGLEN(x); xs = BIGSIGN(x);
yl = BIGLEN(y); ys = BIGSIGN(y);
@ -684,29 +698,34 @@ division
/* arguments must be integers (fixnums or bignums), y must be nonzero */
ptr S_div(x, y) ptr x, y; {
ptr g;
ptr g, n, d;
ptr tc = get_thread_context();
g = S_gcd(x,y);
if (Sfixnump(y) ? UNFIX(y) < 0 : BIGSIGN(y)) g = S_sub(FIX(0),g);
return S_rational(S_trunc(x,g), S_trunc(y,g));
if (Sfixnump(y) ? UNFIX(y) < 0 : BIGSIGN(y)) {
g = Sfixnump(g) ? Sinteger(-UNFIX(g)) : big_negate(tc, g);
}
S_trunc_rem(tc, x, g, &n, (ptr *)NULL);
S_trunc_rem(tc, y, g, &d, (ptr *)NULL);
return S_rational(n, d);
}
ptr S_trunc(x, y) ptr x, y; {
ptr q;
S_trunc_rem(x, y, &q, (ptr *)NULL);
S_trunc_rem(get_thread_context(), x, y, &q, (ptr *)NULL);
return q;
}
ptr S_rem(x, y) ptr x, y; {
ptr r;
S_trunc_rem(x, y, (ptr *)NULL, &r);
S_trunc_rem(get_thread_context(), x, y, (ptr *)NULL, &r);
return r;
}
/* arguments must be integers (fixnums or bignums), y must be nonzero */
void S_trunc_rem(origx, y, q, r) ptr origx, y, *q, *r; {
ptr tc = get_thread_context();
void S_trunc_rem(tc, origx, y, q, r) ptr tc, origx, y, *q, *r; {
iptr xl, yl; IBOOL xs, ys; ptr x = origx;
if (Sfixnump(x)) {
@ -722,13 +741,13 @@ void S_trunc_rem(origx, y, q, r) ptr origx, y, *q, *r; {
return;
}
} else {
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
yl = BIGLEN(y); ys = BIGSIGN(y);
}
} else {
if (Sfixnump(y)) {
xl = BIGLEN(x); xs = BIGSIGN(x);
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
} else {
xl = BIGLEN(x); xs = BIGSIGN(x);
yl = BIGLEN(y); ys = BIGSIGN(y);
@ -750,13 +769,13 @@ static void big_short_trunc(ptr tc, ptr x, bigit s, iptr xl, IBOOL qs, IBOOL rs,
bigit *xp, *zp;
bigit k;
PREPARE_BIGNUM(W(tc),xl)
PREPARE_BIGNUM(tc, W(tc),xl)
for (i = xl, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i-- > 0; )
EDIV(k, *xp++, s, zp++, &k)
if (q != (ptr *)NULL) *q = copy_normalize(&BIGIT(W(tc),0),xl,qs);
if (r != (ptr *)NULL) *r = copy_normalize(&k,1,rs);
if (q != (ptr *)NULL) *q = copy_normalize(tc, &BIGIT(W(tc),0),xl,qs);
if (r != (ptr *)NULL) *r = copy_normalize(tc, &k,1,rs);
}
static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
@ -767,11 +786,11 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
INT d;
bigit k;
PREPARE_BIGNUM(U(tc), xl+1)
PREPARE_BIGNUM(tc, U(tc), xl+1)
for (i = xl, xp = &BIGIT(U(tc),xl+1), p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p;
*--xp = 0;
PREPARE_BIGNUM(V(tc), yl)
PREPARE_BIGNUM(tc, V(tc), yl)
for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p;
d = normalize(xp, yp, xl, yl);
@ -779,10 +798,10 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
if (q == (ptr *)NULL) {
for (i = m; i-- > 0 ; xp++) (void) quotient_digit(xp, yp, yl);
} else {
PREPARE_BIGNUM(W(tc),m)
PREPARE_BIGNUM(tc, W(tc),m)
p = &BIGIT(W(tc),0);
for (i = m; i-- > 0 ; xp++) *p++ = quotient_digit(xp, yp, yl);
*q = copy_normalize(&BIGIT(W(tc),0),m,qs);
*q = copy_normalize(tc, &BIGIT(W(tc),0),m,qs);
}
if (r != (ptr *)NULL) {
@ -790,7 +809,7 @@ static void big_trunc(tc, x, y, xl, yl, qs, rs, q, r)
if (d != 0) {
for (i = yl, p = xp, k = 0; i-- > 0; p++) ERSH(d,p,&k)
}
*r = copy_normalize(xp, yl, rs);
*r = copy_normalize(tc, xp, yl, rs);
}
}
@ -874,12 +893,12 @@ static ptr uptr_gcd(x, y) uptr x, y; {
}
/* sparc C compiler barfs w/o full declaration */
static ptr big_short_gcd(ptr x, bigit y, iptr xl) {
static ptr big_short_gcd(ptr tc, ptr x, bigit y, iptr xl) {
bigit *xp;
iptr i;
bigit r, q;
if (y == 0) return BIGSIGN(x) ? S_sub(FIX(0),x) : x;
if (y == 0) return BIGSIGN(x) ? big_negate(tc, x) : x;
for (i = xl, r = 0, xp = &BIGIT(x,0); i-- > 0; )
EDIV(r, *xp++, y, &q, &r)
@ -893,13 +912,13 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
bigit *p, *xp, *yp, k, b;
/* Copy x to scratch bignum, with a leading zero */
PREPARE_BIGNUM(U(tc),xl+1)
PREPARE_BIGNUM(tc, U(tc),xl+1)
xp = &BIGIT(U(tc),xl+1);
for (i = xl, p = &BIGIT(x,xl); i-- > 0; ) *--xp = *--p;
*--xp = 0; /* leave xp pointing at leading 0-bigit */
/* Copy y to scratch bignum, with a leading zero */
PREPARE_BIGNUM(V(tc),yl+1)
PREPARE_BIGNUM(tc, V(tc),yl+1)
yp = &BIGIT(V(tc),yl+1);
for (i = yl, p = &BIGIT(y,yl); i-- > 0; ) *--yp = *--p;
*(yp-1) = 0; /* leave yp pointing just after leading 0-bigit */
@ -953,7 +972,7 @@ static ptr big_gcd(tc, x, y, xl, yl) ptr tc, x, y; iptr xl, yl; {
if (asc != 0) {
for (i = xl, p = xp, k = 0; i-- > 0; p++) ERSH(asc,p,&k)
}
return copy_normalize(xp,xl,0);
return copy_normalize(tc, xp,xl,0);
} else {
bigit d, r;
@ -976,13 +995,13 @@ ptr S_gcd(x, y) ptr x, y; {
uptr_gcd((uptr)xi, (uptr)yi) :
uptr_gcd((uptr)yi, (uptr)xi);
} else {
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs) x = X(tc);
FIXNUM_TO_BIGNUM(tc, X(tc),x,&xl,&xs) x = X(tc);
yl = BIGLEN(y); ys = BIGSIGN(y);
}
else
if (Sfixnump(y)) {
xl = BIGLEN(x); xs = BIGSIGN(x);
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys) y = Y(tc);
FIXNUM_TO_BIGNUM(tc, Y(tc),y,&yl,&ys) y = Y(tc);
} else {
xl = BIGLEN(x); xs = BIGSIGN(x);
yl = BIGLEN(y); ys = BIGSIGN(y);
@ -993,10 +1012,10 @@ ptr S_gcd(x, y) ptr x, y; {
uptr xu = BIGIT(x,0), yu = BIGIT(y,0);
return xu >= yu ? uptr_gcd(xu, yu) : uptr_gcd(yu, xu);
} else
return big_short_gcd(y, BIGIT(x,0), yl);
return big_short_gcd(tc, y, BIGIT(x,0), yl);
else
if (yl == 1)
return big_short_gcd(x, BIGIT(y,0), xl);
return big_short_gcd(tc, x, BIGIT(y,0), xl);
else
if (abs_big_lt(x, y, xl, yl))
return big_gcd(tc, y, x, yl, xl);
@ -1066,7 +1085,7 @@ static double big_short_floatify(ptr tc, ptr x, bigit s, iptr xl, IBOOL sign) {
iptr i;
bigit *xp, *zp, k;
PREPARE_BIGNUM(W(tc),enough+1)
PREPARE_BIGNUM(tc, W(tc),enough+1)
/* compute only as much of quotient as we need */
for (i = 0, k = 0, xp = &BIGIT(x,0), zp = &BIGIT(W(tc),0); i < enough; i++)
@ -1087,18 +1106,18 @@ static double big_floatify(tc, x, y, xl, yl, sign) ptr tc, x, y; iptr xl, yl; IB
/* copy x to U(tc), scaling with added zero bigits as necessary */
ul = xl < yl + enough-1 ? yl + enough-1 : xl;
PREPARE_BIGNUM(U(tc), ul+1)
PREPARE_BIGNUM(tc, U(tc), ul+1)
for (i = ul - xl, xp = &BIGIT(U(tc),ul+1); i-- > 0;) *--xp = 0;
for (i = xl, p = &BIGIT(x,xl); i-- > 0;) *--xp = *--p;
*--xp = 0;
/* copy y to V(tc) */
PREPARE_BIGNUM(V(tc), yl)
PREPARE_BIGNUM(tc, V(tc), yl)
for (i = yl, yp = &BIGIT(V(tc),yl), p = &BIGIT(y,yl); i-- > 0;) *--yp = *--p;
(void) normalize(xp, yp, ul, yl);
PREPARE_BIGNUM(W(tc),4)
PREPARE_BIGNUM(tc, W(tc),4)
p = &BIGIT(W(tc),0);
/* compute 'enough' bigits of the quotient */
@ -1202,7 +1221,7 @@ static double floatify_ratnum(tc, p) ptr tc, p; {
/* make sure we are dealing with bignums */
if (Sfixnump(x)) {
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
x = X(tc);
} else {
xl = BIGLEN(x);
@ -1211,7 +1230,7 @@ static double floatify_ratnum(tc, p) ptr tc, p; {
if (Sfixnump(y)) {
IBOOL ys;
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
y = Y(tc);
} else {
yl = BIGLEN(y);
@ -1264,7 +1283,7 @@ ptr S_decode_float(d) double d; {
else {
iptr xl;
x = FIX(0);
U64_TO_BIGNUM(x, m, &xl)
U64_TO_BIGNUM(get_thread_context(), x, m, &xl)
SETBIGLENANDSIGN(x, xl, 0);
}
@ -1288,39 +1307,47 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
bigit *p1, *p2, k;
if (cnt < 0) { /* shift to the right */
INT bit_bucket = 0;
iptr whole_bigits;
cnt = -cnt;
/* decrement length to shift by whole bigits */
if ((xl -= (whole_bigits = (cnt = -cnt) / bigit_bits)) <= 0) return sign ? FIX(-1) : FIX(0);
cnt -= whole_bigits * bigit_bits;
/* shift by whole bigits by decrementing length */
while (cnt >= bigit_bits) {
xl -= 1;
if (xl == 0) return sign ? FIX(-1) : FIX(0);
cnt -= bigit_bits;
bit_bucket |= *(xp + xl);
}
/* copy to scratch bignum */
PREPARE_BIGNUM(W(tc),xl)
p1 = &BIGIT(W(tc), xl);
for (i = xl, p2 = xp + xl; i-- > 0; ) *--p1 = *--p2;
/* shift by remaining count */
/* shift by remaining count to scratch bignum, tracking bits shifted off to the right */
PREPARE_BIGNUM(tc, W(tc),xl)
p1 = &BIGIT(W(tc), 0);
p2 = xp;
k = 0;
if (cnt != 0) {
for (i = xl; i-- > 0; p1++) ERSH(cnt,p1,&k)
}
bit_bucket |= k;
/* round down negative numbers by incrementing the magnitude if any
one bits dropped into the bit bucket */
if (sign && bit_bucket) {
p1 = &BIGIT(W(tc), xl - 1);
for (i = xl, k = 1; k != 0 && i-- > 0; p1 -= 1)
EADDC(0, *p1, p1, &k)
i = xl;
if (cnt == 0) {
do { *p1++ = *p2++; } while (--i > 0);
} else {
do { ERSH2(cnt,*p2,p1,&k); p1++; p2++; } while (--i > 0);
}
return copy_normalize(&BIGIT(W(tc), 0), xl, sign);
if (sign) {
if (k == 0) {
/* check for one bits in the shifted-off bigits, looking */
/* from both ends in an attempt to get out more quickly for what */
/* seem like the most likely patterns. of course, there might */
/* be no one bits (in which case this won't help) or they might be */
/* only in the middle (in which case this will be slower) */
p2 = (p1 = xp + xl) + whole_bigits;
while (p1 != p2) {
if ((k = *p1++) || p1 == p2 || (k = *--p2)) break;
}
}
/* round down negative numbers by incrementing the magnitude if any
one bits were shifted off to the right */
if (k) {
p1 = &BIGIT(W(tc), xl - 1);
for (i = xl, k = 1; k != 0 && i-- > 0; p1 -= 1)
EADDC(0, *p1, p1, &k)
}
}
return copy_normalize(tc, &BIGIT(W(tc), 0), xl, sign);
} else { /* shift to the left */
iptr xlplus, newxl;
@ -1334,7 +1361,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
/* maximum total length includes +1 for shift out of top bigit */
newxl = xl + xlplus + 1;
PREPARE_BIGNUM(W(tc),newxl)
PREPARE_BIGNUM(tc, W(tc),newxl)
/* fill bigits to right with zero */
for (i = xlplus, p1 = &BIGIT(W(tc), newxl); i-- > 0; ) *--p1 = 0;
@ -1346,7 +1373,7 @@ static ptr s_big_ash(tc, xp, xl, sign, cnt) ptr tc; bigit *xp; iptr xl; IBOOL si
}
*--p1 = k;
return copy_normalize(p1, newxl, sign);
return copy_normalize(tc, p1, newxl, sign);
}
}
@ -1361,7 +1388,7 @@ ptr S_ash(x, n) ptr x, n; {
do much here anyway since semantics of signed >> are undefined in C */
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs);
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
return s_big_ash(tc, &BIGIT(X(tc),0), xl, xs, cnt);
} else
return s_big_ash(tc, &BIGIT(x,0), BIGLEN(x), BIGSIGN(x), cnt);
@ -1429,7 +1456,7 @@ ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) {
}
/* copy to scratch bignum */
PREPARE_BIGNUM(W(tc),wl)
PREPARE_BIGNUM(tc, W(tc),wl)
p1 = &BIGIT(W(tc), wl);
for (i = wl, p2 = xp + xl; i-- > 0; ) *--p1 = *--p2;
@ -1442,7 +1469,7 @@ ptr S_big_positive_bit_field(ptr x, ptr fxstart, ptr fxend) {
for (i = wl; i > 0; i -= 1, p1 += 1) ERSH(start,p1,&k)
}
return copy_normalize(&BIGIT(W(tc), 0), wl, 0);
return copy_normalize(tc, &BIGIT(W(tc), 0), wl, 0);
}
/* logical operations simulate two's complement operations using the
@ -1470,13 +1497,13 @@ ptr S_logand(x, y) ptr x, y; {
return (ptr)((iptr)x & (iptr)y);
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
return big_logand(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
}
} else {
if (Sfixnump(y)) {
iptr yl; IBOOL ys;
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
return big_logand(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
} else {
if (BIGLEN(x) >= BIGLEN(y))
@ -1505,14 +1532,14 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
if (xs == 0) {
if (ys == 0) {
PREPARE_BIGNUM(W(tc),yl);
PREPARE_BIGNUM(tc, W(tc),yl);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
for (i = yl; i > 0; i -= 1) *--zp = *--xp & *--yp;
return copy_normalize(zp, yl, 0);
return copy_normalize(tc, zp, yl, 0);
} else {
bigit yb;
PREPARE_BIGNUM(W(tc),xl);
PREPARE_BIGNUM(tc, W(tc),xl);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
yb = 1;
for (i = yl; i > 0; i -= 1) {
@ -1523,13 +1550,13 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
/* yb must be 0, since high-order bigit >= 1. effectively, this
means ~t2 would be all 1's from here on out. */
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(zp, xl, 0);
return copy_normalize(tc, zp, xl, 0);
}
} else {
if (ys == 0) {
bigit xb;
PREPARE_BIGNUM(W(tc),yl);
PREPARE_BIGNUM(tc, W(tc),yl);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl);
xb = 1;
for (i = yl; i > 0; i -= 1) {
@ -1537,11 +1564,11 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
xb = t2 > t1;
*--zp = *--yp & ~t2;
}
return copy_normalize(zp, yl, 0);
return copy_normalize(tc, zp, yl, 0);
} else {
bigit xb, yb, k;
PREPARE_BIGNUM(W(tc),xl+1);
PREPARE_BIGNUM(tc, W(tc),xl+1);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
k = yb = xb = 1;
for (i = yl; i > 0; i -= 1) {
@ -1560,7 +1587,7 @@ static ptr big_logand(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, xl+1, 1);
return copy_normalize(tc, zp, xl+1, 1);
}
}
}
@ -1575,13 +1602,13 @@ ptr S_logtest(x, y) ptr x, y; {
return Sboolean((iptr)x & (iptr)y);
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
return big_logtest(y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
}
} else {
if (Sfixnump(y)) {
iptr yl; IBOOL ys;
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
return big_logtest(x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
} else {
if (BIGLEN(x) >= BIGLEN(y))
@ -1690,7 +1717,7 @@ ptr S_logbit0(k, x) ptr k, x; {
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs);
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
return big_logbit0(tc, x, n, X(tc), xl, xs);
}
} else {
@ -1717,7 +1744,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
/* we'd just be clearing a bit that's already (virtually) cleared */
return origx;
} else {
PREPARE_BIGNUM(W(tc),xl);
PREPARE_BIGNUM(tc, W(tc),xl);
xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),xl);
for (;;) {
if (n < bigit_bits) break;
@ -1726,13 +1753,13 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
}
*--zp = *--xp & ~(1 << n);
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(zp,xl,0);
return copy_normalize(tc, zp,xl,0);
}
} else {
bigit xb, k, x1, x2, z1, z2;
iptr zl = (yl > xl ? yl : xl) + 1;
PREPARE_BIGNUM(W(tc),zl);
PREPARE_BIGNUM(tc, W(tc),zl);
xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
k = xb = 1;
i = xl;
@ -1752,7 +1779,7 @@ static ptr big_logbit0(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, zl, 1);
return copy_normalize(tc, zp, zl, 1);
}
}
@ -1767,7 +1794,7 @@ ptr S_logbit1(k, x) ptr k, x; {
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs);
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs);
return big_logbit1(tc, x, n, X(tc), xl, xs);
}
} else {
@ -1785,7 +1812,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
bigit x1;
iptr zl = yl > xl ? yl : xl;
PREPARE_BIGNUM(W(tc),zl);
PREPARE_BIGNUM(tc, W(tc),zl);
xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
i = xl;
@ -1797,7 +1824,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
}
*--zp = x1 | (1 << n);
for (; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(zp, zl, 0);
return copy_normalize(tc, zp, zl, 0);
} else if (yl > xl) {
/* we'd just be setting a bit that's already (virtually) set */
return origx;
@ -1805,7 +1832,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
bigit xb, k, x1, x2, z1, z2;
iptr zl = xl + 1;
PREPARE_BIGNUM(W(tc),zl);
PREPARE_BIGNUM(tc, W(tc),zl);
xp = &BIGIT(x,xl); zp = &BIGIT(W(tc),zl);
k = xb = 1;
for (;;) {
@ -1826,7 +1853,7 @@ static ptr big_logbit1(tc, origx, n, x, xl, xs) ptr tc, origx, x; iptr n, xl; IB
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, zl, 1);
return copy_normalize(tc, zp, zl, 1);
}
}
@ -1838,13 +1865,13 @@ ptr S_logor(x, y) ptr x, y; {
return (ptr)((iptr)x | (iptr)(y));
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
return big_logor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
}
} else {
if (Sfixnump(y)) {
iptr yl; IBOOL ys;
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
return big_logor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
} else {
if (BIGLEN(x) >= BIGLEN(y))
@ -1873,15 +1900,15 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
if (xs == 0) {
if (ys == 0) {
PREPARE_BIGNUM(W(tc),xl);
PREPARE_BIGNUM(tc, W(tc),xl);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
for (i = yl; i > 0; i -= 1) *--zp = *--xp | *--yp;
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(zp, xl, 0);
return copy_normalize(tc, zp, xl, 0);
} else {
bigit yb, k;
PREPARE_BIGNUM(W(tc),yl+1);
PREPARE_BIGNUM(tc, W(tc),yl+1);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1);
k = yb = 1;
for (i = yl; i > 0; i -= 1) {
@ -1892,13 +1919,13 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, yl+1, 1);
return copy_normalize(tc, zp, yl+1, 1);
}
} else {
if (ys == 0) {
bigit xb, k;
PREPARE_BIGNUM(W(tc),xl+1);
PREPARE_BIGNUM(tc, W(tc),xl+1);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
k = xb = 1;
for (i = yl; i > 0; i -= 1) {
@ -1916,11 +1943,11 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, xl+1, 1);
return copy_normalize(tc, zp, xl+1, 1);
} else {
bigit xb, yb, k;
PREPARE_BIGNUM(W(tc),yl+1);
PREPARE_BIGNUM(tc, W(tc),yl+1);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),yl+1);
k = yb = xb = 1;
for (i = yl; i > 0; i -= 1) {
@ -1932,7 +1959,7 @@ static ptr big_logor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, yl+1, 1);
return copy_normalize(tc, zp, yl+1, 1);
}
}
}
@ -1945,13 +1972,13 @@ ptr S_logxor(x, y) ptr x, y; {
return (ptr)((iptr)x ^ (iptr)(y));
} else {
iptr xl; IBOOL xs;
FIXNUM_TO_BIGNUM(X(tc),x,&xl,&xs)
FIXNUM_TO_BIGNUM(tc,X(tc),x,&xl,&xs)
return big_logxor(tc, y, X(tc), BIGLEN(y), xl, BIGSIGN(y), xs);
}
} else {
if (Sfixnump(y)) {
iptr yl; IBOOL ys;
FIXNUM_TO_BIGNUM(Y(tc),y,&yl,&ys)
FIXNUM_TO_BIGNUM(tc,Y(tc),y,&yl,&ys)
return big_logxor(tc, x, Y(tc), BIGLEN(x), yl, BIGSIGN(x), ys);
} else {
if (BIGLEN(x) >= BIGLEN(y))
@ -1980,15 +2007,15 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
if (xs == 0) {
if (ys == 0) {
PREPARE_BIGNUM(W(tc),xl);
PREPARE_BIGNUM(tc, W(tc),xl);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
for (i = yl; i > 0; i -= 1) *--zp = *--xp ^ *--yp;
for (i = xl - yl; i > 0; i -= 1) *--zp = *--xp;
return copy_normalize(zp, xl, 0);
return copy_normalize(tc, zp, xl, 0);
} else {
bigit yb, k;
PREPARE_BIGNUM(W(tc),xl+1);
PREPARE_BIGNUM(tc, W(tc),xl+1);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
k = yb = 1;
for (i = yl; i > 0; i -= 1) {
@ -2005,13 +2032,13 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, xl+1, 1);
return copy_normalize(tc, zp, xl+1, 1);
}
} else {
if (ys == 0) {
bigit xb, k;
PREPARE_BIGNUM(W(tc),xl+1);
PREPARE_BIGNUM(tc, W(tc),xl+1);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl+1);
k = xb = 1;
for (i = yl; i > 0; i -= 1) {
@ -2029,11 +2056,11 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
*--zp = z2;
}
*--zp = k;
return copy_normalize(zp, xl+1, 1);
return copy_normalize(tc, zp, xl+1, 1);
} else {
bigit xb, yb;
PREPARE_BIGNUM(W(tc),xl);
PREPARE_BIGNUM(tc, W(tc),xl);
xp = &BIGIT(x,xl); yp = &BIGIT(y,yl); zp = &BIGIT(W(tc),xl);
yb = xb = 1;
for (i = yl; i > 0; i -= 1) {
@ -2047,7 +2074,7 @@ static ptr big_logxor(tc, x, y, xl, yl, xs, ys) ptr tc, x, y; iptr xl, yl; IBOOL
x1 = *--xp; x2 = x1 - xb; xb = x2 > x1;
*--zp = x2;
}
return copy_normalize(zp, xl, 0);
return copy_normalize(tc, zp, xl, 0);
}
}
}

4
c/prim5.c
View File

@ -166,7 +166,7 @@ static iptr s_fxdiv(x, y) iptr x, y; {
static ptr s_trunc_rem(x, y) ptr x, y; {
ptr q, r;
S_trunc_rem(x, y, &q, &r);
S_trunc_rem(get_thread_context(), x, y, &q, &r);
return Scons(q, r);
}
@ -1596,6 +1596,7 @@ void S_prim5_init() {
Sforeign_symbol("(cs)lognot", (void *)S_lognot);
Sforeign_symbol("(cs)fxmul", (void *)s_fxmul);
Sforeign_symbol("(cs)fxdiv", (void *)s_fxdiv);
Sforeign_symbol("(cs)s_big_negate", (void *)S_big_negate);
Sforeign_symbol("(cs)add", (void *)S_add);
Sforeign_symbol("(cs)gcd", (void *)S_gcd);
Sforeign_symbol("(cs)mul", (void *)S_mul);
@ -1627,6 +1628,7 @@ void S_prim5_init() {
#else
Sforeign_symbol("(cs)directory_list", (void *)S_directory_list);
#endif
Sforeign_symbol("(cs)dequeue_scheme_signals", (void *)S_dequeue_scheme_signals);
Sforeign_symbol("(cs)register_scheme_signal", (void *)S_register_scheme_signal);
Sforeign_symbol("(cs)exp", (void *)s_exp);

2
c/print.c
View File

@ -282,7 +282,7 @@ static void pbignum(x) ptr x; {
static void wrint(x) ptr x; {
ptr q, r;
S_trunc_rem(x, FIX(10), &q, &r);
S_trunc_rem(get_thread_context(), x, FIX(10), &q, &r);
if (q != 0) wrint(q);
putchar((INT)UNFIX(r) + '0');
}

95
c/schsig.c
View File

@ -501,16 +501,24 @@ void S_noncontinuable_interrupt() {
}
#ifdef WIN32
ptr S_dequeue_scheme_signals(ptr tc) {
return Snil;
}
ptr S_allocate_scheme_signal_queue() {
return (ptr)0;
}
void S_register_scheme_signal(sig) iptr sig; {
S_error("register_scheme_signal", "unsupported in this version");
}
/* code courtesy Bob Burger, burgerrg@sagian.com
We cannot call noncontinuable_interrupt, because we are not allowed
to perform a longjmp inside a signal handler; instead, we don't
handle the signal, which will cause the process to terminate.
*/
void S_register_scheme_signal(sig) iptr sig; {
S_error("register_scheme_signal", "unsupported in this version");
}
static BOOL WINAPI handle_signal(DWORD dwCtrlType) {
switch (dwCtrlType) {
case CTRL_C_EVENT:
@ -538,6 +546,8 @@ static void init_signal_handlers() {
#include <signal.h>
static void handle_signal PROTO((INT sig, siginfo_t *si, void *data));
static IBOOL enqueue_scheme_signal PROTO((ptr tc, INT sig));
static ptr allocate_scheme_signal_queue PROTO((void));
static void forward_signal_to_scheme PROTO((INT sig));
#define RESET_SIGNAL {\
@ -547,18 +557,88 @@ static void forward_signal_to_scheme PROTO((INT sig));
sigprocmask(SIG_UNBLOCK,&set,(sigset_t *)0);\
}
/* we buffer up to SIGNALQUEUESIZE - 1 unhandled signals, the start dropping them. */
#define SIGNALQUEUESIZE 64
static IBOOL scheme_signals_registered;
/* we use a simple queue for pending signals. signals are enqueued only by the
C signal handler and dequeued only by the Scheme event handler. since the signal
handler and event handler run in the same thread, there's no need for locks
or write barriers. */
struct signal_queue {
INT head;
INT tail;
INT data[SIGNALQUEUESIZE];
};
static IBOOL enqueue_scheme_signal(ptr tc, INT sig) {
struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
/* ignore the signal if we failed to allocate the queue */
if (queue == NULL) return 0;
INT tail = queue->tail;
INT next_tail = tail + 1;
if (next_tail == SIGNALQUEUESIZE) next_tail = 0;
/* ignore the signal if the queue is full */
if (next_tail == queue->head) return 0;
queue->data[tail] = sig;
queue->tail = next_tail;
return 1;
}
ptr S_dequeue_scheme_signals(ptr tc) {
ptr ls = Snil;
struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc));
if (queue == NULL) return ls;
INT head = queue->head;
INT tail = queue->tail;
INT i = tail;
while (i != head) {
if (i == 0) i = SIGNALQUEUESIZE;
i -= 1;
ls = Scons(Sfixnum(queue->data[i]), ls);
}
queue->head = tail;
return ls;
}
static void forward_signal_to_scheme(sig) INT sig; {
ptr tc = get_thread_context();
SIGNALINTERRUPTPENDING(tc) = Sfixnum(sig);
SOMETHINGPENDING(tc) = Strue;
if (enqueue_scheme_signal(tc, sig)) {
SIGNALINTERRUPTPENDING(tc) = Strue;
SOMETHINGPENDING(tc) = Strue;
}
RESET_SIGNAL
}
static ptr allocate_scheme_signal_queue() {
/* silently fail to allocate space for signals if malloc returns NULL */
struct signal_queue *queue = malloc(sizeof(struct signal_queue));
if (queue != (struct signal_queue *)0) {
queue->head = queue->tail = 0;
}
return (ptr)queue;
}
ptr S_allocate_scheme_signal_queue() {
return scheme_signals_registered ? allocate_scheme_signal_queue() : (ptr)0;
}
void S_register_scheme_signal(sig) iptr sig; {
struct sigaction act;
sigemptyset(&act.sa_mask);
tc_mutex_acquire()
if (!scheme_signals_registered) {
ptr ls;
scheme_signals_registered = 1;
for (ls = S_threads; ls != Snil; ls = Scdr(ls)) {
SIGNALINTERRUPTQUEUE(THREADTC(Scar(ls))) = S_allocate_scheme_signal_queue();
}
}
tc_mutex_release()
sigfillset(&act.sa_mask);
act.sa_flags = 0;
act.sa_handler = forward_signal_to_scheme;
sigaction(sig, &act, (struct sigaction *)0);
@ -690,6 +770,7 @@ void S_schsig_init() {
S_protect(&S_G.error_id);
S_G.error_id = S_intern((const unsigned char *)"$c-error");
scheme_signals_registered = 0;
}

2
c/thread.c
View File

@ -95,6 +95,7 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; {
TIMERTICKS(tc) = Sfalse;
DISABLECOUNT(tc) = Sfixnum(0);
SIGNALINTERRUPTPENDING(tc) = Sfalse;
SIGNALINTERRUPTQUEUE(tc) = S_allocate_scheme_signal_queue();
KEYBOARDINTERRUPTPENDING(tc) = Sfalse;
TARGETMACHINE(tc) = S_intern((const unsigned char *)MACHINE_TYPE);
@ -227,6 +228,7 @@ static IBOOL destroy_thread(tc) ptr tc; {
}
if (LZ4OUTBUFFER(tc) != NULL) free(LZ4OUTBUFFER(tc));
if (SIGNALINTERRUPTQUEUE(tc) != NULL) free(SIGNALINTERRUPTQUEUE(tc));
free((void *)tc);
THREADTC(thread) = 0; /* mark it dead */

2
csug/io.stex
View File

@ -1020,7 +1020,7 @@ be significantly smaller.
\noindent
\scheme{compress-level} determines the amount of effort spent on
compression and is thus relevant only for output.
It can be set to one of the symbols \scheme{low},
It can be set to one of the symbols \scheme{minimum}, \scheme{low},
\scheme{medium}, \scheme{high}, or \scheme{maximum}, which are
listed in order from shortest to longest expected compression time
and least to greatest expected effectiveness.

59
csug/libraries.stex
View File

@ -896,6 +896,57 @@ cannot be proven immutable, which inhibits important optimizations such
as procedure inlining.
This can result in significantly lower run-time performance.
\section{Explicitly invoking libraries\label{SECTLIBRARYINVOCATION}}
%----------------------------------------------------------------------------
\noskipentryheader
\formdef{invoke-library}{\categoryprocedure}{(invoke-library \var{libref})}
\returns unspecified
\listlibraries
\endnoskipentryheader
\var{libref} must be an s-expression in the form of a library reference.
The syntax for library references is given in
Chapter~\ref{TSPL:CHPTLIBRARIES} of {\TSPLFOUR} and in the Revised$^6$
Report.
A library is implicitly invoked when or before some expression
outside the library (e.g., in another library or in a top-level
program) evaluates a reference to one of the library's exported
variables.
When the library is invoked, its body expressions (the right-hand-sides
of the library's variable definitions and its initialization
expressions) are evaluated.
Once invoked, the library is not invoked again within the same process,
unless it is first explicitly redefined or reloaded.
\scheme{invoke-library} explicitly invokes the library specified
by \var{libref} if it has not already been invoked or has since
been redefined or reloaded.
If the library has not yet been loaded, \scheme{invoke-library}
first loads the library via the process described in
Section~\ref{SECTUSELIBRARIES}.
\scheme{invoke-library} is typically only useful for libraries whose
body expressions have side effects.
It is useful to control when the side effects occur and to force
invocation of a library that has no exported variables.
Invoking a library does not force the compile-time code (macro
transformer expressions and meta definitions) to be loaded or
evaluated, nor does it cause the library's bindings to become
visible.
It is good practice to avoid externally visible side effects in
library bodies so the library can be used equally well at compile
time and run time.
When feasible, consider moving the side effects of a library body
to an initialization routine and adding a top-level program that
imports the library and calls the initialization routine.
With this structure, calls to \scheme{invoke-library} on the
library can be replaced by calls to
\index{\scheme{load-program}}\scheme{load-program} on the
top-level program.
\section{Library Parameters\label{SECTLIBRARYPARAMETERS}}
\index{\scheme{import}}%
@ -915,7 +966,7 @@ The parameter \scheme{library-directories} determines where the files
containing library source and object code are located in the file system,
and the parameter \scheme{library-extensions} determines the filename
extensions for the files holding the code, as described in
section~\ref{SECTUSESCRIPTING}.
section~\ref{SECTUSELIBRARIES}.
The values of both parameters are lists of pairs of strings.
The first string in each \scheme{library-directories} pair identifies a
source-file root directory, and the second identifies the corresponding
@ -974,7 +1025,7 @@ to a procedure that simply calls \scheme{compile-library}) on any imported libra
the object file is missing, older than the corresponding source file,
older than any source files included (via \index{\scheme{include}}\scheme{include}) when the
object file was created, or itself requires a library that has or must
be recompiled, as described in Section~\ref{SECTUSESCRIPTING}.
be recompiled, as described in Section~\ref{SECTUSELIBRARIES}.
The default initial value of this parameter is \scheme{#f}.
It can be set to \scheme{#t} via the command-line option
\index{\scheme{--compile-imported-libraries} command-line option}\scheme{--compile-imported-libraries}.
@ -1056,7 +1107,7 @@ The set of libraries initially defined includes those listed in
Section~\ref{SECTBUILTINLIBRARIES} above.
%----------------------------------------------------------------------------
\noskipentryheader
\entryheader
\formdef{library-version}{\categoryprocedure}{(library-version \var{libref})}
\returns the version of the specified library
\formdef{library-exports}{\categoryprocedure}{(library-exports \var{libref})}
@ -1068,7 +1119,7 @@ Section~\ref{SECTBUILTINLIBRARIES} above.
\formdef{library-object-filename}{\categoryprocedure}{(library-object-filename \var{libref})}
\returns the name of the object file holding the specified library, if any
\listlibraries
\endnoskipentryheader
\endentryheader
Information can be obtained only for built-in libraries or libraries
previously loaded into the system.

4
csug/objects.stex
View File

@ -1180,9 +1180,7 @@ the uncompressed size and the compression mode. The result does not include
the header that is written by port-based compression using the
\scheme{compressed} option. The compression format is determined by the
\index{\scheme{compress-format}}\scheme{compress-format}
parameter.
The compression level is fixed to some default determined by the
format; it is not affected by the
parameter, and the compression level is determined by the
\index{\scheme{compress-level}}\scheme{compress-level}
parameter.

24
csug/system.stex
View File

@ -521,6 +521,8 @@ It is generally not a good idea, therefore, to establish handlers for
memory faults, illegal instructions, and the like, since the code that
causes the fault or illegal instruction will continue to execute
(presumably erroneously) for some time before the handler is invoked.
A finite amount of storage is used to buffer as-yet unhandled
signals, after which additional signals are dropped.
\scheme{register-signal-handler} is supported only on Unix-based
systems.
@ -1422,7 +1424,23 @@ The libraries incorporated into the resulting object file are visible (for
use by \scheme{environment} and \scheme{eval}) if the \var{libs-visible?}
argument is supplied and non-false.
Any library incorporated into the resulting object file and required by
an object file left to be loaded at run time is also visible.
an object file left to be loaded at run time is also visible, as are any
libraries the object file depends upon, regardless of the value of
\var{libs-visible?}.
\scheme{compile-whole-program} linearizes the initialization code for the
set of incorporated libraries in a way that respects static
dependencies among the libraries but not necessary dynamic dependencies
deriving from initialization-time uses of \scheme{environment}
or \scheme{eval}.
Additional static dependencies can be added in most cases to force
an ordering that allows the dynamic imports to succeed,
though not in general since a different order might be required each
time the program is run.
Adding a static dependency of one library on a second requires
adding an import of the second in the first as well as a run-time
reference to one of the variables exported by the second in the
body of the first.
\var{input-filename} and \var{output-filename} must be strings.
\var{input-filename} must identify a wpo file, and a wpo or object
@ -1460,6 +1478,10 @@ all libraries are automatically made visible, and a new wpo file is
produced (when \scheme{generate-wpo-files} is \scheme{#t}) as well
as an object file for the resulting combination of libraries.
The comment in the description of \scheme{compile-whole-program}
about the effect of initialization-code linearization on dynamic
dependencies applies to \scheme{compile-whole-library} as well.
%----------------------------------------------------------------------------
\entryheader
\formdef{compile-port}{\categoryprocedure}{(compile-port \var{input-port} \var{output-port})}

664
mats/5_3.ms
View File

@ -2877,6 +2877,107 @@
(eqv? (ash #x-8000000000000000 -31) #x-100000000)
(eqv? (ash #x-8000000000000000 -32) #x-80000000)
(eqv? (ash #x-8000000000000000 -33) #x-40000000)
(begin
(define ($test-right-shift srl)
(define ($go q x n expected)
(let ([got (srl x n)])
(unless (eqv? got expected)
(syntax-error q (format "expected ~x, got ~x" expected got)))))
(define-syntax go
(lambda (q)
(syntax-case q ()
[(_ x n expected) #`($go #'#,q x n expected)])))
(let* ([$x (expt 2 1024)]
[$-x (- $x)]
[$x+1 (+ $x 1)]
[$-x-1 (- $x+1)]
[$x-1 (- $x 1)]
[$-x+1 (- $x-1)]
[$x+8 (+ $x 8)]
[$-x-8 (- $x+8)]
[$x+2^31 (+ $x (expt 2 32))]
[$-x-2^31 (- $x+2^31)]
[$x+2^32 (+ $x (expt 2 32))]
[$-x-2^32 (- $x+2^32)]
[$x+2^40 (+ $x (expt 2 40))]
[$-x-2^40 (- $x+2^40)]
[$x+2^63 (+ $x (expt 2 63))]
[$-x-2^63 (- $x+2^63)]
[$x+2^65 (+ $x (expt 2 65))]
[$-x-2^65 (- $x+2^65)]
[$x*3/2 (ash 3 1023)]
[$-x*3/2 (- $x*3/2)]
; answers
[$2^64 (expt 2 64)]
[$-2^64 (- $2^64)]
[$-2^64-1 (- -1 $2^64)]
[$x>>64 (expt 2 (- 1024 64))]
[$-x>>64 (- $x>>64)]
[$-x>>64-1 (- -1 $x>>64)]
[$x>>64+2 (+ $x>>64 2)]
[$-x>>64-2 (- $x>>64+2 )]
[$x>>80 (expt 2 (- 1024 80))]
[$-x>>80 (- $x>>80)]
[$-x>>80-1 (- -1 $x>>80)]
)
(go $x 1024 1)
(go $-x 1024 -1)
(go $x 1025 0)
(go $-x 1025 -1)
(go $x+1 1024 1)
(go $-x-1 1024 -2)
(go $x+1 1025 0)
(go $-x-1 1025 -1)
(go $x (- 1024 64) $2^64)
(go $-x (- 1024 64) $-2^64)
(go $x+1 (- 1024 64) $2^64)
(go $-x-1 (- 1024 64) $-2^64-1)
(go $x+8 (- 1024 64) $2^64)
(go $-x-8 (- 1024 64) $-2^64-1)
(go $x+2^32 (- 1024 64) $2^64)
(go $-x-2^32 (- 1024 64) $-2^64-1)
(go $x+2^65 (- 1024 64) $2^64)
(go $-x-2^65 (- 1024 64) $-2^64-1)
(go $x 64 $x>>64)
(go $-x 64 $-x>>64)
(go $x+1 64 $x>>64)
(go $-x-1 64 $-x>>64-1)
(go $x+8 64 $x>>64)
(go $-x-8 64 $-x>>64-1)
(go $x+2^31 64 $x>>64)
(go $-x-2^31 64 $-x>>64-1)
(go $x+2^40 64 $x>>64)
(go $-x-2^40 64 $-x>>64-1)
(go $x+2^63 64 $x>>64)
(go $-x-2^63 64 $-x>>64-1)
(go $x+2^65 64 $x>>64+2)
(go $-x-2^65 64 $-x>>64-2)
(go $x 80 $x>>80)
(go $-x 80 $-x>>80)
(go $x+1 80 $x>>80)
(go $-x-1 80 $-x>>80-1)
(go $x+8 80 $x>>80)
(go $-x-8 80 $-x>>80-1)
(go $x+2^31 80 $x>>80)
(go $-x-2^31 80 $-x>>80-1)
(go $x+2^32 80 $x>>80)
(go $-x-2^32 80 $-x>>80-1)
(go $x+2^40 80 $x>>80)
(go $-x-2^40 80 $-x>>80-1)
(go $x+2^63 80 $x>>80)
(go $-x-2^63 80 $-x>>80-1)
(go $x+2^65 80 $x>>80)
(go $-x-2^65 80 $-x>>80-1)
(go $x*3/2 1023 3)
(go $-x*3/2 1023 -3)
(go $x*3/2 1024 1)
(go $-x*3/2 1024 -2)
(go $x*3/2 1025 0)
(go $-x*3/2 1025 -1)
)
#t)
#t)
($test-right-shift (lambda (x n) (ash x (- n))))
)
(mat bitwise-arithmetic-shift
@ -2922,6 +3023,7 @@
(eqv? (bitwise-arithmetic-shift #x-8000000000000000 -31) #x-100000000)
(eqv? (bitwise-arithmetic-shift #x-8000000000000000 -32) #x-80000000)
(eqv? (bitwise-arithmetic-shift #x-8000000000000000 -33) #x-40000000)
($test-right-shift (lambda (x n) (bitwise-arithmetic-shift x (- n))))
)
(mat bitwise-arithmetic-shift-left/right
@ -2967,6 +3069,7 @@
(eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 31) #x-100000000)
(eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 32) #x-80000000)
(eqv? (bitwise-arithmetic-shift-right #x-8000000000000000 33) #x-40000000)
($test-right-shift (lambda (x n) (bitwise-arithmetic-shift-right x n)))
)
(mat bitwise-bit-field
@ -6277,3 +6380,564 @@
'((0 . 3/5) (0 . -3/5) (0 . 3/5) (0 . -3/5)
(5 . 2/7) (-5 . -2/7) (-5 . 2/7) (5 . -2/7)))
)
(mat special-cases ; test special cases added Feb 2020
(begin
(define $n 40910371311673474504209841881478505181983799806634563)
(define $-n (- $n))
(define $q 40910371311673474504209841881478505181983799806634563/7312893582423593745243587)
(define $-q (- $q))
(define $x 1.499423325079378e100)
(define $-x (- $x))
(define $ez 3+4i)
(define $-ez (- $ez))
(define $iz 3.0-4.0i)
(define $-iz (- $iz))
#t)
(error? ; not a number
(div-and-mod 'bogus 1))
(error? ; not a number
(div-and-mod 'bogus -1))
(error? ; domain error
(div-and-mod $n 4+3i))
(error? ; domain error
(div-and-mod 4+3i $n))
(error? ; domain error
(div-and-mod 0 0))
(error? ; domain error
(div-and-mod $n 0))
(error? ; domain error
(div-and-mod $q 0))
(error? ; not a number
(div 'bogus 1))
(error? ; not a number
(div 'bogus -1))
(error? ; domain error
(div $n 4+3i))
(error? ; domain error
(div 4+3i $n))
(error? ; domain error
(div 0 0))
(error? ; domain error
(div $n 0))
(error? ; domain error
(div $q 0))
(error? ; not a number
(mod 'bogus 1))
(error? ; not a number
(mod 'bogus -1))
(error? ; domain error
(mod $n 4+3i))
(error? ; domain error
(mod 4+3i $n))
(error? ; domain error
(mod 0 0))
(error? ; domain error
(mod $n 0))
(error? ; domain error
(mod $q 0))
(error? ; not a number
(div0-and-mod0 'bogus 1))
(error? ; not a number
(div0-and-mod0 'bogus -1))
(error? ; domain error
(div0-and-mod0 $n 4+3i))
(error? ; domain error
(div0-and-mod0 4+3i $n))
(error? ; domain error
(div0-and-mod0 0 0))
(error? ; domain error
(div0-and-mod0 $n 0))
(error? ; domain error
(div0-and-mod0 $q 0))
(error? ; not a number
(div0 'bogus 1))
(error? ; not a number
(div0 'bogus -1))
(error? ; domain error
(div0 $n 4+3i))
(error? ; domain error
(div0 4+3i $n))
(error? ; domain error
(div0 0 0))
(error? ; domain error
(div0 $n 0))
(error? ; domain error
(div0 $q 0))
(error? ; not a number
(mod0 'bogus 1))
(error? ; not a number
(mod0 'bogus -1))
(error? ; domain error
(mod0 $n 4+3i))
(error? ; domain error
(mod0 4+3i $n))
(error? ; domain error
(mod0 0 0))
(error? ; domain error
(mod0 $n 0))
(error? ; domain error
(mod0 $q 0))
(error? ; not a number
(quotient 'bogus 1))
(error? ; not a number
(quotient 'bogus -1))
(error? ; domain error
(quotient $n 4+3i))
(error? ; domain error
(quotient 4.5 $n))
(error? ; domain error
(quotient 0 0))
(error? ; domain error
(quotient $n 0))
(error? ; domain error
(quotient 4.0 0))
(error? ; not a number
(remainder 'bogus 1))
(error? ; not a number
(remainder 'bogus -1))
(error? ; domain error
(remainder $n 4+3i))
(error? ; domain error
(remainder 4.5 $n))
(error? ; domain error
(remainder 0 0))
(error? ; domain error
(remainder $n 0))
(error? ; domain error
(remainder 4.0 0))
(error? ; not a number
(modulo 'bogus 1))
(error? ; not a number
(modulo 'bogus -1))
(error? ; domain error
(modulo $n 4+3i))
(error? ; domain error
(modulo 4.5 $n))
(error? ; domain error
(modulo 0 0))
(error? ; domain error
(modulo $n 0))
(error? ; domain error
(modulo 4.0 0))
(error? ; not a number
(/ 'bogus 1))
(error? ; not a number
(/ 'bogus -1))
(error? ; domain error
(/ 0 0))
(error? ; domain error
(/ $n 0))
(error? ; domain error
(/ $q 0))
(error? ; domain error
(/ $ez 0))
(error? ; not a number
(* 'bogus 0))
(error? ; not a number
(* 'bogus 1))
(error? ; not a number
(* 'bogus -1))
(error? ; not a number
(* 0 'bogus))
(error? ; not a number
(* 1 'bogus))
(error? ; not a number
(* -1 'bogus))
(error? ; not a number
(+ 'bogus 0))
(error? ; not a number
(+ 0 'bogus))
(error? ; not a number
(- 'bogus 0))
(error? ; not a number
(- 0 'bogus))
(equal? (call-with-values (lambda () (div-and-mod $n 1)) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (div-and-mod $n -1)) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (div-and-mod $-n 1)) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (div-and-mod $-n -1)) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (values (div $n 1) (mod $n 1))) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (values (div $n -1) (mod $n -1))) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (values (div $-n 1) (mod $n 1))) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (values (div $-n -1) (mod $n -1))) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (div0-and-mod0 $n 1)) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (div0-and-mod0 $n -1)) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (div0-and-mod0 $-n 1)) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (div0-and-mod0 $-n -1)) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (values (div0 $n 1) (mod0 $n 1))) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (values (div0 $n -1) (mod0 $n -1))) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (values (div0 $-n 1) (mod0 $n 1))) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (values (div0 $-n -1) (mod0 $n -1))) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (values (quotient $n 1) (remainder $n 1))) cons) `(,$n . 0))
(equal? (call-with-values (lambda () (values (quotient $n -1) (remainder $n -1))) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (values (quotient $-n 1) (remainder $n 1))) cons) `(,$-n . 0))
(equal? (call-with-values (lambda () (values (quotient $-n -1) (remainder $n -1))) cons) `(,$n . 0))
(equal? (modulo $n 1) 0)
(equal? (modulo $n -1) 0)
(equal? (modulo $-n 1) 0)
(equal? (modulo $-n -1) 0)
(equal? (/ $n 1) $n)
(equal? (/ $n -1) $-n)
(equal? (/ $-n 1) $-n)
(equal? (/ $-n -1) $n)
(equal? (/ 0 $n) 0)
(equal? (/ 0 $-n) 0)
(equal? (/ $q 1) $q)
(equal? (/ $q -1) $-q)
(equal? (/ $-q 1) $-q)
(equal? (/ $-q -1) $q)
(equal? (/ $x 1) $x)
(equal? (/ $x -1) $-x)
(equal? (/ $-x 1) $-x)
(equal? (/ $-x -1) $x)
(equal? (/ $ez 1) $ez)
(equal? (/ $ez -1) $-ez)
(equal? (/ $-ez 1) $-ez)
(equal? (/ $-ez -1) $ez)
(equal? (/ $iz 1) $iz)
(equal? (/ $iz -1) $-iz)
(equal? (/ $-iz 1) $-iz)
(equal? (/ $-iz -1) $iz)
(equal? (* $n 1) $n)
(equal? (* $n -1) $-n)
(equal? (* $-n 1) $-n)
(equal? (* $-n -1) $n)
(equal? (* $n 0) 0)
(equal? (* $-n 0) 0)
(equal? (* $q 1) $q)
(equal? (* $q -1) $-q)
(equal? (* $-q 1) $-q)
(equal? (* $-q -1) $q)
(equal? (* $q 0) 0)
(equal? (* $-q 0) 0)
(equal? (* $x 1) $x)
(equal? (* $x -1) $-x)
(equal? (* $-x 1) $-x)
(equal? (* $-x -1) $x)
(equal? (* $x 0) 0)
(equal? (* $-x 0) 0)
(equal? (* $ez 1) $ez)
(equal? (* $ez -1) $-ez)
(equal? (* $-ez 1) $-ez)
(equal? (* $-ez -1) $ez)
(equal? (* $ez 0) 0)
(equal? (* $-ez 0) 0)
(equal? (* $iz 1) $iz)
(equal? (* $iz -1) $-iz)
(equal? (* $-iz 1) $-iz)
(equal? (* $-iz -1) $iz)
(equal? (* $iz 0) 0)
(equal? (* $-iz 0) 0)
(equal? (* 1 $n) $n)
(equal? (* -1 $n) $-n)
(equal? (* 1 $-n) $-n)
(equal? (* -1 $-n) $n)
(equal? (* 0 $n) 0)
(equal? (* 0 $-n) 0)
(equal? (* 1 $q) $q)
(equal? (* -1 $q) $-q)
(equal? (* 1 $-q) $-q)
(equal? (* -1 $-q) $q)
(equal? (* 0 $q) 0)
(equal? (* 0 $-q) 0)
(equal? (* 1 $x) $x)
(equal? (* -1 $x) $-x)
(equal? (* 1 $-x) $-x)
(equal? (* -1 $-x) $x)
(equal? (* 0 $x) 0)
(equal? (* 0 $-x) 0)
(equal? (* 1 $ez) $ez)
(equal? (* -1 $ez) $-ez)
(equal? (* 1 $-ez) $-ez)
(equal? (* -1 $-ez) $ez)
(equal? (* 0 $ez) 0)
(equal? (* 0 $-ez) 0)
(equal? (* 1 $iz) $iz)
(equal? (* -1 $iz) $-iz)
(equal? (* 1 $-iz) $-iz)
(equal? (* -1 $-iz) $iz)
(equal? (* 0 $iz) 0)
(equal? (* 0 $-iz) 0)
(equal? (+ $n 0) $n)
(equal? (+ $-n 0) $-n)
(equal? (+ 0 $n) $n)
(equal? (+ 0 $-n) $-n)
(equal? (+ $q 0) $q)
(equal? (+ $-q 0) $-q)
(equal? (+ 0 $q) $q)
(equal? (+ 0 $-q) $-q)
(equal? (+ $x 0) $x)
(equal? (+ $-x 0) $-x)
(equal? (+ 0 $x) $x)
(equal? (+ 0 $-x) $-x)
(equal? (+ $ez 0) $ez)
(equal? (+ $-ez 0) $-ez)
(equal? (+ 0 $ez) $ez)
(equal? (+ 0 $-ez) $-ez)
(equal? (+ $iz 0) $iz)
(equal? (+ $-iz 0) $-iz)
(equal? (+ 0 $iz) $iz)
(equal? (+ 0 $-iz) $-iz)
(equal? (- $n 0) $n)
(equal? (- $-n 0) $-n)
(equal? (- 0 $n) $-n)
(equal? (- 0 $-n) $n)
(equal? (- $q 0) $q)
(equal? (- $-q 0) $-q)
(equal? (- 0 $q) $-q)
(equal? (- 0 $-q) $q)
(equal? (- $x 0) $x)
(equal? (- $-x 0) $-x)
(equal? (- 0 $x) $-x)
(equal? (- 0 $-x) $x)
(equal? (- $ez 0) $ez)
(equal? (- $-ez 0) $-ez)
(equal? (- 0 $ez) $-ez)
(equal? (- 0 $-ez) $ez)
(equal? (- $iz 0) $iz)
(equal? (- $-iz 0) $-iz)
(equal? (- 0 $iz) $-iz)
(equal? (- 0 $-iz) $iz)
(equal? (- 0 (most-negative-fixnum)) (+ (most-positive-fixnum) 1))
)
(mat benchmarks
(let ()
; revert to the original values for benchmarking
(define runs 1 #;10)
(define iter 1 #;100000)
(define min-ns 0 #;#e25e7)
(define time->ns
(lambda (t)
(+ (* (time-second t) 1000000000) (time-nanosecond t))))
(define mean
(lambda (ls)
(assert (not (null? ls)))
(/ (apply + ls) (length ls))))
(define stddev
(lambda (m ls)
(define (square x) (* x x))
(sqrt (mean (map (lambda (x) (square (- x m))) ls)))))
(define ($run-one expr th expected)
(define (do-big-iter)
(collect 0 0)
(let ([t0 (current-time 'time-monotonic)])
(do ([iter iter (#3%fx- iter 1)] [ans #f (th)])
((#3%fx= iter 0)
(let ([t (time-difference t0 (current-time 'time-monotonic))])
(unless (equal? ans expected) (errorf #f "oops ~s != ~s for ~s" ans expected expr))
t)))))
(parameterize ([collect-request-handler void])
(collect (collect-maximum-generation))
; warm up and calibrate number of ITERATIONS to at least meet min-ns
(let ([ITER (let loop ([ITER 1] [t (make-time 'time-duration 0 0)])
(let ([t (time-difference t (do-big-iter))])
(if (>= (time->ns t) min-ns)
ITER
(loop (fx+ ITER 1) t))))])
(do ([run runs (#3%fx- run 1)]
[t* '() (cons
(let loop ([ITER ITER] [t (make-time 'time-duration 0 0)])
(do ([ITER ITER (#3%fx- ITER 1)]
[t (make-time 'time-duration 0 0) (time-difference t (do-big-iter))])
((#3%fx= ITER 0) t)))
t*)])
((#3%fx= run 0)
(let ([ns* (map time->ns (reverse t*))])
(let ([m (mean ns*)])
(printf "~s\n" (vector expr (/ m ITER) (if (= m 0) 0 (/ (stddev m ns*) m)) ITER))
(flush-output-port))))))))
(let ()
(define (run sra)
(define-syntax run-one
(lambda (x)
(define prettify
(lambda (x)
(let-values ([(neg? x) (if (< x 0) (values #t (- x)) (values #f x))])
(let ([s (format "~{~a~^+~}"
(let loop ([x x] [k 0] [ls '()])
(let ([b (bitwise-first-bit-set x)])
(if (= b -1)
ls
(let ([k (+ k b)])
(loop (bitwise-arithmetic-shift-right x (fx+ b 1)) (fx+ k 1)
(cons (if (= k 0) "1" (format "2^~a" k)) ls)))))))])
(if neg? (format "-(~a)" s) s)))))
(syntax-case x ()
[(_ sra x k expected)
(with-syntax ([n (eval (datum x))])
(with-syntax ([expr (format "(sra ~a ~s)" (prettify (datum n)) (datum k))])
#'($run-one expr (lambda () (sra n k)) expected)))])))
(printf "((iter . ~s) (min-ns . ~s))\n" iter min-ns)
(printf "(\n")
(run-one sra 1 1 0)
(run-one sra (ash 1 1024) 1024 1)
(run-one sra (ash 1 1024) 512 (ash 1 512))
(run-one sra (- (ash 1 1024)) 1024 -1)
(run-one sra (- (ash 1 1024)) 512 (- (ash 1 512)))
(run-one sra (+ (ash 1 1024) 1) 1024 1)
(run-one sra (+ (ash 1 1024) 1) 512 (ash 1 512))
(run-one sra (- (+ (ash 1 1024) 1)) 1024 -2)
(run-one sra (- (+ (ash 1 1024) 1)) 512 (- -1 (ash 1 512)))
(run-one sra (- (ash 1 1024)) 1024 -1)
(run-one sra (- (ash 1 1024)) 512 (- (ash 1 512)))
(run-one sra (ash 1 1024) 1025 0)
(run-one sra (- (ash 1 1024)) 1025 -1)
(run-one sra (ash 3 1023) 1024 1)
(run-one sra (- (ash 3 1023)) 1024 -2)
(run-one sra (ash 3 1023) 1025 0)
(run-one sra (- (ash 3 1023)) 1025 -1)
(run-one sra (ash 1 1000000) 1000000 1)
(run-one sra (- (ash 1 1000000)) 1000000 -1)
(run-one sra (ash 1 1000000) 1000001 0)
(run-one sra (- (ash 1 1000000)) 1000001 -1)
(run-one sra (ash 3 1000000) 1000001 1)
(run-one sra (- (ash 3 1000000)) 1000001 -2)
(run-one sra (ash 3 1000000) 1000002 0)
(run-one sra (- (ash 3 1000000)) 1000002 -1)
; worst-case---only shifted-off one bit is in the middle
(run-one sra (- (+ (ash 1 1024) (ash 1 512))) 1024 -2)
; shift by one bit
(run-one sra (ash 3 1000000) 1 (ash 3 999999))
(run-one sra (- (ash 3 1000000)) 1 (- (ash 3 999999)))
(printf ")\n"))
(run bitwise-arithmetic-shift-right)
(run (lambda (x k) (bitwise-arithmetic-shift x (- k))))
(run (lambda (x k) (ash x (- k)))))
(let ()
(define (run)
(define $x 123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789)
(define $y (* (most-positive-fixnum) 2))
(define-syntax run-one
(syntax-rules ()
[(_ expr expected)
($run-one 'expr (lambda () expr) expected)]
[(_ expr expected ...)
($run-one 'expr (lambda () (call-with-values (lambda () expr) list)) (list expected ...))]))
(define $2x (* 2 $x))
(define $x+2 (+ $x 2))
(define $-x (- $x))
(define $x^4 (* $x $x $x $x))
(define $-x^4 (- $x^4))
(define $2y (* $y 2))
(define $y+2 (+ $y 2))
(printf "((iter . ~s) (min-ns . ~s) ($x . ~s) ($y . ~s))\n" iter min-ns $x $y)
(printf "(\n")
(run-one 0 0)
(run-one (* $x 0) 0)
(run-one (* $x^4 0) 0)
(run-one (* $x 1) $x)
(run-one (* $x^4 1) $x^4)
(run-one (* $x -1) $-x)
(run-one (* $x^4 -1) $-x^4)
(run-one (* 1 $x) $x)
(run-one (* 1 $x^4) $x^4)
(run-one (* -1 $x) $-x)
(run-one (* -1 $x^4) $-x^4)
(run-one (/ $x 1) $x)
(run-one (/ $x^4 1) $x^4)
(run-one (/ $x -1) $-x)
(run-one (/ $x^4 -1) $-x^4)
(run-one (+ $x 0) $x)
(run-one (+ $x^4 0) $x^4)
(run-one (- $x 0) $x)
(run-one (- $x^4 0) $x^4)
(run-one (+ 0 $x) $x)
(run-one (+ 0 $x^4) $x^4)
(run-one (- 0 $x) $-x)
(run-one (- 0 $x^4) $-x^4)
(run-one (quotient $x 1) $x)
(run-one (quotient $x^4 1) $x^4)
(run-one (quotient $x -1) $-x)
(run-one (remainder $x 1) 0)
(run-one (remainder $x^4 1) 0)
(run-one (remainder $x -1) 0)
(run-one (div-and-mod $x 1) $x 0)
(run-one (div-and-mod $x^4 1) $x^4 0)
(run-one (div-and-mod $x -1) $-x 0)
(run-one (div0-and-mod0 $x 1) $x 0)
(run-one (div0-and-mod0 $x^4 1) $x^4 0)
(run-one (div0-and-mod0 $x -1) $-x 0)
(run-one (div $x 1) $x)
(run-one (div $x^4 1) $x^4)
(run-one (div $x -1) $-x)
(run-one (div0 $x 1) $x)
(run-one (div0 $x^4 1) $x^4)
(run-one (div0 $x -1) $-x)
(run-one (mod $x 1) 0)
(run-one (mod $x^4 1) 0)
(run-one (mod $x -1) 0)
(run-one (mod0 $x 1) 0)
(run-one (mod0 $x^4 1) 0)
(run-one (mod0 $x -1) 0)
; these should not improve and we hope not slow down measurably
(run-one (* $y 2) $2y)
(run-one (/ $2y 2) $y)
(run-one (+ $y 2) $y+2)
(run-one (- $y -2) $y+2)
(run-one (quotient $y 2) (ash $y -1))
(run-one (remainder $y 2) (logand $y 1))
(run-one (div-and-mod $2y 2) $y 0)
(run-one (div0-and-mod0 $2y 2) $y 0)
(run-one (div $2y 2) $y)
(run-one (div0 $2y 2) $y)
(run-one (mod $2y 2) 0)
(run-one (mod0 $2y 2) 0)
(printf ")\n"))
(run))
; use with --program to compare results
#;(top-level-program
(import (chezscheme))
(unless (= (length (command-line-arguments)) 3)
(fprintf (current-error-port) "usage: ~a: <output-file> <before-input-file> <after-input-file>\n" (car (command-line)))
(exit 1))
(let ([reportfn (car (command-line-arguments))]
[beforefn (cadr (command-line-arguments))]
[afterfn (caddr (command-line-arguments))])
(let-values ([(before-info before) (with-input-from-file beforefn (lambda () (let ([info (read)]) (values info (read)))))]
[(after-info after) (with-input-from-file afterfn (lambda () (let ([info (read)]) (values info (read)))))])
(with-output-to-file reportfn
(lambda ()
(unless (equal? before-info after-info) (errorf #f "before info ~s and after info ~s differ" before-info after-info))
(let ([iter (cond [(assq 'iter before-info) => cdr] [else (errorf #f "expected to find binding for iter in info\n")])])
(printf "<html><head><title>Results ~a</title></head><body><table cellspacing=\"10em\">\n" (machine-type))
(printf "<p>~{~a~^<br>~}</p>" (map (lambda (a) (format "~s = ~s" (car a) (cdr a))) before-info))
(printf "<tr><th align=left>expression</th><th align=right>speedup</th><th align=right>before stddev</th><th align=right>after stddev</th><th align=right>before time (x~s)</th><th align=right>after time (x~s)</th><th align=right>before iterations</th><th align=right>after iterations</th></tr>\n" iter iter)
(for-each
(lambda (before after)
(define EXPR 0)
(define MEAN-NS 1)
(define STDDEV 2)
(define ITER 3)
(for-each
(lambda (i)
(unless (equal? (vector-ref before i) (vector-ref after i))
(errorf #f "comparing apples to oranges: ~s, ~s" before after)))
(list EXPR))
(printf "<tr><td align=left>~a</td><td align=right>~5,2f%</td><td align=right>~7,4f%</td><td align=right>~7,4f%</td><td align=right>~10,8f</td><td align=right>~10,8f</td><td align=right>~s</td><td align=right>~s</td></tr>\n"
(vector-ref before EXPR)
(* (/ (- (vector-ref before MEAN-NS) (vector-ref after MEAN-NS)) (vector-ref before MEAN-NS)) 100)
(vector-ref before STDDEV)
(vector-ref after STDDEV)
(/ (vector-ref before MEAN-NS) (expt 10 9))
(/ (vector-ref after MEAN-NS) (expt 10 9))
(vector-ref before ITER)
(vector-ref after ITER)
))
before
after)
(printf "</table></body></html>\n")))
'replace))))
#t)
)

222
mats/7.ms
View File

@ -2314,6 +2314,228 @@ evaluating module init
(error? ; invoke cycle
(separate-eval
'(load-program "testfile-wpo-b9-all.so")))
(begin
(mkfile "testfile-wpo-a10.ss"
'(library (testfile-wpo-a10)
(export ax)
(import (chezscheme))
(define ax (cons 'a '()))))
(mkfile "testfile-wpo-b10.ss"
'(library (testfile-wpo-b10)
(export bx)
(import (chezscheme) (testfile-wpo-a10))
(define bx (cons 'b ax))))
(mkfile "testfile-wpo-c10.ss"
'(library (testfile-wpo-c10)
(export cx)
(import (chezscheme) (testfile-wpo-b10))
(define cx (cons 'c bx))))
(mkfile "testfile-wpo-d10.ss"
'(import (chezscheme) (testfile-wpo-c10))
'(printf "d: cx = ~s\n" cx))
(mkfile "testfile-wpo-e10.ss"
'(import (chezscheme) (testfile-wpo-a10))
'(printf "e: ax = ~s\n" ax))
(mkfile "testfile-wpo-f10.ss"
'(import (chezscheme) (testfile-wpo-c10))
'(printf "f: cx = ~s\n" cx))
(separate-compile
'(lambda (x)
(parameterize ([generate-wpo-files #t]
[compile-imported-libraries #t])
(compile-program x)))
'wpo-d10)
(separate-compile 'compile-program 'wpo-e10)
(separate-compile 'compile-program 'wpo-f10)
#t)
; cause b10 to be excluded from the whole program
(delete-file "testfile-wpo-b10.wpo")
(equal?
(separate-eval
'(compile-whole-program "testfile-wpo-d10.wpo"
"testfile-wpo-d10-all.so" #f))
"((testfile-wpo-b10))\n")
(equal?
(separate-eval '(verify-loadability 'visit "testfile-wpo-d10-all.so"))
"")
(equal?
(separate-eval '(verify-loadability 'revisit "testfile-wpo-d10-all.so"))
"")
(equal?
(separate-eval '(verify-loadability 'load "testfile-wpo-d10-all.so"))
"")
(equal?
(separate-eval '(load-program "testfile-wpo-d10-all.so"))
"d: cx = (c b a)\n")
; library a10 must be visible for (excluded library)
; b10's benefit, so e10 can reference its export
(equal?
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(load-program "testfile-wpo-e10.so"))
"d: cx = (c b a)\ne: ax = (a)\n")
; library c10 need not and should not be visible, so f10
; shouldn't be able to reference its export.
(error?
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(load-program "testfile-wpo-f10.so")))
(error? ; testfile-wpo-c10 is not visible
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(import (testfile-wpo-c10))))
(equal?
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(verify-loadability 'visit "testfile-wpo-f10.so"))
"d: cx = (c b a)\n")
; verify-loadability should error out trying to invoke
; c10 because c10 is not visible
(error? ; not visible
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(verify-loadability 'revisit "testfile-wpo-f10.so")))
(error? ; not visible
(separate-eval
'(load-program "testfile-wpo-d10-all.so")
'(verify-loadability 'load "testfile-wpo-f10.so")))
(begin
(mkfile "testfile-wpo-a11.ss"
'(library (testfile-wpo-a11)
(export ax)
(import (chezscheme))
(define ax (cons 'a '()))
(printf "invoking a\n")))
(parameterize ([generate-wpo-files #t])
(compile-library "testfile-wpo-a11"))
#t)
(equal?
(compile-whole-library "testfile-wpo-a11.wpo" "testfile-wpo-a11-all.so")
'())
(equal?
(separate-eval
'(load-library "testfile-wpo-a11.so"))
"")
(equal?
(separate-eval
'(load-library "testfile-wpo-a11.so")
'(let () (import (testfile-wpo-a11)) ax))
"invoking a\n(a)\n")
(equal?
(separate-eval
'(load-library "testfile-wpo-a11-all.so"))
"")
(equal?
(separate-eval
'(load-library "testfile-wpo-a11-all.so")
'(let () (import (testfile-wpo-a11)) ax))
"invoking a\n(a)\n")
(begin
(mkfile "testfile-wpo-a12.ss"
'(library (testfile-wpo-a12)
(export ax)
(import (chezscheme))
(define ax (cons 'a '()))))
(mkfile "testfile-wpo-b12.ss"
'(library (testfile-wpo-b12)
(export bx)
(import (chezscheme) (testfile-wpo-a12))
(define bx (eval 'cx (environment '(testfile-wpo-c12))))))
(mkfile "testfile-wpo-c12.ss"
'(library (testfile-wpo-c12)
(export cx)
(import (chezscheme) (testfile-wpo-b12))
(define cx (cons 'c bx))))
(mkfile "testfile-wpo-d12.ss"
'(import (chezscheme) (testfile-wpo-c12))
'(printf "d: cx = ~s\n" cx))
(parameterize ([generate-wpo-files #t]
[compile-imported-libraries #t])
(compile-program "testfile-wpo-d12"))
#t)
(error? ; cyclc
(separate-eval '(load-program "testfile-wpo-d12.so")))
; cause b12 to be excluded from the whole library and program
(delete-file "testfile-wpo-b12.wpo")
(equal?
(separate-eval
'(compile-whole-library "testfile-wpo-c12.wpo"
"testfile-wpo-c12-all.so"))
"((testfile-wpo-b12))\n")
(equal?
(separate-eval
'(compile-whole-program "testfile-wpo-d12.wpo"
"testfile-wpo-d12-all.so" #t))
"((testfile-wpo-b12))\n")
(equal?
(separate-eval
'(load-library "testfile-wpo-c12-all.so"))
"")
(error? ; cycle
(separate-eval
'(load-library "testfile-wpo-c12-all.so")
'(let () (import (testfile-wpo-c12)) cx)))
(error? ; cycle
(separate-eval '(load-program "testfile-wpo-d12-all.so")))
; verify-loadability doesn't catch (dynamic) cycles
(equal?
(separate-eval
'(verify-loadability 'visit "testfile-wpo-c12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'revisit "testfile-wpo-c12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'load "testfile-wpo-c12.so"))
"")
; verify-loadability doesn't catch (dynamic) cycles
(equal?
(separate-eval
'(verify-loadability 'visit "testfile-wpo-d12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'revisit "testfile-wpo-d12.so"))
"")
(equal?
(separate-eval
'(verify-loadability 'load "testfile-wpo-d12.so"))
"")
)
(mat compile-whole-library

78
mats/8.ms
View File

@ -9132,8 +9132,82 @@
(string-append
"123\n"
"123\n"
"Exception in visit: library (testfile-lr-l4) is not visible\n"
"Exception in visit: library (testfile-lr-l4) is not visible\n"))))
"Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"
"Exception in environment: attempt to import invisible library (testfile-lr-l4)\n"))))
(mat invoke-library
(error? ; invalid library reference
(invoke-library '(testfile-il1 (<= 3))))
(error? ; invalid library reference
(invoke-library '(testfile-il1 (what?))))
(error? ; invalid library reference
(invoke-library '()))
(error? ; invalid library reference
(invoke-library 'hello))
(error? ; invalid library reference
(invoke-library '(3 2 1)))
(begin
(mkfile "testfile-il1.ss"
'(library (testfile-il1 (2)) (export a) (import (chezscheme)) (define a 3) (printf "invoked (testfile-il1)\n")))
#t)
(equal?
(separate-eval
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\n3\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1))
'(printf "hello\n")
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\nhello\n3\n")
(equal?
(separate-eval
'(let () (import (testfile-il1)) a)
'(printf "hello\n")
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n3\nhello\n")
(begin
(separate-eval '(compile-library "testfile-il1"))
#t)
(delete-file "testfile-il1.ss")
(equal?
(separate-eval
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\n3\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1))
'(printf "hello\n")
'(let () (import (testfile-il1)) a))
"invoked (testfile-il1)\nhello\n3\n")
(equal?
(separate-eval
'(let () (import (testfile-il1)) a)
'(printf "hello\n")
'(invoke-library '(testfile-il1)))
"invoked (testfile-il1)\n3\nhello\n")
(error? ; version mismatch
(separate-eval '(invoke-library '(testfile-il1 (3)))))
(error? ; version mismatch
(separate-eval
'(invoke-library '(testfile-il1 ((>= 3))))))
(equal?
(separate-eval
'(invoke-library '(testfile-il1 ((>= 2)))))
"invoked (testfile-il1)\n")
(equal?
(separate-eval
'(invoke-library '(testfile-il1 (2))))
"invoked (testfile-il1)\n")
)
(mat cross-library-optimization
(begin

1
mats/Mf-base
View File

@ -406,6 +406,7 @@ foreign.mo ${objdir}/foreign.mo: ${fobj}
thread.mo ${objdir}/thread.mo: ${fobj}
examples.mo ${objdir}/examples.mo: m4test.in m4test.out freq.in freq.out build-examples
6.mo ${objdir}/6.mo: prettytest.ss
bytevector.mo ${objdir}/bytevector.mo: prettytest.ss
io.mo ${objdir}/io.mo: prettytest.ss
unix.mo ${objdir}/unix.mo io.mo ${objdir}/io.mo 6.mo ${objdir}/6.mo: cat_flush
oop.mo ${objdir}/oop.mo: oop.ss

3
mats/bytevector.ms
View File

@ -11275,9 +11275,8 @@
(number? (bytevector-ieee-double-native-ref immutable-100-bytevector 0))
)
(mat bytevector-compress
(parameters [compress-format 'gzip 'lz4])
(parameters [compress-format 'gzip 'lz4] [compress-level 'minimum 'low 'medium 'high 'maximum])
(error? (bytevector-compress 7))
(error? (bytevector-compress "hello"))
(error? (bytevector-uncompress 7))

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

@ -1,5 +1,5 @@
*** errors-compile-0-f-f-f 2020-01-21 14:14:21.000000000 -0800
--- errors-compile-0-f-t-f 2020-01-21 13:41:38.000000000 -0800
*** errors-compile-0-f-f-f 2020-02-11 17:27:14.000000000 -0800
--- errors-compile-0-f-t-f 2020-02-11 16:54:20.000000000 -0800
***************
*** 178,184 ****
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".
***************
*** 3794,3800 ****
*** 3873,3879 ****
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".
--- 3794,3800 ----
--- 3873,3879 ----
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".
***************
*** 7288,7295 ****
*** 7378,7385 ****
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)".
--- 7288,7295 ----
--- 7378,7385 ----
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)".
***************
*** 7297,7311 ****
*** 7387,7401 ****
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".
--- 7297,7311 ----
--- 7387,7401 ----
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".
***************
*** 7318,7343 ****
*** 7408,7433 ****
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".
--- 7318,7343 ----
--- 7408,7433 ----
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".
***************
*** 7468,7506 ****
*** 7558,7596 ****
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".
--- 7468,7506 ----
--- 7558,7596 ----
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".
***************
*** 7515,7571 ****
*** 7605,7661 ****
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".
--- 7515,7571 ----
--- 7605,7661 ----
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".

524
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 2020-01-21 14:14:21.000000000 -0800
--- errors-interpret-0-f-f-f 2020-01-21 13:57:44.000000000 -0800
*** errors-compile-0-f-f-f 2020-02-11 17:27:14.000000000 -0800
--- errors-interpret-0-f-f-f 2020-02-11 17:10:37.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----
@ -221,7 +221,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".
***************
*** 4137,4152 ****
*** 4216,4231 ****
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)".
@ -238,9 +238,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)".
--- 4143,4152 ----
--- 4222,4231 ----
***************
*** 7111,7117 ****
*** 7190,7196 ****
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 include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -248,7 +248,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".
--- 7111,7117 ----
--- 7190,7196 ----
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 include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -257,7 +257,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".
***************
*** 7479,7485 ****
*** 7569,7575 ****
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".
@ -265,7 +265,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".
--- 7479,7485 ----
--- 7569,7575 ----
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".
@ -274,7 +274,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".
***************
*** 8735,8747 ****
*** 8832,8844 ****
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".
@ -288,7 +288,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".
--- 8735,8747 ----
--- 8832,8844 ----
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".
@ -303,7 +303,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".
***************
*** 9502,9526 ****
*** 9599,9623 ****
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".
@ -329,7 +329,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".
--- 9502,9526 ----
--- 9599,9623 ----
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".
@ -356,7 +356,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".
***************
*** 9533,9564 ****
*** 9630,9661 ****
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".
@ -389,7 +389,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>".
--- 9533,9564 ----
--- 9630,9661 ----
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".
@ -423,7 +423,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>".
***************
*** 9566,9591 ****
*** 9663,9688 ****
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>".
@ -450,7 +450,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>".
--- 9566,9591 ----
--- 9663,9688 ----
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>".
@ -478,7 +478,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>".
***************
*** 9596,9630 ****
*** 9693,9727 ****
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>".
@ -514,7 +514,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>".
--- 9596,9630 ----
--- 9693,9727 ----
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>".
@ -551,7 +551,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>".
***************
*** 10231,10240 ****
*** 10328,10337 ****
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 ...)))".
@ -562,7 +562,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".
--- 10231,10240 ----
--- 10328,10337 ----
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 2020-01-21 13:41:38.000000000 -0800
--- errors-interpret-0-f-t-f 2020-01-21 14:05:55.000000000 -0800
*** errors-compile-0-f-t-f 2020-02-11 16:54:20.000000000 -0800
--- errors-interpret-0-f-t-f 2020-02-11 17:19:09.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----
@ -194,7 +194,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".
***************
*** 4137,4152 ****
*** 4216,4231 ****
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)".
@ -211,9 +211,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)".
--- 4143,4152 ----
--- 4222,4231 ----
***************
*** 7111,7117 ****
*** 7190,7196 ****
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 include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -221,7 +221,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".
--- 7111,7117 ----
--- 7190,7196 ----
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 include: file "testfile-mc-1a.ss" not found in source directories
7.mo:Expected error in mat maybe-compile: "separate-compile: Exception in include: failed for ./testfile-mc-3a.ss: no such file or directory
@ -230,7 +230,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".
***************
*** 7288,7295 ****
*** 7378,7385 ****
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".
@ -239,7 +239,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)".
--- 7288,7295 ----
--- 7378,7385 ----
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".
@ -249,7 +249,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)".
***************
*** 7297,7311 ****
*** 7387,7401 ****
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".
@ -265,7 +265,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".
--- 7297,7311 ----
--- 7387,7401 ----
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".
@ -282,7 +282,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".
***************
*** 7318,7343 ****
*** 7408,7433 ****
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>".
@ -309,7 +309,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".
--- 7318,7343 ----
--- 7408,7433 ----
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>".
@ -337,7 +337,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".
***************
*** 7468,7506 ****
*** 7558,7596 ****
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>".
@ -377,7 +377,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".
--- 7468,7506 ----
--- 7558,7596 ----
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>".
@ -418,7 +418,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".
***************
*** 7515,7571 ****
*** 7605,7661 ****
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".
@ -476,7 +476,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".
--- 7515,7571 ----
--- 7605,7661 ----
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".
@ -535,7 +535,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".
***************
*** 8735,8747 ****
*** 8832,8844 ****
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".
@ -549,7 +549,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".
--- 8735,8747 ----
--- 8832,8844 ----
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".
@ -564,7 +564,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".
***************
*** 10231,10240 ****
*** 10328,10337 ****
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 ...)))".
@ -575,7 +575,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".
--- 10231,10240 ----
--- 10328,10337 ----
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 2020-01-21 13:37:52.000000000 -0800
--- errors-interpret-3-f-f-f 2020-01-21 14:18:32.000000000 -0800
*** errors-compile-3-f-f-f 2020-02-11 16:50:22.000000000 -0800
--- errors-interpret-3-f-f-f 2020-02-11 17:31:27.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----

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

@ -1,5 +1,5 @@
*** errors-compile-3-f-t-f 2020-01-21 13:45:08.000000000 -0800
--- errors-interpret-3-f-t-f 2020-01-21 14:10:19.000000000 -0800
*** errors-compile-3-f-t-f 2020-02-11 16:57:59.000000000 -0800
--- errors-interpret-3-f-t-f 2020-02-11 17:23:14.000000000 -0800
***************
*** 1,3 ****
--- 1,9 ----

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

@ -1724,6 +1724,85 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for 0".
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for a".
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for (a)".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
5_4.mo:Expected error in mat char=?/char-ci=?: "incorrect argument count in call (char=?)".
5_4.mo:Expected error in mat char=?/char-ci=?: "char=?: a is not a character".
5_4.mo:Expected error in mat char=?/char-ci=?: "char=?: a is not a character".
@ -3687,6 +3766,62 @@ bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress:
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
profile.mo:Expected error in mat compile-profile: "compile-profile: invalid mode src [must be #f, #t, source, or block]".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump (quote ()))".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-clear (quote ()))".
@ -7132,14 +7267,21 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat eval-when: "invalid syntax revisit-x".
7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory".
7.mo:Expected error in mat compile-whole-program: "incorrect argument count in call (compile-whole-program "testfile-wpo-ab.wpo")".
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in visit: library (testfile-wpo-lib) is not visible
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in environment: attempt to import invisible library (testfile-wpo-lib)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-c5) while it is still being loaded
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c5)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-a9) while it is still being loaded
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to import invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: library (testfile-cwl-a1) not found
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install compile-time part of library (testfile-cwl-a5)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception in environment: attempting to re-install compile-time part of library (testfile-cwl-a5)
@ -8499,6 +8641,13 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-c1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously compiled
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (testfile-il1 (<= 3))".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (testfile-il1 (what?))".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference ()".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference hello".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (3 2 1)".
8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want (3) but found (2) at testfile-il1.so
8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want ((>= 3)) but found (2) at testfile-il1.so
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.ss did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl3.ss did not define library (testfile-ewl3)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl4.ss did not define library (testfile-ewl4)".

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

@ -1724,6 +1724,85 @@ primvars.mo:Expected error in mat trace-output-port: "trace-output-port: #<input
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for 0".
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for a".
5_3.mo:Expected error in mat div0-and-mod0: "mod0: undefined for (a)".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div-and-mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0-and-mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "div0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for bogus".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 4+3i".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "mod0: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "quotient: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "remainder: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: bogus is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: 4+3i is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: 4.5 is not an integer".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "modulo: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "/: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "/: undefined for 0".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "*: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "+: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
5_3.mo:Expected error in mat special-cases: "-: bogus is not a number".
5_4.mo:Expected error in mat char=?/char-ci=?: "incorrect argument count in call (char=?)".
5_4.mo:Expected error in mat char=?/char-ci=?: "char=?: a is not a character".
5_4.mo:Expected error in mat char=?/char-ci=?: "char=?: a is not a character".
@ -3687,6 +3766,62 @@ bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress:
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-compress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: 7 is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: "hello" is not a bytevector".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8()".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: invalid data in source bytevector #vu8(0 0 0 0 0 0 ...)".
bytevector.mo:Expected error in mat bytevector-compress: "bytevector-uncompress: bytevector #vu8(255 255 255 255 255 255 ...) claims invalid uncompressed size <int>".
profile.mo:Expected error in mat compile-profile: "compile-profile: invalid mode src [must be #f, #t, source, or block]".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-dump (quote ()))".
profile.mo:Expected error in mat compile-profile: "incorrect argument count in call (profile-clear (quote ()))".
@ -7132,14 +7267,21 @@ format.mo:Expected error in mat format-dollar: "format: expected real number for
7.mo:Expected error in mat eval-when: "invalid syntax revisit-x".
7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory".
7.mo:Expected error in mat compile-whole-program: "incorrect argument count in call (compile-whole-program "testfile-wpo-ab.wpo")".
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in visit: library (testfile-wpo-lib) is not visible
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in environment: attempt to import invisible library (testfile-wpo-lib)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-c5) while it is still being loaded
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c5)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke library (testfile-wpo-a9) while it is still being loaded
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-a9)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: attempt to import invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in verify-loadability: attempting to invoke invisible library (testfile-wpo-c10)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: cyclic dependency involving invocation of library (testfile-wpo-c12)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: library (testfile-cwl-a1) not found
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception: attempting to re-install compile-time part of library (testfile-cwl-a5)
7.mo:Expected error in mat compile-whole-library: "separate-eval: Exception in environment: attempting to re-install compile-time part of library (testfile-cwl-a5)
@ -8499,6 +8641,13 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-c1) requires a different compilation instance of (testfile-l7-a1) from the one previously loaded from testfile-l7-a1.so
8.mo:Expected error in mat library7: "separate-eval: Exception: compiled (testfile-l7-d1) requires a different compilation instance of (testfile-l7-a1) from the one previously compiled
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (testfile-il1 (<= 3))".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (testfile-il1 (what?))".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference ()".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference hello".
8.mo:Expected error in mat invoke-library: "invoke-library: invalid library reference (3 2 1)".
8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want (3) but found (2) at testfile-il1.so
8.mo:Expected error in mat invoke-library: "separate-eval: Exception in invoke-library: library (testfile-il1) version mismatch: want ((>= 3)) but found (2) at testfile-il1.so
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl1.ss did not define library (testfile-ewl1)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl3.ss did not define library (testfile-ewl3)".
8.mo:Expected error in mat eval-when-library: "loading testfile-ewl4.ss did not define library (testfile-ewl4)".

9
mats/unix.ms
View File

@ -160,15 +160,18 @@
(error? (register-signal-handler list 14))
(error? (register-signal-handler 14 14))
(error? (register-signal-handler list list))
(let ((x #f))
(register-signal-handler 14 (lambda (sig) (set! x sig)))
(let ((x '()))
(register-signal-handler 14 (lambda (sig) (set! x (cons sig x))))
; guard the call to system, since openbsd gets an EINTR error,
; probably in system's call to waitpid, causing s_system to
; raise an exception
(guard (c [#t (display-condition c) (printf "\nexception ignored\n")])
(system "exec kill -14 $PPID")
(system "exec kill -14 $PPID")
(system "exec kill -14 $PPID")
(system "exec kill -14 $PPID"))
(let f ((n 1000000))
(or (eqv? x 14)
(or (equal? x '(14 14 14 14))
(and (not (= n 0))
(f (- n 1))))))
)

44
release_notes/release_notes.stex
View File

@ -2,7 +2,7 @@
\thisversion{Version 9.5.3}
\thatversion{Version 8.4}
\pubmonth{January}
\pubmonth{February}
\pubyear{2020}
\begin{document}
@ -58,6 +58,16 @@ Online versions of both books can be found at
%-----------------------------------------------------------------------------
\section{Functionality Changes}\label{section:functionality}
\subsection{Bytevector compression and compression level (9.5.3)}
The procedure \scheme{bytevector-compress} now selects the level of
compression based on the \scheme{compress-level} parameter.
Prior to this it always used a default setting for compression.
The \scheme{compress-level} parameter can now take on the new value
\scheme{minimum} in addition to \scheme{low}, \scheme{medium},
\scheme{high}, and \scheme{maximum}.
\subsection{Combining object files (9.5.3)}
In previous versions of Chez Scheme, multiple object files could
@ -69,6 +79,15 @@ file. The new \scheme{concatenate-object-files} procedure can be used to
combine multiple object files while moving this information to the
top of the combined file.
\subsection{Explicitly invoking libraries (9.5.3)}
The new procedure \scheme{invoke-library} can be used to force
the evaluation of a library's body expressions (variable definition
right-hand sides and initialization expresisons) before they might
otherwise be needed.
It is generally useful only for libraries whose body expressions
have side effects.
\subsection{Verifying loadability of libraries and programs (9.5.3)}
The new procedure \scheme{verify-loadability} can be used to
@ -1818,6 +1837,16 @@ in fasl files does not generally make sense.
%-----------------------------------------------------------------------------
\section{Bug Fixes}\label{section:bugfixes}
\subsection{Buffering signals (9.5.3)}
Prior to this release, only one unhandled signal was buffered for
any signal for which a handler has been registered via
\scheme{register-signal-handler}, so two signals delivered in
quick succession could be see as only one.
The system now buffers a much larger number (63 in this release) of
signals, and the fact that signals can be dropped has now been
documented.
\subsection{Clear-output bug (9.5.3)}
A bug has been fixed in which a call to \scheme{clear-output-port}
@ -2241,6 +2270,19 @@ x86\_64 has been fixed.
%-----------------------------------------------------------------------------
\section{Performance Enhancements}\label{section:performance}
\subsection{Special-cased basic arithmetic operations (9.5.3)}
The basic arithmetic operations (addition, subtraction, multiplication,
division) are now much faster when presented with certain special
cases, e.g., multiplication of a large integer by 1 or -1 or addition
of large integer and 0.
\subsection{Faster right-shift of large integers (9.5.3)}
Right shifting a large integer is now much faster in most cases
where the shift count is a significant fraction of the number of
bits in the large integer.
\subsection{Faster object-file loading (9.5.3)}\label{sec:faster-object-file-loading}
Visiting an object file (to obtain only compile-time information and

512
s/5_3.ss
View File

@ -77,6 +77,7 @@
(define big<
(foreign-procedure "(cs)s_big_lt" (scheme-object scheme-object)
boolean))
(define big-negate (schemeop1 "(cs)s_big_negate"))
(define integer-ash (schemeop2 "(cs)s_ash"))
(define integer+ (schemeop2 "(cs)add"))
(define integer* (schemeop2 "(cs)mul"))
@ -898,6 +899,19 @@
[else (nonexact-integer-error who x)])]
[else (nonexact-integer-error who n)])))
(define $negate
(lambda (who x)
(type-case x
[(fixnum?)
(if (fx= x (most-negative-fixnum))
(let-syntax ([a (lambda (x) (- (constant most-negative-fixnum)))]) a)
(fx- x))]
[(bignum?) (big-negate x)]
[(flonum?) (fl- x)]
[(ratnum?) (integer/ (- ($ratio-numerator x)) ($ratio-denominator x))]
[($exactnum? $inexactnum?) (make-rectangular (- (real-part x)) (- (imag-part x)))]
[else (nonnumber-error who x)])))
(set! integer?
(lambda (x)
(type-case x
@ -1573,31 +1587,35 @@
[(ratnum?) (quotient ($ratio-numerator x) ($ratio-denominator x))]
[else (nonreal-error who x)])))
(set! quotient
(let ([f (lambda (x y) (truncate (/ x y)))])
(lambda (x y)
(type-case y
[(fixnum?)
(when (fx= y 0) (domain-error 'quotient y))
(set-who! quotient
(let ([f (lambda (x y) (truncate (/ x y)))])
(lambda (x y)
(type-case y
[(fixnum?)
(when (fx= y 0) (domain-error who y))
(cond
[(fx= y 1) (unless (integer? x) (noninteger-error who x)) x]
[(fx= y -1) (unless (integer? x) (noninteger-error who x)) ($negate who x)]
[else
(type-case x
[(fixnum?) (if (and (fx= y -1) (fx= x (most-negative-fixnum)))
(- (most-negative-fixnum))
(fxquotient x y))]
[(bignum?) (intquotient x y)]
[else
(unless (integer? x) (noninteger-error 'quotient x))
(f x y)])]
[(bignum?)
(type-case x
[(fixnum? bignum?) (intquotient x y)]
[else
(unless (integer? x) (noninteger-error 'quotient x))
(f x y)])]
[else
(unless (integer? y) (noninteger-error 'quotient y))
(unless (integer? x) (noninteger-error 'quotient x))
(when (= y 0) (domain-error 'quotient y))
(f x y)]))))
[(fixnum?) (if (and (fx= y -1) (fx= x (most-negative-fixnum)))
(- (most-negative-fixnum))
(fxquotient x y))]
[(bignum?) (intquotient x y)]
[else
(unless (integer? x) (noninteger-error who x))
(f x y)])])]
[(bignum?)
(type-case x
[(fixnum? bignum?) (intquotient x y)]
[else
(unless (integer? x) (noninteger-error who x))
(f x y)])]
[else
(unless (integer? y) (noninteger-error who y))
(unless (integer? x) (noninteger-error who x))
(when (= y 0) (domain-error who y))
(f x y)]))))
(set-who! div-and-mod
(lambda (x y)
@ -1609,15 +1627,19 @@
($fxdiv-and-mod x y #f)]
[(flonum?) ($fldiv-and-mod x (fixnum->flonum y))]
[(bignum?)
(when (fx= y 0) (domain-error who y))
(let ([q.r (intquotient-remainder x y)])
(if ($bigpositive? x)
(values (car q.r) (cdr q.r))
(if (eq? (cdr q.r) 0)
(values (car q.r) 0)
(if (fx< y 0)
(values (+ (car q.r) 1) (fx- (cdr q.r) y))
(values (- (car q.r) 1) (fx+ (cdr q.r) y))))))]
(cond
[(fx= y 1) (values x 0)]
[(fx= y -1) (values (big-negate x) 0)]
[else
(when (fx= y 0) (domain-error who y))
(let ([q.r (intquotient-remainder x y)])
(if ($bigpositive? x)
(values (car q.r) (cdr q.r))
(if (eq? (cdr q.r) 0)
(values (car q.r) 0)
(if (fx< y 0)
(values (+ (car q.r) 1) (fx- (cdr q.r) y))
(values (- (car q.r) 1) (fx+ (cdr q.r) y))))))])]
[(ratnum?)
(when (fx= y 0) (domain-error who y))
($exdiv-and-mod x y)]
@ -1664,14 +1686,18 @@
[(flonum?) ($fldiv x (fixnum->flonum y))]
[(bignum?)
(when (fx= y 0) (domain-error who y))
(if ($bigpositive? x)
(intquotient x y)
(let ([q.r (intquotient-remainder x y)])
(if (eq? (cdr q.r) 0)
(car q.r)
(if (fx< y 0)
(+ (car q.r) 1)
(- (car q.r) 1)))))]
(cond
[(fx= y 1) x]
[(fx= y -1) (big-negate x)]
[else
(if ($bigpositive? x)
(intquotient x y)
(let ([q.r (intquotient-remainder x y)])
(if (eq? (cdr q.r) 0)
(car q.r)
(if (fx< y 0)
(+ (car q.r) 1)
(- (car q.r) 1)))))])]
[(ratnum?)
(when (fx= y 0) (domain-error who y))
($exdiv x y)]
@ -1716,14 +1742,17 @@
[(flonum?) ($flmod x (fixnum->flonum y))]
[(bignum?)
(when (fx= y 0) (domain-error who y))
(if ($bigpositive? x)
(intremainder x y)
(let ([q.r (intquotient-remainder x y)])
(if (eq? (cdr q.r) 0)
0
(if (fx< y 0)
(fx- (cdr q.r) y)
(fx+ (cdr q.r) y)))))]
(cond
[(or (fx= y 1) (fx= y -1)) 0]
[else
(if ($bigpositive? x)
(intremainder x y)
(let ([q.r (intquotient-remainder x y)])
(if (eq? (cdr q.r) 0)
0
(if (fx< y 0)
(fx- (cdr q.r) y)
(fx+ (cdr q.r) y)))))])]
[(ratnum?)
(when (fx= y 0) (domain-error who y))
($exmod x y)]
@ -1766,7 +1795,14 @@
(when (fx= y 0) (domain-error who y))
($fxdiv0-and-mod0 x y #f)]
[(flonum?) ($fldiv0-and-mod0 x (fixnum->flonum y))]
[(bignum? ratnum?)
[(bignum?)
(cond
[(fx= y 1) (values x 0)]
[(fx= y -1) (values (big-negate x) 0)]
[else
(when (fx= y 0) (domain-error who y))
($exdiv0-and-mod0 x y)])]
[(ratnum?)
(when (fx= y 0) (domain-error who y))
($exdiv0-and-mod0 x y)]
[else (domain-error who x)])]
@ -1802,7 +1838,14 @@
(when (fx= y 0) (domain-error who y))
($fxdiv0 x y #f)]
[(flonum?) ($fldiv0 x (fixnum->flonum y))]
[(bignum? ratnum?)
[(bignum?)
(cond
[(fx= y 1) x]
[(fx= y -1) (big-negate x)]
[else
(when (fx= y 0) (domain-error who y))
(exdiv0 x y)])]
[(ratnum?)
(when (fx= y 0) (domain-error who y))
(exdiv0 x y)]
[else (domain-error who x)])]
@ -1838,7 +1881,13 @@
(when (fx= y 0) (domain-error who y))
($fxmod0 x y)]
[(flonum?) ($flmod0 x (fixnum->flonum y))]
[(bignum? ratnum?)
[(bignum?)
(cond
[(or (fx= y 1) (fx= y -1)) 0]
[else
(when (fx= y 0) (domain-error who y))
(exmod0 x y)])]
[(ratnum?)
(when (fx= y 0) (domain-error who y))
(exmod0 x y)]
[else (domain-error who x)])]
@ -1860,35 +1909,38 @@
[else (domain-error who x)])]
[else (domain-error who y)])))
(set! remainder
(let ([f (lambda (x y)
(let ([r (- x (* (quotient x y) y))])
;;; filter out outrageous results
;;; try (remainder 1e194 10.0) without this hack...
(if (if (negative? y) (> r y) (< r y))
r
0.0)))])
(lambda (x y)
(type-case y
[(fixnum?)
(when (fx= y 0) (domain-error 'remainder y))
(set-who! remainder
(let ([f (lambda (x y)
(let ([r (- x (* (quotient x y) y))])
;;; filter out outrageous results
;;; try (remainder 1e194 10.0) without this hack...
(if (if (negative? y) (> r y) (< r y))
r
0.0)))])
(lambda (x y)
(type-case y
[(fixnum?)
(when (fx= y 0) (domain-error who y))
(cond
[(or (fx= y 1) (fx= y -1)) (unless (integer? x) (noninteger-error who x)) 0]
[else
(type-case x
[(fixnum?) (fxremainder x y)]
[(bignum?) (intremainder x y)]
[else
(unless (integer? x) (noninteger-error 'remainder x))
(f x y)])]
[(bignum?)
(type-case x
[(fixnum? bignum?) (intremainder x y)]
[else
(unless (integer? x) (noninteger-error 'remainder x))
(f x y)])]
[else
(unless (integer? y) (noninteger-error 'remainder y))
(unless (integer? x) (noninteger-error 'remainder x))
(when (= y 0) (domain-error 'remainder y))
(f x y)]))))
[(fixnum?) (fxremainder x y)]
[(bignum?) (intremainder x y)]
[else
(unless (integer? x) (noninteger-error who x))
(f x y)])])]
[(bignum?)
(type-case x
[(fixnum? bignum?) (intremainder x y)]
[else
(unless (integer? x) (noninteger-error who x))
(f x y)])]
[else
(unless (integer? y) (noninteger-error who y))
(unless (integer? x) (noninteger-error who x))
(when (= y 0) (domain-error who y))
(f x y)]))))
(set-who! even?
(lambda (x)
@ -2048,185 +2100,227 @@
[else (nonreal-error who x)])))
(set! $+
(lambda (who x y)
(type-case x
[(fixnum? bignum?)
(type-case y
[(fixnum? bignum?) (integer+ x y)]
[(ratnum?)
(let ([d ($ratio-denominator y)])
(/ (+ (* x d) ($ratio-numerator y)) d))]
[(flonum?) (exact-inexact+ x y)]
[($exactnum? $inexactnum?)
(make-rectangular (+ x (real-part y)) (imag-part y))]
[else (nonnumber-error who y)])]
[(ratnum?)
(type-case y
(lambda (who x y)
(define (exint-unknown+ who x y)
(type-case y
[(fixnum? bignum?) (integer+ x y)]
[(ratnum?)
(let ([d ($ratio-denominator y)])
(integer/ (+ (* x d) ($ratio-numerator y)) d))]
[(flonum?) (exact-inexact+ x y)]
[($exactnum? $inexactnum?)
(make-rectangular (+ x (real-part y)) (imag-part y))]
[else (nonnumber-error who y)]))
(cond
[(eqv? y 0) (unless (number? x) (nonnumber-error who x)) x]
[else
(type-case x
[(fixnum?)
(cond
[(fx= x 0) (unless (number? y) (nonnumber-error who y)) y]
[else (exint-unknown+ who x y)])]
[(bignum?) (exint-unknown+ who x y)]
[(ratnum?)
(type-case y
[(fixnum? bignum?)
(let ([d ($ratio-denominator x)])
(/ (+ (* y d) ($ratio-numerator x)) d))]
(integer/ (+ (* y d) ($ratio-numerator x)) d))]
[(ratnum?)
(let ([xd ($ratio-denominator x)] [yd ($ratio-denominator y)])
(/ (+ (* ($ratio-numerator x) yd)
(* ($ratio-numerator y) xd))
(* xd yd)))]
(integer/
(+ (* ($ratio-numerator x) yd) (* ($ratio-numerator y) xd))
(* xd yd)))]
[($exactnum? $inexactnum?)
(make-rectangular (+ x (real-part y)) (imag-part y))]
[(flonum?) (exact-inexact+ x y)]
[else (nonnumber-error who y)])]
[(flonum?)
(type-case y
[(flonum?)
(type-case y
[(cflonum?) (cfl+ x y)]
[(fixnum? bignum? ratnum?) (exact-inexact+ y x)]
[($exactnum?)
(make-rectangular (+ x (real-part y)) (imag-part y))]
[else (nonnumber-error who y)])]
[($exactnum? $inexactnum?)
(type-case y
[($exactnum? $inexactnum?)
(type-case y
[(fixnum? bignum? ratnum? flonum?)
(make-rectangular (+ (real-part x) y) (imag-part x))]
[($exactnum? $inexactnum?)
(make-rectangular (+ (real-part x) (real-part y))
(+ (imag-part x) (imag-part y)))]
(+ (imag-part x) (imag-part y)))]
[else (nonnumber-error who y)])]
[else (nonnumber-error who x)])))
[else (nonnumber-error who x)])])))
(set! $*
(lambda (who x y)
(type-case x
[(fixnum? bignum?)
(type-case y
[(fixnum? bignum?) (integer* x y)]
[(ratnum?) (/ (* x ($ratio-numerator y)) ($ratio-denominator y))]
[($exactnum? $inexactnum?)
(make-rectangular (* x (real-part y)) (* x (imag-part y)))]
[(flonum?) (exact-inexact* x y)]
[else (nonnumber-error who y)])]
[(ratnum?)
(type-case y
(lambda (who x y)
(define (exint-unknown* who x y)
(type-case y
[(fixnum? bignum?) (integer* x y)]
[(ratnum?) (integer/ (* x ($ratio-numerator y)) ($ratio-denominator y))]
[($exactnum? $inexactnum?)
(make-rectangular (* x (real-part y)) (* x (imag-part y)))]
[(flonum?) (exact-inexact* x y)]
[else (nonnumber-error who y)]))
(cond
[(and (fixnum? y) ($fxu< (#3%fx+ y 1) 3))
(cond
[(fx= y 0) (unless (number? x) (nonnumber-error who x)) 0]
[(fx= y 1) (unless (number? x) (nonnumber-error who x)) x]
[else ($negate who x)])]
[else
(type-case x
[(fixnum?)
(cond
[($fxu< (#3%fx+ x 1) 3)
(cond
[(fx= x 0) (unless (number? y) (nonnumber-error who y)) 0]
[(fx= x 1) (unless (number? y) (nonnumber-error who y)) y]
[else ($negate who y)])]
[else (exint-unknown* who x y)])]
[(bignum?) (exint-unknown* who x y)]
[(ratnum?)
(type-case y
[(fixnum? bignum?)
(/ (* y ($ratio-numerator x)) ($ratio-denominator x))]
(integer/ (* y ($ratio-numerator x)) ($ratio-denominator x))]
[(ratnum?)
(/ (* ($ratio-numerator x) ($ratio-numerator y))
(* ($ratio-denominator x) ($ratio-denominator y)))]
(integer/
(* ($ratio-numerator x) ($ratio-numerator y))
(* ($ratio-denominator x) ($ratio-denominator y)))]
[($exactnum? $inexactnum?)
(make-rectangular (* x (real-part y)) (* x (imag-part y)))]
[(flonum?) (exact-inexact* x y)]
[else (nonnumber-error who y)])]
[(flonum?)
(type-case y
[(flonum?)
(type-case y
[(cflonum?) (cfl* x y)]
[(fixnum? bignum? ratnum?) (exact-inexact* y x)]
[($exactnum?)
(make-rectangular (* x (real-part y)) (* x (imag-part y)))]
[else (nonnumber-error who y)])]
[($exactnum? $inexactnum?)
(type-case y
[($exactnum? $inexactnum?)
(type-case y
[(fixnum? bignum? ratnum? flonum?)
(make-rectangular (* (real-part x) y) (* (imag-part x) y))]
[($exactnum? $inexactnum?)
(let ([a (real-part x)] [b (imag-part x)]
[c (real-part y)] [d (imag-part y)])
(make-rectangular (- (* a c) (* b d)) (+ (* a d) (* b c))))]
(make-rectangular (- (* a c) (* b d)) (+ (* a d) (* b c))))]
[else (nonnumber-error who y)])]
[else (nonnumber-error who x)])))
[else (nonnumber-error who x)])])))
(set! $-
(lambda (who x y)
(type-case x
[(fixnum? bignum?)
(type-case y
[(fixnum? bignum?) (integer- x y)]
[(ratnum?)
(let ([d ($ratio-denominator y)])
(/ (- (* x d) ($ratio-numerator y)) d))]
[($exactnum? $inexactnum?)
(make-rectangular (- x (real-part y)) (- (imag-part y)))]
[(flonum?) (exact-inexact- x y)]
[else (nonnumber-error who y)])]
[(ratnum?)
(type-case y
(lambda (who x y)
(define (exint-unknown- who x y)
(type-case y
[(fixnum? bignum?) (integer- x y)]
[(ratnum?)
(let ([d ($ratio-denominator y)])
(integer/ (- (* x d) ($ratio-numerator y)) d))]
[($exactnum? $inexactnum?)
(make-rectangular (- x (real-part y)) (- (imag-part y)))]
[(flonum?) (exact-inexact- x y)]
[else (nonnumber-error who y)]))
(cond
[(eqv? y 0) (unless (number? x) (nonnumber-error who x)) x]
[else
(type-case x
[(fixnum?)
(cond
[(eqv? x 0) ($negate who y)]
[else (exint-unknown- who x y)])]
[(bignum?) (exint-unknown- who x y)]
[(ratnum?)
(type-case y
[(fixnum? bignum?)
(let ([d ($ratio-denominator x)])
(/ (- ($ratio-numerator x) (* y d)) d))]
(integer/ (- ($ratio-numerator x) (* y d)) d))]
[(ratnum?)
(let ([xd ($ratio-denominator x)] [yd ($ratio-denominator y)])
(/ (- (* ($ratio-numerator x) yd)
(* ($ratio-numerator y) xd))
(* xd yd)))]
(integer/
(- (* ($ratio-numerator x) yd) (* ($ratio-numerator y) xd))
(* xd yd)))]
[($exactnum? $inexactnum?)
(make-rectangular (- x (real-part y)) (- (imag-part y)))]
[(flonum?) (exact-inexact- x y)]
[else (nonnumber-error who y)])]
[(flonum?)
(type-case y
[(flonum?)
(type-case y
[(cflonum?) (cfl- x y)]
[(fixnum? bignum? ratnum?) (inexact-exact- x y)]
[($exactnum?)
(make-rectangular (- x (real-part y)) (- (imag-part y)))]
[else (nonnumber-error who y)])]
[($exactnum? $inexactnum?)
(type-case y
[($exactnum? $inexactnum?)
(type-case y
[(fixnum? bignum? ratnum? flonum?)
(make-rectangular (- (real-part x) y) (imag-part x))]
[($exactnum? $inexactnum?)
(make-rectangular (- (real-part x) (real-part y))
(- (imag-part x) (imag-part y)))]
(- (imag-part x) (imag-part y)))]
[else (nonnumber-error who y)])]
[else (nonnumber-error who x)])))
[else (nonnumber-error who x)])])))
(set! $/
(lambda (who x y)
(type-case y
[(fixnum? bignum?)
(type-case x
[(fixnum? bignum?)
(when (eq? y 0) (domain-error who y))
(integer/ x y)]
[(ratnum?)
(when (eq? y 0) (domain-error who y))
(/ ($ratio-numerator x) (* y ($ratio-denominator x)))]
[($exactnum?)
(when (eq? y 0) (domain-error who y))
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[($inexactnum?)
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[(flonum?) (inexact-exact/ x y)]
[else (nonnumber-error who x)])]
[(ratnum?)
(type-case x
[(fixnum? bignum?)
(integer/ (* x ($ratio-denominator y)) ($ratio-numerator y))]
[(ratnum?)
(integer/ (* ($ratio-numerator x) ($ratio-denominator y))
(* ($ratio-denominator x) ($ratio-numerator y)))]
[($exactnum? $inexactnum?)
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[(flonum?) (inexact-exact/ x y)]
[else (nonnumber-error who x)])]
[(flonum?)
(type-case x
[(cflonum?) (cfl/ x y)]
[(fixnum? bignum? ratnum?) (exact-inexact/ x y)]
[($exactnum?)
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[else (nonnumber-error who x)])]
[($exactnum? $inexactnum?)
(type-case x
[(fixnum? bignum? ratnum? flonum?)
;; a / c+di => c(a/(cc+dd)) + (-d(a/cc+dd))i
(let ([c (real-part y)] [d (imag-part y)])
(let ([t (/ x (+ (* c c) (* d d)))])
(make-rectangular (* c t) (- (* d t)))))]
[($exactnum? $inexactnum?)
;; a+bi / c+di => (ac+bd)/(cc+dd) + ((bc-ad)/(cc+dd))i
(let ([a (real-part x)] [b (imag-part x)]
[c (real-part y)] [d (imag-part y)])
(let ([t (+ (* c c) (* d d))])
(make-rectangular (/ (+ (* a c) (* b d)) t)
(/ (- (* b c) (* a d)) t))))]
[else (nonnumber-error who x)])]
[else (nonnumber-error who y)])))
(lambda (who x y)
(define (unknown-exint/ who x y)
(type-case x
[(fixnum?)
(when (eqv? y 0) (domain-error who y))
(if (eqv? x 0) 0 (integer/ x y))]
[(bignum?)
(when (eqv? y 0) (domain-error who y))
(integer/ x y)]
[(ratnum?)
(when (eqv? y 0) (domain-error who y))
(integer/ ($ratio-numerator x) (* y ($ratio-denominator x)))]
[($exactnum?)
(when (eqv? y 0) (domain-error who y))
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[($inexactnum?)
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[(flonum?) (inexact-exact/ x y)]
[else (nonnumber-error who x)]))
(type-case y
[(fixnum?)
(cond
[(fx= y 1) (unless (number? x) (nonnumber-error who x)) x]
[(fx= y -1) (unless (number? x) (nonnumber-error who x)) ($negate who x)]
[else (unknown-exint/ who x y)])]
[(bignum?) (unknown-exint/ who x y)]
[(ratnum?)
(type-case x
[(fixnum? bignum?)
(integer/ (* x ($ratio-denominator y)) ($ratio-numerator y))]
[(ratnum?)
(integer/ (* ($ratio-numerator x) ($ratio-denominator y))
(* ($ratio-denominator x) ($ratio-numerator y)))]
[($exactnum? $inexactnum?)
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[(flonum?) (inexact-exact/ x y)]
[else (nonnumber-error who x)])]
[(flonum?)
(type-case x
[(cflonum?) (cfl/ x y)]
[(fixnum? bignum? ratnum?) (exact-inexact/ x y)]
[($exactnum?)
(make-rectangular (/ (real-part x) y) (/ (imag-part x) y))]
[else (nonnumber-error who x)])]
[($exactnum? $inexactnum?)
(type-case x
[(fixnum? bignum? ratnum? flonum?)
;; a / c+di => c(a/(cc+dd)) + (-d(a/cc+dd))i
(let ([c (real-part y)] [d (imag-part y)])
(let ([t (/ x (+ (* c c) (* d d)))])
(make-rectangular (* c t) (- (* d t)))))]
[($exactnum? $inexactnum?)
;; a+bi / c+di => (ac+bd)/(cc+dd) + ((bc-ad)/(cc+dd))i
(let ([a (real-part x)] [b (imag-part x)]
[c (real-part y)] [d (imag-part y)])
(let ([t (+ (* c c) (* d d))])
(make-rectangular (/ (+ (* a c) (* b d)) t)
(/ (- (* b c) (* a d)) t))))]
[else (nonnumber-error who x)])]
[else (nonnumber-error who y)])))
(set! conjugate
(lambda (x)
@ -2523,15 +2617,15 @@
[(and (bignum? n) (#%$bigpositive? n)) (big-integer-sqrt n)]
[else ($oops who "~s is not a nonnegative exact integer" n)])))
(set! $quotient-remainder
(lambda (x y)
(type-case y
[(bignum? fixnum?)
(when (eq? y 0) (domain-error '$quotient-remainder y))
(type-case x
[(fixnum? bignum?) (intquotient-remainder x y)]
[else (nonexact-integer-error '$quotient-remainder x)])]
[else (nonexact-integer-error '$quotient-remainder y)])))
(set-who! $quotient-remainder
(lambda (x y)
(type-case y
[(fixnum? bignum?)
(when (eq? y 0) (domain-error who y))
(type-case x
[(fixnum? bignum?) (intquotient-remainder x y)]
[else (nonexact-integer-error who x)])]
[else (nonexact-integer-error who y)])))
(set! random
(let ([fxrandom (foreign-procedure "(cs)s_fxrandom"

2
s/back.ss
View File

@ -180,6 +180,7 @@
[()
(let ([x ($tc-field 'compress-level ($tc))])
(cond
[(eqv? x (constant COMPRESS-MIN)) 'minimum]
[(eqv? x (constant COMPRESS-LOW)) 'low]
[(eqv? x (constant COMPRESS-MEDIUM)) 'medium]
[(eqv? x (constant COMPRESS-HIGH)) 'high]
@ -188,6 +189,7 @@
[(x)
($tc-field 'compress-level ($tc)
(case x
[(minimum) (constant COMPRESS-MIN)]
[(low) (constant COMPRESS-LOW)]
[(medium) (constant COMPRESS-MEDIUM)]
[(high) (constant COMPRESS-HIGH)]

10
s/cmacros.ss
View File

@ -536,10 +536,11 @@
(define-constant COMPRESS-LZ4 1)
(define-constant COMPRESS-FORMAT-BITS 3)
(define-constant COMPRESS-LOW 0)
(define-constant COMPRESS-MEDIUM 1)
(define-constant COMPRESS-HIGH 2)
(define-constant COMPRESS-MAX 3)
(define-constant COMPRESS-MIN 0)
(define-constant COMPRESS-LOW 1)
(define-constant COMPRESS-MEDIUM 2)
(define-constant COMPRESS-HIGH 3)
(define-constant COMPRESS-MAX 4)
(define-constant SICONV-DUNNO 0)
(define-constant SICONV-INVALID 1)
@ -1360,6 +1361,7 @@
[ptr timer-ticks]
[ptr disable-count]
[ptr signal-interrupt-pending]
[ptr signal-interrupt-queue]
[ptr keyboard-interrupt-pending]
[ptr threadno]
[ptr current-input]

72
s/compile.ss
View File

@ -1151,17 +1151,7 @@
[(library/ct ,uid (,export-id* ...) ,import-code ,visit-code)
(if (library-node-visible? node)
($build-install-library/ct-code uid export-id* import-code visit-code)
(let ([fail (gen-var 'fail)])
(set-prelex-referenced! fail #t)
(set-prelex-multiply-referenced! fail #t)
(build-let
(list fail)
(list (build-lambda '()
(build-primcall '$oops `(quote ,'visit)
`(quote ,"library ~s is not visible")
`(quote ,(library-node-path node)))))
($build-install-library/ct-code uid export-id* `(ref #f ,fail) `(ref #f ,fail)))))])))
void-pr)])))
(define build-void (let ([void-rec `(quote ,(void))]) (lambda () void-rec)))
@ -1184,6 +1174,10 @@
(syntax-rules ()
[(_ ?name ?arg ...) (build-call (lookup-primref 3 ?name) ?arg ...)]))
(define-syntax build-primref
(syntax-rules ()
[(_ ?level ?name) (lookup-primref ?level ?name)]))
(define build-install-library/rt-code
(lambda (node thunk)
(build-primcall '$install-library/rt-code `(quote ,(library-node-uid node)) thunk)))
@ -1277,30 +1271,34 @@
(define build-combined-program-ir
(lambda (program node*)
(patch
(fold-right
(lambda (node combined-body)
(if (library-node-binary? node)
`(seq
,(build-primcall '$invoke-library
`(quote ,(library-node-path node))
`(quote ,(library-node-version node))
`(quote ,(library-node-uid node)))
,combined-body)
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
`(letrec* ([,dv* ,de*] ...)
(seq ,body
(seq
,(build-install-library/rt-code node
(if (library-node-visible? node)
(build-lambda '() (build-top-level-set!* node))
void-pr))
,combined-body)))])))
(nanopass-case (Lexpand Program) (program-node-ir program)
[(program ,uid ,body) body])
node*)
(make-patch-env (list node*)))))
`(seq
,(build-primcall 'for-each
(build-primref 3 '$mark-pending!)
`(quote ,(map library-node-uid (remp library-node-binary? node*))))
,(patch
(fold-right
(lambda (node combined-body)
(if (library-node-binary? node)
`(seq
,(build-primcall '$invoke-library
`(quote ,(library-node-path node))
`(quote ,(library-node-version node))
`(quote ,(library-node-uid node)))
,combined-body)
(nanopass-case (Lexpand rtLibrary) (library-node-rtir node)
[(library/rt ,uid (,dl* ...) (,db* ...) (,dv* ...) (,de* ...) ,body)
`(letrec* ([,dv* ,de*] ...)
(seq ,body
(seq
,(build-install-library/rt-code node
(if (library-node-visible? node)
(build-lambda '() (build-top-level-set!* node))
void-pr))
,combined-body)))])))
(nanopass-case (Lexpand Program) (program-node-ir program)
[(program ,uid ,body) body])
node*)
(make-patch-env (list node*))))))
(define build-combined-library-ir
(lambda (cluster*)
@ -1417,6 +1415,7 @@
(library-info-path info)
(library-info-version info)
uid
(library-node-visible? node)
(requirements-join
(library/rt-info-invoke-req* info)
(and maybe-ht (symbol-hashtable-ref maybe-ht uid #f))))))
@ -1437,6 +1436,7 @@
(library-info-path info)
(library-info-version info)
uid
(library-node-visible? visit-lib)
(requirements-join
(library/ct-info-import-req* info)
(and maybe-ht (symbol-hashtable-ref maybe-ht uid #f)))
@ -1453,7 +1453,7 @@
(program-node-uid node)
; NB: possibly list direct or indirect binary library reqs here
(program-node-invoke-req* node))))
,body)))
,body)))
(define add-visit-lib-install*
(lambda (visit-lib* body)

11
s/cpnanopass.ss
View File

@ -5064,8 +5064,17 @@
(def-len fxvector-length mask-fxvector type-fxvector fxvector-type-disp fxvector-length-offset)
(def-len string-length mask-string type-string string-type-disp string-length-offset)
(def-len bytevector-length mask-bytevector type-bytevector bytevector-type-disp bytevector-length-offset))
; TODO: consider adding integer?, integer-valued?, rational?, rational-valued?,
; TODO: consider adding integer-valued?, rational?, rational-valued?,
; real?, and real-valued?
(define-inline 2 integer?
[(e) (bind #t (e)
(build-simple-or
(%type-check mask-fixnum type-fixnum ,e)
(build-simple-or
(%typed-object-check mask-bignum type-bignum ,e)
(build-and
(%type-check mask-flonum type-flonum ,e)
`(call ,(make-info-call src sexpr #f #f #f) #f ,(lookup-primref 3 'flinteger?) ,e)))))])
(let ()
(define build-number?
(lambda (e)

9
s/expand-lang.ss
View File

@ -29,11 +29,12 @@
(sealed #t))
(define-record-type library-info
(nongenerative #{library-info e10vy7tci6bqz6pmnxgvlq-2})
(nongenerative #{library-info e10vy7tci6bqz6pmnxgvlq-3})
(fields
(immutable path)
(immutable version)
(immutable uid)))
(immutable uid)
(immutable visible?)))
(define-record-type library/ct-info
(parent library-info)
@ -41,14 +42,14 @@
(immutable import-req*)
(immutable visit-visit-req*)
(immutable visit-req*))
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-3})
(nongenerative #{library/ct-info fgf0koeh2zn6ajlujfyoyf-4})
(sealed #t))
(define-record-type library/rt-info
(parent library-info)
(fields
(immutable invoke-req*))
(nongenerative #{library/rt-info ff86rtm7efmvxcvrmh7t0b-2})
(nongenerative #{library/rt-info ff86rtm7efmvxcvrmh7t0b-3})
(sealed #t))
(define-record-type program-info

2
s/library.ss
View File

@ -1075,7 +1075,7 @@
(let ([handler $signal-interrupt-handler])
($tc-field 'signal-interrupt-pending ($tc) #f)
(keyboard)
(handler x))
(for-each handler ($dequeue-scheme-signals ($tc))))
(keyboard))))
(define (keyboard)
(if ($tc-field 'keyboard-interrupt-pending ($tc))

3
s/primdata.ss
View File

@ -970,6 +970,7 @@
(import-notify [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(interaction-environment [sig [() -> (environment)] [(environment) -> (void)]] [flags ieee r5rs])
(internal-defines-as-letrec* [sig [() -> (boolean)] [(ptr) -> (void)]] [flags unrestricted])
(invoke-library [sig [(ptr) -> (void)]] [flags true])
(keyboard-interrupt-handler [sig [() -> (procedure)] [(procedure) -> (void)]] [flags])
(library-directories [sig [() -> (list)] [(sub-ptr) -> (void)]] [flags])
(library-exports [sig [(sub-list) -> (list)]] [flags])
@ -1809,6 +1810,7 @@
($c-tlv [flags])
($current-stack-link [flags])
($current-winders [flags])
($dequeue-scheme-signals [flags])
($distinct-bound-ids? [flags])
($dofmt [flags])
($do-wind [flags])
@ -2128,6 +2130,7 @@
($make-vtable [flags])
($map [flags])
($mark-invoked! [flags])
($mark-pending! [flags])
($maybe-compile-file [flags])
($noexpand? [flags])
($np-boot-code [flags])

5
s/prims.ss
View File

@ -88,6 +88,11 @@
()
scheme-object))
(define $dequeue-scheme-signals
(foreign-procedure "(cs)dequeue_scheme_signals"
(ptr)
ptr))
(define-who $show-allocation
(let ([fp (foreign-procedure "(cs)s_showalloc" (boolean string) void)])
(case-lambda

157
s/syntax.ss
View File

@ -1029,7 +1029,7 @@
(lambda (b)
(case (binding-type b)
[(visit)
(visit-library (binding-value b))
(visit-loaded-library (binding-value b))
(get-global-definition-hook label)]
[else b]))]
[else (make-binding 'global label)])))
@ -2362,9 +2362,10 @@
(immutable outfn) ; string if imported from or compiled to an object file, else #f
(immutable importer) ; string if we know why this was imported, for error messages
(immutable system?)
(immutable visible?)
(immutable ctdesc)
(immutable rtdesc))
(nongenerative #{libdesc c9z2lszhwazzhbi56x5v5p-2})
(nongenerative #{libdesc c9z2lszhwazzhbi56x5v5p-3})
(sealed #t))
(define-record-type ctdesc
@ -2468,7 +2469,7 @@
(when (import-notify) (fprintf (console-output-port) "~a\n" msg))
e1 e2 ...)]))
(define visit-library
(define visit-loaded-library
; library must already have been loaded, as well as those in its visit-req* list
(lambda (uid)
(define (go desc)
@ -2484,14 +2485,15 @@
(begin
(for-each (lambda (id) ($sc-put-cte id (make-binding 'visit uid) #f)) (libdesc-visit-id* desc))
(libdesc-visit-code-set! desc p))
(for-each (lambda (req) (visit-library (libreq-uid req))) (libdesc-visit-visit-req* desc))
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-visit-req* desc))
(for-each (lambda (req) (visit-loaded-library (libreq-uid req))) (libdesc-visit-visit-req* desc))
(for-each (lambda (req) (invoke-loaded-library (libreq-uid req))) (libdesc-visit-req* desc))
(p))
(libdesc-visit-code-set! desc #f)
(libdesc-visit-id*-set! desc '()))]))
(cond
[(get-library-descriptor uid) =>
(lambda (desc)
(unless (libdesc-visible? desc) ($oops #f "attempt to visit invisible library ~s" (libdesc-path desc)))
(if (libdesc-ctdesc desc)
(go desc)
(let ([fn (libdesc-outfn desc)])
@ -2505,7 +2507,7 @@
(go desc)))))]
[else ($oops #f "library ~:s is not defined" uid)])))
(define invoke-library
(define invoke-loaded-library
; library must already have been loaded, as well as those in its invoke-req* list
(lambda (uid)
(define (go desc)
@ -2518,12 +2520,13 @@
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(for-each (lambda (req) (invoke-loaded-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))
(cond
[(get-library-descriptor uid) =>
(lambda (desc)
(unless (libdesc-visible? desc) ($oops #f "attempt to invoke invisible library ~s" (libdesc-path desc)))
(if (libdesc-rtdesc desc)
(go desc)
(let ([fn (libdesc-outfn desc)])
@ -2571,6 +2574,8 @@
(lambda (desc)
(when invoke-now?
(cond
[(not (libdesc-visible? desc))
($oops #f "attempt to invoke invisible library ~s" (libdesc-path desc))]
[(not (libdesc-rtdesc desc))
(with-message (format "attempting to 'revisit' previously 'visited' ~s for library ~s run-time info" (libdesc-outfn desc) (libdesc-path desc))
($revisit #f (libdesc-outfn desc) #f))
@ -2581,7 +2586,7 @@
($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc)))
(libdesc-invoke-code-set! desc 'pending)
(on-reset (libdesc-invoke-code-set! desc p)
(for-each (lambda (req) (invoke-library (libreq-uid req))) (libdesc-invoke-req* desc))
(for-each (lambda (req) (invoke-loaded-library (libreq-uid req))) (libdesc-invoke-req* desc))
(p))
(libdesc-invoke-code-set! desc #f))]))
(unless (memp (lambda (x) (eq? (libreq-uid x) uid)) req*)
@ -2681,7 +2686,7 @@
(vthunk) ; might as well do this now. visit-req* have already been invoked
(install-library library-path library-uid
; import-code & visit-code is #f because vthunk invocation has already set up compile-time environment
(make-libdesc library-path library-version outfn #f #f
(make-libdesc library-path library-version outfn #f #f #t
(make-ctdesc import-req* visit-visit-req* visit-req* #t #t '() #f #f)
(make-rtdesc invoke-req* #t
(top-level-eval-hook
@ -2701,13 +2706,13 @@
build-void
(lambda ()
(build-library/rt-info
(make-library/rt-info library-path library-version library-uid
(make-library/rt-info library-path library-version library-uid #t
invoke-req*))))
,(ct-eval/residualize ctem
build-void
(lambda ()
(build-library/ct-info
(make-library/ct-info library-path library-version library-uid
(make-library/ct-info library-path library-version library-uid #t
import-req* visit-visit-req* visit-req*))))
,(rt-eval/residualize rtem
build-void
@ -4681,22 +4686,22 @@
(lambda () root)))
(define install-library/ct-desc
(lambda (path version uid outfn importer ctdesc)
(lambda (path version uid outfn importer visible? ctdesc)
(with-tc-mutex
(record-loaded-library path uid)
(put-library-descriptor uid
(let ([desc (get-library-descriptor uid)])
(make-libdesc path version outfn (or (and desc (libdesc-importer desc)) importer) #f
(make-libdesc path version outfn (or (and desc (libdesc-importer desc)) importer) #f visible?
ctdesc
(and desc (libdesc-rtdesc desc))))))))
(define install-library/rt-desc
(lambda (path version uid outfn importer rtdesc)
(lambda (path version uid outfn importer visible? rtdesc)
(with-tc-mutex
(record-loaded-library path uid)
(put-library-descriptor uid
(let ([desc (get-library-descriptor uid)])
(make-libdesc path version outfn (or (and desc (libdesc-importer desc)) importer) #f
(make-libdesc path version outfn (or (and desc (libdesc-importer desc)) importer) #f visible?
(and desc (libdesc-ctdesc desc))
rtdesc))))))
@ -4851,7 +4856,7 @@
($oops who "missing header for compiled file ~s" fn))))))))
(define load-library
(lambda (path version-ref needed-uid importer-path ct? load-deps)
(lambda (who path version-ref needed-uid importer-path ct? load-deps)
(define-syntax with-message
(syntax-rules ()
[(_ msg e1 e2 ...)
@ -4864,7 +4869,7 @@
(unless (eq? found-uid needed-uid)
(let ([c ($make-recompile-condition importer-path)] [importer-path (or importer-path 'program)])
(if src-file-path
($oops/c #f c
($oops/c who c
"loading ~a yielded a different compilation instance of ~s from that required by compiled ~s"
src-file-path
path
@ -4874,7 +4879,7 @@
(if desc
(values (libdesc-outfn desc) (libdesc-importer desc))
(values #f #f)))])
($oops/c #f c
($oops/c who c
"compiled ~s requires a different compilation instance of ~s from the one previously ~:[compiled~;~:*loaded from ~a~]~@[ and originally imported by ~a~]"
importer-path
path
@ -4887,11 +4892,11 @@
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid file-path file-path)
(verify-version who path version-ref found-uid file-path file-path)
(load-deps found-uid)
(verify-uid found-uid file-path)
found-uid)]
[else ($oops #f "loading ~a did not define library ~s" file-path path)])))
[else ($oops who "loading ~a did not define library ~s" file-path path)])))
(define do-compile-library
(lambda (src-path obj-path)
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
@ -4899,11 +4904,11 @@
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(verify-version who path version-ref found-uid obj-path src-path)
(load-deps found-uid)
(verify-uid found-uid src-path)
found-uid)]
[else ($oops #f "compiling ~a did not define library ~s" src-path path)])))
[else ($oops who "compiling ~a did not define library ~s" src-path path)])))
(define do-recompile-or-load-library
(lambda (src-path obj-path)
(let ([compiled? #f])
@ -4920,14 +4925,14 @@
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(verify-version who path version-ref found-uid obj-path src-path)
(load-deps found-uid)
(verify-uid found-uid src-path)
found-uid)]
[else
(if compiled?
($oops #f "compiling ~a did not define library ~s" src-path path)
($oops #f "loading ~a did not define library ~s" obj-path path))]))))
($oops who "compiling ~a did not define library ~s" src-path path)
($oops who "loading ~a did not define library ~s" obj-path path))]))))
(define do-load-library-src-or-obj
(lambda (src-path obj-path)
(define (load-source)
@ -4971,17 +4976,17 @@
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(verify-version who path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "reloading ~a did not define library ~s" src-path path)])])
[else ($oops who "reloading ~a did not define library ~s" src-path path)])])
(parameterize ([source-directories (cons (path-parent src-path) (source-directories))])
(guard (c [(and (irritants-condition? c) (member obj-path (condition-irritants c)))
(with-message (with-output-to-string
(lambda ()
(display-string "failed to load object file: ")
(display-condition c)))
($oops/c #f ($make-recompile-condition path)
($oops/c who ($make-recompile-condition path)
"problem loading object file ~a ~s" obj-path c))])
(let ([situation (if ct? 'visit 'revisit)])
(with-message (format "~sing object file ~s" situation obj-path)
@ -4989,10 +4994,10 @@
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid obj-path src-path)
(verify-version who path version-ref found-uid obj-path src-path)
(load-deps found-uid)
found-uid)]
[else ($oops #f "loading ~a did not define library ~s" obj-path path)]))])
[else ($oops who "loading ~a did not define library ~s" obj-path path)]))])
(verify-uid found-uid src-path)
found-uid))
(load-source)))
@ -5002,7 +5007,7 @@
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path version-ref found-uid #f #f)
(verify-version who path version-ref found-uid #f #f)
(verify-uid found-uid #f)
(let ([desc (get-library-descriptor found-uid)])
(if ct?
@ -5042,7 +5047,7 @@
(let ([situation (if ct? 'visit 'revisit)])
(with-message (format "~sing object file ~s" situation obj-path)
(do-load-library obj-path situation)))
($oops #f "library ~s not found" path))))])))))
($oops who "library ~s not found" path))))])))))
(define version-okay?
(lambda (version-ref version)
@ -5070,14 +5075,14 @@
(version-okay? version-ref version)))
(define verify-version
(lambda (path version-ref found-uid file-path src-file-path)
(lambda (who path version-ref found-uid file-path src-file-path)
(let ([desc (get-library-descriptor found-uid)])
(unless desc ($oops #f "cyclic dependency involving import of library ~s" path))
(unless desc ($oops who "cyclic dependency involving import of library ~s" path))
(let ([version (libdesc-version desc)])
(unless (version-okay? version-ref version)
(if src-file-path
($oops #f "library ~s version mismatch: want ~s but found ~s at ~a" path version-ref version src-file-path)
($oops #f "library ~s version mismatch: want ~s but ~s already loaded" path version-ref version)))))))
($oops who "library ~s version mismatch: want ~s but found ~s at ~a" path version-ref version src-file-path)
($oops who "library ~s version mismatch: want ~s but ~s already loaded" path version-ref version)))))))
(define version-ref?
(lambda (x)
@ -5233,6 +5238,8 @@
(check-uid! found-uid #f)
(let ([desc (or (hashtable-ref uid-ht found-uid #f) (get-library-descriptor found-uid))])
(unless desc ($oops who "cyclic dependency involving import of library ~s" path))
(unless (libdesc-visible? desc)
($oops who "attempting to ~:[invoke~;import or visit~] invisible library ~s" visit? path))
(if visit?
(cond
[(libdesc-ctdesc desc) => (lambda (ctdesc) (check-ctdesc-libreqs! ctdesc importer))]
@ -5286,7 +5293,7 @@
(set! root (record-loaded-library root path uid))
(hashtable-set! uid-ht uid
(let ([desc (or (hashtable-ref uid-ht uid #f) (get-library-descriptor uid))])
(make-libdesc path (library-info-version lpinfo) fn (or (and desc (libdesc-importer desc)) importer) #f
(make-libdesc path (library-info-version lpinfo) fn (or (and desc (libdesc-importer desc)) importer) #f #t
ctdesc
(and desc (libdesc-rtdesc desc))))))
(lambda () (th) (check-ctdesc-libreqs! ctdesc fn))))]
@ -5298,7 +5305,7 @@
(set! root (record-loaded-library root path uid))
(hashtable-set! uid-ht uid
(let ([desc (or (hashtable-ref uid-ht uid #f) (get-library-descriptor uid))])
(make-libdesc path (library-info-version lpinfo) fn (or (and desc (libdesc-importer desc)) importer) #f
(make-libdesc path (library-info-version lpinfo) fn (or (and desc (libdesc-importer desc)) importer) #f #t
(and desc (libdesc-ctdesc desc))
rtdesc))))
(lambda () (th) (check-rtdesc-libreqs! rtdesc fn))))]
@ -5405,60 +5412,61 @@
(let ()
(define make-load-req
(lambda (loader path)
(lambda (who loader path)
(lambda (req)
(loader (libreq-path req) (libreq-version req) (libreq-uid req) path))))
(loader who (libreq-path req) (libreq-version req) (libreq-uid req) path))))
(define load-invoke-library
(lambda (path version-ref uid importer-path)
(load-library path version-ref uid importer-path #f
(lambda (who path version-ref uid importer-path)
(load-library who path version-ref uid importer-path #f
(lambda (uid)
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-rtdesc desc)
($oops #f "loading ~a did not define run-time information for library ~s" (libdesc-outfn desc) path))
($oops who "loading ~a did not define run-time information for library ~s" (libdesc-outfn desc) path))
(case (libdesc-loaded-invoke-reqs desc)
[(#t) (void)]
[(#f)
(libdesc-loaded-invoke-reqs-set! desc 'pending)
(on-reset (libdesc-loaded-invoke-reqs-set! desc #f)
(for-each (make-load-req load-invoke-library path) (libdesc-invoke-req* desc)))
(for-each (make-load-req who load-invoke-library path) (libdesc-invoke-req* desc)))
(libdesc-loaded-invoke-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving invocation of library ~s" (libdesc-path desc))]))))))
[(pending) ($oops who "cyclic dependency involving invocation of library ~s" (libdesc-path desc))]))))))
(define load-visit-library
(lambda (path version-ref uid importer-path)
(load-library path version-ref uid importer-path #t
(lambda (who path version-ref uid importer-path)
(load-library #f path version-ref uid importer-path #t
(lambda (uid)
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-ctdesc desc)
($oops #f "loading ~a did not define compile-time information for library ~s" (libdesc-outfn desc) path))
($oops who "loading ~a did not define compile-time information for library ~s" (libdesc-outfn desc) path))
(case (libdesc-loaded-visit-reqs desc)
[(#t) (void)]
[(#f)
(libdesc-loaded-visit-reqs-set! desc 'pending)
(on-reset (libdesc-loaded-visit-reqs-set! desc #f)
(for-each (make-load-req load-visit-library path) (libdesc-visit-visit-req* desc))
(for-each (make-load-req load-invoke-library path) (libdesc-visit-req* desc)))
(for-each (make-load-req who load-visit-library path) (libdesc-visit-visit-req* desc))
(for-each (make-load-req who load-invoke-library path) (libdesc-visit-req* desc)))
(libdesc-loaded-visit-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving visit of library ~s" (libdesc-path desc))]))))))
[(pending) ($oops who "cyclic dependency involving visit of library ~s" (libdesc-path desc))]))))))
(define load-import-library
(lambda (path version-ref uid importer-path)
(load-library path version-ref uid importer-path #t
(lambda (who path version-ref uid importer-path)
(load-library #f path version-ref uid importer-path #t
(lambda (uid)
(let ([desc (get-library-descriptor uid)])
(unless (libdesc-ctdesc desc)
($oops #f "loading ~a did not define compile-time information for library ~s" (libdesc-outfn desc) path))
($oops who "loading ~a did not define compile-time information for library ~s" (libdesc-outfn desc) path))
(case (libdesc-loaded-import-reqs desc)
[(#t) (void)]
[(#f)
(libdesc-loaded-import-reqs-set! desc 'pending)
(on-reset (libdesc-loaded-import-reqs-set! desc #f)
(for-each (make-load-req load-import-library path) (libdesc-import-req* desc)))
(for-each (make-load-req who load-import-library path) (libdesc-import-req* desc)))
(libdesc-loaded-import-reqs-set! desc #t)]
[(pending) ($oops #f "cyclic dependency involving import of library ~s" (libdesc-path desc))]))))))
[(pending) ($oops who "cyclic dependency involving import of library ~s" (libdesc-path desc))]))))))
(define import-library
(lambda (uid)
(cond
[(get-library-descriptor uid) =>
(lambda (desc)
(unless (libdesc-visible? desc) ($oops #f "attempt to import invisible library ~s" (libdesc-path desc)))
(cond
[(libdesc-import-code desc) =>
(lambda (p)
@ -5477,15 +5485,27 @@
; recompilation or reloading does occur
(set! $invoke-library
(lambda (path version-ref uid)
(invoke-library (load-invoke-library path version-ref uid #f))))
(invoke-loaded-library (load-invoke-library #f path version-ref uid #f))))
(set! $visit-library
(lambda (path version-ref uid)
(visit-library (load-visit-library path version-ref uid #f))))
(visit-loaded-library (load-visit-library #f path version-ref uid #f))))
(set! $import-library
(lambda (path version-ref uid)
(let ([uid (load-import-library path version-ref uid #f)])
(let ([uid (load-import-library #f path version-ref uid #f)])
(import-library uid)
uid)))
(set-who! invoke-library
(lambda (name)
(define (go path version-ref)
(invoke-loaded-library (load-invoke-library who path version-ref #f #f)))
(syntax-case name ()
[(dir-id ... file-id)
(and (andmap symbol? #'(dir-id ...)) (symbol? #'file-id))
(go #'(dir-id ... file-id) '())]
[(dir-id ... file-id version-ref)
(and (andmap symbol? #'(dir-id ...)) (symbol? #'file-id) (version-ref? #'version-ref))
(go #'(dir-id ... file-id) #'version-ref)]
[_ ($oops who "invalid library reference ~s" name)])))
(let ()
(set! $maybe-compile-file
(lambda (who ifn ofn handler)
@ -5533,7 +5553,7 @@
(guard (c [(and ($recompile-condition? c) (eq? ($recompile-importer-path c) #f))
(with-message (format "recompiling ~s because a dependency has changed" ifn)
(handler ifn ofn))])
(for-each (make-load-req load-import-library #f) (recompile-info-import-req* rcinfo))
(for-each (make-load-req who load-import-library #f) (recompile-info-import-req* rcinfo))
#f)
(if (andmap
(lambda (x)
@ -5541,7 +5561,7 @@
(cond
[(search-loaded-libraries path) =>
(lambda (found-uid)
(verify-version path (libreq-version x) found-uid #f #f)
(verify-version who path (libreq-version x) found-uid #f #f)
(eq? found-uid (libreq-uid x)))]
[else
(let-values ([(src-path obj-path obj-exists?) (library-search who path (library-directories) (library-extensions))])
@ -5688,6 +5708,7 @@
(when (let ([desc (get-library-descriptor uid)]) (and desc (libdesc-ctdesc desc)))
($oops #f "attempting to re-install compile-time part of library ~s" (library-info-path linfo/ct))))
(install-library/ct-desc (library-info-path linfo/ct) (library-info-version linfo/ct) uid ofn importer
(library-info-visible? linfo/ct)
(make-ctdesc
(library/ct-info-import-req* linfo/ct)
(library/ct-info-visit-visit-req* linfo/ct)
@ -5701,6 +5722,7 @@
(when (let ([desc (get-library-descriptor uid)]) (and desc (libdesc-rtdesc desc)))
($oops #f "attempting to re-install run-time part of library ~s" (library-info-path linfo/rt))))
(install-library/rt-desc (library-info-path linfo/rt) (library-info-version linfo/rt) uid ofn importer
(library-info-visible? linfo/rt)
(make-rtdesc (library/rt-info-invoke-req* linfo/rt) #f 'loading)))))
(set! $install-library/ct-code
@ -5729,6 +5751,13 @@
(lambda (desc) (libdesc-invoke-code-set! desc #f))]
[else ($oops #f "library ~:s is not defined" uid)])))
(set! $mark-pending!
; library must already have been loaded
(lambda (uid)
(cond
[(get-library-descriptor uid) =>
(lambda (desc) (libdesc-invoke-code-set! desc 'pending))]
[else ($oops #f "library ~:s is not defined" uid)])))
(set! $transformer->binding
(lambda (x)
@ -5780,7 +5809,7 @@
(define-who install-system-library
(lambda (path uid)
(install-library path uid
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #f #t
(make-libdesc path (if (eq? (car path) 'rnrs) '(6) '()) #f #f #t #t
(make-ctdesc '() '() '() #t #t '() #f #f)
(make-rtdesc '() #t #f)))))
(set! $make-base-modules
@ -6789,7 +6818,7 @@
[(primitive) #t]
[(global immutable-global) ($top-level-bound? (binding-value b))]
[(library-global)
(invoke-library (car (binding-value b)))
(invoke-loaded-library (car (binding-value b)))
($top-level-bound? (cdr (binding-value b)))]
[else #f])))]
[else #f])))
@ -6818,7 +6847,7 @@
[(primitive) (#3%$top-level-value (binding-value b))]
[(global immutable-global) (#2%$top-level-value (binding-value b))]
[(library-global)
(invoke-library (car (binding-value b)))
(invoke-loaded-library (car (binding-value b)))
(#2%$top-level-value (cdr (binding-value b)))]
[else ($oops 'top-level-value "~s is not a variable" sym)])))]
[else ($oops #f "variable ~s is not bound" sym)])))