;;;; alist.test --- tests guile's alists -*- scheme -*-
-;;;; Copyright (C) 1999 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001 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
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
-;;;; This program is distributed in the hope that it will be useful,
+;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
;;;;
-;;;; 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
-;;;;
-;;;; As a special exception, the Free Software Foundation gives permission
-;;;; for additional uses of the text contained in its release of GUILE.
-;;;;
-;;;; The exception is that, if you link the GUILE library with other files
-;;;; to produce an executable, this does not by itself cause the
-;;;; resulting executable to be covered by the GNU General Public License.
-;;;; Your use of that executable is in no way restricted on account of
-;;;; linking the GUILE library code into it.
-;;;;
-;;;; This exception does not however invalidate any other reasons why
-;;;; the executable file might be covered by the GNU General Public License.
-;;;;
-;;;; This exception applies only to the code released by the
-;;;; Free Software Foundation under the name GUILE. If you copy
-;;;; code from other Free Software Foundation releases into a copy of
-;;;; GUILE, as the General Public License permits, the exception does
-;;;; not apply to the code that you add in this way. To avoid misleading
-;;;; anyone as to the status of such modified files, you must delete
-;;;; this exception notice from them.
-;;;;
-;;;; If you write modifications of your own for GUILE, it is your choice
-;;;; whether to permit this exception to apply to your modifications.
-;;;; If you do not wish that, delete this exception notice.
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib))
(if x (cdr x) x)))
;;; Creators, getters
-(let ((a (acons 'a 'b (acons 'c 'd (acons 'e 'f ()))))
- (b (acons "this" "is" (acons "a" "test" ())))
+(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 "acons"
(and (equal? a '((a . b) (c . d) (e . f)))
(and (pair? x)
(eq? (car x) 'c)
(eq? (cdr x) 'd))))
- (pass-if "assq deformed"
- (catch 'wrong-type-arg
- (lambda ()
- (assq 'x deformed))
- (lambda (key . args)
- #t)))
+ (pass-if-exception "assq deformed"
+ exception:wrong-type-arg
+ (assq 'x deformed))
(pass-if-not "assq not" (assq 'r a))
(pass-if "assv"
(let ((x (assv 'a a)))
(and (pair? x)
(eq? (car x) 'a)
(eq? (cdr x) 'b))))
- (pass-if "assv deformed"
- (catch 'wrong-type-arg
- (lambda ()
- (assv 'x deformed)
- #f)
- (lambda (key . args)
- #t)))
+ (pass-if-exception "assv deformed"
+ exception:wrong-type-arg
+ (assv 'x deformed))
(pass-if-not "assv not" (assq "this" b))
(pass-if "assoc"
(and (pair? x)
(string=? (car x) "this")
(string=? (cdr x) "is"))))
- (pass-if "assoc deformed"
- (catch 'wrong-type-arg
- (lambda ()
- (assoc 'x deformed)
- #f)
- (lambda (key . args)
- #t)))
+ (pass-if-exception "assoc deformed"
+ exception:wrong-type-arg
+ (assoc 'x deformed))
(pass-if-not "assoc not" (assoc "this isn't" b)))
(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
- (pass-if "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 "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 "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)))))
+ (pass-if-exception "assv-ref deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assv-ref deformed 'sloppy))
+
+ (pass-if-exception "assoc-ref deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assoc-ref deformed 'sloppy))
+
+ (pass-if-exception "assq-ref deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assq-ref deformed 'sloppy))))
;;; Setters
(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
- (pass-if "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 "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 "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)))))
+ (pass-if-exception "assq-set! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assq-set! deformed 'cold '(very cold)))
+
+ (pass-if-exception "assv-set! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assv-set! deformed 'canada 'Canada))
+
+ (pass-if-exception "assoc-set! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assv-ref?) (throw 'unsupported))
+ (assoc-set! deformed 'canada '(Iceland hence the name)))))
;;; Removers
(let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
- (pass-if "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 "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 "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)))))
+ (pass-if-exception "assq-remove! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+ (assq-remove! deformed 'puddle))
+
+ (pass-if-exception "assv-remove! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+ (assv-remove! deformed 'splashing))
+
+ (pass-if-exception "assoc-remove! deformed"
+ exception:wrong-type-arg
+ (if (not have-sloppy-assq-remove?) (throw 'unsupported))
+ (assoc-remove! deformed 'fun))))
HCoop / bpt / guile.git / blobdiff