mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

* Provide and use new convenience macros to test for exceptions.

Browse source
This commit is contained in:
Dirk Herrmann 2001-02-28 11:25:40 +00:00
parent 9d372117f6
commit 6b4113afc5
10 changed files with 292 additions and 472 deletions
Download patch file Download diff file Expand all files Collapse all files

58
test-suite/lib.scm
View file

@ -16,12 +16,18 @@
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA ;;;; Boston, MA 02111-1307 USA
(define-module (test-suite lib)) (define-module (test-suite lib)
:use-module (ice-9 regex))
(export (export
;; Exceptions which are commonly being tested for.
exception:out-of-range exception:wrong-type-arg
;; Reporting passes and failures. ;; Reporting passes and failures.
run-test pass-if expect-fail run-test
pass-if expect-fail
pass-if-exception expect-fail-exception
;; Naming groups of tests in a regular fashion. ;; Naming groups of tests in a regular fashion.
with-test-prefix with-test-prefix* current-test-prefix with-test-prefix with-test-prefix* current-test-prefix
@ -67,7 +73,9 @@
;;;; environment. All other exceptions thrown by THUNK are considered as ;;;; environment. All other exceptions thrown by THUNK are considered as
;;;; errors. ;;;; errors.
;;;; ;;;;
;;;; For convenience, the following macros are provided: ;;;;
;;;; Convenience macros for tests expected to pass or fail
;;;;
;;;; * (pass-if name body) is a short form for ;;;; * (pass-if name body) is a short form for
;;;; (run-test name #t (lambda () body)) ;;;; (run-test name #t (lambda () body))
;;;; * (expect-fail name body) is a short form for ;;;; * (expect-fail name body) is a short form for
@ -76,7 +84,24 @@
;;;; For example: ;;;; For example:
;;;; ;;;;
;;;; (pass-if "integer addition" (= 2 (+ 1 1))) ;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
;;;;
;;;;
;;;; Convenience macros to test for exceptions
;;;;
;;;; The following macros take exception parameters which are pairs
;;;; (type . message), where type is a symbol that denotes an exception type
;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
;;;; regular expression that describes the error message for the exception
;;;; like "Argument .* out of range".
;;;;
;;;; * (pass-if-exception name exception body) will pass if the execution of
;;;; body causes the given exception to be thrown. If no exception is
;;;; thrown, the test fails. If some other exception is thrown, is is an
;;;; error.
;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
;;;; the execution of body causes the given exception to be thrown. If no
;;;; exception is thrown, the test fails expectedly. If some other
;;;; exception is thrown, it is an error.
;;;; TEST NAMES ;;;; TEST NAMES
@ -194,6 +219,12 @@
;;;; MISCELLANEOUS ;;;; MISCELLANEOUS
;;;; ;;;;
;;; Define some exceptions which are commonly being tested for.
(define exception:out-of-range
(cons 'out-of-range "^Argument .*out of range"))
(define exception:wrong-type-arg
(cons 'wrong-type-arg "^Wrong type argument"))
;;; Display all parameters to the default output port, followed by a newline. ;;; Display all parameters to the default output port, followed by a newline.
(define (display-line . objs) (define (display-line . objs)
(for-each display objs) (for-each display objs)
@ -247,6 +278,25 @@
(defmacro expect-fail (name body . rest) (defmacro expect-fail (name body . rest)
`(run-test ,name #f (lambda () ,body ,@rest))) `(run-test ,name #f (lambda () ,body ,@rest)))
;;; A helper function to implement the macros that test for exceptions.
(define (run-test-exception name exception expect-pass thunk)
(run-test name expect-pass
(lambda ()
(catch (car exception)
(lambda () (thunk) #f)
(lambda (key proc message . rest)
(if (not (string-match (cdr exception) message))
(apply throw key proc message rest)
#t))))))
;;; A short form for tests that expect a certain exception to be thrown.
(defmacro pass-if-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
;;; A short form for tests expected to fail to throw a certain exception.
(defmacro expect-fail-exception (name exception body . rest)
`(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
;;;; TEST NAMES ;;;; TEST NAMES
;;;; ;;;;

137
test-suite/tests/alist.test
View file

@ -104,25 +104,18 @@
(and (pair? x) (and (pair? x)
(eq? (car x) 'c) (eq? (car x) 'c)
(eq? (cdr x) 'd)))) (eq? (cdr x) 'd))))
(pass-if "assq deformed" (pass-if-exception "assq deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (assq 'x deformed))
(assq 'x deformed))
(lambda (key . args)
#t)))
(pass-if-not "assq not" (assq 'r a)) (pass-if-not "assq not" (assq 'r a))
(pass-if "assv" (pass-if "assv"
(let ((x (assv 'a a))) (let ((x (assv 'a a)))
(and (pair? x) (and (pair? x)
(eq? (car x) 'a) (eq? (car x) 'a)
(eq? (cdr x) 'b)))) (eq? (cdr x) 'b))))
(pass-if "assv deformed" (pass-if-exception "assv deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (assv 'x deformed))
(assv 'x deformed)
#f)
(lambda (key . args)
#t)))
(pass-if-not "assv not" (assq "this" b)) (pass-if-not "assv not" (assq "this" b))
(pass-if "assoc" (pass-if "assoc"
@ -130,13 +123,9 @@
(and (pair? x) (and (pair? x)
(string=? (car x) "this") (string=? (car x) "this")
(string=? (cdr x) "is")))) (string=? (cdr x) "is"))))
(pass-if "assoc deformed" (pass-if-exception "assoc deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (assoc 'x deformed))
(assoc 'x deformed)
#f)
(lambda (key . args)
#t)))
(pass-if-not "assoc not" (assoc "this isn't" b))) (pass-if-not "assoc not" (assoc "this isn't" b)))
@ -168,32 +157,20 @@
(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
(pass-if "assv-ref deformed" (pass-if-exception "assv-ref deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported))
(if (not have-sloppy-assv-ref?) (throw 'unsupported)) (assv-ref deformed 'sloppy))
(assv-ref deformed 'sloppy)
#f)
(lambda (key . args)
#t)))
(pass-if "assoc-ref deformed" (pass-if-exception "assoc-ref deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported))
(if (not have-sloppy-assv-ref?) (throw 'unsupported)) (assoc-ref deformed 'sloppy))
(assoc-ref deformed 'sloppy)
#f)
(lambda (key . args)
#t)))
(pass-if "assq-ref deformed" (pass-if-exception "assq-ref deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported))
(if (not have-sloppy-assv-ref?) (throw 'unsupported)) (assq-ref deformed 'sloppy))))
(assq-ref deformed 'sloppy)
#f)
(lambda (key . args)
#t)))))
;;; Setters ;;; Setters
@ -241,32 +218,20 @@
(let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref)))
(pass-if "assq-set! deformed" (pass-if-exception "assq-set! deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported))
(if (not have-sloppy-assv-ref?) (throw 'unsupported)) (assq-set! deformed 'cold '(very cold)))
(assq-set! deformed 'cold '(very cold))
#f)
(lambda (key . args)
#t)))
(pass-if "assv-set! deformed" (pass-if-exception "assv-set! deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported))
(if (not have-sloppy-assv-ref?) (throw 'unsupported)) (assv-set! deformed 'canada 'Canada))
(assv-set! deformed 'canada 'Canada)
#f)
(lambda (key . args)
#t)))
(pass-if "assoc-set! deformed" (pass-if-exception "assoc-set! deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assv-ref?) (throw 'unsupported))
(if (not have-sloppy-assv-ref?) (throw 'unsupported)) (assoc-set! deformed 'canada '(Iceland hence the name)))))
(assoc-set! deformed 'canada '(Iceland hence the name))
#f)
(lambda (key . args)
#t)))))
;;; Removers ;;; Removers
@ -288,29 +253,17 @@
(let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove)))
(pass-if "assq-remove! deformed" (pass-if-exception "assq-remove! deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assq-remove?) (throw 'unsupported))
(if (not have-sloppy-assq-remove?) (throw 'unsupported)) (assq-remove! deformed 'puddle))
(assq-remove! deformed 'puddle)
#f)
(lambda (key . args)
#t)))
(pass-if "assv-remove! deformed" (pass-if-exception "assv-remove! deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assq-remove?) (throw 'unsupported))
(if (not have-sloppy-assq-remove?) (throw 'unsupported)) (assv-remove! deformed 'splashing))
(assv-remove! deformed 'splashing)
#f)
(lambda (key . args)
#t)))
(pass-if "assoc-remove! deformed" (pass-if-exception "assoc-remove! deformed"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (if (not have-sloppy-assq-remove?) (throw 'unsupported))
(if (not have-sloppy-assq-remove?) (throw 'unsupported)) (assoc-remove! deformed 'fun))))
(assoc-remove! deformed 'fun)
#f)
(lambda (key . args)
#t)))))

82
test-suite/tests/environments.test
View file

@ -47,6 +47,8 @@
;;; miscellaneous ;;; miscellaneous
;;; ;;;
(define exception:unbound-symbol
(cons 'misc-error "^Symbol .* not bound in environment"))
(define (documented? object) (define (documented? object)
(not (not (object-documentation object)))) (not (not (object-documentation object))))
@ -173,37 +175,21 @@
(environment-define env 'a #f) (environment-define env 'a #f)
(not (eq? (environment-cell env 'a #t) cell))))) (not (eq? (environment-cell env 'a #t) cell)))))
(pass-if "reference an undefined symbol" (pass-if-exception "reference an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-ref (make-leaf-environment) 'a))
(environment-ref (make-leaf-environment) 'a)
#f)
(lambda args
#t)))
(pass-if "set! an undefined symbol" (pass-if-exception "set! an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-set! (make-leaf-environment) 'a #f))
(environment-set! (make-leaf-environment) 'a)
#f)
(lambda args
#t)))
(pass-if "get a readable cell for an undefined symbol" (pass-if-exception "get a readable cell for an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-cell (make-leaf-environment) 'a #f))
(environment-cell (make-leaf-environment) 'a #f)
#f)
(lambda args
#t)))
(pass-if "get a writable cell for an undefined symbol" (pass-if-exception "get a writable cell for an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-cell (make-leaf-environment) 'a #t)))
(environment-cell (make-leaf-environment) 'a #t)
#f)
(lambda args
#t))))
(with-test-prefix "undefine" (with-test-prefix "undefine"
@ -621,37 +607,21 @@
(imported (make-leaf-environment)) (imported (make-leaf-environment))
(env (make-eval-environment local imported))) (env (make-eval-environment local imported)))
(pass-if "reference an undefined symbol" (pass-if-exception "reference an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-ref env 'b))
(environment-ref env 'b)
#f)
(lambda args
#t)))
(pass-if "set! an undefined symbol" (pass-if-exception "set! an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-set! env 'b #f))
(environment-set! env 'b)
#f)
(lambda args
#t)))
(pass-if "get a readable cell for an undefined symbol" (pass-if-exception "get a readable cell for an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-cell env 'b #f))
(environment-cell env 'b #f)
#f)
(lambda args
#t)))
(pass-if "get a writable cell for an undefined symbol" (pass-if-exception "get a writable cell for an unbound symbol"
(catch #t exception:unbound-symbol
(lambda () (environment-cell env 'b #t))))
(environment-cell env 'b #t)
#f)
(lambda args
#t)))))
(with-test-prefix "eval-environment-set-local!" (with-test-prefix "eval-environment-set-local!"

66
test-suite/tests/eval.test
View file

@ -47,7 +47,6 @@
;;; miscellaneous ;;; miscellaneous
;;; ;;;
(define (documented? object) (define (documented? object)
(not (not (object-documentation object)))) (not (not (object-documentation object))))
@ -64,24 +63,17 @@
;; Macros are accepted as function parameters. ;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!! ;; Functions that 'apply' macros are rewritten!!!
(expect-fail "macro as argument" (expect-fail-exception "macro as argument"
exception:wrong-type-arg
(let ((f (lambda (p a b) (p a b)))) (let ((f (lambda (p a b) (p a b))))
(catch 'wrong-type-arg (f and #t #t)))
(lambda ()
(f and #t #t)
#f)
(lambda (key . args)
#t))))
(expect-fail "application of macro" (expect-fail-exception "passing macro as parameter"
(let ((f (lambda (p a b) (p a b)))) exception:wrong-type-arg
(catch 'wrong-type-arg (let* ((f (lambda (p a b) (p a b)))
(lambda () (foo (procedure-source f)))
(let ((foo (procedure-source f))) (f and #t #t)
(f and #t #t) (equal? (procedure-source f) foo)))
(equal? (procedure-source f) foo)))
(lambda (key . args)
#t))))
)) ))
@ -103,35 +95,19 @@
(with-test-prefix "different length lists" (with-test-prefix "different length lists"
(pass-if "first list empty" (pass-if-exception "first list empty"
(catch 'out-of-range exception:out-of-range
(lambda () (map + '() '(1)))
(map + '() '(1))
#f)
(lambda (key . args)
#t)))
(pass-if "second list empty" (pass-if-exception "second list empty"
(catch 'out-of-range exception:out-of-range
(lambda () (map + '(1) '()))
(map + '(1) '())
#f)
(lambda (key . args)
#t)))
(pass-if "first list shorter" (pass-if-exception "first list shorter"
(catch 'out-of-range exception:out-of-range
(lambda () (map + '(1) '(2 3)))
(map + '(1) '(2 3))
#f)
(lambda (key . args)
#t)))
(pass-if "second list shorter" (pass-if-exception "second list shorter"
(catch 'out-of-range exception:out-of-range
(lambda () (map + '(1 2) '(3)))
(map + '(1 2) '(3))
#f)
(lambda (key . args)
#t)))
))) )))

111
test-suite/tests/hooks.test
View file

@ -40,51 +40,32 @@
;;;; whether to permit this exception to apply to your modifications. ;;;; whether to permit this exception to apply to your modifications.
;;;; If you do not wish that, delete this exception notice. ;;;; If you do not wish that, delete this exception notice.
;;; {Description}
;;; ;;;
;;; A test suite for hooks. I maybe should've split off some of the ;;; miscellaneous
;;; stuff (like with alists), but this is small enough that it ;;;
;;; probably isn't worth the hassle. A little note: in some places it
;;; catches all errors when it probably shouldn't, since there's only
;;; one error we consider correct. This is mostly because the
;;; add-hook! error in released guiles isn't really accurate
;;; This should be changed once a released version returns
;;; wrong-type-arg from add-hook!
;; {Utility stuff} ;; FIXME: Maybe a standard wrong-num-arg exception should be thrown instead
;; Evaluate form inside a catch; if it throws an error, return true ;; of a misc-error? If so, the tests should be changed to expect failure.
;; This is good for checking that errors are not ignored (define exception:wrong-num-hook-args
(cons 'misc-error "Hook .* requires .* arguments"))
(define-macro (catch-error-returning-true error . form) ;;;
`(catch ,error (lambda () (begin ,@form #f)) (lambda (key . args) #t))) ;;; {The tests}
;;;
;; Evaluate form inside a catch; if it throws an error, return false (let ((proc1 (lambda (x) (+ x 1)))
;; Good for making sure that errors don't occur
(define-macro (catch-error-returning-false error . form)
`(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f)))
;; pass-if-not: syntactic sugar
(define-macro (pass-if-not string form)
`(pass-if ,string (not ,form)))
;; {The tests}
(let ((proc1 (lambda (x) (+ x 1)))
(proc2 (lambda (x) (- x 1))) (proc2 (lambda (x) (- x 1)))
(bad-proc (lambda (x y) #t))) (bad-proc (lambda (x y) #t)))
(with-test-prefix "hooks" (with-test-prefix "hooks"
(pass-if "make-hook" (pass-if "make-hook"
(catch-error-returning-false (make-hook 1)
#t #t)
(define x (make-hook 1))))
(pass-if "add-hook!" (pass-if "add-hook!"
(catch-error-returning-false (let ((x (make-hook 1)))
#t (add-hook! x proc1)
(let ((x (make-hook 1))) (add-hook! x proc2)
(add-hook! x proc1) #t))
(add-hook! x proc2))))
(with-test-prefix "add-hook!" (with-test-prefix "add-hook!"
(pass-if "append" (pass-if "append"
@ -93,34 +74,30 @@
(add-hook! x proc2 #t) (add-hook! x proc2 #t)
(eq? (cadr (hook->list x)) (eq? (cadr (hook->list x))
proc2))) proc2)))
(pass-if "illegal proc" (pass-if-exception "illegal proc"
(catch-error-returning-true exception:wrong-type-arg
#t (let ((x (make-hook 1)))
(let ((x (make-hook 1))) (add-hook! x bad-proc)))
(add-hook! x bad-proc)))) (pass-if-exception "illegal hook"
(pass-if "illegal hook" exception:wrong-type-arg
(catch-error-returning-true (add-hook! '(foo) proc1)))
'wrong-type-arg
(add-hook! '(foo) proc1))))
(pass-if "run-hook" (pass-if "run-hook"
(let ((x (make-hook 1))) (let ((x (make-hook 1)))
(catch-error-returning-false #t (add-hook! x proc1)
(add-hook! x proc1) (add-hook! x proc2)
(add-hook! x proc2) (run-hook x 1)
(run-hook x 1)))) #t))
(with-test-prefix "run-hook" (with-test-prefix "run-hook"
(pass-if "bad hook" (pass-if-exception "bad hook"
(catch-error-returning-true exception:wrong-type-arg
#t (let ((x (cons 'a 'b)))
(let ((x (cons 'a 'b))) (run-hook x 1)))
(run-hook x 1)))) (pass-if-exception "too many args"
(pass-if "too many args" exception:wrong-num-hook-args
(let ((x (make-hook 1))) (let ((x (make-hook 1)))
(catch-error-returning-true (add-hook! x proc1)
#t (add-hook! x proc2)
(add-hook! x proc1) (run-hook x 1 2)))
(add-hook! x proc2)
(run-hook x 1 2))))
(pass-if (pass-if
"destructive procs" "destructive procs"
@ -146,10 +123,9 @@
; Maybe it should error, but this is probably ; Maybe it should error, but this is probably
; more convienient ; more convienient
(pass-if "empty hook" (pass-if "empty hook"
(catch-error-returning-false (let ((x (make-hook 1)))
#t (remove-hook! x proc1)
(let ((x (make-hook 1))) #t)))
(remove-hook! x proc1)))))
(pass-if "hook->list" (pass-if "hook->list"
(let ((x (make-hook 1))) (let ((x (make-hook 1)))
(add-hook! x proc1) (add-hook! x proc1)
@ -168,7 +144,6 @@
(let ((x (make-hook 1))) (let ((x (make-hook 1)))
(reset-hook! x) (reset-hook! x)
#t)) #t))
(pass-if "bad hook" (pass-if-exception "bad hook"
(catch-error-returning-true exception:wrong-type-arg
#t (reset-hook! '(a b))))))
(reset-hook! '(a b)))))))

180
test-suite/tests/list.test
View file

@ -375,29 +375,17 @@
(with-test-prefix "wrong argument" (with-test-prefix "wrong argument"
(expect-fail "improper list and empty list" (expect-fail-exception "improper list and empty list"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (append! (cons 1 2) '()))
(append! (cons 1 2) '())
#f)
(lambda (key . args)
#t)))
(expect-fail "improper list and list" (expect-fail-exception "improper list and list"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (append! (cons 1 2) (list 3 4)))
(append! (cons 1 2) (list 3 4))
#f)
(lambda (key . args)
#t)))
(expect-fail "list, improper list and list" (expect-fail-exception "list, improper list and list"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (append! (list 1 2) (cons 3 4) (list 5 6)))
(append! (list 1 2) (cons 3 4) (list 5 6))
#f)
(lambda (key . args)
#t)))
(expect-fail "circular list and empty list" (expect-fail "circular list and empty list"
(let ((foo (list 1 2 3))) (let ((foo (list 1 2 3)))
@ -473,47 +461,27 @@
(with-test-prefix "empty list" (with-test-prefix "empty list"
(pass-if "index 0" (pass-if-exception "index 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-ref '() 0))
(list-ref '() 0)
#f)
(lambda (key . args)
#t)))
(pass-if "index > 0" (pass-if-exception "index > 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-ref '() 1))
(list-ref '() 1)
#f)
(lambda (key . args)
#t)))
(pass-if "index < 0" (pass-if-exception "index < 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-ref '() -1)))
(list-ref '() -1)
#f)
(lambda (key . args)
#t))))
(with-test-prefix "non-empty list" (with-test-prefix "non-empty list"
(pass-if "index > length" (pass-if-exception "index > length"
(catch 'out-of-range exception:out-of-range
(lambda () (list-ref '(1) 1))
(list-ref '(1) 1)
#f)
(lambda (key . args)
#t)))
(pass-if "index < 0" (pass-if-exception "index < 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-ref '(1) -1))))))
(list-ref '(1) -1)
#f)
(lambda (key . args)
#t)))))))
;;; list-set! ;;; list-set!
@ -541,47 +509,27 @@
(with-test-prefix "empty list" (with-test-prefix "empty list"
(pass-if "index 0" (pass-if-exception "index 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-set! (list) 0 #t))
(list-set! (list) 0 #t)
#f)
(lambda (key . args)
#t)))
(pass-if "index > 0" (pass-if-exception "index > 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-set! (list) 1 #t))
(list-set! (list) 1 #t)
#f)
(lambda (key . args)
#t)))
(pass-if "index < 0" (pass-if-exception "index < 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-set! (list) -1 #t)))
(list-set! (list) -1 #t)
#f)
(lambda (key . args)
#t))))
(with-test-prefix "non-empty list" (with-test-prefix "non-empty list"
(pass-if "index > length" (pass-if-exception "index > length"
(catch 'out-of-range exception:out-of-range
(lambda () (list-set! (list 1) 1 #t))
(list-set! (list 1) 1 #t)
#f)
(lambda (key . args)
#t)))
(pass-if "index < 0" (pass-if-exception "index < 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-set! (list 1) -1 #t))))))
(list-set! (list 1) -1 #t)
#f)
(lambda (key . args)
#t)))))))
;;; list-cdr-ref ;;; list-cdr-ref
@ -615,47 +563,27 @@
(with-test-prefix "empty list" (with-test-prefix "empty list"
(pass-if "index 0" (pass-if-exception "index 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-cdr-set! (list) 0 #t))
(list-cdr-set! (list) 0 #t)
#f)
(lambda (key . args)
#t)))
(pass-if "index > 0" (pass-if-exception "index > 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-cdr-set! (list) 1 #t))
(list-cdr-set! (list) 1 #t)
#f)
(lambda (key . args)
#t)))
(pass-if "index < 0" (pass-if-exception "index < 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-cdr-set! (list) -1 #t)))
(list-cdr-set! (list) -1 #t)
#f)
(lambda (key . args)
#t))))
(with-test-prefix "non-empty list" (with-test-prefix "non-empty list"
(pass-if "index > length" (pass-if-exception "index > length"
(catch 'out-of-range exception:out-of-range
(lambda () (list-cdr-set! (list 1) 1 #t))
(list-cdr-set! (list 1) 1 #t)
#f)
(lambda (key . args)
#t)))
(pass-if "index < 0" (pass-if-exception "index < 0"
(catch 'out-of-range exception:out-of-range
(lambda () (list-cdr-set! (list 1) -1 #t))))))
(list-cdr-set! (list 1) -1 #t)
#f)
(lambda (key . args)
#t)))))))
;;; list-head ;;; list-head

5
test-suite/tests/ports.test
View file

@ -427,7 +427,8 @@
(call-with-input-string "foo" (lambda (p) p)) (call-with-input-string "foo" (lambda (p) p))
(lambda () (lambda ()
(close-port (current-input-port)) (close-port (current-input-port))
(pass-if name (pass-if-exception name
(signals-error? 'wrong-type-arg (procedure)))))) exception:wrong-type-arg
(procedure)))))
(list read read-char read-line) (list read read-char read-line)
'("read" "read-char" "read-line"))) '("read" "read-char" "read-line")))

37
test-suite/tests/reader.test
View file

@ -1,25 +1,22 @@
;;;; reader.test --- test the Guile parser -*- scheme -*- ;;;; reader.test --- test the Guile parser -*- scheme -*-
;;;; Jim Blandy <jimb@red-bean.com> --- September 1999 ;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
(define (try-to-read string) (define (read-string s)
(pass-if (call-with-output-string (lambda (port) (with-input-from-string s (lambda () (read))))
(display "Try to read " port)
(write string port)))
(not (signals-error?
'signal
(call-with-input-string string
(lambda (p) (read p)))))))
(try-to-read "0") (with-test-prefix "reading"
(try-to-read "1++i") (pass-if "0"
(try-to-read "1+i+i") (equal? (read-string "0") 0))
(try-to-read "1+e10000i") (pass-if "1++i"
(equal? (read-string "1++i") '1++i))
(pass-if "1+i+i"
(equal? (read-string "1+i+i") '1+i+i))
(pass-if "1+e10000i"
(equal? (read-string "1+e10000i") '1+e10000i)))
(pass-if "radix passed to number->string can't be zero" (pass-if-exception "radix passed to number->string can't be zero"
(signals-error? exception:out-of-range
'out-of-range (number->string 10 0))
(number->string 10 0))) (pass-if-exception "radix passed to number->string can't be one either"
(pass-if "radix passed to number->string can't be one either" exception:out-of-range
(signals-error? (number->string 10 1))
'out-of-range
(number->string 10 1)))

17
test-suite/tests/strings.test
View file

@ -21,19 +21,14 @@
(use-modules (test-suite lib)) (use-modules (test-suite lib))
(pass-if "string=? does not accept symbols" (pass-if-exception "string=? does not accept symbols"
(catch 'wrong-type-arg exception:wrong-type-arg
(lambda () (string=? 'a 'b))
(string=? 'a 'b)
#f)
(lambda args
#t)))
(pass-if "string<? respects string length" (pass-if "string<? respects string length"
(not (string<? "foo\0" "foo"))) (not (string<? "foo\0" "foo")))
(pass-if "string-ci<? respects string length" (pass-if "string-ci<? respects string length"
(not (string-ci<? "foo\0" "foo"))) (not (string-ci<? "foo\0" "foo")))
(pass-if "substring-move! checks start and end correctly" (pass-if-exception "substring-move! checks start and end correctly"
(signals-error? exception:out-of-range
'out-of-range (substring-move! "sample" 3 0 "test" 3))
(substring-move! "sample" 3 0 "test" 3)))

71
test-suite/tests/weaks.test
View file

@ -58,20 +58,6 @@
;;; other reasons why they might not work as tested here, so if you ;;; other reasons why they might not work as tested here, so if you
;;; haven't done anything to weaks, don't sweat it :) ;;; haven't done anything to weaks, don't sweat it :)
;;; Utility stuff (maybe these should go in lib? They're pretty useful
;;; at keeping the code size down)
;; Evaluate form inside a catch; if it throws, return false
(define-macro (catch-error-returning-false error . form)
`(catch ,error (lambda () (begin ,@form #t)) (lambda (key . args) #f)))
(define-macro (catch-error-returning-true error . form)
`(catch ,error (lambda () (begin ,@form #f)) (lambda args #t)))
(define-macro (pass-if-not string form)
`(pass-if ,string (not ,form)))
;;; Creation functions ;;; Creation functions
@ -79,12 +65,11 @@
"weak-creation" "weak-creation"
(with-test-prefix "make-weak-vector" (with-test-prefix "make-weak-vector"
(pass-if "normal" (pass-if "normal"
(catch-error-returning-false #t (make-weak-vector 10 #f)
(define x (make-weak-vector 10 #f)))) #t)
(pass-if "bad size" (pass-if-exception "bad size"
(catch-error-returning-true exception:wrong-type-arg
'wrong-type-arg (make-weak-vector 'foo)))
(define x (make-weak-vector 'foo)))))
(with-test-prefix "list->weak-vector" (with-test-prefix "list->weak-vector"
(pass-if "create" (pass-if "create"
@ -97,42 +82,32 @@
(eq? (vector-ref wv 4) 'e) (eq? (vector-ref wv 4) 'e)
(eq? (vector-ref wv 5) 'f) (eq? (vector-ref wv 5) 'f)
(eq? (vector-ref wv 6) 'g)))) (eq? (vector-ref wv 6) 'g))))
(pass-if "bad-args" (pass-if-exception "bad-args"
(catch-error-returning-true exception:wrong-type-arg
'wrong-type-arg (list->weak-vector 32)))
(define x (list->weak-vector 32)))))
(with-test-prefix "make-weak-key-hash-table" (with-test-prefix "make-weak-key-hash-table"
(pass-if "create" (pass-if "create"
(catch-error-returning-false (make-weak-key-hash-table 17)
#t #t)
(define x (make-weak-key-hash-table 17)))) (pass-if-exception "bad-args"
(pass-if "bad-args" exception:wrong-type-arg
(catch-error-returning-true (make-weak-key-hash-table '(bad arg))))
'wrong-type-arg
(define x
(make-weak-key-hash-table '(bad arg))))))
(with-test-prefix "make-weak-value-hash-table" (with-test-prefix "make-weak-value-hash-table"
(pass-if "create" (pass-if "create"
(catch-error-returning-false (make-weak-value-hash-table 17)
#t #t)
(define x (make-weak-value-hash-table 17)))) (pass-if-exception "bad-args"
(pass-if "bad-args" exception:wrong-type-arg
(catch-error-returning-true (make-weak-value-hash-table '(bad arg))))
'wrong-type-arg
(define x
(make-weak-value-hash-table '(bad arg))))))
(with-test-prefix "make-doubly-weak-hash-table" (with-test-prefix "make-doubly-weak-hash-table"
(pass-if "create" (pass-if "create"
(catch-error-returning-false (make-doubly-weak-hash-table 17)
#t #t)
(define x (make-doubly-weak-hash-table 17)))) (pass-if-exception "bad-args"
(pass-if "bad-args" exception:wrong-type-arg
(catch-error-returning-true (make-doubly-weak-hash-table '(bad arg)))))
'wrong-type-arg
(define x
(make-doubly-weak-hash-table '(bad arg)))))))