diff options
author | Gary Houston <ghouston@arglist.com> | 1996-09-07 20:48:45 +0000 |
---|---|---|
committer | Gary Houston <ghouston@arglist.com> | 1996-09-07 20:48:45 +0000 |
commit | 7cb1d4d3059649fd611551e06c3c7aaae6d97397 (patch) | |
tree | 7e5190d3190d5b9e89c376d4fa4f776e5e3c6219 | |
parent | cceac91b8b8356ede44b8230813ee023da297a8d (diff) | |
download | guile-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/ChangeLog | 5 | ||||
-rw-r--r-- | ice-9/boot-9.scm | 69 | ||||
-rw-r--r-- | libguile/ChangeLog | 13 | ||||
-rw-r--r-- | libguile/__scm.h | 18 | ||||
-rw-r--r-- | libguile/error.c | 25 | ||||
-rw-r--r-- | libguile/error.h | 2 |
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); |