static Scheme_Object *
list_p_prim (int argc, Scheme_Object *argv[])
{
Scheme_Object *obj1, *obj2;
obj1 = obj2 = argv[0];
do {
if (SCHEME_NULLP(obj1))
return scheme_true;
if (!SCHEME_PAIRP(obj1))
return (scheme_false);
obj1 = SCHEME_CDR (obj1);
if (SCHEME_NULLP(obj1))
return scheme_true;
if (!SCHEME_PAIRP(obj1))
return scheme_false;
obj1 = SCHEME_CDR(obj1);
obj2 = SCHEME_CDR(obj2);
} while (NOT_SAME_OBJ(obj1, obj2));
return scheme_false;
}
static Scheme_Object *
scheme_append_bang (Scheme_Object *lst1, Scheme_Object *lst2)
{
if (SCHEME_NULLP(lst1))
return lst2;
else {
Scheme_Object *prev, *orig;
orig = lst1;
do {
prev = lst1;
if (!SCHEME_PAIRP(lst1))
scheme_wrong_type("append!", "proper list", -1, 0, &lst1);
lst1 = SCHEME_CDR(lst1);
SCHEME_USE_FUEL(1);
} while (!SCHEME_NULLP(lst1));
if (!SCHEME_MUTABLE_PAIRP(prev))
scheme_wrong_type("append!", "mutable proper list", -1, 0, &lst1);
SCHEME_CDR(prev) = lst2;
return orig;
}
}
Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre)
{
int len, i;
Scheme_Object *loc;
Scheme_Sequence *s;
if (SCHEME_NULLP(clears))
return expr;
len = scheme_list_length(clears);
s = scheme_malloc_sequence(len + 1);
s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type);
s->count = len + 1;
s->array[pre ? len : 0] = expr;
for (i = 0; i < len; i++) {
loc = scheme_make_local(scheme_local_type,
SCHEME_INT_VAL(SCHEME_CAR(clears)),
SCHEME_LOCAL_CLEAR_ON_READ);
s->array[i + (pre ? 0 : 1)] = loc;
clears = SCHEME_CDR(clears);
}
return (Scheme_Object *)s;
}
static Scheme_Object *
reverse_bang_prim (int argc, Scheme_Object *argv[])
{
Scheme_Object *lst, *prev, *next;
prev = NULL;
lst = argv[0];
while (!SCHEME_NULLP(lst)) {
if (!SCHEME_MUTABLE_PAIRP(lst))
scheme_wrong_type("reverse!", "mutable proper list", 0, argc, argv);
next = SCHEME_CDR(lst);
if (prev)
SCHEME_CDR(lst) = prev;
else
SCHEME_CDR(lst) = scheme_null;
prev = lst;
lst = next;
SCHEME_USE_FUEL(1);
}
if (prev)
return prev;
else
return scheme_null;
}
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;
}
int
scheme_proper_list_length (Scheme_Object *list)
{
int len;
Scheme_Object *turtle;
len = 0;
turtle = list;
while (SCHEME_PAIRP(list)) {
len++;
list = SCHEME_CDR(list);
if (!SCHEME_PAIRP(list))
break;
len++;
list = SCHEME_CDR(list);
if (SAME_OBJ(turtle, list))
break;
turtle = SCHEME_CDR(turtle);
}
if (SCHEME_NULLP(list))
return len;
return -1;
}
static Scheme_Object *make_immutable_hash_table(int argc, Scheme_Object *argv[])
{
Scheme_Object *l = argv[0], *a;
Scheme_Hash_Table *ht;
if (scheme_proper_list_length(l) >= 0) {
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (!SCHEME_PAIRP(a))
break;
}
}
if (!SCHEME_NULLP(l))
scheme_wrong_type("make-immutable-hash-table", "list of pairs", 0, argc, argv);
if (argc > 1) {
if (!SAME_OBJ(equal_symbol, argv[1]))
scheme_wrong_type("make-immutable-hash-table", "'equal", 1, argc, argv);
ht = scheme_make_hash_table_equal();
} else
ht = scheme_make_hash_table(SCHEME_hash_ptr);
for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
scheme_hash_set(ht, SCHEME_CAR(a), SCHEME_CDR(a));
}
SCHEME_SET_IMMUTABLE((Scheme_Object *)ht);
return (Scheme_Object *)ht;
}
int
scheme_list_length (Scheme_Object *list)
{
int len;
len = 0;
while (!SCHEME_NULLP(list)) {
len++;
if (SCHEME_PAIRP(list))
list = SCHEME_CDR(list);
else
list = scheme_null;
}
return len;
}
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 *begin_for_syntax_sfs(Scheme_Object *data, SFS_Info *info)
{
Scheme_Object *l, *a;
if (!info->pass) {
int depth;
depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]);
for (l = SCHEME_VEC_ELS(data)[0]; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
info = scheme_new_sfs_info(depth);
a = scheme_sfs(a, info, depth);
SCHEME_CAR(l) = a;
}
}
return data;
}
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 *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 *
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;
}
/**
* Convert a Scheme list or vector to a GVariant that represents an array.
*/
static GVariant *
scheme_object_to_array (Scheme_Object *lv, gchar *type)
{
Scheme_Object *sval; // One element of the list/array
GVariant *gval; // The converted element
GVariantBuilder *builder;
// Special case: The empty list gives the empty array.
if (SCHEME_NULLP (lv))
{
// Note: For individual objects, D-Bus type signatures are acceptable
// as GVariant type strings.
builder = g_variant_builder_new ((GVariantType *) type);
if (builder == NULL)
return NULL;
return g_variant_builder_end (builder);
} // if it's null
// A list, or so we think.
if (SCHEME_PAIRP (lv))
{
builder = g_variant_builder_new ((GVariantType *) type);
if (builder == NULL)
return NULL;
// Follow the cons cells through the list
while (SCHEME_PAIRP (lv))
{
sval = SCHEME_CAR (lv);
gval = scheme_object_to_parameter (sval, type+1);
if (gval == NULL)
{
g_variant_builder_unref (builder);
return NULL;
} // if (gval == NULL)
g_variant_builder_add_value (builder, gval);
lv = SCHEME_CDR (lv);
} // while
// We've reached the end. Was it really a list?
if (! SCHEME_NULLP (lv))
{
g_variant_builder_unref (builder);
return NULL;
} // If the list does not end in null, so it's not a list.
// We've hit the null at the end of the list.
return g_variant_builder_end (builder);
} // if it's a list
// A vector
else if (SCHEME_VECTORP (lv))
{
int len = SCHEME_VEC_SIZE (lv);
int i;
LOG ("scheme_object_to_array: Handling a vector of length %d", len);
builder = g_variant_builder_new (G_VARIANT_TYPE_ARRAY);
if (builder == NULL)
return NULL;
for (i = 0; i < len; i++)
{
sval = SCHEME_VEC_ELS(lv)[i];
gval = scheme_object_to_parameter (sval, type + 1);
if (gval == NULL)
{
g_variant_builder_unref (builder);
return NULL;
} // if we could not convert the object
g_variant_builder_add_value (builder, gval);
} // for each index
return g_variant_builder_end (builder);
} // if it's a vector
// Can only convert lists and vectors.
else
return NULL;
} // scheme_object_to_array
static Scheme_Object *
do_list_ref(char *name, int takecar, int argc, Scheme_Object *argv[])
{
long i, k;
Scheme_Object *lst, *index, *bnindex;
if (SCHEME_BIGNUMP(argv[1])) {
bnindex = argv[1];
k = 0;
} else if (!SCHEME_INTP(argv[1])) {
scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
return NULL;
} else {
bnindex = NULL;
k = SCHEME_INT_VAL(argv[1]);
}
lst = argv[0];
index = argv[1];
if ((bnindex && !SCHEME_BIGPOS(bnindex))
|| (!bnindex && (k < 0))) {
scheme_wrong_type(name, "non-negative exact integer", 1, argc, argv);
return NULL;
}
do {
if (bnindex) {
if (SCHEME_INTP(bnindex)) {
k = SCHEME_INT_VAL(bnindex);
bnindex = 0;
} else {
k = LISTREF_BIGNUM_SLICE;
bnindex = scheme_bin_minus(bnindex, scheme_make_integer(LISTREF_BIGNUM_SLICE));
}
}
for (i = 0; i < k; i++) {
if (!SCHEME_PAIRP(lst)) {
char *lstr;
int llen;
lstr = scheme_make_provided_string(argv[0], 2, &llen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s too large for list%s: %t", name,
scheme_make_provided_string(index, 2, NULL),
SCHEME_NULLP(lst) ? "" : " (not a proper list)",
lstr, llen);
return NULL;
}
lst = SCHEME_CDR(lst);
if (!(i & OCCASIONAL_CHECK))
SCHEME_USE_FUEL(OCCASIONAL_CHECK);
}
} while(bnindex);
if (takecar) {
if (!SCHEME_PAIRP(lst)) {
char *lstr;
int llen;
lstr = scheme_make_provided_string(argv[0], 2, &llen);
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"%s: index %s too large for list%s: %t", name,
scheme_make_provided_string(index, 2, NULL),
SCHEME_NULLP(lst) ? "" : " (not a proper list)",
lstr, llen);
return NULL;
}
return SCHEME_CAR(lst);
} else
return lst;
}
static Scheme_Object *
null_p_prim (int argc, Scheme_Object *argv[])
{
return (SCHEME_NULLP(argv[0]) ? scheme_true : scheme_false);
}