summaryrefslogtreecommitdiff
path: root/test-suite/tests
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-02-11 18:14:48 +0100
committerAndy Wingo <wingo@pobox.com>2012-02-11 18:14:48 +0100
commita41bed83ab2d2f0bf93c06115c695280d04d13e6 (patch)
treefe300b182a0e4e3fb411cfb67bc2ed05313a11c8 /test-suite/tests
parentbbabae997d7e83e0382d086ce2e0ed82b61c2a7e (diff)
parentc2c3bddb1d0b2180282d78262e84c3ae7a44731f (diff)
downloadguile-a41bed83ab2d2f0bf93c06115c695280d04d13e6.tar.gz
Merge remote-tracking branch 'origin/stable-2.0'
Conflicts: libguile/read.c test-suite/tests/tree-il.test
Diffstat (limited to 'test-suite/tests')
-rw-r--r--test-suite/tests/srfi-13.test12
-rw-r--r--test-suite/tests/syntax.test77
-rw-r--r--test-suite/tests/tree-il.test19
3 files changed, 75 insertions, 33 deletions
diff --git a/test-suite/tests/srfi-13.test b/test-suite/tests/srfi-13.test
index 5575a700f..de6df8e52 100644
--- a/test-suite/tests/srfi-13.test
+++ b/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)))
+ (let ((s ""))
+ (eq? s (substring/shared s 0))))
- (pass-if "non-empty string"
+ (pass-if "non-empty string, not eq?"
(string=? "foo" (substring/shared "foo-bar" 0 3)))
- (pass-if "non-empty string, not eq?"
- (string=? "foo-bar" (substring/shared "foo-bar" 0 7))))
+ (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!"
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 5163bac00..e55cba11e 100644
--- a/test-suite/tests/syntax.test
+++ b/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)))))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 1e0b8c179..1f3d4e91c 100644
--- a/test-suite/tests/tree-il.test
+++ b/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.