1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
;;;; hooks.test --- tests guile's hooks implementation -*- scheme -*-
;;;; Copyright (C) 1999, 2001, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; 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 3 of the License, or (at your option) any later version.
;;;;
;;;; 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
;;;; Lesser General Public License for more details.
;;;;
;;;; 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
(define-module (test-suite test-hooks)
#:use-module (test-suite lib))
;;;
;;; miscellaneous
;;;
;; 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"))
;;;
;;; {The tests}
;;;
(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"
(make-hook 1)
#t)
(pass-if "add-hook!"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
#t))
(with-test-prefix "add-hook!"
(pass-if "append"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2 #t)
(eq? (cadr (hook->list x))
proc2)))
(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)))
(add-hook! x proc1)
(add-hook! x proc2)
(run-hook x 1)
#t))
(with-test-prefix "run-hook"
(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"
(let ((x (make-hook 1))
(dest-proc1 (lambda (x)
(set-car! x
'i-sunk-your-battleship)))
(dest-proc2 (lambda (x) (set-cdr! x 'no-way!)))
(val '(a-game-of battleship)))
(add-hook! x dest-proc1)
(add-hook! x dest-proc2 #t)
(run-hook x val)
(and (eq? (car val) 'i-sunk-your-battleship)
(eq? (cdr val) 'no-way!)))))
(with-test-prefix "remove-hook!"
(pass-if ""
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(remove-hook! x proc1)
(not (memq proc1 (hook->list x)))))
; Maybe it should error, but this is probably
; more convienient
(pass-if "empty hook"
(let ((x (make-hook 1)))
(remove-hook! x proc1)
#t)))
(pass-if "hook->list"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(and (memq proc1 (hook->list x))
(memq proc2 (hook->list x))
#t)))
(pass-if "reset-hook!"
(let ((x (make-hook 1)))
(add-hook! x proc1)
(add-hook! x proc2)
(reset-hook! x)
(null? (hook->list x))))
(with-test-prefix "reset-hook!"
(pass-if "empty hook"
(let ((x (make-hook 1)))
(reset-hook! x)
#t))
(pass-if-exception "bad hook"
exception:wrong-type-arg
(reset-hook! '(a b))))))
|
