From a71eebeb0e14fb91086cbcf61916252d81d2f593 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 4 Mar 2026 08:50:21 +0100 Subject: [PATCH] exceptions: introduce the concept of an exception Exceptions, unlike conditions, are stack allocated and can't be captured. --- src/c/alloc_2.d | 5 +++ src/c/clos/instance.d | 3 ++ src/c/dpp.c | 4 +- src/c/error.d | 92 +++++++++++++++++++++++++++++++++++++- src/c/escape.d | 42 +++++++++++++++++ src/c/main.d | 8 ++-- src/c/printer/write_ugly.d | 7 +++ src/c/serialize.d | 1 + src/c/symbols_list.h | 4 ++ src/c/threads/thread.d | 1 + src/c/typespec.d | 2 + src/clos/hierarchy.lsp | 1 + src/h/external.h | 4 ++ src/h/nucleus.h | 17 +++++++ src/h/object.h | 38 ++++++++++++++++ 15 files changed, 220 insertions(+), 9 deletions(-) diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index c0c16c6c5..61ae4fea2 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -557,6 +557,7 @@ void init_type_info (void) init_tm(t_foreign, "FOREIGN", sizeof(struct ecl_foreign), 2); init_tm(t_frame, "STACK-FRAME", sizeof(struct ecl_stack_frame), 0); init_tm(t_token, "TOKEN", sizeof(struct ecl_token), 2); + init_tm(t_exception, "EXCEPTION", sizeof(struct ecl_exception), 3); init_tm(t_weak_pointer, "WEAK-POINTER", sizeof(struct ecl_weak_pointer), 0); #ifdef ECL_SSE2 init_tm(t_sse_pack, "SSE-PACK", sizeof(struct ecl_sse_pack), 0); @@ -719,6 +720,10 @@ void init_type_info (void) type_info[t_token].descriptor = to_bitmap(&o, &(o.token.string)) | to_bitmap(&o, &(o.token.escape))); + type_info[t_exception].descriptor = + to_bitmap(&o, &(o.exception.arg1)) | + to_bitmap(&o, &(o.exception.arg2)) | + to_bitmap(&o, &(o.exception.arg3)); type_info[t_weak_pointer].descriptor = 0; #ifdef ECL_SSE2 type_info[t_sse_pack].descriptor = 0; diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index 27d7d31f8..c5563046c 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -395,6 +395,7 @@ enum ecl_built_in_classes { ECL_BUILTIN_FOREIGN_DATA, ECL_BUILTIN_FRAME, ECL_BUILTIN_TOKEN, + ECL_BUILTIN_EXCEPTION, ECL_BUILTIN_WEAK_POINTER, ECL_BUILTIN_PROCESS, ECL_BUILTIN_LOCK, @@ -514,6 +515,8 @@ cl_class_of(cl_object x) index = ECL_BUILTIN_FRAME; break; case t_token: index = ECL_BUILTIN_TOKEN; break; + case t_exception: + index = ECL_BUILTIN_EXCEPTION; break; case t_weak_pointer: index = ECL_BUILTIN_WEAK_POINTER; break; #ifdef ECL_SSE2 diff --git a/src/c/dpp.c b/src/c/dpp.c index 82c86fedf..38f1f4924 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -753,7 +753,7 @@ put_declaration(void) if (nopt == 0 && !rest_flag && !key_flag) { put_lineno(); fprintf(out, "\tif (ecl_unlikely(narg!=%d))", nreq); - fprintf(out, "\t FEwrong_num_arguments(ecl_make_fixnum(%d));\n", + fprintf(out, "\t ecl_ferror2(ECL_EX_F_NARGS, ecl_make_fixnum(%d));\n", function_code); } else { simple_varargs = !rest_flag && !key_flag && ((nreq + nopt) < 32); @@ -782,7 +782,7 @@ put_declaration(void) if (nopt > 0 && !rest_flag && !key_flag) { fprintf(out, "|| narg > %d", nreq + nopt); } - fprintf(out, ")) FEwrong_num_arguments(ecl_make_fixnum(%d));\n", function_code); + fprintf(out, ")) ecl_ferror2(ECL_EX_F_NARGS, ecl_make_fixnum(%d));\n", function_code); for (i = 0; i < nopt; i++) { put_lineno(); fprintf(out, "\tif (narg > %d) {\n", nreq+i); diff --git a/src/c/error.d b/src/c/error.d index c8bc4a2ce..2c39f3bfc 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -55,6 +55,95 @@ ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) } } +/* -- Integration with low-level exceptions */ +cl_object +ecl_exception_handler(cl_object o) +{ + if (ECL_EXCEPTIONP(o)) { + cl_object arg1 = o->exception.arg1; + cl_object arg2 = o->exception.arg2; + cl_object hand = @'si::universal-error-handler'; + switch (o->exception.ex_type) { + /* General conditions */ + case ECL_EX_FERROR: + ecl_enable_interrupts(); + return _ecl_funcall4(hand, ECL_NIL, arg1, arg2); + case ECL_EX_CERROR: + ecl_enable_interrupts(); + return _ecl_funcall4(hand, ECL_T, arg1, arg2); + /* Stack conditions */ + case ECL_EX_CS_OVR: + CEstack_overflow(@'ext::c-stack', arg1, arg2); + break; + case ECL_EX_FRS_OVR: + CEstack_overflow(@'ext::frame-stack', arg1, arg2); + break; + case ECL_EX_BDS_OVR: + CEstack_overflow(@'ext::binding-stack', arg1, arg2); + break; + /* KLUDGE ByteVM-specific conditions */ + case ECL_EX_VM_BADARG_EXCD: + FEprogram_error("Too many arguments passed to function ~A~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_UNKK: + FEprogram_error("Unknown keyword argument passed to function ~A.~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_ODDK: + FEprogram_error("Odd number of keyword arguments passed to function ~A.~&" + "Argument list: ~S", + 2, arg1, cl_apply(2, @'list', arg2)); + break; + case ECL_EX_VM_BADARG_NTH_VAL: + FEerror("Wrong index passed to NTH-VAL", 0); + break; + case ECL_EX_VM_BADARG_ENDP: + FEwrong_type_only_arg(@[endp], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_CAR: + FEwrong_type_only_arg(@[car], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_CDR: + FEwrong_type_only_arg(@[cdr], arg1, @[list]); + break; + case ECL_EX_VM_BADARG_PROGV: + FEerror("Wrong arguments to special form PROGV. Either~%" + "~A~%or~%~A~%are not proper lists", + 2, arg1, arg2); + break; + /* Variable conditions */ + case ECL_EX_V_CSETQ: + FEassignment_to_constant(arg1); + break; + case ECL_EX_V_CBIND: + FEbinding_a_constant(arg1); + break; + case ECL_EX_V_UNBND: + FEunbound_variable(arg1); + break; + case ECL_EX_V_BNAME: + FEunbound_variable(arg1); + break; + /* Function conditions */ + case ECL_EX_F_NARGS: + FEwrong_num_arguments(arg1); + break; + case ECL_EX_F_UNDEF: + FEundefined_function(arg1); + break; + case ECL_EX_F_INVAL: + FEinvalid_function(arg1); + break; + default: + ecl_internal_error("Unknown exception type."); + } + } + return ECL_NIL; +} + /*****************************************************************************/ /* Support for Lisp Error Handler */ /*****************************************************************************/ @@ -562,6 +651,5 @@ void init_error(void) { ecl_def_c_function(@'si::universal-error-handler', - (cl_objectfn_fixed)universal_error_handler, - 3); + (cl_objectfn_fixed)universal_error_handler, 3); } diff --git a/src/c/escape.d b/src/c/escape.d index 6031c90af..f9b12ecb6 100644 --- a/src/c/escape.d +++ b/src/c/escape.d @@ -97,6 +97,48 @@ ecl_call_with_handler(cl_object handler, cl_object continuation) return result; } +/* -- Exceptions ------------------------------------------------------------ ** + +Conditions in Common Lisp are instances of STANDARD-CLASS. While eventually I'd +like to include classes to the early environment, that would be too much work at +one go. This is also the reason why ecl_signal accepts all kinds of objects. + +In order to signal conditions in the early environment we use a trick: we pass +to ecl_signal objects of type ecl_exception that are recognized by a Common Lisp +handler, and that handler resignals proper conditions. Exceptions are allocated +on the stack and capturing them is prohibited. + +ecl_raise is very similar to ecl_signal with an exception that it does not pop +the current handler from the stack. This is to ensure, that the condition +handler is invoked despite being "above" the exception handler on the stack. To +avoid infinite recursion it is prohibited to resignal the exception itself. + +** ---------------------------------------------------------------------------*/ + +cl_object +ecl_raise(ecl_ex_type type, bool returns, + cl_object arg1, cl_object arg2, cl_object arg3, void *arg4) +{ + const cl_env_ptr the_env = ecl_process_env(); + struct ecl_exception ex = + { .t = t_exception, .ex_type = type, + .arg1 = arg1, .arg2 = arg2, .arg3 = arg3, .arg4 = arg4 }; + cl_object symbol, cluster, handler; + cl_object exception = ecl_cast_ptr(cl_object,&ex); + symbol = ECL_SIGNAL_HANDLERS; + 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_funcall2(handler, exception); + } + if (!returns) + _ecl_unexpected_return(); + ecl_bds_unwind1(the_env); + return ECL_NIL; +} + /* -- Fatal errors ---------------------------------------------------------- ** Fatal errors that can't be recovered from and result in the program abortion. diff --git a/src/c/main.d b/src/c/main.d index 4a8f01be7..f07a59ee4 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -109,11 +109,7 @@ ecl_init_first_env(cl_env_ptr env) #else ecl_cs_init(env); #endif - init_env_mp(env); - init_env_int(env); - init_env_aux(env); - init_env_ffi(env); - init_stacks(env); + ecl_init_env(env); } void @@ -456,6 +452,8 @@ cl_boot(int argc, char **argv) cl_import2(ECL_SIGNAL_HANDLERS, cl_core.system_package); cl_export2(ECL_SIGNAL_HANDLERS, cl_core.system_package); + ECL_SET(ECL_SIGNAL_HANDLERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); + /* * 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/printer/write_ugly.d b/src/c/printer/write_ugly.d index b5f97767b..86226658d 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -376,6 +376,12 @@ write_token(cl_object x, cl_object stream) _ecl_write_unreadable(x, "token", x->token.string, stream); } +static void +write_exception(cl_object x, cl_object stream) +{ + _ecl_write_unreadable(x, "exception", ECL_NIL, stream); +} + static void write_weak_pointer(cl_object x, cl_object stream) { @@ -487,6 +493,7 @@ static printer dispatch[FREE+1] = { write_foreign, /* t_foreign */ write_frame, /* t_frame */ write_token, /* t_token */ + write_exception, /* t_exception */ write_weak_pointer, /* t_weak_pointer */ #ifdef ECL_SSE2 _ecl_write_sse, /* t_sse_pack */ diff --git a/src/c/serialize.d b/src/c/serialize.d index 7edd1cb29..28b387a05 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -77,6 +77,7 @@ static cl_index object_size[] = { ROUNDED_SIZE(ecl_foreign), /* t_foreign */ ROUNDED_SIZE(ecl_stack_frame), /* t_frame */ ROUNDED_SIZE(ecl_token), /* t_token */ + ROUNDED_SIZE(ecl_exception), /* t_exception */ ROUNDED_SIZE(ecl_weak_pointer) /* t_weak_pointer */ #ifdef ECL_SSE2 , ROUNDED_SIZE(ecl_sse_pack) /* t_sse_pack */ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 123e883a6..42096da80 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -110,6 +110,8 @@ cl_symbols[] = { {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)}, +{SYS_ "EXCEPTION-HANDLER" ECL_FUN("ecl_exception_handler", ecl_exception_handler, 1) 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)}, @@ -1850,6 +1852,8 @@ cl_symbols[] = { {SYS_ "CODE-BLOCK" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "TOKEN" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, +{SYS_ "EXCEPTION" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, + {SYS_ "FRAME" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "APPLY-FROM-STACK-FRAME" ECL_FUN("si_apply_from_stack_frame", si_apply_from_stack_frame, 2) ECL_VAR(SI_ORDINARY, OBJNULL)}, diff --git a/src/c/threads/thread.d b/src/c/threads/thread.d index fc5817b85..907f09ff6 100644 --- a/src/c/threads/thread.d +++ b/src/c/threads/thread.d @@ -365,6 +365,7 @@ ecl_import_current_thread(cl_object name, cl_object bindings) env_aux->interrupt_struct->signal_queue = ECL_NIL; ecl_set_process_env(env_aux); ecl_init_env(env_aux); + ECL_SET(ECL_HANDLER_CLUSTERS, ecl_list1(ECL_SYM_FUN(@'si::exception-handler'))); /* Allocate real environment, link it together with process */ env = _ecl_alloc_env(0); diff --git a/src/c/typespec.d b/src/c/typespec.d index bca1f5c67..5504da5ba 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -183,6 +183,8 @@ ecl_type_to_symbol(cl_type t) return @'si::frame'; case t_token: return @'si::token'; + case t_exception: + return @'si::exception'; case t_weak_pointer: return @'ext::weak-pointer'; #ifdef ECL_SSE2 diff --git a/src/clos/hierarchy.lsp b/src/clos/hierarchy.lsp index 4a40329a3..716920362 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -229,6 +229,7 @@ (si::foreign-data) (si::frame) (si::token) + (si::exception) (si::weak-pointer) (:threads mp::process) (:threads mp::lock) diff --git a/src/h/external.h b/src/h/external.h index c8ea495d9..27319fe3b 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -549,6 +549,8 @@ extern ECL_API cl_object si_bc_join(cl_object lex, cl_object code, cl_object dat extern ECL_API cl_object cl_error _ECL_ARGS((cl_narg narg, cl_object eformat, ...)) ecl_attr_noreturn; extern ECL_API cl_object cl_cerror _ECL_ARGS((cl_narg narg, cl_object cformat, cl_object eformat, ...)); +extern ECL_API cl_object ecl_exception_handler(cl_object exception); + extern ECL_API void ecl_internal_error(const char *s) ecl_attr_noreturn; #ifdef ECL_THREADS extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn; @@ -556,6 +558,8 @@ extern ECL_API void ecl_thread_internal_error(const char *s) ecl_attr_noreturn; extern ECL_API void ecl_unrecoverable_error(cl_env_ptr the_env, const char *message) ecl_attr_noreturn; extern ECL_API void ecl_miscompilation_error(void) ecl_attr_noreturn; extern ECL_API void ecl_cs_overflow(void) /*ecl_attr_noreturn*/; + +extern ECL_API void CEstack_overflow(cl_object resume, cl_object type, cl_object size); extern ECL_API void FEprogram_error(const char *s, int narg, ...) ecl_attr_noreturn; extern ECL_API void FEcontrol_error(const char *s, int narg, ...) ecl_attr_noreturn; extern ECL_API void FEreader_error(const char *s, cl_object stream, int narg, ...) ecl_attr_noreturn; diff --git a/src/h/nucleus.h b/src/h/nucleus.h index f3ebf29e8..c5721cdc8 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -50,4 +50,21 @@ cl_object ecl_call_with_handler(cl_object handler, cl_object continuation); #define ECL_WITH_HANDLER_END ecl_bds_unwind1(__the_env); } while(0) +cl_object ecl_raise(ecl_ex_type t, bool ret, + cl_object a1, cl_object a2, cl_object a3, void *a4); + +#define ecl_ferror ecl_ferror3 +#define ecl_ferror1(extype) ecl_raise(extype, 0, ECL_NIL, ECL_NIL, ECL_NIL, NULL) +#define ecl_ferror2(extype,a1) ecl_raise(extype, 0, a1, ECL_NIL, ECL_NIL, NULL) +#define ecl_ferror3(extype,a1,a2) ecl_raise(extype, 0, a1, a2, ECL_NIL, NULL) +#define ecl_ferror4(extype,a1,a2,a3) ecl_raise(extype, 0, a1, a2, a3, NULL) +#define ecl_ferror5(extype,a1,a2,a3,p4) ecl_raise(extype, 0, a1, a2, a3, p4) + +#define ecl_cerror ecl_cerror3 +#define ecl_cerror1(extype) ecl_raise(extype, 1, ECL_NIL, ECL_NIL, ECL_NIL, NULL) +#define ecl_cerror2(extype,a1) ecl_raise(extype, 1, a1, ECL_NIL, ECL_NIL, NULL) +#define ecl_cerror3(extype,a1,a2) ecl_raise(extype, 1, a1, a2, ECL_NIL, NULL) +#define ecl_cerror4(extype,a1,a2,a3) ecl_raise(extype, 1, a1, a2, a3, NULL) +#define ecl_cerror5(extype,a1,a2,a3,p4) ecl_raise(extype, 1, a1, a2, a3, p4) + #endif /* ECL_NUCLEUS_H */ diff --git a/src/h/object.h b/src/h/object.h index b3c332ae0..991249ea1 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -85,6 +85,7 @@ typedef enum { t_foreign, t_frame, t_token, + t_exception, t_weak_pointer, #ifdef ECL_SSE2 t_sse_pack, @@ -958,6 +959,42 @@ struct ecl_token { cl_object escape; /* ranges of escaped characters */ }; +typedef enum { + ECL_EX_FERROR, /* general purpose fatal error */ + ECL_EX_CERROR, /* general purpose continuable error */ + ECL_EX_CS_OVR, /* stack overflow */ + ECL_EX_FRS_OVR, /* stack overflow */ + ECL_EX_BDS_OVR, /* stack overflow */ + /* Kludges for the bytecodes VM */ + ECL_EX_VM_BADARG_EXCD, + ECL_EX_VM_BADARG_UNKK, + ECL_EX_VM_BADARG_ODDK, + ECL_EX_VM_BADARG_NTH_VAL, + ECL_EX_VM_BADARG_ENDP, + ECL_EX_VM_BADARG_CAR, + ECL_EX_VM_BADARG_CDR, + ECL_EX_VM_BADARG_PROGV, + /* Specific normal conditions */ + ECL_EX_V_CSETQ, /* assigning a constant */ + ECL_EX_V_CBIND, /* binding a constant */ + ECL_EX_V_UNBND, /* unbound variable */ + ECL_EX_V_BNAME, /* illegal variable name */ + ECL_EX_F_NARGS, /* wrong number of arguments */ + ECL_EX_F_UNDEF, /* undefined function */ + ECL_EX_F_INVAL /* non-function passed as function */ +} ecl_ex_type; + +#define ECL_EXCEPTIONP(x) ((ECL_IMMEDIATE(x)==0) && ((x)->d.t==t_exception)) + +struct ecl_exception { + _ECL_HDR1(ex_type); + /* Slots for storing contextual data. Depends on the exception type. */ + cl_object arg1; /* usually the offending object or the type. */ + cl_object arg2; /* usually additional arguments or the flag. */ + cl_object arg3; /* arbitrary lisp extra argument (i.e ECL_NIL). */ + void * arg4; /* arbitrary last ditch argument (usually NULL). */ +}; + struct ecl_weak_pointer { /* weak pointer to value */ _ECL_HDR; cl_object value; @@ -1187,6 +1224,7 @@ union cl_lispunion { struct ecl_dummy d; /* dummy */ struct ecl_instance instance; /* clos instance */ struct ecl_token token; /* token */ + struct ecl_exception exception; /* exception */ #ifdef ECL_THREADS struct ecl_process process; /* process */ struct ecl_lock lock; /* lock */