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

Conflicts:
	libguile/read.c
	test-suite/tests/tree-il.test

test-suite/tests/srfi-13.test

@@ -1,7 +1,7 @@
 ;;;; srfi-13.test --- Test suite for Guile's SRFI-13 functions. -*- scheme -*-
 ;;;; Martin Grabmueller, 2001-05-07
 ;;;;
-;;;; Copyright (C) 2001, 2004, 2005, 2006, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001, 2004, 2005, 2006, 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
@@ -561,13 +561,15 @@
 (with-test-prefix "substring/shared"
 
   (pass-if "empty string"
-    (eq? "" (substring/shared "" 0)))
-
-  (pass-if "non-empty string"
-    (string=? "foo" (substring/shared "foo-bar" 0 3)))
+    (let ((s ""))
+      (eq? s (substring/shared s 0))))
 
   (pass-if "non-empty string, not eq?"
-    (string=? "foo-bar" (substring/shared "foo-bar" 0 7))))
+    (string=? "foo" (substring/shared "foo-bar" 0 3)))
+
+  (pass-if "shared copy of non-empty string is eq?"
+    (let ((s "foo-bar"))
+      (eq? s (substring/shared s 0 7)))))
 
 (with-test-prefix "string-copy!"
 

test-suite/tests/syntax.test

@@ -648,11 +648,13 @@
 
     (pass-if-syntax-error "missing recipient"
       '(cond . "wrong number of receiver expressions")
-      (cond (#t identity =>)))
+      (eval '(cond (#t identity =>))
+            (interaction-environment)))
 
     (pass-if-syntax-error "extra recipient"
       '(cond . "wrong number of receiver expressions")
-      (cond (#t identity => identity identity))))
+      (eval '(cond (#t identity => identity identity))
+            (interaction-environment))))
 
   (with-test-prefix "bad or missing clauses"
 
@@ -662,43 +664,48 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond #t)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond #t)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1 2)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1 2)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1 2 3)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1 2 3)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond 1 2 3 4)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond 1 2 3 4)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond ())"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond ())
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond () 1)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond () 1)
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(cond (1) 1)"
-      exception:generic-syncase-error
+      '(cond . "invalid clause")
       (eval '(cond (1) 1)
+	    (interaction-environment)))
+
+    (pass-if-syntax-error "(cond (else #f) (#t #t))"
+      '(cond . "else must be the last clause")
+      (eval '(cond (else #f) (#t #t))
 	    (interaction-environment))))
 
   (with-test-prefix "wrong number of arguments"
@@ -712,10 +719,46 @@
   (pass-if "clause with empty labels list"
     (case 1 (() #f) (else #t)))
 
+  (with-test-prefix "case handles '=> correctly"
+
+    (pass-if "(1 2 3) => list"
+      (equal? (case 1 ((1 2 3) => list))
+              '(1)))
+
+    (pass-if "else => list"
+      (equal? (case 6
+                ((1 2 3) 'wrong)
+                (else => list))
+              '(6)))
+
+    (with-test-prefix "bound '=> is handled correctly"
+
+      (pass-if "(1) => 'ok"
+        (let ((=> 'foo))
+          (eq? (case 1 ((1) => 'ok)) 'ok)))
+
+      (pass-if "else =>"
+        (let ((=> 'foo))
+          (eq? (case 1 (else =>)) 'foo)))
+
+      (pass-if "else => list"
+        (let ((=> 'foo))
+          (eq? (case 1 (else => identity)) identity))))
+
+    (pass-if-syntax-error "missing recipient"
+      '(case . "wrong number of receiver expressions")
+      (eval '(case 1 ((1) =>))
+            (interaction-environment)))
+
+    (pass-if-syntax-error "extra recipient"
+      '(case . "wrong number of receiver expressions")
+      (eval '(case 1 ((1) => identity identity))
+            (interaction-environment))))
+
   (with-test-prefix "case is hygienic"
 
     (pass-if-syntax-error "bound 'else is handled correctly"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(let ((else #f)) (case 1 (else #f)))
             (interaction-environment))))
 
@@ -742,22 +785,22 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 \"foo\")"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 "foo")
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 ())"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ())
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 (\"foo\"))"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ("foo"))
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 (\"foo\" \"bar\"))"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ("foo" "bar"))
 	    (interaction-environment)))
 
@@ -767,7 +810,7 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 ((2) \"bar\") (else))"
-      exception:generic-syncase-error
+      '(case . "invalid clause")
       (eval '(case 1 ((2) "bar") (else))
 	    (interaction-environment)))
 
@@ -777,7 +820,7 @@
 	    (interaction-environment)))
 
     (pass-if-syntax-error "(case 1 (else #f) ((1) #t))"
-      exception:generic-syncase-error
+      '(case . "else must be the last clause")
       (eval '(case 1 (else #f) ((1) #t))
 	    (interaction-environment)))))
 

test-suite/tests/tree-il.test

@@ -1162,24 +1162,21 @@
     (case foo
       ((3 2 1) 'a)
       (else 'b))
-    (if (let (t) (_) ((toplevel foo))
-             (if (primcall eqv? (lexical t _) (const 3))
+    (let (key) (_) ((toplevel foo))
+         (if (if (primcall eqv? (lexical key _) (const 3))
                  (const #t)
-                 (if (primcall eqv? (lexical t _) (const 2))
+                 (if (primcall eqv? (lexical key _) (const 2))
                      (const #t)
-                     (primcall eqv? (lexical t _) (const 1)))))
-        (const a)
-        (const b)))
+                     (primcall eqv? (lexical key _) (const 1))))
+             (const a)
+             (const b))))
 
   (pass-if-peval
-    ;; Memv with non-constant key, empty list, test context.  Currently
-    ;; doesn't fold entirely.
+    ;; Memv with non-constant key, empty list, test context.
     (case foo
       (() 'a)
       (else 'b))
-    (if (seq (toplevel foo) (const #f))
-        (const a)
-        (const b)))
+    (seq (toplevel foo) (const 'b)))
 
   ;;
   ;; Below are cases where constant propagation should bail out.