summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-03-02 17:20:47 +0100
committerAndy Wingo <wingo@pobox.com>2012-03-02 17:20:47 +0100
commitd489998364e5f20e81cf7cf12998e694626d2f6f (patch)
treef097df9ac80e73111bd8d34686643b06e33c8924
parent79eb47ea47650ef42c545931726277a7118a0210 (diff)
parenteebcacf41c4fe58ad8c9388d516a99f59212b223 (diff)
downloadguile-d489998364e5f20e81cf7cf12998e694626d2f6f.tar.gz
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
-rw-r--r--module/language/tree-il/analyze.scm3
-rw-r--r--module/language/tree-il/canonicalize.scm10
-rw-r--r--module/language/tree-il/peval.scm35
-rw-r--r--module/language/tree-il/primitives.scm31
-rw-r--r--module/srfi/srfi-4.scm6
-rw-r--r--module/srfi/srfi-4/gnu.scm5
-rw-r--r--module/system/base/pmatch.scm16
-rw-r--r--test-suite/lib.scm55
-rw-r--r--test-suite/tests/srfi-18.test863
-rw-r--r--test-suite/tests/srfi-4.test25
-rw-r--r--test-suite/tests/tree-il.test49
11 files changed, 592 insertions, 506 deletions
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 11c19d8ec..5c1cb55b7 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 27d72956f..2536a7155 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 a588b68b7..6b375919e 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 157aaa18d..3d98c686b 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 818ae7a73..43f5ef68f 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 ac22809ea..39d6350e7 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 00563f689..e9b9eb205 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 681a0d158..5785378ad 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 b769ce1a2..47f8f7f40 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 2e7f0d5f5..033e39f47 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 834ce5f47..630e113f0 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 ()