mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
* Provide and use new convenience macros to test for exceptions.
This commit is contained in:
Dirk Herrmann
parent
9d372117f6
commit
6b4113afc5
10 changed files with 292 additions and 472 deletions
|
|
@ -16,12 +16,18 @@
|
|||
;;;; 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
|
||||
|
|
@ -67,7 +73,9 @@
|
|||
;;;; 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
|
||||
|
|
@ -76,7 +84,24 @@
|
|||
;;;; 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.
|
||||
|
||||
|
||||
;;;; TEST NAMES
|
||||
|
|
@ -194,6 +219,12 @@
|
|||
;;;; 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)
|
||||
|
|
@ -247,6 +278,25 @@
|
|||
(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)))
|
||||
|
||||
|
||||
;;;; TEST NAMES
|
||||
;;;;
|
||||
|
|
|
|||
|
|
@ -104,25 +104,18 @@
|
|||
(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"
|
||||
|
|
@ -130,13 +123,9 @@
|
|||
(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)))
|
||||
|
||||
|
||||
|
|
@ -168,32 +157,20 @@
|
|||
|
||||
(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-exception "assv-ref deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assv-ref deformed 'sloppy))
|
||||
|
||||
(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-exception "assoc-ref deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assoc-ref deformed 'sloppy))
|
||||
|
||||
(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 "assq-ref deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assq-ref deformed 'sloppy))))
|
||||
|
||||
|
||||
;;; Setters
|
||||
|
|
@ -241,32 +218,20 @@
|
|||
|
||||
(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-exception "assq-set! deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assq-set! deformed 'cold '(very cold)))
|
||||
|
||||
(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-exception "assv-set! deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assv-set! deformed 'canada 'Canada))
|
||||
|
||||
(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 "assoc-set! deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assv-ref?) (throw 'unsupported))
|
||||
(assoc-set! deformed 'canada '(Iceland hence the name)))))
|
||||
|
||||
;;; Removers
|
||||
|
||||
|
|
@ -288,29 +253,17 @@
|
|||
|
||||
(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-exception "assq-remove! deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assq-remove?) (throw 'unsupported))
|
||||
(assq-remove! deformed 'puddle))
|
||||
|
||||
(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-exception "assv-remove! deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assq-remove?) (throw 'unsupported))
|
||||
(assv-remove! deformed 'splashing))
|
||||
|
||||
(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 "assoc-remove! deformed"
|
||||
exception:wrong-type-arg
|
||||
(if (not have-sloppy-assq-remove?) (throw 'unsupported))
|
||||
(assoc-remove! deformed 'fun))))
|
||||
|
|
|
|||
|
|
@ -47,6 +47,8 @@
|
|||
;;; miscellaneous
|
||||
;;;
|
||||
|
||||
(define exception:unbound-symbol
|
||||
(cons 'misc-error "^Symbol .* not bound in environment"))
|
||||
|
||||
(define (documented? object)
|
||||
(not (not (object-documentation object))))
|
||||
|
|
@ -173,37 +175,21 @@
|
|||
(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-exception "reference an unbound symbol"
|
||||
exception:unbound-symbol
|
||||
(environment-ref (make-leaf-environment) 'a))
|
||||
|
||||
(pass-if "set! an undefined symbol"
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(environment-set! (make-leaf-environment) 'a)
|
||||
#f)
|
||||
(lambda args
|
||||
#t)))
|
||||
(pass-if-exception "set! an unbound symbol"
|
||||
exception:unbound-symbol
|
||||
(environment-set! (make-leaf-environment) 'a #f))
|
||||
|
||||
(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-exception "get a readable cell for an unbound symbol"
|
||||
exception:unbound-symbol
|
||||
(environment-cell (make-leaf-environment) 'a #f))
|
||||
|
||||
(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 "get a writable cell for an unbound symbol"
|
||||
exception:unbound-symbol
|
||||
(environment-cell (make-leaf-environment) 'a #t)))
|
||||
|
||||
|
||||
(with-test-prefix "undefine"
|
||||
|
|
@ -621,37 +607,21 @@
|
|||
(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!"
|
||||
|
||||
|
|
|
|||
|
|
@ -47,7 +47,6 @@
|
|||
;;; miscellaneous
|
||||
;;;
|
||||
|
||||
|
||||
(define (documented? object)
|
||||
(not (not (object-documentation object))))
|
||||
|
||||
|
|
@ -64,24 +63,17 @@
|
|||
;; Macros are accepted as function parameters.
|
||||
;; 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))))
|
||||
(catch 'wrong-type-arg
|
||||
(lambda ()
|
||||
(f and #t #t)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t))))
|
||||
(f and #t #t)))
|
||||
|
||||
(expect-fail "application of macro"
|
||||
(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))))
|
||||
(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)))
|
||||
|
||||
))
|
||||
|
||||
|
|
@ -103,35 +95,19 @@
|
|||
|
||||
(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-exception "first list empty"
|
||||
exception:out-of-range
|
||||
(map + '() '(1)))
|
||||
|
||||
(pass-if "second list empty"
|
||||
(catch 'out-of-range
|
||||
(lambda ()
|
||||
(map + '(1) '())
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-exception "second list empty"
|
||||
exception:out-of-range
|
||||
(map + '(1) '()))
|
||||
|
||||
(pass-if "first list shorter"
|
||||
(catch 'out-of-range
|
||||
(lambda ()
|
||||
(map + '(1) '(2 3))
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-exception "first list shorter"
|
||||
exception:out-of-range
|
||||
(map + '(1) '(2 3)))
|
||||
|
||||
(pass-if "second list shorter"
|
||||
(catch 'out-of-range
|
||||
(lambda ()
|
||||
(map + '(1 2) '(3))
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-exception "second list shorter"
|
||||
exception:out-of-range
|
||||
(map + '(1 2) '(3)))
|
||||
)))
|
||||
|
|
|
|||
|
|
@ -40,51 +40,32 @@
|
|||
;;;; 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!
|
||||
;;; miscellaneous
|
||||
;;;
|
||||
|
||||
;; {Utility stuff}
|
||||
;; Evaluate form inside a catch; if it throws an error, return true
|
||||
;; This is good for checking that errors are not ignored
|
||||
;; 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 (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
|
||||
;; 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)))
|
||||
(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"
|
||||
|
|
@ -93,34 +74,30 @@
|
|||
(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"
|
||||
|
|
@ -146,10 +123,9 @@
|
|||
; 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)
|
||||
|
|
@ -168,7 +144,6 @@
|
|||
(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))))))
|
||||
|
|
|
|||
|
|
@ -375,29 +375,17 @@
|
|||
|
||||
(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-exception "improper list and empty list"
|
||||
exception:wrong-type-arg
|
||||
(append! (cons 1 2) '()))
|
||||
|
||||
(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-exception "improper list and list"
|
||||
exception:wrong-type-arg
|
||||
(append! (cons 1 2) (list 3 4)))
|
||||
|
||||
(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 "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)))
|
||||
|
|
@ -473,47 +461,27 @@
|
|||
|
||||
(with-test-prefix "empty list"
|
||||
|
||||
(pass-if "index 0"
|
||||
(catch 'out-of-range
|
||||
(lambda ()
|
||||
(list-ref '() 0)
|
||||
#f)
|
||||
(lambda (key . args)
|
||||
#t)))
|
||||
(pass-if-exception "index 0"
|
||||
exception:out-of-range
|
||||
(list-ref '() 0))
|
||||
|
||||
(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 '() 1))
|
||||
|
||||
(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 '() -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!
|
||||
|
|
@ -541,47 +509,27 @@
|
|||
|
||||
(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-exception "index 0"
|
||||
exception:out-of-range
|
||||
(list-set! (list) 0 #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) 1 #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) -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
|
||||
|
|
@ -615,47 +563,27 @@
|
|||
|
||||
(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-exception "index 0"
|
||||
exception:out-of-range
|
||||
(list-cdr-set! (list) 0 #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) 1 #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) -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-exception "index > length"
|
||||
exception:out-of-range
|
||||
(list-cdr-set! (list 1) 1 #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 < 0"
|
||||
exception:out-of-range
|
||||
(list-cdr-set! (list 1) -1 #t))))))
|
||||
|
||||
|
||||
;;; list-head
|
||||
|
|
|
|||
|
|
@ -427,7 +427,8 @@
|
|||
(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")))
|
||||
|
|
|
|||
|
|
@ -1,25 +1,22 @@
|
|||
;;;; 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)))))))
|
||||
(define (read-string s)
|
||||
(with-input-from-string s (lambda () (read))))
|
||||
|
||||
(try-to-read "0")
|
||||
(try-to-read "1++i")
|
||||
(try-to-read "1+i+i")
|
||||
(try-to-read "1+e10000i")
|
||||
(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 "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)))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -21,19 +21,14 @@
|
|||
(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))
|
||||
|
|
|
|||
|
|
@ -58,20 +58,6 @@
|
|||
;;; 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
|
||||
|
||||
|
||||
|
|
@ -79,12 +65,11 @@
|
|||
"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"
|
||||
|
|
@ -97,42 +82,32 @@
|
|||
(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)))))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue