[uim-commit] r2139 - branches/r5rs/sigscheme
yamaken at freedesktop.org
yamaken at freedesktop.org
Mon Nov 14 06:16:56 PST 2005
Author: yamaken
Date: 2005-11-14 06:16:52 -0800 (Mon, 14 Nov 2005)
New Revision: 2139
Modified:
branches/r5rs/sigscheme/Makefile.am
branches/r5rs/sigscheme/config.h
branches/r5rs/sigscheme/debug.c
branches/r5rs/sigscheme/error.c
branches/r5rs/sigscheme/main.c
branches/r5rs/sigscheme/operations-new-srfi34.c
branches/r5rs/sigscheme/operations-nonstd.c
branches/r5rs/sigscheme/operations-srfi23.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/sigschemefunctable.c
branches/r5rs/sigscheme/sigschemefunctable.h
branches/r5rs/sigscheme/sigschemeinternal.h
Log:
* This commit reorganizes the error and exception handlings based on
the new SRFI-34 implementation and an error object. It basically
works and become default
* sigscheme/config.h
- Make SCM_USE_NEW_SRFI34 default
* sigscheme/sigscheme.h
- (Scm_MakeErrorObj, Scm_RaiseError, ScmOp_sscm_error_objectp,
ScmOp_sscm_fatal_error, ScmOp_sscm_inspect_error): New function decl
* sigscheme/sigschemeinternal.h
- (SCM_ERROBJP, ERROBJP, ASSERT_ERROBJP): New macro
- (SigScm_InitError): New function decl
* sigscheme/error.c
- (ERRMSG_UNHANDLED_EXCEPTION): New macro
- (srfi34_is_provided, fatal_err_looped, err_obj_tag, str_srfi34):
New static variable
- (srfi34_providedp): New static function
- (SigScm_InitError, ScmOp_sscm_error_objectp, Scm_MakeErrorObj, Scm_RaiseError, ScmOp_sscm_fatal_error, ScmOp_sscm_inspect_error): New function
- (ScmOp_sscm_backtrace): Moved from operations-nonstd.c
- (Scm_ThrowException): Disable when SCM_USE_FORMER_SRFI34 is disabled
- (SigScm_Die, SigScm_Error, SigScm_ErrorObj, Scm_ErrorObj):
Delegate the error handling to Scm_RaiseError() when SCM_USE_NEW_SRFI34
* sigscheme/operations-nonstd.c
- (ScmOp_sscm_backtrace): Move to error.c
* sigscheme/debug.c
- (print_errobj): New static function
- (print_ScmObj_internal): Add error object support
* sigscheme/operations-new-srfi34.c
- (USE_WITH_SIGSCHEME_FATAL_ERROR, ERRMSG_FALLBACK_EXHAUSTED): New
macro
- (errmsg_fallback_exhausted): New static variable
- (global_var_list): Add errmsg_fallback_exhausted
- (SigScm_Initialize_SRFI34):
* Add errmsg_fallback_exhausted initialization
* Initialize proc_fallback_handler cooperates with error.c when
USE_WITH_SIGSCHEME_FATAL_ERROR
- (with_exception_handlers): Remove never-fail sanity check
- (ScmOp_SRFI34_raise):
* Add handler exhaustion check
* Make cooperate with error.c
* Fix double evaluation for the obj
- (guard_handler_body): Fix double evaluation for the condition object
* sigscheme/operations-srfi23.c
- (ScmOp_SRFI23_error): Make cooperate with error.c and SRFI-34 when
SCM_USE_NEW_SRFI34
* sigscheme/main.c
- (repl): Move initialization for feature_id_siod to main() as
proper responsibility separation
- (main): Moved feature_id_siod initialization from repl() and add
lacking GC protection for it
- (repl_loop): Follow the reorganization of error.c and SRFI-34 for
SCM_USE_NEW_SRFI34
* sigscheme/sigscheme.c
- (SigScm_Initialize_internal):
* Add SigScm_InitError()
* Enclose the 'else => #t binding into #if SCM_USE_FORMER_SRFI34
-(SigScm_features): Add a comment
* sigscheme/Makefile.am
- (FUNC_TABLES): Add sigschemefunctable-error.c
- Add generation rule for sigschemefunctable-error.c
* sigscheme/sigschemefunctable.h
- (scm_error_func_info_table): New variable decl
* sigscheme/sigschemefunctable.c
- Add sigschemefunctable-error.c
Modified: branches/r5rs/sigscheme/Makefile.am
===================================================================
--- branches/r5rs/sigscheme/Makefile.am 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/Makefile.am 2005-11-14 14:16:52 UTC (rev 2139)
@@ -5,6 +5,7 @@
FUNC_TABLES = \
sigschemefunctable-r5rs.c \
sigschemefunctable-r5rs-deepcadrs.c \
+ sigschemefunctable-error.c \
sigschemefunctable-nonstd.c \
sigschemefunctable-siod.c \
sigschemefunctable-srfi1.c \
@@ -25,6 +26,8 @@
sigschemefunctable-r5rs-deepcadrs.c: ./script/build_func_table.rb operations-r5rs-deepcadrs.c
./script/build_func_table.rb "" "r5rs_deepcadrs_func_info_table" "operations-r5rs-deepcadrs.c" \
> sigschemefunctable-r5rs-deepcadrs.c
+sigschemefunctable-error.c: error.c $(BUILD_FUNCTBL)
+ $(BUILD_FUNCTBL) "" "scm_error_func_info_table" $< > $@
sigschemefunctable-nonstd.c: ./script/build_func_table.rb operations-nonstd.c
./script/build_func_table.rb "" "nonstd_func_info_table" "operations-nonstd.c" \
> sigschemefunctable-nonstd.c
Modified: branches/r5rs/sigscheme/config.h
===================================================================
--- branches/r5rs/sigscheme/config.h 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/config.h 2005-11-14 14:16:52 UTC (rev 2139)
@@ -46,8 +46,8 @@
#define SCM_USE_SRFI8 1 /* use SRFI-8 'receive' */
#define SCM_USE_SRFI23 1 /* use SRFI-23 'error' */
#define SCM_USE_SRFI34 1 /* use SRFI-34 exception handling for programs */
-#define SCM_USE_FORMER_SRFI34 1 /* use former SRFI-34 implementation */
-#define SCM_USE_NEW_SRFI34 0 /* use new SRFI-34 implementation */
+#define SCM_USE_FORMER_SRFI34 0 /* use former SRFI-34 implementation */
+#define SCM_USE_NEW_SRFI34 1 /* use new SRFI-34 implementation */
#define SCM_USE_SRFI38 1 /* use SRFI-38 'write-with-shared-structure' */
#define SCM_USE_SRFI60 1 /* use SRFI-60 integers as bits */
#define SCM_USE_SRFI75_NAMED_CHARS 1 /* use named characters of SRFI-75 R6RS unicode data */
Modified: branches/r5rs/sigscheme/debug.c
===================================================================
--- branches/r5rs/sigscheme/debug.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/debug.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -108,6 +108,7 @@
static void print_vector(ScmObj port, ScmObj vec, enum OutputType otype);
static void print_port(ScmObj port, ScmObj obj, enum OutputType otype);
static void print_constant(ScmObj port, ScmObj obj, enum OutputType otype);
+static void print_errobj(ScmObj port, ScmObj obj, enum OutputType otype);
#if SCM_USE_SRFI38
static void hash_grow(hash_table *tab);
@@ -233,7 +234,10 @@
SigScm_PortPrintf(port, "%d", SCM_INT_VALUE(obj));
break;
case ScmCons:
- print_list(port, obj, otype);
+ if (ERROBJP(obj))
+ print_errobj(port, obj, otype);
+ else
+ print_list(port, obj, otype);
break;
case ScmSymbol:
SCM_PORT_PRINT(port, SCM_SYMBOL_NAME(obj));
@@ -492,6 +496,43 @@
SCM_PORT_PRINT(port, "#<undef>");
}
+static void print_errobj(ScmObj port, ScmObj obj, enum OutputType otype)
+{
+ ScmObj err_obj_tag, reason, objs, trace_stack;
+ DECLARE_INTERNAL_FUNCTION("print_errobj");
+
+ err_obj_tag = MUST_POP_ARG(obj);
+ reason = MUST_POP_ARG(obj);
+ objs = MUST_POP_ARG(obj);
+ trace_stack = MUST_POP_ARG(obj);
+ ASSERT_NO_MORE_ARG(obj);
+
+ switch (otype) {
+ case AS_WRITE:
+ SCM_PORT_PRINT(port, "#<error ");
+ SigScm_WriteToPort(port, reason);
+ break;
+
+ case AS_DISPLAY:
+ SigScm_DisplayToPort(port, reason);
+ if (CONSP(objs))
+ SCM_PORT_PRINT(port, ":");
+ break;
+
+ default:
+ ERR("print_errobj: unknown output type");
+ break;
+ }
+
+ for (; CONSP(objs); objs = CDR(objs)) {
+ SCM_PORT_PRINT(port, " ");
+ SigScm_WriteToPort(port, CAR(objs));
+ }
+
+ if (otype == AS_WRITE)
+ SCM_PORT_PRINT(port, ">");
+}
+
#if SCM_USE_SRFI38
static void hash_grow(hash_table *tab)
{
Modified: branches/r5rs/sigscheme/error.c
===================================================================
--- branches/r5rs/sigscheme/error.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/error.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -55,17 +55,150 @@
#define SCM_ERR_HEADER "Error: "
#define SCM_BACKTRACE_HEADER "**** BACKTRACE ****\n"
+#define ERRMSG_UNHANDLED_EXCEPTION "unhandled exception"
+
/*=======================================
Variable Declarations
=======================================*/
+static int srfi34_is_provided, fatal_err_looped;
+static ScmObj err_obj_tag, str_srfi34;
+
/*=======================================
File Local Function Declarations
=======================================*/
+static int srfi34_providedp(void);
/*=======================================
Function Implementations
=======================================*/
+void SigScm_InitError(void)
+{
+ SigScm_GC_Protect(&err_obj_tag);
+ SigScm_GC_Protect(&str_srfi34);
+
+ /* allocate a cons cell as unique ID */
+ err_obj_tag = CONS(SCM_UNDEF, SCM_UNDEF);
+
+ str_srfi34 = Scm_NewStringCopying("srfi-34");
+ srfi34_is_provided = FALSE;
+
+ fatal_err_looped = FALSE;
+
+ REGISTER_FUNC_TABLE(scm_error_func_info_table);
+}
+
+#if SCM_USE_SRFI34
+static int srfi34_providedp(void)
+{
+ if (!srfi34_is_provided) {
+ /* expensive */
+ srfi34_is_provided = NFALSEP(ScmOp_providedp(str_srfi34));
+ }
+ return srfi34_is_provided;
+}
+#endif
+
+/* The name 'error?' should be reserved for SRFI-35 */
+ScmObj ScmOp_sscm_error_objectp(ScmObj obj)
+{
+ DECLARE_FUNCTION("%%error-object?", ProcedureFixed1);
+ return (CONSP(obj) && EQ(CAR(obj), err_obj_tag)) ? SCM_TRUE : SCM_FALSE;
+}
+
+/* FIXME: make (pair? err-obj) #f */
+ScmObj Scm_MakeErrorObj(ScmObj reason, ScmObj objs)
+{
+ DECLARE_INTERNAL_FUNCTION("Scm_MakeErrorObj");
+
+ ASSERT_CONSP(objs);
+#if 0
+ /* should be string, but not forced. displayable is sufficient. */
+ ASSERT_STRINGP(reason);
+#endif
+
+ return LIST_4(err_obj_tag, reason, objs, Scm_TraceStack());
+}
+
+void Scm_RaiseError(ScmObj err_obj)
+{
+ DECLARE_INTERNAL_FUNCTION("Scm_RaiseError");
+
+ ASSERT_ERROBJP(err_obj);
+
+#if SCM_USE_SRFI34
+ if (srfi34_providedp()) {
+ ScmOp_SRFI34_raise(err_obj);
+ /* NOTREACHED */
+ }
+#endif
+ ScmOp_sscm_fatal_error(err_obj);
+}
+
+ScmObj ScmOp_sscm_fatal_error(ScmObj err_obj)
+{
+ DECLARE_FUNCTION("%%fatal-error", ProcedureFixed1);
+
+ if (!fatal_err_looped) {
+ fatal_err_looped = TRUE;
+ ASSERT_ERROBJP(err_obj);
+ ScmOp_sscm_inspect_error(err_obj);
+ }
+
+#if 0
+ if (cb_fatal_error)
+ (*cb_fatal_error)();
+#endif
+
+ exit(EXIT_FAILURE);
+ /* NOTREACHED */
+}
+
+ScmObj ScmOp_sscm_inspect_error(ScmObj err_obj)
+{
+ ScmObj rest, err_obj_tag, reason, objs, trace_stack;
+ DECLARE_FUNCTION("%%inspect-error", ProcedureFixed1);
+
+ if (ERROBJP(err_obj)) {
+ rest = err_obj;
+ err_obj_tag = MUST_POP_ARG(rest);
+ reason = MUST_POP_ARG(rest);
+ objs = MUST_POP_ARG(rest);
+ trace_stack = MUST_POP_ARG(rest);
+ ASSERT_NO_MORE_ARG(rest);
+ }
+
+ if (SigScm_DebugCategories() & SCM_DBG_ERRMSG) {
+ SigScm_ShowErrorHeader();
+ if (ERROBJP(err_obj)) {
+ SigScm_DisplayToPort(scm_current_error_port, err_obj);
+ } else {
+ SCM_PORT_PRINT(scm_current_error_port, ERRMSG_UNHANDLED_EXCEPTION);
+ SCM_PORT_PRINT(scm_current_error_port, ": ");
+ SigScm_WriteToPort(scm_current_error_port, err_obj);
+ }
+ SigScm_ErrorNewline();
+ }
+
+ if (SigScm_DebugCategories() & SCM_DBG_BACKTRACE) {
+ if (!ERROBJP(err_obj))
+ trace_stack = Scm_TraceStack();
+ SigScm_ShowBacktrace(trace_stack);
+ }
+
+ return SCM_UNDEF;
+}
+
+ScmObj ScmOp_sscm_backtrace(void)
+{
+ DECLARE_FUNCTION("%%backtrace", ProcedureFixed0);
+
+ SigScm_ShowBacktrace(Scm_TraceStack());
+
+ return SCM_UNDEF;
+}
+
+#if SCM_USE_FORMER_SRFI34
void Scm_ThrowException(ScmObj errorobj)
{
#if SCM_EXCEPTION_HANDLING
@@ -86,8 +219,24 @@
exit(EXIT_FAILURE);
}
+#endif /* SCM_USE_FORMER_SRFI34 */
-int SigScm_Die(const char *msg, const char *filename, int line) {
+int SigScm_Die(const char *msg, const char *filename, int line)
+{
+#if SCM_USE_NEW_SRFI34
+ char *reason;
+ ScmObj err_obj;
+
+#if HAVE_ASPRINTF
+ asprintf(&reason, "SigScheme Died : %s (file : %s, line : %d)",
+ msg, filename, line);
+#else /* HAVE_ASPRINTF */
+ /* FIXME: provide replace asprintf */
+ reason = strdup("SigScheme Died");
+#endif /* HAVE_ASPRINTF */
+ err_obj = Scm_MakeErrorObj(Scm_NewString(reason), LIST_1(SCM_UNDEF));
+ ScmOp_sscm_fatal_error(err_obj);
+#else /* SCM_USE_NEW_SRFI34 */
if (SigScm_DebugCategories() & SCM_DBG_ERRMSG) {
SigScm_ShowErrorHeader();
SigScm_ErrorPrintf("SigScheme Died : %s (file : %s, line : %d)\n",
@@ -98,6 +247,7 @@
SigScm_ShowBacktrace(Scm_TraceStack());
exit(EXIT_FAILURE);
+#endif /* SCM_USE_NEW_SRFI34 */
/* NOTREACHED */
return 1; /* dummy value for boolean expression */
}
@@ -106,6 +256,20 @@
{
va_list va;
+#if SCM_USE_NEW_SRFI34
+ char *reason;
+ ScmObj err_obj;
+
+#if HAVE_VASPRINTF
+ vasprintf(&reason, msg, va);
+#else /* HAVE_VASPRINTF */
+ /* FIXME: provide replace vasprintf */
+ reason = strdup(msg);
+#endif /* HAVE_VASPRINTF */
+ err_obj = Scm_MakeErrorObj(Scm_NewString(reason), LIST_1(SCM_UNDEF));
+ Scm_RaiseError(err_obj);
+ /* NOTREACHED */
+#else /* SCM_USE_NEW_SRFI34 */
if (SigScm_DebugCategories() & SCM_DBG_ERRMSG) {
SigScm_ShowErrorHeader();
@@ -118,11 +282,19 @@
/* FIXME: this errorobj is OK? */
Scm_ThrowException(Scm_NewStringCopying("ERROR"));
+#endif /* SCM_USE_NEW_SRFI34 */
}
/* Obsolete. */
void SigScm_ErrorObj(const char *msg, ScmObj obj)
{
+#if SCM_USE_NEW_SRFI34
+ ScmObj err_obj;
+
+ err_obj = Scm_MakeErrorObj(Scm_NewStringCopying(msg), LIST_1(obj));
+ Scm_RaiseError(err_obj);
+ /* NOTREACHED */
+#else /* SCM_USE_NEW_SRFI34 */
if (SigScm_DebugCategories() & SCM_DBG_ERRMSG) {
SigScm_ShowErrorHeader();
SigScm_ErrorPrintf(msg);
@@ -132,11 +304,26 @@
/* FIXME: this errorobj is OK? */
Scm_ThrowException(Scm_NewStringCopying("ERROR"));
+#endif /* SCM_USE_NEW_SRFI34 */
}
/* This function obsoletes SigScm_ErrorObj(). */
void Scm_ErrorObj(const char *func_name, const char *msg, ScmObj obj)
{
+#if SCM_USE_NEW_SRFI34
+ char *reason;
+ ScmObj err_obj;
+
+#if HAVE_ASPRINTF
+ asprintf(&reason, "in %s: %s: ", func_name, msg);
+#else /* HAVE_ASPRINTF */
+ /* FIXME: provide replace asprintf */
+ reason = strdup(msg);
+#endif /* HAVE_ASPRINTF */
+ err_obj = Scm_MakeErrorObj(Scm_NewString(reason), LIST_1(obj));
+ Scm_RaiseError(err_obj);
+ /* NOTREACHED */
+#else /* SCM_USE_NEW_SRFI34 */
if (SigScm_DebugCategories() & SCM_DBG_ERRMSG) {
SigScm_ShowErrorHeader();
SigScm_ErrorPrintf("in %s: %s: ", func_name, msg);
@@ -146,6 +333,7 @@
/* FIXME: this errorobj is OK? */
Scm_ThrowException(Scm_NewStringCopying("ERROR"));
+#endif /* SCM_USE_NEW_SRFI34 */
}
void SigScm_ShowBacktrace(ScmObj trace_stack)
Modified: branches/r5rs/sigscheme/main.c
===================================================================
--- branches/r5rs/sigscheme/main.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/main.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -80,8 +80,6 @@
SigScm_GC_ProtectStack(&stack_start);
#endif
- feature_id_siod = Scm_NewStringCopying(FEATURE_ID_SIOD);
-
repl_loop();
#if !SCM_GCC4_READY_GC
@@ -91,38 +89,37 @@
static void repl_loop(void)
{
- ScmObj s_exp = SCM_FALSE;
- ScmObj result = SCM_FALSE;
- int is_prompt = is_repl_prompt();
+ ScmObj s_exp = SCM_FALSE;
+ ScmObj result = SCM_FALSE;
+ ScmObj sym_guard = SCM_FALSE;
+ ScmObj cond_catch = SCM_FALSE;
+ int is_prompt = is_repl_prompt();
+ /* prepare the constant part of the form to get the loop fast */
+ sym_guard = Scm_Intern("guard");
+ cond_catch = LIST_2(Scm_Intern("err"),
+ LIST_2(SYM_ELSE,
+ LIST_2(Scm_Intern("%%inspect-error"),
+ Scm_Intern("err"))));
+
if (is_prompt)
SigScm_PortPrintf(scm_current_output_port, PROMPT_STR);
while (s_exp = SigScm_Read(scm_current_input_port), !EOFP(s_exp)) {
#if SCM_USE_SRFI34
#if SCM_USE_NEW_SRFI34
- /* FIXME: move the fallback exception handling into error.c */
/*
* Error-proof evaluation
*
* (guard (err
* (else
- * (display "unhandled exception: ")
- * (write err)
- * (newline)
- * #<undef>))
+ * (%%inspect-error err)))
* exp)
+ *
+ * To allow redefinition of 'guard' and '%%inspect-err', surely access
+ * them via symbol instead of prepared syntax or procedure object.
*/
- result = EVAL(LIST_3(Scm_Intern("guard"),
- LIST_2(Scm_Intern("err"),
- LIST_5(SYM_ELSE,
- LIST_2(Scm_Intern("display"),
- Scm_NewStringCopying("unhandled exception: ")),
- LIST_2(Scm_Intern("write"),
- Scm_Intern("err")),
- LIST_1(Scm_Intern("newline")),
- SCM_UNDEF)),
- s_exp),
+ result = EVAL(LIST_3(sym_guard, cond_catch, s_exp),
SCM_INTERACTION_ENV);
#else /* SCM_USE_NEW_SRFI34 */
/*
@@ -174,6 +171,9 @@
Scm_use("srfi-34");
#endif
+ SigScm_GC_Protect(&feature_id_siod);
+ feature_id_siod = Scm_NewStringCopying(FEATURE_ID_SIOD);
+
if (argc < 2) {
#if SCM_GCC4_READY_GC
SCM_GC_PROTECTED_CALL_VOID(repl, ());
Modified: branches/r5rs/sigscheme/operations-new-srfi34.c
===================================================================
--- branches/r5rs/sigscheme/operations-new-srfi34.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/operations-new-srfi34.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -55,8 +55,11 @@
/*=======================================
File Local Macro Definitions
=======================================*/
+#define USE_WITH_SIGSCHEME_FATAL_ERROR 1
+
#define ERRMSG_UNHANDLED_EXCEPTION "unhandled exception"
#define ERRMSG_HANDLER_RETURNED "handler returned"
+#define ERRMSG_FALLBACK_EXHAUSTED "fallback handler exhausted"
#define MAKE_STR_COPYING Scm_NewStringCopying
#define DECLARE_PRIVATE_FUNCTION(func_name, type) \
@@ -73,6 +76,7 @@
/* error messages */
static ScmObj errmsg_unhandled_exception, errmsg_handler_returned;
+static ScmObj errmsg_fallback_exhausted;
/* symbols */
static ScmObj sym_error, sym_raise;
@@ -89,6 +93,7 @@
static ScmObj *const global_var_list[] = {
¤t_exception_handlers,
&errmsg_unhandled_exception, &errmsg_handler_returned,
+ &errmsg_fallback_exhausted,
&sym_error, &sym_raise,
&sym_lex_env, &sym_cond_catch, &sym_body,
&sym_condition, &sym_guard_k, &sym_handler_k,
@@ -127,6 +132,7 @@
errmsg_unhandled_exception = MAKE_STR_COPYING(ERRMSG_UNHANDLED_EXCEPTION);
errmsg_handler_returned = MAKE_STR_COPYING(ERRMSG_HANDLER_RETURNED);
+ errmsg_fallback_exhausted = MAKE_STR_COPYING(ERRMSG_FALLBACK_EXHAUSTED);
sym_error = Scm_Intern("error");
sym_raise = Scm_Intern("raise");
@@ -155,9 +161,23 @@
syn_guard_body = Scm_NewFunc(SCM_SYNTAX_FIXED_TAIL_REC | 0,
&guard_body);
+#if USE_WITH_SIGSCHEME_FATAL_ERROR
+ proc_fallback_handler
+ = ScmExp_lambda(LIST_1(sym_condition),
+ LIST_1(LIST_4(Scm_Intern("if"),
+ LIST_2(Scm_Intern("%%error-object?"),
+ sym_condition),
+ LIST_2(Scm_Intern("%%fatal-error"),
+ sym_condition),
+ LIST_3(sym_error,
+ errmsg_unhandled_exception,
+ sym_condition))),
+ SCM_INTERACTION_ENV);
+#else /* USE_WITH_SIGSCHEME_FATAL_ERROR */
/*
- * The 'error' procedure should not be invoked directly by ScmOp_error(),
- * to allow dynamic redifinition, and keep SRFI-23 implementation abstract.
+ * The 'error' procedure should not be invoked directly by
+ * ScmOp_SRFI23_error(), to allow dynamic redifinition, and keep SRFI-23
+ * implementation abstract.
*/
proc_fallback_handler
= ScmExp_lambda(LIST_1(sym_condition),
@@ -165,6 +185,7 @@
errmsg_unhandled_exception,
sym_condition)),
SCM_INTERACTION_ENV);
+#endif /* USE_WITH_SIGSCHEME_FATAL_ERROR */
REGISTER_FUNC_TABLE(scm_new_srfi34_func_info_table);
@@ -191,7 +212,7 @@
after = ScmExp_lambda(SCM_NULL,
LIST_1(LIST_2(syn_set_cur_handlers, prev_handlers)),
SCM_INTERACTION_ENV);
- return ScmOp_dynamic_wind(before, thunk, after);
+ return Scm_DynamicWind(before, thunk, after);
}
/* with-exception-handler */
@@ -212,11 +233,21 @@
ScmObj ScmOp_SRFI34_raise(ScmObj obj)
{
- ScmObj handler, rest_handlers, thunk;
+ ScmObj handler, rest_handlers, thunk, err_obj;
DECLARE_FUNCTION("raise", ProcedureFixed1);
+ if (NULLP(current_exception_handlers)) {
+ if (ERROBJP(obj))
+ err_obj = obj;
+ else
+ err_obj = Scm_MakeErrorObj(errmsg_fallback_exhausted, LIST_1(obj));
+ ScmOp_sscm_fatal_error(err_obj);
+ /* NOTREACHED */
+ }
+
handler = CAR(current_exception_handlers);
rest_handlers = CDR(current_exception_handlers);
+ obj = LIST_2(SYM_QUOTE, obj);
thunk = ScmExp_lambda(SCM_NULL,
LIST_2(LIST_2(handler, obj),
LIST_3(sym_error,
@@ -300,7 +331,6 @@
sym_var = CAR(cond_catch);
clauses = CDR(cond_catch);
ASSERT_SYMBOLP(sym_var);
- condition = EVAL(condition, lex_env);
cond_env = Scm_ExtendEnvironment(LIST_1(sym_var),
LIST_1(condition),
lex_env);
Modified: branches/r5rs/sigscheme/operations-nonstd.c
===================================================================
--- branches/r5rs/sigscheme/operations-nonstd.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/operations-nonstd.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -88,15 +88,6 @@
|| SCM_SYMBOL_BOUNDP(sym)) ? SCM_TRUE : SCM_FALSE;
}
-ScmObj ScmOp_sscm_backtrace(void)
-{
- DECLARE_FUNCTION("%%backtrace", ProcedureFixed0);
-
- SigScm_ShowBacktrace(Scm_TraceStack());
-
- return SCM_UNDEF;
-}
-
/* SIOD compatible */
ScmObj ScmOp_load_path(void)
{
Modified: branches/r5rs/sigscheme/operations-srfi23.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi23.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/operations-srfi23.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -72,8 +72,43 @@
/*=============================================================================
SRFI23 : Error reporting mechanism
=============================================================================*/
+#if SCM_USE_NEW_SRFI34
+
+/*
+ * This code implements the '4.' of following Specification defined in SRFI-34.
+ *
+ * 1. Display <reason> and <arg1>... on the screen and terminate the Scheme
+ * program. (This might be suitable for a Scheme system implemented as a
+ * batch compiler.)
+ * 2. Display <reason> and <arg1>... on the screen and go back to the
+ * read-evaluate-print loop. (This might be suitable for an interactive
+ * implementation).
+ * 4. Package <reason> and <arg1>... up into an error object and pass this
+ * error object to an exception handler. The default exception handler then
+ * might do something as described in points 1 to 3.
+ */
ScmObj ScmOp_SRFI23_error(ScmObj reason, ScmObj args)
{
+ ScmObj err_obj;
+ DECLARE_FUNCTION("error", ProcedureVariadic1);
+#if 0
+ /*
+ * Although SRFI-23 specified that "The argument <reason> should be a
+ * string", we should not force it. Displayable is sufficient.
+ */
+ ASSERT_STRINGP(reason);
+#endif
+
+ err_obj = Scm_MakeErrorObj(reason, args);
+ Scm_RaiseError(err_obj);
+ /* NOTREACHED */
+ return SCM_UNDEF;
+}
+
+#else /* SCM_USE_NEW_SRFI34 */
+
+ScmObj ScmOp_SRFI23_error(ScmObj reason, ScmObj args)
+{
ScmObj arg = SCM_FALSE;
DECLARE_FUNCTION("error", ProcedureVariadic1);
@@ -101,3 +136,4 @@
/* NOTREACHED */
return SCM_UNDEF;
}
+#endif /* SCM_USE_NEW_SRFI34 */
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -135,6 +135,7 @@
SigScm_SetDebugCategories(SCM_DBG_ERRMSG | SCM_DBG_BACKTRACE
| SigScm_PredefinedDebugCategories());
SigScm_InitStorage();
+ SigScm_InitError();
/*=======================================================================
Predefined Symbols and Variables
@@ -145,13 +146,13 @@
Scm_sym_unquote_splicing = Scm_Intern("unquote-splicing");
Scm_sym_else = Scm_Intern("else");
Scm_sym_yields = Scm_Intern("=>");
-#if 1
+#if SCM_USE_FORMER_SRFI34
/* FIXME: obsolete this. don't set SCM_TRUE and rely on the value */
- /* only operations-srfi34.c depends on this */
SCM_SYMBOL_SET_VCELL(Scm_Intern("else"), SCM_TRUE);
#endif
#if SCM_USE_NONSTD_FEATURES
+ /* FIXME: make invisible from users */
SigScm_features = Scm_Intern("*features*");
SCM_SYMBOL_SET_VCELL(SigScm_features, SCM_NULL);
#endif
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-11-14 14:16:52 UTC (rev 2139)
@@ -575,7 +575,6 @@
/* operations-nonstd.c */
#if SCM_USE_NONSTD_FEATURES
ScmObj ScmOp_symbol_boundp(ScmObj sym, ScmObj rest);
-ScmObj ScmOp_sscm_backtrace(void);
ScmObj ScmOp_load_path(void);
/* FIXME: add ScmObj SigScm_require(const char *c_filename); */
ScmObj ScmOp_require(ScmObj filename);
@@ -631,6 +630,12 @@
void SigScm_Error(const char *msg, ...) SCM_NORETURN;
void SigScm_ErrorObj(const char *msg, ScmObj obj) SCM_NORETURN;
void SigScm_ShowBacktrace(ScmObj trace_stack);
+ScmObj Scm_MakeErrorObj(ScmObj reason, ScmObj objs);
+void Scm_RaiseError(ScmObj err_obj) SCM_NORETURN;
+ScmObj ScmOp_sscm_error_objectp(ScmObj obj);
+ScmObj ScmOp_sscm_fatal_error(ScmObj err_obj) SCM_NORETURN;
+ScmObj ScmOp_sscm_inspect_error(ScmObj err_obj);
+ScmObj ScmOp_sscm_backtrace(void);
/* debug.c */
int SigScm_DebugCategories(void);
Modified: branches/r5rs/sigscheme/sigschemefunctable.c
===================================================================
--- branches/r5rs/sigscheme/sigschemefunctable.c 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/sigschemefunctable.c 2005-11-14 14:16:52 UTC (rev 2139)
@@ -54,6 +54,7 @@
Builtin Function Tables
=======================================*/
#include "sigschemefunctable-r5rs.c"
+#include "sigschemefunctable-error.c"
#if SCM_USE_DEEP_CADRS
#include "sigschemefunctable-r5rs-deepcadrs.c"
Modified: branches/r5rs/sigscheme/sigschemefunctable.h
===================================================================
--- branches/r5rs/sigscheme/sigschemefunctable.h 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/sigschemefunctable.h 2005-11-14 14:16:52 UTC (rev 2139)
@@ -76,6 +76,9 @@
#if SCM_USE_NONSTD_FEATURES
extern struct builtin_func_info nonstd_func_info_table[];
#endif
+#if SCM_USE_NONSTD_FEATURES
+extern struct builtin_func_info scm_error_func_info_table[];
+#endif
#if SCM_USE_SRFI1
extern struct builtin_func_info srfi1_func_info_table[];
#endif
Modified: branches/r5rs/sigscheme/sigschemeinternal.h
===================================================================
--- branches/r5rs/sigscheme/sigschemeinternal.h 2005-11-14 13:49:16 UTC (rev 2138)
+++ branches/r5rs/sigscheme/sigschemeinternal.h 2005-11-14 14:16:52 UTC (rev 2139)
@@ -113,6 +113,8 @@
#define SCM_FREECELL_SET_CDR(a, cdr) (SCM_FREECELL_CDR(a) = (cdr))
#endif
+#define SCM_ERROBJP(obj) (NFALSEP(ScmOp_sscm_error_objectp(obj)))
+
/* Prefix-less Abbreviation Names For Convenient Internal Use */
#define SYM_QUOTE SCM_SYM_QUOTE
#define SYM_QUASIQUOTE SCM_SYM_QUASIQUOTE
@@ -170,6 +172,7 @@
#define C_POINTERP SCM_C_POINTERP
#define C_FUNCPOINTERP SCM_C_FUNCPOINTERP
#define ENVP SCM_ENVP
+#define ERROBJP SCM_ERROBJP
#define CDBG SCM_CDBG
#define DBG SCM_DBG
@@ -295,6 +298,7 @@
#define ASSERT_CONTINUATIONP(obj) ASSERT_TYPE(CONTINUATIONP, "continuation", (obj))
#define ASSERT_PROCEDUREP(obj) ASSERT_TYPE(PROCEDUREP, "procedure", (obj))
#define ASSERT_ENVP(obj) ASSERT_TYPE(ENVP, "environment specifier", (obj))
+#define ASSERT_ERROBJP(obj) ASSERT_TYPE(ERROBJP, "error object", (obj))
#if SCM_USE_FORMER_SRFI34
/* Macros and Variables For Handling Exception Handlers based on SRFI-34 */
@@ -363,6 +367,7 @@
ScmObj ScmExp_cond_internal(ScmObj args, ScmEvalState *eval_state);
/* error.c */
+void SigScm_InitError(void);
void Scm_ThrowException(ScmObj errorobj) SCM_NORETURN;
void SigScm_ShowErrorHeader(void);
void Scm_ErrorObj(const char *func_name, const char *msg, ScmObj obj) SCM_NORETURN;
More information about the uim-commit
mailing list