mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-05-09 09:10:44 -07:00
Code Issues Projects Releases Packages Wiki Activity

exceptions: introduce the concept of an exception

Browse source 
Exceptions, unlike conditions, are stack allocated and can't be captured.
This commit is contained in:
Daniel Kochmański 2026-03-12 13:36:17 +01:00
parent 41833adcf3
commit 367def24c0
14 changed files with 219 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/c/clos/instance.d
View file

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

4
src/c/dpp.c
View file

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

92
src/c/error.d
View file

@ -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);
}

42
src/c/escape.d
View file

@ -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.

4
src/c/main.d
View file

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

4
src/c/memory.d
View file

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

7
src/c/printer/write_ugly.d
View file

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

1
src/c/serialize.d
View file

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

3
src/c/symbols_list.h
View file

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

2
src/c/typespec.d
View file

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

1
src/clos/hierarchy.lsp
View file

@ -230,6 +230,7 @@
(si::frame)
(si::token)
(si::module)
(si::exception)
(si::weak-pointer)
(:threads mp::process)
(:threads mp::lock)

4
src/h/external.h
View file

@ -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;

18
src/h/nucleus.h
View file

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

38
src/h/object.h
View file

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