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 *
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;
}
}
static Scheme_Object *read_letrec(Scheme_Object *obj)
{
Scheme_Letrec *lr;
int i, c;
Scheme_Object **sa;
lr = MALLOC_ONE_TAGGED(Scheme_Letrec);
lr->so.type = scheme_letrec_type;
if (!SCHEME_PAIRP(obj)) return NULL;
c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
lr->body = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
sa = MALLOC_N(Scheme_Object*, c);
lr->procs = sa;
for (i = 0; i < c; i++) {
if (!SCHEME_PAIRP(obj)) return NULL;
lr->procs[i] = SCHEME_CAR(obj);
obj = SCHEME_CDR(obj);
}
return (Scheme_Object *)lr;
}
static Scheme_Object *
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;
}
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 *read_quote_syntax(Scheme_Object *obj)
{
Scheme_Quote_Syntax *qs;
Scheme_Object *a;
int c, i, p;
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
c = SCHEME_INT_VAL(a);
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
a = SCHEME_CAR(obj);
i = SCHEME_INT_VAL(a);
a = SCHEME_CDR(obj);
p = SCHEME_INT_VAL(a);
qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax);
qs->so.type = scheme_quote_syntax_type;
qs->depth = c;
qs->position = i;
qs->midpoint = p;
return (Scheme_Object *)qs;
}
inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
{
Scheme_Object *pr, *prev = NULL, *next;
GC_Weak_Box *wb;
Mark2_Proc cust_box_mark = gc->mark_table[btc_redirect_cust_box];
/* cust boxes is a list of weak boxes to cust boxes */
pr = cur->cust_boxes;
while (pr) {
wb = (GC_Weak_Box *)SCHEME_CAR(pr);
next = SCHEME_CDR(pr);
if (wb->val) {
cust_box_mark(wb->val, gc);
prev = pr;
} else {
if (prev)
SCHEME_CDR(prev) = next;
else
cur->cust_boxes = next;
--cur->num_cust_boxes;
}
pr = next;
}
cur->checked_cust_boxes = cur->num_cust_boxes;
}
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;
}
static Scheme_Object *read_top(Scheme_Object *obj)
{
Scheme_Compilation_Top *top;
top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top);
top->so.type = scheme_compilation_top_type;
if (!SCHEME_PAIRP(obj)) return NULL;
top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj);
top->code = SCHEME_CDR(obj);
return (Scheme_Object *)top;
}
static Scheme_Object *read_with_cont_mark(Scheme_Object *obj)
{
Scheme_With_Continuation_Mark *wcm;
if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj)))
return NULL; /* bad .zo */
wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark);
wcm->so.type = scheme_with_cont_mark_type;
wcm->key = SCHEME_CAR(obj);
wcm->val = SCHEME_CADR(obj);
wcm->body = SCHEME_CDR(SCHEME_CDR(obj));
return (Scheme_Object *)wcm;
}
void scheme_make_list_immutable(Scheme_Object *l)
{
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
if (SCHEME_MUTABLEP(l))
SCHEME_SET_IMMUTABLE(l);
}
}
/* This function applies a thunk, returning the Scheme value if there's no exception,
otherwise returning NULL and setting *exn to the raised value (usually an exn
structure). */
Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f, Scheme_Object **exn)
{
Scheme_Object *v;
init_exn_catching_apply();
v = _scheme_apply(exn_catching_apply, 1, &f);
/* v is a pair: (cons #t value) or (cons #f exn) */
if (SCHEME_TRUEP(SCHEME_CAR(v)))
return SCHEME_CDR(v);
else {
*exn = SCHEME_CDR(v);
return NULL;
}
}
static Scheme_Object *read_let_void(Scheme_Object *obj)
{
Scheme_Let_Void *lv;
lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void));
lv->iso.so.type = scheme_let_void_type;
if (!SCHEME_PAIRP(obj)) return NULL;
lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj));
lv->body = SCHEME_CDR(obj);
return (Scheme_Object *)lv;
}
static Scheme_Object *apply_impersonator_of(int for_chaperone, Scheme_Object *procs, Scheme_Object *obj)
{
Scheme_Object *a[1], *v, *oprocs;
a[0] = obj;
v = _scheme_apply(SCHEME_CDR(procs), 1, a);
if (SCHEME_FALSEP(v))
return NULL;
oprocs = scheme_struct_type_property_ref(scheme_impersonator_of_property, v);
if (!oprocs || !SAME_OBJ(SCHEME_CAR(oprocs), SCHEME_CAR(procs)))
scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
"impersonator-of property procedure returned a value with a different prop:impersonator-of source",
"original value", 1, obj,
"returned value", 1, v,
NULL);
procs = scheme_struct_type_property_ref(scheme_equal_property, obj);
oprocs = scheme_struct_type_property_ref(scheme_equal_property, v);
if (procs || oprocs)
if (!procs || !oprocs || !SAME_OBJ(SCHEME_VEC_ELS(oprocs)[0],
SCHEME_VEC_ELS(procs)[0]))
scheme_contract_error((for_chaperone ? "impersonator-of?" : "equal?"),
"impersonator-of property procedure returned a value with a different prop:equal+hash source",
"original value", 1, obj,
"returned value", 1, v,
NULL);
return v;
}
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[3], *red;
o = px->prev;
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = v;
red = SCHEME_CDR(px->redirects);
v = _scheme_apply(red, 3, a);
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2]))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"vector-set!: chaperone produced a result: %V that is not a chaperone of the original result: %V",
v,
a[2]);
}
}
}
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 *
cdr_prim (int argc, Scheme_Object *argv[])
{
if (!SCHEME_PAIRP(argv[0]))
scheme_wrong_type("cdr", "pair", 0, argc, argv);
return (SCHEME_CDR (argv[0]));
}
static Scheme_Object *read_set_bang(Scheme_Object *obj)
{
Scheme_Set_Bang *sb;
sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang);
sb->so.type = scheme_set_bang_type;
if (!SCHEME_PAIRP(obj)) return NULL;
sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj));
obj = SCHEME_CDR(obj);
if (!SCHEME_PAIRP(obj)) return NULL;
sb->var = SCHEME_CAR(obj);
sb->val = SCHEME_CDR(obj);
return (Scheme_Object *)sb;
}
static Scheme_Object *
set_cdr_prim (int argc, Scheme_Object *argv[])
{
if (!SCHEME_MUTABLE_PAIRP(argv[0]))
scheme_wrong_type("set-cdr!", "mutable-pair", 0, argc, argv);
SCHEME_CDR (argv[0]) = argv[1];
return scheme_void;
}
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
{
Scheme_Object *cons;
cons = scheme_alloc_object();
cons->type = scheme_pair_type;
SCHEME_CAR(cons) = car;
SCHEME_CDR(cons) = cdr;
return cons;
}
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;
}
Scheme_Object *scheme_make_immutable_pair(Scheme_Object *car, Scheme_Object *cdr)
{
Scheme_Object *cons;
cons = scheme_alloc_object();
cons->type = scheme_pair_type;
SCHEME_CAR(cons) = car;
SCHEME_CDR(cons) = cdr;
SCHEME_SET_PAIR_IMMUTABLE(cons);
return cons;
}
static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info)
{
Scheme_Object *v;
if (!info->pass)
scheme_signal_error("internal error: wrong pass to get saved info");
if (!SCHEME_PAIRP(info->saved))
scheme_signal_error("internal error: no saved info");
v = SCHEME_CAR(info->saved);
info->saved = SCHEME_CDR(info->saved);
return v;
}
Scheme_Object *read_boxenv(Scheme_Object *o)
{
Scheme_Object *data;
if (!SCHEME_PAIRP(o)) return NULL;
data = scheme_alloc_object();
data->type = scheme_boxenv_type;
SCHEME_PTR1_VAL(data) = SCHEME_CAR(o);
SCHEME_PTR2_VAL(data) = SCHEME_CDR(o);
return data;
}
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);
}
void scheme_chaperone_vector_set(Scheme_Object *o, int i, Scheme_Object *v)
{
Scheme_Object *outermost = o;
while (1) {
if (!SCHEME_NP_CHAPERONEP(o)) {
SCHEME_VEC_ELS(o)[i] = v;
return;
} else {
Scheme_Chaperone *px = (Scheme_Chaperone *)o;
Scheme_Object *a[4], *red;
int chap_star = SCHEME_CHAPERONE_FLAGS(px) & SCHEME_VEC_CHAPERONE_STAR ? 1 : 0;
red = px->redirects;
if (SCHEME_FALSEP(red)) {
o = px->val;
continue;
}
o = px->prev;
if (!SCHEME_REDIRECTS_PROP_ONLY_VECTORP(red)) {
/* not a property only chaperone */
red = SCHEME_CDR(px->redirects);
if (chap_star) {
a[0] = outermost;
a[1] = o;
a[2] = scheme_make_integer(i);
a[3] = v;
v = _scheme_apply(red, 4, a);
}
else {
a[0] = o;
a[1] = scheme_make_integer(i);
a[2] = v;
v = _scheme_apply(red, 3, a);
}
if (!(SCHEME_CHAPERONE_FLAGS(px) & SCHEME_CHAPERONE_IS_IMPERSONATOR))
if (!scheme_chaperone_of(v, a[2 + chap_star]))
scheme_wrong_chaperoned("vector-set!", "value", a[2 + chap_star], v);
}
}
}
}
Scheme_Object *
scheme_list_to_vector (Scheme_Object *list)
{
intptr_t len, i;
Scheme_Object *vec, *orig = list;
len = scheme_proper_list_length(list);
if (len < 0)
scheme_wrong_contract("list->vector", "list?", -1, 0, &orig);
vec = scheme_make_vector(len, NULL);
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_CAR(list);
list = SCHEME_CDR(list);
}
return vec;
}
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;
}
}