static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[])
{
if (SCHEME_HASHTP(argv[0])) {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
return scheme_make_integer(t->count);
} else if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
int count = 0, weak, i;
Scheme_Bucket **buckets, *bucket;
const char *key;
buckets = t->buckets;
weak = t->weak;
for (i = t->size; i--; ) {
bucket = buckets[i];
if (bucket) {
if (weak) {
key = (const char *)HT_EXTRACT_WEAK(bucket->key);
} else {
key = bucket->key;
}
if (key)
count++;
}
SCHEME_USE_FUEL(1);
}
return scheme_make_integer(count);
} else {
scheme_wrong_type("hash-table-count", "hash-table", 0, argc, argv);
return NULL;
}
}
static Scheme_Object *write_quote_syntax(Scheme_Object *obj)
{
Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj;
return cons(scheme_make_integer(qs->depth),
cons(scheme_make_integer(qs->position),
scheme_make_integer(qs->midpoint)));
}
Scheme_Object *scheme_complex_sqrt(const Scheme_Object *o)
{
Scheme_Complex *c = (Scheme_Complex *)o;
Scheme_Object *r, *i, *ssq, *srssq, *nrsq, *prsq, *nr, *ni;
r = c->r;
i = c->i;
if (scheme_is_zero(i)) {
/* Special case for x+0.0i: */
r = scheme_sqrt(1, &r);
if (!SCHEME_COMPLEXP(r))
return scheme_make_complex(r, i);
else {
c = (Scheme_Complex *)r;
if (SAME_OBJ(c->r, zero)) {
/* need an inexact-zero real part: */
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(c->i))
r = scheme_make_float(0.0);
else
#endif
r = scheme_make_double(0.0);
return scheme_make_complex(r, c->i);
} else
return r;
}
}
ssq = scheme_bin_plus(scheme_bin_mult(r, r),
scheme_bin_mult(i, i));
srssq = scheme_sqrt(1, &ssq);
if (SCHEME_FLOATP(srssq)) {
/* We may have lost too much precision, if i << r. The result is
going to be inexact, anyway, so switch to using expt. */
Scheme_Object *a[2];
a[0] = (Scheme_Object *)o;
a[1] = scheme_make_double(0.5);
return scheme_expt(2, a);
}
nrsq = scheme_bin_div(scheme_bin_minus(srssq, r),
scheme_make_integer(2));
nr = scheme_sqrt(1, &nrsq);
if (scheme_is_negative(i))
nr = scheme_bin_minus(zero, nr);
prsq = scheme_bin_div(scheme_bin_plus(srssq, r),
scheme_make_integer(2));
ni = scheme_sqrt(1, &prsq);
return scheme_make_complex(ni, nr);
}
Scheme_Object *scheme_complex_negate(const Scheme_Object *o)
{
Scheme_Complex *c = (Scheme_Complex *)o;
return make_complex(scheme_bin_minus(scheme_make_integer(0),
c->r),
scheme_bin_minus(scheme_make_integer(0),
c->i),
0);
}
static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
{
Scheme_Object *s1, *s2;
intptr_t istart, ifinish;
intptr_t ostart, ofinish;
int slow = 0;
s1 = argv[0];
if (SCHEME_NP_CHAPERONEP(s1)) {
slow = 1;
s1 = SCHEME_CHAPERONE_VAL(s1);
}
if (!SCHEME_MUTABLE_VECTORP(s1))
scheme_wrong_contract("vector-copy!", "(and/c vector? (not/c immutable?))", 0, argc, argv);
scheme_do_get_substring_indices("vector-copy!", s1,
argc, argv, 1, 5,
&ostart, &ofinish, SCHEME_VEC_SIZE(s1));
s2 = argv[2];
if (SCHEME_NP_CHAPERONEP(s2)) {
slow = 1;
s2 = SCHEME_CHAPERONE_VAL(s2);
}
if (!SCHEME_VECTORP(s2))
scheme_wrong_contract("vector-copy!", "vector?", 2, argc, argv);
scheme_do_get_substring_indices("vector-copy!", s2,
argc, argv, 3, 4,
&istart, &ifinish, SCHEME_VEC_SIZE(s2));
if ((ofinish - ostart) < (ifinish - istart)) {
scheme_contract_error("vector-copy!",
"not enough room in target vector",
"target vector", 1, argv[2],
"starting index", 1, scheme_make_integer(ostart),
"element count", 1, scheme_make_integer(ofinish - ostart),
NULL);
return NULL;
}
if (slow) {
int i, o;
for (i = istart, o = ostart; i < ifinish; i++, o++) {
scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i));
}
} else {
memmove(SCHEME_VEC_ELS(s1) + ostart,
SCHEME_VEC_ELS(s2) + istart,
(ifinish - istart) * sizeof(Scheme_Object*));
}
return scheme_void;
}
static Scheme_Object *write_let_value(Scheme_Object *obj)
{
Scheme_Let_Value *lv;
lv = (Scheme_Let_Value *)obj;
return cons(scheme_make_integer(lv->count),
cons(scheme_make_integer(lv->position),
cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false,
cons(scheme_protect_quote(lv->value),
scheme_protect_quote(lv->body)))));
}
static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b, *vec;
int pos, save_mnt;
scheme_sfs_start_sequence(info, 3, 1);
k = scheme_sfs_expr(wcm->key, info, -1);
v = scheme_sfs_expr(wcm->val, info, -1);
scheme_sfs_push(info, 1, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
b = scheme_sfs_expr(wcm->body, info, -1);
wcm->key = k;
wcm->val = v;
wcm->body = b;
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
}
return o;
}
Scheme_Object *scheme_chaperone_vector_ref2(Scheme_Object *o, int i, Scheme_Object *outermost)
{
if (!SCHEME_NP_CHAPERONEP(o)) {
return SCHEME_VEC_ELS(o)[i];
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[4], *red, *orig;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_vector_ref_overflow(o, i);
}
#endif
if(SCHEME_FALSEP(px->redirects)) {
/* unsafe chaperones */
return scheme_chaperone_vector_ref2(px->val, i, outermost);
}
orig = scheme_chaperone_vector_ref2(px->prev, i, outermost);
if (SCHEME_REDIRECTS_PROP_ONLY_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
/* or vector chaperone is property only */
return orig;
}
red = SCHEME_CAR(px->redirects);
if (SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR) {
a[0] = outermost;
a[1] = px->prev;
a[2] = scheme_make_integer(i);
a[3] = orig;
o = _scheme_apply(red, 4, a);
}
else {
a[0] = px->prev;
a[1] = scheme_make_integer(i);
a[2] = orig;
o = _scheme_apply(red, 3, a);
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig))
scheme_wrong_chaperoned("vector-ref", "result", orig, o);
return o;
}
}
Scheme_Object *scheme_complex_add1(const Scheme_Object *n)
{
Small_Complex s;
return scheme_complex_add(scheme_make_small_complex(scheme_make_integer(1), &s),
n);
}
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red;
o = px->prev;
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = v;
red = SCHEME_CDR(px->redirects);
v = _scheme_apply(red, 3, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v,
a[2]);
}
}
}
Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
Scheme_Object *vec;
intptr_t i;
if (size < 0) {
vec = scheme_make_integer(size);
scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
} else {
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, VECTOR_BYTES(size));
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *unsafe_fx_mod(int argc, Scheme_Object *argv[])
{
int neg1, neg2;
intptr_t v, v1, av1, v2, av2;
if (scheme_current_thread->constant_folding) return scheme_modulo(argc, argv);
v1 = SCHEME_INT_VAL(argv[0]);
v2 = SCHEME_INT_VAL(argv[1]);
av1 = (v1 < 0) ? -v1 : v1;
av2 = (v2 < 0) ? -v2 : v2;
v = av1 % av2;
if (v) {
neg1 = (v1 < 0);
neg2 = (v2 < 0);
if (neg1 != neg2)
v = av2 - v;
if (neg2)
v = -v;
}
return scheme_make_integer(v);
}
Scheme_Object *
scheme_sub1 (int argc, Scheme_Object *argv[])
{
Scheme_Type t;
Scheme_Object *o = argv[0];
if (SCHEME_INTP(o)) {
intptr_t v;
v = SCHEME_INT_VAL(o);
if (v > -(0x3FFFFFFF))
return scheme_make_integer(SCHEME_INT_VAL(o) - 1);
else {
Small_Bignum b;
return scheme_bignum_sub1(scheme_make_small_bignum(v, &b));
}
}
t = _SCHEME_TYPE(o);
#ifdef MZ_USE_SINGLE_FLOATS
if (t == scheme_float_type)
return scheme_make_float(SCHEME_FLT_VAL(o) - 1.0f);
#endif
if (t == scheme_double_type)
return scheme_make_double(SCHEME_DBL_VAL(o) - 1.0);
if (t == scheme_bignum_type)
return scheme_bignum_sub1(o);
if (t == scheme_rational_type)
return scheme_rational_sub1(o);
if (t == scheme_complex_type)
return scheme_complex_sub1(o);
NEED_NUMBER(sub1);
ESCAPED_BEFORE_HERE;
}
Scheme_Object *scheme_complex_sub1(const Scheme_Object *n)
{
Small_Complex s;
return scheme_complex_add(n, scheme_make_small_complex(scheme_make_integer(-1),
&s));
}
Scheme_Object *
scheme_make_vector (int size, Scheme_Object *fill)
{
Scheme_Object *vec;
int i;
if (size <= 0) {
if (size) {
vec = scheme_make_integer(size);
scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
} else
return zero_length_vector;
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector)
+ (size - 1) * sizeof(Scheme_Object *));
} else {
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged,
sizeof(Scheme_Vector)
+ (size - 1) * sizeof(Scheme_Object *));
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
Scheme_Object *scheme_chaperone_vector_ref(Scheme_Object *o, int i)
{
if (!SCHEME_NP_CHAPERONEP(o)) {
return SCHEME_VEC_ELS(o)[i];
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red, *orig;
#ifdef DO_STACK_CHECK
{
# include "mzstkchk.h"
return chaperone_vector_ref_overflow(o, i);
}
#endif
orig = scheme_chaperone_vector_ref(px->prev, i);
if (SCHEME_VECTORP(px->redirects)) {
/* chaperone was on property accessors */
return orig;
}
a[0] = px->prev;
a[1] = scheme_make_integer(i);
a[2] = orig;
red = SCHEME_CAR(px->redirects);
o = _scheme_apply(red, 3, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(o, orig))
scheme_wrong_chaperoned("vector-ref", "result", orig, o);
return o;
}
}
static Scheme_Object *unsafe_vector_star_len (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
intptr_t n;
n = SCHEME_VEC_SIZE(vec);
return scheme_make_integer(n);
}
Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
Scheme_Object *vec;
intptr_t i;
if (size < 0) {
vec = scheme_make_integer(size);
scheme_wrong_contract("make-vector", "exact-nonnegative-integer?", -1, 0, &vec);
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
} else {
size_t sz;
sz = VECTOR_BYTES(size);
if (REV_VECTOR_BYTES(sz) != size)
/* overflow */
scheme_raise_out_of_memory(NULL, NULL);
else
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz);
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
Scheme_Object *body;
int i, pos, save_mnt;
Scheme_Object *vec;
scheme_sfs_push(info, lv->count, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(lv->count + 1, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (!SCHEME_VECTORP(vec))
scheme_signal_error("internal error: not a vector");
for (i = 0; i < lv->count; i++) {
info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]);
info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
body = scheme_sfs_expr(lv->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail);
for (i = 0; i < lv->count; i++) {
n = info->max_used[pos + i];
SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n);
}
} else {
info->max_nontail = save_mnt;
}
lv->body = body;
return o;
}
static void test_air(int interior, int stack)
{
size_t n_finalized = 0;
size_t i, j;
obj_t *s[OBJ_COUNT] = {0};
mps_root_t root = NULL;
if (!stack) {
mps_addr_t *p = (void *)s;
die(mps_root_create_table(&root, scheme_arena, mps_rank_ambig(), 0, p,
OBJ_COUNT), "mps_root_create_table");
}
mps_message_type_enable(scheme_arena, mps_message_type_finalization());
for (j = 0; j < OBJ_COUNT; ++j) {
obj_t n = scheme_make_integer(obj_ap, (long)j);
obj_t obj = scheme_make_vector(obj_ap, OBJ_LEN, n);
mps_addr_t ref = obj;
mps_finalize(scheme_arena, &ref);
s[j] = obj->vector.vector;
}
for (i = 1; i < OBJ_LEN; ++i) {
obj_t n = scheme_make_integer(obj_ap, (long)i);
mps_message_t msg;
for (j = 0; j + 1 < OBJ_COUNT; ++j) {
*++s[j] = n;
}
mps_arena_collect(scheme_arena);
mps_arena_release(scheme_arena);
if (mps_message_get(&msg, scheme_arena, mps_message_type_finalization())) {
mps_addr_t ref;
mps_message_finalization_ref(&ref, scheme_arena, msg);
++ n_finalized;
if (interior) {
obj_t o;
o = ref;
error("wrongly finalized vector %ld at %p",
o->vector.vector[0]->integer.integer, (void *)o);
}
}
}
if (!interior && n_finalized < OBJ_COUNT) {
error("only finalized %"PRIuLONGEST" out of %"PRIuLONGEST" vectors.",
(ulongest_t)n_finalized, (ulongest_t)OBJ_COUNT);
}
if (!stack) {
mps_root_destroy(root);
}
}
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
intptr_t n;
if (SCHEME_NP_CHAPERONEP(vec)) vec = SCHEME_CHAPERONE_VAL(vec);
n = SCHEME_VEC_SIZE(vec);
return scheme_make_integer(n);
}
Scheme_Object *scheme_make_small_rational(long n, Small_Rational *s)
{
s->so.type = scheme_rational_type;
s->num = scheme_make_integer(n);
s->denom = one;
return (Scheme_Object *)s;
}
static Scheme_Object *
vector_length (int argc, Scheme_Object *argv[])
{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector-length", "vector", 0, argc, argv);
return scheme_make_integer(SCHEME_VEC_SIZE(argv[0]));
}
Scheme_Object *scheme_make_fixnum_rational(intptr_t n, intptr_t d)
{
/* This function is called to implement division on small integers,
so don't allocate unless necessary. */
Small_Rational s;
Scheme_Object *o;
s.so.type = scheme_rational_type;
s.num = scheme_make_integer(n);
s.denom = scheme_make_integer(d);
o = scheme_rational_normalize((Scheme_Object *)&s);
if (o == (Scheme_Object *)&s)
return make_rational(s.num, s.denom, 0);
else
return o;
}
Scheme_Object *
irgb_blue (int argc, Scheme_Object **argv)
{
if (! SCHEME_INTP (argv[0]))
scheme_wrong_type ("irgb-blue", "integer", 0, 1, argv);
int color = SCHEME_INT_VAL (argv[0]);
return scheme_make_integer (color & 255);
} // irgb_blue
Scheme_Object *scheme_rational_negate(const Scheme_Object *o)
{
Scheme_Rational *r = (Scheme_Rational *)o;
return make_rational(scheme_bin_minus(scheme_make_integer(0),
r->num),
r->denom, 0);
}
static Scheme_Object *unsafe_fx_abs(int argc, Scheme_Object *argv[])
{
intptr_t v;
if (scheme_current_thread->constant_folding) return scheme_abs(argc, argv);
v = SCHEME_INT_VAL(argv[0]);
if (v < 0) v = -v;
return scheme_make_integer(v);
}
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
Scheme_Object *outermost = o;
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[4], *red;
int chap_star = SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR ? 1 : 0;
red = px->redirects;
if (SCHEME_FALSEP(red)) {
o = px->val;
continue;
}
o = px->prev;
if (!SCHEME_REDIRECTS_PROP_ONLY_VECTORP(red)) {
/* not a property only chaperone */
red = SCHEME_CDR(px->redirects);
if (chap_star) {
a[0] = outermost;
a[1] = o;
a[2] = scheme_make_integer(i);
a[3] = v;
v = _scheme_apply(red, 4, a);
}
else {
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = v;
v = _scheme_apply(red, 3, a);
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2 + chap_star]))
scheme_wrong_chaperoned("vector-set!", "value", a[2 + chap_star], v);
}
}
}
}
static Scheme_Object *
vector_star_length (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
if (!SCHEME_VECTORP(vec))
scheme_wrong_contract("vector*-length", "(and/c vector? (not/c impersonator?))", 0, argc, argv);
return scheme_make_integer(SCHEME_VEC_SIZE(vec));
}
static Scheme_Object *write_let_void(Scheme_Object *obj)
{
Scheme_Let_Void *lv;
lv = (Scheme_Let_Void *)obj;
return cons(scheme_make_integer(lv->count),
cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false,
scheme_protect_quote(lv->body)));
}
