-/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
#define META_HEADER(meta) meta, 0, 0, 0, 0, 0, 0, 0
#endif
-#define ROUND_UP(len,align) (((len-1)|(align-1))+1)
-#define ALIGN_PTR(type,p,align) (type*)(ROUND_UP (((scm_t_bits)p), align))
+#define OBJCODE_TAG SCM_MAKE_OBJCODE_TAG (SCM_OBJCODE_TYPE_STATIC, 0)
-#ifdef SCM_ALIGNED
-#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
+#if defined (SCM_ALIGNED) && 0
+#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym) \
static const type sym[]
-#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym)\
+#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
static SCM_ALIGNED (alignment) const type sym[]
-#else
-#define SCM_DECLARE_STATIC_ALIGNED_ARRAY(type, sym)\
-static type *sym
-#define SCM_STATIC_ALIGNED_ARRAY(alignment, type, sym) \
-SCM_SNARF_INIT(sym = scm_malloc (sizeof(sym##__unaligned) + alignment - 1); \
- sym = ALIGN_PTR (type, sym, alignment); \
- memcpy (sym, sym##__unaligned, sizeof(sym##__unaligned));) \
-static type *sym = NULL; \
-static const type sym##__unaligned[]
-#endif
-
-#define STATIC_OBJCODE_TAG \
- SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
-
#define SCM_STATIC_OBJCODE(sym) \
SCM_DECLARE_STATIC_ALIGNED_ARRAY (scm_t_uint8, sym##__bytecode); \
SCM_STATIC_ALIGNED_ARRAY (8, scm_t_cell, sym##__cells) = { \
- { STATIC_OBJCODE_TAG, SCM_PACK (sym##__bytecode) }, \
+ { SCM_PACK (OBJCODE_TAG), SCM_PACK (sym##__bytecode) }, \
{ SCM_BOOL_F, SCM_PACK (0) } \
}; \
static const SCM sym = SCM_PACK (sym##__cells); \
SCM_STATIC_ALIGNED_ARRAY (8, scm_t_uint8, sym##__bytecode)
+#else
+#define SCM_STATIC_OBJCODE(sym) \
+static SCM sym; \
+static scm_t_uint8 *sym##_bytecode; \
+SCM_SNARF_INIT(sym##_bytecode = scm_gc_malloc_pointerless (sizeof(sym##_bytecode__unaligned), "partial continuation stub"); \
+ memcpy (sym##_bytecode, sym##_bytecode__unaligned, sizeof(sym##_bytecode__unaligned));) \
+SCM_SNARF_INIT(sym = scm_double_cell (OBJCODE_TAG, \
+ (scm_t_bits)sym##_bytecode, \
+ SCM_UNPACK (SCM_BOOL_F), \
+ 0);) \
+static const scm_t_uint8 sym##_bytecode__unaligned[]
+#endif
+
-
SCM_STATIC_OBJCODE (cont_objcode) = {
/* This code is the same as in gsubr.c, except we use continuation_call
instead of subr_call. */
scm_i_thread *thread = SCM_I_CURRENT_THREAD;
scm_t_contregs *continuation = SCM_CONTREGS (cont);
- if (continuation->root != thread->continuation_root)
+ if (!scm_is_eq (continuation->root, thread->continuation_root))
scm_misc_error
("%continuation-call",
"invoking continuation would cross continuation barrier: ~A",
return result;
}
+\f
+
+static int
+should_print_backtrace (SCM tag, SCM stack)
+{
+ return SCM_BACKTRACE_P
+ && scm_is_true (stack)
+ && scm_initialized_p
+ /* It's generally not useful to print backtraces for errors reading
+ or expanding code in these fallback catch statements. */
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("read-error"))
+ && !scm_is_eq (tag, scm_from_latin1_symbol ("syntax-error"));
+}
+
+static void
+print_exception_and_backtrace (SCM port, SCM tag, SCM args)
+{
+ SCM stack, frame;
+
+ /* We get here via a throw to a catch-all. In that case there is the
+ throw frame active, and this catch closure, so narrow by two
+ frames. */
+ stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+ frame = scm_is_true (stack) ? scm_stack_ref (stack, SCM_INUM0) : SCM_BOOL_F;
+
+ if (should_print_backtrace (tag, stack))
+ {
+ scm_puts ("Backtrace:\n", port);
+ scm_display_backtrace_with_highlights (stack, port,
+ SCM_BOOL_F, SCM_BOOL_F,
+ SCM_EOL);
+ scm_newline (port);
+ }
+
+ scm_print_exception (port, frame, tag, args);
+}
+
+\f
+
struct c_data {
void *(*func) (void *);
void *data;
static SCM
c_handler (void *d, SCM tag, SCM args)
{
- struct c_data *data = (struct c_data *)d;
+ struct c_data *data;
+
+ /* If TAG is `quit', exit() the process. */
+ if (scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
+ exit (scm_exit_status (args));
+
+ data = (struct c_data *)d;
data->result = NULL;
return SCM_UNSPECIFIED;
}
+static SCM
+pre_unwind_handler (void *error_port, SCM tag, SCM args)
+{
+ /* Print the exception unless TAG is `quit'. */
+ if (!scm_is_eq (tag, scm_from_latin1_symbol ("quit")))
+ print_exception_and_backtrace (PTR2SCM (error_port), tag, args);
+
+ return SCM_UNSPECIFIED;
+}
+
void *
scm_c_with_continuation_barrier (void *(*func) (void *), void *data)
{
c_data.data = data;
scm_i_with_continuation_barrier (c_body, &c_data,
c_handler, &c_data,
- scm_handle_by_message_noexit, NULL);
+ pre_unwind_handler,
+ SCM2PTR (scm_current_error_port ()));
return c_data.result;
}
static SCM
scm_handler (void *d, SCM tag, SCM args)
{
+ /* Print a message. Note that if TAG is `quit', this will exit() the
+ process. */
+ scm_handle_by_message_noexit (NULL, tag, args);
+
return SCM_BOOL_F;
}
scm_data.proc = proc;
return scm_i_with_continuation_barrier (scm_body, &scm_data,
scm_handler, &scm_data,
- scm_handle_by_message_noexit, NULL);
+ pre_unwind_handler,
+ SCM2PTR (scm_current_error_port ()));
}
#undef FUNC_NAME
HCoop / bpt / guile.git / blobdiff