diff --git a/contrib/profile/profile.lisp b/contrib/profile/profile.lisp index 916717745..fdff5d99a 100644 --- a/contrib/profile/profile.lisp +++ b/contrib/profile/profile.lisp @@ -36,9 +36,6 @@ `(progn ,@body)) ) -(ffi:clines " -") - (defconstant +wrap+ (ffi:c-inline () () :object "ecl_make_unsigned_integer(~((size_t)0))" :one-liner t)) @@ -390,7 +387,7 @@ Lisp process." "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%" (sort no-call-name-list #'string< :key (lambda (name) - (symbol-name (fun-name-block-name name)))))) + (symbol-name name))))) (values))) diff --git a/msvc/ecl-threads.def b/msvc/ecl-threads.def index 90fe939a0..5112f08c4 100755 --- a/msvc/ecl-threads.def +++ b/msvc/ecl-threads.def @@ -195,6 +195,14 @@ EXPORTS ; interpreter.c si_interpreter_stack + ecl_stack_frame_reserve + ecl_stack_frame_push + ecl_stack_frame_push_va_list + ecl_stack_frame_close + ecl_stack_frame_pop_values + ecl_stack_frame_elt + ecl_stack_frame_elt_set + ecl_apply_from_stack_frame cl_stack_push cl_stack_pop @@ -365,7 +373,7 @@ EXPORTS ;si_set_funcallable si_generic_function_p - _ecl_compute_method + _ecl_standard_dispatch ; hash.c diff --git a/msvc/ecl.def b/msvc/ecl.def index 5dab53957..d63821adf 100644 --- a/msvc/ecl.def +++ b/msvc/ecl.def @@ -200,6 +200,14 @@ EXPORTS ; interpreter.c si_interpreter_stack + ecl_stack_frame_reserve + ecl_stack_frame_push + ecl_stack_frame_push_va_list + ecl_stack_frame_close + ecl_stack_frame_pop_values + ecl_stack_frame_elt + ecl_stack_frame_elt_set + ecl_apply_from_stack_frame cl_stack_push cl_stack_pop @@ -371,7 +379,7 @@ EXPORTS ;si_set_funcallable si_generic_function_p - _ecl_compute_method + _ecl_standard_dispatch ; hash.c diff --git a/src/CHANGELOG b/src/CHANGELOG index eba7b2aff..4c9ce4ec1 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -84,6 +84,13 @@ ECL 0.9k: - The compiler now inlines and optimizes (FUNCALL (X ..) ... ) where X is a macro that returns a lambda form. +* System design: + + - We introduce a new kind of lisp objects, the stack frames. These are objects + with dynamical extent, which work as adjustable arrays and are mainly used + for collecting the arguments of a function, in MAP, MAPCAR, APPLY, FUNCALL, + MULTIPLE-VALUE-CALL, etc. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/c/arch/ffi_x86.d b/src/c/arch/ffi_x86.d index 7ba076e7f..9fcae6d2a 100644 --- a/src/c/arch/ffi_x86.d +++ b/src/c/arch/ffi_x86.d @@ -110,6 +110,8 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer) union ecl_ffi_values output; enum ecl_ffi_tag tag; + ECL_BUILD_STACK_FRAME(frame); + fun = CAR(cbk_info); rtype = CADR(cbk_info); argtypes = CADDR(cbk_info); @@ -119,7 +121,7 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer) tag = ecl_foreign_type_code(CAR(argtypes)); size = fix(si_size_of_foreign_elt_type(CAR(argtypes))); result = ecl_foreign_data_ref_elt(arg_buffer, tag); - cl_stack_push(result); + ecl_stack_frame_push(frame,result); { int mask = 3; int sp = (size + mask) & ~mask; @@ -127,8 +129,8 @@ ecl_dynamic_callback_execute(cl_object cbk_info, char *arg_buffer) } } - result = cl_apply_from_stack(i, fun); - cl_stack_pop_n(i); + result = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); tag = ecl_foreign_type_code(rtype); memset(&output, 0, sizeof(output)); diff --git a/src/c/compiler.d b/src/c/compiler.d index c70feb265..1da6a5f8d 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -1918,7 +1918,8 @@ compile_form(cl_object stmt, int flags) { stmt = CAR(stmt); goto QUOTED; } - for (l = database; l->symbol != OBJNULL; l++) + for (l = database; l->symbol != OBJNULL; l++) { + /*cl_print(1, l->symbol);*/ if (l->symbol == function) { ENV->lexical_level += l->lexical_increment; if (ENV->stepping && function != @'function' && @@ -1930,6 +1931,7 @@ compile_form(cl_object stmt, int flags) { asm_op(OP_STEPOUT); goto OUTPUT; } + } /* * Next try to macroexpand */ @@ -2389,7 +2391,13 @@ ecl_make_lambda(cl_object name, cl_object lambda) { if (Null(si_valid_function_name_p(name))) FEprogram_error("LAMBDA: Not a valid function name ~S",1,name); - ENV->constants = reqs; /* Special arguments */ + /* We register as special variable a symbol which is not + * to be used. We use this to mark the boundary of a function + * environment and when code-walking */ + c_register_var(cl_make_symbol(make_constant_base_string("FUNCTION")), + TRUE, TRUE); + + ENV->constants = reqs; /* Required arguments */ reqs = CDR(reqs); while (!ecl_endp(reqs)) { cl_object v = pop(&reqs); diff --git a/src/c/eval.d b/src/c/eval.d index ee682fea7..28aa5d7b7 100644 --- a/src/c/eval.d +++ b/src/c/eval.d @@ -61,24 +61,11 @@ cl_va_arg(cl_va_list args) return va_arg(args[0].args, cl_object); } - -/* - *---------------------------------------------------------------------- - * - * apply -- - * applies a Lisp function to the arguments in array args. - * narg is their count. - * - * Results: - * number of values - * - * Side Effect: - * values are placed into the array Values - *---------------------------------------------------------------------- - */ cl_object -cl_apply_from_stack(cl_index narg, cl_object x) +ecl_apply_from_stack_frame(cl_object frame, cl_object x) { + cl_index narg = frame->frame.narg; + cl_object *sp = frame->frame.sp + cl_env.stack; cl_object fun = x; AGAIN: if (fun == OBJNULL || fun == Cnil) @@ -89,17 +76,22 @@ cl_apply_from_stack(cl_index narg, cl_object x) if (narg != (cl_index)fun->cfun.narg) FEwrong_num_arguments(fun); return APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, - cl_env.stack_top - narg); + sp); } - return APPLY(narg, fun->cfun.entry, cl_env.stack_top - narg); + return APPLY(narg, fun->cfun.entry, sp); case t_cclosure: return APPLY_closure(narg, fun->cclosure.entry, - fun->cclosure.env, cl_env.stack_top - narg); + fun->cclosure.env, sp); #ifdef CLOS case t_instance: - fun = _ecl_compute_method(narg, fun, cl_env.stack_top - narg); - if (fun == NULL) - return VALUES(0); + switch (fun->instance.isgf) { + case ECL_STANDARD_DISPATCH: + return _ecl_standard_dispatch(frame, fun); + case ECL_USER_DISPATCH: + fun = fun->instance.slots[fun->instance.length - 1]; + default: + FEinvalid_function(fun); + } goto AGAIN; #endif case t_symbol: @@ -108,7 +100,7 @@ cl_apply_from_stack(cl_index narg, cl_object x) fun = SYM_FUN(fun); goto AGAIN; case t_bytecodes: - return ecl_apply_lambda(narg, fun); + return ecl_apply_lambda(frame, fun); default: ERROR: FEinvalid_function(x); @@ -122,15 +114,19 @@ cl_apply_from_stack(cl_index narg, cl_object x) cl_object _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_va_list args) { - cl_index sp; cl_object out, fun = ecl_fdefinition(sym); + struct ecl_stack_frame frame_aux; + cl_object frame; if (fun == OBJNULL) FEerror("Undefined function.", 0); + frame = (cl_object)&frame_aux; + frame->frame.t = t_frame; + frame->frame.narg = narg; if (args[0].sp) - sp = args[0].sp; + frame->frame.sp = args[0].sp; else - sp = cl_stack_push_va_list(args); + frame->frame.sp = cl_stack_push_va_list(args); AGAIN: if (fun == OBJNULL) goto ERROR; @@ -140,7 +136,7 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v if (narg != fun->cfun.narg) FEwrong_num_arguments(fun); out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, - cl_env.stack_top - narg); + cl_env.stack + frame->frame.sp); } else { if (pLK) { si_put_sysprop(sym, @'si::link-from', @@ -151,33 +147,34 @@ _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_object cblock, int narg, cl_v cblock->cblock.links = CONS(sym, cblock->cblock.links); } - out = APPLY(narg, fun->cfun.entry, cl_env.stack + sp); + out = APPLY(narg, fun->cfun.entry, cl_env.stack + frame->frame.sp); } break; #ifdef CLOS - case t_instance: { - fun = _ecl_compute_method(narg, fun, cl_env.stack + sp); - pLK = NULL; - if (fun == NULL) { - out = VALUES(0); - break; + case t_instance: + switch (fun->instance.isgf) { + case ECL_STANDARD_DISPATCH: + return _ecl_standard_dispatch(frame, fun); + case ECL_USER_DISPATCH: + fun = fun->instance.slots[fun->instance.length - 1]; + default: + FEinvalid_function(fun); } goto AGAIN; - } #endif /* CLOS */ case t_cclosure: out = APPLY_closure(narg, fun->cclosure.entry, - fun->cclosure.env, cl_env.stack + sp); + fun->cclosure.env, cl_env.stack + frame->frame.sp); break; case t_bytecodes: - out = ecl_apply_lambda(narg, fun); + out = ecl_apply_lambda(frame, fun); break; default: ERROR: FEinvalid_function(fun); } if (!args[0].sp) - cl_stack_set_index(sp); + ecl_stack_frame_close(frame); return out; } @@ -202,58 +199,64 @@ si_unlink_symbol(cl_object s) } @(defun funcall (function &rest funargs) - cl_index sp; - cl_object fun = function, out; + struct ecl_stack_frame frame_aux; + cl_object frame; + cl_object out; @ - narg--; + frame = (cl_object)&frame_aux; + frame->frame.t = t_frame; + frame->frame.narg = narg-1; if (funargs[0].sp) - sp = funargs[0].sp; + frame->frame.sp = funargs[0].sp; else - sp = cl_stack_push_va_list(funargs); - AGAIN: - if (fun == OBJNULL || fun == Cnil) - FEundefined_function(function); - switch (type_of(fun)) { - case t_cfun: - if (fun->cfun.narg >= 0) { - if (narg != fun->cfun.narg) - FEwrong_num_arguments(fun); - out = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, - cl_env.stack_top - narg); - } else { - out = APPLY(narg, fun->cfun.entry, cl_env.stack + sp); - } - break; - case t_cclosure: - out = APPLY_closure(narg, fun->cclosure.entry, - fun->cclosure.env, cl_env.stack + sp); - break; -#ifdef CLOS - case t_instance: - fun = _ecl_compute_method(narg, fun, cl_env.stack + sp); - if (fun == NULL) { - out = VALUES(0); - break; - } - goto AGAIN; -#endif - case t_symbol: - if (fun->symbol.mflag) - FEundefined_function(fun); - fun = SYM_FUN(fun); - goto AGAIN; - case t_bytecodes: - out = ecl_apply_lambda(narg, fun); - break; - default: - ERROR: - FEinvalid_function(fun); + frame->frame.sp = cl_stack_push_va_list(funargs); + out = ecl_apply_from_stack_frame(frame, function); + if (!funargs[0].sp) { + /* Closing a frame implies popping out all arguments. + * If the arguments had been previously pushed, we must + * avoid this and leave that task to the caller */ + ecl_stack_frame_close(frame); } - if (!funargs[0].sp) - cl_stack_set_index(sp); return out; @) +@(defun apply (fun lastarg &rest args) +@ + if (narg == 2 && type_of(lastarg) == t_frame) { + return ecl_apply_from_stack_frame(lastarg, fun); + } else { + cl_object out; + cl_index i; + struct ecl_stack_frame frame_aux; + const cl_object frame = (cl_object)&frame_aux; + frame->frame.t = t_frame; + frame->frame.narg = frame->frame.sp = 0; + narg -= 2; + for (i = 0; narg; i++,narg--) { + ecl_stack_frame_push(frame, lastarg); + lastarg = cl_va_arg(args); + } + if (type_of(lastarg) == t_frame) { + ecl_stack_frame_reserve(frame, lastarg->frame.narg); + /* This could be replaced with a memcpy() */ + for (i = 0; i < lastarg->frame.narg; i++) { + cl_object o = ecl_stack_frame_elt(lastarg, i); + ecl_stack_frame_elt_set(frame, i, o); + } + } else loop_for_in (lastarg) { + if (i >= CALL_ARGUMENTS_LIMIT) { + ecl_stack_frame_close(frame); + FEprogram_error("CALL-ARGUMENTS-LIMIT exceeded",0); + } + ecl_stack_frame_push(frame, CAR(lastarg)); + i++; + } end_loop_for_in; + out = ecl_apply_from_stack_frame(frame, fun); + ecl_stack_frame_close(frame); + return out; + } +@) + cl_object cl_eval(cl_object form) { diff --git a/src/c/gfun.d b/src/c/gfun.d index 8a3125fb1..fcd66034a 100644 --- a/src/c/gfun.d +++ b/src/c/gfun.d @@ -279,8 +279,10 @@ search_method_hash(cl_object keys, cl_object table) } static cl_object -get_spec_vector(cl_narg narg, cl_object gf, cl_object *args) +get_spec_vector(cl_object frame, cl_object gf) { + cl_object *args = cl_env.stack + frame->frame.sp; + cl_index narg = frame->frame.narg; cl_object spec_how_list = GFUN_SPEC(gf); cl_object vector = cl_env.method_spec_vector; cl_object *argtype = vector->vector.self.t; @@ -307,18 +309,18 @@ get_spec_vector(cl_narg narg, cl_object gf, cl_object *args) } static cl_object -compute_applicable_method(cl_narg narg, cl_object gf, cl_object *args) +compute_applicable_method(cl_object frame, cl_object gf) { /* method not cached */ cl_object methods, arglist, func; int i; - for (i = narg, arglist = Cnil; i-- > 0; ) { - arglist = CONS(args[i], arglist); + for (i = frame->frame.narg, arglist = Cnil; i; ) { + arglist = CONS(ecl_stack_frame_elt(frame, --i), arglist); } methods = funcall(3, @'compute-applicable-methods', gf, arglist); if (methods == Cnil) { func = funcall(3, @'no-applicable-method', gf, arglist); - args[0] = 0; + ecl_stack_frame_elt_set(frame, 0, OBJNULL); return func; } else { return funcall(4, @'clos::compute-effective-method', gf, @@ -326,10 +328,10 @@ compute_applicable_method(cl_narg narg, cl_object gf, cl_object *args) } } -static cl_object -standard_dispatch(cl_narg narg, cl_object gf, cl_object *args) +cl_object +_ecl_standard_dispatch(cl_object frame, cl_object gf) { - cl_object vector; + cl_object func, vector; #ifdef ECL_THREADS /* See whether we have to clear the hash from some generic functions right now. */ if (cl_env.method_hash_clear_list != Cnil) { @@ -343,17 +345,17 @@ standard_dispatch(cl_narg narg, cl_object gf, cl_object *args) THREAD_OP_UNLOCK(); } #endif - vector = get_spec_vector(narg, gf, args); + vector = get_spec_vector(frame, gf); if (vector == OBJNULL) { - return compute_applicable_method(narg, gf, args); + func = compute_applicable_method(frame, gf); } else { cl_object table = cl_env.method_hash; cl_object *e = search_method_hash(vector, table); if (RECORD_KEY(e) != OBJNULL) { - return RECORD_VALUE(e); + func = RECORD_VALUE(e); } else { cl_object keys = cl_copy_seq(vector); - cl_object func = compute_applicable_method(narg, gf, args); + func = compute_applicable_method(frame, gf); if (RECORD_KEY(e) != OBJNULL) { /* The cache might have changed while we * computed applicable methods */ @@ -361,20 +363,13 @@ standard_dispatch(cl_narg narg, cl_object gf, cl_object *args) } RECORD_KEY(e) = keys; RECORD_VALUE(e) = func; - return func; } } -} - -cl_object -_ecl_compute_method(cl_narg narg, cl_object gf, cl_object *args) -{ - switch (gf->instance.isgf) { - case ECL_STANDARD_DISPATCH: - return standard_dispatch(narg, gf, args); - case ECL_USER_DISPATCH: - return gf->instance.slots[gf->instance.length - 1]; - default: - FEinvalid_function(gf); + { + ECL_BUILD_STACK_FRAME(frame1); + ecl_stack_frame_push(frame1, frame); + func = ecl_apply_from_stack_frame(frame1, func); + ecl_stack_frame_close(frame1); + return func; } } diff --git a/src/c/instance.d b/src/c/instance.d index 50245923c..45c716865 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -286,6 +286,8 @@ cl_class_of(cl_object x) t = @'si::code-block'; break; case t_foreign: t = @'si::foreign-data'; break; + case t_frame: + t = @'si::frame'; break; default: ecl_internal_error("not a lisp data object"); } diff --git a/src/c/interpreter.d b/src/c/interpreter.d index 1fd90a3b6..1f8292256 100644 --- a/src/c/interpreter.d +++ b/src/c/interpreter.d @@ -164,6 +164,93 @@ cl_stack_push_list(cl_object list) return n; } +void +ecl_stack_frame_reserve(cl_object f, cl_index size) +{ + cl_index sp = cl_stack_index(); + cl_index n = f->frame.narg; + if (n == 0) { + f->frame.sp = sp; + } else if (sp != f->frame.sp + n) { + ecl_internal_error("Inconsistency in interpreter stack frame"); + } + f->frame.narg = n+size; + cl_stack_insert(sp, size); +} + +void +ecl_stack_frame_push(cl_object f, cl_object o) +{ + cl_index sp = cl_stack_index(); + cl_index n = f->frame.narg; + if (n == 0) { + f->frame.sp = sp; + } else if (sp != f->frame.sp + n) { + ecl_internal_error("Inconsistency in interpreter stack frame"); + } + f->frame.narg = n+1; + cl_stack_push(o); +} + +void +ecl_stack_frame_push_values(cl_object f) +{ + cl_index sp = cl_stack_index(); + cl_index n = f->frame.narg; + if (n == 0) { + f->frame.sp = sp; + } else if (sp != f->frame.sp + n) { + ecl_internal_error("Inconsistency in interpreter stack frame"); + } + f->frame.narg = n+cl_stack_push_values(); +} + +void +ecl_stack_frame_push_va_list(cl_object f, cl_va_list args) +{ + cl_index sp = cl_stack_index(); + cl_index n = f->frame.narg; + if (n == 0) { + f->frame.sp = sp; + } else if (sp != f->frame.sp + n) { + ecl_internal_error("Inconsistency in interpreter stack frame"); + } + f->frame.narg = n + args[0].narg; + cl_stack_push_va_list(args); +} + +cl_object +ecl_stack_frame_pop_values(cl_object f) +{ + cl_stack_pop_values(f->frame.narg); + return VALUES(0); +} + +cl_object +ecl_stack_frame_elt(cl_object f, cl_index ndx) +{ + if (ndx >= f->frame.narg) { + FEtype_error_index(f, ecl_make_unsigned_integer(ndx)); + } + return cl_env.stack[f->frame.sp + ndx]; +} + +void +ecl_stack_frame_elt_set(cl_object f, cl_index ndx, cl_object o) +{ + if (ndx >= f->frame.narg) { + FEtype_error_index(f, ecl_make_unsigned_integer(ndx)); + } + cl_env.stack[f->frame.sp + ndx] = o; +} + +void +ecl_stack_frame_close(cl_object f) +{ + if (f->frame.narg) cl_stack_set_index(f->frame.sp); +} + + /* ------------------------------ LEXICAL ENV. ------------------------------ */ #define bind_var(var, val) \ @@ -323,9 +410,8 @@ lambda_bind(cl_narg narg, cl_object lambda, cl_index sp) } cl_object -ecl_apply_lambda(cl_narg narg, cl_object fun) +ecl_apply_lambda(cl_object frame, cl_object fun) { - cl_index args = cl_stack_index() - narg; cl_object name; bds_ptr old_bds_top; struct ihs_frame ihs; @@ -339,7 +425,7 @@ ecl_apply_lambda(cl_narg narg, cl_object fun) old_bds_top = cl_env.bds_top; /* Establish bindings */ - lambda_bind(narg, fun, args); + lambda_bind(frame->frame.narg, fun, frame->frame.sp); VALUES(0) = Cnil; NVALUES = 0; @@ -369,81 +455,20 @@ search_global(register cl_object s) { * (cl_env.lex_env) needs to be saved. */ static cl_object -interpret_funcall(cl_narg narg, cl_object fun) { +interpret_funcall(cl_narg narg, cl_object fun) +{ cl_object lex_env = cl_env.lex_env; - cl_object *args; - cl_object x; - args = cl_env.stack_top - narg; - if (fun == OBJNULL || fun == Cnil) - goto ERROR; - AGAIN: - switch (type_of(fun)) { - case t_cfun: { - struct ihs_frame ihs; - ihs_push(&ihs, fun->cfun.name); - if (fun->cfun.narg >= 0) { - if (narg != fun->cfun.narg) - FEwrong_num_arguments(fun); - x = APPLY_fixed(narg, (cl_objectfn_fixed)fun->cfun.entry, args); - } else { - x = APPLY(narg, fun->cfun.entry, args); - } - ihs_pop(); - break; - } - case t_cclosure:{ - struct ihs_frame ihs; - ihs_push(&ihs, fun); - x = APPLY_closure(narg, fun->cclosure.entry, fun->cclosure.env, args); - ihs_pop(); - break; - } -#ifdef CLOS - case t_instance: - fun = _ecl_compute_method(narg, fun, args); - if (fun == NULL) { - x = VALUES(0); - break; - } - goto AGAIN; -#endif - case t_bytecodes: - x = ecl_apply_lambda(narg, fun); - break; - case t_symbol: { - cl_object function = SYM_FUN(fun); - if (function == Cnil || fun->symbol.mflag) - FEundefined_function(fun); - fun = function; - goto AGAIN; - } - default: ERROR: - FEinvalid_function(fun); - } + struct ecl_stack_frame frame_aux; + cl_object frame = (cl_object)&frame_aux; + frame->frame.t = t_frame; + frame->frame.narg = narg; + frame->frame.sp = (cl_env.stack_top - cl_env.stack) - narg; + fun = ecl_apply_from_stack_frame(frame, fun); cl_env.lex_env = lex_env; - cl_stack_pop_n(narg); - return x; + ecl_stack_frame_close(frame); + return fun; } -@(defun apply (fun lastarg &rest args) - cl_index i; -@ - narg -= 2; - for (i = 0; narg; i++,narg--) { - cl_stack_push(lastarg); - lastarg = cl_va_arg(args); - } - loop_for_in (lastarg) { - if (i >= CALL_ARGUMENTS_LIMIT) { - cl_stack_pop_n(i); - FEprogram_error("CALL-ARGUMENTS-LIMIT exceeded",0); - } - cl_stack_push(CAR(lastarg)); - i++; - } end_loop_for_in; - returnn(interpret_funcall(i, fun)); -@) - /* -------------------- THE INTERPRETER -------------------- */ static cl_object @@ -1225,6 +1250,7 @@ ecl_interpret(cl_object bytecodes, void *pc) { cl_stack_pop_values(n); break; } + default: FEerror("Internal error: Unknown code ~S", 1, MAKE_FIXNUM(*(vector-1))); diff --git a/src/c/list.d b/src/c/list.d index 15ec2106c..2dd2417e4 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -24,6 +24,10 @@ struct cl_test { cl_object test_function; cl_object item_compared; cl_object key_function; + cl_object frame_key; + struct ecl_stack_frame frame_key_aux; + cl_object frame_test; + struct ecl_stack_frame frame_test_aux; }; static cl_object subst(struct cl_test *t, cl_object new_obj, cl_object tree); @@ -36,17 +40,19 @@ static void nsublis(struct cl_test *t, cl_object alist, cl_object *treep); static bool test_compare(struct cl_test *t, cl_object x) { - cl_object outcome = funcall(3, t->test_function, t->item_compared, - (t->key_c_function)(t, x)); - return (outcome != Cnil); + ecl_stack_frame_elt_set(t->frame_test, 0, t->item_compared); + x = (t->key_c_function)(t, x); + ecl_stack_frame_elt_set(t->frame_test, 1, x); + return ecl_apply_from_stack_frame(t->frame_test, t->test_function) != Cnil; } static bool test_compare_not(struct cl_test *t, cl_object x) { - cl_object outcome = funcall(3, t->test_function, t->item_compared, - (t->key_c_function)(t, x)); - return (outcome == Cnil); + ecl_stack_frame_elt_set(t->frame_test, 0, t->item_compared); + x = (t->key_c_function)(t, x); + ecl_stack_frame_elt_set(t->frame_test, 1, x); + return ecl_apply_from_stack_frame(t->frame_test, t->test_function) == Cnil; } static bool @@ -76,7 +82,8 @@ test_equalp(struct cl_test *t, cl_object x) static cl_object key_function(struct cl_test *t, cl_object x) { - return funcall(2, t->key_function, x); + ecl_stack_frame_elt_set(t->frame_key, 0, x); + return ecl_apply_from_stack_frame(t->frame_key, t->key_function); } static cl_object @@ -86,10 +93,11 @@ key_identity(struct cl_test *t, cl_object x) } static void -setupTEST(struct cl_test *t, cl_object item, cl_object test, - cl_object test_not, cl_object key) +setup_test(struct cl_test *t, cl_object item, cl_object test, + cl_object test_not, cl_object key) { t->item_compared = item; + t->test_function = t->key_function =Cnil; if (test != Cnil) { if (test_not != Cnil) FEerror("Both :TEST and :TEST-NOT are specified.", 0); @@ -117,6 +125,31 @@ setupTEST(struct cl_test *t, cl_object item, cl_object test, } else { t->key_c_function = key_identity; } + if (t->test_function != Cnil) { + t->frame_test = (cl_object)&(t->frame_test_aux); + t->frame_test_aux.t = t_frame; + t->frame_test_aux.narg = 0; + t->frame_test_aux.sp = 0; + ecl_stack_frame_reserve(t->frame_test, 2); + ecl_stack_frame_elt_set(t->frame_test, 0, item); + } + if (t->key_function != Cnil) { + t->frame_key = (cl_object)&(t->frame_key_aux); + t->frame_key_aux.t = t_frame; + t->frame_key_aux.narg = 0; + t->frame_key_aux.sp = 0; + ecl_stack_frame_reserve(t->frame_key, 1); + } +} + +static void close_test(struct cl_test *t) +{ + if (t->key_function != Cnil) { + ecl_stack_frame_close(t->frame_key); + } + if (t->test_function != Cnil) { + ecl_stack_frame_close(t->frame_test); + } } cl_object @@ -290,9 +323,12 @@ BEGIN: @(defun tree_equal (x y &key test test_not) struct cl_test t; + cl_object output; @ - setupTEST(&t, Cnil, test, test_not, Cnil); - @(return (tree_equal(&t, x, y)? Ct : Cnil)) + setup_test(&t, Cnil, test, test_not, Cnil); + output = tree_equal(&t, x, y)? Ct : Cnil; + close_test(&t); + @(return output) @) cl_object @@ -581,9 +617,12 @@ cl_rplacd(cl_object x, cl_object v) @(defun subst (new_obj old_obj tree &key test test_not key) struct cl_test t; + cl_object output; @ - setupTEST(&t, old_obj, test, test_not, key); - @(return subst(&t, new_obj, tree)) + setup_test(&t, old_obj, test, test_not, key); + output = subst(&t, new_obj, tree); + close_test(&t); + @(return output) @) @@ -607,8 +646,9 @@ subst(struct cl_test *t, cl_object new_obj, cl_object tree) @(defun nsubst (new_obj old_obj tree &key test test_not key) struct cl_test t; @ - setupTEST(&t, old_obj, test, test_not, key); + setup_test(&t, old_obj, test, test_not, key); nsubst(&t, new_obj, &tree); + close_test(&t); @(return tree) @) @@ -631,8 +671,9 @@ nsubst(struct cl_test *t, cl_object new_obj, cl_object *treep) @(defun sublis (alist tree &key test test_not key) struct cl_test t; @ - setupTEST(&t, Cnil, test, test_not, key); + setup_test(&t, Cnil, test, test_not, key); tree = sublis(&t, alist, tree); + close_test(&t); @(return tree) @) @@ -664,8 +705,9 @@ sublis(struct cl_test *t, cl_object alist, cl_object tree) @(defun nsublis (alist tree &key test test_not key) struct cl_test t; @ - setupTEST(&t, Cnil, test, test_not, key); + setup_test(&t, Cnil, test, test_not, key); nsublis(&t, alist, &tree); + close_test(&t); @(return tree) @) @@ -697,11 +739,12 @@ nsublis(struct cl_test *t, cl_object alist, cl_object *treep) @(defun member (item list &key test test_not key) struct cl_test t; @ - setupTEST(&t, item, test, test_not, key); + setup_test(&t, item, test, test_not, key); loop_for_in(list) { if (TEST(&t, CAR(list))) break; } end_loop_for_in; + close_test(&t); @(return list) @) @@ -754,11 +797,12 @@ si_member1(cl_object item, cl_object list, cl_object test, cl_object test_not, c if (key != Cnil) item = funcall(2, key, item); - setupTEST(&t, item, test, test_not, key); + setup_test(&t, item, test, test_not, key); loop_for_in(list) { if (TEST(&t, CAR(list))) break; } end_loop_for_in; + close_test(&t); @(return list) } @@ -818,7 +862,7 @@ error: FEerror("The keys ~S and the data ~S are not of the same length", @(defun assoc (item a_list &key test test_not key) struct cl_test t; @ - setupTEST(&t, item, test, test_not, key); + setup_test(&t, item, test, test_not, key); loop_for_in(a_list) { cl_object pair = CAR(a_list); if (Null(pair)) { @@ -830,13 +874,14 @@ error: FEerror("The keys ~S and the data ~S are not of the same length", break; } } end_loop_for_in; + close_test(&t); @(return a_list) @) @(defun rassoc (item a_list &key test test_not key) struct cl_test t; @ - setupTEST(&t, item, test, test_not, key); + setup_test(&t, item, test, test_not, key); loop_for_in(a_list) { cl_object pair = CAR(a_list); if (Null(pair)) { @@ -848,6 +893,7 @@ error: FEerror("The keys ~S and the data ~S are not of the same length", break; } } end_loop_for_in; + close_test(&t); @(return a_list) @) diff --git a/src/c/mapfun.d b/src/c/mapfun.d index 9ac886675..781ae2bba 100644 --- a/src/c/mapfun.d +++ b/src/c/mapfun.d @@ -16,150 +16,163 @@ #include +#include -static cl_index -prepare_map(cl_va_list lists, cl_index *cdrs_sp) +static void +prepare_map(cl_va_list lists, cl_object cdrs_frame, cl_object cars_frame) { - cl_index i, nlist = lists[0].narg; - - *cdrs_sp = cl_stack_index(); - if (nlist == 0) + cl_index i; + ecl_stack_frame_push_va_list(cdrs_frame, lists); + if (cdrs_frame->frame.narg == 0) { FEprogram_error("MAP*: Too few arguments.", 0); - cl_stack_push_va_list(lists); - for (i = 0; iframe.narg); + for (i = 0; i < cars_frame->frame.narg; i++) { + ecl_stack_frame_elt_set(cars_frame, i, Cnil); + } } @(defun mapcar (fun &rest lists) cl_object res, *val = &res; - cl_index i, nlist, cdrs_sp; -@ - nlist = prepare_map(lists, &cdrs_sp); + cl_index i; +@ { + ECL_BUILD_STACK_FRAME(cars_frame); + ECL_BUILD_STACK_FRAME(cdrs_frame); + prepare_map(lists, cdrs_frame, cars_frame); res = Cnil; while (TRUE) { - /* INV: The stack does not grow here. */ - cl_object *cdrs = cl_env.stack + cdrs_sp; - cl_object *cars = cdrs + nlist; - for (i = 0; i < nlist; i++) { - if (ecl_endp(cdrs[i])) { - cl_stack_set_index(cdrs_sp); + cl_index i; + for (i = 0; i < cdrs_frame->frame.narg; i++) { + cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i); + if (ecl_endp(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); @(return res) } - cars[i] = CAR(cdrs[i]); - cdrs[i] = CDR(cdrs[i]); + ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr)); + ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = CONS(cl_apply_from_stack(nlist, fun), Cnil); + *val = CONS(ecl_apply_from_stack_frame(cars_frame, fun), Cnil); val = &CDR(*val); } -@) +} @) @(defun maplist (fun &rest lists) cl_object res, *val = &res; - cl_index i, nlist, cdrs_sp; -@ - nlist = prepare_map(lists, &cdrs_sp); +@ { + ECL_BUILD_STACK_FRAME(cars_frame); + ECL_BUILD_STACK_FRAME(cdrs_frame); + prepare_map(lists, cdrs_frame, cars_frame); res = Cnil; while (TRUE) { - cl_object *cdrs = cl_env.stack + cdrs_sp; - cl_object *cars = cdrs + nlist; - for (i = 0; i < nlist; i++) { - if (ecl_endp(cdrs[i])) { - cl_stack_set_index(cdrs_sp); + cl_index i; + for (i = 0; i < cdrs_frame->frame.narg; i++) { + cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i); + if (ecl_endp(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); @(return res) } - cars[i] = cdrs[i]; - cdrs[i] = CDR(cdrs[i]); + ecl_stack_frame_elt_set(cars_frame, i, cdr); + ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = CONS(cl_apply_from_stack(nlist, fun), Cnil); + *val = CONS(ecl_apply_from_stack_frame(cars_frame, fun), Cnil); val = &CDR(*val); } -@) +} @) @(defun mapc (fun &rest lists) cl_object onelist; - cl_index i, nlist, cdrs_sp; -@ - nlist = prepare_map(lists, &cdrs_sp); - onelist = cl_env.stack[cdrs_sp]; +@ { + ECL_BUILD_STACK_FRAME(cars_frame); + ECL_BUILD_STACK_FRAME(cdrs_frame); + prepare_map(lists, cdrs_frame, cars_frame); + onelist = ecl_stack_frame_elt(cdrs_frame, 0); while (TRUE) { - cl_object *cdrs = cl_env.stack + cdrs_sp; - cl_object *cars = cdrs + nlist; - for (i = 0; i < nlist; i++) { - if (ecl_endp(cdrs[i])) { - cl_stack_set_index(cdrs_sp); + cl_index i; + for (i = 0; i < cdrs_frame->frame.narg; i++) { + cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i); + if (ecl_endp(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); @(return onelist) } - cars[i] = CAR(cdrs[i]); - cdrs[i] = CDR(cdrs[i]); + ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr)); + ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - cl_apply_from_stack(nlist, fun); + ecl_apply_from_stack_frame(cars_frame, fun); } -@) +} @) @(defun mapl (fun &rest lists) cl_object onelist; - cl_index i, nlist, cdrs_sp; -@ - nlist = prepare_map(lists, &cdrs_sp); - onelist = cl_env.stack[cdrs_sp]; +@ { + ECL_BUILD_STACK_FRAME(cars_frame); + ECL_BUILD_STACK_FRAME(cdrs_frame); + prepare_map(lists, cdrs_frame, cars_frame); + onelist = ecl_stack_frame_elt(cdrs_frame, 0); while (TRUE) { - cl_object *cdrs = cl_env.stack + cdrs_sp; - cl_object *cars = cdrs + nlist; - for (i = 0; i < nlist; i++) { - if (ecl_endp(cdrs[i])) { - cl_stack_set_index(cdrs_sp); + cl_index i; + for (i = 0; i < cdrs_frame->frame.narg; i++) { + cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i); + if (ecl_endp(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); @(return onelist) } - cars[i] = cdrs[i]; - cdrs[i] = CDR(cdrs[i]); + ecl_stack_frame_elt_set(cars_frame, i, cdr); + ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - cl_apply_from_stack(nlist, fun); + ecl_apply_from_stack_frame(cars_frame, fun); } -@) +} @) @(defun mapcan (fun &rest lists) cl_object res, *val = &res; - cl_index i, nlist, cdrs_sp; -@ - nlist = prepare_map(lists, &cdrs_sp); +@ { + ECL_BUILD_STACK_FRAME(cars_frame); + ECL_BUILD_STACK_FRAME(cdrs_frame); + prepare_map(lists, cdrs_frame, cars_frame); res = Cnil; while (TRUE) { - cl_object *cdrs = cl_env.stack + cdrs_sp; - cl_object *cars = cdrs + nlist; - for (i = 0; i < nlist; i++) { - if (ecl_endp(cdrs[i])) { - cl_stack_set_index(cdrs_sp); + cl_index i; + for (i = 0; i < cdrs_frame->frame.narg; i++) { + cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i); + if (ecl_endp(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); @(return res) } - cars[i] = CAR(cdrs[i]); - cdrs[i] = CDR(cdrs[i]); + ecl_stack_frame_elt_set(cars_frame, i, CAR(cdr)); + ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = cl_apply_from_stack(nlist, fun); + *val = ecl_apply_from_stack_frame(cars_frame, fun); while (CONSP(*val)) val = &CDR(*val); } -@) +} @) @(defun mapcon (fun &rest lists) cl_object res, *val = &res; - cl_index i, nlist, cdrs_sp; -@ - nlist = prepare_map(lists, &cdrs_sp); +@ { + ECL_BUILD_STACK_FRAME(cars_frame); + ECL_BUILD_STACK_FRAME(cdrs_frame); + prepare_map(lists, cdrs_frame, cars_frame); res = Cnil; while (TRUE) { - cl_object *cdrs = cl_env.stack + cdrs_sp; - cl_object *cars = cdrs + nlist; - for (i = 0; i < nlist; i++) { - if (ecl_endp(cdrs[i])) { - cl_stack_set_index(cdrs_sp); + cl_index i; + for (i = 0; i < cdrs_frame->frame.narg; i++) { + cl_object cdr = ecl_stack_frame_elt(cdrs_frame, i); + if (ecl_endp(cdr)) { + ecl_stack_frame_close(cars_frame); + ecl_stack_frame_close(cdrs_frame); @(return res) } - cars[i] = cdrs[i]; - cdrs[i] = CDR(cdrs[i]); + ecl_stack_frame_elt_set(cars_frame, i, cdr); + ecl_stack_frame_elt_set(cdrs_frame, i, CDR(cdr)); } - *val = cl_apply_from_stack(nlist, fun); + *val = ecl_apply_from_stack_frame(cars_frame, fun); while (CONSP(*val)) val = &CDR(*val); } -@) +} @) diff --git a/src/c/print.d b/src/c/print.d index 71915da75..59723744f 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -922,7 +922,7 @@ write_array(bool vector, cl_object x, cl_object stream) if (readably) { write_ch('A', stream); write_ch('(', stream); - si_write_object_recursive(ecl_elttype_to_symbol(x->array.elttype), stream); + si_write_object_recursive(ecl_elttype_to_symbol(ecl_array_elttype(x)), stream); write_ch(INDENT, stream); if (n > 0) { write_ch('(', stream); @@ -1409,8 +1409,14 @@ si_write_ugly_object(cl_object x, cl_object stream) break; case t_random: - write_str("#$", stream); - write_array(1, x->random.value, stream); + if (ecl_print_readably()) { + write_str("#$", stream); + write_array(1, x->random.value, stream); + } else { + write_str("#random.value, stream); + write_str("#>", stream); + } break; #ifndef CLOS @@ -1520,6 +1526,14 @@ si_write_ugly_object(cl_object x, cl_object stream) write_addr((cl_object)x->foreign.data, stream); write_ch('>', stream); break; + case t_frame: + if (ecl_print_readably()) FEprint_not_readable(x); + write_str("#frame.narg, stream); + write_ch(' ', stream); + write_decimal(x->frame.sp, stream); + write_ch('>', stream); + break; #ifdef ECL_THREADS case t_process: if (ecl_print_readably()) FEprint_not_readable(x); diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 121f69d36..8216fc5cb 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1678,6 +1678,9 @@ cl_symbols[] = { {SYS_ "CLEAR-GFUN-HASH", SI_ORDINARY, si_clear_gfun_hash, 1, OBJNULL}, #endif +{SYS_ "FRAME", SI_ORDINARY, NULL, -1, OBJNULL}, +{SYS_ "APPLY-FROM-STACK-FRAME", SI_ORDINARY, si_apply_from_stack_frame, 2, OBJNULL}, + /* Tag for end of list */ {NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index ab39dcef2..be4f36c5e 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1678,6 +1678,9 @@ cl_symbols[] = { {SYS_ "CLEAR-GFUN-HASH","si_clear_gfun_hash"}, #endif +{SYS_ "FRAME",NULL}, +{SYS_ "APPLY-FROM-STACK-FRAME","si_apply_from_stack_frame"}, + /* Tag for end of list */ {NULL,NULL}}; diff --git a/src/c/typespec.d b/src/c/typespec.d index 47c3a6242..933b6c3e3 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -186,6 +186,8 @@ ecl_type_to_symbol(cl_type t) return @'si::code-block'; case t_foreign: return @'si::foreign-data'; + case t_frame: + return @'si::frame'; default: ecl_internal_error("not a lisp data object"); } diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp index f0c362c03..27784a586 100644 --- a/src/clos/builtin.lsp +++ b/src/clos/builtin.lsp @@ -89,6 +89,7 @@ (readtable) (si::code-block) (si::foreign-data) + (si::frame) #+threads (mp::process) #+threads (mp::lock))) diff --git a/src/clos/combin.lsp b/src/clos/combin.lsp index b6ee250ac..e52e2d78b 100644 --- a/src/clos/combin.lsp +++ b/src/clos/combin.lsp @@ -47,26 +47,33 @@ ;;; 5) Ordinary forms are turned into lambda forms, much like ;;; what happens with the content of MAKE-METHOD. ;;; -(defun effective-method-function (form) - (if (atom form) - (cond ((method-p form) - (method-function form)) - ((functionp form) - form) - (t - (error "Malformed effective method form:~%~A" form))) - (case (first form) - (CALL-METHOD +(defun effective-method-function (form &optional top-level) + (cond ((functionp form) + form) + ((method-p form) + (wrapped-method-function (method-function form))) + ((atom form) + (error "Malformed effective method form:~%~A" form)) + ((and (not top-level) (eq (first form) 'MAKE-METHOD)) + (coerce `(lambda (.combined-method-args. *next-methods*) + (declare (special .combined-method-args. *next-methods*)) + ,(second form)) + 'function)) + ((and top-level (eq (first form) 'CALL-METHOD)) (combine-method-functions (effective-method-function (second form)) (mapcar #'effective-method-function (third form)))) - (MAKE-METHOD - (setq form (second form)) - (coerce `(lambda (&rest .combined-method-args.) ,form) + (top-level + (coerce `(lambda (.combined-method-args.) + ,form) 'function)) (t - (coerce `(lambda (&rest .combined-method-args.) ,form) - 'function))))) + (error "Malformed effective method form:~%~A" form)))) + +(defun wrapped-method-function (method-function) + #'(lambda (.combined-method-args. *next-methods*) + (declare (special .combined-method-args. *next-methods*)) + (apply method-function .combined-method-args.))) ;;; ;;; This function is a combinator of effective methods. It creates a @@ -76,17 +83,30 @@ ;;; (defun combine-method-functions (method rest-methods) (declare (si::c-local)) - #'(lambda (&rest .combined-method-args.) - (let ((*next-methods* rest-methods)) - (declare (special *next-methods*)) - (apply method .combined-method-args.)))) + #'(lambda (.combined-method-args.) + (funcall method .combined-method-args. rest-methods))) (defmacro call-method (method rest-methods) - (setq method (effective-method-function method) - rest-methods (mapcar #'effective-method-function rest-methods)) - `(let ((*next-methods* ,rest-methods)) - (declare (special *next-methods*)) - (apply ,method .combined-method-args.))) + `(funcall ,(effective-method-function method) + .combined-method-args. + ',(mapcar #'effective-method-function rest-methods))) + +(defun call-next-method (&rest args) + (unless *next-methods* + (error "No next method.")) + (funcall (car *next-methods*) (or args .combined-method-args.) (rest *next-methods*))) + +(defun next-method-p () + *next-methods*) + +(define-compiler-macro call-next-method (&rest args) + (print 'call-next-method) + `(if *next-methods* + (funcall (car *next-methods*) ,(if args `(list ,@args) '.combined-method-args.) + (rest *next-methods*)) + (error "No next method."))) + +(define-compiler-macro next-method-p () clos::*next-methods*) (defun error-qualifier (m qualifier) (declare (si::c-local)) @@ -97,19 +117,15 @@ (defun standard-main-effective-method (before primary after) (declare (si::c-local)) - #'(lambda (&rest .combined-method-args.) - (let ((*next-methods* nil)) - (declare (special *next-methods*)) - (dolist (i before) - (apply i .combined-method-args.)) - (setf *next-methods* (rest primary)) - (if after - (multiple-value-prog1 - (apply (first primary) .combined-method-args.) - (setf *next-methods* nil) - (dolist (i after) - (apply i .combined-method-args.))) - (apply (first primary) .combined-method-args.))))) + #'(lambda (.combined-method-args.) + (dolist (i before) + (funcall i .combined-method-args. nil)) + (if after + (multiple-value-prog1 + (funcall (first primary) .combined-method-args. (rest primary)) + (dolist (i after) + (funcall i .combined-method-args. nil))) + (funcall (first primary) .combined-method-args. (rest primary))))) (defun standard-compute-effective-method (gf methods) (declare (si::c-local)) @@ -119,7 +135,7 @@ (around ())) (dolist (m methods) (let* ((qualifiers (method-qualifiers m)) - (f (method-function m))) + (f (wrapped-method-function (method-function m)))) (cond ((null qualifiers) (push f primary)) ((rest qualifiers) (error-qualifier m qualifiers)) ((eq (setq qualifiers (first qualifiers)) :BEFORE) @@ -256,7 +272,7 @@ "Method qualifiers ~S are not allowed in the method~ combination ~S." .method-qualifiers. ,name))))) ,@group-after - (effective-method-function ,@body)))) + (effective-method-function ,@body t)))) ))) (defmacro define-method-combination (name &body body) diff --git a/src/clos/method.lsp b/src/clos/method.lsp index d23ca25ad..b7c54c8f8 100644 --- a/src/clos/method.lsp +++ b/src/clos/method.lsp @@ -98,223 +98,84 @@ ,@(and class-declarations `((declare ,@class-declarations))) ,@real-body)) - (original-args ()) - (applyp nil) ; flag indicating whether or not the - ; method takes &mumble arguments. If - ; it does, it means call-next-method - ; without arguments must be APPLY'd - ; to original-args. If this gets set - ; true, save-original-args is set so - ; as well (aux-bindings ()) ; Suffice to say that &aux is one of ; damndest things to have put in a ; language. (plist ())) - (multiple-value-bind (walked-lambda call-next-method-p - save-original-args next-method-p-p) + (multiple-value-bind (call-next-method-p next-method-p-p in-closure-p) (walk-method-lambda method-lambda required-parameters env) - ;; Scan the lambda list to determine whether this method - ;; takes &mumble arguments. If it does, we set applyp and - ;; save-original-args true. - ;; - ;; This is also the place where we construct the original - ;; arguments lambda list if there has to be one. - (dolist (p lambda-list) - (if (member p '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX) - :test #'eq) ; cant use lambda-list-keywords - (if (eq p '&aux) - (progn - (setq aux-bindings (cdr (member '&AUX lambda-list - :test #'eq))) - (return nil)) - (progn - (setq applyp t - save-original-args t) - (push '&REST original-args) - (push (make-symbol "AMPERSAND-ARGS") original-args) - (return nil))) - (push (make-symbol (symbol-name p)) original-args))) - (setq original-args (when save-original-args - (nreverse original-args))) + (when (or call-next-method-p next-method-p-p) + (setf plist '(:needs-next-method-p t))) - (multiple-value-bind (walked-declarations walked-lambda-body) - (sys::find-declarations (cdddr walked-lambda) t) - (declare (ignore ignore)) + (when in-closure-p + (setf plist '(:needs-next-method-p FUNCTION)) + (setf real-body + `((let* ((.combined-method-args. + (if (listp .combined-method-args.) + .combined-method-args. + (apply #'list .combined-method-args.))) + (.next-methods. *next-methods*)) + (flet ((call-next-method (&rest args) + (unless .next-methods. + (error "No next method")) + (funcall (car .next-methods.) + (or args .combined-method-args.) + (rest .next-methods.))) + (next-method-p () + .next-methods.)) + ,@real-body))))) + (values + `(ext::lambda-block ,generic-function-name + ,lambda-list + ,@(and class-declarations `((declare ,@class-declarations))) + ,@real-body) + documentation + plist))))) - (when (or next-method-p-p call-next-method-p) - (setq plist (list* :needs-next-methods-p 'T plist))) - - (values - (let ((walked-lambda `(ext::lambda-block ,(second walked-lambda) - ,lambda-list - ,@walked-declarations - ,.walked-lambda-body))) - (if (or call-next-method-p next-method-p-p) - `(function ,(add-lexical-functions-to-method-lambda - walked-declarations - walked-lambda-body - generic-function-name - walked-lambda - original-args - lambda-list - save-original-args - applyp - aux-bindings - call-next-method-p - next-method-p-p)) - `(function ,walked-lambda))) - documentation - plist)))))) +(defun environment-contains-closure (env) + ;; + ;; As explained in compiler.d (make_lambda()), we use a symbol with name + ;; "FUNCTION" to mark the beginning of a function. If we find that symbol + ;; twice, it is quite likely that this form will end up in a closure. + ;; + (flet ((function-boundary (s) + (and (consp s) + (symbolp (setf s (first s))) + (null (symbol-package s)) + (equal (symbol-name s) "FUNCTION")))) + (> (count-if #'function-boundary (car env)) 1))) (defun walk-method-lambda (method-lambda required-parameters env) (declare (si::c-local)) (let ((call-next-method-p nil) (next-method-p-p nil) - (save-original-args-p nil)) + (in-closure-p nil)) (flet ((code-walker (form env) (unless (atom form) (let ((name (first form))) (case name (CALL-NEXT-METHOD (setf call-next-method-p - (or call-next-method-p T)) - (unless (rest form) - (setf save-original-args-p t))) + (or call-next-method-p T) + in-closure-p + (or in-closure-p (environment-contains-closure env)))) (NEXT-METHOD-P - (setf next-method-p-p t)) + (setf next-method-p-p t + in-closure-p (or in-closure-p (environment-contains-closure env)))) (FUNCTION (when (eq (second form) 'CALL-NEXT-METHOD) - (setf save-original-args-p t + (setf in-closure-p t call-next-method-p 'FUNCTION)) (when (eq (second form) 'NEXT-METHOD-P) - (setf next-method-p-p 'FUNCTION)))))) + (setf next-method-p-p 'FUNCTION + in-closure-p t)))))) form)) (let ((si::*code-walker* #'code-walker)) (coerce method-lambda 'function))) - (values method-lambda call-next-method-p - save-original-args-p - next-method-p-p))) - -(defun add-lexical-functions-to-method-lambda (walked-declarations - walked-lambda-body - generic-function-name - walked-lambda - original-args - lambda-list - save-original-args - applyp - aux-bindings - call-next-method-p - next-method-p-p) - (declare (si::c-local)) - ;; - ;; WARNING: these &rest/apply combinations produce useless garbage. Beppe - ;; - (cond ((and (null save-original-args) - (null applyp)) - ;; - ;; We don't have to save the original arguments. In addition, - ;; this method doesn't take any &mumble arguments (this means - ;; that there is no way the lexical functions can be used inside - ;; of the default value form for an &mumble argument). - ;; - ;; We can expand this into a simple lambda expression with an - ;; FLET to define the lexical functions. - ;; - `(ext::lambda-block ,generic-function-name ,lambda-list - ,@walked-declarations - (declare (special *next-methods*)) - (let* ((.next-method. (car *next-methods*)) - (*next-methods* (cdr *next-methods*))) - (declare (special *next-methods*)) - (flet (,@(and call-next-method-p - '((CALL-NEXT-METHOD (&REST CNM-ARGS) - ;; (declare (static-extent cnm-args)) - (IF .NEXT-METHOD. - (APPLY .NEXT-METHOD. CNM-ARGS) - (ERROR "No next method."))))) - ,@(and next-method-p-p - '((NEXT-METHOD-P () - (NOT (NULL .NEXT-METHOD.)))))) - ,@walked-lambda-body))) - ;; Assuming that we can determine statically which is the next method, - ;; we could use this solution. Compute-effective-method can set - ;; the value of .next-method. within each closure at the appropriate - ;; value. Same thing for next case. Beppe - ;; `(let (.next-method.) - ;; (lambda ,lambda-list - ;; ,@walked-declarations - ;; (flet (,@(and call-next-method-p - ;; '((CALL-NEXT-METHOD (&REST CNM-ARGS) - ;; ;; (declare (static-extent cnm-args)) - ;; (IF .NEXT-METHOD. - ;; (APPLY .NEXT-METHOD. CNM-ARGS) - ;; (ERROR "No next method."))))) - ;; ,@(and next-method-p-p - ;; '((NEXT-METHOD-P () - ;; (NOT (NULL .NEXT-METHOD.)))))) - ;; ,@walked-lambda-body))) - ) - ((null applyp) - ;; - ;; This method doesn't accept any &mumble arguments. But we - ;; do have to save the original arguments (this is because - ;; call-next-method is being called with no arguments). - ;; Have to be careful though, there may be multiple calls to - ;; call-next-method, all we know is that at least one of them - ;; is with no arguments. - ;; - `(ext::lambda-block ,generic-function-name ,original-args - (declare (special *next-methods*)) - (let* ((.next-method. (car *next-methods*)) - (*next-methods* (cdr *next-methods*))) - (declare (special *next-methods*)) - (flet (,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - ;; (declare (static-extent cnm-args)) - (if .next-method. - (if cnm-args - (apply .next-method. cnm-args) - (funcall .next-method. ,@original-args)) - (error "No next method."))))) - ,@(and next-method-p-p - '((NEXT-METHOD-P () - (NOT (NULL .NEXT-METHOD.)))))) - (let* (,@(mapcar #'list - (subseq lambda-list 0 - (position '&AUX lambda-list)) - original-args) - ,@aux-bindings) - ,@walked-declarations - ,@walked-lambda-body))))) - (t - ;; - ;; This is the fully general case. - ;; We must allow for the lexical functions being used inside - ;; the default value forms of &mumble arguments, and if must - ;; allow for call-next-method being called with no arguments. - ;; - `(lambda ,original-args - (declare (special *next-methods*)) - (let* ((.next-method. (car *next-methods*)) - (*next-methods* (cdr *next-methods*))) - (declare (special *next-methods*)) - (flet (,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - ;; (declare (static-extent cnm-args)) - (if .next-method. - (if cnm-args - (apply .next-method. cnm-args) - (apply .next-method. - ,@(remove '&REST original-args))) - (error "No next method."))))) - ,@(and next-method-p-p - '((NEXT-METHOD-P () - (NOT (NULL .NEXT-METHOD.)))))) - (apply (function ,walked-lambda) - ,@(remove '&REST original-args)))))))) - + (values call-next-method-p + next-method-p-p + in-closure-p))) ;;; ---------------------------------------------------------------------- ;;; parsing diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 295077501..6f78722c7 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -25,9 +25,10 @@ (let ((l (length arguments))) (if (<= l si::c-arguments-limit) (make-c1form* 'FUNCALL :args (c1expr fun) (c1args* arguments)) - (c1expr `(with-stack + (let ((frame (gensym))) + (c1expr `(with-stack ,frame ,@(loop for i in arguments collect `(stack-push ,i)) - (apply-from-stack ,l ,fim)))))) + (si::apply-from-stack-frame ,frame ,fim))))))) (defun c1funcall (args) (check-args-number 'FUNCALL args 1) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 24d4a3228..e78ecfee8 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -87,9 +87,10 @@ (let ((l (length args))) (when (> l si::c-arguments-limit) (return-from c1call-local - (c1expr `(with-stack - ,@(loop for i in args collect `(stack-push ,i)) - (apply-from-stack ,l #',fname)))))) + (let ((frame (gensym))) + (c1expr `(with-stack ,frame + ,@(loop for i in args collect `(stack-push ,i)) + (si::apply-from-stack-frame ,frame #',fname))))))) (let* ((forms (c1args* args)) (lambda-form (fun-lambda fun)) (return-type (or (get-local-return-type fun) 'T)) @@ -111,9 +112,10 @@ (defun c1call-global (fname args) (let ((l (length args))) (if (> l si::c-arguments-limit) - (c1expr `(with-stack - ,@(loop for i in args collect `(stack-push ,i)) - (apply-from-stack ,l #',fname))) + (c1expr (let ((frame (gensym))) + `(with-stack ,frame + ,@(loop for i in args collect `(stack-push ,frame ,i)) + (si::apply-from-stack-frame ,frame #',fname)))) (let* ((forms (c1args* args)) (return-type (propagate-types fname forms args))) (make-c1form* 'CALL-GLOBAL diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index aca16582e..18bd8b409 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -14,10 +14,12 @@ (in-package "COMPILER") -(defun unwind-bds (bds-lcl bds-bind stack-sp ihs-p) +(defun unwind-bds (bds-lcl bds-bind stack-frame ihs-p) (declare (fixnum bds-bind)) - (when stack-sp - (wt-nl "cl_stack_set_index(" stack-sp ");")) + (when stack-frame + (if (stringp stack-frame) + (wt-nl "ecl_stack_frame_close(" stack-frame ");") + (wt-nl "cl_stack_set_index(" stack-frame ");"))) (when bds-lcl (wt-nl "bds_unwind(" bds-lcl ");")) (if (< bds-bind 4) @@ -26,7 +28,7 @@ (when ihs-p (wt-nl "ihs_pop();"))) -(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil) (ihs-p nil)) +(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) (declare (fixnum bds-bind)) (when (consp *destination*) (case (car *destination*) @@ -41,7 +43,7 @@ (cond ((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n) (cond ((eq (car ue) 'STACK) - (setf stack-sp (second ue))) + (setf stack-frame (second ue))) ((eq (car ue) 'LCL) (setq bds-lcl ue bds-bind 0)) ((eq ue *exit*) @@ -49,8 +51,8 @@ (cond ((and (consp *destination*) (or (eq (car *destination*) 'JUMP-TRUE) (eq (car *destination*) 'JUMP-FALSE))) - (unwind-bds bds-lcl bds-bind stack-sp ihs-p)) - ((not (or bds-lcl (plusp bds-bind) stack-sp)) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p)) + ((not (or bds-lcl (plusp bds-bind) stack-frame)) (set-loc loc)) ;; Save the value if LOC may possibly refer ;; to special binding. @@ -60,11 +62,11 @@ (temp (make-temp-var))) (let ((*destination* temp)) (set-loc loc)) ; temp <- loc - (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (set-loc temp))) ; *destination* <- temp (t (set-loc loc) - (unwind-bds bds-lcl bds-bind stack-sp ihs-p))) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p))) (when jump-p (wt-nl) (wt-go *exit*)) (return)) (t (setq jump-p t)))) @@ -78,16 +80,16 @@ ;; *destination* must be either RETURN or TRASH. (cond ((eq loc 'VALUES) ;; from multiple-value-prog1 or values - (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (wt-nl "return VALUES(0);")) ((eq loc 'RETURN) ;; from multiple-value-prog1 or values - (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (wt-nl "return value0;")) (t (let* ((*destination* 'RETURN)) (set-loc loc)) - (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (wt-nl "return value0;"))) (return)) ((RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT @@ -105,7 +107,7 @@ (if (or bds-lcl (plusp bds-bind)) (let ((lcl (make-lcl-var :type (second loc)))) (wt-nl "{cl_fixnum " lcl "= " loc ";") - (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (wt-nl "return(" lcl ");}")) (progn (wt-nl "return(" loc ");"))) @@ -121,22 +123,22 @@ ;;; Never reached ) -(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil) (ihs-p nil)) +(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-frame nil) (ihs-p nil)) (declare (fixnum bds-bind)) (dolist (ue *unwind-exit* (baboon)) (cond ((consp ue) (cond ((eq ue exit) - (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (return)) ((eq (first ue) 'STACK) - (setf stack-sp (second ue))))) + (setf stack-frame (second ue))))) ((numberp ue) (setq bds-lcl ue bds-bind 0)) ((eq ue 'BDS-BIND) (incf bds-bind)) ((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT)) (if (eq exit ue) - (progn (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (return)) (baboon)) ;;; Never reached @@ -144,7 +146,7 @@ ((eq ue 'FRAME) (wt-nl "frs_pop();")) ((eq ue 'TAIL-RECURSION-MARK) (if (eq exit 'TAIL-RECURSION-MARK) - (progn (unwind-bds bds-lcl bds-bind stack-sp ihs-p) + (progn (unwind-bds bds-lcl bds-bind stack-frame ihs-p) (return)) (baboon)) ;;; Never reached diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index cbde3047d..f4611d804 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -31,22 +31,20 @@ (t (c1expr (let ((function (gensym)) - (nargs (gensym))) - `(with-stack - (let* ((,function ,(first args)) - (,nargs (+ ,@(loop for i in (rest args) - collect `(stack-push-values ,i))))) - (declare (fixnum ,nargs)) - (apply-from-stack ,nargs ,function)))))))) + (frame (gensym))) + `(with-stack ,frame + (let* ((,function ,(first args))) + ,@(loop for i in (rest args) + collect `(stack-push-values ,frame ,i)) + (si::apply-from-stack-frame ,frame ,function)))))))) (defun c1multiple-value-prog1 (args) (check-args-number 'MULTIPLE-VALUE-PROG1 args 1) - (c1expr (let ((l (gensym))) - `(with-stack - (let ((,l (stack-push-values ,(first args)))) - (declare (fixnum ,l)) - ,@(rest args) - (stack-pop ,l)))))) + (c1expr (let ((frame (gensym))) + `(with-stack ,frame + (stack-push-values ,frame ,(first args)) + ,@(rest args) + (stack-pop ,frame))))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/src/cmp/cmpstack.lsp b/src/cmp/cmpstack.lsp index 9c0c19750..6863d36ad 100644 --- a/src/cmp/cmpstack.lsp +++ b/src/cmp/cmpstack.lsp @@ -23,32 +23,43 @@ (in-package "COMPILER") (defun c1with-stack (forms) - (let ((body (c1expr `(progn ,@forms)))) - (make-c1form* 'WITH-STACK :type (c1form-type body) - :args body))) + (let* ((var (pop forms)) + (body (c1expr `(let ((,var (innermost-stack-frame))) ,@forms)))) + (make-c1form* 'WITH-STACK + :type (c1form-type body) + :args body))) + +(defvar +ecl-stack-frame-variable+ "_ecl_inner_frame") (defun c2with-stack (body) (let* ((new-destination (tmp-destination *destination*)) - (*temp* *temp*) - (sp (make-lcl-var :rep-type :cl-index))) - (wt-nl "{cl_index " sp "=cl_stack_index();") + (*temp* *temp*)) + (wt-nl "{ struct ecl_stack_frame _ecl_inner_frame_aux;") + (wt-nl *volatile* "cl_object _ecl_inner_frame = (_ecl_inner_frame_aux.narg=0,_ecl_inner_frame_aux.sp=0,_ecl_inner_frame_aux.t=t_frame,(cl_object)&_ecl_inner_frame_aux);") (let* ((*destination* new-destination) - (*unwind-exit* `((STACK ,sp) ,@*unwind-exit*))) + (*unwind-exit* `((STACK ,+ecl-stack-frame-variable+) ,@*unwind-exit*))) (c2expr* body)) - (wt-nl "cl_stack_set_index(" sp ");}") + (wt-nl "ecl_stack_frame_close(_ecl_inner_frame);}") (unwind-exit new-destination))) +(defun c1innermost-stack-frame (args) + (c1expr `(c-inline () () :object ,+ecl-stack-frame-variable+ + :one-liner t :side-effects nil))) + (defun c1stack-push (args) (c1expr `(progn - (c-inline ,args (t) :void "cl_stack_push(#0)" + (c-inline ,args (t t) :void "ecl_stack_frame_push(#0,#1)" :one-liner t :side-effects t) 1))) (defun c1stack-push-values (args) - (make-c1form* 'STACK-PUSH-VALUES :type 'fixnum - :args (c1expr (first args)) - (c1expr `(c-inline () () fixnum "cl_stack_push_values()" - :one-liner t :side-effects t)))) + (let ((frame-var (pop args)) + (form (pop args))) + (make-c1form* 'STACK-PUSH-VALUES :type '(VALUES) + :args + (c1expr form) + (c1expr `(c-inline (,frame-var) (t) :void "ecl_stack_frame_push_values(#0)" + :one-liner t :side-effects t))))) (defun c2stack-push-values (form push-statement) (let ((*destination* 'VALUES)) @@ -56,26 +67,20 @@ (c2expr push-statement)) (defun c1stack-pop (args) - (let ((action (c1expr `(c-inline ,args (fixnum) :void - "cl_stack_pop_values(#0)" - :one-liner t - :side-effects t)))) - (make-c1form* 'STACK-POP :type t :args action))) + (c1expr `(c-inline ,args (t) (values &rest t) + "VALUES(0)=ecl_stack_frame_pop_values(#0);" + :one-liner nil :side-effects t))) -(defun c2stack-pop (action) - (let ((*destination* 'TRASH)) - (c2expr* action)) - (unwind-exit 'VALUES)) - -(defun c1apply-from-stack (args) - (c1expr `(c-inline ,args (fixnum t) (values &rest t) "cl_apply_from_stack(#0,#1);" +(defun c1apply-from-stack-frame (args) + (c1expr `(c-inline ,args (t t) (values &rest t) + "VALUES(0)=ecl_apply_from_stack_frame(#0,#1);" :one-liner nil :side-effects t))) (put-sysprop 'with-stack 'C1 #'c1with-stack) (put-sysprop 'with-stack 'c2 #'c2with-stack) +(put-sysprop 'innermost-stack-frame 'C1 #'c1innermost-stack-frame) (put-sysprop 'stack-push 'C1 #'c1stack-push) (put-sysprop 'stack-push-values 'C1 #'c1stack-push-values) (put-sysprop 'stack-push-values 'C2 #'c2stack-push-values) (put-sysprop 'stack-pop 'C1 #'c1stack-pop) -(put-sysprop 'stack-pop 'C2 #'c2stack-pop) -(put-sysprop 'apply-from-stack 'c1 #'c1apply-from-stack) \ No newline at end of file +(put-sysprop 'si::apply-from-stack-frame 'c1 #'c1apply-from-stack-frame) \ No newline at end of file diff --git a/src/h/external.h b/src/h/external.h index 974420cd4..5e66f593a 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -440,6 +440,16 @@ extern cl_object si_eval_with_env _ARGS((cl_narg narg, cl_object form, ...)); /* interpreter.c */ extern cl_object si_interpreter_stack _ARGS((cl_narg narg)); +extern void ecl_stack_frame_reserve(cl_object f, cl_index size); +extern void ecl_stack_frame_push(cl_object f, cl_object o); +extern void ecl_stack_frame_push_values(cl_object f); +extern void ecl_stack_frame_push_va_list(cl_object f, cl_va_list args); +extern void ecl_stack_frame_close(cl_object f); +extern cl_object ecl_stack_frame_pop_values(cl_object f); +extern cl_object ecl_stack_frame_elt(cl_object f, cl_index n); +extern void ecl_stack_frame_elt_set(cl_object f, cl_index n, cl_object o); +extern cl_object ecl_apply_from_stack_frame(cl_object f, cl_object o); +#define si_apply_from_stack_frame ecl_apply_from_stack_frame extern void cl_stack_push(cl_object o); extern cl_object cl_stack_pop(void); @@ -454,7 +464,7 @@ extern void cl_stack_push_n(cl_index n, cl_object *args); extern cl_index cl_stack_push_values(void); extern void cl_stack_pop_values(cl_index n); -extern cl_object ecl_apply_lambda(cl_narg narg, cl_object fun); +extern cl_object ecl_apply_lambda(cl_object frame, cl_object fun); extern void *ecl_interpret(cl_object bytecodes, void *pc); /* disassembler.c */ @@ -649,7 +659,7 @@ extern cl_object si_clear_gfun_hash(cl_object what); extern cl_object clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t); extern cl_object si_generic_function_p(cl_object instance); -extern cl_object _ecl_compute_method(cl_narg narg, cl_object fun, cl_object *args); +extern cl_object _ecl_standard_dispatch(cl_object frame, cl_object fun); #endif /* CLOS */ diff --git a/src/h/internal.h b/src/h/internal.h index 1426b63e1..a5bf30408 100644 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -68,6 +68,10 @@ struct cl_compiler_env { #define cl_stack_ref(n) cl_env.stack[n] #define cl_stack_index() (cl_env.stack_top-cl_env.stack) +#define ECL_BUILD_STACK_FRAME(name) \ + struct ecl_stack_frame name##_aux;\ + cl_object name=(name##_aux.t=t_frame,name##_aux.narg=name##_aux.sp=0,(cl_object)&(name##_aux)); + /* ffi.d */ #define ECL_FFICALL_LIMIT 256 diff --git a/src/h/object.h b/src/h/object.h index ce4a494ee..a23ce4c64 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -487,6 +487,12 @@ struct ecl_foreign { /* user defined datatype */ char *data; /* the data itself */ }; +struct ecl_stack_frame { + HEADER; + cl_index narg; /* Size */ + cl_index sp; /* Stack pointer start */ +}; + /* dummy type */ @@ -582,7 +588,8 @@ union cl_lispunion { struct ecl_condition_variable condition_variable; /* condition-variable */ #endif struct ecl_codeblock cblock; /* codeblock */ - struct ecl_foreign foreign; /* user defined data type */ + struct ecl_foreign foreign; /* user defined data type */ + struct ecl_stack_frame frame; /* stack frame */ }; /* @@ -635,6 +642,7 @@ typedef enum { #endif t_codeblock, t_foreign, + t_frame, t_end, t_other, t_contiguous, /* contiguous block */ diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in index f584dad71..6e2abebef 100644 --- a/src/lsp/config.lsp.in +++ b/src/lsp/config.lsp.in @@ -24,7 +24,7 @@ Returns, as a string, the location of the machine on which ECL runs." (defun lisp-implementation-version () "Args:() Returns the version of your ECL as a string." - "@PACKAGE_VERSION@ (CVS 2008-02-09 20:37)") + "@PACKAGE_VERSION@ (CVS 2008-02-10 18:53)") (defun machine-type () "Args: ()