summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGary Houston <ghouston@arglist.com>1996-09-07 20:48:45 +0000
committerGary Houston <ghouston@arglist.com>1996-09-07 20:48:45 +0000
commit7cb1d4d3059649fd611551e06c3c7aaae6d97397 (patch)
tree7e5190d3190d5b9e89c376d4fa4f776e5e3c6219
parentcceac91b8b8356ede44b8230813ee023da297a8d (diff)
downloadguile-7cb1d4d3059649fd611551e06c3c7aaae6d97397.tar.gz
* 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.)
-rw-r--r--ice-9/ChangeLog5
-rw-r--r--ice-9/boot-9.scm69
-rw-r--r--libguile/ChangeLog13
-rw-r--r--libguile/__scm.h18
-rw-r--r--libguile/error.c25
-rw-r--r--libguile/error.h2
6 files changed, 111 insertions, 21 deletions
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index 9c2c6ac43..e742b1a47 100644
--- 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 50ba8f60b..ed8166deb 100644
--- 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 165895cc9..f15522d16 100644
--- 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 346b99728..0d4d29e7a 100644
--- 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 2be3f12df..8c6d81dd6 100644
--- 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 705290b5f..a4a128bf6 100644
--- a/libguile/error.h
+++ b/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);