mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

SRFI-18 uses core exceptions

Browse source 
* module/ice-9/boot-9.scm (exception-kind, exception-args): Export.
* module/ice-9/exceptions.scm (exception-kind, exception-args):
  Re-export.
* module/srfi/srfi-18.scm: Rewrite exception support in terms of core
  exceptions, not SRFI-34/35.
* test-suite/tests/srfi-18.test: Since Guile doesn't expose the current
  exception handler as such, SRFI-18 captures it using delimited
  continuations.  This means that we can't compare the result
  of (current-exception-handler) with the installed handler using eq?,
  even though the procedures are indeed equivalent.  So, instead test
  handler behavior.
This commit is contained in:
Andy Wingo 2019-11-14 16:33:10 +01:00
parent 44ee8c5559
commit 95efe14e44
4 changed files with 87 additions and 103 deletions
Download patch file Download diff file Expand all files Collapse all files

4
module/ice-9/boot-9.scm
View file

@ -1538,7 +1538,9 @@ exception that is an instance of @var{rtd}."
(else
exn)))))
(define-values* (raise-exception
(define-values* (exception-kind
exception-args
raise-exception
with-exception-handler
catch
with-throw-handler

3
module/ice-9/exceptions.scm
View file

@ -32,6 +32,9 @@
exception-predicate
exception-accessor
exception-kind
exception-args
&error
&programming-error
&non-continuable

146
module/srfi/srfi-18.scm
View file

@ -31,13 +31,10 @@
;;; Code:
(define-module (srfi srfi-18)
#:use-module (ice-9 exceptions)
#:use-module ((ice-9 threads) #:prefix threads:)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module ((srfi srfi-34) #:prefix srfi-34:)
#:use-module ((srfi srfi-35) #:select (define-condition-type
&error
condition))
#:export (;; Threads
make-thread
thread-name
@ -74,13 +71,13 @@
seconds->time
current-exception-handler
with-exception-handler
join-timeout-exception?
abandoned-mutex-exception?
terminated-thread-exception?
uncaught-exception?
uncaught-exception-reason)
#:re-export ((srfi-34:raise . raise))
#:re-export ((raise-continuable . raise)
with-exception-handler)
#:replace (current-time
current-thread
thread?
@ -101,14 +98,14 @@
(scm-error 'wrong-type-arg caller
"Wrong type argument: ~S" (list arg) '())))
(define-condition-type &abandoned-mutex-exception &error
abandoned-mutex-exception?)
(define-condition-type &join-timeout-exception &error
join-timeout-exception?)
(define-condition-type &terminated-thread-exception &error
terminated-thread-exception?)
(define-condition-type &uncaught-exception &error
uncaught-exception?
(define-exception-type &abandoned-mutex-exception &external-error
make-abandoned-mutex-exception abandoned-mutex-exception?)
(define-exception-type &join-timeout-exception &external-error
make-join-timeout-exception join-timeout-exception?)
(define-exception-type &terminated-thread-exception &external-error
make-terminated-thread-exception terminated-thread-exception?)
(define-exception-type &uncaught-exception &programming-error
make-uncaught-exception uncaught-exception?
(reason uncaught-exception-reason))
(define-record-type <mutex>
@ -159,20 +156,17 @@ object (absolute point in time), or #f."
(define (exception-handler-for-foreign-threads obj)
(values))
(define current-exception-handler
(make-parameter exception-handler-for-foreign-threads))
(define (with-exception-handler handler thunk)
(check-arg-type procedure? handler "with-exception-handler")
(check-arg-type thunk? thunk "with-exception-handler")
(srfi-34:with-exception-handler
(let ((prev-handler (current-exception-handler)))
(lambda (obj)
(parameterize ((current-exception-handler prev-handler))
(handler obj))))
(lambda ()
(parameterize ((current-exception-handler handler))
(thunk)))))
(define (current-exception-handler)
(let ((tag (make-prompt-tag)))
(call-with-prompt
tag
(lambda ()
(with-exception-handler
(lambda (exn)
(raise-exception (abort-to-prompt tag) #:continuable? #t))
(lambda ()
(raise-exception #f #:continuable? #t))))
(lambda (k) k))))
;; THREADS
@ -201,23 +195,19 @@ object (absolute point in time), or #f."
(mutex-lock! sm)
(let ((prim (threads:call-with-new-thread
(lambda ()
(catch #t
(lambda ()
(parameterize ((current-thread thread))
(with-thread-mutex-cleanup
(lambda ()
(mutex-lock! sm)
(condition-variable-signal! sc)
(mutex-unlock! sm sc)
(thunk)))))
(lambda (key . args)
(set-thread-exception!
thread
(condition (&uncaught-exception
(reason
(match (cons key args)
(('srfi-34 obj) obj)
(obj obj))))))))))))
(with-exception-handler
(lambda (exn)
(set-thread-exception! thread
(make-uncaught-exception exn)))
(lambda ()
(parameterize ((current-thread thread))
(with-thread-mutex-cleanup
(lambda ()
(mutex-lock! sm)
(condition-variable-signal! sc)
(mutex-unlock! sm sc)
(thunk)))))
#:unwind? #t)))))
(set-thread-prim! thread prim)
(mutex-unlock! sm sc)
thread)))
@ -248,26 +238,14 @@ object (absolute point in time), or #f."
(when (> usecs 0) (usleep usecs))
*unspecified*))
;; Whereas SRFI-34 leaves the continuation of a call to an exception
;; handler unspecified, SRFI-18 has this to say:
;; SRFI-18 has this to say:
;;
;; When one of the primitives defined in this SRFI raises an exception
;; defined in this SRFI, the exception handler is called with the same
;; continuation as the primitive (i.e. it is a tail call to the
;; exception handler).
;;
;; Therefore arrange for exceptions thrown by SRFI-18 primitives to run
;; handlers with the continuation of the primitive call, for those
;; primitives that throw exceptions.
(define (with-exception-handlers-here thunk)
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
(lambda ()
(with-exception-handler (lambda (exn) (abort-to-prompt tag exn))
thunk))
(lambda (k exn)
((current-exception-handler) exn)))))
;; Therefore we use raise-continuable as appropriate.
;; A unique value.
(define %cancel-sentinel (list 'cancelled))
@ -279,21 +257,19 @@ object (absolute point in time), or #f."
(define %timeout-sentinel (list 1))
(define* (thread-join! thread #:optional (timeout %timeout-sentinel)
(timeoutval %timeout-sentinel))
(let ((t (thread-prim thread)))
(with-exception-handlers-here
(lambda ()
(let* ((v (if (eq? timeout %timeout-sentinel)
(threads:join-thread t)
(threads:join-thread t timeout %timeout-sentinel))))
(cond
((eq? v %timeout-sentinel)
(if (eq? timeoutval %timeout-sentinel)
(srfi-34:raise (condition (&join-timeout-exception)))
timeoutval))
((eq? v %cancel-sentinel)
(srfi-34:raise (condition (&terminated-thread-exception))))
((thread-exception thread) => srfi-34:raise)
(else v)))))))
(let* ((t (thread-prim thread))
(v (if (eq? timeout %timeout-sentinel)
(threads:join-thread t)
(threads:join-thread t timeout %timeout-sentinel))))
(cond
((eq? v %timeout-sentinel)
(if (eq? timeoutval %timeout-sentinel)
(raise-continuable (make-join-timeout-exception))
timeoutval))
((eq? v %cancel-sentinel)
(raise-continuable (make-terminated-thread-exception)))
((thread-exception thread) => raise-continuable)
(else v))))
;; MUTEXES
@ -315,18 +291,16 @@ object (absolute point in time), or #f."
(let ((mutexes (thread-mutexes)))
(when mutexes
(hashq-set! mutexes mutex #t)))
(with-exception-handlers-here
(lambda ()
(cond
((threads:lock-mutex (mutex-prim mutex)
(timeout->absolute-time timeout))
(set-mutex-owner! mutex thread)
(when (mutex-abandoned? mutex)
(set-mutex-abandoned?! mutex #f)
(srfi-34:raise
(condition (&abandoned-mutex-exception))))
#t)
(else #f)))))
(cond
((threads:lock-mutex (mutex-prim mutex)
(timeout->absolute-time timeout))
(set-mutex-owner! mutex thread)
(cond
((mutex-abandoned? mutex)
(set-mutex-abandoned?! mutex #f)
(raise-continuable (make-abandoned-mutex-exception)))
(else #t)))
(else #f)))
(define %unlock-sentinel (list 'unlock))
(define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel)

37
test-suite/tests/srfi-18.test
View file

@ -461,21 +461,24 @@
(pass-if "current handler returned at top level"
(procedure? (current-exception-handler)))
(pass-if "specified handler set under with-exception-handler"
(let ((h (lambda (key . args) 'nothing)))
(with-exception-handler h (lambda () (eq? (current-exception-handler)
h)))))
(pass-if-equal "specified handler set under with-exception-handler"
'nothing
(let ((h (lambda (exn) 'nothing)))
(with-exception-handler
h
(lambda () ((current-exception-handler) #f)))))
(pass-if "multiple levels of handler nesting"
(let ((h (lambda (key . args) 'nothing))
(i (current-exception-handler)))
(and (with-exception-handler h (lambda ()
(eq? (current-exception-handler) h)))
(eq? (current-exception-handler) i))))
(pass-if-equal "multiple levels of handler nesting"
42
(with-exception-handler
(lambda (exn) (+ exn 20))
(lambda ()
(with-exception-handler
(lambda (exn) (raise (+ exn 12)))
(lambda () (raise 10))))))
(pass-if "exception handler installation is thread-safe"
(let* ((h1 (current-exception-handler))
(h2 (lambda (key . args) 'nothing-2))
(let* ((h2 (lambda (exn) 'nothing-2))
(m (make-mutex 'current-exception-handler-4))
(c (make-condition-variable 'current-exception-handler-4))
(t (make-thread (lambda ()
@ -485,15 +488,14 @@
(condition-variable-signal! c)
(mutex-unlock! m c)
(mutex-lock! m)
(and (eq? (current-exception-handler) h2)
(and (eq? (raise #f) 'nothing-2)
(mutex-unlock! m)))))
'current-exception-handler-4)))
(mutex-lock! m)
(thread-start! t)
(mutex-unlock! m c)
(mutex-lock! m)
(and (eq? (current-exception-handler) h1)
(condition-variable-signal! c)
(and (condition-variable-signal! c)
(mutex-unlock! m)
(thread-join! t)))))
@ -518,7 +520,10 @@
(with-exception-handler
(lambda (obj)
(and (uncaught-exception? obj)
(equal? (uncaught-exception-reason obj) '(foo))
(equal? (exception-kind (uncaught-exception-reason obj))
'foo)
(equal? (exception-args (uncaught-exception-reason obj))
'())
(set! success #t)))
(lambda () (thread-join! t)))
success)))))