* error.c (scm_error): declare scm_error_callback.

	* error.h: prototype for scm_error_callback.

	* __scm.h: define lgh_error.
 	(SCM_SYSERROR): redefine using lgh_error.

	* boot-9.scm (%%handle-system-error): recognise errors thrown
	by lgh-error (fill-message etc.)

diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index 9c2c6ac..e742b1a 100644 (file)
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,8 @@
+Sat Sep  7 06:44:47 1996  Gary Houston  <ghouston@actrix.gen.nz>
+
+       * boot-9.scm (%%handle-system-error): recognise errors thrown
+       by lgh-error (fill-message etc.)
+
 Thu Sep  5 11:33:41 1996  Jim Blandy  <jimb@floss.cyclic.com>
 
        * boot-9.scm: %load-path is initialized in C code now.

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index 50ba8f6..ed8166d 100644 (file)
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -669,25 +669,56 @@
 
 
 ;; The default handler for built-in error types when
-;; thrown by their symbolic name.  The action is to 
-;; convert the error into a generic error, building
-;; a descriptive message for the error.
-;;
-(define (%%handle-system-error ignored desc proc . args)
-  (let* ((b (assoc desc %%system-errors))
-        (msghead (cond
-                  (b (caddr b))
-                  ((or (symbol? desc) (string? desc))
-                   (string-append desc " "))
-                  (#t "Unknown error")))
-        (msg (if (symbol? proc)
-                 (string-append msghead proc ":")
-                 msghead))
-        (rest (if (and proc (not (symbol? proc)))
-                  (cons proc args)
-                  args))
-        (fixed-args (cons msg rest)))
-    (apply error fixed-args)))
+;; thrown by their symbolic name.
+(define (%%handle-system-error key . arg-list)
+  (cond ((= (length arg-list) 4)
+        (letrec ((subr (car arg-list))
+                 (message (cadr arg-list))
+                 (args (caddr arg-list))
+                 (rest (cadddr arg-list))
+                 (cep (current-error-port))
+                 (fill-message (lambda (message args)
+                                 (let ((len (string-length message)))
+                                   (cond ((< len 2)
+                                          (display message cep))
+                                         ((string=? (substring message 0 2)
+                                                    "%S")
+                                          (display (car args) cep)
+                                          (fill-message
+                                           (substring message 2 len)
+                                           (cdr args)))
+                                         (else
+                                          (display (substring message 0 2)
+                                                   cep)
+                                          (fill-message
+                                           (substring message 2 len)
+                                           args)))))))
+          (display "ERROR: " cep)
+          (display subr cep)
+          (display ": " cep)
+          (fill-message message args)
+          (newline cep)
+          (force-output cep)
+          (apply throw 'abort key arg-list)))
+       (else
+        ;; old style errors.
+        (let* ((desc (car arg-list))
+               (proc (cadr arg-list))
+               (args (cddr arg-list))
+               (b (assoc desc %%system-errors))
+               (msghead (cond
+                         (b (caddr b))
+                         ((or (symbol? desc) (string? desc))
+                          (string-append desc " "))
+                         (#t "Unknown error")))
+               (msg (if (symbol? proc)
+                        (string-append msghead proc ":")
+                        msghead))
+               (rest (if (and proc (not (symbol? proc)))
+                         (cons proc args)
+                         args))
+               (fixed-args (cons msg rest)))
+          (apply error fixed-args)))))
 
 
 (set-symbol-property! '%%system-error

diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 165895c..f15522d 100644 (file)
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,5 +1,18 @@
+Sat Sep  7 06:57:23 1996  Gary Houston  <ghouston@actrix.gen.nz>
+
+       * error.c (scm_error): declare scm_error_callback.
+
+       * error.h: prototype for scm_error_callback.
+
+       * __scm.h: define lgh_error.
+       (SCM_SYSERROR): redefine using lgh_error.
+
 Thu Sep  5 22:40:06 1996  Gary Houston  <ghouston@actrix.gen.nz>
 
+       * error.c (scm_error): new procedure.
+
+       * error.h: prototype for scm_error.
+
        * Makefile.in (install): install scmconfig.h from the current
        directory, not $(srcdir).
 

diff --git a/libguile/__scm.h b/libguile/__scm.h
index 346b997..0d4d29e 100644 (file)
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -296,9 +296,23 @@ extern unsigned int scm_async_clock;
           goto _label
 #endif
 
+#define lgh_error(_key, _subr, _message, _args, _rest) \
+       scm_error (_key, _subr, _message, _args, _rest)
+
 #define SCM_SYSERROR(_subr) \
-       scm_everr (SCM_UNDEFINED, SCM_EOL, SCM_UNDEFINED, \
-                  strerror (errno), _subr)
+       lgh_error (system_error_sym, \
+                  _subr, \
+                  "%S", \
+                  scm_listify (scm_makfrom0str (strerror (errno)), \
+                               SCM_UNDEFINED), \
+                  scm_listify (SCM_MAKINUM (errno), SCM_UNDEFINED));
+
+/*
+  old version:
+  #define SCM_SYSERROR(_subr) \
+         scm_everr (SCM_UNDEFINED, SCM_EOL, SCM_UNDEFINED, \
+         strerror (errno), _subr)
+         */
 
      /* equivalent to:
        scm_throw (system_error_sym, \

diff --git a/libguile/error.c b/libguile/error.c
index 2be3f12..8c6d81d 100644 (file)
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -191,7 +191,32 @@ scm_wta (arg, pos, s_subr)
   return SCM_UNSPECIFIED;
 }
 
+void (*scm_error_callback) () = 0;
 
+void
+scm_error (key, subr, message, args, rest)
+     SCM key;
+     char *subr;
+     char *message;
+     SCM args;
+     SCM rest;
+{
+  SCM arg_list;
+  if (scm_error_callback)
+    (*scm_error_callback) (key, subr, message, args, rest);
+
+  arg_list = scm_listify (scm_makfrom0str (subr),
+                         scm_makfrom0str (message),
+                         args,
+                         rest,
+                         SCM_UNDEFINED);
+  scm_ithrow (key, arg_list, 1);
+  
+  /* No return, but just in case: */
+
+  write (2, "unhandled system error", sizeof ("unhandled system error") - 1);
+  exit (1);
+}
 
 #ifdef __STDC__
 void

diff --git a/libguile/error.h b/libguile/error.h
index 705290b..a4a128b 100644 (file)
--- a/libguile/error.h
+++ b/libguile/error.h
@@ -53,6 +53,8 @@ extern SCM system_error_sym;
 
 \f
 
+extern void scm_error PROTO ((SCM key, char *subr, char *message, SCM args, SCM rest));
+extern void (*scm_error_callback) PROTO ((SCM key, char *subr, char *message, SCM args, SCM rest));
 
 #ifdef __STDC__
 extern int scm_handle_it (int i);