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));
}
