diff --git a/src/c/escape.d b/src/c/escape.d index 0d8fa836d..fa358ec82 100644 --- a/src/c/escape.d +++ b/src/c/escape.d @@ -28,6 +28,75 @@ # include #endif +/* -- Escapes --------------------------------------------------------------- ** + +Non-local transfer of control. Practically this is like THROW, where +continuation is the exit point estabilished by an equivalent of CATCH. + +** -------------------------------------------------------------------------- */ + +cl_object +ecl_escape(cl_object continuation) +{ + ecl_frame_ptr fr = frs_sch(continuation); + if (!fr) ecl_internal_error("si_fear_handler: continuation not found!"); + ecl_unwind(ecl_process_env(), fr); + _ecl_unexpected_return(); +} + +/* -- Signaling conditions -------------------------------------------------- ** + +Low level signals work slightly different from Common Lisp. There are no handler +clusters nor restarts. %signal is called with three arguments: + +- condition :: the signaled object (may be any cl_object) +- returns :: the flag stating whether whether the function returns +- destination :: the thread the condition is delivered to (implementme!) + +The signal invokes all handlers bound with with-handler in LIFO order and call +them with the condition. The handler may take do one of the following: + +- decline :: return, then signal proceeds to the next handler +- escape :: perform non-local transfer of control +- defer :: signal a condition, invoke a debugger, ... + +The called handler is not bound as an active signal handler during its execution +to avoid an infinite recursion while resignaling. When all handlers decline and +the CONTINUABLE is ECL_NIL, then we abort the program by invoking the function +_ecl_unexpected_return(). + +** -------------------------------------------------------------------------- */ + +cl_object +ecl_signal(cl_object condition, cl_object returns, cl_object thread) { + const cl_env_ptr the_env = ecl_process_env(); + cl_object symbol, cluster, handler; + symbol = ECL_HANDLER_CLUSTERS; + cluster = ECL_SYM_VAL(the_env, symbol); + ecl_bds_bind(the_env, symbol, cluster); + while(!Null(cluster)) { + handler = ECL_CONS_CAR(cluster); + cluster = ECL_CONS_CDR(cluster); + ECL_SETQ(the_env, symbol, cluster); + _ecl_funcall2(handler, condition); + } + if (returns == ECL_NIL) + _ecl_unexpected_return(); + ecl_bds_unwind1(the_env); + return ECL_NIL; +} + +cl_object +ecl_call_with_handler(cl_object handler, cl_object continuation) +{ + cl_env_ptr the_env = ecl_process_env(); + cl_object result; + ECL_WITH_HANDLER_BEGIN(the_env, handler) { + result = _ecl_funcall1(continuation); + } ECL_WITH_HANDLER_END; + return result; +} + /* -- Fatal errors ---------------------------------------------------------- ** Fatal errors that can't be recovered from and result in the program abortion. diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 6ad2faef8..b44d210ea 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -108,6 +108,9 @@ cl_symbols[] = { {SYS_ "*HANDLER-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, {EXT_ "*INTERRUPTS-ENABLED*" ECL_FUN(NULL, NULL, 1) ECL_VAR(EXT_SPECIAL, ECL_T)}, +{SYS_ "%ESCAPE" ECL_FUN("ecl_escape", ecl_escape, 1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "%SIGNAL" ECL_FUN("ecl_signal", ecl_signal, 3) ECL_VAR(SI_ORDINARY, OBJNULL)}, + /* LISP PACKAGE */ {"&ALLOW-OTHER-KEYS" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {"&AUX" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 64ae26cd2..40989d089 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -396,14 +396,10 @@ (cons #'simple-handler *handler-clusters*))) (defun signal (datum &rest arguments) - (let* ((condition - (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL)) - (*handler-clusters* *handler-clusters*)) + (let ((condition (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL))) (when (typep condition *break-on-signals*) (break "~A~%Break entered because of *BREAK-ON-SIGNALS*." condition)) - (loop (unless *handler-clusters* (return)) - (let ((handler (pop *handler-clusters*))) - (funcall handler condition))) + (%signal condition t nil) nil)) diff --git a/src/h/nucleus.h b/src/h/nucleus.h index 70d7617d9..b95cb93be 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -33,4 +33,21 @@ struct ecl_core_struct { cl_object library_pathname; }; +/* control.c */ +cl_object ecl_escape(cl_object continuation) ecl_attr_noreturn; +cl_object ecl_signal(cl_object condition, cl_object returns, cl_object thread); +cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); + +/* Binding a handler conses a new list, but at this stage we don't assume the + the garbage collector to work! Luckily the extent of the binding is dynamic + and we can allocate cons on the stack. */ +#define ECL_WITH_HANDLER_BEGIN(the_env, handler) do { \ + const cl_env_ptr __the_env = the_env; \ + cl_object __ecl_sym = ECL_HANDLER_CLUSTERS; \ + cl_object __ecl_hnd = ECL_SYM_VAL(__the_env, __ecl_sym); \ + cl_object __ecl_hnds = ecl_cons_stack(handler, __ecl_hnd); \ + ecl_bds_bind(__the_env, __ecl_sym, __ecl_hnds); + +#define ECL_WITH_HANDLER_END ecl_bds_unwind1(__the_env); } while(0) + #endif /* ECL_NUCLEUS_H */