static Scheme_Object *write_set_bang(Scheme_Object *obj) { Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj; return scheme_make_pair((sb->set_undef ? scheme_true : scheme_false), scheme_make_pair(sb->var, scheme_protect_quote(sb->val))); }
static void scheme_sfs_save(SFS_Info *info, Scheme_Object *v) { if (info->pass) scheme_signal_error("internal error: wrong pass to save info"); v = scheme_make_pair(v, info->saved); info->saved = v; }
Scheme_Object * scheme_append (Scheme_Object *lst1, Scheme_Object *lst2) { Scheme_Object *first, *last, *orig1, *v; orig1 = lst1; first = last = NULL; while (SCHEME_PAIRP(lst1)) { v = scheme_make_pair(SCHEME_CAR(lst1), scheme_null); if (!first) first = v; else SCHEME_CDR(last) = v; last = v; lst1 = SCHEME_CDR(lst1); SCHEME_USE_FUEL(1); } if (!SCHEME_NULLP(lst1)) scheme_wrong_type("append", "proper list", -1, 0, &orig1); if (!last) return lst2; SCHEME_CDR(last) = lst2; return first; }
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int argc, Scheme_Object **argv) { Scheme_Chaperone *px; Scheme_Object *val = argv[0]; Scheme_Object *redirects; Scheme_Hash_Tree *props; if (SCHEME_CHAPERONEP(val)) val = SCHEME_CHAPERONE_VAL(val); if (!SCHEME_VECTORP(val) || (is_impersonator && !SCHEME_MUTABLEP(val))) scheme_wrong_contract(name, is_impersonator ? "(and/c vector? (not/c immutable?))" : "vector?", 0, argc, argv); scheme_check_proc_arity(name, 3, 1, argc, argv); scheme_check_proc_arity(name, 3, 2, argc, argv); props = scheme_parse_chaperone_props(name, 3, argc, argv); redirects = scheme_make_pair(argv[1], argv[2]); px = MALLOC_ONE_TAGGED(Scheme_Chaperone); px->iso.so.type = scheme_chaperone_type; px->props = props; px->val = val; px->prev = argv[0]; px->redirects = redirects; if (is_impersonator) SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR; return (Scheme_Object *)px; }
static Scheme_Object * cons_prim (int argc, Scheme_Object *argv[]) { Scheme_Object *cons; cons = scheme_make_pair(argv[0], argv[1]); return (cons); }
Scheme_Object *scheme_build_list(int size, Scheme_Object **argv) { Scheme_Object *pair = scheme_null; int i; for (i = size; i--; ) { pair = scheme_make_pair(argv[i], pair); } return pair; }
Scheme_Object *scheme_alloc_list(int size) { Scheme_Object *pair = scheme_null; int i; for (i = size; i--; ) { pair = scheme_make_pair(scheme_false, pair); } return pair; }
Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context) /* If lr is supplied as a letrec binding this closure, it may be used for JIT compilation. */ { #ifdef MZ_USE_JIT Scheme_Lambda *data = (Scheme_Lambda *)code, *data2; /* We need to cache clones to support multiple references to a zero-sized closure in bytecode. We need either a clone or native code, and context determines which field is relevant, so we put the two possibilities in a union `u'. */ if (!context) data2 = data->u.jit_clone; else data2 = NULL; if (!data2) { Scheme_Native_Lambda *ndata; data2 = MALLOC_ONE_TAGGED(Scheme_Lambda); memcpy(data2, code, sizeof(Scheme_Lambda)); data2->context = context; ndata = scheme_generate_lambda(data2, 1, NULL); data2->u.native_code = ndata; if (current_linklet_native_lambdas) current_linklet_native_lambdas = scheme_make_pair((Scheme_Object *)ndata, current_linklet_native_lambdas); if (!context) data->u.jit_clone = data2; if (current_linklet_native_lambdas) { /* Force jitprep on body, too, to discover all lambdas */ Scheme_Object *body; body = jit_expr(data2->body); data2->body = body; } } /* If it's zero-sized, then create closure now */ if (!data2->closure_size) return scheme_make_native_closure(data2->u.native_code); return (Scheme_Object *)data2; #endif return code; }
Scheme_Object * scheme_vector_to_list (Scheme_Object *vec) { int i; Scheme_Object *pair = scheme_null; i = SCHEME_VEC_SIZE(vec); if (i < 0xFFF) { for (; i--; ) { pair = scheme_make_pair(SCHEME_VEC_ELS(vec)[i], pair); } } else { for (; i--; ) { if (!(i & 0xFFF)) SCHEME_USE_FUEL(0xFFF); pair = scheme_make_pair(SCHEME_VEC_ELS(vec)[i], pair); } } return pair; }
/** * Convert an array of Scheme objects into a list of the same objects. */ Scheme_Object * make_object_list (int n, Scheme_Object *values[]) { Scheme_Object *result; // The result we're building int i; // Everyone's favorite counter variable result = scheme_null; // Step through the objects from right to left, adding each to the front // of the list. for (i = n-1; i >= 0; i--) { result = scheme_make_pair (values[i], result); } // for // And we're done. return result; } // make_object_list
/** *For Server : Convert an array of Scheme objects into a list of the same objects for SchemeObject to Gvariant <<<<<<< HEAD * ======= *We have not used this recursive helper function. We did it iteratively below. >>>>>>> 3cb492700f6fe2265add3da53ebfb79622e240de */ Scheme_Object * g_variant_tuple_to_scheme_list (GVariant *tuple, int index, int size) { // Base case: We reached the end of the tuple if (index == size) return scheme_null; // Or whatever the empty list value is else { Scheme_Object *car; Scheme_Object *cdr; car = gvariant_to_schemeobj (g_variant_get_child_value (tuple, index)); cdr = g_variant_tuple_to_scheme_list (tuple, index+1, size); return scheme_make_pair (car, cdr); } // if we're still in the tuple } // g_variant_tuple_to_scheme_list
Scheme_Object * scheme_named_map_1(char *name, Scheme_Object *(*fun)(Scheme_Object*, Scheme_Object*), Scheme_Object *lst, Scheme_Object *form) { if (SCHEME_STX_NULLP(lst)) return (scheme_null); else if (SCHEME_STX_PAIRP(lst)) { Scheme_Object *v; v = SCHEME_STX_CAR(lst); v = fun(v, form); lst = SCHEME_STX_CDR(lst); return scheme_make_pair(v, scheme_named_map_1(name, fun, lst, form)); } else { scheme_wrong_syntax(name, lst, form, "bad syntax (" IMPROPER_LIST_FORM ")"); return scheme_void; } }
static Scheme_Object * reverse_prim (int argc, Scheme_Object *argv[]) { Scheme_Object *lst, *last; last = scheme_null; lst = argv[0]; while (!SCHEME_NULLP (lst)) { if (!SCHEME_PAIRP(lst)) scheme_wrong_type("reverse", "proper list", 0, argc, argv); last = scheme_make_pair (SCHEME_CAR (lst), last); lst = SCHEME_CDR (lst); SCHEME_USE_FUEL(1); } return (last); }
static Scheme_Object * list_exec (int argc, Scheme_Object *argv[], int star) { int i; Scheme_Object *l; if (star) { --argc; l = argv[argc]; } else l = scheme_null; for (i = argc ; i--; ) { l = scheme_make_pair(argv[i], l); } return l; }
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 *sfs_let_value(Scheme_Object *o, SFS_Info *info) { Scheme_Let_Value *lv = (Scheme_Let_Value *)o; Scheme_Object *body, *rhs, *clears = scheme_null; int i, pos; scheme_sfs_start_sequence(info, 2, 1); rhs = scheme_sfs_expr(lv->value, info, -1); if (!info->pass || (info->ip < info->max_nontail)) { for (i = 0; i < lv->count; i++) { pos = lv->position + i; if (!info->pass) scheme_sfs_used(info, pos); else { int spos; spos = pos + info->stackpos; if ((info->max_used[spos] == info->ip) && (info->max_calls[spos] > info->ip)) { /* No one is using the id after we set it. We still need to set it, in case it's boxed and shared, but then remove the binding or box. */ clears = scheme_make_pair(scheme_make_integer(pos), clears); } } } } body = scheme_sfs_expr(lv->body, info, -1); body = scheme_sfs_add_clears(body, clears, 1); lv->value = rhs; lv->body = body; return o; }
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 *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; }
/** * Get all of the methods from a louDBus Proxy. */ Scheme_Object * loudbus_methods (int argc, Scheme_Object **argv) { Scheme_Object *result = NULL; // The result we're building Scheme_Object *val = NULL; // One method in the result GDBusMethodInfo *method; // Information on one method LouDBusProxy *proxy; // The proxy int m; // Counter variable for methods MZ_GC_DECL_REG (2); MZ_GC_VAR_IN_REG (0, result); MZ_GC_VAR_IN_REG (1, val); // Get the proxy proxy = scheme_object_to_proxy (argv[0]); if (proxy == NULL) { scheme_wrong_type ("loudbus-methods", "LouDBusProxy *", 0, argc, argv); } // if proxy == NULL MZ_GC_REG (); // Build the list. result = scheme_null; for (m = g_dbus_interface_info_num_methods (proxy->iinfo) - 1; m >= 0; m--) { method = proxy->iinfo->methods[m]; val = scheme_make_locale_string (method->name); result = scheme_make_pair (val, result); } // for each method MZ_GC_UNREG (); // And we're done. return result; } // loudbus_methods
/** * Convert a GVariant to a Scheme object. Returns NULL if there's a * problem. */ static Scheme_Object * g_variant_to_scheme_object (GVariant *gv) { const GVariantType *type; // The type of the GVariant const gchar *typestring; // A string that describes the type int i; // A counter variable int len; // Length of arrays and tuples Scheme_Object *lst = NULL; // A list that we build as a result Scheme_Object *sval = NULL; // One value Scheme_Object *result = NULL; // One result to return. // Special case: We'll treat NULL as void. if (gv == NULL) { return scheme_void; } // if (gv == NULL) // Get the type type = g_variant_get_type (gv); typestring = g_variant_get_type_string (gv); // ** Handle most of the basic types ** // Integer if (g_variant_type_equal (type, G_VARIANT_TYPE_INT32)) { // We don't refer to any Scheme objects across allocating calls, // so no need for GC code. int i; i = g_variant_get_int32 (gv); result = scheme_make_integer (i); return result; } // if it's an integer // Double if (g_variant_type_equal (type, G_VARIANT_TYPE_DOUBLE)) { double d; d = g_variant_get_double (gv); result = scheme_make_double (d); return result; } // if it's a double // String if (g_variant_type_equal (type, G_VARIANT_TYPE_STRING)) { // We don't refer to any Scheme objects across allocating calls, // so no need for GC code. const gchar *str; str = g_variant_get_string (gv, NULL); result = scheme_make_locale_string (str); return result; } // if it's a string // ** Handle some special cases ** // We treat arrays of bytes as bytestrings if (g_strcmp0 (typestring, "ay") == 0) { gsize size; guchar *data; data = (guchar *) g_variant_get_fixed_array (gv, &size, sizeof (guchar)); return scheme_make_sized_byte_string ((char *) data, size, 1); } // if it's an array of bytes // ** Handle the compound types ** // Tuple or Array if ( (g_variant_type_is_tuple (type)) || (g_variant_type_is_array (type)) ) { // Find out how many values to put into the list. len = g_variant_n_children (gv); // Here, we are referring to stuff across allocating calls, so we // need to be careful. MZ_GC_DECL_REG (2); MZ_GC_VAR_IN_REG (0, lst); MZ_GC_VAR_IN_REG (1, sval); MZ_GC_REG (); // Start with the empty list. lst = scheme_null; // Step through the items, right to left, adding them to the list. for (i = len-1; i >= 0; i--) { sval = g_variant_to_scheme_object (g_variant_get_child_value (gv, i)); lst = scheme_make_pair (sval, lst); } // for // Okay, we've made it through the list, now we can clean up. MZ_GC_UNREG (); if ((g_variant_type_is_array (type))) { //If type is array, convert to vector scheme_list_to_vector ((char*)lst); }//If array // And we're done. return lst; } // if it's a tuple or an array // Unknown. Give up. scheme_signal_error ("Unknown type %s", typestring); return scheme_void; } // g_variant_to_scheme_object
/** * Get information on one method (annotations, parameters, return * values, etc). * * TODO: * 1. Add missing documentation (see ????) * 2. Check to make sure that the second parameter is a string. (Also * do other error checking. See below.) * 3. Make sure that you get annotations for parameters and return * values (if they exist). * 4. Add tags for the other parts of the record (if they aren't * there already). For example, something like * '((name gimp_image_new) * (annotations "...") * (inputs (width integer "width of image")) * (outputs (image integer "id of created image"))) * If you'd prefer, input and output could also have their own * tags. * (inputs ((name width) (type integer) (annotations "width of image"))) * 5. Add a function to louDBus/unsafe that pretty prints this. * (If you'd prefer, you can add it to this file. But you can't * use printf to pretty print.) * 6. Add information for the garbage collector. (Yup, you'll need to * read really bad documentation on this. But try.) */ static Scheme_Object * loudbus_method_info (int argc, Scheme_Object **argv) { Scheme_Object *val, *val2; // ???? Scheme_Object *result = NULL; // The result we're building Scheme_Object *arglist = NULL; // The list of arguments Scheme_Object *outarglist = NULL; // The list of return values Scheme_Object *annolist = NULL; // The list of annotations Scheme_Object *name = NULL; // The method's name Scheme_Object *parampair = NULL; // ???? Scheme_Object *outparampair = NULL; // ???? GDBusMethodInfo *method; // Information on one method GDBusAnnotationInfo *anno; // Information on the annotations GDBusArgInfo *args, *outargs; // Information on the arguments LouDBusProxy *proxy; // The proxy gchar *methodName; // The method name int m; // Counter variable for methods // Get the proxy proxy = scheme_object_to_proxy (argv[0]); if (proxy == NULL) { scheme_wrong_type ("loudbus-methods", "LouDBusProxy *", 0, argc, argv); } // if proxy == NULL //Get the method name. WHAT IF WE CAN'T CONVERT TO A STRING???? methodName = scheme_object_to_string (argv[1]); // Permit the use of dashes in method names by converting them back // to underscores (which is what we use over DBus). score_it_all (methodName); //Get the method struct. WHAT IF THE METHOD DOESN'T EXIST???? method = g_dbus_interface_info_lookup_method (proxy->iinfo, methodName); // Build the list for arguments. arglist = scheme_null; for (m = parray_len ((gpointer *) method->in_args) - 1; m >= 0; m--) { args = method->in_args[m]; //Go through the arguments. val = scheme_make_symbol (args->name); val2 = scheme_make_symbol (args->signature); parampair = scheme_make_pair (val, val2); arglist = scheme_make_pair (parampair, arglist); } // for each argument //Build list for output. outarglist = scheme_null; for (m = parray_len ((gpointer *) method->out_args) - 1; m >= 0; m--) { outargs = method->out_args[m]; val = scheme_make_symbol (outargs->name); val2 = scheme_make_symbol (outargs->signature); outparampair = scheme_make_pair (val, val2); outarglist = scheme_make_pair (outparampair, outarglist); } // for each output formals // Build list of annotations annolist = scheme_null; for (m = parray_len ((gpointer *) method->annotations) - 1; m >= 0; m--) { anno = method->annotations[m]; //Go through the annotations. val = scheme_make_locale_string (anno->value); annolist = scheme_make_pair (val, annolist); } // for each annotation // Create the name entry name = scheme_null; name = scheme_make_pair (scheme_make_symbol(methodName), name); name = scheme_make_pair (scheme_make_symbol("name"), name); result = scheme_null; result = scheme_make_pair (annolist, result); result = scheme_make_pair (outarglist, result); result = scheme_make_pair (arglist, result); result = scheme_make_pair (name, result); // And we're done. return result; } // loudbus_method_info
Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Table *ht) { Scheme_Object *new_so = so; if (SCHEME_INTP(so)) { return so; } if (ht) { Scheme_Object *r; if ((r = scheme_hash_get(ht, so))) { return r; } } switch (so->type) { case scheme_true_type: case scheme_false_type: case scheme_null_type: case scheme_void_type: /* place_bi_channels are allocated in the master and can be passed along as is */ case scheme_place_bi_channel_type: new_so = so; break; case scheme_place_type: new_so = ((Scheme_Place *) so)->channel; break; case scheme_char_type: new_so = scheme_make_char(SCHEME_CHAR_VAL(so)); break; case scheme_rational_type: { Scheme_Object *n; Scheme_Object *d; n = scheme_rational_numerator(so); d = scheme_rational_denominator(so); n = scheme_places_deep_copy_worker(n, ht); d = scheme_places_deep_copy_worker(d, ht); new_so = scheme_make_rational(n, d); } break; case scheme_float_type: new_so = scheme_make_float(SCHEME_FLT_VAL(so)); break; case scheme_double_type: new_so = scheme_make_double(SCHEME_DBL_VAL(so)); break; case scheme_complex_type: { Scheme_Object *r; Scheme_Object *i; r = scheme_complex_real_part(so); i = scheme_complex_imaginary_part(so); r = scheme_places_deep_copy_worker(r, ht); i = scheme_places_deep_copy_worker(i, ht); new_so = scheme_make_complex(r, i); } break; case scheme_char_string_type: new_so = scheme_make_sized_offset_char_string(SCHEME_CHAR_STR_VAL(so), 0, SCHEME_CHAR_STRLEN_VAL(so), 1); break; case scheme_byte_string_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); } break; case scheme_unix_path_type: new_so = scheme_make_sized_offset_path(SCHEME_BYTE_STR_VAL(so), 0, SCHEME_BYTE_STRLEN_VAL(so), 1); break; case scheme_symbol_type: if (SCHEME_SYM_UNINTERNEDP(so)) { scheme_log_abort("cannot copy uninterned symbol"); abort(); } else { new_so = scheme_make_sized_offset_byte_string(SCHEME_SYM_VAL(so), 0, SCHEME_SYM_LEN(so), 1); new_so->type = scheme_serialized_symbol_type; } break; case scheme_serialized_symbol_type: new_so = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(so), SCHEME_BYTE_STRLEN_VAL(so)); break; case scheme_pair_type: { Scheme_Object *car; Scheme_Object *cdr; Scheme_Object *pair; car = scheme_places_deep_copy_worker(SCHEME_CAR(so), ht); cdr = scheme_places_deep_copy_worker(SCHEME_CDR(so), ht); pair = scheme_make_pair(car, cdr); new_so = pair; } break; case scheme_vector_type: { Scheme_Object *vec; intptr_t i; intptr_t size = SCHEME_VEC_SIZE(so); vec = scheme_make_vector(size, 0); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker(SCHEME_VEC_ELS(so)[i], ht); SCHEME_VEC_ELS(vec)[i] = tmp; } SCHEME_SET_IMMUTABLE(vec); new_so = vec; } break; case scheme_fxvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Vector *vec; intptr_t i; intptr_t size = SCHEME_FXVEC_SIZE(so); vec = scheme_alloc_fxvector(size); for (i = 0; i < size; i++) { SCHEME_FXVEC_ELS(vec)[i] = SCHEME_FXVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_flvector_type: if (SHARED_ALLOCATEDP(so)) { new_so = so; } else { Scheme_Double_Vector *vec; intptr_t i; intptr_t size = SCHEME_FLVEC_SIZE(so); vec = scheme_alloc_flvector(size); for (i = 0; i < size; i++) { SCHEME_FLVEC_ELS(vec)[i] = SCHEME_FLVEC_ELS(so)[i]; } new_so = (Scheme_Object *) vec; } break; case scheme_structure_type: { Scheme_Structure *st = (Scheme_Structure*)so; Scheme_Serialized_Structure *nst; Scheme_Struct_Type *stype = st->stype; Scheme_Struct_Type *ptype = stype->parent_types[stype->name_pos - 1]; Scheme_Object *nprefab_key; intptr_t size = stype->num_slots; int local_slots = stype->num_slots - (ptype ? ptype->num_slots : 0); int i = 0; if (!stype->prefab_key) { scheme_log_abort("cannot copy non prefab structure"); abort(); } { for (i = 0; i < local_slots; i++) { if (!stype->immutables || stype->immutables[i] != 1) { scheme_log_abort("cannot copy mutable prefab structure"); abort(); } } } nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht); nst = (Scheme_Serialized_Structure*) scheme_make_serialized_struct_instance(nprefab_key, size); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*) nst; } break; case scheme_serialized_structure_type: { Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so; Scheme_Struct_Type *stype; Scheme_Structure *nst; intptr_t size; int i = 0; size = st->num_slots; stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size); nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype); for (i = 0; i <size ; i++) { Scheme_Object *tmp; tmp = scheme_places_deep_copy_worker((Scheme_Object*) st->slots[i], ht); nst->slots[i] = tmp; } new_so = (Scheme_Object*)nst; } break; case scheme_resolved_module_path_type: default: printf("places deep copy cannot copy object of type %hi at %p\n", so->type, so); scheme_log_abort("places deep copy cannot copy object"); abort(); break; } if (ht) { scheme_hash_set(ht, so, new_so); } return new_so; }
/** * Convert a GVariant to a Scheme object. Returns NULL if there's a * problem. */ static Scheme_Object * g_variant_to_scheme_object (GVariant *gv) { const GVariantType *type; // The type of the GVariant int i; // A counter variable int len; // Length of arrays and tuples Scheme_Object *lst = NULL; // A list that we build as a result Scheme_Object *sval = NULL; // One value Scheme_Object *result = NULL; // One result to return. // Special case: We'll treat NULL as void. if (gv == NULL) { return scheme_void; } // if (gv == NULL) // Get the type type = g_variant_get_type (gv); // ** Handle most of the basic types ** // Integer if (g_variant_type_equal (type, G_VARIANT_TYPE_INT32)) { // We don't refer to any Scheme objects across allocating calls, // so no need for GC code. int i; i = g_variant_get_int32 (gv); result = scheme_make_integer (i); return result; } // if it's an integer // String if (g_variant_type_equal (type, G_VARIANT_TYPE_STRING)) { // We don't refer to any Scheme objects across allocating calls, // so no need for GC code. const gchar *str; str = g_variant_get_string (gv, NULL); result = scheme_make_locale_string (str); return result; } // if it's a string // ** Handle the compound types ** // Tuple or Array if ( (g_variant_type_is_tuple (type)) || (g_variant_type_is_array (type)) ) { // Find out how many values to put into the list. len = g_variant_n_children (gv); // Here, we are referring to stuff across allocating calls, so we // need to be careful. MZ_GC_DECL_REG (2); MZ_GC_VAR_IN_REG (0, lst); MZ_GC_VAR_IN_REG (1, sval); MZ_GC_REG (); // Start with the empty list. lst = scheme_null; // Step through the items, right to left, adding them to the list. for (i = len-1; i >= 0; i--) { sval = g_variant_to_scheme_object (g_variant_get_child_value (gv, i)); lst = scheme_make_pair (sval, lst); } // for // Okay, we've made it through the list, now we can clean up. MZ_GC_UNREG (); // And we're done. return lst; } // if it's a tuple or an array // Unknown. Give up. return NULL; } // g_variant_to_scheme_object
Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr) { #ifdef MZ_USE_JIT Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr; if (!seqin->native_code) { Scheme_Case_Lambda *seqout; Scheme_Native_Lambda *ndata; Scheme_Object *val, *name; int i, cnt, size, all_closed = 1; cnt = seqin->count; size = sizeof(Scheme_Case_Lambda) + ((cnt - mzFLEX_DELTA) * sizeof(Scheme_Object *)); seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size); memcpy(seqout, seqin, size); name = seqin->name; if (name && SCHEME_BOXP(name)) name = SCHEME_BOX_VAL(name); for (i = 0; i < cnt; i++) { val = seqout->array[i]; if (SCHEME_PROCP(val)) { /* Undo creation of empty closure */ val = (Scheme_Object *)((Scheme_Closure *)val)->code; seqout->array[i] = val; } ((Scheme_Lambda *)val)->name = name; if (((Scheme_Lambda *)val)->closure_size) all_closed = 0; } /* Generating the code may cause empty closures to be formed: */ ndata = scheme_generate_case_lambda(seqout); seqout->native_code = ndata; if (current_linklet_native_lambdas) { for (i = 0; i < cnt; i++) { val = seqout->array[i]; { /* Force jitprep on body, too, to discover all lambdas */ Scheme_Object *body; body = jit_expr(((Scheme_Lambda *)val)->body); ((Scheme_Lambda *)val)->body = body; } val = (Scheme_Object *)((Scheme_Lambda *)val)->u.native_code; current_linklet_native_lambdas = scheme_make_pair(val, current_linklet_native_lambdas); } } if (all_closed) { /* Native closures do not refer back to the original bytecode, so no need to worry about clearing the reference. */ Scheme_Native_Closure *nc; nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata); for (i = 0; i < cnt; i++) { val = seqout->array[i]; if (!SCHEME_PROCP(val)) { val = scheme_make_native_closure(((Scheme_Lambda *)val)->u.native_code); } nc->vals[i] = val; } return (Scheme_Object *)nc; } else { /* The case-lambda data must point to the original closure-data record, because that's where the closure maps are kept. But we don't need the bytecode, anymore. So clone the closure-data record and drop the bytecode in thte clone. */ for (i = 0; i < cnt; i++) { val = seqout->array[i]; if (!SCHEME_PROCP(val)) { Scheme_Lambda *data; data = MALLOC_ONE_TAGGED(Scheme_Lambda); memcpy(data, val, sizeof(Scheme_Lambda)); data->body = NULL; seqout->array[i] = (Scheme_Object *)data; } } } return (Scheme_Object *)seqout; } #endif return expr; }
/** *Translating the gvariant to Scheme Object */ Scheme_Object * gvariant_to_schemeobj (GVariant *ivalue) { gint32 i; GVariant *temp; const gchar *fstring; gsize length = 0; gsize size = 0; gint32 r1 = 0; gdouble r2 = 0; Scheme_Object *fint; Scheme_Object *fstringss; Scheme_Object *fdouble; Scheme_Object *sflist = NULL; gchar *tmp; //scheme_signal_error ("Not tuple yet"); tmp = g_variant_print (ivalue, FALSE); fprintf (stderr, "gvariant_to_schemobj(%s)\n", tmp); g_free (tmp); size = g_variant_get_size (ivalue); // fprintf (stderr, "Exploring the return value.\n"); /* if (ivalue == NULL) { fprintf (stderr, "Return value is <NULL>\n"); } // if (ivalue == NULL) else // if (ivalue != NULL) { type = g_variant_get_type (ivalue); typestring = g_variant_type_dup_string (type); fprintf (stderr, "Got type %s\n", typestring); g_free (typestring); description = g_variant_print (ivalue, TRUE); fprintf (stderr, "Got value %s\n", description); g_free (description); } // if (ivalue != NULL)*/ if (ivalue == NULL) { return scheme_void; } if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_INT32)) { r1 = g_variant_get_int32 (ivalue); fint = scheme_make_integer_value(r1); return fint; }// else if else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_STRING)) { fprintf ( stderr, "Type_string\n"); // scheme_signal_error ("%d", size); fstring = g_variant_get_string(ivalue, &size); fstringss = scheme_make_locale_string(fstring); return fstringss; }// else if else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_BYTESTRING)) { fprintf (stderr, "Bytestring\n"); scheme_signal_error("stringbyeerror"); fstring = g_variant_get_bytestring (ivalue); fstringss = scheme_make_locale_string(fstring); return fstringss; }// else if else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_DOUBLE)) { r2 = g_variant_get_double (ivalue); fdouble = scheme_make_double (r2); return fdouble; }// else if else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_TUPLE)) { int i; Scheme_Object *result; // The list we're building Scheme_Object *element; // One element of that list fprintf (stderr, "Handling a tuple.\n"); result = scheme_null; for (i = g_variant_n_children (ivalue) - 1; i >= 0; i--) { fprintf (stderr, "Handling child %d\n", i); element = gvariant_to_schemeobj (g_variant_get_child_value (ivalue, i)); result = scheme_make_pair (element, result); } // for return result; } // if it's a tuple // Default. Give up else { scheme_signal_error ("could not convert type"); } // default } //gvariant_to_schemeobj
static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, Scheme_Object *vec, int delta, Scheme_Object *tbranch) { int t_min_t, t_max_t, t_cnt, n, stackpos, i, save_nt, b_end, nt; Scheme_Object *t_vec, *o; Scheme_Object *clears = scheme_null; info->min_touch = -1; info->max_touch = -1; save_nt = info->max_nontail; SFS_LOG(printf("%d %d %s %d\n", info->pass, ip, (delta ? "else" : "then"), ip)); if (info->pass) { /* Re-install max_used entries that refer to the branch */ o = SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W]; t_min_t = SCHEME_INT_VAL(o); o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2]; nt = SCHEME_INT_VAL(o); if (nt > info->max_nontail) info->max_nontail = nt; if (t_min_t > -1) { t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1]; t_cnt = SCHEME_VEC_SIZE(t_vec); for (i = 0; i < t_cnt; i++) { o = SCHEME_VEC_ELS(t_vec)[i]; if (SCHEME_INTP(o)) { n = SCHEME_INT_VAL(o); SFS_LOG(printf(" @%d %d\n", i + t_min_t, n)); if (info->max_used[i + t_min_t] < n) { SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail)); info->max_used[i + t_min_t] = n; info->max_calls[i + t_min_t] = info->max_nontail; } } } } /* If the other branch has last use for something not used in this branch, and if there's a non-tail call in this branch of later, then we'll have to start with explicit clears. Note that it doesn't matter whether the other branch actually clears them (i.e., the relevant non-tail call might be only in this branch). */ o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3]; b_end = SCHEME_INT_VAL(o); SFS_LOG(printf(" %d %d %d %d\n", nt, ip, b_end, save_nt)); if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */ || ((ip + 1) < save_nt)) { /* => non-tail call after branches */ SFS_LOG(printf(" other\n")); o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W]; t_min_t = SCHEME_INT_VAL(o); if (t_min_t > -1) { int at_ip, pos; t_vec = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 1]; t_cnt = SCHEME_VEC_SIZE(t_vec); o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 2]; nt = SCHEME_INT_VAL(o); o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 3]; b_end = SCHEME_INT_VAL(o); for (i = 0; i < t_cnt; i++) { o = SCHEME_VEC_ELS(t_vec)[i]; if (SCHEME_INTP(o)) { n = SCHEME_INT_VAL(o); pos = i + t_min_t; at_ip = info->max_used[pos]; SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip)); /* is last use in other branch? */ if (((!delta && (at_ip == ip)) || (delta && (at_ip == n)))) { /* Yes, so add clear */ SFS_LOG(printf(" !%d %d %d\n", pos, n, at_ip)); pos -= info->stackpos; clears = scheme_make_pair(scheme_make_integer(pos), clears); } } } } } } stackpos = info->stackpos; tbranch = scheme_sfs_expr(tbranch, info, -1); if (info->pass) info->max_nontail = save_nt; # if MAX_SFS_CLEARING else info->max_nontail = info->ip; # endif tbranch = scheme_sfs_add_clears(tbranch, clears, 1); if (!info->pass) { t_min_t = info->min_touch; t_max_t = info->max_touch; if (t_min_t < stackpos) t_min_t = stackpos; if (t_max_t < stackpos) t_max_t = -1; SFS_LOG(printf("%d %s %d [%d,%d] /%d\n", info->pass, (delta ? "else" : "then"), ip, t_min_t, t_max_t, stackpos)); if (t_max_t < 0) { t_min_t = -1; t_vec = scheme_false; } else { t_cnt = t_max_t - t_min_t + 1; t_vec = scheme_make_vector(t_cnt, NULL); for (i = 0; i < t_cnt; i++) { n = info->max_used[i + t_min_t]; SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip, i + t_min_t, n, info->max_calls[i+ t_min_t])); if (n > ip) { SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n); info->max_used[i + t_min_t] = ip; } else { SCHEME_VEC_ELS(t_vec)[i] = scheme_false; } } } SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W] = scheme_make_integer(t_min_t); SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1] = t_vec; SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2] = scheme_make_integer(info->max_nontail); SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3] = scheme_make_integer(info->ip); } memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); info->stackpos = stackpos; return tbranch; }
Scheme_Object *write_apply_values(Scheme_Object *o) { return scheme_make_pair(scheme_protect_quote(SCHEME_PTR1_VAL(o)), scheme_protect_quote(SCHEME_PTR2_VAL(o))); }
static Scheme_Object *sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_pos) { Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; Scheme_Object *code; int i, size, has_tl = 0; size = data->closure_size; if (size) { if (info->stackpos + data->closure_map[size - 1] == info->tlpos) { has_tl = 1; --size; } } if (!info->pass) { for (i = size; i--; ) { scheme_sfs_used(info, data->closure_map[i]); } } else { /* Check whether we need to zero out any stack positions after capturing them in a closure: */ Scheme_Object *clears = scheme_null; if (info->ip < info->max_nontail) { int pos, ip; for (i = size; i--; ) { pos = data->closure_map[i] + info->stackpos; if (pos < info->depth) { ip = info->max_used[pos]; if ((ip == info->ip) && (ip < info->max_calls[pos])) { pos -= info->stackpos; clears = scheme_make_pair(scheme_make_integer(pos), clears); } } } } return scheme_sfs_add_clears(expr, clears, 0); } if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SFS)) { SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SFS; info = scheme_new_sfs_info(data->max_let_depth); scheme_sfs_push(info, data->closure_size + data->num_params, 1); if (has_tl) info->tlpos = info->stackpos + data->closure_size - 1; if (self_pos >= 0) { for (i = size; i--; ) { if (data->closure_map[i] == self_pos) { info->selfpos = info->stackpos + i; info->selfstart = info->stackpos; info->selflen = data->closure_size; break; } } } code = scheme_sfs(data->code, info, data->max_let_depth); /* If any arguments go unused, and if there's a non-tail, non-immediate call in the body, then we flush the unused arguments at the start of the body. We assume that the closure values are used (otherwise they wouldn't be in the closure). */ if (info->max_nontail) { int i, pos, cnt; Scheme_Object *clears = scheme_null; cnt = data->num_params; for (i = 0; i < cnt; i++) { pos = data->max_let_depth - (cnt - i); if (!info->max_used[pos]) { pos = i + data->closure_size; clears = scheme_make_pair(scheme_make_integer(pos), clears); } } if (SCHEME_PAIRP(clears)) code = scheme_sfs_add_clears(code, clears, 1); if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR; } data->code = code; } return expr; }
static Scheme_Object *sfs_lambda(Scheme_Object *expr, SFS_Info *info, int self_pos) { Scheme_Lambda *data = (Scheme_Lambda *)expr; Scheme_Object *code; int i, size, has_tl = 0; size = data->closure_size; if (size) { if (info->stackpos + data->closure_map[size - 1] == info->tlpos) { has_tl = 1; --size; } } if (!info->pass) { for (i = size; i--; ) { scheme_sfs_used(info, data->closure_map[i]); } } else { /* Check whether we need to zero out any stack positions after capturing them in a closure: */ Scheme_Object *clears = scheme_null; if (info->ip < info->max_nontail) { int pos, ip; for (i = size; i--; ) { pos = data->closure_map[i] + info->stackpos; if (pos < info->depth) { ip = info->max_used[pos]; if ((ip == info->ip) && (ip < info->max_calls[pos])) { pos -= info->stackpos; clears = scheme_make_pair(scheme_make_integer(pos), clears); } } } } return scheme_sfs_add_clears(expr, clears, 0); } if (!(SCHEME_LAMBDA_FLAGS(data) & LAMBDA_SFS)) { SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_SFS; info = scheme_new_sfs_info(data->max_let_depth); scheme_sfs_push(info, data->closure_size + data->num_params, 1); if (has_tl) info->tlpos = info->stackpos + data->closure_size - 1; if (self_pos >= 0) { for (i = size; i--; ) { if (data->closure_map[i] == self_pos) { info->selfpos = info->stackpos + i; info->selfstart = info->stackpos; info->selflen = data->closure_size; break; } } } /* Never clear typed arguments or typed closure elements: */ if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_TYPED_ARGS) { int delta, size, ct, j, pos; mzshort *map; delta = data->closure_size; size = data->closure_size + data->num_params; map = data->closure_map; for (j = 0; j < size; j++) { ct = scheme_boxmap_get(map, j, delta); if (ct > LAMBDA_TYPE_TYPE_OFFSET) { if (j < data->num_params) pos = info->stackpos + delta + j; else pos = info->stackpos + (j - data->num_params); info->max_used[pos] = FAR_VALUE_FOR_MAX_USED; } } } code = scheme_sfs(data->body, info, data->max_let_depth); /* If any arguments go unused, and if there's a non-tail, non-immediate call in the body, then we flush the unused arguments at the start of the body. We assume that the closure values are used (otherwise they wouldn't be in the closure). */ if (info->max_nontail) { int i, pos, cnt; Scheme_Object *clears = scheme_null; cnt = data->num_params; for (i = 0; i < cnt; i++) { pos = data->max_let_depth - (cnt - i); if (!info->max_used[pos]) { pos = i + data->closure_size; clears = scheme_make_pair(scheme_make_integer(pos), clears); } } if (SCHEME_PAIRP(clears)) code = scheme_sfs_add_clears(code, clears, 1); if (SCHEME_LAMBDA_FLAGS(data) & LAMBDA_HAS_REST) SCHEME_LAMBDA_FLAGS(data) |= LAMBDA_NEED_REST_CLEAR; } data->body = code; } return expr; }
Scheme_Object *write_boxenv(Scheme_Object *o) { return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); }