mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 05:43:19 -08:00
Code Issues Projects Releases Packages Wiki Activity

Simplified the frame stack by replacing the frame class with a particular tag.

Browse source
This commit is contained in:
jjgarcia 2005-08-30 14:38:04 +00:00
parent 93cf73b8d5
commit a5b4834caf
13 changed files with 47 additions and 88 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/cmpaux.d
View file

@ -166,7 +166,7 @@ aset_bv(cl_object x, cl_index index, int value)
void
cl_throw(cl_object tag)
{
ecl_frame_ptr fr = frs_sch_catch(tag);
ecl_frame_ptr fr = frs_sch(tag);
if (fr == NULL)
FEcontrol_error("THROW: The catch ~S is undefined.", 1, tag);
unwind(fr);

9
src/c/eval.d
View file

@ -252,14 +252,13 @@ cl_safe_eval(cl_object form, cl_object env, cl_object err_value)
{
cl_object output;
if (frs_push(FRS_CATCHALL, Cnil)) {
output = err_value;
} else {
CL_CATCH_ALL_BEGIN
bds_bind(@'si::*ignore-errors*', Ct);
output = si_eval_with_env(2, form, env);
bds_unwind1();
}
frs_pop();
CL_CATCH_ALL_IF_CAUGHT
output = err_value;
CL_CATCH_ALL_END;
return output;
}

10
src/c/interpreter.d
View file

@ -1096,7 +1096,7 @@ interpret(cl_object bytecodes, void *pc) {
name = GET_DATA(vector, bytecodes);
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
if (frs_push(FRS_CATCH, id) == 0) {
if (frs_push(id) == 0) {
bind_block(name, id);
} else {
reg0 = VALUES(0);
@ -1120,7 +1120,7 @@ interpret(cl_object bytecodes, void *pc) {
/* FIXME! */
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
if (frs_push(FRS_CATCH, id) == 0) {
if (frs_push(id) == 0) {
bind_block(name, id);
} else {
reg0 = VALUES(0);
@ -1142,7 +1142,7 @@ interpret(cl_object bytecodes, void *pc) {
cl_opcode *exit;
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
if (frs_push(FRS_CATCH, reg0) != 0) {
if (frs_push(reg0) != 0) {
reg0 = VALUES(0);
cl_env.lex_env = cl_env.frs_top->frs_lex;
frs_pop();
@ -1166,7 +1166,7 @@ interpret(cl_object bytecodes, void *pc) {
int n = GET_OPARG(vector);
/* Here we save the location of the jump table */
cl_stack_push((cl_object)vector); /* FIXME! */
if (frs_push(FRS_CATCH, bind_tagbody()) == 0) {
if (frs_push(bind_tagbody()) == 0) {
/* The first time, we "name" the tagbody and
* skip the jump table */
vector += n * OPARG_SIZE;
@ -1309,7 +1309,7 @@ interpret(cl_object bytecodes, void *pc) {
cl_opcode *exit;
GET_LABEL(exit, vector);
cl_stack_push((cl_object)exit);
if (frs_push(FRS_PROTECT,Cnil) != 0) {
if (frs_push(ECL_PROTECT_TAG) != 0) {
cl_env.lex_env = cl_env.frs_top->frs_lex;
frs_pop();
vector = (cl_opcode *)cl_stack_pop();

5
src/c/main.d
View file

@ -128,12 +128,11 @@ cl_shutdown(void)
{
cl_object l = SYM_VAL(@'si::*exit-hooks*');
while (CONSP(l)) {
if (!frs_push(FRS_CATCHALL, Cnil)) {
CL_CATCH_ALL_BEGIN
bds_bind(@'si::*ignore-errors*', Ct);
funcall(1, CAR(l));
bds_unwind1();
}
frs_pop();
CL_CATCH_ALL_END;
l = CDR(l);
}
#ifdef ENABLE_DLOPEN

33
src/c/stacks.d
View file

@ -255,13 +255,12 @@ frs_overflow(void) /* used as condition in list.d */
}
ecl_frame_ptr
_frs_push(register enum fr_class clas, register cl_object val)
_frs_push(register cl_object val)
{
ecl_frame_ptr output = ++cl_env.frs_top;
if (output >= cl_env.frs_limit) frs_overflow();
output->frs_lex = cl_env.lex_env;
output->frs_bds_top = cl_env.bds_top;
output->frs_class = clas;
output->frs_val = val;
output->frs_ihs = cl_env.ihs_top;
output->frs_sp = cl_stack_index();
@ -272,7 +271,7 @@ void
unwind(ecl_frame_ptr fr)
{
cl_env.nlj_fr = fr;
while (cl_env.frs_top != fr && cl_env.frs_top->frs_class == FRS_CATCH)
while (cl_env.frs_top != fr && cl_env.frs_top->frs_val != ECL_PROTECT_TAG)
--cl_env.frs_top;
cl_env.lex_env = cl_env.frs_top->frs_lex;
cl_env.ihs_top = cl_env.frs_top->frs_ihs;
@ -288,23 +287,11 @@ frs_sch (cl_object frame_id)
ecl_frame_ptr top;
for (top = cl_env.frs_top; top >= cl_env.frs_org; top--)
if (top->frs_val == frame_id && top->frs_class == FRS_CATCH)
if (top->frs_val == frame_id)
return(top);
return(NULL);
}
ecl_frame_ptr
frs_sch_catch(cl_object frame_id)
{
ecl_frame_ptr top;
for(top = cl_env.frs_top; top >= cl_env.frs_org ;top--)
if ((top->frs_val == frame_id && top->frs_class == FRS_CATCH)
|| top->frs_class == FRS_CATCHALL)
return(top);
return(NULL);
}
static ecl_frame_ptr
get_frame_ptr(cl_object x)
{
@ -330,20 +317,6 @@ si_frs_bds(cl_object arg)
@(return MAKE_FIXNUM(get_frame_ptr(arg)->frs_bds_top - cl_env.bds_org))
}
cl_object
si_frs_class(cl_object arg)
{
enum fr_class c;
cl_object output;
c = get_frame_ptr(arg)->frs_class;
if (c == FRS_CATCH) output = @':catch';
else if (c == FRS_PROTECT) output = @':protect';
else if (c == FRS_CATCHALL) output = @':catchall';
else FEerror("Unknown frs class was detected.", 0);
@(return output)
}
cl_object
si_frs_tag(cl_object arg)
{

4
src/c/symbols_list.h
View file

@ -1098,7 +1098,6 @@ cl_symbols[] = {
{SYS_ "FORMATTER-AUX", SI_ORDINARY, si_formatter_aux, -1, OBJNULL},
#endif
{SYS_ "FRS-BDS", SI_ORDINARY, si_frs_bds, 1, OBJNULL},
{SYS_ "FRS-CLASS", SI_ORDINARY, si_frs_class, 1, OBJNULL},
{SYS_ "FRS-IHS", SI_ORDINARY, si_frs_ihs, 1, OBJNULL},
{SYS_ "FRS-TAG", SI_ORDINARY, si_frs_tag, 1, OBJNULL},
{SYS_ "FRS-TOP", SI_ORDINARY, si_frs_top, 0, OBJNULL},
@ -1300,8 +1299,6 @@ cl_symbols[] = {
{KEY_ "BLOCK", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CAPITALIZE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CASE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CATCH", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CATCHALL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CIRCLE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "COMPILE-TOPLEVEL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "COMMON",KEYWORD,NULL,-1,OBJNULL},
@ -1387,7 +1384,6 @@ cl_symbols[] = {
{KEY_ "PRINT-FUNCTION", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PRINT-OBJECT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PROBE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PROTECT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "RADIX", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "READABLY", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "REHASH-SIZE", KEYWORD, NULL, -1, OBJNULL},

4
src/c/symbols_list2.h
View file

@ -1098,7 +1098,6 @@ cl_symbols[] = {
{SYS_ "FORMATTER-AUX","si_formatter_aux"},
#endif
{SYS_ "FRS-BDS","si_frs_bds"},
{SYS_ "FRS-CLASS","si_frs_class"},
{SYS_ "FRS-IHS","si_frs_ihs"},
{SYS_ "FRS-TAG","si_frs_tag"},
{SYS_ "FRS-TOP","si_frs_top"},
@ -1300,8 +1299,6 @@ cl_symbols[] = {
{KEY_ "BLOCK",NULL},
{KEY_ "CAPITALIZE",NULL},
{KEY_ "CASE",NULL},
{KEY_ "CATCH",NULL},
{KEY_ "CATCHALL",NULL},
{KEY_ "CIRCLE",NULL},
{KEY_ "COMPILE-TOPLEVEL",NULL},
{KEY_ "COMMON",NULL},
@ -1387,7 +1384,6 @@ cl_symbols[] = {
{KEY_ "PRINT-FUNCTION",NULL},
{KEY_ "PRINT-OBJECT",NULL},
{KEY_ "PROBE",NULL},
{KEY_ "PROTECT",NULL},
{KEY_ "RADIX",NULL},
{KEY_ "READABLY",NULL},
{KEY_ "REHASH-SIZE",NULL},

2
src/cmp/cmpblock.lsp
View file

@ -62,7 +62,7 @@
(wt-nl "volatile cl_object env" (incf *env-lvl*)
" = env" env-lvl ";")))
(bind "new_frame_id()" blk-var)
(wt-nl "if (frs_push(FRS_CATCH," blk-var ")!=0) {")
(wt-nl "if (frs_push(" blk-var ")!=0) {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*)))
(unwind-exit 'VALUES)
(wt-nl "} else {")

6
src/cmp/cmpcatch.lsp
View file

@ -28,12 +28,12 @@
(*unwind-exit* (list* *exit* 'FRAME *unwind-exit*)))
(if (member new-destination '(TRASH VALUES))
(progn
(wt-nl "if (frs_push(FRS_CATCH," 'VALUE0 ")==0) {")
(wt-nl "if (frs_push(" 'VALUE0 ")==0) {")
(wt-comment "BEGIN CATCH " code nil)
(c2expr body)
(wt-nl "}"))
(progn
(wt-nl "if (frs_push(FRS_CATCH," 'VALUE0 ")) {")
(wt-nl "if (frs_push(" 'VALUE0 ")) {")
(wt-comment "BEGIN CATCH " code nil)
(unwind-exit 'VALUES t)
(wt-nl "}")
@ -60,7 +60,7 @@
(wt-nl "ecl_frame_ptr next_fr; cl_object next_tag;")
;; Here we compile the form which is protected. When this form
;; is aborted, it continues at the frs_pop() with unwinding=TRUE.
(wt-nl "if (frs_push(FRS_PROTECT,Cnil)) {")
(wt-nl "if (frs_push(ECL_PROTECT_TAG)) {")
(wt-nl "unwinding = TRUE; next_fr=cl_env.nlj_fr; } else {")
(let ((*unwind-exit* (cons 'FRAME *unwind-exit*))
(*destination* 'VALUES))

2
src/cmp/cmptag.lsp
View file

@ -132,7 +132,7 @@
(wt-nl "{ cl_object " tag-loc ";")
(setq env-grows t)) ; just to ensure closing the block
(bind "new_frame_id()" tag-loc)
(wt-nl "if (frs_push(FRS_CATCH," tag-loc ")) {")
(wt-nl "if (frs_push(" tag-loc ")) {")
;; Allocate labels.
(dolist (tag body)
(when (and (tag-p tag) (plusp (tag-ref tag)))

1
src/cmp/sysfun.lsp
View file

@ -306,7 +306,6 @@
(proclaim-function si:frs-top (*) t)
(proclaim-function si::frs-vs (*) t)
(proclaim-function si:frs-bds (*) t)
(proclaim-function si:frs-class (*) t)
(proclaim-function si:frs-tag (*) t)
(proclaim-function si:frs-ihs (*) t)
(proclaim-function si:bds-top (*) t)

1
src/h/external.h
View file

@ -1229,7 +1229,6 @@ extern cl_object si_ihs_next(cl_object arg);
extern cl_object si_ihs_prev(cl_object arg);
extern cl_object si_frs_top(void);
extern cl_object si_frs_bds(cl_object arg);
extern cl_object si_frs_class(cl_object arg);
extern cl_object si_frs_tag(cl_object arg);
extern cl_object si_frs_ihs(cl_object arg);
extern cl_object si_bds_top(void);

56
src/h/stacks.h
View file

@ -92,40 +92,38 @@ extern cl_object ihs_top_function_name(void);
/***************
* FRAME STACK
***************/
/*
frs_class | frs_value | frs_prev
----------+--------------------------------------+--------------
CATCH | frame-id, i.e. |
| throw-tag, |
| block-id (uninterned symbol), or | value of ihs_top
| tagbody-id (uninterned symbol) | when the frame
----------+--------------------------------------| was pushed
CATCHALL | NIL |
----------+--------------------------------------|
PROTECT | NIL |
----------------------------------------------------------------
*/
enum fr_class {
FRS_CATCH, /* for catch,block,tabbody */
FRS_CATCHALL, /* for catchall */
FRS_PROTECT /* for protect-all */
};
/* Frames signal points in the code to which we can at any time jump.
* Frames are established, for instance, by CATCH, BLOCK, TAGBODY,
* LAMBDA, UNWIND-PROTECT, etc.
*
* Frames are established by frs_push(). For each call to frs_push()
* there must be a corresponding frs_pop(). More precisely, since our
* frame mechanism relies on the C stack and on the setjmp/longjmp
* functions, any function that creates a frame must also destroy it
* with frs_pop() before returning.
*
* Frames are identified by a value frs_val. This can be either a
* unique identifier, created for each CATCH, BLOCK, etc, or a common
* one ECL_PROTECT_TAG, used by UNWIND-PROTECT forms. The first type
* of frames can be target of a search frs_sch() and thus one can jump
* to them. The second type of frames are like barriers designed to
* intercept the jumps to the outer frames and are called
* automatically by the function unwind() whenever it jumps to a frame
* which is beyond one of these barriers.
*/
typedef struct ecl_frame {
jmp_buf frs_jmpbuf;
cl_object frs_val;
cl_object frs_lex;
bds_ptr frs_bds_top;
enum fr_class frs_class;
cl_object frs_val;
ihs_ptr frs_ihs;
cl_index frs_sp;
} *ecl_frame_ptr;
extern ecl_frame_ptr _frs_push(register enum fr_class clas, register cl_object val);
#define frs_push(class, val) ecl_setjmp(_frs_push(class, val)->frs_jmpbuf)
#define ECL_PROTECT_TAG OBJNULL
extern ecl_frame_ptr _frs_push(register cl_object val);
#define frs_push(val) ecl_setjmp(_frs_push(val)->frs_jmpbuf)
#define frs_pop() (cl_env.frs_top--)
/*******************
@ -178,7 +176,7 @@ cl_env.lex_env ------> ( tag0 value0 tag1 value1 ... )
#define CL_UNWIND_PROTECT_BEGIN {\
bool __unwinding; ecl_frame_ptr __next_fr; \
cl_index __nr; \
if (frs_push(FRS_PROTECT,Cnil)) { \
if (frs_push(ECL_PROTECT_TAG)) { \
__unwinding=1; __next_fr=cl_env.nlj_fr; \
} else {
@ -193,19 +191,19 @@ cl_env.lex_env ------> ( tag0 value0 tag1 value1 ... )
#define CL_BLOCK_BEGIN(id) { \
cl_object id = new_frame_id(); \
if (frs_push(FRS_CATCH,id) == 0)
if (frs_push(id) == 0)
#define CL_BLOCK_END } \
frs_pop()
#define CL_CATCH_BEGIN(tag) \
if (frs_push(FRS_CATCH,tag) == 0) {
if (frs_push(tag) == 0) {
#define CL_CATCH_END } \
frs_pop();
#define CL_CATCH_ALL_BEGIN \
if (frs_push(FRS_CATCH,Cnil) == 0) {
if (frs_push(ECL_PROTECT_TAG) == 0) {
#define CL_CATCH_ALL_IF_CAUGHT } else {