[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-77-gd489998
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-77-gd489998 |
|
Date: |
Fri, 02 Mar 2012 16:21:22 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=d489998364e5f20e81cf7cf12998e694626d2f6f
The branch, master has been updated
via d489998364e5f20e81cf7cf12998e694626d2f6f (commit)
via eebcacf41c4fe58ad8c9388d516a99f59212b223 (commit)
via 542aa859dede56545538fd90e6ee5b2abe3f5f25 (commit)
via 20337139d20d0587ebf78c05a7efa6db2337d2e6 (commit)
via e082b13b662309021c73bae1561fb5c6d191d258 (commit)
via ef405f8ba73fc57706d7155a2e008352416debcf (commit)
via d316047326fde9d63ca52c0051fbf09124ef297e (commit)
via a850c3ccc4bebe07dba2298c5ed0bc86bb64f172 (commit)
via 006163e02febaf5569bd42b362957a99c01c4528 (commit)
from 79eb47ea47650ef42c545931726277a7118a0210 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d489998364e5f20e81cf7cf12998e694626d2f6f
Merge: 79eb47e eebcacf
Author: Andy Wingo <address@hidden>
Date: Fri Mar 2 17:20:47 2012 +0100
Merge remote-tracking branch 'origin/stable-2.0'
There are a some failures currently:
FAIL: tree-il.test: warnings: format: non-literal format string with
forward declaration
ERROR: srfi-18.test: current-exception-handler: current handler
returned at top level - arguments: ((wrong-type-arg "car" "Wrong type argument
in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))
ERROR: srfi-18.test: current-exception-handler: multiple levels of
handler nesting - arguments: ((wrong-type-arg "car" "Wrong type argument in
position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>) (#<unspecified>)))
ERROR: srfi-18.test: current-exception-handler: exception handler
installation is thread-safe - arguments: ((wrong-type-arg "car" "Wrong type
argument in position ~A (expecting ~A): ~S" (1 "pair" #<unspecified>)
(#<unspecified>)))
Conflicts:
module/language/tree-il/peval.scm
module/language/tree-il/primitives.scm
test-suite/tests/tree-il.test
-----------------------------------------------------------------------
Summary of changes:
module/language/tree-il/analyze.scm | 3 +-
module/language/tree-il/canonicalize.scm | 10 +-
module/language/tree-il/peval.scm | 35 +-
module/language/tree-il/primitives.scm | 31 +-
module/srfi/srfi-4.scm | 6 +-
module/srfi/srfi-4/gnu.scm | 5 +-
module/system/base/pmatch.scm | 16 +-
test-suite/lib.scm | 55 +-
test-suite/tests/srfi-18.test | 863 +++++++++++++++---------------
test-suite/tests/srfi-4.test | 25 +
test-suite/tests/tree-il.test | 49 ++-
11 files changed, 592 insertions(+), 506 deletions(-)
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 11c19d8..5c1cb55 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1360,7 +1360,8 @@ resort, return #t when EXP refers to the global variable
SPECIAL-NAME."
(($ <toplevel-ref> _ name)
(let ((var (false-if-exception (module-variable env name))))
(if var
- (eq? (variable-ref var) proc)
+ (eq? (false-if-exception (variable-ref var)) ; VAR may be unbound
+ proc)
(eq? name special-name)))) ; special hack to support local
aliases
(($ <module-ref> _ module name public?)
(let ((m (false-if-exception (if public?
diff --git a/module/language/tree-il/canonicalize.scm
b/module/language/tree-il/canonicalize.scm
index 27d7295..2536a71 100644
--- a/module/language/tree-il/canonicalize.scm
+++ b/module/language/tree-il/canonicalize.scm
@@ -1,6 +1,6 @@
;;; Tree-il canonicalizer
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -48,10 +48,10 @@
(define (escape-only? handler)
(match handler
(($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
- (tree-il-any (lambda (x)
- (and (lexical-ref? x)
- (eq? (lexical-ref-gensym x) cont)))
- body))
+ (not (tree-il-any (lambda (x)
+ (and (lexical-ref? x)
+ (eq? (lexical-ref-gensym x) cont)))
+ body)))
(else #f)))
(define (thunk-application? x)
(match x
diff --git a/module/language/tree-il/peval.scm
b/module/language/tree-il/peval.scm
index a588b68..6b37591 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1221,21 +1221,36 @@ top-level bindings from ENV and return the resulting
expression."
exp
(make-lambda src meta (for-values body))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
+ (define (lift-applied-lambda body gensyms)
+ (and (not opt) rest (not kw)
+ (match body
+ (($ <primcall> _ '@apply
+ (($ <lambda> _ _ lcase)
+ ($ <lexical-ref> _ _ sym)
+ ...))
+ (and (equal? sym gensyms)
+ (not (lambda-case-alternate lcase))
+ lcase))
+ (_ #f))))
(let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars))
(env (fold extend-env env gensyms
(make-unbound-operands vars new)))
(new-sym (lambda (old)
- (operand-sym (cdr (vhash-assq old env))))))
- (make-lambda-case src req opt rest
- (match kw
- ((aok? (kw name old) ...)
- (cons aok? (map list kw name (map new-sym old))))
- (_ #f))
- (map (cut loop <> env counter 'value) inits)
- new
- (loop body env counter ctx)
- (and alt (for-tail alt)))))
+ (operand-sym (cdr (vhash-assq old env)))))
+ (body (loop body env counter ctx)))
+ (or
+ ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
+ (lift-applied-lambda body new)
+ (make-lambda-case src req opt rest
+ (match kw
+ ((aok? (kw name old) ...)
+ (cons aok? (map list kw name (map new-sym
old))))
+ (_ #f))
+ (map (cut loop <> env counter 'value) inits)
+ new
+ body
+ (and alt (for-tail alt))))))
(($ <seq> src head tail)
(let ((head (for-effect head))
(tail (for-tail tail)))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 157aaa1..3d98c68 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -544,22 +544,21 @@
'call-with-prompt
(case-lambda
((src tag thunk handler)
- ;; Sigh. Until the inliner does its job, manually inline
- ;; (let ((h (lambda ...))) (prompt k x h))
- (cond
- ((lambda? handler)
- (let ((args-sym (gensym)))
- (make-prompt
- src tag (make-call #f thunk '())
- ;; If handler itself is a lambda, the inliner can do some
- ;; trickery here.
- (make-lambda-case
- (tree-il-src handler) '() #f 'args #f '() (list args-sym)
- (make-primcall #f 'apply
- (list handler
- (make-lexical-ref #f 'args
args-sym)))
- #f))))
- (else #f)))
+ (let ((handler-sym (gensym))
+ (args-sym (gensym)))
+ (make-let
+ src '(handler) (list handler-sym) (list handler)
+ (make-prompt
+ src tag (make-call #f thunk '())
+ ;; If handler itself is a lambda, the inliner can do some
+ ;; trickery here.
+ (make-lambda-case
+ (tree-il-src handler) '() #f 'args #f '() (list args-sym)
+ (make-primcall
+ #f 'apply
+ (list (make-lexical-ref #f 'handler handler-sym)
+ (make-lexical-ref #f 'args args-sym)))
+ #f)))))
(else #f)))
(hashq-set! *primitive-expand-table*
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index 818ae7a..43f5ef6 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -1,6 +1,7 @@
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
-;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software
Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
+;; 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -79,7 +80,8 @@
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
- (/ ,size (uniform-vector-element-size v)))))
+ (uniform-vector-element-size v)
+ (/ ,size))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index ac22809..39d6350 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -1,6 +1,6 @@
;;; Extensions to SRFI-4
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -52,7 +52,8 @@
(apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v)
- (/ ,size (uniform-vector-element-size v)))))
+ (uniform-vector-element-size v)
+ (/ ,size))))
(if (integer? len)
len
(error "fractional length" v ',tag ,size))))
diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm
index 00563f6..e9b9eb2 100644
--- a/module/system/base/pmatch.scm
+++ b/module/system/base/pmatch.scm
@@ -1,6 +1,6 @@
;;; pmatch, a simple matcher
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc
+;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
;;; Copyright (C) 2007 Daniel P. Friedman
;;;
@@ -35,22 +35,22 @@
;;; Code:
(define-module (system base pmatch)
- #:export (pmatch))
+ #:export-syntax (pmatch))
-(define-syntax pmatch
+(define-syntax-rule (pmatch e cs ...)
+ (let ((v e)) (pmatch1 v cs ...)))
+
+(define-syntax pmatch1
(syntax-rules (else guard)
- ((_ (op arg ...) cs ...)
- (let ((v (op arg ...)))
- (pmatch v cs ...)))
((_ v) (if #f #f))
((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
- (let ((fk (lambda () (pmatch v cs ...))))
+ (let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
- (let ((fk (lambda () (pmatch v cs ...))))
+ (let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index 681a0d1..5785378 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -314,34 +314,33 @@
;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
-(define run-test #f)
-(let ((test-running #f))
- (define (local-run-test name expect-pass thunk)
- (if test-running
- (error "Nested calls to run-test are not permitted.")
- (let ((test-name (full-name name)))
- (set! test-running #t)
- (catch #t
- (lambda ()
- (let ((result (thunk)))
- (if (eq? result #t) (throw 'pass))
- (if (eq? result #f) (throw 'fail))
- (throw 'unresolved)))
- (lambda (key . args)
- (case key
- ((pass)
- (report (if expect-pass 'pass 'upass) test-name))
- ((fail)
- (report (if expect-pass 'fail 'xfail) test-name))
- ((unresolved untested unsupported)
- (report key test-name))
- ((quit)
- (report 'unresolved test-name)
- (quit))
- (else
- (report 'error test-name (cons key args))))))
- (set! test-running #f))))
- (set! run-test local-run-test))
+(define run-test
+ (let ((test-running #f))
+ (lambda (name expect-pass thunk)
+ (if test-running
+ (error "Nested calls to run-test are not permitted."))
+ (let ((test-name (full-name name)))
+ (set! test-running #t)
+ (catch #t
+ (lambda ()
+ (let ((result (thunk)))
+ (if (eq? result #t) (throw 'pass))
+ (if (eq? result #f) (throw 'fail))
+ (throw 'unresolved)))
+ (lambda (key . args)
+ (case key
+ ((pass)
+ (report (if expect-pass 'pass 'upass) test-name))
+ ((fail)
+ (report (if expect-pass 'fail 'xfail) test-name))
+ ((unresolved untested unsupported)
+ (report key test-name))
+ ((quit)
+ (report 'unresolved test-name)
+ (quit))
+ (else
+ (report 'error test-name (cons key args))))))
+ (set! test-running #f)))))
;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if
diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test
index b769ce1..47f8f7f 100644
--- a/test-suite/tests/srfi-18.test
+++ b/test-suite/tests/srfi-18.test
@@ -1,7 +1,7 @@
;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26
;;;;
-;;;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2008, 2012 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -25,461 +25,458 @@
(if (provided? 'threads)
(use-modules (srfi srfi-18)))
-(and
- (provided? 'threads)
+(cond
+ ((provided? 'threads)
+ (with-test-prefix "current-thread"
-(with-test-prefix "current-thread"
+ (pass-if "current-thread eq current-thread"
+ (eq? (current-thread) (current-thread))))
- (pass-if "current-thread eq current-thread"
- (eq? (current-thread) (current-thread))))
+ (with-test-prefix "thread?"
-(with-test-prefix "thread?"
+ (pass-if "current-thread is thread"
+ (thread? (current-thread)))
- (pass-if "current-thread is thread"
- (thread? (current-thread)))
+ (pass-if "foo not thread"
+ (not (thread? 'foo))))
- (pass-if "foo not thread"
- (not (thread? 'foo))))
+ (with-test-prefix "make-thread"
-(with-test-prefix "make-thread"
+ (pass-if "make-thread creates new thread"
+ (let* ((n (length (all-threads)))
+ (t (make-thread (lambda () 'foo) 'make-thread-1))
+ (r (> (length (all-threads)) n)))
+ (thread-terminate! t) r)))
- (pass-if "make-thread creates new thread"
- (let* ((n (length (all-threads)))
- (t (make-thread (lambda () 'foo) 'make-thread-1))
- (r (> (length (all-threads)) n)))
- (thread-terminate! t) r)))
+ (with-test-prefix "thread-name"
-(with-test-prefix "thread-name"
+ (pass-if "make-thread with name binds name"
+ (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
+ (r (eq? (thread-name t) 'thread-name-1)))
+ (thread-terminate! t) r))
- (pass-if "make-thread with name binds name"
- (let* ((t (make-thread (lambda () 'foo) 'thread-name-1))
- (r (eq? (thread-name t) 'thread-name-1)))
- (thread-terminate! t) r))
+ (pass-if "make-thread without name does not bind name"
+ (let* ((t (make-thread (lambda () 'foo)))
+ (r (not (thread-name t))))
+ (thread-terminate! t) r)))
- (pass-if "make-thread without name does not bind name"
- (let* ((t (make-thread (lambda () 'foo)))
- (r (not (thread-name t))))
- (thread-terminate! t) r)))
+ (with-test-prefix "thread-specific"
-(with-test-prefix "thread-specific"
+ (pass-if "thread-specific is initially #f"
+ (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
+ (r (not (thread-specific t))))
+ (thread-terminate! t) r))
- (pass-if "thread-specific is initially #f"
- (let* ((t (make-thread (lambda () 'foo) 'thread-specific-1))
- (r (not (thread-specific t))))
- (thread-terminate! t) r))
+ (pass-if "thread-specific-set! can set value"
+ (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
+ (thread-specific-set! t "hello")
+ (let ((r (equal? (thread-specific t) "hello")))
+ (thread-terminate! t) r))))
- (pass-if "thread-specific-set! can set value"
- (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
- (thread-specific-set! t "hello")
- (let ((r (equal? (thread-specific t) "hello")))
- (thread-terminate! t) r))))
+ (with-test-prefix "thread-start!"
-(with-test-prefix "thread-start!"
+ (pass-if "thread activates only after start"
+ (let* ((started #f)
+ (m (make-mutex 'thread-start-mutex))
+ (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
+ (and (not started) (thread-start! t) (thread-join! t) started))))
- (pass-if "thread activates only after start"
- (let* ((started #f)
- (m (make-mutex 'thread-start-mutex))
- (t (make-thread (lambda () (set! started #t)) 'thread-start-1)))
- (and (not started) (thread-start! t) (thread-join! t) started))))
+ (with-test-prefix "thread-yield!"
-(with-test-prefix "thread-yield!"
+ (pass-if "thread yield suceeds"
+ (thread-yield!) #t))
- (pass-if "thread yield suceeds"
- (thread-yield!) #t))
+ (with-test-prefix "thread-sleep!"
-(with-test-prefix "thread-sleep!"
+ (pass-if "thread sleep with time"
+ (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
+ (unspecified? (thread-sleep! future-time))))
- (pass-if "thread sleep with time"
- (let ((future-time (seconds->time (+ (time->seconds (current-time)) 2))))
- (unspecified? (thread-sleep! future-time))))
+ (pass-if "thread sleep with number"
+ (let ((old-secs (car (current-time))))
+ (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
- (pass-if "thread sleep with number"
- (let ((old-secs (car (current-time))))
- (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
+ (pass-if "thread does not sleep on past time"
+ (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
+ (unspecified? (thread-sleep! past-time)))))
- (pass-if "thread does not sleep on past time"
- (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
- (unspecified? (thread-sleep! past-time)))))
-
-(with-test-prefix "thread-terminate!"
+ (with-test-prefix "thread-terminate!"
- (pass-if "termination destroys non-started thread"
- (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
- (num-threads (length (all-threads)))
- (success #f))
- (thread-terminate! t)
- (with-exception-handler
- (lambda (obj) (set! success (terminated-thread-exception? obj)))
- (lambda () (thread-join! t)))
- success))
-
- (pass-if "termination destroys started thread"
- (let* ((m1 (make-mutex 'thread-terminate-2a))
- (m2 (make-mutex 'thread-terminate-2b))
- (c (make-condition-variable 'thread-terminate-2))
- (t (make-thread (lambda ()
- (mutex-lock! m1)
- (condition-variable-signal! c)
- (mutex-unlock! m1)
- (mutex-lock! m2))
- 'thread-terminate-2))
- (success #f))
- (mutex-lock! m1)
- (mutex-lock! m2)
- (thread-start! t)
- (mutex-unlock! m1 c)
- (thread-terminate! t)
- (with-exception-handler
- (lambda (obj) (set! success (terminated-thread-exception? obj)))
- (lambda () (thread-join! t)))
- success)))
-
-(with-test-prefix "thread-join!"
-
- (pass-if "join receives result of thread"
- (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
- (thread-start! t)
- (eq? (thread-join! t) 'foo)))
-
- (pass-if "join receives timeout val if timeout expires"
- (let* ((m (make-mutex 'thread-join-2))
- (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
- (mutex-lock! m)
- (thread-start! t)
- (let ((r (thread-join! t (current-time) 'bar)))
- (thread-terminate! t)
- (eq? r 'bar))))
-
- (pass-if "join throws exception on timeout without timeout val"
- (let* ((m (make-mutex 'thread-join-3))
- (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
- (success #f))
- (mutex-lock! m)
- (thread-start! t)
- (with-exception-handler
- (lambda (obj) (set! success (join-timeout-exception? obj)))
- (lambda () (thread-join! t (current-time))))
- (thread-terminate! t)
- success))
-
- (pass-if "join waits on timeout"
- (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
- (thread-start! t)
- (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
-
-(with-test-prefix "mutex?"
-
- (pass-if "make-mutex creates mutex"
- (mutex? (make-mutex)))
-
- (pass-if "symbol not mutex"
- (not (mutex? 'foo))))
-
-(with-test-prefix "mutex-name"
-
- (pass-if "make-mutex with name binds name"
- (let* ((m (make-mutex 'mutex-name-1)))
- (eq? (mutex-name m) 'mutex-name-1)))
-
- (pass-if "make-mutex without name does not bind name"
- (let* ((m (make-mutex)))
- (not (mutex-name m)))))
-
-(with-test-prefix "mutex-specific"
-
- (pass-if "mutex-specific is initially #f"
- (let ((m (make-mutex 'mutex-specific-1)))
- (not (mutex-specific m))))
-
- (pass-if "mutex-specific-set! can set value"
- (let ((m (make-mutex 'mutex-specific-2)))
- (mutex-specific-set! m "hello")
- (equal? (mutex-specific m) "hello"))))
-
-(with-test-prefix "mutex-state"
-
- (pass-if "mutex state is initially not-abandoned"
- (let ((m (make-mutex 'mutex-state-1)))
- (eq? (mutex-state m) 'not-abandoned)))
-
- (pass-if "mutex state of locked, owned mutex is owner thread"
- (let ((m (make-mutex 'mutex-state-2)))
- (mutex-lock! m)
- (eq? (mutex-state m) (current-thread))))
+ (pass-if "termination destroys non-started thread"
+ (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
+ (num-threads (length (all-threads)))
+ (success #f))
+ (thread-terminate! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (terminated-thread-exception? obj)))
+ (lambda () (thread-join! t)))
+ success))
+
+ (pass-if "termination destroys started thread"
+ (let* ((m1 (make-mutex 'thread-terminate-2a))
+ (m2 (make-mutex 'thread-terminate-2b))
+ (c (make-condition-variable 'thread-terminate-2))
+ (t (make-thread (lambda ()
+ (mutex-lock! m1)
+ (condition-variable-signal! c)
+ (mutex-unlock! m1)
+ (mutex-lock! m2))
+ 'thread-terminate-2))
+ (success #f))
+ (mutex-lock! m1)
+ (mutex-lock! m2)
+ (thread-start! t)
+ (mutex-unlock! m1 c)
+ (thread-terminate! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (terminated-thread-exception? obj)))
+ (lambda () (thread-join! t)))
+ success)))
+
+ (with-test-prefix "thread-join!"
+
+ (pass-if "join receives result of thread"
+ (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
+ (thread-start! t)
+ (eq? (thread-join! t) 'foo)))
+
+ (pass-if "join receives timeout val if timeout expires"
+ (let* ((m (make-mutex 'thread-join-2))
+ (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (let ((r (thread-join! t (current-time) 'bar)))
+ (thread-terminate! t)
+ (eq? r 'bar))))
+
+ (pass-if "join throws exception on timeout without timeout val"
+ (let* ((m (make-mutex 'thread-join-3))
+ (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
+ (success #f))
+ (mutex-lock! m)
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (join-timeout-exception? obj)))
+ (lambda () (thread-join! t (current-time))))
+ (thread-terminate! t)
+ success))
+
+ (pass-if "join waits on timeout"
+ (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
+ (thread-start! t)
+ (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
+
+ (with-test-prefix "mutex?"
+
+ (pass-if "make-mutex creates mutex"
+ (mutex? (make-mutex)))
+
+ (pass-if "symbol not mutex"
+ (not (mutex? 'foo))))
+
+ (with-test-prefix "mutex-name"
+
+ (pass-if "make-mutex with name binds name"
+ (let* ((m (make-mutex 'mutex-name-1)))
+ (eq? (mutex-name m) 'mutex-name-1)))
+
+ (pass-if "make-mutex without name does not bind name"
+ (let* ((m (make-mutex)))
+ (not (mutex-name m)))))
+
+ (with-test-prefix "mutex-specific"
+
+ (pass-if "mutex-specific is initially #f"
+ (let ((m (make-mutex 'mutex-specific-1)))
+ (not (mutex-specific m))))
+
+ (pass-if "mutex-specific-set! can set value"
+ (let ((m (make-mutex 'mutex-specific-2)))
+ (mutex-specific-set! m "hello")
+ (equal? (mutex-specific m) "hello"))))
+
+ (with-test-prefix "mutex-state"
+
+ (pass-if "mutex state is initially not-abandoned"
+ (let ((m (make-mutex 'mutex-state-1)))
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "mutex state of locked, owned mutex is owner thread"
+ (let ((m (make-mutex 'mutex-state-2)))
+ (mutex-lock! m)
+ (eq? (mutex-state m) (current-thread))))
- (pass-if "mutex state of locked, unowned mutex is not-owned"
- (let ((m (make-mutex 'mutex-state-3)))
- (mutex-lock! m #f #f)
- (eq? (mutex-state m) 'not-owned)))
-
- (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
- (let* ((m (make-mutex 'mutex-state-4))
- (t (make-thread (lambda () (mutex-lock! m)))))
- (thread-start! t)
- (thread-join! t)
- (eq? (mutex-state m) 'abandoned))))
-
-(with-test-prefix "mutex-lock!"
+ (pass-if "mutex state of locked, unowned mutex is not-owned"
+ (let ((m (make-mutex 'mutex-state-3)))
+ (mutex-lock! m #f #f)
+ (eq? (mutex-state m) 'not-owned)))
+
+ (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
+ (let* ((m (make-mutex 'mutex-state-4))
+ (t (make-thread (lambda () (mutex-lock! m)))))
+ (thread-start! t)
+ (thread-join! t)
+ (eq? (mutex-state m) 'abandoned))))
+
+ (with-test-prefix "mutex-lock!"
- (pass-if "mutex-lock! returns true on successful lock"
- (let* ((m (make-mutex 'mutex-lock-1)))
- (mutex-lock! m)))
-
- (pass-if "mutex-lock! returns false on timeout"
- (let* ((m (make-mutex 'mutex-lock-2))
- (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
- (mutex-lock! m)
- (thread-start! t)
- (not (thread-join! t))))
-
- (pass-if "mutex-lock! returns true when lock obtained within timeout"
- (let* ((m (make-mutex 'mutex-lock-3))
- (t (make-thread (lambda ()
- (mutex-lock! m (+ (time->seconds (current-time))
- 100)
- #f)))))
- (mutex-lock! m)
- (thread-start! t)
- (mutex-unlock! m)
- (thread-join! t)))
-
- (pass-if "can lock mutex for non-current thread"
- (let* ((m1 (make-mutex 'mutex-lock-4a))
- (m2 (make-mutex 'mutex-lock-4b))
- (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
- (mutex-lock! m1)
- (thread-start! t)
- (mutex-lock! m2 #f t)
- (let ((success (eq? (mutex-state m2) t)))
- (thread-terminate! t) success)))
-
- (pass-if "locking abandoned mutex throws exception"
- (let* ((m (make-mutex 'mutex-lock-5))
- (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
- (success #f))
- (thread-start! t)
- (thread-join! t)
- (with-exception-handler
- (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
- (lambda () (mutex-lock! m)))
- (and success (eq? (mutex-state m) (current-thread)))))
-
- (pass-if "sleeping threads notified of abandonment"
- (let* ((m1 (make-mutex 'mutex-lock-6a))
- (m2 (make-mutex 'mutex-lock-6b))
- (c (make-condition-variable 'mutex-lock-6))
- (t (make-thread (lambda ()
- (mutex-lock! m1)
- (mutex-lock! m2)
- (condition-variable-signal! c))))
- (success #f))
- (mutex-lock! m1)
- (thread-start! t)
- (with-exception-handler
- (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
- (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
- success)))
-
-(with-test-prefix "mutex-unlock!"
+ (pass-if "mutex-lock! returns true on successful lock"
+ (let* ((m (make-mutex 'mutex-lock-1)))
+ (mutex-lock! m)))
+
+ (pass-if "mutex-lock! returns false on timeout"
+ (let* ((m (make-mutex 'mutex-lock-2))
+ (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (not (thread-join! t))))
+
+ (pass-if "mutex-lock! returns true when lock obtained within timeout"
+ (let* ((m (make-mutex 'mutex-lock-3))
+ (t (make-thread (lambda ()
+ (mutex-lock! m (+ (time->seconds
(current-time))
+ 100)
+ #f)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m)
+ (thread-join! t)))
+
+ (pass-if "can lock mutex for non-current thread"
+ (let* ((m1 (make-mutex 'mutex-lock-4a))
+ (m2 (make-mutex 'mutex-lock-4b))
+ (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
+ (mutex-lock! m1)
+ (thread-start! t)
+ (mutex-lock! m2 #f t)
+ (let ((success (eq? (mutex-state m2) t)))
+ (thread-terminate! t) success)))
+
+ (pass-if "locking abandoned mutex throws exception"
+ (let* ((m (make-mutex 'mutex-lock-5))
+ (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
+ (success #f))
+ (thread-start! t)
+ (thread-join! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+ (lambda () (mutex-lock! m)))
+ (and success (eq? (mutex-state m) (current-thread)))))
+
+ (pass-if "sleeping threads notified of abandonment"
+ (let* ((m1 (make-mutex 'mutex-lock-6a))
+ (m2 (make-mutex 'mutex-lock-6b))
+ (c (make-condition-variable 'mutex-lock-6))
+ (t (make-thread (lambda ()
+ (mutex-lock! m1)
+ (mutex-lock! m2)
+ (condition-variable-signal! c))))
+ (success #f))
+ (mutex-lock! m1)
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
+ (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
+ success)))
+
+ (with-test-prefix "mutex-unlock!"
- (pass-if "unlock changes mutex state"
- (let* ((m (make-mutex 'mutex-unlock-1)))
- (mutex-lock! m)
- (mutex-unlock! m)
- (eq? (mutex-state m) 'not-abandoned)))
-
- (pass-if "can unlock from any thread"
- (let* ((m (make-mutex 'mutex-unlock-2))
- (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
- (mutex-lock! m)
- (thread-start! t)
- (thread-join! t)
- (eq? (mutex-state m) 'not-abandoned)))
-
- (pass-if "mutex unlock is true when condition is signalled"
- (let* ((m (make-mutex 'mutex-unlock-3))
- (c (make-condition-variable 'mutex-unlock-3))
- (t (make-thread (lambda ()
- (mutex-lock! m)
- (condition-variable-signal! c)
- (mutex-unlock! m)))))
- (mutex-lock! m)
- (thread-start! t)
- (mutex-unlock! m c)))
-
- (pass-if "mutex unlock is false when condition times out"
- (let* ((m (make-mutex 'mutex-unlock-4))
- (c (make-condition-variable 'mutex-unlock-4)))
- (mutex-lock! m)
- (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
-
-(with-test-prefix "condition-variable?"
-
- (pass-if "make-condition-variable creates condition variable"
- (condition-variable? (make-condition-variable)))
-
- (pass-if "symbol not condition variable"
- (not (condition-variable? 'foo))))
-
-(with-test-prefix "condition-variable-name"
-
- (pass-if "make-condition-variable with name binds name"
- (let* ((c (make-condition-variable 'condition-variable-name-1)))
- (eq? (condition-variable-name c) 'condition-variable-name-1)))
-
- (pass-if "make-condition-variable without name does not bind name"
- (let* ((c (make-condition-variable)))
- (not (condition-variable-name c)))))
-
-(with-test-prefix "condition-variable-specific"
-
- (pass-if "condition-variable-specific is initially #f"
- (let ((c (make-condition-variable 'condition-variable-specific-1)))
- (not (condition-variable-specific c))))
-
- (pass-if "condition-variable-specific-set! can set value"
- (let ((c (make-condition-variable 'condition-variable-specific-1)))
- (condition-variable-specific-set! c "hello")
- (equal? (condition-variable-specific c) "hello"))))
-
-(with-test-prefix "condition-variable-signal!"
+ (pass-if "unlock changes mutex state"
+ (let* ((m (make-mutex 'mutex-unlock-1)))
+ (mutex-lock! m)
+ (mutex-unlock! m)
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "can unlock from any thread"
+ (let* ((m (make-mutex 'mutex-unlock-2))
+ (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (thread-join! t)
+ (eq? (mutex-state m) 'not-abandoned)))
+
+ (pass-if "mutex unlock is true when condition is signalled"
+ (let* ((m (make-mutex 'mutex-unlock-3))
+ (c (make-condition-variable 'mutex-unlock-3))
+ (t (make-thread (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m c)))
+
+ (pass-if "mutex unlock is false when condition times out"
+ (let* ((m (make-mutex 'mutex-unlock-4))
+ (c (make-condition-variable 'mutex-unlock-4)))
+ (mutex-lock! m)
+ (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
+
+ (with-test-prefix "condition-variable?"
+
+ (pass-if "make-condition-variable creates condition variable"
+ (condition-variable? (make-condition-variable)))
+
+ (pass-if "symbol not condition variable"
+ (not (condition-variable? 'foo))))
+
+ (with-test-prefix "condition-variable-name"
+
+ (pass-if "make-condition-variable with name binds name"
+ (let* ((c (make-condition-variable 'condition-variable-name-1)))
+ (eq? (condition-variable-name c) 'condition-variable-name-1)))
+
+ (pass-if "make-condition-variable without name does not bind name"
+ (let* ((c (make-condition-variable)))
+ (not (condition-variable-name c)))))
+
+ (with-test-prefix "condition-variable-specific"
+
+ (pass-if "condition-variable-specific is initially #f"
+ (let ((c (make-condition-variable 'condition-variable-specific-1)))
+ (not (condition-variable-specific c))))
+
+ (pass-if "condition-variable-specific-set! can set value"
+ (let ((c (make-condition-variable 'condition-variable-specific-1)))
+ (condition-variable-specific-set! c "hello")
+ (equal? (condition-variable-specific c) "hello"))))
+
+ (with-test-prefix "condition-variable-signal!"
- (pass-if "condition-variable-signal! wakes up single thread"
- (let* ((m (make-mutex 'condition-variable-signal-1))
- (c (make-condition-variable 'condition-variable-signal-1))
- (t (make-thread (lambda ()
- (mutex-lock! m)
- (condition-variable-signal! c)
- (mutex-unlock! m)))))
- (mutex-lock! m)
- (thread-start! t)
- (mutex-unlock! m c))))
-
-(with-test-prefix "condition-variable-broadcast!"
-
- (pass-if "condition-variable-broadcast! wakes up multiple threads"
- (let* ((sem 0)
- (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
- (m1 (make-mutex 'condition-variable-broadcast-1-a))
- (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
- (m2 (make-mutex 'condition-variable-broadcast-1-b))
- (inc-sem! (lambda ()
- (mutex-lock! m1)
- (set! sem (+ sem 1))
- (condition-variable-broadcast! c1)
- (mutex-unlock! m1)))
- (dec-sem! (lambda ()
- (mutex-lock! m1)
- (while (eqv? sem 0) (wait-condition-variable c1 m1))
- (set! sem (- sem 1))
- (mutex-unlock! m1)))
- (t1 (make-thread (lambda ()
- (mutex-lock! m2)
- (inc-sem!)
- (mutex-unlock! m2 c2)
- (inc-sem!))))
- (t2 (make-thread (lambda ()
- (mutex-lock! m2)
- (inc-sem!)
- (mutex-unlock! m2 c2)
- (inc-sem!)))))
- (thread-start! t1)
- (thread-start! t2)
- (dec-sem!)
- (dec-sem!)
- (mutex-lock! m2)
- (condition-variable-broadcast! c2)
- (mutex-unlock! m2)
- (dec-sem!)
- (dec-sem!))))
-
-(with-test-prefix "time?"
-
- (pass-if "current-time is time" (time? (current-time)))
- (pass-if "number is not time" (not (time? 123)))
- (pass-if "symbol not time" (not (time? 'foo))))
-
-(with-test-prefix "time->seconds"
-
- (pass-if "time->seconds makes time into rational"
- (rational? (time->seconds (current-time))))
-
- (pass-if "time->seconds is reversible"
- (let ((t (current-time)))
- (equal? t (seconds->time (time->seconds t))))))
-
-(with-test-prefix "seconds->time"
-
- (pass-if "seconds->time makes rational into time"
- (time? (seconds->time 123.456)))
-
- (pass-if "seconds->time is reversible"
- (let ((t (time->seconds (current-time))))
- (equal? t (time->seconds (seconds->time t))))))
-
-(with-test-prefix "current-exception-handler"
-
- (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 "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 "exception handler installation is thread-safe"
- (let* ((h1 (current-exception-handler))
- (h2 (lambda (key . args) 'nothing-2))
- (m (make-mutex 'current-exception-handler-4))
- (c (make-condition-variable 'current-exception-handler-4))
- (t (make-thread (lambda ()
- (with-exception-handler
- h2 (lambda ()
- (mutex-lock! m)
- (condition-variable-signal! c)
- (wait-condition-variable c m)
- (and (eq? (current-exception-handler) h2)
- (mutex-unlock! m)))))
- 'current-exception-handler-4)))
- (mutex-lock! m)
- (thread-start! t)
- (wait-condition-variable c m)
- (and (eq? (current-exception-handler) h1)
- (condition-variable-signal! c)
- (mutex-unlock! m)
- (thread-join! t)))))
-
-(with-test-prefix "uncaught-exception-reason"
-
- (pass-if "initial handler captures top level exception"
- (let ((t (make-thread (lambda () (raise 'foo))))
- (success #f))
- (thread-start! t)
- (with-exception-handler
- (lambda (obj)
- (and (uncaught-exception? obj)
- (eq? (uncaught-exception-reason obj) 'foo)
- (set! success #t)))
- (lambda () (thread-join! t)))
- success))
-
- (pass-if "initial handler captures non-SRFI-18 throw"
- (let ((t (make-thread (lambda () (throw 'foo))))
- (success #f))
- (thread-start! t)
- (with-exception-handler
- (lambda (obj)
- (and (uncaught-exception? obj)
- (eq? (uncaught-exception-reason obj) 'foo)
- (set! success #t)))
- (lambda () (thread-join! t)))
- success)))
-
-)
+ (pass-if "condition-variable-signal! wakes up single thread"
+ (let* ((m (make-mutex 'condition-variable-signal-1))
+ (c (make-condition-variable 'condition-variable-signal-1))
+ (t (make-thread (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)))))
+ (mutex-lock! m)
+ (thread-start! t)
+ (mutex-unlock! m c))))
+
+ (with-test-prefix "condition-variable-broadcast!"
+
+ (pass-if "condition-variable-broadcast! wakes up multiple threads"
+ (let* ((sem 0)
+ (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
+ (m1 (make-mutex 'condition-variable-broadcast-1-a))
+ (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
+ (m2 (make-mutex 'condition-variable-broadcast-1-b))
+ (inc-sem! (lambda ()
+ (mutex-lock! m1)
+ (set! sem (+ sem 1))
+ (condition-variable-broadcast! c1)
+ (mutex-unlock! m1)))
+ (dec-sem! (lambda ()
+ (mutex-lock! m1)
+ (while (eqv? sem 0) (wait-condition-variable c1 m1))
+ (set! sem (- sem 1))
+ (mutex-unlock! m1)))
+ (t1 (make-thread (lambda ()
+ (mutex-lock! m2)
+ (inc-sem!)
+ (mutex-unlock! m2 c2)
+ (inc-sem!))))
+ (t2 (make-thread (lambda ()
+ (mutex-lock! m2)
+ (inc-sem!)
+ (mutex-unlock! m2 c2)
+ (inc-sem!)))))
+ (thread-start! t1)
+ (thread-start! t2)
+ (dec-sem!)
+ (dec-sem!)
+ (mutex-lock! m2)
+ (condition-variable-broadcast! c2)
+ (mutex-unlock! m2)
+ (dec-sem!)
+ (dec-sem!))))
+
+ (with-test-prefix "time?"
+
+ (pass-if "current-time is time" (time? (current-time)))
+ (pass-if "number is not time" (not (time? 123)))
+ (pass-if "symbol not time" (not (time? 'foo))))
+
+ (with-test-prefix "time->seconds"
+
+ (pass-if "time->seconds makes time into rational"
+ (rational? (time->seconds (current-time))))
+
+ (pass-if "time->seconds is reversible"
+ (let ((t (current-time)))
+ (equal? t (seconds->time (time->seconds t))))))
+
+ (with-test-prefix "seconds->time"
+
+ (pass-if "seconds->time makes rational into time"
+ (time? (seconds->time 123.456)))
+
+ (pass-if "seconds->time is reversible"
+ (let ((t (time->seconds (current-time))))
+ (equal? t (time->seconds (seconds->time t))))))
+
+ (with-test-prefix "current-exception-handler"
+
+ (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 "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 "exception handler installation is thread-safe"
+ (let* ((h1 (current-exception-handler))
+ (h2 (lambda (key . args) 'nothing-2))
+ (m (make-mutex 'current-exception-handler-4))
+ (c (make-condition-variable 'current-exception-handler-4))
+ (t (make-thread (lambda ()
+ (with-exception-handler
+ h2 (lambda ()
+ (mutex-lock! m)
+ (condition-variable-signal! c)
+ (wait-condition-variable c m)
+ (and (eq? (current-exception-handler) h2)
+ (mutex-unlock! m)))))
+ 'current-exception-handler-4)))
+ (mutex-lock! m)
+ (thread-start! t)
+ (wait-condition-variable c m)
+ (and (eq? (current-exception-handler) h1)
+ (condition-variable-signal! c)
+ (mutex-unlock! m)
+ (thread-join! t)))))
+
+ (with-test-prefix "uncaught-exception-reason"
+
+ (pass-if "initial handler captures top level exception"
+ (let ((t (make-thread (lambda () (raise 'foo))))
+ (success #f))
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj)
+ (and (uncaught-exception? obj)
+ (eq? (uncaught-exception-reason obj) 'foo)
+ (set! success #t)))
+ (lambda () (thread-join! t)))
+ success))
+
+ (pass-if "initial handler captures non-SRFI-18 throw"
+ (let ((t (make-thread (lambda () (throw 'foo))))
+ (success #f))
+ (thread-start! t)
+ (with-exception-handler
+ (lambda (obj)
+ (and (uncaught-exception? obj)
+ (eq? (uncaught-exception-reason obj) 'foo)
+ (set! success #t)))
+ (lambda () (thread-join! t)))
+ success)))))
\ No newline at end of file
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index 2e7f0d5..033e39f 100644
--- a/test-suite/tests/srfi-4.test
+++ b/test-suite/tests/srfi-4.test
@@ -515,3 +515,28 @@
(pass-if-exception "generalized-vector-set!, out-of-range"
exception:out-of-range
(generalized-vector-set! (c64vector 1.0) 1 2.0)))
+
+(with-test-prefix "accessing uniform vectors of different types"
+
+ (pass-if "u32vector-length of u16vector"
+ (= 2 (u32vector-length (make-u16vector 4))))
+
+ (pass-if "u32vector-length of u8vector"
+ (= 2 (u32vector-length (make-u8vector 8))))
+
+ (pass-if "u8vector-length of u16vector"
+ (= 4 (u8vector-length (make-u16vector 2))))
+
+ (pass-if "u8vector-length of u32vector"
+ (= 8 (u8vector-length (make-u32vector 2))))
+
+ (pass-if "u32vector-set! of u16vector"
+ (let ((v (make-u16vector 4 #xFFFF)))
+ (u32vector-set! v 1 0)
+ (equal? v #u16(#xFFFF #xFFFF 0 0))))
+
+ (pass-if "u16vector-set! of u32vector"
+ (let ((v (make-u32vector 2 #xFFFFFFFF)))
+ (u16vector-set! v 2 0)
+ (u16vector-set! v 3 0)
+ (equal? v #u32(#xFFFFFFFF 0)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 834ce5f..630e113 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1549,6 +1549,31 @@
(lambda args args)))
(const 1))
+ ;; Handler lambda inlined
+ (pass-if-peval
+ (call-with-prompt tag
+ (lambda () 1)
+ (lambda (k x) x))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _)))))
+
+ ;; Handler toplevel not inlined
+ (pass-if-peval
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (let (handler) (_) ((toplevel handler))
+ (prompt (toplevel tag)
+ (const 1)
+ (lambda-case
+ ((() #f args #f () (_))
+ (primcall @apply
+ (lexical handler _)
+ (lexical args _)))))))
+
(pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
@@ -1564,7 +1589,16 @@
((() #f #f #f () ())
(call (lexical loop _))))))
(call (lexical loop _)))))))
- (call (lexical lp _)))))
+ (call (lexical lp _))))
+
+ (pass-if-peval
+ (lambda (a . rest)
+ (apply (lambda (x y) (+ x y))
+ a rest))
+ (lambda _
+ (lambda-case
+ (((x y) #f #f #f () (_ _))
+ _)))))
@@ -2200,6 +2234,19 @@
#:opts %opts-w-format
#:to 'assembly)))))
+ (pass-if "non-literal format string with forward declaration"
+ (let ((w (call-with-warnings
+ (lambda ()
+ (compile '(begin
+ (define (foo)
+ (format #t (_ "~A ~A!") "hello" "world"))
+ (define _ bar))
+ #:opts %opts-w-format
+ #:to 'assembly)))))
+ (and (= (length w) 1)
+ (number? (string-contains (car w)
+ "non-literal format string")))))
+
(pass-if "wrong format string"
(let ((w (call-with-warnings
(lambda ()
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-77-gd489998,
Andy Wingo <=