1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
|
; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
;;;; Raising and handling conditions
; An exception is an unusual situation detected by the virtual machine.
; A condition is a run-time system structure describing unusual situations,
; including exceptions.
; Usual exception handler vector.
(define (define-exception-handler opcode proc)
(vector-set! exception-handlers opcode proc))
(define (signal-exception opcode reason . args)
(really-signal-condition (make-exception opcode
(if reason
(enumerand->name reason exception)
#f)
args)))
(define exception-handlers
(make-vector op-count signal-exception))
; TRAP is the same as SIGNAL-CONDITION.
(define-exception-handler (enum op trap)
(lambda (opcode reason arg)
(really-signal-condition arg)))
; The time opcode sometimes needs a little help.
(define-exception-handler (enum op time)
(lambda (opcode reason option arg0 . maybe-arg1)
(if (= reason (enum exception arithmetic-overflow))
(+ (* arg0 1000) ; seconds
(car maybe-arg1)) ; milliseconds
(apply signal-exception opcode reason option arg0 maybe-arg1))))
; This is for generic arithmetic, mostly
(define (extend-opcode! opcode make-handler)
(let* ((except (lambda args
(apply signal-exception
opcode
#f ; lost our reason
args)))
(handler (make-handler except)))
(define-exception-handler opcode
(lambda (opcode reason . args)
(apply handler args)))))
; Raising and handling conditions.
; (fluid $condition-handlers) is a list of handler procedures.
; Each handler takes two arguments: the condition to be handled, and
; a thunk that can be called if the handler decides to decline handling
; the condition. The continuation to a call to a handler is that
; of the call to signal-condition.
(define (really-signal-condition condition)
(let loop ((hs (fluid $condition-handlers)))
((car hs) condition (lambda () (loop (cdr hs))))))
(define (with-handler h thunk)
(let-fluid $condition-handlers
(cons h (fluid $condition-handlers))
thunk))
(define $condition-handlers
(make-fluid #f))
; CURRENT-ERROR-PORT and WRITE-STRING are passed in to avoid circular
; module dependencies.
(define (initialize-exceptions! current-error-port write-string thunk)
(call-with-current-continuation
(lambda (k)
(set-fluid! $condition-handlers
(list (last-resort-condition-handler k
current-error-port
write-string)))
(set-exception-handlers! exception-handlers)
(thunk))))
(define (last-resort-condition-handler halt current-error-port write-string)
(let ((interrupt/keyboard (enum interrupt keyboard))
(losing? #f))
(lambda (condition punt)
(cond ((error? condition)
(primitive-catch
(lambda (c)
(if (not losing?)
(begin (set! losing? #t)
(report-utter-lossage condition
c
current-error-port
write-string)))
(halt 123))))
((and (interrupt? condition)
(= (cadr condition) interrupt/keyboard))
(halt 2))
(else
(unspecific)))))) ;proceed
; This will print a list of template id's, which you can look up in
; initial.debug to get some idea of what was going on.
(define (report-utter-lossage condition c current-error-port write-string)
(let ((out (current-error-port)))
(if out
(begin
(cond ((exception? condition)
(write-string (number->string (exception-opcode condition))
out)
(write-string " / " out))
((or (error? condition)
(warning? condition))
(write-string (car (condition-stuff condition)) out)
(write-string " / " out)))
(for-each (lambda (id+pc)
(if (number? (car id+pc))
(write-string (number->string
(car id+pc))
out))
(write-string " <- " out))
(continuation-preview c))
(write-char #\newline out)))))
(define (continuation-preview c)
(if (continuation? c)
(cons (cons (template-info (continuation-template c))
(continuation-pc c))
(continuation-preview (continuation-parent c)))
'()))
; ERROR is a compiler primitive, but if it weren't, it could be
; defined as follows:
;(define (error message . irritants)
; (signal-condition (make-condition 'error (cons message irritants))))
; Run THUNK, returning either the value returned by THUNK or any error
; that occurs.
(define (ignore-errors thunk)
(call-with-current-continuation
(lambda (k)
(with-handler (lambda (c next)
(if (error? c)
(k c)
(next)))
thunk))))
; Downgrade errors to warnings while executing THUNK. Returns #T if an
; error occured.
(define (report-errors-as-warnings thunk message . irritants)
(let ((condition (ignore-errors
(lambda ()
(thunk)
#f))))
(if condition
(begin
(apply warn message (append irritants (list condition)))
#t)
#f)))
; Define disclosers that are most important for error messages.
(define-method &disclose ((obj :closure))
(list 'procedure (template-ref (closure-template obj) 1)))
(define-method &disclose ((obj :location))
(list 'location (location-id obj)))
; (put 'with-handler 'scheme-indent-hook 1)
|