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 }