mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 12:20:26 +02:00
b20b27776f
see if a given element of scm_dynwinds is a valid catch. * throw.c (scm_ithrow): If scm_dynwinds has invalid list structure, abort; don't just silently ignore the garbage.
328 lines
8.5 KiB
C
328 lines
8.5 KiB
C
/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
|
||
*
|
||
* This program is free software; you can redistribute it and/or modify
|
||
* it under the terms of the GNU General Public License as published by
|
||
* the Free Software Foundation; either version 2, or (at your option)
|
||
* any later version.
|
||
*
|
||
* This program is distributed in the hope that it will be useful,
|
||
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
* GNU General Public License for more details.
|
||
*
|
||
* You should have received a copy of the GNU General Public License
|
||
* along with this software; see the file COPYING. If not, write to
|
||
* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
||
*
|
||
* As a special exception, the Free Software Foundation gives permission
|
||
* for additional uses of the text contained in its release of GUILE.
|
||
*
|
||
* The exception is that, if you link the GUILE library with other files
|
||
* to produce an executable, this does not by itself cause the
|
||
* resulting executable to be covered by the GNU General Public License.
|
||
* Your use of that executable is in no way restricted on account of
|
||
* linking the GUILE library code into it.
|
||
*
|
||
* This exception does not however invalidate any other reasons why
|
||
* the executable file might be covered by the GNU General Public License.
|
||
*
|
||
* This exception applies only to the code released by the
|
||
* Free Software Foundation under the name GUILE. If you copy
|
||
* code from other Free Software Foundation releases into a copy of
|
||
* GUILE, as the General Public License permits, the exception does
|
||
* not apply to the code that you add in this way. To avoid misleading
|
||
* anyone as to the status of such modified files, you must delete
|
||
* this exception notice from them.
|
||
*
|
||
* If you write modifications of your own for GUILE, it is your choice
|
||
* whether to permit this exception to apply to your modifications.
|
||
* If you do not wish that, delete this exception notice.
|
||
*/
|
||
|
||
|
||
#include <stdio.h>
|
||
#include "_scm.h"
|
||
#include "genio.h"
|
||
#include "smob.h"
|
||
#include "alist.h"
|
||
#include "eval.h"
|
||
#include "dynwind.h"
|
||
#ifdef DEBUG_EXTENSIONS
|
||
#include "debug.h"
|
||
#endif
|
||
#include "continuations.h"
|
||
#include "stackchk.h"
|
||
|
||
#include "throw.h"
|
||
|
||
|
||
/* {Catch and Throw}
|
||
*/
|
||
static int scm_tc16_jmpbuffer;
|
||
|
||
#define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
|
||
#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
|
||
#define ACTIVATEJB(O) (SCM_CAR (O) |= (1L << 16L))
|
||
#define DEACTIVATEJB(O) (SCM_CAR (O) &= ~(1L << 16L))
|
||
|
||
#ifndef DEBUG_EXTENSIONS
|
||
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
|
||
#define SETJBJMPBUF SCM_SETCDR
|
||
#else
|
||
#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
|
||
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
|
||
#define SCM_SETJBDFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X)
|
||
#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
|
||
|
||
static scm_sizet freejb SCM_P ((SCM jbsmob));
|
||
|
||
static scm_sizet
|
||
freejb (jbsmob)
|
||
SCM jbsmob;
|
||
{
|
||
scm_must_free ((char *) SCM_CDR (jbsmob));
|
||
return sizeof (scm_cell);
|
||
}
|
||
#endif
|
||
|
||
static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
|
||
static int
|
||
printjb (exp, port, pstate)
|
||
SCM exp;
|
||
SCM port;
|
||
scm_print_state *pstate;
|
||
{
|
||
scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
|
||
scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
|
||
scm_intprint((SCM) JBJMPBUF(exp), 16, port);
|
||
scm_gen_putc ('>', port);
|
||
return 1 ;
|
||
}
|
||
|
||
static scm_smobfuns jbsmob = {
|
||
scm_mark0,
|
||
#ifdef DEBUG_EXTENSIONS
|
||
freejb,
|
||
#else
|
||
scm_free0,
|
||
#endif
|
||
printjb,
|
||
0
|
||
};
|
||
|
||
static SCM make_jmpbuf SCM_P ((void));
|
||
static SCM
|
||
make_jmpbuf ()
|
||
{
|
||
SCM answer;
|
||
SCM_NEWCELL (answer);
|
||
SCM_REDEFER_INTS;
|
||
{
|
||
#ifdef DEBUG_EXTENSIONS
|
||
char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
|
||
SCM_SETCDR (answer, (SCM) mem);
|
||
#endif
|
||
SCM_CAR(answer) = scm_tc16_jmpbuffer;
|
||
SETJBJMPBUF(answer, (jmp_buf *)0);
|
||
DEACTIVATEJB(answer);
|
||
}
|
||
SCM_REALLOW_INTS;
|
||
return answer;
|
||
}
|
||
|
||
struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
|
||
{
|
||
jmp_buf buf; /* must be first */
|
||
SCM throw_tag;
|
||
SCM retval;
|
||
};
|
||
|
||
SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
|
||
SCM
|
||
scm_catch (tag, thunk, handler)
|
||
SCM tag;
|
||
SCM thunk;
|
||
SCM handler;
|
||
{
|
||
struct jmp_buf_and_retval jbr;
|
||
SCM jmpbuf;
|
||
SCM answer;
|
||
|
||
SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T),
|
||
tag, SCM_ARG1, s_catch);
|
||
jmpbuf = make_jmpbuf ();
|
||
answer = SCM_EOL;
|
||
scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
|
||
SETJBJMPBUF(jmpbuf, &jbr.buf);
|
||
#ifdef DEBUG_EXTENSIONS
|
||
SCM_SETJBDFRAME(jmpbuf, last_debug_info_frame);
|
||
#endif
|
||
if (setjmp (jbr.buf))
|
||
{
|
||
SCM throw_tag;
|
||
SCM throw_args;
|
||
|
||
#ifdef STACK_CHECKING
|
||
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
|
||
#endif
|
||
SCM_REDEFER_INTS;
|
||
DEACTIVATEJB (jmpbuf);
|
||
scm_dynwinds = SCM_CDR (scm_dynwinds);
|
||
SCM_REALLOW_INTS;
|
||
throw_args = jbr.retval;
|
||
throw_tag = jbr.throw_tag;
|
||
jbr.throw_tag = SCM_EOL;
|
||
jbr.retval = SCM_EOL;
|
||
answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL);
|
||
}
|
||
else
|
||
{
|
||
ACTIVATEJB (jmpbuf);
|
||
answer = scm_apply (thunk,
|
||
((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL),
|
||
SCM_EOL);
|
||
SCM_REDEFER_INTS;
|
||
DEACTIVATEJB (jmpbuf);
|
||
scm_dynwinds = SCM_CDR (scm_dynwinds);
|
||
SCM_REALLOW_INTS;
|
||
}
|
||
return answer;
|
||
}
|
||
|
||
|
||
/* The user has thrown to an uncaught key --- print a message and die.
|
||
1) If the user wants something different, they can use (catch #t
|
||
...) to do what they like.
|
||
2) Outside the context of a read-eval-print loop, there isn't
|
||
anything else good to do; libguile should not assume the existence
|
||
of a read-eval-print loop.
|
||
3) Given that we shouldn't do anything complex, it's much more
|
||
robust to do it in C code. */
|
||
static SCM uncaught_throw SCM_P ((SCM key, SCM args));
|
||
static SCM
|
||
uncaught_throw (key, args)
|
||
SCM key;
|
||
SCM args;
|
||
{
|
||
SCM p = scm_def_errp;
|
||
scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p);
|
||
scm_prin1 (key, p, 0);
|
||
scm_gen_puts (scm_regular_string, ": ", p);
|
||
scm_prin1 (args, p, 1);
|
||
scm_gen_putc ('\n', p);
|
||
|
||
exit (2);
|
||
}
|
||
|
||
|
||
static char s_throw[];
|
||
SCM
|
||
scm_ithrow (key, args, noreturn)
|
||
SCM key;
|
||
SCM args;
|
||
int noreturn;
|
||
{
|
||
SCM jmpbuf;
|
||
SCM wind_goal;
|
||
|
||
if (SCM_NIMP (key) && SCM_JMPBUFP (key))
|
||
{
|
||
jmpbuf = key;
|
||
if (noreturn)
|
||
{
|
||
SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf,
|
||
"throw to dynamically inactive catch",
|
||
s_throw);
|
||
}
|
||
else if (!JBACTIVE (jmpbuf))
|
||
return SCM_UNSPECIFIED;
|
||
}
|
||
else
|
||
{
|
||
SCM dynpair;
|
||
SCM winds;
|
||
|
||
if (noreturn)
|
||
{
|
||
SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1,
|
||
s_throw);
|
||
}
|
||
else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key)))
|
||
return SCM_UNSPECIFIED;
|
||
|
||
/* Search the wind list for an appropriate catch.
|
||
"Waiter, please bring us the wind list." */
|
||
for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds))
|
||
{
|
||
if (! SCM_CONSP (winds))
|
||
abort ();
|
||
|
||
dynpair = SCM_CAR (winds);
|
||
if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair))
|
||
{
|
||
SCM this_key = SCM_CAR (dynpair);
|
||
|
||
if (this_key == SCM_BOOL_T || this_key == key)
|
||
break;
|
||
}
|
||
}
|
||
|
||
/* If we didn't find anything, print a message and exit Guile. */
|
||
if (winds == SCM_EOL)
|
||
uncaught_throw (key, args);
|
||
|
||
if (SCM_IMP (winds) || SCM_NCONSP (winds))
|
||
abort ();
|
||
|
||
if (dynpair != SCM_BOOL_F)
|
||
jmpbuf = SCM_CDR (dynpair);
|
||
else
|
||
{
|
||
if (!noreturn)
|
||
return SCM_UNSPECIFIED;
|
||
else
|
||
{
|
||
scm_exitval = scm_cons (key, args);
|
||
scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
|
||
#ifdef DEBUG_EXTENSIONS
|
||
last_debug_info_frame = SCM_DFRAME (scm_rootcont);
|
||
#endif
|
||
longjmp (SCM_JMPBUF (scm_rootcont), 1);
|
||
}
|
||
}
|
||
}
|
||
for (wind_goal = scm_dynwinds;
|
||
SCM_CDAR (wind_goal) != jmpbuf;
|
||
wind_goal = SCM_CDR (wind_goal))
|
||
;
|
||
{
|
||
struct jmp_buf_and_retval * jbr;
|
||
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
|
||
jbr->throw_tag = key;
|
||
jbr->retval = args;
|
||
}
|
||
scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
|
||
#ifdef DEBUG_EXTENSIONS
|
||
last_debug_info_frame = SCM_JBDFRAME (jmpbuf);
|
||
#endif
|
||
longjmp (*JBJMPBUF (jmpbuf), 1);
|
||
}
|
||
|
||
|
||
SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
|
||
SCM
|
||
scm_throw (key, args)
|
||
SCM key;
|
||
SCM args;
|
||
{
|
||
scm_ithrow (key, args, 1);
|
||
return SCM_BOOL_F; /* never really returns */
|
||
}
|
||
|
||
|
||
void
|
||
scm_init_throw ()
|
||
{
|
||
scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
|
||
#include "throw.x"
|
||
}
|