mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 19:50:24 +02:00
Code Activity

srfi-18: Improve style.

Browse source 
* module/srfi/srfi-18.scm (raise): Rely on SRFI-34 to #:replace raise.
  (make-thread): Use lambda* and when.
This commit is contained in:
Andy Wingo 2016-10-30 20:38:18 +01:00
parent e5399d3e7c
commit 501c0e67b1
1 changed files with 7 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -70,7 +70,6 @@
current-exception-handler current-exception-handler
with-exception-handler with-exception-handler
raise
join-timeout-exception? join-timeout-exception?
abandoned-mutex-exception? abandoned-mutex-exception?
terminated-thread-exception? terminated-thread-exception?
@ -79,12 +78,12 @@
#:re-export ((threads:condition-variable? . condition-variable?) #:re-export ((threads:condition-variable? . condition-variable?)
(threads:current-thread . current-thread) (threads:current-thread . current-thread)
(threads:thread? . thread?) (threads:thread? . thread?)
(threads:mutex? . mutex?)) (threads:mutex? . mutex?)
raise)
#:replace (current-time #:replace (current-time
make-thread make-thread
make-mutex make-mutex
make-condition-variable make-condition-variable))
raise))
(unless (provided? 'threads) (unless (provided? 'threads)
(error "SRFI-18 requires Guile with threads support")) (error "SRFI-18 requires Guile with threads support"))
@ -109,7 +108,6 @@
;; EXCEPTIONS ;; EXCEPTIONS
(define raise (@ (srfi srfi-34) raise))
(define (initial-handler obj) (define (initial-handler obj)
(srfi-18-exception-preserver (cons uncaught-exception obj))) (srfi-18-exception-preserver (cons uncaught-exception obj)))
@ -181,10 +179,8 @@
(threads:unlock-mutex smutex) (threads:unlock-mutex smutex)
(with-exception-handler initial-handler (with-exception-handler initial-handler
thunk))))) thunk)))))
(lambda (thunk . name) (lambda* (thunk #:optional name)
(let ((n (and (pair? name) (car name))) (let ((lm (make-mutex 'launch-mutex))
(lm (make-mutex 'launch-mutex))
(lc (make-condition-variable 'launch-condition-variable)) (lc (make-condition-variable 'launch-condition-variable))
(sm (make-mutex 'start-mutex)) (sm (make-mutex 'start-mutex))
(sc (make-condition-variable 'start-condition-variable))) (sc (make-condition-variable 'start-condition-variable)))
@ -194,7 +190,7 @@
(make-cond-wrapper thunk lc lm sc sm) (make-cond-wrapper thunk lc lm sc sm)
srfi-18-exception-handler))) srfi-18-exception-handler)))
(hashq-set! thread-start-conds t (cons sm sc)) (hashq-set! thread-start-conds t (cons sm sc))
(and n (hashq-set! object-names t n)) (when name (hashq-set! object-names t name))
(threads:wait-condition-variable lc lm) (threads:wait-condition-variable lc lm)
(threads:unlock-mutex lm) (threads:unlock-mutex lm)
t))))) t)))))