-/* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000 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
#include <stdio.h>
-#include "_scm.h"
-#include "genio.h"
-#include "smob.h"
-#include "alist.h"
-#include "eval.h"
-#include "eq.h"
-#include "dynwind.h"
-#include "backtrace.h"
+#include "libguile/_scm.h"
+#include "libguile/smob.h"
+#include "libguile/alist.h"
+#include "libguile/eval.h"
+#include "libguile/eq.h"
+#include "libguile/dynwind.h"
+#include "libguile/backtrace.h"
#ifdef DEBUG_EXTENSIONS
-#include "debug.h"
+#include "libguile/debug.h"
#endif
-#include "continuations.h"
-#include "stackchk.h"
-#include "stacks.h"
-#include "fluids.h"
+#include "libguile/continuations.h"
+#include "libguile/stackchk.h"
+#include "libguile/stacks.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
-#include "scm_validate.h"
-#include "throw.h"
+#include "libguile/validate.h"
+#include "libguile/throw.h"
\f
/* the jump buffer data structure */
-static int scm_tc16_jmpbuffer;
+static scm_bits_t 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_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-#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_SETCAR (SCM_CDR (O), (SCM)(X))
-#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
+#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)))
-static scm_sizet
-freejb (SCM jbsmob)
-{
- scm_must_free ((char *) SCM_CDR (jbsmob));
- return sizeof (scm_cell);
-}
+#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
+#define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v)))
+#ifdef DEBUG_EXTENSIONS
+#define SCM_JBDFRAME(x) ((scm_debug_frame *) SCM_CELL_WORD_2 (x))
+#define SCM_SETJBDFRAME(x,v) (SCM_SET_CELL_WORD_2 ((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((SCM) JBJMPBUF(exp), 16, port);
+ scm_intprint((long) JBJMPBUF (exp), 16, port);
scm_putc ('>', port);
return 1 ;
}
-
static SCM
make_jmpbuf (void)
{
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);
+ 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);
BODY is a pointer to a C function which runs the body of the catch;
this is the code you can throw from. We call it like this:
- BODY (BODY_DATA, JMPBUF)
+ BODY (BODY_DATA)
where:
BODY_DATA is just the BODY_DATA argument we received; we pass it
through to BODY as its first argument. The caller can make
BODY_DATA point to anything useful that BODY might need.
- JMPBUF is the Scheme jmpbuf object corresponding to this catch,
- which we have just created and initialized.
HANDLER is a pointer to a C function to deal with a throw to TAG,
should one occur. We call it like this:
/* 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_CDR (closure);
+ struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure);
char buf[200];
sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
}
-#define SCM_LAZY_CATCH_P(obj) \
- (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch))
+#define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
/* Exactly like scm_internal_catch, except:
{
/* Save the stack */
scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid),
- scm_make_stack (scm_cons (SCM_BOOL_T, SCM_EOL)));
+ scm_make_stack (SCM_BOOL_T, SCM_EOL));
/* Throw the error */
return scm_throw (tag, throw_args);
}
if (scm_ilength (args) >= 3)
{
- SCM stack = scm_make_stack (SCM_LIST1 (SCM_BOOL_T));
+ SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
SCM subr = SCM_CAR (args);
SCM message = SCM_CADR (args);
SCM parts = SCM_CADDR (args);
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);
}
\f
/* the Scheme-visible CATCH and LAZY-CATCH functions */
-GUILE_PROC(scm_catch, "catch", 3, 0, 0,
+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 ((SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || tag == SCM_BOOL_T,
+ SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T),
tag, SCM_ARG1, FUNC_NAME);
c.tag = tag;
#undef FUNC_NAME
-GUILE_PROC(scm_lazy_catch, "lazy-catch", 3, 0, 0,
+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),
+ SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T),
tag, SCM_ARG1, FUNC_NAME);
c.tag = tag;
\f
/* throwing */
-GUILE_PROC(scm_throw, "throw", 1, 0, 1,
+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);
+ SCM_VALIDATE_SYMBOL (1,key);
/* May return if handled by lazy catch. */
return scm_ithrow (key, args, 1);
}
#undef FUNC_NAME
-
SCM
scm_ithrow (SCM key, SCM args, int noreturn)
{
/* 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_NIMP (dynpair) && SCM_CONSP (dynpair))
+ if (SCM_CONSP (dynpair))
{
SCM this_key = SCM_CAR (dynpair);
- if (this_key == SCM_BOOL_T || this_key == key)
+ if (SCM_EQ_P (this_key, SCM_BOOL_T) || SCM_EQ_P (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 (winds == SCM_EOL)
- 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 (dynpair != SCM_BOOL_F)
- 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_CDAR (wind_goal) != jmpbuf;
+ !SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf);
wind_goal = SCM_CDR (wind_goal))
;
is bound to a lazy_catch smob, not a jmpbuf. */
if (SCM_LAZY_CATCH_P (jmpbuf))
{
- struct lazy_catch *c = (struct lazy_catch *) SCM_CDR (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)
void
scm_init_throw ()
{
-#ifdef DEBUG_EXTENSIONS
- scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer",
- sizeof (scm_cell),
- NULL, /* mark */
- freejb,
- printjb,
- NULL);
-#else
- scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer",
- 0,
- NULL, /* mark */
- NULL
- printjb,
- NULL);
-#endif
+ tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
+ scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
- tc16_lazy_catch = scm_make_smob_type_mfpe ("lazy-catch", 0,
- NULL,
- NULL,
- print_lazy_catch,
- NULL);
-#include "throw.x"
+ 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
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff