;;;; 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
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
+;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+(define-module (test-srfi-1)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
-(use-modules (srfi srfi-1)
- (test-suite lib))
(define (ref-delete x lst . proc)
"Reference implemenation of srfi-1 `delete'."
(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
;;
(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))
(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)))))))
(pass-if "(2) 1 1"
(equal? '(1 2) (lset-adjoin = '(2) 1 1))))
+;;
+;; lset-difference
+;;
+
+(with-test-prefix "lset-difference"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-difference (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) '(2))
+ good)))
+
+;;
+;; lset-difference!
+;;
+
+(with-test-prefix "lset-difference!"
+
+ (pass-if-exception "proc - num" exception:wrong-type-arg
+ (lset-difference! 123 '(4)))
+ (pass-if-exception "proc - list" exception:wrong-type-arg
+ (lset-difference! (list 1 2 3) '(4)))
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-difference! (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ (list 1) (list 2))
+ good))
+
+ (pass-if (equal? '() (lset-difference! = '())))
+ (pass-if (equal? '(1) (lset-difference! = (list 1))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 2))))
+
+ (pass-if (equal? '() (lset-difference! = (list ) '(3))))
+ (pass-if (equal? '() (lset-difference! = (list 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 3 1) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 3 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 3 1 3) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 3 3 1) '(3))))
+
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2 3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3 2))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(3) '(2))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(2 3))))
+ (pass-if (equal? '(1) (lset-difference! = (list 1 2 3) '(2) '(3 2))))
+
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3) '(3) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2) '(3) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2) '(3) '(3))))
+
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 3 4) '(4))))
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 2 4 3) '(4))))
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 1 4 2 3) '(4))))
+ (pass-if (equal? '(1 2 3) (lset-difference! = (list 4 1 2 3) '(4))))
+
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 2 3 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 2 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 2 4) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 1 3 4 2) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 1 4 2) '(4) '(3))))
+ (pass-if (equal? '(1 2) (lset-difference! = (list 3 4 1 2) '(4) '(3)))))
+
+;;
+;; lset-diff+intersection
+;;
+
+(with-test-prefix "lset-diff+intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-diff+intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) '(2))
+ good)))
+
+;;
+;; lset-diff+intersection!
+;;
+
+(with-test-prefix "lset-diff+intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-diff+intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ (list 1) (list 2))
+ good)))
+
+;;
+;; lset-intersection
+;;
+
+(with-test-prefix "lset-intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ '(1) '(2))
+ good)))
+
+;;
+;; lset-intersection!
+;;
+
+(with-test-prefix "lset-intersection"
+
+ (pass-if "called arg order"
+ (let ((good #f))
+ (lset-intersection (lambda (x y)
+ (set! good (and (= x 1) (= y 2)))
+ (= x y))
+ (list 1) (list 2))
+ good)))
+
;;
;; lset-union
;;
HCoop / bpt / guile.git / blobdiff