Adopted a couple of nice ideas from Greg.

1 files changed, 237 insertions, 222 deletions

diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test
index d021717c9..2c8f3df83 100644
--- a/test-suite/tests/alist.test
+++ b/test-suite/tests/alist.test
@@ -70,232 +70,247 @@
     (if x (cdr x) x)))
   
 ;;; Creators, getters
-(catch-test-errors
- (let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
-       (b (acons "this" "is" (acons "a" "test" ())))
-       (deformed '(a b c d e f g)))
-   (pass-if "alist: acons"
-            (and (equal? a '((a . b) (c . d) (e . f)))
-                 (equal? b '(("this" . "is") ("a" . "test")))))
-   (pass-if "alist: sloppy-assq"
-            (let ((x (sloppy-assq 'c a)))
-              (and (pair? x)
-                   (eq? (car x) 'c)
-                   (eq? (cdr x) 'd))))
-   (pass-if "alist: sloppy-assq not"
-            (let ((x (sloppy-assq "this" b)))
-              (not x)))
-   (pass-if "alist: sloppy-assv"
-            (let ((x (sloppy-assv 'c a)))
-              (and (pair? x)
-                   (eq? (car x) 'c)
-                   (eq? (cdr x) 'd))))
-   (pass-if "alist: sloppy-assv not"
-            (let ((x (sloppy-assv "this" b)))
-              (not x)))
-   (pass-if "alist: sloppy-assoc"
-            (let ((x (sloppy-assoc "this" b)))
-              (and (pair? x)
-                   (string=? (cdr x) "is"))))
-   (pass-if "alist: sloppy-assoc not"
-            (let ((x (sloppy-assoc "heehee" b)))
-              (not x)))
-   (pass-if "alist: assq"
-            (let ((x (assq 'c a)))
-              (and (pair? x)
-                   (eq? (car x) 'c)
-                   (eq? (cdr x) 'd))))
-   (pass-if "alist: assq deformed"
-            (catch 'wrong-type-arg
-                   (lambda ()
-                     (assq 'x deformed))
-                   (lambda (key . args)
-                     #t)))
-   (pass-if-not "alist: assq not" (assq 'r a))
-   (pass-if "alist: assv"
-            (let ((x (assv 'a a)))
-              (and (pair? x)
-                   (eq? (car x) 'a)
-                   (eq? (cdr x) 'b))))
-   (pass-if "alist: assv deformed"
-            (catch 'wrong-type-arg
-                   (lambda ()
-                     (assv 'x deformed)
-                     #f)
-                   (lambda (key . args)
-                     #t)))
-   (pass-if-not "alist: assv not" (assq "this" b))
-
-   (pass-if "alist: assoc"
-            (let ((x (assoc "this" b)))
-              (and (pair? x)
-                   (string=? (car x) "this")
-                   (string=? (cdr x) "is"))))
-   (pass-if "alist: assoc deformed"
-            (catch 'wrong-type-arg
-                   (lambda ()
-                     (assoc 'x deformed)
-                     #f)
-                   (lambda (key . args)
-                     #t)))
-   (pass-if-not "alist: assoc not" (assoc "this isn't" b))))
+(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
+      (b (acons "this" "is" (acons "a" "test" ())))
+      (deformed '(a b c d e f g)))
+  (pass-if "alist: acons"
+	   (and (equal? a '((a . b) (c . d) (e . f)))
+		(equal? b '(("this" . "is") ("a" . "test")))))
+  (pass-if "alist: sloppy-assq"
+	   (let ((x (sloppy-assq 'c a)))
+	     (and (pair? x)
+		  (eq? (car x) 'c)
+		  (eq? (cdr x) 'd))))
+  (pass-if "alist: sloppy-assq not"
+	   (let ((x (sloppy-assq "this" b)))
+	     (not x)))
+  (pass-if "alist: sloppy-assv"
+	   (let ((x (sloppy-assv 'c a)))
+	     (and (pair? x)
+		  (eq? (car x) 'c)
+		  (eq? (cdr x) 'd))))
+  (pass-if "alist: sloppy-assv not"
+	   (let ((x (sloppy-assv "this" b)))
+	     (not x)))
+  (pass-if "alist: sloppy-assoc"
+	   (let ((x (sloppy-assoc "this" b)))
+	     (and (pair? x)
+		  (string=? (cdr x) "is"))))
+  (pass-if "alist: sloppy-assoc not"
+	   (let ((x (sloppy-assoc "heehee" b)))
+	     (not x)))
+  (pass-if "alist: assq"
+	   (let ((x (assq 'c a)))
+	     (and (pair? x)
+		  (eq? (car x) 'c)
+		  (eq? (cdr x) 'd))))
+  (pass-if "alist: assq deformed"
+	   (catch 'wrong-type-arg
+		  (lambda ()
+		    (assq 'x deformed))
+		  (lambda (key . args)
+		    #t)))
+  (pass-if-not "alist: assq not" (assq 'r a))
+  (pass-if "alist: assv"
+	   (let ((x (assv 'a a)))
+	     (and (pair? x)
+		  (eq? (car x) 'a)
+		  (eq? (cdr x) 'b))))
+  (pass-if "alist: assv deformed"
+	   (catch 'wrong-type-arg
+		  (lambda ()
+		    (assv 'x deformed)
+		    #f)
+		  (lambda (key . args)
+		    #t)))
+  (pass-if-not "alist: assv not" (assq "this" b))
+
+  (pass-if "alist: assoc"
+	   (let ((x (assoc "this" b)))
+	     (and (pair? x)
+		  (string=? (car x) "this")
+		  (string=? (cdr x) "is"))))
+  (pass-if "alist: assoc deformed"
+	   (catch 'wrong-type-arg
+		  (lambda ()
+		    (assoc 'x deformed)
+		    #f)
+		  (lambda (key . args)
+		    #t)))
+  (pass-if-not "alist: assoc not" (assoc "this isn't" b)))
 
 
 ;;; Refers
-(catch-test-errors
- (let ((a '((foo bar) (baz quux)))
-       (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
-       (deformed '(thats a real sloppy assq you got there)))
-   (pass-if "alist: assq-ref"
-            (let ((x (assq-ref a 'foo)))
-              (and (list? x)
-                   (eq? (car x) 'bar))))
-   
-   (pass-if-not "alist: assq-ref not" (assq-ref b "one"))
-   (pass-if "alist: assv-ref"
-            (let ((x (assv-ref a 'baz)))
-              (and (list? x)
-                   (eq? (car x) 'quux))))
-           
-   (pass-if-not "alist: assv-ref not" (assv-ref b "one"))
-
-   (pass-if "alist: assoc-ref"
-            (let ((x (assoc-ref b "one")))
-              (and (list? x)
-                   (eq? (car x) 2)
-                   (eq? (cadr x) 3))))
-
-   
-   (pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
-   (expect-failure-if (not (defined? 'sloppy-assv-ref)) 
-                      (pass-if "alist: assv-ref deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assv-ref deformed 'sloppy)
-                                        #f)
-                                      (lambda (key . args)
-                                        #t)))
-                      (pass-if "alist: assoc-ref deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assoc-ref deformed 'sloppy)
-                                        #f)
-                                      (lambda (key . args)
-                                        #t)))
-                      
-                      (pass-if "alist: assq-ref deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assq-ref deformed 'sloppy)
-                                        #f)
-                                      (lambda (key . args)
-                                        #t))))))
-                      
+(let ((a '((foo bar) (baz quux)))
+      (b '(("one" 2 3) ("four" 5 6) ("seven" 8 9)))
+      (deformed '(thats a real sloppy assq you got there)))
+  (pass-if "alist: assq-ref"
+	   (let ((x (assq-ref a 'foo)))
+	     (and (list? x)
+		  (eq? (car x) 'bar))))
+
+  (pass-if-not "alist: assq-ref not" (assq-ref b "one"))
+  (pass-if "alist: assv-ref"
+	   (let ((x (assv-ref a 'baz)))
+	     (and (list? x)
+		  (eq? (car x) 'quux))))
+
+  (pass-if-not "alist: assv-ref not" (assv-ref b "one"))
+
+  (pass-if "alist: assoc-ref"
+	   (let ((x (assoc-ref b "one")))
+	     (and (list? x)
+		  (eq? (car x) 2)
+		  (eq? (cadr x) 3))))
+
+
+  (pass-if-not "alist: assoc-ref not" (assoc-ref a 'testing))
+
+  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) 
+
+    (pass-if "alist: assv-ref deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+	  (assv-ref deformed 'sloppy)
+	  #f)
+	(lambda (key . args)
+	  #t)))
+
+    (pass-if "alist: assoc-ref deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+	  (assoc-ref deformed 'sloppy)
+	  #f)
+	(lambda (key . args)
+	  #t)))
+
+    (pass-if "alist: assq-ref deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+	  (assq-ref deformed 'sloppy)
+	  #f)
+	(lambda (key . args)
+	  #t)))))
+
 
 ;;; Setters
-(catch-test-errors
- (let ((a '((another . silly) (alist . test-case)))
-       (b '(("this" "one" "has") ("strings" "!")))
-       (deformed '(canada is a cold nation)))
-   (pass-if "alist: assq-set!"
-            (begin
-              (set! a (assq-set! a 'another 'stupid))
-              (let ((x (safe-assq-ref a 'another)))
-                (and x
-                     (symbol? x) (eq? x 'stupid)))))
-
-   (pass-if "alist: assq-set! add"
-            (begin
-              (set! a (assq-set! a 'fickle 'pickle))
-              (let ((x (safe-assq-ref a 'fickle)))
-                (and x (symbol? x)
-                     (eq? x 'pickle)))))
-   
-   (pass-if "alist: assv-set!"
-            (begin
-              (set! a (assv-set! a 'another 'boring))
-              (let ((x (safe-assv-ref a 'another)))
-                    (and x
-                         (eq? x 'boring)))))
-   (pass-if "alist: assv-set! add"
-            (begin
-              (set! a (assv-set! a 'whistle '(while you work)))
-              (let ((x (safe-assv-ref a 'whistle)))
-                (and x (equal? x '(while you work))))))
-
-   (pass-if "alist: assoc-set!"
-            (begin
-              (set! b (assoc-set! b "this" "has"))
-              (let ((x (safe-assoc-ref b "this")))
-                (and x (string? x)
-                     (string=? x "has")))))
-   (pass-if "alist: assoc-set! add"
-            (begin
-              (set! b (assoc-set! b "flugle" "horn"))
-              (let ((x (safe-assoc-ref b "flugle")))
-                (and x (string? x)
-                     (string=? x "horn")))))
-   (expect-failure-if (not (defined? 'sloppy-assq-ref))
-                      (pass-if "alist: assq-set! deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assq-set! deformed 'cold '(very cold))
-                                        #f)
-                                      (lambda (key . args)
-                                        #t)))   
-                      (pass-if "alist: assv-set! deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assv-set! deformed 'canada 'Canada)
-                                        #f)
-                                      (lambda (key . args)
-                                        #t)))
-                      (pass-if "alist: assoc-set! deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assoc-set! deformed 'canada 
-                                                    '(Iceland hence the name))
-                                        #f)
-                                      (lambda (key . args)
-                                        #t))))))
-   
+(let ((a '((another . silly) (alist . test-case)))
+      (b '(("this" "one" "has") ("strings" "!")))
+      (deformed '(canada is a cold nation)))
+  (pass-if "alist: assq-set!"
+	   (begin
+	     (set! a (assq-set! a 'another 'stupid))
+	     (let ((x (safe-assq-ref a 'another)))
+	       (and x
+		    (symbol? x) (eq? x 'stupid)))))
+
+  (pass-if "alist: assq-set! add"
+	   (begin
+	     (set! a (assq-set! a 'fickle 'pickle))
+	     (let ((x (safe-assq-ref a 'fickle)))
+	       (and x (symbol? x)
+		    (eq? x 'pickle)))))
+
+  (pass-if "alist: assv-set!"
+	   (begin
+	     (set! a (assv-set! a 'another 'boring))
+	     (let ((x (safe-assv-ref a 'another)))
+		   (and x
+			(eq? x 'boring)))))
+  (pass-if "alist: assv-set! add"
+	   (begin
+	     (set! a (assv-set! a 'whistle '(while you work)))
+	     (let ((x (safe-assv-ref a 'whistle)))
+	       (and x (equal? x '(while you work))))))
+
+  (pass-if "alist: assoc-set!"
+	   (begin
+	     (set! b (assoc-set! b "this" "has"))
+	     (let ((x (safe-assoc-ref b "this")))
+	       (and x (string? x)
+		    (string=? x "has")))))
+  (pass-if "alist: assoc-set! add"
+	   (begin
+	     (set! b (assoc-set! b "flugle" "horn"))
+	     (let ((x (safe-assoc-ref b "flugle")))
+	       (and x (string? x)
+		    (string=? x "horn")))))
+
+  (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) 
+
+    (pass-if "alist: assq-set! deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+	  (assq-set! deformed 'cold '(very cold))
+	  #f)
+	(lambda (key . args)
+	  #t)))   
+
+    (pass-if "alist: assv-set! deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+	  (assv-set! deformed 'canada 'Canada)
+	  #f)
+	(lambda (key . args)
+	  #t)))
+
+    (pass-if "alist: assoc-set! deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+	  (assoc-set! deformed 'canada '(Iceland hence the name))
+	  #f)
+	(lambda (key . args)
+	  #t)))))
+
 ;;; Removers
 
-(catch-test-errors
- (let ((a '((a b) (c d) (e boring)))
-       (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
-       (deformed 1))
-   (pass-if "alist: assq-remove!"
-            (begin 
-              (set! a (assq-remove! a 'a))
-              (equal? a '((c d) (e boring)))))
-   (pass-if "alist: assv-remove!"
-            (begin
-              (set! a (assv-remove! a 'c))
-              (equal? a '((e boring)))))
-   (pass-if "alist: assoc-remove!"
-            (begin
-              (set! b (assoc-remove! b "what"))
-              (equal? b '(("could" . "I") ("say" . "here")))))
-   (expect-failure-if (not (defined? 'sloppy-assq-remove!))
-                      (pass-if "alist: assq-remove! deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assq-remove! deformed 'puddle)
-                                        #f)
-                                      (lambda (key . args)
-                                        #t)))
-                      (pass-if "alist: assv-remove! deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assv-remove! deformed 'splashing)
-                                        #f)
-                                      (lambda (key . args)
-                                        #t)))
-                      (pass-if "alist: assoc-remove! deformed"
-                               (catch 'wrong-type-arg
-                                      (lambda ()
-                                        (assoc-remove! deformed 'fun)
-                                        #f)
-                                      (lambda (key . args)
-                                        #t))))))
+(let ((a '((a b) (c d) (e boring)))
+      (b '(("what" .  "else") ("could" . "I") ("say" . "here")))
+      (deformed 1))
+  (pass-if "alist: assq-remove!"
+	   (begin 
+	     (set! a (assq-remove! a 'a))
+	     (equal? a '((c d) (e boring)))))
+  (pass-if "alist: assv-remove!"
+	   (begin
+	     (set! a (assv-remove! a 'c))
+	     (equal? a '((e boring)))))
+  (pass-if "alist: assoc-remove!"
+	   (begin
+	     (set! b (assoc-remove! b "what"))
+	     (equal? b '(("could" . "I") ("say" . "here")))))
+
+  (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) 
+
+    (pass-if "alist: assq-remove! deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+	  (assq-remove! deformed 'puddle)
+	  #f)
+	(lambda (key . args)
+	  #t)))
+
+    (pass-if "alist: assv-remove! deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+	  (assv-remove! deformed 'splashing)
+	  #f)
+	(lambda (key . args)
+	  #t)))
+
+    (pass-if "alist: assoc-remove! deformed"
+      (catch 'wrong-type-arg
+	(lambda ()
+	  (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+	  (assoc-remove! deformed 'fun)
+	  #f)
+	(lambda (key . args)
+	  #t)))))