-/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998 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
* 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. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
\f
#include <stdio.h>
#endif
#include "continuations.h"
#include "stackchk.h"
+#include "stacks.h"
+#include "fluids.h"
+#include "validate.h"
#include "throw.h"
\f
/* the jump buffer data structure */
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_SETOR_CAR (O, (1L << 16L)))
-#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
+#define SCM_JMPBUFP(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer))
+
+#define JBACTIVE(OBJ) (SCM_CARW (OBJ) & (1L << 16L))
+#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L)))
+#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L)))
#ifndef DEBUG_EXTENSIONS
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
+#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (OBJ) )
#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_SETCAR (SCM_CDR (O), (SCM)(X))
-#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
-
-static scm_sizet freejb SCM_P ((SCM jbsmob));
+#define SCM_JBDFRAME(OBJ) ((scm_debug_frame*)SCM_CAR (SCM_CDR (OBJ)) )
+#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (SCM_CDR (OBJ)) )
+#define SCM_SETJBDFRAME(OBJ,X) SCM_SETCAR (SCM_CDR (OBJ), (SCM)(X))
+#define SETJBJMPBUF(OBJ,X) SCM_SETCDR(SCM_CDR (OBJ), X)
static scm_sizet
-freejb (jbsmob)
- SCM jbsmob;
+freejb (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;
+printjb (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);
+ scm_puts ("#<jmpbuffer ", port);
+ scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
+ scm_intprint(SCM_ASWORD ( JBJMPBUF(exp) ), 16, port);
+
+ scm_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 ()
+make_jmpbuf (void)
{
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_SETCAR (answer, scm_tc16_jmpbuffer);
+#ifdef DEBUG_EXTENSIONS
+ SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, mem);
+#else
+ SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, 0);
+#endif
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
}
TAG, but it could be something else if TAG was #t (i.e., a
catch-all), or the user threw to a jmpbuf.
THROW_ARGS is the list of arguments the user passed to the THROW
- function.
+ function, after the tag.
BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
is just a pointer we pass through to HANDLER. We don't actually
will be found. */
SCM
-scm_internal_catch (tag, body, body_data, handler, handler_data)
- SCM tag;
- scm_catch_body_t body;
- void *body_data;
- scm_catch_handler_t handler;
- void *handler_data;
+scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
{
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
else
{
ACTIVATEJB (jmpbuf);
- answer = body (body_data, jmpbuf);
+ answer = body (body_data);
SCM_REDEFER_INTS;
DEACTIVATEJB (jmpbuf);
scm_dynwinds = SCM_CDR (scm_dynwinds);
sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
(long) c->handler, (long) c->handler_data);
- scm_gen_puts (scm_regular_string, buf, port);
+ scm_puts (buf, port);
return 1;
}
-static scm_smobfuns lazy_catch_funs = {
- scm_mark0, scm_free0, print_lazy_catch, 0
-};
-
/* Given a pointer to a lazy catch structure, return a smob for it,
suitable for inclusion in the wind list. ("Ah yes, a Château
static SCM
make_lazy_catch (struct lazy_catch *c)
{
- SCM smob;
-
- SCM_NEWCELL (smob);
- SCM_SETCDR (smob, c);
- SCM_SETCAR (smob, tc16_lazy_catch);
-
- return smob;
+ SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
}
#define SCM_LAZY_CATCH_P(obj) \
- (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch))
+ (SCM_NIMP (obj) && (SCM_CARW (obj) == tc16_lazy_catch))
/* Exactly like scm_internal_catch, except:
- It does not unwind the stack (this is the major difference).
- - If handler returns, its value is returned from the throw.
- - BODY always receives #f as its JMPBUF argument (since there's no
- jmpbuf associated with a lazy catch, because we don't unwind the
- stack.) */
+ - If handler returns, its value is returned from the throw. */
SCM
-scm_internal_lazy_catch (tag, body, body_data, handler, handler_data)
- SCM tag;
- scm_catch_body_t body;
- void *body_data;
- scm_catch_handler_t handler;
- void *handler_data;
+scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
{
SCM lazy_catch, answer;
struct lazy_catch c;
scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
SCM_REALLOW_INTS;
- answer = (*body) (body_data, SCM_BOOL_F);
+ answer = (*body) (body_data);
SCM_REDEFER_INTS;
scm_dynwinds = SCM_CDR (scm_dynwinds);
return answer;
}
+\f
+/* scm_internal_stack_catch
+ Use this one if you want debugging information to be stored in
+ scm_the_last_stack_fluid on error. */
+
+static SCM
+ss_handler (void *data, SCM tag, SCM throw_args)
+{
+ /* Save the stack */
+ scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid),
+ scm_make_stack (scm_cons (SCM_BOOL_T, SCM_EOL)));
+ /* Throw the error */
+ return scm_throw (tag, throw_args);
+}
+
+struct cwss_data
+{
+ SCM tag;
+ scm_catch_body_t body;
+ void *data;
+};
+
+static SCM
+cwss_body (void *data)
+{
+ struct cwss_data *d = data;
+ return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
+}
+
+SCM
+scm_internal_stack_catch (SCM tag,
+ scm_catch_body_t body,
+ void *body_data,
+ scm_catch_handler_t handler,
+ void *handler_data)
+{
+ struct cwss_data d;
+ d.tag = tag;
+ d.body = body;
+ d.data = body_data;
+ return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
+}
+
\f
-/* body and handler functions for use with either of the above */
+/* body and handler functions for use with any of the above catch variants */
/* This is a body function you can pass to scm_internal_catch if you
- want the body to be like Scheme's `catch' --- a thunk, or a
- function of one argument if the tag is #f.
+ want the body to be like Scheme's `catch' --- a thunk.
BODY_DATA is a pointer to a scm_body_thunk_data structure, which
contains the Scheme procedure to invoke as the body, and the tag
- we're catching. If the tag is #f, then we pass JMPBUF (created by
- scm_internal_catch) to the body procedure; otherwise, the body gets
- no arguments. */
+ we're catching. */
SCM
-scm_body_thunk (body_data, jmpbuf)
- void *body_data;
- SCM jmpbuf;
+scm_body_thunk (void *body_data)
{
struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
- if (c->tag == SCM_BOOL_F)
- return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL);
- else
- return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
+ return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
}
/* This is a handler function you can pass to scm_internal_catch if
- you want the handler to act like Scheme's catch --- call a
- procedure with the tag and the throw arguments.
+ you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
+ applies a handler procedure to (TAG ARGS ...).
If the user does a throw to this catch, this function runs a
handler procedure written in Scheme. HANDLER_DATA is a pointer to
the stack), or the procedure object should be otherwise protected
from GC. */
SCM
-scm_handle_by_proc (handler_data, tag, throw_args)
- void *handler_data;
- SCM tag;
- SCM throw_args;
+scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
{
SCM *handler_proc_p = (SCM *) handler_data;
return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
}
+/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
+ catches all throws that the handler might emit itself. The handler
+ used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
+
+struct hbpca_data {
+ SCM proc;
+ SCM args;
+};
+
+static SCM
+hbpca_body (void *body_data)
+{
+ struct hbpca_data *data = (struct hbpca_data *)body_data;
+ return scm_apply (data->proc, data->args, SCM_EOL);
+}
+
+SCM
+scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
+{
+ SCM *handler_proc_p = (SCM *) handler_data;
+ struct hbpca_data data;
+ data.proc = *handler_proc_p;
+ data.args = scm_cons (tag, throw_args);
+
+ return scm_internal_catch (SCM_BOOL_T,
+ hbpca_body, &data,
+ scm_handle_by_message_noexit, NULL);
+}
/* Derive the an exit status from the arguments to (quit ...). */
int
-scm_exit_status (args)
- SCM args;
+scm_exit_status (SCM args)
{
if (SCM_NNULLP (args))
{
handler_message (void *handler_data, SCM tag, SCM args)
{
char *prog_name = (char *) handler_data;
- SCM p = scm_def_errp;
-
- if (! prog_name)
- prog_name = "guile";
-
- scm_gen_puts (scm_regular_string, prog_name, p);
- scm_gen_puts (scm_regular_string, ": ", p);
+ SCM p = scm_cur_errp;
if (scm_ilength (args) >= 3)
{
+ SCM stack = scm_make_stack (SCM_LIST1 (SCM_BOOL_T));
+ SCM subr = SCM_CAR (args);
SCM message = SCM_CADR (args);
- SCM parts = SCM_CADDR (args);
+ SCM parts = SCM_CADDR (args);
+ SCM rest = SCM_CDDDR (args);
- scm_display_error_message (message, parts, p);
+ if (SCM_BACKTRACE_P && SCM_NFALSEP (stack))
+ {
+ scm_puts ("Backtrace:\n", p);
+ scm_display_backtrace (stack, p, SCM_UNDEFINED, SCM_UNDEFINED);
+ scm_newline (p);
+ }
+ scm_display_error (stack, p, subr, message, parts, rest);
}
else
{
- scm_gen_puts (scm_regular_string, "uncaught throw to ", p);
+ if (! prog_name)
+ prog_name = "guile";
+
+ scm_puts (prog_name, p);
+ scm_puts (": ", p);
+
+ scm_puts ("uncaught throw to ", p);
scm_prin1 (tag, p, 0);
- scm_gen_puts (scm_regular_string, ": ", p);
+ scm_puts (": ", p);
scm_prin1 (args, p, 1);
- scm_gen_putc ('\n', p);
+ scm_putc ('\n', p);
}
}
text is followed by a colon, then the message described by ARGS. */
SCM
-scm_handle_by_message (handler_data, tag, args)
- void *handler_data;
- SCM tag;
- SCM args;
+scm_handle_by_message (void *handler_data, SCM tag, SCM args)
{
if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit")))))
- exit (scm_exit_status (args));
+ {
+ exit (scm_exit_status (args));
+ }
handler_message (handler_data, tag, args);
-
+ /* try to flush the error message first before the rest of the
+ ports: if any throw error, it currently causes a bus
+ exception. */
exit (2);
}
enough about the body to handle things in a better way, but don't
want to let throws fall off the bottom of the wind list. */
SCM
-scm_handle_by_message_noexit (handler_data, tag, args)
- void *handler_data;
- SCM tag;
- SCM args;
+scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
{
handler_message (handler_data, tag, args);
}
+SCM
+scm_handle_by_throw (void *handler_data, SCM tag, SCM args)
+{
+ scm_ithrow (tag, args, 1);
+ return SCM_UNSPECIFIED; /* never returns */
+}
+
+
\f
/* the Scheme-visible CATCH and LAZY-CATCH functions */
-SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
-SCM
-scm_catch (tag, thunk, handler)
- SCM tag;
- SCM thunk;
- SCM handler;
+SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
+ (SCM tag, SCM thunk, SCM handler),
+ "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
+ "exceptions matching @var{key}. If thunk throws to the symbol @var{key},\n"
+ "then @var{handler} is invoked this way:\n\n"
+ "@example\n"
+ "(handler key args ...)\n"
+ "@end example\n\n"
+ "@var{key} is a symbol or #t.\n\n"
+ "@var{thunk} takes no arguments. If @var{thunk} returns normally, that\n"
+ "is the return value of @code{catch}.\n\n"
+ "Handler is invoked outside the scope of its own @code{catch}. If\n"
+ "@var{handler} again throws to the same key, a new handler from further\n"
+ "up the call chain is invoked.\n\n"
+ "If the key is @code{#t}, then a throw to @emph{any} symbol will match\n"
+ "this call to @code{catch}.")
+#define FUNC_NAME s_scm_catch
{
struct scm_body_thunk_data c;
- SCM_ASSERT ((tag == SCM_BOOL_F)
- || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
- || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_catch);
+ SCM_ASSERT (SCM_SYMBOLP(tag) || tag == SCM_BOOL_T,
+ tag, SCM_ARG1, FUNC_NAME);
c.tag = tag;
c.body_proc = thunk;
scm_body_thunk, &c,
scm_handle_by_proc, &handler);
}
+#undef FUNC_NAME
-SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
-SCM
-scm_lazy_catch (tag, thunk, handler)
- SCM tag;
- SCM thunk;
- SCM handler;
+SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
+ (SCM tag, SCM thunk, SCM handler),
+ "")
+#define FUNC_NAME s_scm_lazy_catch
{
struct scm_body_thunk_data c;
- SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
- || (tag == SCM_BOOL_T),
- tag, SCM_ARG1, s_lazy_catch);
+ SCM_ASSERT (SCM_SYMBOLP(tag) || (tag == SCM_BOOL_T),
+ tag, SCM_ARG1, FUNC_NAME);
c.tag = tag;
c.body_proc = thunk;
scm_body_thunk, &c,
scm_handle_by_proc, &handler);
}
+#undef FUNC_NAME
\f
/* throwing */
-SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
-SCM
-scm_throw (key, args)
- SCM key;
- SCM args;
+SCM_DEFINE (scm_throw, "throw", 1, 0, 1,
+ (SCM key, SCM args),
+ "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
+ "@var{handler}. \n\n"
+ "@var{key} is a symbol. It will match catches of the same symbol or of\n"
+ "#t.\n\n"
+ "If there is no handler at all, an error is signaled.")
+#define FUNC_NAME s_scm_throw
{
+ SCM_VALIDATE_SYMBOL (1,key);
/* May return if handled by lazy catch. */
return scm_ithrow (key, args, 1);
}
+#undef FUNC_NAME
SCM
-scm_ithrow (key, args, noreturn)
- SCM key;
- SCM args;
- int noreturn;
+scm_ithrow (SCM key, SCM args, int noreturn)
{
- SCM jmpbuf;
+ SCM jmpbuf = SCM_UNDEFINED;
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_UNDEFINED;
- SCM winds;
+ SCM dynpair = SCM_UNDEFINED;
+ 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 ();
- /* 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))
+ dynpair = SCM_CAR (winds);
+ if (SCM_CONSP (dynpair))
{
- if (! SCM_CONSP (winds))
- abort ();
+ SCM this_key = SCM_CAR (dynpair);
- 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 (this_key == SCM_BOOL_T || this_key == key)
+ break;
}
+ }
- /* If we didn't find anything, abort. scm_boot_guile should
+ /* If we didn't find anything, abort. scm_boot_guile should
have established a catch-all, but obviously things are
thoroughly screwed up. */
- if (winds == SCM_EOL)
- abort ();
+ if (winds == SCM_EOL)
+ abort ();
/* If the wind list is malformed, bail. */
- if (SCM_IMP (winds) || SCM_NCONSP (winds))
- abort ();
+ if (SCM_IMP (winds) || SCM_NCONSP (winds))
+ abort ();
- if (dynpair != SCM_BOOL_F)
- jmpbuf = SCM_CDR (dynpair);
+ if (dynpair != SCM_BOOL_F)
+ jmpbuf = SCM_CDR (dynpair);
+ else
+ {
+ if (!noreturn)
+ return SCM_UNSPECIFIED;
else
{
- if (!noreturn)
- return SCM_UNSPECIFIED;
- else
- {
- scm_exitval = scm_cons (key, args);
- scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
+ scm_exitval = scm_cons (key, args);
+ scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
+ scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
#endif
- longjmp (SCM_JMPBUF (scm_rootcont), 1);
- }
+ longjmp (SCM_JMPBUF (scm_rootcont), 1);
}
}
+
for (wind_goal = scm_dynwinds;
SCM_CDAR (wind_goal) != jmpbuf;
wind_goal = SCM_CDR (wind_goal))
void
scm_init_throw ()
{
- scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
- tc16_lazy_catch = scm_newsmob (&lazy_catch_funs);
+ scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer",
+#ifdef DEBUG_EXTENSIONS
+ sizeof (scm_cell),
+ NULL, /* mark */
+ freejb,
+#else
+ 0,
+ NULL, /* mark */
+ NULL,
+#endif
+ printjb,
+ NULL);
+
+ tc16_lazy_catch = scm_make_smob_type_mfpe ("lazy-catch", 0,
+ NULL,
+ NULL,
+ print_lazy_catch,
+ NULL);
#include "throw.x"
}
HCoop / bpt / guile.git / blobdiff