-/* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 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, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 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 library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * 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.
+ * This library 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
+ * Lesser General Public License for more details.
*
- * 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. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
#include "libguile/eq.h"
#include "libguile/dynwind.h"
#include "libguile/backtrace.h"
-#ifdef DEBUG_EXTENSIONS
#include "libguile/debug.h"
-#endif
#include "libguile/continuations.h"
#include "libguile/stackchk.h"
#include "libguile/stacks.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
+#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/throw.h"
\f
/* the jump buffer data structure */
-static int scm_tc16_jmpbuffer;
+static scm_t_bits tc16_jmpbuffer;
-#define SCM_JMPBUFP(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer))
+#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
-#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L)))
-#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L)))
+#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
+#define ACTIVATEJB(x) \
+ (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
+#define DEACTIVATEJB(x) \
+ (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
-#ifndef DEBUG_EXTENSIONS
#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
-#define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v)))
-#else
-#define SCM_JBDFRAME(x) ((scm_debug_frame *) SCM_CELL_WORD_0 (SCM_CDR (x)))
-#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (SCM_CDR (OBJ)))
-#define SCM_SETJBDFRAME(OBJ,X) (SCM_SET_CELL_WORD_0 (SCM_CDR (OBJ), (X)))
-#define SETJBJMPBUF(OBJ,X) (SCM_SET_CELL_WORD_1 (SCM_CDR (OBJ), (X)))
-
-static scm_sizet
-freejb (SCM jbsmob)
-{
- scm_must_free ((char *) SCM_CELL_WORD_1 (jbsmob));
- return sizeof (scm_cell);
-}
-#endif
+#define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
+#define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
+#define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
static int
-printjb (SCM exp, SCM port, scm_print_state *pstate)
+jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
scm_puts ("#<jmpbuffer ", port);
scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
scm_intprint((long) JBJMPBUF (exp), 16, port);
-
scm_putc ('>', port);
return 1 ;
}
-
static SCM
make_jmpbuf (void)
{
SCM answer;
SCM_REDEFER_INTS;
{
-#ifdef DEBUG_EXTENSIONS
- char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
-#endif
-#ifdef DEBUG_EXTENSIONS
- SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, mem);
-#else
- SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, 0);
-#endif
+ SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
}
will be found. */
SCM
-scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
+scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
{
struct jmp_buf_and_retval jbr;
SCM jmpbuf;
answer = SCM_EOL;
scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
SETJBJMPBUF(jmpbuf, &jbr.buf);
-#ifdef DEBUG_EXTENSIONS
SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
-#endif
if (setjmp (jbr.buf))
{
SCM throw_tag;
/* scm_internal_lazy_catch (the guts of lazy catching) */
/* The smob tag for lazy_catch smobs. */
-static long tc16_lazy_catch;
+static scm_t_bits tc16_lazy_catch;
/* This is the structure we put on the wind list for a lazy catch. It
stores the handler function to call, and the data pointer to pass
(We don't need anything like this in the "eager" catch code,
because the same C frame runs both the body and the handler.) */
struct lazy_catch {
- scm_catch_handler_t handler;
+ scm_t_catch_handler handler;
void *handler_data;
};
appear in normal data structures, only in the wind list. However,
it might be nice for debugging someday... */
static int
-print_lazy_catch (SCM closure, SCM port, scm_print_state *pstate)
+lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
{
struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure);
char buf[200];
SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
}
-#define SCM_LAZY_CATCH_P(obj) \
- (SCM_NIMP (obj) && (SCM_UNPACK_CAR (obj) == tc16_lazy_catch))
+#define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
/* 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. */
+ - The handler is not allowed to return. */
SCM
-scm_internal_lazy_catch (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_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data)
{
SCM lazy_catch, answer;
struct lazy_catch c;
\f
/* scm_internal_stack_catch
Use this one if you want debugging information to be stored in
- scm_the_last_stack_fluid on error. */
+ scm_the_last_stack_fluid_var on error. */
static SCM
-ss_handler (void *data, SCM tag, SCM throw_args)
+ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
{
/* Save the stack */
- scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid),
+ scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var),
scm_make_stack (SCM_BOOL_T, SCM_EOL));
/* Throw the error */
return scm_throw (tag, throw_args);
struct cwss_data
{
SCM tag;
- scm_catch_body_t body;
+ scm_t_catch_body body;
void *data;
};
SCM
scm_internal_stack_catch (SCM tag,
- scm_catch_body_t body,
+ scm_t_catch_body body,
void *body_data,
- scm_catch_handler_t handler,
+ scm_t_catch_handler handler,
void *handler_data)
{
struct cwss_data d;
{
struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
- return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
+ return scm_call_0 (c->body_proc);
}
{
SCM *handler_proc_p = (SCM *) handler_data;
- return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
+ return scm_apply_1 (*handler_proc_p, tag, throw_args);
}
/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
hbpca_body (void *body_data)
{
struct hbpca_data *data = (struct hbpca_data *)body_data;
- return scm_apply (data->proc, data->args, SCM_EOL);
+ return scm_apply_0 (data->proc, data->args);
}
SCM
int
scm_exit_status (SCM args)
{
- if (SCM_NNULLP (args))
+ if (!SCM_NULL_OR_NIL_P (args))
{
SCM cqa = SCM_CAR (args);
- if (SCM_INUMP (cqa))
- return (SCM_INUM (cqa));
- else if (SCM_FALSEP (cqa))
+ if (scm_is_integer (cqa))
+ return (scm_to_int (cqa));
+ else if (scm_is_false (cqa))
return 1;
}
return 0;
SCM parts = SCM_CADDR (args);
SCM rest = SCM_CDDDR (args);
- if (SCM_BACKTRACE_P && SCM_NFALSEP (stack))
+ if (SCM_BACKTRACE_P && scm_is_true (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);
+ scm_i_display_error (stack, p, subr, message, parts, rest);
}
else
{
message header to print; if zero, we use "guile" instead. That
text is followed by a colon, then the message described by ARGS. */
+/* Dirk:FIXME:: The name of the function should make clear that the
+ * application gets terminated.
+ */
+
SCM
scm_handle_by_message (void *handler_data, SCM tag, SCM args)
{
- if (SCM_NFALSEP (scm_eq_p (tag, SCM_CAR (scm_intern0 ("quit")))))
+ if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
{
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);
}
SCM
-scm_handle_by_throw (void *handler_data, SCM tag, SCM args)
+scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
{
scm_ithrow (tag, args, 1);
return SCM_UNSPECIFIED; /* never returns */
/* the Scheme-visible CATCH and LAZY-CATCH functions */
SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
- (SCM tag, SCM thunk, SCM handler),
+ (SCM key, 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"
+ "exceptions matching @var{key}. If thunk throws to the symbol\n"
+ "@var{key}, then @var{handler} is invoked this way:\n"
+ "@lisp\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}.")
+ "@end lisp\n"
+ "\n"
+ "@var{key} is a symbol or @code{#t}.\n"
+ "\n"
+ "@var{thunk} takes no arguments. If @var{thunk} returns\n"
+ "normally, that is the return value of @code{catch}.\n"
+ "\n"
+ "Handler is invoked outside the scope of its own @code{catch}.\n"
+ "If @var{handler} again throws to the same key, a new handler\n"
+ "from further up the call chain is invoked.\n"
+ "\n"
+ "If the key is @code{#t}, then a throw to @emph{any} symbol will\n"
+ "match this call to @code{catch}.")
#define FUNC_NAME s_scm_catch
{
struct scm_body_thunk_data c;
- SCM_ASSERT (SCM_SYMBOLP(tag) || SCM_TRUE_P (tag),
- tag, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
- c.tag = tag;
+ c.tag = key;
c.body_proc = thunk;
/* scm_internal_catch takes care of all the mechanics of setting up
- a catch tag; we tell it to call scm_body_thunk to run the body,
+ a catch key; we tell it to call scm_body_thunk to run the body,
and scm_handle_by_proc to deal with any throws to this catch.
The former receives a pointer to c, telling it how to behave.
The latter receives a pointer to HANDLER, so it knows who to call. */
- return scm_internal_catch (tag,
+ return scm_internal_catch (key,
scm_body_thunk, &c,
scm_handle_by_proc, &handler);
}
SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
- (SCM tag, SCM thunk, SCM handler),
- "")
+ (SCM key, SCM thunk, SCM handler),
+ "This behaves exactly like @code{catch}, except that it does\n"
+ "not unwind the stack before invoking @var{handler}.\n"
+ "The @var{handler} procedure is not allowed to return:\n"
+ "it must throw to another catch, or otherwise exit non-locally.")
#define FUNC_NAME s_scm_lazy_catch
{
struct scm_body_thunk_data c;
- SCM_ASSERT (SCM_SYMBOLP(tag) || SCM_TRUE_P (tag),
- tag, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (scm_is_symbol (key) || scm_is_eq (key, SCM_BOOL_T),
+ key, SCM_ARG1, FUNC_NAME);
- c.tag = tag;
+ c.tag = key;
c.body_proc = thunk;
/* scm_internal_lazy_catch takes care of all the mechanics of
- setting up a lazy catch tag; we tell it to call scm_body_thunk to
+ setting up a lazy catch key; we tell it to call scm_body_thunk to
run the body, and scm_handle_by_proc to deal with any throws to
this catch. The former receives a pointer to c, telling it how
to behave. The latter receives a pointer to HANDLER, so it knows
who to call. */
- return scm_internal_lazy_catch (tag,
+ return scm_internal_lazy_catch (key,
scm_body_thunk, &c,
scm_handle_by_proc, &handler);
}
"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.")
+ "@code{#t}.\n\n"
+ "If there is no handler at all, Guile prints an error and then exits.")
#define FUNC_NAME s_scm_throw
{
- SCM_VALIDATE_SYMBOL (1,key);
- /* May return if handled by lazy catch. */
+ SCM_VALIDATE_SYMBOL (1, key);
return scm_ithrow (key, args, 1);
}
#undef FUNC_NAME
SCM
-scm_ithrow (SCM key, SCM args, int noreturn)
+scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
{
SCM jmpbuf = SCM_UNDEFINED;
SCM wind_goal;
/* 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))
+ for (winds = scm_dynwinds; scm_is_pair (winds); winds = SCM_CDR (winds))
{
- if (! SCM_CONSP (winds))
- abort ();
-
dynpair = SCM_CAR (winds);
- if (SCM_CONSP (dynpair))
+ if (scm_is_pair (dynpair))
{
SCM this_key = SCM_CAR (dynpair);
- if (SCM_TRUE_P (this_key) || SCM_EQ_P (this_key, key))
+ if (scm_is_eq (this_key, SCM_BOOL_T) || scm_is_eq (this_key, key))
break;
}
}
- /* If we didn't find anything, abort. scm_boot_guile should
- have established a catch-all, but obviously things are
- thoroughly screwed up. */
- if (SCM_NULLP (winds))
- abort ();
-
- /* If the wind list is malformed, bail. */
- if (SCM_IMP (winds) || SCM_NCONSP (winds))
- abort ();
-
- if (!SCM_FALSEP (dynpair))
- jmpbuf = SCM_CDR (dynpair);
- else
+ /* If we didn't find anything, print a message and abort the process
+ right here. If you don't want this, establish a catch-all around
+ any code that might throw up. */
+ if (scm_is_null (winds))
{
- if (!noreturn)
- return SCM_UNSPECIFIED;
- else
- {
- 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);
-#endif
- longjmp (SCM_JMPBUF (scm_rootcont), 1);
- }
+ scm_handle_by_message (NULL, key, args);
+ abort ();
}
+ /* If the wind list is malformed, bail. */
+ if (!scm_is_pair (winds))
+ abort ();
+
+ jmpbuf = SCM_CDR (dynpair);
+
for (wind_goal = scm_dynwinds;
- !SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf);
+ !scm_is_eq (SCM_CDAR (wind_goal), jmpbuf);
wind_goal = SCM_CDR (wind_goal))
;
if (SCM_LAZY_CATCH_P (jmpbuf))
{
struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf);
- SCM oldwinds = scm_dynwinds;
SCM handle, answer;
scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
- scm_ilength (wind_goal)));
scm_dynwinds = SCM_CDR (scm_dynwinds);
SCM_REALLOW_INTS;
answer = (c->handler) (c->handler_data, key, args);
- SCM_REDEFER_INTS;
- SCM_SETCDR (handle, scm_dynwinds);
- scm_dynwinds = handle;
- SCM_REALLOW_INTS;
- scm_dowinds (oldwinds, (scm_ilength (scm_dynwinds)
- - scm_ilength (oldwinds)));
- return answer;
+ scm_misc_error ("throw", "lazy-catch handler did return.", SCM_EOL);
}
/* Otherwise, it's a normal catch. */
jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
jbr->throw_tag = key;
jbr->retval = args;
+ scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
+ longjmp (*JBJMPBUF (jmpbuf), 1);
}
/* Otherwise, it's some random piece of junk. */
else
abort ();
-
-#ifdef DEBUG_EXTENSIONS
- scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
-#endif
- longjmp (*JBJMPBUF (jmpbuf), 1);
}
void
scm_init_throw ()
{
- 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);
+ tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
+ scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
+
+ tc16_lazy_catch = scm_make_smob_type ("lazy-catch", 0);
+ scm_set_smob_print (tc16_lazy_catch, lazy_catch_print);
+
#include "libguile/throw.x"
}
HCoop / bpt / guile.git / blobdiff