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

exceptions: introduce the concept of an exception

Browse source 
The exception in CL is resignaled as a condition.
This commit is contained in:
Daniel Kochmański 2025-05-14 15:05:35 +02:00
parent 8e5ae5d398
commit f6321ed5e3
14 changed files with 209 additions and 12 deletions
Download patch file Download diff file Expand all files Collapse all files

5
src/c/alloc_2.d
View file

@ -552,6 +552,7 @@ void init_type_info (void)
init_tm(t_codeblock, "CODEBLOCK", sizeof(struct ecl_codeblock), -1);
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_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);
@ -710,6 +711,10 @@ void init_type_info (void)
to_bitmap(&o, &(o.foreign.tag));
type_info[t_frame].descriptor =
to_bitmap(&o, &(o.frame.env));
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;

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

@ -383,6 +383,7 @@ enum ecl_built_in_classes {
ECL_BUILTIN_CODE_BLOCK,
ECL_BUILTIN_FOREIGN_DATA,
ECL_BUILTIN_FRAME,
ECL_BUILTIN_EXCEPTION,
ECL_BUILTIN_WEAK_POINTER
#ifdef ECL_THREADS
,
@ -505,6 +506,8 @@ cl_class_of(cl_object x)
index = ECL_BUILTIN_FOREIGN_DATA; break;
case t_frame:
index = ECL_BUILTIN_FRAME; break;
case t_exception:
index = ECL_BUILTIN_EXCEPTION; break;
case t_weak_pointer:
index = ECL_BUILTIN_WEAK_POINTER; break;
#ifdef ECL_SSE2

84
src/c/error.d
View file

@ -55,6 +55,87 @@ 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;
/* 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;
/* 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 +643,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);
}

56
src/c/jump.d
View file

@ -97,6 +97,62 @@ 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_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_funcall2(handler, exception);
}
if (!returns)
_ecl_unexpected_return();
ecl_bds_unwind1(the_env);
return ECL_NIL;
}
cl_object
ecl_ferror(ecl_ex_type extype, cl_object type, cl_object args)
{
ecl_raise(extype, 0, type, args, ECL_NIL, NULL);
_ecl_unexpected_return();
}
cl_object
ecl_cerror(ecl_ex_type extype, cl_object type, cl_object args)
{
ecl_raise(extype, 1, type, args, ECL_NIL, NULL);
return ECL_NIL;
}
/* -- Fatal errors ---------------------------------------------------------- **
Fatal errors that can't be recovered from and result in the program abortion.

9
src/c/main.d
View file

@ -105,11 +105,7 @@ ecl_init_first_env(cl_env_ptr env)
#ifdef ECL_THREADS
init_threads();
#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
@ -448,6 +444,9 @@ 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. */
ECL_SET(ECL_HANDLER_CLUSTERS, 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

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

@ -370,6 +370,12 @@ write_frame(cl_object x, cl_object stream)
_ecl_write_unreadable(x, "frame", ecl_make_fixnum(x->frame.size), 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)
{
@ -480,6 +486,7 @@ static printer dispatch[FREE+1] = {
write_codeblock, /* t_codeblock */
write_foreign, /* t_foreign */
write_frame, /* t_frame */
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

@ -76,6 +76,7 @@ static cl_index object_size[] = {
ROUNDED_SIZE(ecl_codeblock), /* t_codeblock */
ROUNDED_SIZE(ecl_foreign), /* t_foreign */
ROUNDED_SIZE(ecl_stack_frame), /* t_frame */
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

@ -111,6 +111,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)},
@ -1844,6 +1846,7 @@ cl_symbols[] = {
{SYS_ "CODE-BLOCK" 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)},

1
src/c/threads/thread.d
View file

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

2
src/c/typespec.d
View file

@ -181,6 +181,8 @@ ecl_type_to_symbol(cl_type t)
return @'si::foreign-data';
case t_frame:
return @'si::frame';
case t_exception:
return @'si::exception';
case t_weak_pointer:
return @'ext::weak-pointer';
#ifdef ECL_SSE2

1
src/clos/hierarchy.lsp
View file

@ -229,6 +229,7 @@
(si::code-block)
(si::foreign-data)
(si::frame)
(si::exception)
(si::weak-pointer)
#+threads (mp::process)
#+threads (mp::lock)

4
src/h/external.h
View file

@ -533,6 +533,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;
@ -540,6 +542,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;

9
src/h/nucleus.h
View file

@ -50,11 +50,10 @@ 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 type, cl_object returns,
cl_object arg1, cl_object arg2, cl_object arg3);
cl_object ecl_raise(ecl_ex_type t, bool ret,
cl_object a1, cl_object a2, cl_object a3, void *a4);
cl_object ecl_ferror(cl_object type, cl_object args);
cl_object ecl_cerror(cl_object type, cl_object args, cl_object cmsg);
cl_object ecl_serror(cl_object type, cl_object size, cl_object resz);
cl_object ecl_ferror(ecl_ex_type extype, cl_object type, cl_object args);
cl_object ecl_cerror(ecl_ex_type extype, cl_object type, cl_object args);
#endif /* ECL_NUCLEUS_H */

36
src/h/object.h
View file

@ -84,6 +84,7 @@ typedef enum {
t_codeblock,
t_foreign,
t_frame,
t_exception,
t_weak_pointer,
#ifdef ECL_SSE2
t_sse_pack,
@ -933,6 +934,40 @@ struct ecl_stack_frame {
struct cl_env_struct *env;
};
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,
/* 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_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;
@ -1161,6 +1196,7 @@ union cl_lispunion {
struct ecl_cclosure cclosure; /* compiled closure */
struct ecl_dummy d; /* dummy */
struct ecl_instance instance; /* clos instance */
struct ecl_exception exception; /* exception */
#ifdef ECL_THREADS
struct ecl_process process; /* process */
struct ecl_lock lock; /* lock */