signals: introduce signals to the early environment

src/c/escape.d

@@ -28,6 +28,75 @@
 # include <DbgHelp.h>
 #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.

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)},

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))
 
 

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 */