X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f2c9fcb07ed55b916c3ba5f2357686fda3ad011e..5425fc2f3a7782d507ec8b5a5ec23c4e33227d8a:/libguile/throw.c diff --git a/libguile/throw.c b/libguile/throw.c index 17e046c57..a4e610b7b 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 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 @@ -66,13 +66,15 @@ /* 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))) @@ -82,17 +84,15 @@ static int scm_tc16_jmpbuffer; #endif static int -printjb (SCM exp, SCM port, scm_print_state *pstate) +jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1 ; } - static SCM make_jmpbuf (void) { @@ -100,9 +100,9 @@ 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); @@ -218,7 +218,7 @@ scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_h /* 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 @@ -238,7 +238,7 @@ struct lazy_catch { 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]; @@ -260,7 +260,7 @@ make_lazy_catch (struct lazy_catch *c) 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: @@ -436,7 +436,7 @@ handler_message (void *handler_data, SCM tag, SCM 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 { @@ -472,18 +472,19 @@ handler_message (void *handler_data, SCM tag, SCM args) 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); } @@ -513,37 +514,41 @@ scm_handle_by_throw (void *handler_data, SCM tag, SCM args) /* 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); } @@ -551,25 +556,27 @@ SCM_DEFINE (scm_catch, "catch", 3, 0, 0, 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); } @@ -585,7 +592,7 @@ SCM_DEFINE (scm_throw, "throw", 1, 0, 1, "@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); @@ -605,11 +612,8 @@ 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_CONSP (dynpair)) { @@ -620,33 +624,29 @@ scm_ithrow (SCM key, SCM args, int noreturn) } } - /* 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)) @@ -700,19 +700,15 @@ scm_ithrow (SCM key, SCM args, int noreturn) 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 } /*