From 4e860d86bcf1ced5b9fccdad77c3fb76abf9092a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 23 Apr 2024 08:04:21 +0200 Subject: [PATCH] signals: define *SIGNAL-HANDLERS* in cold_boot I've also renamed *HANDLER-CLUSTERS* to a more appropriate *SIGNAL-HANDLERS*. Currently this symbol is imported to the SYSTEM package, although this may be revised in the future to cater to multiple global environments. Alternatively the SYSTEM package may be common to all runtimes. --- src/c/alloc_2.d | 3 +++ src/c/boot.d | 11 +++++------ src/c/cinit.d | 2 +- src/c/escape.d | 2 +- src/c/main.d | 4 ++++ src/c/symbols_list.h | 1 - src/clos/conditions.lsp | 6 +++--- src/h/ecl-inl.h | 8 ++++++++ src/h/external.h | 3 +++ src/h/nucleus.h | 2 +- src/h/object.h | 4 ++-- src/h/stacks.h | 2 +- 12 files changed, 32 insertions(+), 16 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index 7e7d943c7..c0c16c6c5 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -1187,7 +1187,10 @@ stacks_scanner() GC_set_mark_bit((void *)dll); } } end_loop_for_on_unsafe(l); + /* ECL runtime */ GC_push_all((void *)(&ecl_core), (void *)(&ecl_core + 1)); + GC_push_all((void *)ecl_vr_shandlers, (void *)(ecl_vr_shandlers + 1)); + /* Common Lisp */ GC_push_all((void *)(&cl_core), (void *)(&cl_core + 1)); GC_push_all((void *)cl_symbols, (void *)(cl_symbols + cl_num_symbols_in_core)); ecl_mark_env(ecl_core.first_env); diff --git a/src/c/boot.d b/src/c/boot.d index 878533331..9a24e6724 100644 --- a/src/c/boot.d +++ b/src/c/boot.d @@ -46,13 +46,12 @@ ecl_def_ct_ratio(ecl_ct_plus_half,ecl_make_fixnum(1),ecl_make_fixnum(2),,const); ecl_def_ct_ratio(ecl_ct_minus_half,ecl_make_fixnum(-1),ecl_make_fixnum(2),,const); /* These two tags have a special meaning for the frame stack. */ +ecl_def_constant(ecl_ct_protect_tag, ECL_NIL, "PROTECT-TAG", 11); +ecl_def_constant(ecl_ct_dummy_tag, ECL_NIL, "DUMMY-TAG", 9); -ecl_def_ct_base_string(ecl_ct_ptag_string,"PROTECT-TAG",11,static,const); -ecl_def_ct_base_string(ecl_ct_dtag_string,"DUMMY-TAG",9,static,const); - -ecl_def_ct_token(ecl_ct_protect_tag,ecl_stp_constant,ecl_ct_ptag_string,ECL_NIL,,const); -ecl_def_ct_token(ecl_ct_dummy_tag ,ecl_stp_constant,ecl_ct_dtag_string,ECL_NIL,,const); - +/* This variable is a stack with functions that are called for raised exceptions + and signaled conditions. */ +ecl_def_variable(ecl_vr_shandlers, ECL_NIL, "*SIGNAL-HANDLERS*", 17); /* -- implementation ------------------------------------------------ */ diff --git a/src/c/cinit.d b/src/c/cinit.d index 8f81d28d4..852d663b9 100644 --- a/src/c/cinit.d +++ b/src/c/cinit.d @@ -77,7 +77,7 @@ si_bind_simple_handlers(cl_object tag, cl_object names) if (ECL_FBOUNDP(@'si::bind-simple-handlers')) return _ecl_funcall3(@'si::bind-simple-handlers', tag, names); else - return ECL_SYM_VAL(ecl_process_env(), @'si::*handler-clusters*'); + return ECL_SYM_VAL(ecl_process_env(), ECL_SIGNAL_HANDLERS); } extern cl_object diff --git a/src/c/escape.d b/src/c/escape.d index fa358ec82..6031c90af 100644 --- a/src/c/escape.d +++ b/src/c/escape.d @@ -71,7 +71,7 @@ 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; + symbol = ECL_SIGNAL_HANDLERS; cluster = ECL_SYM_VAL(the_env, symbol); ecl_bds_bind(the_env, symbol, cluster); while(!Null(cluster)) { diff --git a/src/c/main.d b/src/c/main.d index f97ebf1f2..4a8f01be7 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -452,6 +452,10 @@ cl_boot(int argc, char **argv) /* We need to enable GC because a lot of stuff is to be created */ init_alloc(1); + /* Initialize the handler stack with the exception handler. */ + cl_import2(ECL_SIGNAL_HANDLERS, cl_core.system_package); + cl_export2(ECL_SIGNAL_HANDLERS, cl_core.system_package); + /* * Set *default-pathname-defaults* to a temporary fake value. We * will fix this when we have access to the condition system to diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index b44d210ea..123e883a6 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -105,7 +105,6 @@ cl_symbols[] = { {"T" ECL_FUN(NULL, NULL, -1) ECL_VAR(CL_ORDINARY, OBJNULL)}, {SYS_ "UNBOUND" ECL_FUN("si_unbound", si_unbound, 0) ECL_VAR(SI_CONSTANT, ECL_UNBOUND)}, {SYS_ "*RESTART-CLUSTERS*" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_SPECIAL, ECL_NIL)}, -{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)}, diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 8098366d2..0d5ed0732 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -373,7 +373,7 @@ |# -(defvar *handler-clusters* nil) +(defvar *signal-handlers* nil) (defmacro handler-bind (bindings &body body) (with-gensyms (handler condition) @@ -388,7 +388,7 @@ collect `(when (typep ,condition ',type) (funcall ,func ,condition)))))) (declare (dynamic-extent (function ,handler))) - (let ((*handler-clusters* (cons (function ,handler) *handler-clusters*))) + (let ((*signal-handlers* (cons (function ,handler) *signal-handlers*))) ,@body)))) (defun bind-simple-handlers (tag names) @@ -398,7 +398,7 @@ for type in (if (atom names) (list names) names) when (typep condition type) do (throw tag (values code condition)))))) - (cons #'simple-handler *handler-clusters*))) + (cons #'simple-handler *signal-handlers*))) (defun signal (datum &rest arguments) (let ((condition (coerce-to-condition datum arguments 'SIMPLE-CONDITION 'SIGNAL))) diff --git a/src/h/ecl-inl.h b/src/h/ecl-inl.h index e375c4536..7047ca80b 100644 --- a/src/h/ecl-inl.h +++ b/src/h/ecl-inl.h @@ -129,6 +129,14 @@ #define ecl_cast_ptr(type,n) ((type)(n)) #endif +#define ecl_def_variable(name, value, chars, len) \ + ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \ + ecl_def_ct_token(name, ecl_stp_special, name ## _var_name, value,,) + +#define ecl_def_constant(name, value, chars, len) \ + ecl_def_ct_base_string (name ## _var_name, chars, len,static,const); \ + ecl_def_ct_token(name, ecl_stp_constant, name ## _var_name, value,,const) + #ifdef ECL_THREADS #define ecl_def_ct_token(name,stype,sname,value,static,const) \ static const struct ecl_symbol name ## _data = { \ diff --git a/src/h/external.h b/src/h/external.h index a02e6c72e..c8ea495d9 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -210,6 +210,9 @@ struct cl_core_struct { extern ECL_API struct ecl_core_struct ecl_core; extern ECL_API struct cl_core_struct cl_core; +/* variables */ +extern ECL_API cl_object ecl_vr_shandlers; + /* memory.c */ extern ECL_API void *ecl_malloc(cl_index n); extern ECL_API void *ecl_realloc(void *ptr, cl_index o, cl_index n); diff --git a/src/h/nucleus.h b/src/h/nucleus.h index b95cb93be..f3ebf29e8 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -43,7 +43,7 @@ cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); 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_sym = ECL_SIGNAL_HANDLERS; \ 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); diff --git a/src/h/object.h b/src/h/object.h index 9c1350c24..b3c332ae0 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -262,13 +262,13 @@ enum ecl_stype { /* symbol type */ #define ECL_NIL ((cl_object)t_list) #define ECL_PROTECT_TAG ecl_ct_protect_tag #define ECL_DUMMY_TAG ecl_ct_dummy_tag +#define ECL_SIGNAL_HANDLERS ecl_vr_shandlers #define ECL_NIL_SYMBOL ((cl_object)cl_symbols) #define ECL_T ((cl_object)(cl_symbols+1)) #define ECL_UNBOUND ((cl_object)(cl_symbols+2)) #define ECL_RESTART_CLUSTERS ((cl_object)(cl_symbols+3)) -#define ECL_HANDLER_CLUSTERS ((cl_object)(cl_symbols+4)) -#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+5)) +#define ECL_INTERRUPTS_ENABLED ((cl_object)(cl_symbols+4)) #define ECL_NO_TL_BINDING ((cl_object)(1 << ECL_TAG_BITS)) struct ecl_symbol { diff --git a/src/h/stacks.h b/src/h/stacks.h index 0fa79433c..e9520309f 100755 --- a/src/h/stacks.h +++ b/src/h/stacks.h @@ -510,7 +510,7 @@ ecl_data_stack_set_index(cl_env_ptr env, cl_index ndx) #define ECL_HANDLER_CASE_BEGIN(the_env, names) do { \ const cl_env_ptr __the_env = (the_env); \ const cl_object __ecl_tag = ecl_list1(names); \ - ecl_bds_bind(__the_env, ECL_HANDLER_CLUSTERS, \ + ecl_bds_bind(__the_env, ECL_SIGNAL_HANDLERS, \ si_bind_simple_handlers(__ecl_tag, names)); \ ecl_frs_push(__the_env,__ecl_tag); \ if (__ecl_frs_push_result == 0) {