static Scheme_Object *define_values_jit(Scheme_Object *data) { Scheme_Object *orig = SCHEME_DEFN_RHS(data), *naya; if (SAME_TYPE(SCHEME_TYPE(orig), scheme_lambda_type) && (SCHEME_DEFN_VAR_COUNT(data) == 1)) naya = scheme_jit_closure(orig, SCHEME_DEFN_VAR_(data, 0)); else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type) && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_lambda_type) && (SCHEME_DEFN_VAR_COUNT(data) == 1)) { naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_DEFN_VAR_(data, 0)); if (!SAME_OBJ(naya, SCHEME_DEFN_RHS(orig))) naya = clone_inline_variant(orig, naya); } else naya = jit_expr(orig); if (SAME_OBJ(naya, orig)) return data; else { orig = naya; naya = scheme_clone_vector(data, 0, 1); SCHEME_DEFN_RHS(naya) = orig; return naya; } }
static Scheme_Object *define_values_jit(Scheme_Object *data) { Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya; if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type) && (SCHEME_VEC_SIZE(data) == 2)) naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]); else if (SAME_TYPE(SCHEME_TYPE(orig), scheme_inline_variant_type) && SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(orig)[0]), scheme_unclosed_procedure_type) && (SCHEME_VEC_SIZE(data) == 2)) { naya = scheme_jit_closure(SCHEME_VEC_ELS(orig)[0], SCHEME_VEC_ELS(data)[1]); if (!SAME_OBJ(naya, SCHEME_VEC_ELS(orig)[0])) naya = clone_inline_variant(orig, naya); } else naya = scheme_jit_expr(orig); if (SAME_OBJ(naya, orig)) return data; else { orig = naya; naya = scheme_clone_vector(data, 0, 1); SCHEME_VEC_ELS(naya)[0] = orig; return naya; } }
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) { if (argc == 1) { Scheme_Object *mso; Scheme_Place_Bi_Channel *ch; if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) { ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel; } else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) { ch = (Scheme_Place_Bi_Channel *) args[0]; } else { ch = NULL; scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args); } { void *msg_memory = NULL; mso = scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch, &msg_memory); return scheme_places_deserialize(mso, msg_memory); } } else { scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0); } return scheme_true; }
XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2) { Scheme_Type t1, t2; if (SAME_OBJ(obj1, obj2)) return 1; t1 = SCHEME_TYPE(obj1); t2 = SCHEME_TYPE(obj2); if (NOT_SAME_TYPE(t1, t2)) { #ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS /* If one is a float and the other is a double, coerce to double */ if ((t1 == scheme_float_type) && (t2 == scheme_double_type)) return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2)); else if ((t2 == scheme_float_type) && (t1 == scheme_double_type)) return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2)); #endif return -1; } else { switch (t1) { #ifdef MZ_LONG_DOUBLE case scheme_long_double_type: return mz_long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2)); #endif #ifdef MZ_USE_SINGLE_FLOATS case scheme_float_type: return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2)); #endif case scheme_double_type: return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2)); case scheme_bignum_type: return scheme_bignum_eq(obj1, obj2); case scheme_rational_type: return scheme_rational_eq(obj1, obj2); case scheme_complex_type: { Scheme_Complex *c1 = (Scheme_Complex *)obj1; Scheme_Complex *c2 = (Scheme_Complex *)obj2; return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i); } case scheme_char_type: return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2); case scheme_symbol_type: case scheme_keyword_type: case scheme_scope_type: /* `eqv?` requires `eq?` */ return 0; default: return -1; } } }
GVariant * scheme_obj_to_gvariant (Scheme_Object *list) { GVariant *rvalue; Scheme_Object *firstelement; int length; long i; char* rstring; double rdouble; rvalue = NULL; length = scheme_list_length (list); if (length == 0) { return rvalue ; } else if (length == 1) { // Get the first element of the argument firstelement = scheme_car (list); // checking the scheme_type to see whether it is an integer or not // Eventually see if we can convert this to a switch statement. if (SCHEME_TYPE (firstelement)== scheme_integer_type) { // we saved the return value at &i scheme_get_int_val (list,&i); // we concert it to g_variant rvalue = g_variant_new ("(i)", i); return rvalue; } // if it's an integer else if (SCHEME_TYPE (firstelement) == scheme_char_type) { //getting the string out of the scheme_object rstring = SCHEME_BYTE_STR_VAL(list); // we will convert it to g_variant rvalue = g_variant_new_string(rstring); return rvalue; } // if it's a character else if (SCHEME_TYPE (firstelement) == scheme_double_type) { //getting the double out of the scheme_object rdouble = scheme_real_to_double(list); // we will convert it to g_variant rvalue = g_variant_new_double(rdouble); return rvalue; } // if it's a double } // if we have a single element return rvalue; } // scheme_obj_to_gvariant
static void sfs_note_app(SFS_Info *info, Scheme_Object *rator) { if (!info->pass) { if (!info->tail_pos) { if (SAME_OBJ(scheme_values_func, rator)) /* no need to clear for app of `values' */ return; if (SCHEME_PRIMP(rator)) { int opt; opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; if (opt >= SCHEME_PRIM_OPT_IMMEDIATE) /* Don't need to clear stack before an immediate/folding call */ return; } info->max_nontail = info->ip; } else { if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) { if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) { if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) { /* No point in clearing out any of the closure before the tail call. */ int i; for (i = info->selflen; i--; ) { if ((info->selfstart + i) != info->tlpos) scheme_sfs_used(info, (info->selfstart - info->stackpos) + i); } } } } } } }
static Scheme_Object *read_sequence_splice(Scheme_Object *obj) { obj = scheme_make_sequence_compilation(obj, 1); if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type)) obj->type = scheme_splice_sequence_type; return obj; }
intptr_t BTC_get_memory_use(NewGC* gc, void *o) { Scheme_Object *arg = (Scheme_Object*)o; if(SAME_TYPE(SCHEME_TYPE(arg), scheme_custodian_type)) { return custodian_usage(gc, arg); } return 0; }
XFORM_NONGCING static int is_eqv(Scheme_Object *obj1, Scheme_Object *obj2) { Scheme_Type t1, t2; if (SAME_OBJ(obj1, obj2)) return 1; t1 = SCHEME_TYPE(obj1); t2 = SCHEME_TYPE(obj2); if (NOT_SAME_TYPE(t1, t2)) { #ifdef EQUATE_FLOATS_OF_DIFFERENT_PRECISIONS /* If one is a float and the other is a double, coerce to double */ if ((t1 == scheme_float_type) && (t2 == scheme_double_type)) return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_DBL_VAL(obj2)); else if ((t2 == scheme_float_type) && (t1 == scheme_double_type)) return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_FLT_VAL(obj2)); #endif return -1; #ifdef MZ_LONG_DOUBLE } else if (t1 == scheme_long_double_type) { return long_double_eqv(SCHEME_LONG_DBL_VAL(obj1), SCHEME_LONG_DBL_VAL(obj2)); #endif #ifdef MZ_USE_SINGLE_FLOATS } else if (t1 == scheme_float_type) { return double_eqv(SCHEME_FLT_VAL(obj1), SCHEME_FLT_VAL(obj2)); #endif } else if (t1 == scheme_double_type) { return double_eqv(SCHEME_DBL_VAL(obj1), SCHEME_DBL_VAL(obj2)); } else if (t1 == scheme_bignum_type) return scheme_bignum_eq(obj1, obj2); else if (t1 == scheme_rational_type) return scheme_rational_eq(obj1, obj2); else if (t1 == scheme_complex_type) { Scheme_Complex *c1 = (Scheme_Complex *)obj1; Scheme_Complex *c2 = (Scheme_Complex *)obj2; return scheme_eqv(c1->r, c2->r) && scheme_eqv(c1->i, c2->i); } else if (t1 == scheme_char_type) return SCHEME_CHAR_VAL(obj1) == SCHEME_CHAR_VAL(obj2); else return -1; }
static int scheme_place_channel_ready(Scheme_Object *so) { Scheme_Place_Bi_Channel *ch; if (SAME_TYPE(SCHEME_TYPE(so), scheme_place_type)) { ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) so)->channel; } else { ch = (Scheme_Place_Bi_Channel *)so; } return scheme_place_async_ch_ready((Scheme_Place_Async_Channel *) ch->recvch); }
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) { if (argc == 1) { Scheme_Place_Bi_Channel *ch; if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) { ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel; } else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) { ch = (Scheme_Place_Bi_Channel *) args[0]; } else { ch = NULL; scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args); } return scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch); } else { scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0); } return scheme_true; }
Scheme_Object *scheme_place_send(int argc, Scheme_Object *args[]) { if (argc == 2) { Scheme_Place_Bi_Channel *ch; if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) { ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel; } else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) { ch = (Scheme_Place_Bi_Channel *) args[0]; } else { ch = NULL; scheme_wrong_type("place-channel-send", "place-channel", 0, argc, args); } scheme_place_async_send((Scheme_Place_Async_Channel *) ch->sendch, args[1]); } else { scheme_wrong_count_m("place-channel-send", 2, 2, argc, args, 0); } return scheme_true; }
static Scheme_Object * case_lambda_sfs(Scheme_Object *expr, SFS_Info *info) { Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; Scheme_Object *le, *clears = scheme_null; int i; scheme_sfs_start_sequence(info, seq->count, 0); for (i = 0; i < seq->count; i++) { le = seq->array[i]; le = scheme_sfs_expr(le, info, -1); if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. Lift them out. */ int j; Scheme_Sequence *cseq = (Scheme_Sequence *)le; if (!cseq->count) scheme_signal_error("internal error: empty sequence"); for (j = 1; j < cseq->count; j++) { int pos; pos = SCHEME_LOCAL_POS(cseq->array[j]); clears = scheme_make_pair(scheme_make_integer(pos), clears); } le = cseq->array[0]; } if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type) && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) { scheme_signal_error("internal error: not a lambda for case-lambda: %d", SCHEME_TYPE(le)); } seq->array[i] = le; } if (!SCHEME_NULLP(clears)) { return scheme_sfs_add_clears(expr, clears, 0); } else return expr; }
static Scheme_Object *flatten_sequence(Scheme_Object *o) { /* At this point, we sometimes have (begin ... (begin ... (begin ...))). Flatten those out. */ Scheme_Sequence *s = (Scheme_Sequence *)o, *s2; int i, extra = 0; o = s->array[s->count - 1]; while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) { s2 = (Scheme_Sequence *)o; extra += s2->count - 1; o = s2->array[s2->count - 1]; } if (extra) { s2 = scheme_malloc_sequence(s->count + extra); s2->so.type = scheme_sequence_type; s2->count = s->count + extra; extra = 0; o = (Scheme_Object *)s; while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) { s = (Scheme_Sequence *)o; for (i = 0; i < s->count - 1; i++) { s2->array[extra++] = s->array[i]; } o = s->array[i]; } s2->array[extra++] = o; if (extra != s2->count) scheme_signal_error("internal error: flatten failed"); return (Scheme_Object *)s2; } else return (Scheme_Object *)s; }
Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth) { int init, i; SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o))); if (!info) { info = scheme_new_sfs_info(max_let_depth); } info->pass = 0; info->ip = 1; info->abs_ip = 1; info->saved = scheme_null; info->min_touch = -1; info->max_touch = -1; info->tail_pos = 1; init = info->stackpos; o = scheme_sfs_expr(o, info, -1); if (info->seqn) scheme_signal_error("ended in the middle of an expression?"); # if MAX_SFS_CLEARING info->max_nontail = info->ip; info->abs_max_nontail = info->abs_ip; # endif for (i = info->depth; i-- > init; ) { info->max_calls[i] = info->max_nontail; } { Scheme_Object *v; v = scheme_reverse(info->saved); info->saved = v; } info->pass = 1; info->seqn = 0; info->ip = 1; info->abs_ip = 1; info->tail_pos = 1; info->stackpos = init; o = scheme_sfs_expr(o, info, -1); return o; }
long gpioread(Chan *c, void *va, long n, vlong off) { int type, scheme; uint pin; char *a; a = va; if(c->qid.type & QTDIR) { return devdirread(c, va, n, 0, 0, gpiogen); } type = FILE_TYPE(c->qid); scheme = SCHEME_TYPE(c->qid); if(scheme != Qgeneric && scheme != pinscheme) { error(nil); } switch(type) { case Qdata: pin = PIN_NUMBER(c->qid); a[0] = (gpioin(pin))?'1':'0'; n = 1; break; case Qctl: break; case Qevent: if(off >= 4) { off %= 4; eventvalue = 0; } sleep(&rend, isset, 0); if(off + n > 4) { n = 4 - off; } memmove(a, &eventvalue + off, n); } return n; }
static int scheme_place_channel_ready(Scheme_Object *so, Scheme_Schedule_Info *sinfo) { Scheme_Place_Bi_Channel *ch; Scheme_Object *msg = NULL; if (SAME_TYPE(SCHEME_TYPE(so), scheme_place_type)) { ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) so)->channel; } else { ch = (Scheme_Place_Bi_Channel *)so; } msg = scheme_place_async_try_recv((Scheme_Place_Async_Channel *) ch->recvch); if (msg != NULL) { scheme_set_sync_target(sinfo, msg, NULL, NULL, 0, 0, NULL); return 1; } return 0; }
static Scheme_Object *read_case_lambda(Scheme_Object *obj) { Scheme_Object *s, *a; int count, i, all_closed = 1; Scheme_Case_Lambda *cl; if (!SCHEME_PAIRP(obj)) return NULL; s = SCHEME_CDR(obj); for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) { count++; } cl = (Scheme_Case_Lambda *) scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + (count - 1) * sizeof(Scheme_Object *)); cl->so.type = scheme_case_lambda_sequence_type; cl->count = count; cl->name = SCHEME_CAR(obj); if (SCHEME_NULLP(cl->name)) cl->name = NULL; s = SCHEME_CDR(obj); for (i = 0; i < count; i++, s = SCHEME_CDR(s)) { a = SCHEME_CAR(s); cl->array[i] = a; if (!SCHEME_PROCP(a)) { if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type)) return NULL; all_closed = 0; } } if (all_closed) { /* Empty closure: produce procedure value directly. (We assume that this was generated by a direct write of a case-lambda data record in print.c, and that it's not in a CASE_LAMBDA_EXPD syntax record.) */ return scheme_case_lambda_execute((Scheme_Object *)cl); } return (Scheme_Object *)cl; }
static Scheme_Object *do_define_syntaxes_clone(Scheme_Object *expr, int jit) { Resolve_Prefix *rp, *orig_rp; Scheme_Object *naya, *rhs; rhs = SCHEME_VEC_ELS(expr)[0]; #ifdef MZ_USE_JIT if (jit) { if (SAME_TYPE(SCHEME_TYPE(expr), scheme_define_syntaxes_type)) naya = scheme_jit_expr(rhs); else { int changed = 0; Scheme_Object *a, *l = rhs; naya = scheme_null; while (!SCHEME_NULLP(l)) { a = scheme_jit_expr(SCHEME_CAR(l)); if (!SAME_OBJ(a, SCHEME_CAR(l))) changed = 1; naya = scheme_make_pair(a, naya); l = SCHEME_CDR(l); } if (changed) naya = scheme_reverse(naya); else naya = rhs; } } else #endif naya = rhs; orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1]; rp = scheme_prefix_eval_clone(orig_rp); if (SAME_OBJ(naya, rhs) && SAME_OBJ(orig_rp, rp)) return expr; else { expr = scheme_clone_vector(expr, 0, 1); SCHEME_VEC_ELS(expr)[0] = naya; SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp; return expr; } }
static Scheme_Object *scheme_place_wait(int argc, Scheme_Object *args[]) { Scheme_Place *place; place = (Scheme_Place *) args[0]; if (argc != 1) { scheme_wrong_count_m("place-wait", 1, 1, argc, args, 0); } if (!SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) { scheme_wrong_type("place-wait", "place", 0, argc, args); } # ifdef MZ_PRECISE_GC { Scheme_Object *rc; mz_proc_thread *worker_thread; Scheme_Place *waiting_place; int *wake_fd; proc_thread_wait_data *wd; wd = (proc_thread_wait_data*) malloc(sizeof(proc_thread_wait_data)); wd->proc_thread = (mz_proc_thread *)place->proc_thread; wd->waiting_place = waiting_place; wake_fd = scheme_get_signal_handle(); wd->wake_fd = wake_fd; wd->ready = 0; worker_thread = mz_proc_thread_create(mz_proc_thread_wait_worker, wd); mz_proc_thread_detach(worker_thread); scheme_block_until(place_wait_ready, NULL, (Scheme_Object *) wd, 0); rc = scheme_make_integer((intptr_t)wd->rc); free(wd); return rc; } # else { void *rcvoid; rcvoid = mz_proc_thread_wait((mz_proc_thread *)place->proc_thread); return scheme_make_integer((intptr_t) rcvoid); } # endif }
static void get_outof_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w) { Scheme_Channel_Syncer *last, *first; if (!w->in_line) return; w->in_line = 0; if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) { return; /* !!!! skip everything else */ } else if (SCHEME_SEMAP(sema)) { last = sema->last; first = sema->first; } else if (SCHEME_CHANNELP(sema)) { last = ((Scheme_Channel *)sema)->get_last; first = ((Scheme_Channel *)sema)->get_first; } else { last = ((Scheme_Channel_Put *)sema)->ch->put_last; first = ((Scheme_Channel_Put *)sema)->ch->put_first; } if (w->prev) w->prev->next = w->next; else first = w->next; if (w->next) w->next->prev = w->prev; else last = w->prev; if (SCHEME_SEMAP(sema)) { sema->last = last; sema->first = first; } else if (SCHEME_CHANNELP(sema)) { ((Scheme_Channel *)sema)->get_last = last; ((Scheme_Channel *)sema)->get_first = first; } else { ((Scheme_Channel_Put *)sema)->ch->put_last = last; ((Scheme_Channel_Put *)sema)->ch->put_first = first; } }
static void get_into_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w) /* Can be called multiple times. */ { Scheme_Channel_Syncer *last, *first; w->in_line = 1; w->picked = 0; if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) { return; /* !!!! skip everything else */ } else if (SCHEME_SEMAP(sema)) { last = sema->last; first = sema->first; } else if (SCHEME_CHANNELP(sema)) { last = ((Scheme_Channel *)sema)->get_last; first = ((Scheme_Channel *)sema)->get_first; } else { last = ((Scheme_Channel_Put *)sema)->ch->put_last; first = ((Scheme_Channel_Put *)sema)->ch->put_first; } w->prev = last; if (last) last->next = w; else first = w; last = w; w->next = NULL; if (SCHEME_SEMAP(sema)) { sema->last = last; sema->first = first; } else if (SCHEME_CHANNELP(sema)) { ((Scheme_Channel *)sema)->get_last = last; ((Scheme_Channel *)sema)->get_first = first; } else { ((Scheme_Channel_Put *)sema)->ch->put_last = last; ((Scheme_Channel_Put *)sema)->ch->put_first = first; } }
void count_tagged(void *p, int size, void *data) { int which = SCHEME_TYPE((Scheme_Object *)p); if ((which >= 0) && (which < _scheme_last_type_)) { scheme_count_memory((Scheme_Object *)p, smc_ht); } else if (which >= scheme_num_types()) bad_seeds++; else { if (which >= NUM_TYPE_SLOTS) which = NUM_TYPE_SLOTS - 1; scheme_memory_count[which]++; scheme_memory_size[which] += size; } if (which == obj_type) { if (obj_buffer_pos < OBJ_BUFFER_SIZE) { obj_buffer[obj_buffer_pos++] = p; } } if (which == scheme_application_type) { Scheme_App_Rec *app = (Scheme_App_Rec *)p; int cnt; cnt = app->num_args; if (cnt >= NUM_RECORDED_APP_SIZES) { cnt = NUM_RECORDED_APP_SIZES; } else { int i, devals, kind; devals = sizeof(Scheme_App_Rec) + (app->num_args * sizeof(Scheme_Object *)); for (i = 0; i <= cnt; i++) { kind = ((char *)app + devals)[i]; if ((kind >= 0) && (kind <= 4)) { app_arg_kinds[cnt][i][kind]++; } } } app_sizes[cnt]++; } }
static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info) { Scheme_Letrec *lr = (Scheme_Letrec *)o; Scheme_Object **procs, *v, *clears = scheme_null; int i, count; count = lr->count; scheme_sfs_start_sequence(info, count + 1, 1); procs = lr->procs; for (i = 0; i < count; i++) { v = scheme_sfs_expr(procs[i], info, i); if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) { /* Some clearing actions were added to the closure. Lift them out. */ int j; Scheme_Sequence *cseq = (Scheme_Sequence *)v; for (j = 1; j < cseq->count; j++) { int pos; pos = SCHEME_LOCAL_POS(cseq->array[j]); clears = scheme_make_pair(scheme_make_integer(pos), clears); } v = cseq->array[0]; } procs[i] = v; } v = scheme_sfs_expr(lr->body, info, -1); v = scheme_sfs_add_clears(v, clears, 1); lr->body = v; return o; }
static void trace_count(void *p, int size) { int which = SCHEME_TYPE((Scheme_Object *)p); if ((which >= 0) && (which <= _scheme_last_type_)) { /* fall through to below */ } else if (which >= scheme_num_types()) { bad_seeds++; return; } else { if (which >= NUM_TYPE_SLOTS) which = NUM_TYPE_SLOTS - 1; /* fall through to below */ } { unsigned long s = (unsigned long)p; scheme_memory_actual_count[which]++; scheme_memory_actual_size[which] += size; if (!scheme_memory_lo[which] || (s < scheme_memory_lo[which])) scheme_memory_lo[which] = s; if (!scheme_memory_hi[which] || (s > scheme_memory_hi[which])) scheme_memory_hi[which] = s; } }
/** *Translating the scheme_object to gvariant type for the client *This step is used on sending input values onto the DBus */ GVariant * scheme_obj_to_gvariant (Scheme_Object *list) { GVariantBuilder *builder; GVariant *finalr; GVariant *rvalue = NULL; Scheme_Object *firstelement; int length = 0; gint32 i; char* rstring; double rdouble; builder = g_variant_builder_new(G_VARIANT_TYPE_TUPLE); length = scheme_list_length (list); // rvalue = g_new(GVariant *, length); if (length == 0) { // scheme_signal_error("length 0"); return rvalue ; } // if else{ while (length != 0) { // Get the first element of the argument firstelement = scheme_car (list); list = scheme_cdr(list); length = scheme_list_length(list); // checking the scheme_type to see whether it is an integer or not // Eventually see if we can convert this to a switch statement. if (SCHEME_INTP (firstelement)) { // we saved the return value at &i i = SCHEME_INT_VAL(firstelement); rvalue = g_variant_new ("i",i); g_variant_builder_add_value(builder,rvalue); // return rvalue; } // if it's an integer else if (SCHEME_BYTE_STRINGP (firstelement)|| SCHEME_CHAR_STRINGP(firstelement)) { //scheme_signal_error ("We are in Character"); //getting the string out of the scheme_object rstring = SCHEME_BYTE_STR_VAL(list); // we will convert it to g_variant rvalue = g_variant_new ("(&s)", rstring); g_variant_builder_add_value(builder, rvalue); } // if it's a character else if (SCHEME_TYPE (firstelement) == scheme_double_type) { //getting the double out of the scheme_object rdouble = scheme_real_to_double(list); // we will convert it to g_variant rvalue = g_variant_new_double(rdouble); g_variant_builder_add_value(builder, rvalue); } // if it's a double } // while loop finalr = g_variant_builder_end (builder); return finalr; } //else return finalr; } // scheme_obj_to_gvariant
long gpiowrite(Chan *c, void *va, long n, vlong) { int type, i, scheme; uint pin; char *arg; Cmdbuf *cb; Cmdtab *ct; if(c->qid.type & QTDIR) { error(Eisdir); } type = FILE_TYPE(c->qid); scheme = SCHEME_TYPE(c->qid); if(scheme != Qgeneric && scheme != pinscheme) { error(nil); } cb = parsecmd(va, n); if(waserror()) { free(cb); nexterror(); } ct = lookupcmd(cb, gpiocmd, nelem(gpiocmd)); if(ct == nil) { error(Ebadctl); } switch(type) { case Qdata: pin = PIN_NUMBER(c->qid); switch(ct->index) { case CMzero: gpioout(pin, 0); break; case CMone: gpioout(pin, 1); break; default: error(Ebadctl); } break; case Qctl: switch(ct->index) { case CMscheme: arg = cb->f[1]; for(i = 0; i < nelem(schemename); i++) { if(strncmp(schemename[i], arg, strlen(schemename[i])) == 0) { pinscheme = i; break; } } break; case CMfunc: pin = getpin(cb->f[2]); arg = cb->f[1]; if(pin == -1) { error(Ebadctl); } for(i = 0; i < nelem(funcname); i++) { if(strncmp(funcname[i], arg, strlen(funcname[i])) == 0) { gpiofuncset(pin, i); break; } } break; case CMpull: pin = getpin(cb->f[2]); if(pin == -1) { error(Ebadctl); } arg = cb->f[1]; for(i = 0; i < nelem(pudname); i++) { if(strncmp(pudname[i], arg, strlen(pudname[i])) == 0) { gpiopullset(pin, i); break; } } break; case CMevent: pin = getpin(cb->f[3]); if(pin == -1) { error(Ebadctl); } arg = cb->f[1]; for(i = 0; i < nelem(evtypename); i++) { if(strncmp(evtypename[i], arg, strlen(evtypename[i])) == 0) { gpioevent(pin, i, (cb->f[2][0] == 'e')); break; } } break; default: error(Ebadctl); } break; } free(cb); poperror(); return n; }
static int gpiogen(Chan *c, char *, Dirtab *, int , int s, Dir *db) { Qid qid; int parent, scheme, l; char **pintable = getpintable(); qid.vers = 0; parent = PARENT_TYPE(c->qid); scheme = SCHEME_TYPE(c->qid); if(s == DEVDOTDOT) { switch(parent) { case Qtopdir: case Qgpiodir: mkdeventry(c, qid, &topdir, db); break; default: return -1; } return 1; } if(parent == Qtopdir) { switch(s) { case 0: mkdeventry(c, qid, &gpiodir, db); break; default: return -1; } return 1; } if(scheme != Qgeneric && scheme != pinscheme) { error(nil); } if(parent == Qgpiodir) { l = nelem(typedir); if(s < l) { mkdeventry(c, qid, &typedir[s], db); } else if (s < l + PIN_TABLE_SIZE) { s -= l; if(pintable[s] == 0) { return 0; } mkqid(&qid, PATH(s, pinscheme, Qgpiodir, Qdata), 0, QTFILE); snprint(up->genbuf, sizeof up->genbuf, "%s", pintable[s]); devdir(c, qid, up->genbuf, 0, eve, 0666, db); } else { return -1; } return 1; } return 1; }
int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) { Scheme_Type t1, t2; int cmp; top: if (eql->next_next) { if (eql->next) { Scheme_Object *a[2]; a[0] = obj1; a[1] = obj2; obj1 = _scheme_apply(eql->next, 2, a); return SCHEME_TRUEP(obj1); } eql->next = eql->next_next; } cmp = is_eqv(obj1, obj2); if (cmp > -1) return cmp; if (eql->for_chaperone && SCHEME_CHAPERONEP(obj1) && (!(SCHEME_CHAPERONE_FLAGS((Scheme_Chaperone *)obj1) & SCHEME_CHAPERONE_IS_IMPERSONATOR) || (eql->for_chaperone > 1))) { obj1 = ((Scheme_Chaperone *)obj1)->prev; goto top; } t1 = SCHEME_TYPE(obj1); t2 = SCHEME_TYPE(obj2); if (NOT_SAME_TYPE(t1, t2)) { if (!eql->for_chaperone) { if (SCHEME_CHAPERONEP(obj1)) { obj1 = ((Scheme_Chaperone *)obj1)->val; goto top; } if (SCHEME_CHAPERONEP(obj2)) { obj2 = ((Scheme_Chaperone *)obj2)->val; goto top; } } return 0; } else if (t1 == scheme_pair_type) { # include "mzeqchk.inc" if ((eql->car_depth > 2) || !scheme_is_list(obj1)) { if (union_check(obj1, obj2, eql)) return 1; } eql->car_depth += 2; if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) { eql->car_depth -= 2; obj1 = SCHEME_CDR(obj1); obj2 = SCHEME_CDR(obj2); goto top; } else return 0; } else if (t1 == scheme_mutable_pair_type) { # include "mzeqchk.inc" if (eql->for_chaperone == 1) return 0; if (union_check(obj1, obj2, eql)) return 1; if (is_equal(SCHEME_CAR(obj1), SCHEME_CAR(obj2), eql)) { obj1 = SCHEME_CDR(obj1); obj2 = SCHEME_CDR(obj2); goto top; } else return 0; } else if ((t1 == scheme_vector_type) || (t1 == scheme_fxvector_type)) { # include "mzeqchk.inc" if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2))) return 0; if (union_check(obj1, obj2, eql)) return 1; return vector_equal(obj1, obj2, eql); } else if (t1 == scheme_flvector_type) { intptr_t l1, l2, i; l1 = SCHEME_FLVEC_SIZE(obj1); l2 = SCHEME_FLVEC_SIZE(obj2); if (l1 == l2) { for (i = 0; i < l1; i++) { if (!double_eqv(SCHEME_FLVEC_ELS(obj1)[i], SCHEME_FLVEC_ELS(obj2)[i])) return 0; } return 1; } return 0; } else if ((t1 == scheme_byte_string_type) || ((t1 >= scheme_unix_path_type) && (t1 <= scheme_windows_path_type))) { intptr_t l1, l2; if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2))) return 0; l1 = SCHEME_BYTE_STRTAG_VAL(obj1); l2 = SCHEME_BYTE_STRTAG_VAL(obj2); return ((l1 == l2) && !memcmp(SCHEME_BYTE_STR_VAL(obj1), SCHEME_BYTE_STR_VAL(obj2), l1)); } else if (t1 == scheme_char_string_type) { intptr_t l1, l2; if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2))) return 0; l1 = SCHEME_CHAR_STRTAG_VAL(obj1); l2 = SCHEME_CHAR_STRTAG_VAL(obj2); return ((l1 == l2) && !memcmp(SCHEME_CHAR_STR_VAL(obj1), SCHEME_CHAR_STR_VAL(obj2), l1 * sizeof(mzchar))); } else if (t1 == scheme_regexp_type) { if (scheme_regexp_is_byte(obj1) != scheme_regexp_is_byte(obj2)) return 0; if (scheme_regexp_is_pregexp(obj1) != scheme_regexp_is_pregexp(obj2)) return 0; obj1 = scheme_regexp_source(obj1); obj2 = scheme_regexp_source(obj2); goto top; } else if ((t1 == scheme_structure_type) || (t1 == scheme_proc_struct_type)) { Scheme_Struct_Type *st1, *st2; Scheme_Object *procs1, *procs2; st1 = SCHEME_STRUCT_TYPE(obj1); st2 = SCHEME_STRUCT_TYPE(obj2); if (eql->for_chaperone == 1) procs1 = NULL; else procs1 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st1); if (procs1) procs1 = apply_impersonator_of(eql->for_chaperone, procs1, obj1); if (eql->for_chaperone) procs2 = NULL; else { procs2 = scheme_struct_type_property_ref(scheme_impersonator_of_property, (Scheme_Object *)st2); if (procs2) procs2 = apply_impersonator_of(eql->for_chaperone, procs2, obj2); } if (procs1 || procs2) { /* impersonator-of property trumps other forms of checking */ if (procs1) obj1 = procs1; if (procs2) obj2 = procs2; goto top; } else { procs1 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st1); if (procs1 && (st1 != st2)) { procs2 = scheme_struct_type_property_ref(scheme_equal_property, (Scheme_Object *)st2); if (!procs2 || !SAME_OBJ(SCHEME_VEC_ELS(procs1)[0], SCHEME_VEC_ELS(procs2)[0])) procs1 = NULL; } if (procs1) { /* Has an equality property: */ Scheme_Object *a[3], *recur; Equal_Info *eql2; # include "mzeqchk.inc" if (union_check(obj1, obj2, eql)) return 1; /* Create/cache closure to use for recursive equality checks: */ if (eql->recur) { recur = eql->recur; eql2 = (Equal_Info *)SCHEME_PRIM_CLOSURE_ELS(recur)[0]; } else { eql2 = (Equal_Info *)scheme_malloc(sizeof(Equal_Info)); a[0] = (Scheme_Object *)eql2; recur = scheme_make_prim_closure_w_arity(equal_recur, 1, a, "equal?/recur", 2, 2); eql->recur = recur; } memcpy(eql2, eql, sizeof(Equal_Info)); a[0] = obj1; a[1] = obj2; a[2] = recur; procs1 = SCHEME_VEC_ELS(procs1)[1]; recur = _scheme_apply(procs1, 3, a); memcpy(eql, eql2, sizeof(Equal_Info)); return SCHEME_TRUEP(recur); } else if (st1 != st2) { return 0; } else if ((eql->for_chaperone == 1) && !(MZ_OPT_HASH_KEY(&st1->iso) & STRUCT_TYPE_ALL_IMMUTABLE)) { return 0; } else { /* Same types, but doesn't have an equality property (or checking for chaperone), so check transparency: */ Scheme_Object *insp; insp = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR); if (scheme_inspector_sees_part(obj1, insp, -2) && scheme_inspector_sees_part(obj2, insp, -2)) { # include "mzeqchk.inc" if (union_check(obj1, obj2, eql)) return 1; return struct_equal(obj1, obj2, eql); } else return 0; } } } else if (t1 == scheme_box_type) { SCHEME_USE_FUEL(1); if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1) || !SCHEME_IMMUTABLEP(obj2))) return 0; if (union_check(obj1, obj2, eql)) return 1; obj1 = SCHEME_BOX_VAL(obj1); obj2 = SCHEME_BOX_VAL(obj2); goto top; } else if (t1 == scheme_hash_table_type) { # include "mzeqchk.inc" if (eql->for_chaperone == 1) return 0; if (union_check(obj1, obj2, eql)) return 1; return scheme_hash_table_equal_rec((Scheme_Hash_Table *)obj1, (Scheme_Hash_Table *)obj2, eql); } else if (t1 == scheme_hash_tree_type) { # include "mzeqchk.inc" if (union_check(obj1, obj2, eql)) return 1; return scheme_hash_tree_equal_rec((Scheme_Hash_Tree *)obj1, (Scheme_Hash_Tree *)obj2, eql); } else if (t1 == scheme_bucket_table_type) { # include "mzeqchk.inc" if (eql->for_chaperone == 1) return 0; if (union_check(obj1, obj2, eql)) return 1; return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql); } else if (t1 == scheme_cpointer_type) { return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1)) == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2))); } else if (t1 == scheme_wrap_chunk_type) { return vector_equal(obj1, obj2, eql); } else if (t1 == scheme_resolved_module_path_type) { obj1 = SCHEME_PTR_VAL(obj1); obj2 = SCHEME_PTR_VAL(obj2); goto top; } else if (t1 == scheme_place_bi_channel_type) { Scheme_Place_Bi_Channel *bc1, *bc2; bc1 = (Scheme_Place_Bi_Channel *)obj1; bc2 = (Scheme_Place_Bi_Channel *)obj2; return (SAME_OBJ(bc1->recvch, bc2->recvch) && SAME_OBJ(bc1->sendch, bc2->sendch)); } else if (!eql->for_chaperone && ((t1 == scheme_chaperone_type) || (t1 == scheme_proc_chaperone_type))) { /* both chaperones */ obj1 = ((Scheme_Chaperone *)obj1)->val; obj2 = ((Scheme_Chaperone *)obj2)->val; goto top; } else { Scheme_Equal_Proc eqlp = scheme_type_equals[t1]; if (eqlp) { if (union_check(obj1, obj2, eql)) return 1; return eqlp(obj1, obj2, eql); } else return 0; } }
static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) { Scheme_Let_One *lo = (Scheme_Let_One *)o; Scheme_Object *body, *rhs, *vec; int pos, save_mnt, ip, et; int unused = 0; scheme_sfs_start_sequence(info, 2, 1); scheme_sfs_push(info, 1, 1); ip = info->ip; 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]); } rhs = scheme_sfs_expr(lo->value, info, -1); body = scheme_sfs_expr(lo->body, info, -1); # 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; if (info->max_used[pos] <= ip) { /* No one is using it, so don't actually push the value at run time (but keep the check that the result is single-valued). The optimizer normally would have converted away the binding, but it might not because (1) it was introduced late by inlining, or (2) the rhs expression doesn't always produce a single value. */ if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) { rhs = scheme_false; } else if ((ip < info->max_calls[pos]) && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { /* Unusual case: we can't just drop the global-variable access, because it might be undefined, but we don't need the value, and we want to avoid an SFS clear in the interpreter loop. So, bind #f and then access in the global in a `begin'. */ Scheme_Sequence *s; s = scheme_malloc_sequence(2); s->so.type = scheme_sequence_type; s->count = 2; s->array[0] = rhs; s->array[1] = body; body = (Scheme_Object *)s; rhs = scheme_false; } unused = 1; } } lo->value = rhs; lo->body = body; et = scheme_get_eval_type(lo->value); SCHEME_LET_EVAL_TYPE(lo) = (et | (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM)) | (unused ? LET_ONE_UNUSED : 0)); return o; }