mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
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
This commit is contained in:
Andy Wingo 2012-03-02 17:20:47 +01:00
commit d489998364
11 changed files with 535 additions and 449 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/language/tree-il/analyze.scm
View file

@ -1360,7 +1360,8 @@ resort, return #t when EXP refers to the global variable SPECIAL-NAME."
(($ <toplevel-ref> _ name) (($ <toplevel-ref> _ name)
(let ((var (false-if-exception (module-variable env name)))) (let ((var (false-if-exception (module-variable env name))))
(if var (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 (eq? name special-name)))) ; special hack to support local aliases
(($ <module-ref> _ module name public?) (($ <module-ref> _ module name public?)
(let ((m (false-if-exception (if public? (let ((m (false-if-exception (if public?

10
module/language/tree-il/canonicalize.scm
View file

@ -1,6 +1,6 @@
;;; Tree-il canonicalizer ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -48,10 +48,10 @@
(define (escape-only? handler) (define (escape-only? handler)
(match handler (match handler
(($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
(tree-il-any (lambda (x) (not (tree-il-any (lambda (x)
(and (lexical-ref? x) (and (lexical-ref? x)
(eq? (lexical-ref-gensym x) cont))) (eq? (lexical-ref-gensym x) cont)))
body)) body)))
(else #f))) (else #f)))
(define (thunk-application? x) (define (thunk-application? x)
(match x (match x

35
module/language/tree-il/peval.scm
View file

@ -1221,21 +1221,36 @@ top-level bindings from ENV and return the resulting expression."
exp exp
(make-lambda src meta (for-values body)))))) (make-lambda src meta (for-values body))))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt) (($ <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)) (let* ((vars (map lookup-var gensyms))
(new (fresh-gensyms vars)) (new (fresh-gensyms vars))
(env (fold extend-env env gensyms (env (fold extend-env env gensyms
(make-unbound-operands vars new))) (make-unbound-operands vars new)))
(new-sym (lambda (old) (new-sym (lambda (old)
(operand-sym (cdr (vhash-assq old env)))))) (operand-sym (cdr (vhash-assq old env)))))
(make-lambda-case src req opt rest (body (loop body env counter ctx)))
(match kw (or
((aok? (kw name old) ...) ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(cons aok? (map list kw name (map new-sym old)))) (lift-applied-lambda body new)
(_ #f)) (make-lambda-case src req opt rest
(map (cut loop <> env counter 'value) inits) (match kw
new ((aok? (kw name old) ...)
(loop body env counter ctx) (cons aok? (map list kw name (map new-sym old))))
(and alt (for-tail alt))))) (_ #f))
(map (cut loop <> env counter 'value) inits)
new
body
(and alt (for-tail alt))))))
(($ <seq> src head tail) (($ <seq> src head tail)
(let ((head (for-effect head)) (let ((head (for-effect head))
(tail (for-tail tail))) (tail (for-tail tail)))

31
module/language/tree-il/primitives.scm
View file

@ -544,22 +544,21 @@
'call-with-prompt 'call-with-prompt
(case-lambda (case-lambda
((src tag thunk handler) ((src tag thunk handler)
;; Sigh. Until the inliner does its job, manually inline (let ((handler-sym (gensym))
;; (let ((h (lambda ...))) (prompt k x h)) (args-sym (gensym)))
(cond (make-let
((lambda? handler) src '(handler) (list handler-sym) (list handler)
(let ((args-sym (gensym))) (make-prompt
(make-prompt src tag (make-call #f thunk '())
src tag (make-call #f thunk '()) ;; If handler itself is a lambda, the inliner can do some
;; If handler itself is a lambda, the inliner can do some ;; trickery here.
;; trickery here. (make-lambda-case
(make-lambda-case (tree-il-src handler) '() #f 'args #f '() (list args-sym)
(tree-il-src handler) '() #f 'args #f '() (list args-sym) (make-primcall
(make-primcall #f 'apply #f 'apply
(list handler (list (make-lexical-ref #f 'handler handler-sym)
(make-lexical-ref #f 'args args-sym))) (make-lexical-ref #f 'args args-sym)))
#f)))) #f)))))
(else #f)))
(else #f))) (else #f)))
(hashq-set! *primitive-expand-table* (hashq-set! *primitive-expand-table*

6
module/srfi/srfi-4.scm
View file

@ -1,6 +1,7 @@
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -79,7 +80,8 @@
(apply make-srfi-4-vector ',tag len fill)) (apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v) (define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v) (let ((len (* (uniform-vector-length v)
(/ ,size (uniform-vector-element-size v))))) (uniform-vector-element-size v)
(/ ,size))))
(if (integer? len) (if (integer? len)
len len
(error "fractional length" v ',tag ,size)))) (error "fractional length" v ',tag ,size))))

5
module/srfi/srfi-4/gnu.scm
View file

@ -1,6 +1,6 @@
;;; Extensions to SRFI-4 ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -52,7 +52,8 @@
(apply make-srfi-4-vector ',tag len fill)) (apply make-srfi-4-vector ',tag len fill))
(define (,(symbol-append tag 'vector-length) v) (define (,(symbol-append tag 'vector-length) v)
(let ((len (* (uniform-vector-length v) (let ((len (* (uniform-vector-length v)
(/ ,size (uniform-vector-element-size v))))) (uniform-vector-element-size v)
(/ ,size))))
(if (integer? len) (if (integer? len)
len len
(error "fractional length" v ',tag ,size)))) (error "fractional length" v ',tag ,size))))

16
module/system/base/pmatch.scm
View file

@ -1,6 +1,6 @@
;;; pmatch, a simple matcher ;;; 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) 2005,2006,2007 Oleg Kiselyov
;;; Copyright (C) 2007 Daniel P. Friedman ;;; Copyright (C) 2007 Daniel P. Friedman
;;; ;;;
@ -35,22 +35,22 @@
;;; Code: ;;; Code:
(define-module (system base pmatch) (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) (syntax-rules (else guard)
((_ (op arg ...) cs ...)
(let ((v (op arg ...)))
(pmatch v cs ...)))
((_ v) (if #f #f)) ((_ v) (if #f #f))
((_ v (else e0 e ...)) (let () e0 e ...)) ((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...) ((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...)))) (let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat (ppat v pat
(if (and g ...) (let () e0 e ...) (fk)) (if (and g ...) (let () e0 e ...) (fk))
(fk)))) (fk))))
((_ v (pat e0 e ...) cs ...) ((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...)))) (let ((fk (lambda () (pmatch1 v cs ...))))
(ppat v pat (let () e0 e ...) (fk)))))) (ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat (define-syntax ppat

55
test-suite/lib.scm
View file

@ -314,34 +314,33 @@
;;; The central testing routine. ;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment. ;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test #f) (define run-test
(let ((test-running #f)) (let ((test-running #f))
(define (local-run-test name expect-pass thunk) (lambda (name expect-pass thunk)
(if test-running (if test-running
(error "Nested calls to run-test are not permitted.") (error "Nested calls to run-test are not permitted."))
(let ((test-name (full-name name))) (let ((test-name (full-name name)))
(set! test-running #t) (set! test-running #t)
(catch #t (catch #t
(lambda () (lambda ()
(let ((result (thunk))) (let ((result (thunk)))
(if (eq? result #t) (throw 'pass)) (if (eq? result #t) (throw 'pass))
(if (eq? result #f) (throw 'fail)) (if (eq? result #f) (throw 'fail))
(throw 'unresolved))) (throw 'unresolved)))
(lambda (key . args) (lambda (key . args)
(case key (case key
((pass) ((pass)
(report (if expect-pass 'pass 'upass) test-name)) (report (if expect-pass 'pass 'upass) test-name))
((fail) ((fail)
(report (if expect-pass 'fail 'xfail) test-name)) (report (if expect-pass 'fail 'xfail) test-name))
((unresolved untested unsupported) ((unresolved untested unsupported)
(report key test-name)) (report key test-name))
((quit) ((quit)
(report 'unresolved test-name) (report 'unresolved test-name)
(quit)) (quit))
(else (else
(report 'error test-name (cons key args)))))) (report 'error test-name (cons key args))))))
(set! test-running #f)))) (set! test-running #f)))))
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg. ;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if (define-syntax pass-if

749
test-suite/tests/srfi-18.test
View file

@ -1,7 +1,7 @@
;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*- ;;;; srfi-18.test --- Test suite for Guile's SRFI-18 functions. -*- scheme -*-
;;;; Julian Graham, 2007-10-26 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -25,461 +25,458 @@
(if (provided? 'threads) (if (provided? 'threads)
(use-modules (srfi srfi-18))) (use-modules (srfi srfi-18)))
(and (cond
(provided? 'threads) ((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" (with-test-prefix "thread?"
(eq? (current-thread) (current-thread))))
(with-test-prefix "thread?" (pass-if "current-thread is thread"
(thread? (current-thread)))
(pass-if "current-thread is thread" (pass-if "foo not thread"
(thread? (current-thread))) (not (thread? 'foo))))
(pass-if "foo not thread" (with-test-prefix "make-thread"
(not (thread? 'foo))))
(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" (with-test-prefix "thread-name"
(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" (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" (pass-if "make-thread without name does not bind name"
(let* ((t (make-thread (lambda () 'foo) 'thread-name-1)) (let* ((t (make-thread (lambda () 'foo)))
(r (eq? (thread-name t) 'thread-name-1))) (r (not (thread-name t))))
(thread-terminate! t) r)) (thread-terminate! t) r)))
(pass-if "make-thread without name does not bind name" (with-test-prefix "thread-specific"
(let* ((t (make-thread (lambda () 'foo)))
(r (not (thread-name t))))
(thread-terminate! t) r)))
(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" (pass-if "thread-specific-set! can set value"
(let* ((t (make-thread (lambda () 'foo) 'thread-specific-1)) (let ((t (make-thread (lambda () 'foo) 'thread-specific-2)))
(r (not (thread-specific t)))) (thread-specific-set! t "hello")
(thread-terminate! t) r)) (let ((r (equal? (thread-specific t) "hello")))
(thread-terminate! t) r))))
(pass-if "thread-specific-set! can set value" (with-test-prefix "thread-start!"
(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!" (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" (with-test-prefix "thread-yield!"
(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!" (pass-if "thread yield suceeds"
(thread-yield!) #t))
(pass-if "thread yield suceeds" (with-test-prefix "thread-sleep!"
(thread-yield!) #t))
(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" (pass-if "thread sleep with number"
(let ((future-time (seconds->time (+ (time->seconds (current-time)) 2)))) (let ((old-secs (car (current-time))))
(unspecified? (thread-sleep! future-time)))) (unspecified? (thread-sleep! (+ (time->seconds (current-time)))))))
(pass-if "thread sleep with number" (pass-if "thread does not sleep on past time"
(let ((old-secs (car (current-time)))) (let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
(unspecified? (thread-sleep! (+ (time->seconds (current-time))))))) (unspecified? (thread-sleep! past-time)))))
(pass-if "thread does not sleep on past time" (with-test-prefix "thread-terminate!"
(let ((past-time (seconds->time (- (time->seconds (current-time)) 2))))
(unspecified? (thread-sleep! past-time)))))
(with-test-prefix "thread-terminate!"
(pass-if "termination destroys non-started thread" (pass-if "termination destroys non-started thread"
(let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1)) (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1))
(num-threads (length (all-threads))) (num-threads (length (all-threads)))
(success #f)) (success #f))
(thread-terminate! t) (thread-terminate! t)
(with-exception-handler (with-exception-handler
(lambda (obj) (set! success (terminated-thread-exception? obj))) (lambda (obj) (set! success (terminated-thread-exception? obj)))
(lambda () (thread-join! t))) (lambda () (thread-join! t)))
success)) success))
(pass-if "termination destroys started thread" (pass-if "termination destroys started thread"
(let* ((m1 (make-mutex 'thread-terminate-2a)) (let* ((m1 (make-mutex 'thread-terminate-2a))
(m2 (make-mutex 'thread-terminate-2b)) (m2 (make-mutex 'thread-terminate-2b))
(c (make-condition-variable 'thread-terminate-2)) (c (make-condition-variable 'thread-terminate-2))
(t (make-thread (lambda () (t (make-thread (lambda ()
(mutex-lock! m1) (mutex-lock! m1)
(condition-variable-signal! c) (condition-variable-signal! c)
(mutex-unlock! m1) (mutex-unlock! m1)
(mutex-lock! m2)) (mutex-lock! m2))
'thread-terminate-2)) 'thread-terminate-2))
(success #f)) (success #f))
(mutex-lock! m1) (mutex-lock! m1)
(mutex-lock! m2) (mutex-lock! m2)
(thread-start! t) (thread-start! t)
(mutex-unlock! m1 c) (mutex-unlock! m1 c)
(thread-terminate! t) (thread-terminate! t)
(with-exception-handler (with-exception-handler
(lambda (obj) (set! success (terminated-thread-exception? obj))) (lambda (obj) (set! success (terminated-thread-exception? obj)))
(lambda () (thread-join! t))) (lambda () (thread-join! t)))
success))) success)))
(with-test-prefix "thread-join!" (with-test-prefix "thread-join!"
(pass-if "join receives result of thread" (pass-if "join receives result of thread"
(let ((t (make-thread (lambda () 'foo) 'thread-join-1))) (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
(thread-start! t) (thread-start! t)
(eq? (thread-join! t) 'foo))) (eq? (thread-join! t) 'foo)))
(pass-if "join receives timeout val if timeout expires" (pass-if "join receives timeout val if timeout expires"
(let* ((m (make-mutex 'thread-join-2)) (let* ((m (make-mutex 'thread-join-2))
(t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2))) (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-2)))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(let ((r (thread-join! t (current-time) 'bar))) (let ((r (thread-join! t (current-time) 'bar)))
(thread-terminate! t) (thread-terminate! t)
(eq? r 'bar)))) (eq? r 'bar))))
(pass-if "join throws exception on timeout without timeout val" (pass-if "join throws exception on timeout without timeout val"
(let* ((m (make-mutex 'thread-join-3)) (let* ((m (make-mutex 'thread-join-3))
(t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3)) (t (make-thread (lambda () (mutex-lock! m)) 'thread-join-3))
(success #f)) (success #f))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(with-exception-handler (with-exception-handler
(lambda (obj) (set! success (join-timeout-exception? obj))) (lambda (obj) (set! success (join-timeout-exception? obj)))
(lambda () (thread-join! t (current-time)))) (lambda () (thread-join! t (current-time))))
(thread-terminate! t) (thread-terminate! t)
success)) success))
(pass-if "join waits on timeout" (pass-if "join waits on timeout"
(let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4))) (let ((t (make-thread (lambda () (sleep 1) 'foo) 'thread-join-4)))
(thread-start! t) (thread-start! t)
(eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo)))) (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
(with-test-prefix "mutex?" (with-test-prefix "mutex?"
(pass-if "make-mutex creates mutex" (pass-if "make-mutex creates mutex"
(mutex? (make-mutex))) (mutex? (make-mutex)))
(pass-if "symbol not mutex" (pass-if "symbol not mutex"
(not (mutex? 'foo)))) (not (mutex? 'foo))))
(with-test-prefix "mutex-name" (with-test-prefix "mutex-name"
(pass-if "make-mutex with name binds name" (pass-if "make-mutex with name binds name"
(let* ((m (make-mutex 'mutex-name-1))) (let* ((m (make-mutex 'mutex-name-1)))
(eq? (mutex-name m) 'mutex-name-1))) (eq? (mutex-name m) 'mutex-name-1)))
(pass-if "make-mutex without name does not bind name" (pass-if "make-mutex without name does not bind name"
(let* ((m (make-mutex))) (let* ((m (make-mutex)))
(not (mutex-name m))))) (not (mutex-name m)))))
(with-test-prefix "mutex-specific" (with-test-prefix "mutex-specific"
(pass-if "mutex-specific is initially #f" (pass-if "mutex-specific is initially #f"
(let ((m (make-mutex 'mutex-specific-1))) (let ((m (make-mutex 'mutex-specific-1)))
(not (mutex-specific m)))) (not (mutex-specific m))))
(pass-if "mutex-specific-set! can set value" (pass-if "mutex-specific-set! can set value"
(let ((m (make-mutex 'mutex-specific-2))) (let ((m (make-mutex 'mutex-specific-2)))
(mutex-specific-set! m "hello") (mutex-specific-set! m "hello")
(equal? (mutex-specific m) "hello")))) (equal? (mutex-specific m) "hello"))))
(with-test-prefix "mutex-state" (with-test-prefix "mutex-state"
(pass-if "mutex state is initially not-abandoned" (pass-if "mutex state is initially not-abandoned"
(let ((m (make-mutex 'mutex-state-1))) (let ((m (make-mutex 'mutex-state-1)))
(eq? (mutex-state m) 'not-abandoned))) (eq? (mutex-state m) 'not-abandoned)))
(pass-if "mutex state of locked, owned mutex is owner thread" (pass-if "mutex state of locked, owned mutex is owner thread"
(let ((m (make-mutex 'mutex-state-2))) (let ((m (make-mutex 'mutex-state-2)))
(mutex-lock! m) (mutex-lock! m)
(eq? (mutex-state m) (current-thread)))) (eq? (mutex-state m) (current-thread))))
(pass-if "mutex state of locked, unowned mutex is not-owned" (pass-if "mutex state of locked, unowned mutex is not-owned"
(let ((m (make-mutex 'mutex-state-3))) (let ((m (make-mutex 'mutex-state-3)))
(mutex-lock! m #f #f) (mutex-lock! m #f #f)
(eq? (mutex-state m) 'not-owned))) (eq? (mutex-state m) 'not-owned)))
(pass-if "mutex state of unlocked, abandoned mutex is abandoned" (pass-if "mutex state of unlocked, abandoned mutex is abandoned"
(let* ((m (make-mutex 'mutex-state-4)) (let* ((m (make-mutex 'mutex-state-4))
(t (make-thread (lambda () (mutex-lock! m))))) (t (make-thread (lambda () (mutex-lock! m)))))
(thread-start! t) (thread-start! t)
(thread-join! t) (thread-join! t)
(eq? (mutex-state m) 'abandoned)))) (eq? (mutex-state m) 'abandoned))))
(with-test-prefix "mutex-lock!" (with-test-prefix "mutex-lock!"
(pass-if "mutex-lock! returns true on successful lock" (pass-if "mutex-lock! returns true on successful lock"
(let* ((m (make-mutex 'mutex-lock-1))) (let* ((m (make-mutex 'mutex-lock-1)))
(mutex-lock! m))) (mutex-lock! m)))
(pass-if "mutex-lock! returns false on timeout" (pass-if "mutex-lock! returns false on timeout"
(let* ((m (make-mutex 'mutex-lock-2)) (let* ((m (make-mutex 'mutex-lock-2))
(t (make-thread (lambda () (mutex-lock! m (current-time) #f))))) (t (make-thread (lambda () (mutex-lock! m (current-time) #f)))))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(not (thread-join! t)))) (not (thread-join! t))))
(pass-if "mutex-lock! returns true when lock obtained within timeout" (pass-if "mutex-lock! returns true when lock obtained within timeout"
(let* ((m (make-mutex 'mutex-lock-3)) (let* ((m (make-mutex 'mutex-lock-3))
(t (make-thread (lambda () (t (make-thread (lambda ()
(mutex-lock! m (+ (time->seconds (current-time)) (mutex-lock! m (+ (time->seconds (current-time))
100) 100)
#f))))) #f)))))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(mutex-unlock! m) (mutex-unlock! m)
(thread-join! t))) (thread-join! t)))
(pass-if "can lock mutex for non-current thread" (pass-if "can lock mutex for non-current thread"
(let* ((m1 (make-mutex 'mutex-lock-4a)) (let* ((m1 (make-mutex 'mutex-lock-4a))
(m2 (make-mutex 'mutex-lock-4b)) (m2 (make-mutex 'mutex-lock-4b))
(t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4))) (t (make-thread (lambda () (mutex-lock! m1)) 'mutex-lock-4)))
(mutex-lock! m1) (mutex-lock! m1)
(thread-start! t) (thread-start! t)
(mutex-lock! m2 #f t) (mutex-lock! m2 #f t)
(let ((success (eq? (mutex-state m2) t))) (let ((success (eq? (mutex-state m2) t)))
(thread-terminate! t) success))) (thread-terminate! t) success)))
(pass-if "locking abandoned mutex throws exception" (pass-if "locking abandoned mutex throws exception"
(let* ((m (make-mutex 'mutex-lock-5)) (let* ((m (make-mutex 'mutex-lock-5))
(t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5)) (t (make-thread (lambda () (mutex-lock! m)) 'mutex-lock-5))
(success #f)) (success #f))
(thread-start! t) (thread-start! t)
(thread-join! t) (thread-join! t)
(with-exception-handler (with-exception-handler
(lambda (obj) (set! success (abandoned-mutex-exception? obj))) (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
(lambda () (mutex-lock! m))) (lambda () (mutex-lock! m)))
(and success (eq? (mutex-state m) (current-thread))))) (and success (eq? (mutex-state m) (current-thread)))))
(pass-if "sleeping threads notified of abandonment" (pass-if "sleeping threads notified of abandonment"
(let* ((m1 (make-mutex 'mutex-lock-6a)) (let* ((m1 (make-mutex 'mutex-lock-6a))
(m2 (make-mutex 'mutex-lock-6b)) (m2 (make-mutex 'mutex-lock-6b))
(c (make-condition-variable 'mutex-lock-6)) (c (make-condition-variable 'mutex-lock-6))
(t (make-thread (lambda () (t (make-thread (lambda ()
(mutex-lock! m1) (mutex-lock! m1)
(mutex-lock! m2) (mutex-lock! m2)
(condition-variable-signal! c)))) (condition-variable-signal! c))))
(success #f)) (success #f))
(mutex-lock! m1) (mutex-lock! m1)
(thread-start! t) (thread-start! t)
(with-exception-handler (with-exception-handler
(lambda (obj) (set! success (abandoned-mutex-exception? obj))) (lambda (obj) (set! success (abandoned-mutex-exception? obj)))
(lambda () (mutex-unlock! m1 c) (mutex-lock! m2))) (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
success))) success)))
(with-test-prefix "mutex-unlock!" (with-test-prefix "mutex-unlock!"
(pass-if "unlock changes mutex state" (pass-if "unlock changes mutex state"
(let* ((m (make-mutex 'mutex-unlock-1))) (let* ((m (make-mutex 'mutex-unlock-1)))
(mutex-lock! m) (mutex-lock! m)
(mutex-unlock! m) (mutex-unlock! m)
(eq? (mutex-state m) 'not-abandoned))) (eq? (mutex-state m) 'not-abandoned)))
(pass-if "can unlock from any thread" (pass-if "can unlock from any thread"
(let* ((m (make-mutex 'mutex-unlock-2)) (let* ((m (make-mutex 'mutex-unlock-2))
(t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2))) (t (make-thread (lambda () (mutex-unlock! m)) 'mutex-unlock-2)))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(thread-join! t) (thread-join! t)
(eq? (mutex-state m) 'not-abandoned))) (eq? (mutex-state m) 'not-abandoned)))
(pass-if "mutex unlock is true when condition is signalled" (pass-if "mutex unlock is true when condition is signalled"
(let* ((m (make-mutex 'mutex-unlock-3)) (let* ((m (make-mutex 'mutex-unlock-3))
(c (make-condition-variable 'mutex-unlock-3)) (c (make-condition-variable 'mutex-unlock-3))
(t (make-thread (lambda () (t (make-thread (lambda ()
(mutex-lock! m) (mutex-lock! m)
(condition-variable-signal! c) (condition-variable-signal! c)
(mutex-unlock! m))))) (mutex-unlock! m)))))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(mutex-unlock! m c))) (mutex-unlock! m c)))
(pass-if "mutex unlock is false when condition times out" (pass-if "mutex unlock is false when condition times out"
(let* ((m (make-mutex 'mutex-unlock-4)) (let* ((m (make-mutex 'mutex-unlock-4))
(c (make-condition-variable 'mutex-unlock-4))) (c (make-condition-variable 'mutex-unlock-4)))
(mutex-lock! m) (mutex-lock! m)
(not (mutex-unlock! m c (+ (time->seconds (current-time)) 1)))))) (not (mutex-unlock! m c (+ (time->seconds (current-time)) 1))))))
(with-test-prefix "condition-variable?" (with-test-prefix "condition-variable?"
(pass-if "make-condition-variable creates condition variable" (pass-if "make-condition-variable creates condition variable"
(condition-variable? (make-condition-variable))) (condition-variable? (make-condition-variable)))
(pass-if "symbol not condition variable" (pass-if "symbol not condition variable"
(not (condition-variable? 'foo)))) (not (condition-variable? 'foo))))
(with-test-prefix "condition-variable-name" (with-test-prefix "condition-variable-name"
(pass-if "make-condition-variable with name binds name" (pass-if "make-condition-variable with name binds name"
(let* ((c (make-condition-variable 'condition-variable-name-1))) (let* ((c (make-condition-variable 'condition-variable-name-1)))
(eq? (condition-variable-name c) 'condition-variable-name-1))) (eq? (condition-variable-name c) 'condition-variable-name-1)))
(pass-if "make-condition-variable without name does not bind name" (pass-if "make-condition-variable without name does not bind name"
(let* ((c (make-condition-variable))) (let* ((c (make-condition-variable)))
(not (condition-variable-name c))))) (not (condition-variable-name c)))))
(with-test-prefix "condition-variable-specific" (with-test-prefix "condition-variable-specific"
(pass-if "condition-variable-specific is initially #f" (pass-if "condition-variable-specific is initially #f"
(let ((c (make-condition-variable 'condition-variable-specific-1))) (let ((c (make-condition-variable 'condition-variable-specific-1)))
(not (condition-variable-specific c)))) (not (condition-variable-specific c))))
(pass-if "condition-variable-specific-set! can set value" (pass-if "condition-variable-specific-set! can set value"
(let ((c (make-condition-variable 'condition-variable-specific-1))) (let ((c (make-condition-variable 'condition-variable-specific-1)))
(condition-variable-specific-set! c "hello") (condition-variable-specific-set! c "hello")
(equal? (condition-variable-specific c) "hello")))) (equal? (condition-variable-specific c) "hello"))))
(with-test-prefix "condition-variable-signal!" (with-test-prefix "condition-variable-signal!"
(pass-if "condition-variable-signal! wakes up single thread" (pass-if "condition-variable-signal! wakes up single thread"
(let* ((m (make-mutex 'condition-variable-signal-1)) (let* ((m (make-mutex 'condition-variable-signal-1))
(c (make-condition-variable 'condition-variable-signal-1)) (c (make-condition-variable 'condition-variable-signal-1))
(t (make-thread (lambda () (t (make-thread (lambda ()
(mutex-lock! m) (mutex-lock! m)
(condition-variable-signal! c) (condition-variable-signal! c)
(mutex-unlock! m))))) (mutex-unlock! m)))))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(mutex-unlock! m c)))) (mutex-unlock! m c))))
(with-test-prefix "condition-variable-broadcast!" (with-test-prefix "condition-variable-broadcast!"
(pass-if "condition-variable-broadcast! wakes up multiple threads" (pass-if "condition-variable-broadcast! wakes up multiple threads"
(let* ((sem 0) (let* ((sem 0)
(c1 (make-condition-variable 'condition-variable-broadcast-1-a)) (c1 (make-condition-variable 'condition-variable-broadcast-1-a))
(m1 (make-mutex 'condition-variable-broadcast-1-a)) (m1 (make-mutex 'condition-variable-broadcast-1-a))
(c2 (make-condition-variable 'condition-variable-broadcast-1-b)) (c2 (make-condition-variable 'condition-variable-broadcast-1-b))
(m2 (make-mutex 'condition-variable-broadcast-1-b)) (m2 (make-mutex 'condition-variable-broadcast-1-b))
(inc-sem! (lambda () (inc-sem! (lambda ()
(mutex-lock! m1) (mutex-lock! m1)
(set! sem (+ sem 1)) (set! sem (+ sem 1))
(condition-variable-broadcast! c1) (condition-variable-broadcast! c1)
(mutex-unlock! m1))) (mutex-unlock! m1)))
(dec-sem! (lambda () (dec-sem! (lambda ()
(mutex-lock! m1) (mutex-lock! m1)
(while (eqv? sem 0) (wait-condition-variable c1 m1)) (while (eqv? sem 0) (wait-condition-variable c1 m1))
(set! sem (- sem 1)) (set! sem (- sem 1))
(mutex-unlock! m1))) (mutex-unlock! m1)))
(t1 (make-thread (lambda () (t1 (make-thread (lambda ()
(mutex-lock! m2) (mutex-lock! m2)
(inc-sem!) (inc-sem!)
(mutex-unlock! m2 c2) (mutex-unlock! m2 c2)
(inc-sem!)))) (inc-sem!))))
(t2 (make-thread (lambda () (t2 (make-thread (lambda ()
(mutex-lock! m2) (mutex-lock! m2)
(inc-sem!) (inc-sem!)
(mutex-unlock! m2 c2) (mutex-unlock! m2 c2)
(inc-sem!))))) (inc-sem!)))))
(thread-start! t1) (thread-start! t1)
(thread-start! t2) (thread-start! t2)
(dec-sem!) (dec-sem!)
(dec-sem!) (dec-sem!)
(mutex-lock! m2) (mutex-lock! m2)
(condition-variable-broadcast! c2) (condition-variable-broadcast! c2)
(mutex-unlock! m2) (mutex-unlock! m2)
(dec-sem!) (dec-sem!)
(dec-sem!)))) (dec-sem!))))
(with-test-prefix "time?" (with-test-prefix "time?"
(pass-if "current-time is time" (time? (current-time))) (pass-if "current-time is time" (time? (current-time)))
(pass-if "number is not time" (not (time? 123))) (pass-if "number is not time" (not (time? 123)))
(pass-if "symbol not time" (not (time? 'foo)))) (pass-if "symbol not time" (not (time? 'foo))))
(with-test-prefix "time->seconds" (with-test-prefix "time->seconds"
(pass-if "time->seconds makes time into rational" (pass-if "time->seconds makes time into rational"
(rational? (time->seconds (current-time)))) (rational? (time->seconds (current-time))))
(pass-if "time->seconds is reversible" (pass-if "time->seconds is reversible"
(let ((t (current-time))) (let ((t (current-time)))
(equal? t (seconds->time (time->seconds t)))))) (equal? t (seconds->time (time->seconds t))))))
(with-test-prefix "seconds->time" (with-test-prefix "seconds->time"
(pass-if "seconds->time makes rational into time" (pass-if "seconds->time makes rational into time"
(time? (seconds->time 123.456))) (time? (seconds->time 123.456)))
(pass-if "seconds->time is reversible" (pass-if "seconds->time is reversible"
(let ((t (time->seconds (current-time)))) (let ((t (time->seconds (current-time))))
(equal? t (time->seconds (seconds->time t)))))) (equal? t (time->seconds (seconds->time t))))))
(with-test-prefix "current-exception-handler" (with-test-prefix "current-exception-handler"
(pass-if "current handler returned at top level" (pass-if "current handler returned at top level"
(procedure? (current-exception-handler))) (procedure? (current-exception-handler)))
(pass-if "specified handler set under with-exception-handler" (pass-if "specified handler set under with-exception-handler"
(let ((h (lambda (key . args) 'nothing))) (let ((h (lambda (key . args) 'nothing)))
(with-exception-handler h (lambda () (eq? (current-exception-handler) (with-exception-handler h (lambda () (eq? (current-exception-handler)
h))))) h)))))
(pass-if "multiple levels of handler nesting" (pass-if "multiple levels of handler nesting"
(let ((h (lambda (key . args) 'nothing)) (let ((h (lambda (key . args) 'nothing))
(i (current-exception-handler))) (i (current-exception-handler)))
(and (with-exception-handler h (lambda () (and (with-exception-handler h (lambda ()
(eq? (current-exception-handler) h))) (eq? (current-exception-handler) h)))
(eq? (current-exception-handler) i)))) (eq? (current-exception-handler) i))))
(pass-if "exception handler installation is thread-safe" (pass-if "exception handler installation is thread-safe"
(let* ((h1 (current-exception-handler)) (let* ((h1 (current-exception-handler))
(h2 (lambda (key . args) 'nothing-2)) (h2 (lambda (key . args) 'nothing-2))
(m (make-mutex 'current-exception-handler-4)) (m (make-mutex 'current-exception-handler-4))
(c (make-condition-variable 'current-exception-handler-4)) (c (make-condition-variable 'current-exception-handler-4))
(t (make-thread (lambda () (t (make-thread (lambda ()
(with-exception-handler (with-exception-handler
h2 (lambda () h2 (lambda ()
(mutex-lock! m) (mutex-lock! m)
(condition-variable-signal! c) (condition-variable-signal! c)
(wait-condition-variable c m) (wait-condition-variable c m)
(and (eq? (current-exception-handler) h2) (and (eq? (current-exception-handler) h2)
(mutex-unlock! m))))) (mutex-unlock! m)))))
'current-exception-handler-4))) 'current-exception-handler-4)))
(mutex-lock! m) (mutex-lock! m)
(thread-start! t) (thread-start! t)
(wait-condition-variable c m) (wait-condition-variable c m)
(and (eq? (current-exception-handler) h1) (and (eq? (current-exception-handler) h1)
(condition-variable-signal! c) (condition-variable-signal! c)
(mutex-unlock! m) (mutex-unlock! m)
(thread-join! t))))) (thread-join! t)))))
(with-test-prefix "uncaught-exception-reason" (with-test-prefix "uncaught-exception-reason"
(pass-if "initial handler captures top level exception" (pass-if "initial handler captures top level exception"
(let ((t (make-thread (lambda () (raise 'foo)))) (let ((t (make-thread (lambda () (raise 'foo))))
(success #f)) (success #f))
(thread-start! t) (thread-start! t)
(with-exception-handler (with-exception-handler
(lambda (obj) (lambda (obj)
(and (uncaught-exception? obj) (and (uncaught-exception? obj)
(eq? (uncaught-exception-reason obj) 'foo) (eq? (uncaught-exception-reason obj) 'foo)
(set! success #t))) (set! success #t)))
(lambda () (thread-join! t))) (lambda () (thread-join! t)))
success)) success))
(pass-if "initial handler captures non-SRFI-18 throw" (pass-if "initial handler captures non-SRFI-18 throw"
(let ((t (make-thread (lambda () (throw 'foo)))) (let ((t (make-thread (lambda () (throw 'foo))))
(success #f)) (success #f))
(thread-start! t) (thread-start! t)
(with-exception-handler (with-exception-handler
(lambda (obj) (lambda (obj)
(and (uncaught-exception? obj) (and (uncaught-exception? obj)
(eq? (uncaught-exception-reason obj) 'foo) (eq? (uncaught-exception-reason obj) 'foo)
(set! success #t))) (set! success #t)))
(lambda () (thread-join! t))) (lambda () (thread-join! t)))
success))) success)))))
)

25
test-suite/tests/srfi-4.test
View file

@ -515,3 +515,28 @@
(pass-if-exception "generalized-vector-set!, out-of-range" (pass-if-exception "generalized-vector-set!, out-of-range"
exception:out-of-range exception:out-of-range
(generalized-vector-set! (c64vector 1.0) 1 2.0))) (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)))))

49
test-suite/tests/tree-il.test
View file

@ -1549,6 +1549,31 @@
(lambda args args))) (lambda args args)))
(const 1)) (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 (pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its ;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get ;; condition folded. Unfortunately the outer `lp' does not yet get
@ -1564,7 +1589,16 @@
((() #f #f #f () ()) ((() #f #f #f () ())
(call (lexical loop _)))))) (call (lexical loop _))))))
(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 #:opts %opts-w-format
#:to 'assembly))))) #: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" (pass-if "wrong format string"
(let ((w (call-with-warnings (let ((w (call-with-warnings
(lambda () (lambda ()