-/* Copyright (C) 1995,1996,1997 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
* 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>
-#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 "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)))
-
-#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 SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-static scm_sizet freejb SCM_P ((SCM jbsmob));
+#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 (jbsmob)
- 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_P ((SCM exp, SCM port, scm_print_state *pstate));
static int
-printjb (exp, port, pstate)
- 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_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);
+ SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
+#else
+ SCM_NEWSMOB (answer, tc16_jmpbuffer, 0);
#endif
- SCM_SETCAR (answer, scm_tc16_jmpbuffer);
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:
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);
/* 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>",
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))
+#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.
- - 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);
{
/* 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);
}
};
static SCM
-cwss_body (void *data, SCM jmpbuf)
+cwss_body (void *data)
{
struct cwss_data *d = data;
return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
/* 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);
}
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;
};
static SCM
-hbpca_body (body_data, jmpbuf)
- void *body_data;
- SCM jmpbuf;
+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 (handler_data, tag, throw_args)
- void *handler_data;
- SCM tag;
- SCM throw_args;
+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;
/* 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_puts (prog_name, p);
- scm_puts (": ", p);
+ SCM p = scm_cur_errp;
if (scm_ilength (args) >= 3)
{
+ 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 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_i_display_error (stack, p, subr, message, parts, rest);
}
else
{
+ 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_puts (": ", p);
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 (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));
+ if (SCM_NFALSEP (scm_eq_p (tag, scm_str2symbol ("quit"))))
+ {
+ exit (scm_exit_status (args));
+ }
handler_message (handler_data, tag, args);
-
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) || SCM_EQ_P (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) || SCM_EQ_P (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))
+ SCM dynpair = SCM_UNDEFINED;
+ SCM winds;
+
+ /* Search the wind list for an appropriate catch.
+ "Waiter, please bring us the wind list." */
+ for (winds = scm_dynwinds; SCM_CONSP (winds); winds = SCM_CDR (winds))
{
- jmpbuf = key;
- if (noreturn)
+ dynpair = SCM_CAR (winds);
+ if (SCM_CONSP (dynpair))
{
- 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 this_key = SCM_CAR (dynpair);
- if (noreturn)
- {
- SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1,
- s_throw);
+ if (SCM_EQ_P (this_key, SCM_BOOL_T) || SCM_EQ_P (this_key, key))
+ break;
}
- 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;
- }
- }
+#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 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 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))
+ {
+ scm_handle_by_message (NULL, key, args);
+ abort ();
+ }
- /* If the wind list is malformed, bail. */
- if (SCM_IMP (winds) || SCM_NCONSP (winds))
- abort ();
+ /* If the wind list is malformed, bail. */
+ if (!SCM_CONSP (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
- scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
-#endif
- longjmp (SCM_JMPBUF (scm_rootcont), 1);
- }
- }
- }
+ 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 ()
{
- scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
- tc16_lazy_catch = scm_newsmob (&lazy_catch_funs);
-#include "throw.x"
+ 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
}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff