From 367def24c05d367bca096f60db07a29e0122ddce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Thu, 12 Mar 2026 13:36:17 +0100 Subject: [PATCH] exceptions: introduce the concept of an exception Exceptions, unlike conditions, are stack allocated and can't be captured. --- 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 | 4 ++ src/c/memory.d | 4 ++ src/c/printer/write_ugly.d | 7 +++ src/c/serialize.d | 1 + src/c/symbols_list.h | 3 ++ src/c/typespec.d | 2 + src/clos/hierarchy.lsp | 1 + src/h/external.h | 4 ++ src/h/nucleus.h | 18 ++++++++ src/h/object.h | 38 ++++++++++++++++ 14 files changed, 219 insertions(+), 4 deletions(-) diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index f0f4eccba..79901ccae 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -418,6 +418,7 @@ enum ecl_built_in_classes { ECL_BUILTIN_FRAME, ECL_BUILTIN_TOKEN, ECL_BUILTIN_MODULE, + ECL_BUILTIN_EXCEPTION, ECL_BUILTIN_WEAK_POINTER, ECL_BUILTIN_PROCESS, ECL_BUILTIN_LOCK, @@ -539,6 +540,8 @@ cl_class_of(cl_object x) index = ECL_BUILTIN_TOKEN; break; case t_module: index = ECL_BUILTIN_MODULE; 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 db63cd206..bf3c6eb3a 100644 --- a/src/c/escape.d +++ b/src/c/escape.d @@ -136,6 +136,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 48cfc5beb..ad9496021 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -309,6 +309,10 @@ cl_boot(int argc, char **argv) cl_import2(ECL_SIGNAL_HANDLERS, cl_core.system_package); cl_export2(ECL_SIGNAL_HANDLERS, cl_core.system_package); + /* Set the default exception handler that coerces exceptions to conditions + that are understood by the condition system. */ + 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/memory.d b/src/c/memory.d index e91a0b55b..484944cfe 100644 --- a/src/c/memory.d +++ b/src/c/memory.d @@ -280,6 +280,10 @@ init_type_info_database(void) to_bitmap(&o, &(o.token.string)) | to_bitmap(&o, &(o.token.escape))); init_tm(t_module, "MODULE", ecl_module, 0); + init_tm(t_exception, "EXCEPTION", ecl_exception, + to_bitmap(&o, &(o.exception.arg1)) | + to_bitmap(&o, &(o.exception.arg2)) | + to_bitmap(&o, &(o.exception.arg3))); init_tm(t_weak_pointer, "WEAK-POINTER", ecl_weak_pointer, 0); #ifdef ECL_SSE2 init_tm(t_sse_pack, "SSE-PACK", ecl_sse_pack, 0); diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index 205733d43..cf34c4097 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -382,6 +382,12 @@ write_module(cl_object x, cl_object stream) _ecl_write_unreadable(x, "module", x->module.name, 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) { @@ -494,6 +500,7 @@ static printer dispatch[FREE+1] = { write_frame, /* t_frame */ write_token, /* t_token */ write_module, /* t_module */ + 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 5a5272e77..52e441343 100644 --- a/src/c/serialize.d +++ b/src/c/serialize.d @@ -78,6 +78,7 @@ static cl_index object_size[] = { ROUNDED_SIZE(ecl_stack_frame), /* t_frame */ ROUNDED_SIZE(ecl_token), /* t_token */ ROUNDED_SIZE(ecl_module), /* t_module */ + 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 ab6a232a0..fe6aeafa8 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -106,6 +106,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)}, @@ -1846,6 +1848,7 @@ cl_symbols[] = { {SYS_ "TOKEN" ECL_FUN(NULL, NULL, -1) ECL_VAR(SI_ORDINARY, OBJNULL)}, {SYS_ "MODULE" 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/typespec.d b/src/c/typespec.d index d53fe9c9d..cf8efb63a 100644 --- a/src/c/typespec.d +++ b/src/c/typespec.d @@ -185,6 +185,8 @@ ecl_type_to_symbol(cl_type t) return @'si::token'; case t_module: return @'si::module'; + 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 6a50295d1..3cc5f3bbb 100644 --- a/src/clos/hierarchy.lsp +++ b/src/clos/hierarchy.lsp @@ -230,6 +230,7 @@ (si::frame) (si::token) (si::module) + (si::exception) (si::weak-pointer) (:threads mp::process) (:threads mp::lock) diff --git a/src/h/external.h b/src/h/external.h index 5876bb4d6..e4ed4f559 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -556,6 +556,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; @@ -563,6 +565,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 a2b073a33..df97e66eb 100644 --- a/src/h/nucleus.h +++ b/src/h/nucleus.h @@ -63,4 +63,22 @@ cl_object ecl_alloc_object(cl_type t); void ecl_free_memory(void *ptr); void ecl_free_object(cl_object o); +/* escape.c */ +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 75add3898..38bdc5343 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -86,6 +86,7 @@ typedef enum { t_frame, t_token, t_module, + t_exception, t_weak_pointer, #ifdef ECL_SSE2 t_sse_pack, @@ -994,6 +995,42 @@ struct ecl_module { cl_objectfn_fixed destroy; }; +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; @@ -1221,6 +1258,7 @@ union cl_lispunion { struct ecl_instance instance; /* clos instance */ struct ecl_token token; /* token */ struct ecl_module module; /* core module */ + struct ecl_exception exception; /* exception */ #ifdef ECL_THREADS struct ecl_process process; /* process */ struct ecl_lock lock; /* lock */