-/* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001 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
\f
/* the jump buffer data structure */
-static int scm_tc16_jmpbuffer;
+static scm_bits_t 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))))
#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
#define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v)))
#endif
static int
-printjb (SCM exp, SCM port, scm_print_state *pstate)
+jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate)
{
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_REDEFER_INTS;
{
#ifdef DEBUG_EXTENSIONS
- SCM_NEWSMOB2 (answer, scm_tc16_jmpbuffer, 0, 0);
+ SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
#else
- SCM_NEWSMOB (answer, scm_tc16_jmpbuffer, 0);
+ SCM_NEWSMOB (answer, tc16_jmpbuffer, 0);
#endif
SETJBJMPBUF(answer, (jmp_buf *)0);
DEACTIVATEJB(answer);
/* scm_internal_lazy_catch (the guts of lazy catching) */
/* The smob tag for lazy_catch smobs. */
-static long tc16_lazy_catch;
+static scm_bits_t 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
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)
{
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_SMOB_PREDICATE (tc16_lazy_catch, obj))
+#define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
/* Exactly like scm_internal_catch, except:
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_NFALSEP (scm_eq_p (tag, scm_str2symbol ("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);
}
/* 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_EQ_P (tag, SCM_BOOL_T),
- tag, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (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 (this is the major difference), and if\n"
+ "handler returns, its value is returned from the throw.")
#define FUNC_NAME s_scm_lazy_catch
{
struct scm_body_thunk_data c;
- SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T),
- tag, SCM_ARG1, FUNC_NAME);
+ SCM_ASSERT (SCM_SYMBOLP (key) || SCM_EQ_P (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);
}
"@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.")
+ "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);
/* 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_CONSP (winds); winds = SCM_CDR (winds))
{
- if (! SCM_CONSP (winds))
- abort ();
-
dynpair = SCM_CAR (winds);
if (SCM_CONSP (dynpair))
{
}
}
- /* 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 ();
+#ifdef __GNUC__
+ /* Dirk:FIXME:: This bugfix should be removed some time. */
+ /* GCC 2.95.2 has a bug in its optimizer that makes it generate
+ incorrect code sometimes. This barrier stops it from being too
+ clever. */
+ asm volatile ("" : "=g" (winds));
+#endif
- /* 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_NULLP (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_CONSP (winds))
+ abort ();
+
+ jmpbuf = SCM_CDR (dynpair);
+
for (wind_goal = scm_dynwinds;
!SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf);
wind_goal = SCM_CDR (wind_goal))
void
scm_init_throw ()
{
- scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer",
- 0,
- NULL, /* mark */
- NULL,
- 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);
+
+#ifndef SCM_MAGIC_SNARFER
#include "libguile/throw.x"
+#endif
}
/*
HCoop / bpt / guile.git / blobdiff