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

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?

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)
+             (not (tree-il-any (lambda (x)
                                  (and (lexical-ref? x)
                                       (eq? (lexical-ref-gensym x) cont)))
-                          body))
+                               body)))
             (else #f)))
         (define (thunk-application? x)
           (match x

module/language/tree-il/peval.scm

@@ -1221,12 +1221,27 @@ 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))))))
+                         (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) ...)
@@ -1234,8 +1249,8 @@ top-level bindings from ENV and return the resulting expression."
                               (_ #f))
                             (map (cut loop <> env counter 'value) inits)
                             new
-                           (loop body env counter ctx)
+                            body
-                           (and alt (for-tail alt)))))
+                            (and alt (for-tail alt))))))
       (($ <seq> src head tail)
        (let ((head (for-effect head))
              (tail (for-tail tail)))

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 ((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
                    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
+                    (make-primcall
-                                    (list handler
+                     #f 'apply
+                     (list (make-lexical-ref #f 'handler handler-sym)
                            (make-lexical-ref #f 'args args-sym)))
-                     #f))))
+                    #f)))))
-                (else #f)))
               (else #f)))
 
 (hashq-set! *primitive-expand-table*

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))))

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))))

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

test-suite/lib.scm

@@ -314,11 +314,11 @@
 
 ;;; The central testing routine.
 ;;; 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
-	(error "Nested calls to run-test are not permitted.")
+          (error "Nested calls to run-test are not permitted."))
       (let ((test-name (full-name name)))
             (set! test-running #t)
             (catch #t
@@ -340,8 +340,7 @@
                    (quit))
                   (else
                    (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.
 (define-syntax pass-if

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,15 +25,14 @@
 (if (provided? 'threads)
     (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))))
 
-(with-test-prefix "thread?"
+  (with-test-prefix "thread?"
 
     (pass-if "current-thread is thread"
       (thread? (current-thread)))
@@ -41,7 +40,7 @@
     (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)))
@@ -49,7 +48,7 @@
              (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))
@@ -61,7 +60,7 @@
              (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))
@@ -74,7 +73,7 @@
         (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)
@@ -82,12 +81,12 @@
              (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))
 
-(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))))
@@ -101,7 +100,7 @@
       (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))
@@ -134,7 +133,7 @@
          (lambda () (thread-join! t)))
         success)))
 
-(with-test-prefix "thread-join!"
+  (with-test-prefix "thread-join!"
 
     (pass-if "join receives result of thread"
       (let ((t (make-thread (lambda () 'foo) 'thread-join-1)))
@@ -167,7 +166,7 @@
         (thread-start! t)
         (eq? (thread-join! t (+ (time->seconds (current-time)) 2)) 'foo))))
 
-(with-test-prefix "mutex?"
+  (with-test-prefix "mutex?"
 
     (pass-if "make-mutex creates mutex"
       (mutex? (make-mutex)))
@@ -175,7 +174,7 @@
     (pass-if "symbol not mutex"
       (not (mutex? 'foo))))
 
-(with-test-prefix "mutex-name"
+  (with-test-prefix "mutex-name"
 
     (pass-if "make-mutex with name binds name"
       (let* ((m (make-mutex 'mutex-name-1)))
@@ -185,7 +184,7 @@
       (let* ((m (make-mutex)))
         (not (mutex-name m)))))
 
-(with-test-prefix "mutex-specific"
+  (with-test-prefix "mutex-specific"
 
     (pass-if "mutex-specific is initially #f"
       (let ((m (make-mutex 'mutex-specific-1)))
@@ -196,7 +195,7 @@
         (mutex-specific-set! 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"
       (let ((m (make-mutex 'mutex-state-1)))
@@ -219,7 +218,7 @@
         (thread-join! t)
         (eq? (mutex-state m) 'abandoned))))
 
-(with-test-prefix "mutex-lock!"
+  (with-test-prefix "mutex-lock!"
   
     (pass-if "mutex-lock! returns true on successful lock"
       (let* ((m (make-mutex 'mutex-lock-1)))
@@ -280,7 +279,7 @@
          (lambda () (mutex-unlock! m1 c) (mutex-lock! m2)))
         success)))
 
-(with-test-prefix "mutex-unlock!"
+  (with-test-prefix "mutex-unlock!"
    
     (pass-if "unlock changes mutex state"
       (let* ((m (make-mutex 'mutex-unlock-1)))
@@ -313,7 +312,7 @@
         (mutex-lock! m)
         (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"
       (condition-variable? (make-condition-variable)))
@@ -321,7 +320,7 @@
     (pass-if "symbol not condition variable"
       (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"
       (let* ((c (make-condition-variable 'condition-variable-name-1)))
@@ -331,7 +330,7 @@
       (let* ((c (make-condition-variable)))
         (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"
       (let ((c (make-condition-variable 'condition-variable-specific-1)))
@@ -342,7 +341,7 @@
         (condition-variable-specific-set! 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"
       (let* ((m (make-mutex 'condition-variable-signal-1))
@@ -355,7 +354,7 @@
         (thread-start! t)
         (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"
       (let* ((sem 0)
@@ -393,13 +392,13 @@
         (dec-sem!)
         (dec-sem!))))
 
-(with-test-prefix "time?"
+  (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"
+  (with-test-prefix "time->seconds"
 
     (pass-if "time->seconds makes time into rational"
       (rational? (time->seconds (current-time))))
@@ -408,7 +407,7 @@
       (let ((t (current-time)))
         (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"
       (time? (seconds->time 123.456)))
@@ -417,7 +416,7 @@
       (let ((t (time->seconds (current-time))))
         (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"
       (procedure? (current-exception-handler)))
@@ -456,7 +455,7 @@
              (mutex-unlock! m)
              (thread-join! t)))))
 
-(with-test-prefix "uncaught-exception-reason"
+  (with-test-prefix "uncaught-exception-reason"
 
     (pass-if "initial handler captures top level exception"
       (let ((t (make-thread (lambda () (raise 'foo))))
@@ -480,6 +479,4 @@
                 (eq? (uncaught-exception-reason obj) 'foo)
                 (set! success #t)))
          (lambda () (thread-join! t)))
-      success)))
+        success)))))
-
-)

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)))))

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 ()