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);
}
static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[])
{
if (SCHEME_CHAPERONEP(argv[0]))
return scheme_struct_ref(argv[0], SCHEME_INT_VAL(argv[1]));
else
return ((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])];
}
Scheme_Object *scheme_rational_add(const Scheme_Object *a, const Scheme_Object *b)
{
Scheme_Rational *ra = (Scheme_Rational *)a;
Scheme_Rational *rb = (Scheme_Rational *)b;
Scheme_Object *ac, *bd, *sum, *cd;
int no_normalize = 0;
if (SCHEME_INTP(ra->denom) && (SCHEME_INT_VAL(ra->denom) == 1)) {
/* Swap, to take advantage of the next optimization */
Scheme_Rational *rx = ra;
ra = rb;
rb = rx;
}
if (SCHEME_INTP(rb->denom) && (SCHEME_INT_VAL(rb->denom) == 1)) {
/* From Brad Lucier: */
/* (+ p/q n) = (make-rational (+ p (* n q)) q), no normalize */
ac = ra->num;
cd = ra->denom;
no_normalize = 1;
} else {
ac = scheme_bin_mult(ra->num, rb->denom);
cd = scheme_bin_mult(ra->denom, rb->denom);
}
bd = scheme_bin_mult(ra->denom, rb->num);
sum = scheme_bin_plus(ac, bd);
if (no_normalize)
return make_rational(sum, cd, 0);
else
return scheme_make_rational(sum, cd);
}
static Scheme_Object *read_quote_syntax(Scheme_Object *obj)
{
Scheme_Quote_Syntax *qs;
Scheme_Object *a;
int c, i, p;
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
c = SCHEME_INT_VAL(a);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
i = SCHEME_INT_VAL(a);
a = SCHEME_CDR(obj);
p = SCHEME_INT_VAL(a);
qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
qs->so.type = scheme_quote_syntax_type;
qs->depth = c;
qs->position = i;
qs->midpoint = p;
return (Scheme_Object *)qs;
}
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;
}
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[])
{
if (SCHEME_NP_CHAPERONEP(argv[0]))
return scheme_chaperone_vector_ref(argv[0], SCHEME_INT_VAL(argv[1]));
else
return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])];
}
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[])
{
if (SCHEME_NP_CHAPERONEP(argv[0]))
scheme_chaperone_vector_set(argv[0], SCHEME_INT_VAL(argv[1]), argv[2]);
else
SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}
static Scheme_Object *unsafe_struct_set (int argc, Scheme_Object *argv[])
{
if (SCHEME_CHAPERONEP(argv[0]))
scheme_struct_set(argv[0], SCHEME_INT_VAL(argv[1]), argv[2]);
else
((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}
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;
}
static int zpoll_wait(Scheme_Object *data)
{
Scheme_Object **argv;
zmq_pollitem_t *items;
int nitems, timeout;
argv = (Scheme_Object **)data;
items = SCHEME_CPTR_VAL(argv[0]);
nitems = SCHEME_INT_VAL(argv[1]);
timeout = SCHEME_INT_VAL(argv[2]);
return zmq_poll(items, nitems, timeout);
}
/**
* Convert a Scheme object to a GVariant that will serve as one of
* the parameters of a call go g_dbus_proxy_call_.... Returns NULL
* if it is unable to do the conversion.
*/
static GVariant *
scheme_object_to_parameter (Scheme_Object *obj, gchar *type)
{
gchar *str; // A temporary string
switch (type[0])
{
// Arrays
case 'a':
return scheme_object_to_array (obj, type);
// Doubles
case 'd':
if (SCHEME_DBLP (obj))
return g_variant_new ("d", SCHEME_DBL_VAL (obj));
else if (SCHEME_FLTP (obj))
return g_variant_new ("d", (double) SCHEME_FLT_VAL (obj));
else if (SCHEME_INTP (obj))
return g_variant_new ("d", (double) SCHEME_INT_VAL (obj));
else
return NULL;
// 32 bit integers
case 'i':
if (SCHEME_INTP (obj))
return g_variant_new ("i", (int) SCHEME_INT_VAL (obj));
else if (SCHEME_DBLP (obj))
return g_variant_new ("i", (int) SCHEME_DBL_VAL (obj));
else
return NULL;
// Strings
case 's':
str = scheme_object_to_string (obj);
if (str == NULL)
return NULL;
return g_variant_new ("s", str);
// 32 bit unsigned integers
case 'u':
if (SCHEME_INTP (obj))
return g_variant_new ("u", (unsigned int) SCHEME_INT_VAL (obj));
else
return NULL;
// Everything else is currently unsupported
default:
return NULL;
} // switch
} // scheme_object_to_parameter
Scheme_Object *scheme_rational_normalize(const Scheme_Object *o)
{
Scheme_Rational *r = (Scheme_Rational *)o;
Scheme_Object *gcd, *tmpn;
int negate = 0;
if (r->num == scheme_exact_zero)
return scheme_make_integer(0);
if (SCHEME_INTP(r->denom)) {
if (SCHEME_INT_VAL(r->denom) < 0) {
tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->denom));
r->denom = tmpn;
negate = 1;
}
} else if (!SCHEME_BIGPOS(r->denom)) {
tmpn = scheme_bignum_negate(r->denom);
r->denom = tmpn;
negate = 1;
}
if (negate) {
if (SCHEME_INTP(r->num)) {
tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->num));
r->num = tmpn;
} else {
tmpn = scheme_bignum_negate(r->num);
r->num = tmpn;
}
}
if (r->denom == one)
return r->num;
gcd = scheme_bin_gcd(r->num, r->denom);
if (gcd == one)
return (Scheme_Object *)o;
tmpn = scheme_bin_quotient(r->num, gcd);
r->num = tmpn;
tmpn = scheme_bin_quotient(r->denom, gcd);
r->denom = tmpn;
if (r->denom == one)
return r->num;
return (Scheme_Object *)r;
}
Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre)
{
int len, i;
Scheme_Object *loc;
Scheme_Sequence *s;
if (SCHEME_NULLP(clears))
return expr;
len = scheme_list_length(clears);
s = scheme_malloc_sequence(len + 1);
s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type);
s->count = len + 1;
s->array[pre ? len : 0] = expr;
for (i = 0; i < len; i++) {
loc = scheme_make_local(scheme_local_type,
SCHEME_INT_VAL(SCHEME_CAR(clears)),
SCHEME_LOCAL_CLEAR_ON_READ);
s->array[i + (pre ? 0 : 1)] = loc;
clears = SCHEME_CDR(clears);
}
return (Scheme_Object *)s;
}
static Scheme_Object *negate_simple(Scheme_Object *v)
{
if (SCHEME_INTP(v))
return scheme_make_integer_value(-SCHEME_INT_VAL(v));
else
return scheme_bignum_negate(v);
}
static Scheme_Object *
integer_to_char (int argc, Scheme_Object *argv[])
{
if (SCHEME_INTP(argv[0])) {
intptr_t v;
v = SCHEME_INT_VAL(argv[0]);
if ((v >= 0)
&& (v <= 0x10FFFF)
&& ((v < 0xD800) || (v > 0xDFFF)))
return _scheme_make_char((int)v);
} else if (SCHEME_BIGNUMP(argv[0])
&& SCHEME_BIGPOS(argv[0])) {
/* On 32-bit machines, there's still a chance... */
intptr_t y;
if (scheme_get_int_val(argv[0], &y)) {
if (y <= 0x10FFFF)
return _scheme_make_char((int)y);
}
}
scheme_wrong_contract("integer->char",
"(and/c (integer-in 0 #x10FFFF) (not/c (integer-in #xD800 #xDFFF)))",
0, argc, argv);
return NULL;
}
static Scheme_Object *read_letrec(Scheme_Object *obj)
{
Scheme_Letrec *lr;
int i, c;
Scheme_Object **sa;
lr = MALLOC_ONE_TAGGED(Scheme_Letrec);
lr->so.type = scheme_letrec_type;
if (!SCHEME_PAIRP(obj)) return NULL;
c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
lr->body = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
sa = MALLOC_N(Scheme_Object*, c);
lr->procs = sa;
for (i = 0; i < c; i++) {
if (!SCHEME_PAIRP(obj)) return NULL;
lr->procs[i] = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
}
return (Scheme_Object *)lr;
}
static Scheme_Object *
integer_to_char (int argc, Scheme_Object *argv[])
{
if (SCHEME_INTP(argv[0])) {
long v;
v = SCHEME_INT_VAL(argv[0]);
if ((v >= 0)
&& (v <= 0x10FFFF)
&& ((v < 0xD800) || (v > 0xDFFF)))
return _scheme_make_char(v);
} else if (SCHEME_BIGNUMP(argv[0])
&& SCHEME_BIGPOS(argv[0])) {
/* On 32-bit machines, there's still a chance... */
long y;
if (scheme_get_int_val(argv[0], &y)) {
if (y <= 0x10FFFF)
return _scheme_make_char(y);
}
}
scheme_wrong_type("integer->char",
"exact integer in [0,#x10FFFF], not in [#xD800,#xDFFF]",
0, argc, argv);
return NULL;
}
static int out_of_line(Scheme_Object *a)
{
Scheme_Thread *p;
int n, i;
Scheme_Channel_Syncer *w;
/* Out of one line? */
n = SCHEME_INT_VAL(((Scheme_Object **)a)[0]);
for (i = 0; i < n; i++) {
w = (((Scheme_Channel_Syncer ***)a)[1])[i];
if (w->picked)
return 1;
}
/* Suspended break? */
p = ((Scheme_Thread **)a)[2];
if (p->external_break) {
int v;
--p->suspend_break;
v = scheme_can_break(p);
p->suspend_break++;
if (v)
return 1;
}
/* Suspended by user? */
if ((p->running & MZTHREAD_USER_SUSPENDED)
|| scheme_main_was_once_suspended)
return 1;
return 0;
}
Scheme_Object *
irgb_new (int argc, Scheme_Object **argv)
{
if (! SCHEME_INTP (argv[0]))
scheme_wrong_type ("irgb-red", "integer", 0, 3, argv);
if (! SCHEME_INTP (argv[1]))
scheme_wrong_type ("irgb-red", "integer", 1, 3, argv);
if (! SCHEME_INTP (argv[2]))
scheme_wrong_type ("irgb-red", "integer", 2, 3, argv);
int r = byte (SCHEME_INT_VAL (argv[0]));
int g = byte (SCHEME_INT_VAL (argv[1]));
int b = byte (SCHEME_INT_VAL (argv[2]));
return scheme_make_integer ((r << 16) | (g << 8) | b);
} // irgb_new
Scheme_Object *
scheme_abs(int argc, Scheme_Object *argv[])
{
Scheme_Type t;
Scheme_Object *o;
o = argv[0];
if (SCHEME_INTP(o)) {
intptr_t n = SCHEME_INT_VAL(o);
return scheme_make_integer_value(ABS(n));
}
t = _SCHEME_TYPE(o);
#ifdef MZ_USE_SINGLE_FLOATS
if (t == scheme_float_type)
return scheme_make_float(fabs(SCHEME_FLT_VAL(o)));
#endif
if (t == scheme_double_type)
return scheme_make_double(fabs(SCHEME_DBL_VAL(o)));
if (t == scheme_bignum_type) {
if (SCHEME_BIGPOS(o))
return o;
return scheme_bignum_negate(o);
}
if (t == scheme_rational_type) {
if (scheme_is_rational_positive(o))
return o;
else
return scheme_rational_negate(o);
}
NEED_REAL(abs);
ESCAPED_BEFORE_HERE;
}
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;
}
Scheme_Object *
irgb_red (int argc, Scheme_Object **argv)
{
if (! SCHEME_INTP (argv[0]))
scheme_wrong_type ("irgb-red", "integer", 1, 1, argv);
int color = SCHEME_INT_VAL (argv[0]);
return scheme_make_integer ((color >> 16) & 255);
} // irgb_red
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
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);
}
int scheme_is_rational_positive(const Scheme_Object *o)
{
Scheme_Rational *r = (Scheme_Rational *)o;
if (SCHEME_INTP(r->num))
return (SCHEME_INT_VAL(r->num) > 0);
else
return SCHEME_BIGPOS(r->num);
}
Scheme_Object *scheme_rational_round(const Scheme_Object *o)
{
Scheme_Rational *r = (Scheme_Rational *)o;
Scheme_Object *q, *qd, *delta, *half;
int more = 0, can_eq_half, negative;
negative = !scheme_is_rational_positive(o);
q = scheme_bin_quotient(r->num, r->denom);
/* Get remainder absolute value: */
qd = scheme_bin_mult(q, r->denom);
if (negative)
delta = scheme_bin_minus(qd, r->num);
else
delta = scheme_bin_minus(r->num, qd);
half = scheme_bin_quotient(r->denom, scheme_make_integer(2));
can_eq_half = SCHEME_FALSEP(scheme_odd_p(1, &r->denom));
if (SCHEME_INTP(half) && SCHEME_INTP(delta)) {
if (can_eq_half && (SCHEME_INT_VAL(delta) == SCHEME_INT_VAL(half)))
more = SCHEME_TRUEP(scheme_odd_p(1, &q));
else
more = (SCHEME_INT_VAL(delta) > SCHEME_INT_VAL(half));
} else if (SCHEME_BIGNUMP(delta) && SCHEME_BIGNUMP(half)) {
if (can_eq_half && (scheme_bignum_eq(delta, half)))
more = SCHEME_TRUEP(scheme_odd_p(1, &q));
else
more = !scheme_bignum_lt(delta, half);
} else
more = SCHEME_BIGNUMP(delta);
if (more) {
if (negative)
q = scheme_sub1(1, &q);
else
q = scheme_add1(1, &q);
}
return q;
}
static Scheme_Object *unsafe_vector_star_cas (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
Scheme_Object *idx = argv[1];
Scheme_Object *ov = argv[2];
Scheme_Object *nv = argv[3];
#ifdef MZ_USE_FUTURES
return mzrt_cas((volatile uintptr_t *)(SCHEME_VEC_ELS(vec) + SCHEME_INT_VAL(idx)),
(uintptr_t)ov, (uintptr_t)nv)
? scheme_true : scheme_false;
#else
/* For cooperative threading, no atomicity required */
if (SCHEME_VEC_ELS(vec)[SCHEME_INT_VAL(idx)] == ov) {
SCHEME_VEC_ELS(vec)[SCHEME_INT_VAL(idx)] = nv;
return scheme_true;
} else {
return scheme_false;
}
#endif
}
static void check_always_fixnum(const char *name, Scheme_Object *o)
{
if (SCHEME_INTP(o)) {
intptr_t v = SCHEME_INT_VAL(o);
if ((v < -1073741824) || (v > 1073741823)) {
scheme_contract_error(name,
"cannot fold to result that is not a fixnum on some platforms",
"result", 1, o,
NULL);
}
}
}
static int zpoll_ready(Scheme_Object *data)
{
Scheme_Object **argv;
zmq_pollitem_t *items;
int nitems;
argv = (Scheme_Object **)data;
items = SCHEME_CPTR_VAL(argv[0]);
nitems = SCHEME_INT_VAL(argv[1]);
return zmq_poll(items, nitems, 0);
}
static Scheme_Object *unsafe_struct_star_cas (int argc, Scheme_Object *argv[])
{
Scheme_Object *s = argv[0];
Scheme_Object *idx = argv[1];
Scheme_Object *ov = argv[2];
Scheme_Object *nv = argv[3];
#ifdef MZ_USE_FUTURES
return (mzrt_cas((volatile uintptr_t *)(&((Scheme_Structure *)s)->slots[SCHEME_INT_VAL(idx)]),
(uintptr_t)ov, (uintptr_t)nv)
? scheme_true : scheme_false);
#else
/* For cooperative threading, no atomicity required */
if (((Scheme_Structure *)s)->slots[SCHEME_INT_VAL(idx)] == ov) {
((Scheme_Structure *)s)->slots[SCHEME_INT_VAL(idx)] = nv;
return scheme_true;
} else {
return scheme_false;
}
#endif
}
