[uim-commit] r2513 - branches/r5rs/sigscheme

[yamaken at freedesktop.org]

Author: yamaken
Date: 2005-12-09 22:43:32 -0800 (Fri, 09 Dec 2005)
New Revision: 2513

Modified:
   branches/r5rs/sigscheme/error.c
   branches/r5rs/sigscheme/sigscheme.h
Log:
* sigscheme/error.c
  - (cb_fatal_error): New static variable
  - (SigScm_InitError): Initialize cb_fatal_error
  - (Scm_FatalError, Scm_SetFatalErrorCallback): New function
  - (ScmOp_fatal_error): Rewrite with Scm_FatalError()


Modified: branches/r5rs/sigscheme/error.c
===================================================================
--- branches/r5rs/sigscheme/error.c	2005-12-10 06:35:58 UTC (rev 2512)
+++ branches/r5rs/sigscheme/error.c	2005-12-10 06:43:32 UTC (rev 2513)
@@ -60,6 +60,7 @@
   Variable Declarations
 =======================================*/
 static int srfi34_is_provided, fatal_err_looped;
+static void (*cb_fatal_error)(void);
 
 static ScmObj err_obj_tag, str_srfi34;
 
@@ -85,6 +86,7 @@
     str_srfi34 = Scm_NewImmutableStringCopying("srfi-34");
     srfi34_is_provided = FALSE;
 
+    cb_fatal_error = NULL;
     fatal_err_looped = FALSE;
 
     REGISTER_FUNC_TABLE(scm_error_func_info_table);
@@ -138,8 +140,30 @@
     ScmOp_fatal_error(err_obj);
 }
 
+void Scm_FatalError(const char *msg)
+{
+    /* don't use Scheme-level ports here */
+    if (msg) {
+        fputs(msg, stderr);
+        fputs(SCM_NEWLINE_STR, stderr);
+    }
+
+    if (cb_fatal_error)
+        (*cb_fatal_error)();
+
+    exit(EXIT_FAILURE);
+    /* NOTREACHED */
+}
+
+void Scm_SetFatalErrorCallback(void (*cb)(void))
+{
+    cb_fatal_error = cb;
+}
+
 ScmObj ScmOp_fatal_error(ScmObj err_obj)
 {
+    ScmObj reason;
+    const char *msg;
     DECLARE_FUNCTION("%%fatal-error", ProcedureFixed1);
 
     if (!fatal_err_looped) {
@@ -147,13 +171,11 @@
         ASSERT_ERROBJP(err_obj);
         ScmOp_inspect_error(err_obj);
     }
+    /* ERROBJP(err_obj) is always true here */
+    reason = CADR(err_obj);
+    msg = (STRINGP(reason)) ? SCM_STRING_STR(reason) : NULL;
 
-#if 0
-    if (cb_fatal_error)
-        (*cb_fatal_error)();
-#endif
-
-    exit(EXIT_FAILURE);
+    Scm_FatalError(msg);
     /* NOTREACHED */
 }
 

Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h	2005-12-10 06:35:58 UTC (rev 2512)
+++ branches/r5rs/sigscheme/sigscheme.h	2005-12-10 06:43:32 UTC (rev 2513)
@@ -645,7 +645,9 @@
 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;
+void Scm_RaiseError(ScmObj err_obj) SCM_NORETURN;
+void Scm_FatalError(const char *msg) SCM_NORETURN;
+void Scm_SetFatalErrorCallback(void (*cb)(void));
 ScmObj ScmOp_error_objectp(ScmObj obj);
 ScmObj ScmOp_fatal_error(ScmObj err_obj) SCM_NORETURN;
 ScmObj ScmOp_inspect_error(ScmObj err_obj);