;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
-(define-module (test-suite lib))
+(define-module (test-suite lib)
+ :use-module (ice-9 regex))
(export
+ ;; Exceptions which are commonly being tested for.
+ exception:out-of-range exception:wrong-type-arg
+
;; 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.
with-test-prefix with-test-prefix* current-test-prefix
;;;; environment. All other exceptions thrown by THUNK are considered as
;;;; 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
;;;; (run-test name #t (lambda () body))
;;;; * (expect-fail name body) is a short form for
;;;; For example:
;;;;
;;;; (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.
\f
;;;; TEST NAMES
;;;; 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.
(define (display-line . objs)
(for-each display objs)
(defmacro expect-fail (name 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)))
+
\f
;;;; TEST NAMES
;;;;
(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))))
;;; miscellaneous
;;;
+(define exception:unbound-symbol
+ (cons 'misc-error "^Symbol .* not bound in environment"))
(define (documented? object)
(not (not (object-documentation object))))
(environment-define env 'a #f)
(not (eq? (environment-cell env 'a #t) cell)))))
- (pass-if "reference an undefined symbol"
- (catch #t
- (lambda ()
- (environment-ref (make-leaf-environment) 'a)
- #f)
- (lambda args
- #t)))
-
- (pass-if "set! an undefined symbol"
- (catch #t
- (lambda ()
- (environment-set! (make-leaf-environment) 'a)
- #f)
- (lambda args
- #t)))
-
- (pass-if "get a readable cell for an undefined symbol"
- (catch #t
- (lambda ()
- (environment-cell (make-leaf-environment) 'a #f)
- #f)
- (lambda args
- #t)))
-
- (pass-if "get a writable cell for an undefined symbol"
- (catch #t
- (lambda ()
- (environment-cell (make-leaf-environment) 'a #t)
- #f)
- (lambda args
- #t))))
+ (pass-if-exception "reference an unbound symbol"
+ exception:unbound-symbol
+ (environment-ref (make-leaf-environment) 'a))
+
+ (pass-if-exception "set! an unbound symbol"
+ exception:unbound-symbol
+ (environment-set! (make-leaf-environment) 'a #f))
+
+ (pass-if-exception "get a readable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell (make-leaf-environment) 'a #f))
+
+ (pass-if-exception "get a writable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell (make-leaf-environment) 'a #t)))
(with-test-prefix "undefine"
(imported (make-leaf-environment))
(env (make-eval-environment local imported)))
- (pass-if "reference an undefined symbol"
- (catch #t
- (lambda ()
- (environment-ref env 'b)
- #f)
- (lambda args
- #t)))
+ (pass-if-exception "reference an unbound symbol"
+ exception:unbound-symbol
+ (environment-ref env 'b))
- (pass-if "set! an undefined symbol"
- (catch #t
- (lambda ()
- (environment-set! env 'b)
- #f)
- (lambda args
- #t)))
+ (pass-if-exception "set! an unbound symbol"
+ exception:unbound-symbol
+ (environment-set! env 'b #f))
- (pass-if "get a readable cell for an undefined symbol"
- (catch #t
- (lambda ()
- (environment-cell env 'b #f)
- #f)
- (lambda args
- #t)))
+ (pass-if-exception "get a readable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell env 'b #f))
- (pass-if "get a writable cell for an undefined symbol"
- (catch #t
- (lambda ()
- (environment-cell env 'b #t)
- #f)
- (lambda args
- #t)))))
+ (pass-if-exception "get a writable cell for an unbound symbol"
+ exception:unbound-symbol
+ (environment-cell env 'b #t))))
(with-test-prefix "eval-environment-set-local!"
;;; miscellaneous
;;;
-
(define (documented? object)
(not (not (object-documentation object))))
;; Macros are accepted as function parameters.
;; Functions that 'apply' macros are rewritten!!!
- (expect-fail "macro as argument"
- (let ((f (lambda (p a b) (p a b))))
- (catch 'wrong-type-arg
- (lambda ()
- (f and #t #t)
- #f)
- (lambda (key . args)
- #t))))
-
- (expect-fail "application of macro"
+ (expect-fail-exception "macro as argument"
+ exception:wrong-type-arg
(let ((f (lambda (p a b) (p a b))))
- (catch 'wrong-type-arg
- (lambda ()
- (let ((foo (procedure-source f)))
- (f and #t #t)
- (equal? (procedure-source f) foo)))
- (lambda (key . args)
- #t))))
+ (f and #t #t)))
+
+ (expect-fail-exception "passing macro as parameter"
+ exception:wrong-type-arg
+ (let* ((f (lambda (p a b) (p a b)))
+ (foo (procedure-source f)))
+ (f and #t #t)
+ (equal? (procedure-source f) foo)))
))
(with-test-prefix "different length lists"
- (pass-if "first list empty"
- (catch 'out-of-range
- (lambda ()
- (map + '() '(1))
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "second list empty"
- (catch 'out-of-range
- (lambda ()
- (map + '(1) '())
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "first list shorter"
- (catch 'out-of-range
- (lambda ()
- (map + '(1) '(2 3))
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "second list shorter"
- (catch 'out-of-range
- (lambda ()
- (map + '(1 2) '(3))
- #f)
- (lambda (key . args)
- #t)))
+ (pass-if-exception "first list empty"
+ exception:out-of-range
+ (map + '() '(1)))
+
+ (pass-if-exception "second list empty"
+ exception:out-of-range
+ (map + '(1) '()))
+
+ (pass-if-exception "first list shorter"
+ exception:out-of-range
+ (map + '(1) '(2 3)))
+
+ (pass-if-exception "second list shorter"
+ exception:out-of-range
+ (map + '(1 2) '(3)))
)))
;;;; whether to permit this exception to apply to your modifications.
;;;; 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
-;;; 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}
-;; Evaluate form inside a catch; if it throws an error, return true
-;; This is good for checking that errors are not ignored
-
-(define-macro (catch-error-returning-true error . form)
- `(catch ,error (lambda () (begin ,@form #f)) (lambda (key . args) #t)))
-
-;; Evaluate form inside a catch; if it throws an error, return false
-;; 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)))
+;;; miscellaneous
+;;;
-;; pass-if-not: syntactic sugar
+;; FIXME: Maybe a standard wrong-num-arg exception should be thrown instead
+;; of a misc-error? If so, the tests should be changed to expect failure.
+(define exception:wrong-num-hook-args
+ (cons 'misc-error "Hook .* requires .* arguments"))
-(define-macro (pass-if-not string form)
- `(pass-if ,string (not ,form)))
+;;;
+;;; {The tests}
+;;;
-;; {The tests}
- (let ((proc1 (lambda (x) (+ x 1)))
+(let ((proc1 (lambda (x) (+ x 1)))
(proc2 (lambda (x) (- x 1)))
(bad-proc (lambda (x y) #t)))
(with-test-prefix "hooks"
(pass-if "make-hook"
- (catch-error-returning-false
- #t
- (define x (make-hook 1))))
+ (make-hook 1)
+ #t)
(pass-if "add-hook!"
- (catch-error-returning-false
- #t
- (let ((x (make-hook 1)))
- (add-hook! x proc1)
- (add-hook! x proc2))))
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ #t))
(with-test-prefix "add-hook!"
(pass-if "append"
(add-hook! x proc2 #t)
(eq? (cadr (hook->list x))
proc2)))
- (pass-if "illegal proc"
- (catch-error-returning-true
- #t
- (let ((x (make-hook 1)))
- (add-hook! x bad-proc))))
- (pass-if "illegal hook"
- (catch-error-returning-true
- 'wrong-type-arg
- (add-hook! '(foo) proc1))))
+ (pass-if-exception "illegal proc"
+ exception:wrong-type-arg
+ (let ((x (make-hook 1)))
+ (add-hook! x bad-proc)))
+ (pass-if-exception "illegal hook"
+ exception:wrong-type-arg
+ (add-hook! '(foo) proc1)))
(pass-if "run-hook"
(let ((x (make-hook 1)))
- (catch-error-returning-false #t
- (add-hook! x proc1)
- (add-hook! x proc2)
- (run-hook x 1))))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ (run-hook x 1)
+ #t))
(with-test-prefix "run-hook"
- (pass-if "bad hook"
- (catch-error-returning-true
- #t
- (let ((x (cons 'a 'b)))
- (run-hook x 1))))
- (pass-if "too many args"
- (let ((x (make-hook 1)))
- (catch-error-returning-true
- #t
- (add-hook! x proc1)
- (add-hook! x proc2)
- (run-hook x 1 2))))
+ (pass-if-exception "bad hook"
+ exception:wrong-type-arg
+ (let ((x (cons 'a 'b)))
+ (run-hook x 1)))
+ (pass-if-exception "too many args"
+ exception:wrong-num-hook-args
+ (let ((x (make-hook 1)))
+ (add-hook! x proc1)
+ (add-hook! x proc2)
+ (run-hook x 1 2)))
(pass-if
"destructive procs"
; Maybe it should error, but this is probably
; more convienient
(pass-if "empty hook"
- (catch-error-returning-false
- #t
- (let ((x (make-hook 1)))
- (remove-hook! x proc1)))))
+ (let ((x (make-hook 1)))
+ (remove-hook! x proc1)
+ #t)))
(pass-if "hook->list"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(let ((x (make-hook 1)))
(reset-hook! x)
#t))
- (pass-if "bad hook"
- (catch-error-returning-true
- #t
- (reset-hook! '(a b)))))))
+ (pass-if-exception "bad hook"
+ exception:wrong-type-arg
+ (reset-hook! '(a b))))))
(with-test-prefix "wrong argument"
- (expect-fail "improper list and empty list"
- (catch 'wrong-type-arg
- (lambda ()
- (append! (cons 1 2) '())
- #f)
- (lambda (key . args)
- #t)))
-
- (expect-fail "improper list and list"
- (catch 'wrong-type-arg
- (lambda ()
- (append! (cons 1 2) (list 3 4))
- #f)
- (lambda (key . args)
- #t)))
-
- (expect-fail "list, improper list and list"
- (catch 'wrong-type-arg
- (lambda ()
- (append! (list 1 2) (cons 3 4) (list 5 6))
- #f)
- (lambda (key . args)
- #t)))
+ (expect-fail-exception "improper list and empty list"
+ exception:wrong-type-arg
+ (append! (cons 1 2) '()))
+
+ (expect-fail-exception "improper list and list"
+ exception:wrong-type-arg
+ (append! (cons 1 2) (list 3 4)))
+
+ (expect-fail-exception "list, improper list and list"
+ exception:wrong-type-arg
+ (append! (list 1 2) (cons 3 4) (list 5 6)))
(expect-fail "circular list and empty list"
(let ((foo (list 1 2 3)))
(with-test-prefix "empty list"
- (pass-if "index 0"
- (catch 'out-of-range
- (lambda ()
- (list-ref '() 0)
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "index > 0"
- (catch 'out-of-range
- (lambda ()
- (list-ref '() 1)
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "index < 0"
- (catch 'out-of-range
- (lambda ()
- (list-ref '() -1)
- #f)
- (lambda (key . args)
- #t))))
+ (pass-if-exception "index 0"
+ exception:out-of-range
+ (list-ref '() 0))
+
+ (pass-if-exception "index > 0"
+ exception:out-of-range
+ (list-ref '() 1))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-ref '() -1)))
(with-test-prefix "non-empty list"
- (pass-if "index > length"
- (catch 'out-of-range
- (lambda ()
- (list-ref '(1) 1)
- #f)
- (lambda (key . args)
- #t)))
+ (pass-if-exception "index > length"
+ exception:out-of-range
+ (list-ref '(1) 1))
- (pass-if "index < 0"
- (catch 'out-of-range
- (lambda ()
- (list-ref '(1) -1)
- #f)
- (lambda (key . args)
- #t)))))))
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-ref '(1) -1))))))
;;; list-set!
(with-test-prefix "empty list"
- (pass-if "index 0"
- (catch 'out-of-range
- (lambda ()
- (list-set! (list) 0 #t)
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "index > 0"
- (catch 'out-of-range
- (lambda ()
- (list-set! (list) 1 #t)
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "index < 0"
- (catch 'out-of-range
- (lambda ()
- (list-set! (list) -1 #t)
- #f)
- (lambda (key . args)
- #t))))
+ (pass-if-exception "index 0"
+ exception:out-of-range
+ (list-set! (list) 0 #t))
+
+ (pass-if-exception "index > 0"
+ exception:out-of-range
+ (list-set! (list) 1 #t))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-set! (list) -1 #t)))
(with-test-prefix "non-empty list"
- (pass-if "index > length"
- (catch 'out-of-range
- (lambda ()
- (list-set! (list 1) 1 #t)
- #f)
- (lambda (key . args)
- #t)))
+ (pass-if-exception "index > length"
+ exception:out-of-range
+ (list-set! (list 1) 1 #t))
- (pass-if "index < 0"
- (catch 'out-of-range
- (lambda ()
- (list-set! (list 1) -1 #t)
- #f)
- (lambda (key . args)
- #t)))))))
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-set! (list 1) -1 #t))))))
;;; list-cdr-ref
(with-test-prefix "empty list"
- (pass-if "index 0"
- (catch 'out-of-range
- (lambda ()
- (list-cdr-set! (list) 0 #t)
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "index > 0"
- (catch 'out-of-range
- (lambda ()
- (list-cdr-set! (list) 1 #t)
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "index < 0"
- (catch 'out-of-range
- (lambda ()
- (list-cdr-set! (list) -1 #t)
- #f)
- (lambda (key . args)
- #t))))
+ (pass-if-exception "index 0"
+ exception:out-of-range
+ (list-cdr-set! (list) 0 #t))
+
+ (pass-if-exception "index > 0"
+ exception:out-of-range
+ (list-cdr-set! (list) 1 #t))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-cdr-set! (list) -1 #t)))
(with-test-prefix "non-empty list"
- (pass-if "index > length"
- (catch 'out-of-range
- (lambda ()
- (list-cdr-set! (list 1) 1 #t)
- #f)
- (lambda (key . args)
- #t)))
-
- (pass-if "index < 0"
- (catch 'out-of-range
- (lambda ()
- (list-cdr-set! (list 1) -1 #t)
- #f)
- (lambda (key . args)
- #t)))))))
+ (pass-if-exception "index > length"
+ exception:out-of-range
+ (list-cdr-set! (list 1) 1 #t))
+
+ (pass-if-exception "index < 0"
+ exception:out-of-range
+ (list-cdr-set! (list 1) -1 #t))))))
;;; list-head
(call-with-input-string "foo" (lambda (p) p))
(lambda ()
(close-port (current-input-port))
- (pass-if name
- (signals-error? 'wrong-type-arg (procedure))))))
+ (pass-if-exception name
+ exception:wrong-type-arg
+ (procedure)))))
(list read read-char read-line)
'("read" "read-char" "read-line")))
-;;;; reader.test --- test the Guile parser -*- scheme -*-
-;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
-
-(define (try-to-read string)
- (pass-if (call-with-output-string (lambda (port)
- (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")
-(try-to-read "1++i")
-(try-to-read "1+i+i")
-(try-to-read "1+e10000i")
-
-(pass-if "radix passed to number->string can't be zero"
- (signals-error?
- 'out-of-range
- (number->string 10 0)))
-(pass-if "radix passed to number->string can't be one either"
- (signals-error?
- 'out-of-range
- (number->string 10 1)))
+;;;; reader.test --- test the Guile parser -*- scheme -*-
+;;;; Jim Blandy <jimb@red-bean.com> --- September 1999
+
+(define (read-string s)
+ (with-input-from-string s (lambda () (read))))
+
+(with-test-prefix "reading"
+ (pass-if "0"
+ (equal? (read-string "0") 0))
+ (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-exception "radix passed to number->string can't be zero"
+ exception:out-of-range
+ (number->string 10 0))
+(pass-if-exception "radix passed to number->string can't be one either"
+ exception:out-of-range
+ (number->string 10 1))
(use-modules (test-suite lib))
-(pass-if "string=? does not accept symbols"
- (catch 'wrong-type-arg
- (lambda ()
- (string=? 'a 'b)
- #f)
- (lambda args
- #t)))
+(pass-if-exception "string=? does not accept symbols"
+ exception:wrong-type-arg
+ (string=? 'a 'b))
(pass-if "string<? respects string length"
(not (string<? "foo\0" "foo")))
(pass-if "string-ci<? respects string length"
(not (string-ci<? "foo\0" "foo")))
-(pass-if "substring-move! checks start and end correctly"
- (signals-error?
- 'out-of-range
- (substring-move! "sample" 3 0 "test" 3)))
+(pass-if-exception "substring-move! checks start and end correctly"
+ exception:out-of-range
+ (substring-move! "sample" 3 0 "test" 3))
;;; other reasons why they might not work as tested here, so if you
;;; 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
"weak-creation"
(with-test-prefix "make-weak-vector"
(pass-if "normal"
- (catch-error-returning-false #t
- (define x (make-weak-vector 10 #f))))
- (pass-if "bad size"
- (catch-error-returning-true
- 'wrong-type-arg
- (define x (make-weak-vector 'foo)))))
+ (make-weak-vector 10 #f)
+ #t)
+ (pass-if-exception "bad size"
+ exception:wrong-type-arg
+ (make-weak-vector 'foo)))
(with-test-prefix "list->weak-vector"
(pass-if "create"
(eq? (vector-ref wv 4) 'e)
(eq? (vector-ref wv 5) 'f)
(eq? (vector-ref wv 6) 'g))))
- (pass-if "bad-args"
- (catch-error-returning-true
- 'wrong-type-arg
- (define x (list->weak-vector 32)))))
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (list->weak-vector 32)))
(with-test-prefix "make-weak-key-hash-table"
(pass-if "create"
- (catch-error-returning-false
- #t
- (define x (make-weak-key-hash-table 17))))
- (pass-if "bad-args"
- (catch-error-returning-true
- 'wrong-type-arg
- (define x
- (make-weak-key-hash-table '(bad arg))))))
+ (make-weak-key-hash-table 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-weak-key-hash-table '(bad arg))))
(with-test-prefix "make-weak-value-hash-table"
(pass-if "create"
- (catch-error-returning-false
- #t
- (define x (make-weak-value-hash-table 17))))
- (pass-if "bad-args"
- (catch-error-returning-true
- 'wrong-type-arg
- (define x
- (make-weak-value-hash-table '(bad arg))))))
+ (make-weak-value-hash-table 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-weak-value-hash-table '(bad arg))))
(with-test-prefix "make-doubly-weak-hash-table"
(pass-if "create"
- (catch-error-returning-false
- #t
- (define x (make-doubly-weak-hash-table 17))))
- (pass-if "bad-args"
- (catch-error-returning-true
- 'wrong-type-arg
- (define x
- (make-doubly-weak-hash-table '(bad arg)))))))
+ (make-doubly-weak-hash-table 17)
+ #t)
+ (pass-if-exception "bad-args"
+ exception:wrong-type-arg
+ (make-doubly-weak-hash-table '(bad arg)))))
HCoop / bpt / guile.git / commitdiff