diff options
author | Andy Wingo <wingo@pobox.com> | 2012-03-02 17:20:47 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-03-02 17:20:47 +0100 |
commit | d489998364e5f20e81cf7cf12998e694626d2f6f (patch) | |
tree | f097df9ac80e73111bd8d34686643b06e33c8924 | |
parent | 79eb47ea47650ef42c545931726277a7118a0210 (diff) | |
parent | eebcacf41c4fe58ad8c9388d516a99f59212b223 (diff) | |
download | guile-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.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/canonicalize.scm | 10 | ||||
-rw-r--r-- | module/language/tree-il/peval.scm | 35 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 31 | ||||
-rw-r--r-- | module/srfi/srfi-4.scm | 6 | ||||
-rw-r--r-- | module/srfi/srfi-4/gnu.scm | 5 | ||||
-rw-r--r-- | module/system/base/pmatch.scm | 16 | ||||
-rw-r--r-- | test-suite/lib.scm | 55 | ||||
-rw-r--r-- | test-suite/tests/srfi-18.test | 863 | ||||
-rw-r--r-- | test-suite/tests/srfi-4.test | 25 | ||||
-rw-r--r-- | 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 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 () |