-/* 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 "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 "ports.h"
+#include "libguile/continuations.h"
+#include "libguile/stackchk.h"
+#include "libguile/stacks.h"
+#include "libguile/fluids.h"
+#include "libguile/ports.h"
-#include "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(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer))
+#define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
-#define JBACTIVE(OBJ) (SCM_UNPACK_CAR (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(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L)))
+#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L)))
-#ifndef DEBUG_EXTENSIONS
-#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (OBJ) )
-#define SETJBJMPBUF SCM_SETCDR
-#else
-#define SCM_JBDFRAME(OBJ) ((scm_debug_frame*)SCM_CAR (SCM_CDR (OBJ)) )
-#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (SCM_CDR (OBJ)) )
-#define SCM_SETJBDFRAME(OBJ,X) SCM_SETCAR (SCM_CDR (OBJ), (SCM)(X))
-#define SETJBJMPBUF(OBJ,X) SCM_SETCDR(SCM_CDR (OBJ), X)
-
-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_UNPACK ( 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);
/* 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_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:
{
/* 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);
}
{
struct scm_body_thunk_data c;
- SCM_ASSERT (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;
{
struct scm_body_thunk_data c;
- SCM_ASSERT (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;
/* 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))
{
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 ()
{
- scm_tc16_jmpbuffer = scm_make_smob_type_mfpe ("jmpbuffer",
-#ifdef DEBUG_EXTENSIONS
- sizeof (scm_cell),
- NULL, /* mark */
- freejb,
-#else
- 0,
- NULL, /* mark */
- 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
- printjb,
- NULL);
-
- tc16_lazy_catch = scm_make_smob_type_mfpe ("lazy-catch", 0,
- NULL,
- NULL,
- print_lazy_catch,
- NULL);
-#include "throw.x"
}
/*
HCoop / bpt / guile.git / blobdiff