mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +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 (else
exn))))) exn)))))
(define-values* (raise-exception (define-values* (exception-kind
exception-args
raise-exception
with-exception-handler with-exception-handler
catch catch
with-throw-handler with-throw-handler

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

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

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

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