mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 06:09:18 +02:00
-e/-p options in main had a long-standing stupid gc bug
This commit is contained in:
Alex Shinn
parent
17afe65125
commit
0f9a23f94f
9 changed files with 126 additions and 38 deletions
2
eval.c
2
eval.c
|
|
@ -377,6 +377,7 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s
|
|||
if (!res || sexp_exceptionp(res))
|
||||
return res;
|
||||
if (ctx) sexp_gc_preserve1(ctx, res);
|
||||
sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE));
|
||||
sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE);
|
||||
sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE;
|
||||
sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE;
|
||||
|
|
@ -387,7 +388,6 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s
|
|||
sexp_stack_top(stack) = 0;
|
||||
}
|
||||
sexp_context_stack(res) = stack;
|
||||
sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE));
|
||||
if (! ctx) sexp_init_eval_context_globals(res);
|
||||
if (ctx) {
|
||||
sexp_context_params(res) = sexp_context_params(ctx);
|
||||
|
|
|
|||
51
gc.c
51
gc.c
|
|
@ -177,6 +177,16 @@ int stack_references_pointer_p (sexp ctx, sexp x) {
|
|||
return 0;
|
||||
}
|
||||
|
||||
const char* sexp_debug_string(sexp ctx, sexp p) {
|
||||
static char buf[32];
|
||||
if (sexp_pointerp(p))
|
||||
return sexp_object_type_name(ctx, p);
|
||||
else if (sexp_nullp(p))
|
||||
return "()";
|
||||
sprintf(buf, "%p", p);
|
||||
return buf;
|
||||
}
|
||||
|
||||
void sexp_conservative_mark (sexp ctx) {
|
||||
sexp_heap h = sexp_context_heap(ctx);
|
||||
sexp p, end;
|
||||
|
|
@ -193,16 +203,41 @@ void sexp_conservative_mark (sexp ctx) {
|
|||
continue;
|
||||
}
|
||||
if (!sexp_markedp(p) && stack_references_pointer_p(ctx, p)) {
|
||||
#if SEXP_USE_DEBUG_GC > 3
|
||||
if (p && sexp_pointerp(p)) {
|
||||
fprintf(stderr, SEXP_BANNER("MISS: %p: %s"), p,sexp_pointer_source(p));
|
||||
fflush(stderr);
|
||||
}
|
||||
#endif
|
||||
#if SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG
|
||||
#ifdef SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG
|
||||
if (sexp_pointer_tag(p) == SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG)
|
||||
#endif
|
||||
sexp_mark(ctx, p);
|
||||
if (sexp_pairp(p) && sexp_pairp(sexp_car(p))
|
||||
&& sexp_symbolp(sexp_caar(p))
|
||||
&& (sexp_caar(p)==(sexp)0x6c7677
|
||||
/* || sexp_caar(p)==(sexp)0xffd27 */
|
||||
)
|
||||
) {
|
||||
#if SEXP_USE_DEBUG_GC > 3
|
||||
if (p && sexp_pointerp(p)) {
|
||||
if (sexp_pairp(p)) {
|
||||
fprintf(stderr, SEXP_BANNER("MISS: %p (%s . %s): %s"), p,
|
||||
sexp_debug_string(ctx, sexp_car(p)),
|
||||
sexp_debug_string(ctx, sexp_cdr(p)),
|
||||
sexp_pointer_source(p));
|
||||
if (sexp_pairp(sexp_car(p))) {
|
||||
fprintf(stderr, "car: (%s . %s)\n",
|
||||
sexp_debug_string(ctx, sexp_caar(p)),
|
||||
sexp_debug_string(ctx, sexp_cdar(p)));
|
||||
if (sexp_pairp(sexp_cdar(p)))
|
||||
fprintf(stderr, "cdar: (%s . %s)\n",
|
||||
sexp_debug_string(ctx, sexp_cadar(p)),
|
||||
sexp_debug_string(ctx, sexp_cddar(p)));
|
||||
}
|
||||
} else {
|
||||
fprintf(stderr, SEXP_BANNER("MISS: %p: %s"), p,
|
||||
sexp_pointer_source(p));
|
||||
}
|
||||
sexp_stack_trace(ctx, SEXP_FALSE);
|
||||
fflush(stderr);
|
||||
}
|
||||
#endif
|
||||
sexp_mark(ctx, p);
|
||||
}
|
||||
}
|
||||
p = (sexp) (((char*)p)+sexp_heap_align(sexp_allocated_bytes(ctx, p)));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -136,7 +136,7 @@ SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_u
|
|||
SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);
|
||||
SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj);
|
||||
SEXP_API sexp sexp_analyze (sexp context, sexp x);
|
||||
SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
|
||||
/* SEXP_API void sexp_stack_trace (sexp ctx, sexp out); */
|
||||
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
|
||||
SEXP_API sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
|
||||
SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv);
|
||||
|
|
@ -164,9 +164,9 @@ SEXP_API sexp sexp_open_output_file_op(sexp ctx sexp_api_params(self, n), sexp x
|
|||
SEXP_API sexp sexp_close_port_op(sexp ctx sexp_api_params(self, n), sexp x);
|
||||
SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val);
|
||||
SEXP_API sexp sexp_env_cell (sexp env, sexp sym);
|
||||
SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
|
||||
/* SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); */
|
||||
SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt);
|
||||
SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
|
||||
/* SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param); */
|
||||
SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to);
|
||||
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
|
||||
SEXP_API sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, sexp num_args, sexp bc, sexp vars);
|
||||
|
|
|
|||
|
|
@ -316,10 +316,6 @@
|
|||
#define SEXP_USE_CONSERVATIVE_GC 0
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG
|
||||
#define SEXP_USE_CONSERVATIVE_GC_PRESERVE_TAG 0
|
||||
#endif
|
||||
|
||||
#ifndef SEXP_USE_TRACK_ALLOC_SOURCE
|
||||
#define SEXP_USE_TRACK_ALLOC_SOURCE SEXP_USE_DEBUG_GC > 2
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -1150,6 +1150,10 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj)
|
|||
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, (sexp_proc2)finalizer)
|
||||
#endif
|
||||
|
||||
SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt);
|
||||
SEXP_API sexp sexp_parameter_ref (sexp ctx, sexp param);
|
||||
SEXP_API void sexp_stack_trace (sexp ctx, sexp out);
|
||||
|
||||
#define sexp_current_error_port(ctx) sexp_parameter_ref(ctx, sexp_env_ref(sexp_context_env(ctx), sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL), SEXP_FALSE))
|
||||
#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx)))
|
||||
|
||||
|
|
|
|||
21
lib/init.scm
21
lib/init.scm
|
|
@ -261,14 +261,16 @@
|
|||
((null? ls) #f)
|
||||
((compare (rename 'else) (caar ls))
|
||||
`(,(rename 'begin) ,@(cdar ls)))
|
||||
((and (pair? (car (car ls))) (null? (cdr (car (car ls)))))
|
||||
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp)
|
||||
(,(rename 'quote) ,(caaar ls)))
|
||||
(,(rename 'begin) ,@(cdar ls))
|
||||
,(clause (cdr ls))))
|
||||
(else
|
||||
(if (and (pair? (caar ls)) (null? (cdaar ls)))
|
||||
`(,(rename 'if) (,(rename 'eqv?) ,(rename 'tmp) ',(caaar ls))
|
||||
(,(rename 'begin) ,@(cdar ls))
|
||||
,(clause (cdr ls)))
|
||||
`(,(rename 'if) (,(rename 'memv) ,(rename 'tmp) ',(caar ls))
|
||||
(,(rename 'begin) ,@(cdar ls))
|
||||
,(clause (cdr ls)))))))
|
||||
`(,(rename 'if) (,(rename 'memv) ,(rename 'tmp)
|
||||
(,(rename 'quote) ,(caar ls)))
|
||||
(,(rename 'begin) ,@(cdar ls))
|
||||
,(clause (cdr ls))))))
|
||||
`(let ((,(rename 'tmp) ,(cadr expr)))
|
||||
,(clause (cddr expr))))))
|
||||
|
||||
|
|
@ -345,6 +347,11 @@
|
|||
(call-with-output-string
|
||||
(lambda (out) (for-each (lambda (ch) (write-char ch out)) ls))))
|
||||
|
||||
;; (define (list->string ls)
|
||||
;; (let lp ((ls ls) (res '()))
|
||||
;; (cond ((null? ls) (string-concatenate (reverse res)))
|
||||
;; (else (lp (cdr ls) (cons (make-string 1 (car ls)) res))))))
|
||||
|
||||
(define (string->list str)
|
||||
(let lp ((i (string-cursor-prev str (string-cursor-end str))) (res '()))
|
||||
(if (< i 0)
|
||||
|
|
|
|||
7
main.c
7
main.c
|
|
@ -124,7 +124,7 @@ static sexp sexp_load_standard_repl_env (sexp ctx, sexp env, sexp k) {
|
|||
|
||||
void run_main (int argc, char **argv) {
|
||||
char *arg, *impmod, *p;
|
||||
sexp out=SEXP_FALSE, res=SEXP_VOID, env=NULL, ctx=NULL;
|
||||
sexp out=SEXP_FALSE, env=NULL, ctx=NULL;
|
||||
sexp_sint_t i, j, len, quit=0, print=0, init_loaded=0, fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS;
|
||||
sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE;
|
||||
sexp_gc_var2(tmp, args);
|
||||
|
|
@ -139,12 +139,11 @@ void run_main (int argc, char **argv) {
|
|||
print = (argv[i][1] == 'p');
|
||||
arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2);
|
||||
check_nonull_arg('e', arg);
|
||||
res = check_exception(ctx, sexp_read_from_string(ctx, arg, -1));
|
||||
res = check_exception(ctx, sexp_eval(ctx, res, env));
|
||||
tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env));
|
||||
if (print) {
|
||||
if (! sexp_oportp(out))
|
||||
out = sexp_eval_string(ctx, "(current-output-port)", -1, env);
|
||||
sexp_write(ctx, res, out);
|
||||
sexp_write(ctx, tmp, out);
|
||||
sexp_write_char(ctx, '\n', out);
|
||||
}
|
||||
quit = 1;
|
||||
|
|
|
|||
66
sexp.c
66
sexp.c
|
|
@ -1044,14 +1044,45 @@ int sstream_read (void *vec, char *dst, int n) {
|
|||
return n;
|
||||
}
|
||||
|
||||
#define SEXP_LAST_CONTEXT_CHECK_LIMIT 256
|
||||
|
||||
#if ! SEXP_USE_BOEHM
|
||||
static int in_heap_p (sexp_heap h, sexp p) {
|
||||
for ( ; h; h = h->next)
|
||||
if (((sexp)h < p) && (p < (sexp)((char*)h + h->size)))
|
||||
return 1;
|
||||
return 0;
|
||||
}
|
||||
#endif
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
int sstream_write (void *vec, const char *src, int n) {
|
||||
sexp_uint_t len, pos, newpos;
|
||||
sexp newbuf;
|
||||
sexp newbuf, ctx;
|
||||
len = sexp_unbox_fixnum(sexp_stream_size(vec));
|
||||
pos = sexp_unbox_fixnum(sexp_stream_pos(vec));
|
||||
newpos = pos+n;
|
||||
ctx = sexp_last_context(sexp_stream_ctx(vec), &ctx);
|
||||
if (newpos >= len) {
|
||||
newbuf = sexp_make_string(sexp_stream_ctx(vec),
|
||||
newbuf = sexp_make_string(ctx, /* sexp_stream_ctx(vec) */
|
||||
sexp_make_fixnum(newpos*2),
|
||||
SEXP_VOID);
|
||||
memcpy(sexp_string_data(newbuf),
|
||||
|
|
@ -1082,6 +1113,7 @@ sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str
|
|||
FILE *in;
|
||||
sexp res;
|
||||
sexp_gc_var1(cookie);
|
||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
||||
sexp_gc_preserve1(ctx, cookie);
|
||||
cookie = sexp_make_vector(ctx, sexp_make_fixnum(4), SEXP_VOID);
|
||||
sexp_stream_ctx_set(cookie, ctx);
|
||||
|
|
@ -1122,7 +1154,7 @@ sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) {
|
|||
sexp_stream_pos(cookie));
|
||||
}
|
||||
|
||||
#else
|
||||
#else /* SEXP_USE_STRING_STREAMS && ! SEXP_BSD */
|
||||
|
||||
sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str) {
|
||||
FILE *in;
|
||||
|
|
@ -1151,13 +1183,14 @@ sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
|
|||
}
|
||||
|
||||
sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port) {
|
||||
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
|
||||
fflush(sexp_port_stream(port));
|
||||
return sexp_c_string(ctx, sexp_port_buf(port), sexp_port_size(port));
|
||||
}
|
||||
|
||||
#endif
|
||||
|
||||
#else
|
||||
#else /* ! SEXP_USE_STRING_STREAMS */
|
||||
|
||||
#define SEXP_PORT_BUFFER_SIZE 4096
|
||||
|
||||
|
|
@ -1176,7 +1209,7 @@ int sexp_buffered_read_char (sexp ctx, sexp p) {
|
|||
}
|
||||
|
||||
sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) {
|
||||
if (sexp_port_offset(p) >= sexp_port_size(p))
|
||||
if (sexp_port_offset(p)+1 >= sexp_port_size(p))
|
||||
sexp_buffered_flush(ctx, p);
|
||||
sexp_port_buf(p)[sexp_port_offset(p)++] = c;
|
||||
return SEXP_VOID;
|
||||
|
|
@ -1184,8 +1217,18 @@ sexp sexp_buffered_write_char (sexp ctx, int c, sexp p) {
|
|||
|
||||
sexp sexp_buffered_write_string_n (sexp ctx, const char *str,
|
||||
sexp_uint_t len, sexp p) {
|
||||
if (sexp_port_offset(p) >= sexp_port_size(p))
|
||||
int diff;
|
||||
/* fprintf(stderr, "write %s: off: %ld size: %ld len: %ld\n", */
|
||||
/* str, sexp_port_offset(p), sexp_port_size(p), len); */
|
||||
while (sexp_port_offset(p)+len >= sexp_port_size(p)) {
|
||||
diff = sexp_port_size(p) - sexp_port_offset(p);
|
||||
/* fprintf(stderr, "write: off: %ld size: %ld len: %ld diff: %ld\n", */
|
||||
/* sexp_port_offset(p), sexp_port_size(p), len, diff); */
|
||||
memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, diff);
|
||||
sexp_buffered_flush(ctx, p);
|
||||
str += diff;
|
||||
len -= diff;
|
||||
}
|
||||
memcpy(sexp_port_buf(p)+sexp_port_offset(p), str, len);
|
||||
sexp_port_offset(p) += len;
|
||||
return SEXP_VOID;
|
||||
|
|
@ -1196,7 +1239,7 @@ sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) {
|
|||
}
|
||||
|
||||
sexp sexp_buffered_flush (sexp ctx, sexp p) {
|
||||
sexp_gc_var1(tmp);
|
||||
sexp_gc_var2(tmp, ls);
|
||||
if (! sexp_oportp(p))
|
||||
return sexp_type_exception(ctx, NULL, SEXP_OPORT, p);
|
||||
if (! sexp_port_openp(p))
|
||||
|
|
@ -1206,10 +1249,12 @@ sexp sexp_buffered_flush (sexp ctx, sexp p) {
|
|||
fwrite(sexp_port_buf(p), 1, sexp_port_offset(p), sexp_port_stream(p));
|
||||
fflush(sexp_port_stream(p));
|
||||
} else if (sexp_port_offset(p) > 0) {
|
||||
sexp_gc_preserve1(ctx, tmp);
|
||||
sexp_gc_preserve2(ctx, tmp, ls);
|
||||
ls = sexp_port_cookie(p);
|
||||
tmp = sexp_c_string(ctx, sexp_port_buf(p), sexp_port_offset(p));
|
||||
sexp_push(ctx, sexp_port_cookie(p), tmp);
|
||||
sexp_gc_release1(ctx);
|
||||
/* sexp_push(ctx, sexp_port_cookie(p), tmp); */
|
||||
sexp_port_cookie(p) = sexp_cons(ctx, tmp, ls);
|
||||
sexp_gc_release2(ctx);
|
||||
}
|
||||
sexp_port_offset(p) = 0;
|
||||
return SEXP_VOID;
|
||||
|
|
@ -1245,6 +1290,7 @@ sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
|
|||
sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp out) {
|
||||
sexp res;
|
||||
sexp_gc_var2(ls, tmp);
|
||||
sexp_assert_type(ctx, sexp_oportp, SEXP_OPORT, out);
|
||||
sexp_gc_preserve2(ctx, ls, tmp);
|
||||
if (sexp_port_offset(out) > 0) {
|
||||
tmp = sexp_c_string(ctx, sexp_port_buf(out), sexp_port_offset(out));
|
||||
|
|
|
|||
3
vm.c
3
vm.c
|
|
@ -22,7 +22,8 @@ static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out)
|
|||
void sexp_stack_trace (sexp ctx, sexp out) {
|
||||
int i, fp=sexp_context_last_fp(ctx);
|
||||
sexp self, bc, ls, *stack=sexp_stack_data(sexp_context_stack(ctx));
|
||||
if (! sexp_oportp(out)) out = sexp_current_error_port(ctx);
|
||||
if (! sexp_oportp(out))
|
||||
out = sexp_current_error_port(ctx);
|
||||
for (i=fp; i>4; i=sexp_unbox_fixnum(stack[i+3])) {
|
||||
self = stack[i+2];
|
||||
if (self && sexp_procedurep(self)) {
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue