summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGary Houston <ghouston@arglist.com>1996-09-19 09:04:55 +0000
committerGary Houston <ghouston@arglist.com>1996-09-19 09:04:55 +0000
commit2194b6f00e053c36c59df2d2cc686385e64cca68 (patch)
tree4e7764215ae6ae3a7f50acca332ef019860b4150
parent9fec1f77c3b6277cd30b48a6dbb74b0e8d967547 (diff)
downloadguile-2194b6f00e053c36c59df2d2cc686385e64cca68.tar.gz
* boot-9.scm (%%handle-system-error key): remove the code for
SCM-style errors. handle the case that an unexpected number of args are supplied. (%%system-errors): removed. (error): redefine using a throw with key and 4 args. ('error): associate 'error, 'error-signal keys with %%handle-system-error. (%%default-error-handler): removed. (signal-handler): throw with 4 args and use the error-signal key. Create an error message instead of using numerical codes. (%%bad-throw): call error instead of throw if key not found. * boot-9.scm: initialize new error keys (see libguile/ChangeLog). (%%handle-system-error key): check subr is not #f before printing. Recognize %s (embed an argument using "display") and %S (embed an argument using "write").
-rw-r--r--ice-9/ChangeLog21
-rw-r--r--ice-9/boot-9.scm249
2 files changed, 137 insertions, 133 deletions
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index 3921efee0..a43879e51 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,24 @@
+Wed Sep 18 09:07:37 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm (%%handle-system-error key): remove the code for
+ SCM-style errors. handle the case that an unexpected number
+ of args are supplied.
+ (%%system-errors): removed.
+ (error): redefine using a throw with key and 4 args.
+ ('error): associate 'error, 'error-signal keys with
+ %%handle-system-error.
+ (%%default-error-handler): removed.
+ (signal-handler): throw with 4 args and use the error-signal key.
+ Create an error message instead of using numerical codes.
+ (%%bad-throw): call error instead of throw if key not found.
+
+Tue Sep 17 04:11:28 1996 Gary Houston <ghouston@actrix.gen.nz>
+
+ * boot-9.scm: initialize new error keys (see libguile/ChangeLog).
+ (%%handle-system-error key): check subr is not #f before printing.
+ Recognize %s (embed an argument using "display") and
+ %S (embed an argument using "write").
+
Sun Sep 15 03:55:35 1996 Gary Houston <ghouston@actrix.gen.nz>
* boot-9.scm (%%handle-system-error key): set args and rest to
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index da1a3dc27..5b7bfd9cb 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -577,41 +577,15 @@
;;; {Error Handling}
;;;
-
-;; (error . args) is short for (throw (quote error) . args)
-;;
(define (error . args)
- (apply throw 'error args))
-
-
-
-
-;; Error handling a la SCM.
-;;
-(define (%%default-error-handler tag . args)
- (define cep (current-error-port))
- (perror "ERROR")
- (errno 0)
- (display "ERROR: " cep)
- (if (not (null? args))
- (begin (display (car args) cep)
- (for-each (lambda (x) (display #\ cep) (write x cep))
- (cdr args))))
- (newline cep)
- (force-output cep)
- (apply throw 'abort tag args))
-
-
-
-;; Install SCM error handling as the default.
-;;
-(set-symbol-property! 'error
- 'throw-handler-default
- %%default-error-handler)
-
-
-
-
+ (if (null? args)
+ (throw 'error #f "?" #f #f)
+ (let loop ((msg "%s")
+ (rest (cdr args)))
+ (if (not (null? rest))
+ (loop (string-append msg " %S")
+ (cdr rest))
+ (throw 'error #f msg args #f)))))
;; %%bad-throw is the hook that is called upon a throw to a an unhandled
;; key. If the key has a default handler (a throw-handler-default property),
@@ -620,40 +594,37 @@
(define (%%bad-throw key . args)
(let ((default (symbol-property key 'throw-handler-default)))
(or (and default (apply default key args))
- (throw 'error 'unhandled-exception key args))))
-
-
-
-
+ (apply error "unhandled-exception:" key args))))
-;; A number of internally defined error types are represented
+;; mostly obsolete.
+;; A number of internally defined error types were represented
;; as integers. Here is the mapping to symbolic names
;; and error messages.
;;
-(define %%system-errors
- '((-1 UNKNOWN "Unknown error")
- (0 ARGn "Wrong type argument to ")
- (1 ARG1 "Wrong type argument in position 1 to ")
- (2 ARG2 "Wrong type argument in position 2 to ")
- (3 ARG3 "Wrong type argument in position 3 to ")
- (4 ARG4 "Wrong type argument in position 4 to ")
- (5 ARG5 "Wrong type argument in position 5 to ")
- (6 ARG5 "Wrong type argument in position 5 to ")
- (7 ARG5 "Wrong type argument in position 5 to ")
- (8 WNA "Wrong number of arguments to ")
- (9 OVFLOW "Numerical overflow to ")
- (10 OUTOFRANGE "Argument out of range to ")
- (11 NALLOC "Could not allocate to ")
- (12 STACK_OVFLOW "Stack overflow")
- (13 EXIT "Exit (internal error?).")
- (14 HUP_SIGNAL "hang-up")
- (15 INT_SIGNAL "user interrupt")
- (16 FPE_SIGNAL "arithmetic error")
- (17 BUS_SIGNAL "bus error")
- (18 SEGV_SIGNAL "segmentation violation")
- (19 ALRM_SIGNAL "alarm")
- (20 GC_SIGNAL "gc")
- (21 TICK_SIGNAL "tick")))
+;(define %%system-errors
+; '((-1 UNKNOWN "Unknown error")
+; (0 ARGn "Wrong type argument to ")
+; (1 ARG1 "Wrong type argument in position 1 to ")
+; (2 ARG2 "Wrong type argument in position 2 to ")
+; (3 ARG3 "Wrong type argument in position 3 to ")
+; (4 ARG4 "Wrong type argument in position 4 to ")
+; (5 ARG5 "Wrong type argument in position 5 to ")
+; (6 ARG5 "Wrong type argument in position 5 to ")
+; (7 ARG5 "Wrong type argument in position 5 to ")
+; (8 WNA "Wrong number of arguments to ")
+; (9 OVFLOW "Numerical overflow to ")
+; (10 OUTOFRANGE "Argument out of range to ")
+; (11 NALLOC "Could not allocate to ")
+; (12 STACK_OVFLOW "Stack overflow")
+; (13 EXIT "Exit (internal error?).")
+; (14 HUP_SIGNAL "hang-up")
+; (15 INT_SIGNAL "user interrupt")
+; (16 FPE_SIGNAL "arithmetic error")
+; (17 BUS_SIGNAL "bus error")
+; (18 SEGV_SIGNAL "segmentation violation")
+; (19 ALRM_SIGNAL "alarm")
+; (20 GC_SIGNAL "gc")
+; (21 TICK_SIGNAL "tick")))
(define (timer-thunk) #t)
@@ -661,76 +632,88 @@
(define (alarm-thunk) #t)
(define (signal-handler n)
- (cond
- ((= n 21) (unmask-signals) (timer-thunk))
- ((= n 20) (unmask-signals) (gc-thunk))
- ((= n 19) (unmask-signals) (alarm-thunk))
- (else (unmask-signals) (throw 'system-error n #f))))
-
-
-;; The default handler for built-in error types when
-;; thrown by their symbolic name.
+ (let* (
+ ;; these numbers are set in libguile, not the same as those
+ ;; interned in posix.c.
+ ;;
+ (signal-messages `((14 . "hang-up")
+ (15 . "user interrupt")
+ (16 . "arithmetic error")
+ (17 . "bus error")
+ (18 . "segmentation violation"))))
+ (cond
+ ((= n 21) (unmask-signals) (timer-thunk))
+ ((= n 20) (unmask-signals) (gc-thunk))
+ ((= n 19) (unmask-signals) (alarm-thunk))
+ (else (unmask-signals)
+ (let ((sig-pair (assoc n signal-messages)))
+ (throw 'error-signal #f
+ (cdr (or sig-pair
+ (cons n "Unknow signal: %s")))
+ (if sig-pair
+ #f
+ (list n))
+ (list n)))))))
+
+(define display-error-message
+ (lambda (message args port)
+ (if (or (not (list? args))
+ (null? args))
+ (display message port)
+ (let ((len (string-length message)))
+ (cond ((< len 2)
+ (display message port))
+ ((string=? (substring message 0 2)
+ "%s")
+ (display (car args) port)
+ (display-error-message (substring message 2 len)
+ (cdr args)
+ port))
+ ((string=? (substring message 0 2)
+ "%S")
+ (write (car args) port)
+ (display-error-message (substring message 2 len)
+ (cdr args)
+ port))
+ (else
+ (display (substring message 0 1)
+ port)
+ (display-error-message (substring message 1 len)
+ args
+ port)))))))
+
+;; The default handler for built-in error types when thrown by their
+;; symbolic names.
(define (%%handle-system-error key . arg-list)
- (cond ((= (length arg-list) 4)
- (letrec ((subr (car arg-list))
- (message (cadr arg-list))
- (args (or (caddr arg-list)
- '()))
- (rest (or (cadddr arg-list)
- '()))
- (cep (current-error-port))
- (fill-message
- (lambda (message args)
- (if (null? args)
- (display message cep)
- (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 1)
- cep)
- (fill-message
- (substring message 1 len)
- args))))))))
- (display "ERROR: " cep)
- (display subr cep)
- (display ": " cep)
- (cond ((list? args)
- (fill-message message args))
- (else
- (display message cep)
- (display " (bad message args)" cep)))
- (newline cep)
- (force-output cep)
- (apply throw 'abort key (list (car 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)))))
-
-;; associate error symbols with the default handler.
-(let loop ((keys '(system-error numerical-overflow out-of-range)))
+ (let ((cep (current-error-port)))
+ (cond ((not (= (length arg-list) 4))
+ (display "ERROR: bad error throw: " cep)
+ (write arg-list cep))
+ (else
+ (let ((subr (car arg-list))
+ (message (cadr arg-list))
+ (args (or (caddr arg-list)
+ '()))
+ (rest (or (cadddr arg-list)
+ '())))
+ (display "ERROR: " cep)
+ (cond (subr
+ (display subr cep)
+ (display ": " cep)))
+ (cond ((list? args)
+ (display-error-message message args cep))
+ (else
+ (display message cep)
+ (display " (bad message args)" cep))))))
+ (newline cep)
+ (force-output cep)
+ (throw 'abort key)))
+
+;; associate error symbols with %%handle-system-error.
+(let loop ((keys '(error error-signal system-error numerical-overflow
+ out-of-range wrong-type-arg wrong-number-of-args
+ memory-allocation-error stack-overflow
+ misc-error)))
(cond ((not (null? keys))
(set-symbol-property! (car keys)
'throw-handler-default