diff --git a/eval.c b/eval.c index 2ec932f5..6e1fade3 100644 --- a/eval.c +++ b/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); diff --git a/gc.c b/gc.c index 5d98de1d..d06a7250 100644 --- a/gc.c +++ b/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))); } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5c5f01d6..29db9300 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -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); diff --git a/include/chibi/features.h b/include/chibi/features.h index 770d7069..41e7c896 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -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 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index bb7dcf83..ef6824cb 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -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))) diff --git a/lib/init.scm b/lib/init.scm index 5b62d97b..dafd2d3c 100644 --- a/lib/init.scm +++ b/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) diff --git a/main.c b/main.c index 7becccdf..0588beca 100644 --- a/main.c +++ b/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; diff --git a/sexp.c b/sexp.c index 3a6473b0..7150867a 100644 --- a/sexp.c +++ b/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= 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)); diff --git a/vm.c b/vm.c index fbf3a521..613301d9 100644 --- a/vm.c +++ b/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)) {