merge from 1.8 branch

[bpt/guile.git] / test-suite / tests / srfi-1.test

diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index 1ea775e..22c4a9a 100644 (file)
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1,6 +1,6 @@
 ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*-
 ;;;;
-;;;; Copyright 2003, 2004, 2005 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -17,8 +17,10 @@
 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 ;;;; Boston, MA 02110-1301 USA
 
-(use-modules (srfi srfi-1)
-            (test-suite lib))
+(define-module (test-srfi-1)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-1))
+
 
 (define (ref-delete x lst . proc)
   "Reference implemenation of srfi-1 `delete'."
@@ -200,7 +202,115 @@
 
     (pass-if "(1) (2) / 9 9"
       (equal? '(1 2) (append-map noop '((1) (2)) '(9 9))))))
-  
+
+;;
+;; append-reverse
+;;
+
+(with-test-prefix "append-reverse"
+
+  ;; return a list which is the cars and cdrs of LST
+  (define (list-contents lst)
+    (if (null? lst)
+       '()
+       (cons* (car lst) (cdr lst) (list-contents (cdr lst)))))
+
+  (define (valid-append-reverse revhead tail want)
+    (let ((revhead-contents (list-contents revhead))
+         (got              (append-reverse revhead tail)))
+      (and (equal? got want)
+          ;; revhead unchanged
+          (equal? revhead-contents (list-contents revhead)))))
+
+  (pass-if-exception "too few args (0)" exception:wrong-num-args
+    (append-reverse))
+
+  (pass-if-exception "too few args (1)" exception:wrong-num-args
+    (append-reverse '(x)))
+
+  (pass-if-exception "too many args (3)" exception:wrong-num-args
+    (append-reverse '() '() #f))
+
+  (pass-if (valid-append-reverse '() '()      '()))
+  (pass-if (valid-append-reverse '() '(1 2 3) '(1 2 3)))
+
+  (pass-if (valid-append-reverse '(1) '()    '(1)))
+  (pass-if (valid-append-reverse '(1) '(2)   '(1 2)))
+  (pass-if (valid-append-reverse '(1) '(2 3) '(1 2 3)))
+
+  (pass-if (valid-append-reverse '(1 2) '()    '(2 1)))
+  (pass-if (valid-append-reverse '(1 2) '(3)   '(2 1 3)))
+  (pass-if (valid-append-reverse '(1 2) '(3 4) '(2 1 3 4)))
+
+  (pass-if (valid-append-reverse '(1 2 3) '()    '(3 2 1)))
+  (pass-if (valid-append-reverse '(1 2 3) '(4)   '(3 2 1 4)))
+  (pass-if (valid-append-reverse '(1 2 3) '(4 5) '(3 2 1 4 5))))
+
+;;
+;; append-reverse!
+;;
+
+(with-test-prefix "append-reverse!"
+
+  (pass-if-exception "too few args (0)" exception:wrong-num-args
+    (append-reverse!))
+
+  (pass-if-exception "too few args (1)" exception:wrong-num-args
+    (append-reverse! '(x)))
+
+  (pass-if-exception "too many args (3)" exception:wrong-num-args
+    (append-reverse! '() '() #f))
+
+  (pass-if (equal? '()      (append-reverse! '() '())))
+  (pass-if (equal? '(1 2 3) (append-reverse! '() '(1 2 3))))
+
+  (pass-if (equal? '(1)     (append-reverse! '(1) '())))
+  (pass-if (equal? '(1 2)   (append-reverse! '(1) '(2))))
+  (pass-if (equal? '(1 2 3) (append-reverse! '(1) '(2 3))))
+
+  (pass-if (equal? '(2 1)     (append-reverse! '(1 2) '())))
+  (pass-if (equal? '(2 1 3)   (append-reverse! '(1 2) '(3))))
+  (pass-if (equal? '(2 1 3 4) (append-reverse! '(1 2) '(3 4))))
+
+  (pass-if (equal? '(3 2 1)     (append-reverse! '(1 2 3) '())))
+  (pass-if (equal? '(3 2 1 4)   (append-reverse! '(1 2 3) '(4))))
+  (pass-if (equal? '(3 2 1 4 5) (append-reverse! '(1 2 3) '(4 5)))))
+
+;;
+;; assoc
+;;
+
+(with-test-prefix "assoc"
+
+  (pass-if "not found"
+    (let ((alist '((a . 1)
+                  (b . 2)
+                  (c . 3))))
+      (eqv? #f (assoc 'z alist))))
+
+  (pass-if "found"
+    (let ((alist '((a . 1)
+                  (b . 2)
+                  (c . 3))))
+      (eqv? (second alist) (assoc 'b alist))))
+
+  ;; this was wrong in guile 1.8.0 (a gremlin newly introduced in the 1.8
+  ;; series, 1.6.x and earlier was ok)
+  (pass-if "= arg order"
+    (let ((alist '((b . 1)))
+         (good  #f))
+      (assoc 'a alist (lambda (x y)
+                       (set! good (and (eq? x 'a)
+                                       (eq? y 'b)))))
+      good))
+
+  ;; likewise this one bad in guile 1.8.0
+  (pass-if "srfi-1 example <"
+    (let ((alist '((1 . a)
+                  (5 . b)
+                  (6 . c))))
+      (eq? (third alist) (assoc 5 alist <)))))
+
 ;;
 ;; break
 ;;
@@ -577,11 +687,11 @@
       (delete-proc 0 '() equal? 99))
     
     (pass-if "empty"
-      (eq? '() (delete-proc 0 '())))
+      (eq? '() (delete-proc 0 '() equal?)))
     
-    (pass-if "equal? (the default)"
+    (pass-if "equal?"
       (equal? '((1) (3))
-             (delete-proc '(2) '((1) (2) (3)))))
+             (delete-proc '(2) '((1) (2) (3)) equal?)))
     
     (pass-if "eq?"
       (equal? '((1) (2) (3))
@@ -599,8 +709,8 @@
        (let ((lst-copy (list-copy lst)))
         (with-test-prefix lst-copy
           (pass-if "result"
-            (equal? (delete     #f lst)
-                    (ref-delete #f lst)))
+            (equal? (delete     #f lst equal?)
+                    (ref-delete #f lst equal?)))
           (pass-if "non-destructive"
             (equal? lst-copy lst)))))))