mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-21 12:10:26 +02:00
Code Activity

* boot-9.scm (%%handle-system-error key): remove the code for

Browse source 
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").
This commit is contained in:
Gary Houston 1996-09-19 09:04:55 +00:00
parent 9fec1f77c3
commit 2194b6f00e
2 changed files with 134 additions and 130 deletions
Download patch file Download diff file Expand all files Collapse all files

21
ice-9/ChangeLog
View file

@ -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> 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 * boot-9.scm (%%handle-system-error key): set args and rest to

243
ice-9/boot-9.scm
View file

@ -577,41 +577,15 @@
;;; {Error Handling} ;;; {Error Handling}
;;; ;;;
;; (error . args) is short for (throw (quote error) . args)
;;
(define (error . args) (define (error . args)
(apply throw 'error args)) (if (null? args)
(throw 'error #f "?" #f #f)
(let loop ((msg "%s")
(rest (cdr args)))
(if (not (null? rest))
;; Error handling a la SCM. (loop (string-append msg " %S")
;; (cdr rest))
(define (%%default-error-handler tag . args) (throw 'error #f msg args #f)))))
(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)
;; %%bad-throw is the hook that is called upon a throw to a an unhandled ;; %%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), ;; key. If the key has a default handler (a throw-handler-default property),
@ -620,40 +594,37 @@
(define (%%bad-throw key . args) (define (%%bad-throw key . args)
(let ((default (symbol-property key 'throw-handler-default))) (let ((default (symbol-property key 'throw-handler-default)))
(or (and default (apply default key args)) (or (and default (apply default key args))
(throw 'error 'unhandled-exception key args)))) (apply error "unhandled-exception:" key args))))
;; mostly obsolete.
;; A number of internally defined error types were represented
;; A number of internally defined error types are represented
;; as integers. Here is the mapping to symbolic names ;; as integers. Here is the mapping to symbolic names
;; and error messages. ;; and error messages.
;; ;;
(define %%system-errors ;(define %%system-errors
'((-1 UNKNOWN "Unknown error") ; '((-1 UNKNOWN "Unknown error")
(0 ARGn "Wrong type argument to ") ; (0 ARGn "Wrong type argument to ")
(1 ARG1 "Wrong type argument in position 1 to ") ; (1 ARG1 "Wrong type argument in position 1 to ")
(2 ARG2 "Wrong type argument in position 2 to ") ; (2 ARG2 "Wrong type argument in position 2 to ")
(3 ARG3 "Wrong type argument in position 3 to ") ; (3 ARG3 "Wrong type argument in position 3 to ")
(4 ARG4 "Wrong type argument in position 4 to ") ; (4 ARG4 "Wrong type argument in position 4 to ")
(5 ARG5 "Wrong type argument in position 5 to ") ; (5 ARG5 "Wrong type argument in position 5 to ")
(6 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 ") ; (7 ARG5 "Wrong type argument in position 5 to ")
(8 WNA "Wrong number of arguments to ") ; (8 WNA "Wrong number of arguments to ")
(9 OVFLOW "Numerical overflow to ") ; (9 OVFLOW "Numerical overflow to ")
(10 OUTOFRANGE "Argument out of range to ") ; (10 OUTOFRANGE "Argument out of range to ")
(11 NALLOC "Could not allocate to ") ; (11 NALLOC "Could not allocate to ")
(12 STACK_OVFLOW "Stack overflow") ; (12 STACK_OVFLOW "Stack overflow")
(13 EXIT "Exit (internal error?).") ; (13 EXIT "Exit (internal error?).")
(14 HUP_SIGNAL "hang-up") ; (14 HUP_SIGNAL "hang-up")
(15 INT_SIGNAL "user interrupt") ; (15 INT_SIGNAL "user interrupt")
(16 FPE_SIGNAL "arithmetic error") ; (16 FPE_SIGNAL "arithmetic error")
(17 BUS_SIGNAL "bus error") ; (17 BUS_SIGNAL "bus error")
(18 SEGV_SIGNAL "segmentation violation") ; (18 SEGV_SIGNAL "segmentation violation")
(19 ALRM_SIGNAL "alarm") ; (19 ALRM_SIGNAL "alarm")
(20 GC_SIGNAL "gc") ; (20 GC_SIGNAL "gc")
(21 TICK_SIGNAL "tick"))) ; (21 TICK_SIGNAL "tick")))
(define (timer-thunk) #t) (define (timer-thunk) #t)
@ -661,76 +632,88 @@
(define (alarm-thunk) #t) (define (alarm-thunk) #t)
(define (signal-handler n) (define (signal-handler n)
(cond (let* (
((= n 21) (unmask-signals) (timer-thunk)) ;; these numbers are set in libguile, not the same as those
((= n 20) (unmask-signals) (gc-thunk)) ;; interned in posix.c.
((= n 19) (unmask-signals) (alarm-thunk)) ;;
(else (unmask-signals) (throw 'system-error n #f)))) (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 ;; The default handler for built-in error types when thrown by their
;; thrown by their symbolic name. ;; symbolic names.
(define (%%handle-system-error key . arg-list) (define (%%handle-system-error key . arg-list)
(cond ((= (length arg-list) 4) (let ((cep (current-error-port)))
(letrec ((subr (car arg-list)) (cond ((not (= (length arg-list) 4))
(message (cadr arg-list)) (display "ERROR: bad error throw: " cep)
(args (or (caddr arg-list) (write arg-list cep))
'())) (else
(rest (or (cadddr arg-list) (let ((subr (car arg-list))
'())) (message (cadr arg-list))
(cep (current-error-port)) (args (or (caddr arg-list)
(fill-message '()))
(lambda (message args) (rest (or (cadddr arg-list)
(if (null? args) '())))
(display message cep) (display "ERROR: " cep)
(let ((len (string-length message))) (cond (subr
(cond ((< len 2) (display subr cep)
(display message cep)) (display ": " cep)))
((string=? (substring message 0 2) (cond ((list? args)
"%S") (display-error-message message args cep))
(display (car args) cep) (else
(fill-message (display message cep)
(substring message 2 len) (display " (bad message args)" cep))))))
(cdr args))) (newline cep)
(else (force-output cep)
(display (substring message 0 1) (throw 'abort key)))
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. ;; associate error symbols with %%handle-system-error.
(let loop ((keys '(system-error numerical-overflow out-of-range))) (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)) (cond ((not (null? keys))
(set-symbol-property! (car keys) (set-symbol-property! (car keys)
'throw-handler-default 'throw-handler-default