static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
size_t freed;
sexp_uint_t stats[256], hi_type=0, i;
sexp_heap h = sexp_context_heap(ctx);
sexp p, out=SEXP_FALSE;
sexp_free_list q, r;
char *end;
sexp_gc_var3(res, tmp, name);
if (printp)
out = sexp_parameter_ref(ctx,
sexp_env_ref(ctx,
sexp_context_env(ctx),
sexp_global(ctx,SEXP_G_CUR_OUT_SYMBOL),
SEXP_FALSE));
/* run gc once to remove unused variables */
sexp_gc(ctx, &freed);
/* initialize stats */
for (i=0; i<256; i++) stats[i]=0;
/* loop over each heap chunk */
for ( ; h; h=h->next) {
p = (sexp) (h->data + sexp_heap_align(sexp_sizeof(pair)));
q = h->free_list;
end = (char*)h->data + h->size;
while (((char*)p) < end) {
/* find the preceding and succeeding free list pointers */
for (r=q->next; r && ((char*)r<(char*)p); q=r, r=r->next)
;
if ((char*)r == (char*)p) { /* this is a free block, skip */
p = (sexp) (((char*)p) + r->size);
continue;
}
/* otherwise maybe print, then increment the stat and continue */
if (sexp_oportp(out)) {
sexp_print_simple(ctx, p, out, depth);
sexp_write_char(ctx, '\n', out);
}
stats[sexp_pointer_tag(p)]++;
if (sexp_pointer_tag(p) > hi_type)
hi_type = sexp_pointer_tag(p);
p = (sexp) (((char*)p) + sexp_heap_align(sexp_allocated_bytes(ctx, p)));
}
}
/* build and return results */
sexp_gc_preserve3(ctx, res, tmp, name);
res = SEXP_NULL;
for (i=hi_type; i>0; i--)
if (stats[i]) {
name = sexp_string_to_symbol(ctx, sexp_type_name_by_index(ctx, i));
tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
res = sexp_cons(ctx, tmp, res);
}
sexp_gc_release3(ctx);
return res;
}
static int sexp_object_compare (sexp ctx, sexp a, sexp b) {
int res;
if (a == b)
return 0;
if (sexp_pointerp(a)) {
if (sexp_pointerp(b)) {
if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) {
res = sexp_pointer_tag(a) - sexp_pointer_tag(b);
} else {
switch (sexp_pointer_tag(a)) {
case SEXP_FLONUM:
res = sexp_flonum_value(a) - sexp_flonum_value(b);
break;
case SEXP_BIGNUM:
res = sexp_bignum_compare(a, b);
break;
case SEXP_STRING:
res = strcmp(sexp_string_data(a), sexp_string_data(b));
break;
case SEXP_SYMBOL:
res = strcmp(sexp_symbol_data(a), sexp_symbol_data(b));
break;
default:
res = 0;
break;
}
}
#if SEXP_USE_HUFF_SYMS
} else if (sexp_lsymbolp(a) && sexp_isymbolp(b)) {
res = strcmp(sexp_symbol_data(a),
sexp_string_data(sexp_write_to_string(ctx, b)));
#endif
} else {
res = 1;
}
} else if (sexp_pointerp(b)) {
#if SEXP_USE_HUFF_SYMS
if (sexp_isymbolp(a) && sexp_lsymbolp(b))
res = strcmp(sexp_string_data(sexp_write_to_string(ctx, a)),
sexp_symbol_data(b));
else
#endif
res = -1;
} else {
#if SEXP_USE_HUFF_SYMS
if (sexp_isymbolp(a) && sexp_isymbolp(b))
return sexp_isymbol_compare(ctx, a, b);
else
#endif
res = (sexp_sint_t)a - (sexp_sint_t)b;
}
return res;
}
static sexp sexp_set_time_of_day_x_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) {
int err;
sexp res;
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
if (! ((sexp_pointerp(arg1) && (sexp_pointer_tag(arg1) == sexp_unbox_fixnum(sexp_opcode_arg2_type(self)))) || sexp_not(arg1)))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg2_type(self)), arg1);
err = settimeofday((struct timeval*)sexp_cpointer_value(arg0), (struct timezone*)sexp_cpointer_maybe_null_value(arg1));
if (err) {
res = SEXP_FALSE;
} else {
res = SEXP_TRUE;
}
return res;
}
static sexp sexp_object_size (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
sexp t;
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
return SEXP_ZERO;
t = sexp_object_type(ctx, x);
return sexp_make_fixnum(sexp_type_size_of_object(t, x));
}
static sexp sexp_make_custom_port (sexp ctx, sexp self,
char *mode, sexp read, sexp write,
sexp seek, sexp close) {
sexp vec;
sexp_gc_var2(res, str);
sexp_gc_preserve2(ctx, res, str);
str = sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID);
if (sexp_exceptionp(str)) return str;
res = sexp_open_input_string(ctx, str);
if (sexp_exceptionp(res)) return res;
if (mode && mode[0] == 'w') {
sexp_pointer_tag(res) = SEXP_OPORT;
sexp_port_cookie(res) = str;
} else {
sexp_port_offset(res) = 0;
sexp_port_size(res) = 0;
}
vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
if (sexp_exceptionp(vec)) return vec;
sexp_vector_set(vec, SEXP_ZERO, SEXP_FALSE);
sexp_vector_set(vec, SEXP_ONE, sexp_port_cookie(res));
sexp_vector_set(vec, SEXP_TWO, read);
sexp_vector_set(vec, SEXP_THREE, write);
sexp_vector_set(vec, SEXP_FOUR, seek);
sexp_vector_set(vec, SEXP_FIVE, close);
sexp_port_cookie(res) = vec;
sexp_gc_release2(ctx);
return res;
}
static sexp sexp_readdir_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) {
sexp res;
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
res = sexp_make_cpointer(ctx, sexp_unbox_fixnum(sexp_opcode_return_type(self)), readdir((DIR*)sexp_cpointer_value(arg0)), arg0, 0);
return res;
}
static sexp sexp_player_delete_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) {
sexp res;
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
res = ((player_delete((struct player**)sexp_cpointer_value(arg0))), SEXP_VOID);
return res;
}
static int usedp (sexp lambda, sexp var, sexp x) {
sexp ls;
loop:
switch (sexp_pointerp(x) ? sexp_pointer_tag(x) : 0) {
case SEXP_REF:
return sexp_ref_name(x) == var && sexp_ref_loc(x) == lambda;
case SEXP_SET:
x = sexp_set_value(x);
goto loop;
case SEXP_LAMBDA:
x = sexp_lambda_body(x);
goto loop;
case SEXP_CND:
if (usedp(lambda, var, sexp_cnd_test(x))
|| usedp(lambda, var, sexp_cnd_pass(x)))
return 1;
x = sexp_cnd_fail(x);
goto loop;
case SEXP_SEQ:
x = sexp_seq_ls(x);
case SEXP_PAIR:
for (ls=x; sexp_pairp(ls); ls=sexp_cdr(ls))
if (usedp(lambda, var, sexp_car(ls)))
return 1;
}
return 0;
}
static sexp sexp_time_3e_seconds_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) {
sexp res;
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
res = sexp_make_integer(ctx, sexp_shift_epoch(mktime((struct tm*)sexp_cpointer_value(arg0))));
return res;
}
sexp sexp_make_custom_output_port (sexp ctx, sexp self,
sexp write, sexp seek, sexp close) {
sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close);
#if SEXP_USE_STRING_STREAMS
if (!sexp_exceptionp(res))
sexp_pointer_tag(res) = SEXP_OPORT;
#endif
return res;
}
static sexp sexp_player_move_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1, sexp arg2) {
sexp res;
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
if (! sexp_exact_integerp(arg1))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg1);
if (! sexp_exact_integerp(arg2))
return sexp_type_exception(ctx, self, SEXP_FIXNUM, arg2);
res = ((player_move((struct player**)sexp_cpointer_value(arg0), sexp_uint_value(arg1), sexp_uint_value(arg2))), SEXP_VOID);
return res;
}
sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
sexp_uint_t res;
sexp t;
if (!sexp_pointerp(x) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
return sexp_heap_align(1);
t = sexp_object_type(ctx, x);
res = sexp_type_size_of_object(t, x) + SEXP_GC_PAD;
#if SEXP_USE_DEBUG_GC
if (res == 0) {
fprintf(stderr, SEXP_BANNER("%p zero-size object: %p"), ctx, x);
return 1;
}
#endif
return res;
}
static sexp sexp_last_context (sexp ctx, sexp *cstack) {
sexp res=SEXP_FALSE;
#if ! SEXP_USE_BOEHM
sexp p;
sexp_sint_t i;
sexp_heap h = sexp_context_heap(ctx);
for (i=0; i<SEXP_LAST_CONTEXT_CHECK_LIMIT; i++) {
p = cstack[i];
if (p && (p != ctx) && sexp_pointerp(p) && in_heap_p(h, p)
&& (sexp_pointer_tag(p) == SEXP_CONTEXT)
&& (sexp_context_heap(p) == h)) {
res = p;
break;
}
}
#endif
return res;
}
static sexp sexp_time_3e_string_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0) {
char *err;
char tmp1[64];
sexp res;
sexp_gc_var1(res1);
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
sexp_gc_preserve1(ctx, res1);
err = asctime_r((struct tm*)sexp_cpointer_value(arg0), tmp1);
if (!err) {
res = SEXP_FALSE;
} else {
res1 = sexp_c_string(ctx, tmp1, -1);
res = res1;
}
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_make_custom_port (sexp ctx, sexp self, char *mode,
sexp read, sexp write,
sexp seek, sexp close) {
FILE *in;
sexp res;
sexp_gc_var1(vec);
if (sexp_truep(read) && ! sexp_procedurep(read))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, read);
if (sexp_truep(write) && ! sexp_procedurep(write))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, write);
if (sexp_truep(seek) && ! sexp_procedurep(seek))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, seek);
if (sexp_truep(close) && ! sexp_procedurep(close))
return sexp_type_exception(ctx, self, SEXP_PROCEDURE, close);
sexp_gc_preserve1(ctx, vec);
vec = sexp_make_vector(ctx, SEXP_SIX, SEXP_VOID);
sexp_cookie_ctx_set(vec, ctx);
sexp_cookie_buffer_set(vec, sexp_make_string(ctx, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE), SEXP_VOID));
sexp_cookie_read_set(vec, read);
sexp_cookie_write_set(vec, write);
sexp_cookie_seek_set(vec, seek);
sexp_cookie_close_set(vec, close);
#if SEXP_BSD
in = funopen(vec,
(sexp_procedurep(read) ? sexp_cookie_reader : NULL),
(sexp_procedurep(write) ? sexp_cookie_writer : NULL),
NULL, /* (sexp_procedurep(seek) ? sexp_cookie_reader : NULL), */
(sexp_procedurep(close) ? sexp_cookie_cleaner : NULL));
#else
in = fopencookie(vec, mode, (sexp_truep(seek) ? sexp_cookie : sexp_cookie_no_seek));
#endif
if (! in) {
res = sexp_user_exception(ctx, self, "couldn't make custom port", read);
} else {
res = sexp_make_input_port(ctx, in, SEXP_FALSE);
sexp_port_cookie(res) = vec; /* for gc preserving */
}
if (mode && mode[0] == 'w')
sexp_pointer_tag(res) = SEXP_OPORT;
sexp_gc_release1(ctx);
return res;
}
static sexp sexp_stat_get_st_blocks (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
if (! (sexp_pointerp(x) && (sexp_pointer_tag(x) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), x);
return sexp_make_unsigned_integer(ctx, ((struct stat*)sexp_cpointer_value(x))->st_blocks);
}
static sexp sexp_dirent_get_d_name (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
if (! (sexp_pointerp(x) && (sexp_pointer_tag(x) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), x);
return sexp_c_string(ctx, ((struct dirent*)sexp_cpointer_value(x))->d_name, -1);
}
static sexp sexp_make_custom_output_port (sexp ctx, sexp self,
sexp write, sexp seek, sexp close) {
sexp res = sexp_make_custom_port(ctx, self, "w", SEXP_FALSE, write, seek, close);
sexp_pointer_tag(res) = SEXP_OPORT;
return res;
}
static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
int check;
sexp ls1, ls2, p1, p2, sv;
sexp_gc_var5(res, substs, tmp, app, ctx2);
sexp_gc_preserve5(ctx, res, substs, tmp, app, ctx2);
res = ast; /* return the ast as-is by default */
substs = init_substs;
loop:
switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) {
case SEXP_PAIR:
/* don't simplify the operator if it's a lambda because we
simplify that as a special case below, with the appropriate
substs list */
app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
: (tmp=simplify(ctx, sexp_car(res), substs, lambda)));
sexp_pair_source(app) = sexp_pair_source(res);
for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda));
if (sexp_pairp(app)) sexp_pair_source(app) = sexp_pair_source(ls1);
}
app = sexp_nreverse(ctx, app);
/* app now holds a copy of the list, and is the default result
(res = app below) if we don't replace it with a simplification */
if (sexp_opcodep(sexp_car(app))) {
/* opcode app - right now we just constant fold arithmetic */
if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) {
for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
check = 0;
break;
}
}
if (check) {
ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0, 0);
sexp_generate(ctx2, 0, 0, 0, app);
res = sexp_complete_bytecode(ctx2);
if (! sexp_exceptionp(res)) {
tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp);
if (! sexp_exceptionp(tmp)) {
tmp = sexp_apply(ctx2, tmp, SEXP_NULL);
if (! sexp_exceptionp(tmp))
app = sexp_make_lit(ctx2, tmp);
}
}
}
}
} else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */
p1 = NULL;
p2 = sexp_lambda_params(sexp_car(app));
ls1 = app;
ls2 = sexp_cdr(app);
sv = sexp_lambda_sv(sexp_car(app));
if (sexp_length(ctx, p2) == sexp_length(ctx, ls2)) {
for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) {
if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv))
&& (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2))
|| (sexp_refp(sexp_car(ls2))
&& sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))
&& sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)),
sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) {
tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2));
tmp = sexp_cons(ctx, sexp_car(p2), tmp);
sexp_push(ctx, substs, tmp);
sexp_cdr(ls1) = sexp_cdr(ls2);
if (p1)
sexp_cdr(p1) = sexp_cdr(p2);
else
sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2);
} else {
p1 = p2;
ls1 = ls2;
}
}
sexp_lambda_body(sexp_car(app))
= simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
if (sexp_nullp(sexp_cdr(app))
&& sexp_nullp(sexp_lambda_params(sexp_car(app)))
&& sexp_nullp(sexp_lambda_defs(sexp_car(app))))
app = sexp_lambda_body(sexp_car(app));
}
}
res = app;
break;
case SEXP_LAMBDA:
sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res);
break;
case SEXP_CND:
tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda);
if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) {
res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp))
? sexp_cnd_fail(res) : sexp_cnd_pass(res);
goto loop;
} else {
sexp_cnd_test(res) = tmp;
simplify_it(sexp_cnd_pass(res));
simplify_it(sexp_cnd_fail(res));
}
break;
case SEXP_REF:
tmp = sexp_ref_name(res);
for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) {
res = sexp_cddar(ls1);
break;
}
break;
case SEXP_SET:
simplify_it(sexp_set_value(res));
break;
case SEXP_SEQ:
app = SEXP_NULL;
for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) {
tmp = simplify(ctx, sexp_car(ls2), substs, lambda);
if (! (sexp_pairp(sexp_cdr(ls2))
&& (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
|| sexp_lambdap(tmp))))
sexp_push(ctx, app, tmp);
}
if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
res = sexp_car(app);
else
sexp_seq_ls(res) = sexp_nreverse(ctx, app);
break;
}
sexp_gc_release5(ctx);
return res;
}
static sexp sexp_timezone_get_tz_minuteswest (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
if (! (sexp_pointerp(x) && (sexp_pointer_tag(x) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), x);
return sexp_make_integer(ctx, ((struct timezone*)sexp_cpointer_value(x))->tz_minuteswest);
}
static sexp sexp_tm_get_tm_gmtoff (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
if (! (sexp_pointerp(x) && (sexp_pointer_tag(x) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), x);
return sexp_make_integer(ctx, ((struct tm*)sexp_cpointer_value(x))->tm_gmtoff);
}
static sexp sexp_timeval_get_tv_sec (sexp ctx, sexp self, sexp_sint_t n, sexp x) {
if (! (sexp_pointerp(x) && (sexp_pointer_tag(x) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), x);
return sexp_make_integer(ctx, sexp_shift_epoch(((struct timeval*)sexp_cpointer_value(x))->tv_sec));
}
