* 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.)

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.

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

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).
 

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, \

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

libguile/error.h

@@ -53,6 +53,8 @@ extern SCM system_error_sym;
 
 
 
+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);