Mercurial > hg > xemacs-beta

comparison tests/automated/symbol-tests.el @ 4855:189fb67ca31a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Create Assert-eq, Assert-equal, etc. These are equivalent to (Assert (eq ...)) but display both the actual value and the expected value of the comparison. Use them throughout the test suite.
author Ben Wing <ben@xemacs.org>
date Thu, 14 Jan 2010 02:18:03 -0600
parents 3906442b491b
children 0f66906b6e37
comparison
equal deleted inserted replaced
4854:95c4ced5c07c 4855:189fb67ca31a
61 "!@#$%^^&*(()__")) 61 "!@#$%^^&*(()__"))
62 (let ((interned (intern name)) 62 (let ((interned (intern name))
63 (uninterned (make-symbol name))) 63 (uninterned (make-symbol name)))
64 (Assert (symbolp interned)) 64 (Assert (symbolp interned))
65 (Assert (symbolp uninterned)) 65 (Assert (symbolp uninterned))
66 (Assert (equal (symbol-name interned) name)) 66 (Assert-equal (symbol-name interned) name)
67 (Assert (equal (symbol-name uninterned) name)) 67 (Assert-equal (symbol-name uninterned) name)
68 (Assert (not (eq interned uninterned))) 68 (Assert (not (eq interned uninterned)))
69 (Assert (not (equal interned uninterned))))) 69 (Assert (not (equal interned uninterned)))))
70 70
71 (flet ((check-weak-list-unique (weak-list &optional reversep) 71 (flet ((check-weak-list-unique (weak-list &optional reversep)
72 "Check that elements of WEAK-LIST are referenced only there." 72 "Check that elements of WEAK-LIST are referenced only there."
74 (if (string-match "Using the new GC algorithms." 74 (if (string-match "Using the new GC algorithms."
75 Installation-string) 75 Installation-string)
76 (Implementation-Incomplete-Expect-Failure 76 (Implementation-Incomplete-Expect-Failure
77 (Assert (not (zerop len))) 77 (Assert (not (zerop len)))
78 (garbage-collect) 78 (garbage-collect)
79 (Assert (eq (length (weak-list-list weak-list)) 79 (Assert-eq (length (weak-list-list weak-list))
80 (if (not reversep) 0 len)))) 80 (if (not reversep) 0 len)))
81 (Assert (not (zerop len))) 81 (Assert (not (zerop len)))
82 (garbage-collect) 82 (garbage-collect)
83 (Assert (eq (length (weak-list-list weak-list)) 83 (Assert-eq (length (weak-list-list weak-list))
84 (if (not reversep) 0 len))))))) 84 (if (not reversep) 0 len))))))
85 (let ((weak-list (make-weak-list)) 85 (let ((weak-list (make-weak-list))
86 (gc-cons-threshold most-positive-fixnum)) 86 (gc-cons-threshold most-positive-fixnum))
87 ;; Symbols created with `make-symbol' and `gensym' should be fresh 87 ;; Symbols created with `make-symbol' and `gensym' should be fresh
88 ;; and not referenced anywhere else. We check that no other 88 ;; and not referenced anywhere else. We check that no other
89 ;; references are available using a weak list. 89 ;; references are available using a weak list.
110 (dolist (string (mapcar #'ts-fresh-symbol-name '("foo" "bar" "\\\0\\\1"))) 110 (dolist (string (mapcar #'ts-fresh-symbol-name '("foo" "bar" "\\\0\\\1")))
111 (setq symbol (read string) 111 (setq symbol (read string)
112 string (read (concat "\"" string "\""))) 112 string (read (concat "\"" string "\"")))
113 (Assert (intern-soft string)) 113 (Assert (intern-soft string))
114 (Assert (intern-soft symbol)) 114 (Assert (intern-soft symbol))
115 (Assert (eq (intern-soft string) (intern-soft symbol)))) 115 (Assert-eq (intern-soft string) (intern-soft symbol)))
116 116
117 (let ((fresh (read (concat "#:" (ts-fresh-symbol-name "foo"))))) 117 (let ((fresh (read (concat "#:" (ts-fresh-symbol-name "foo")))))
118 (Assert (not (intern-soft fresh)))) 118 (Assert (not (intern-soft fresh))))
119 119
120 ;; Check #N=OBJECT and #N# read syntax. 120 ;; Check #N=OBJECT and #N# read syntax.
125 (bar2 (nth 3 list)) 125 (bar2 (nth 3 list))
126 (foo3 (nth 4 list)) 126 (foo3 (nth 4 list))
127 (bar3 (nth 5 list))) 127 (bar3 (nth 5 list)))
128 (Assert (symbolp foo)) 128 (Assert (symbolp foo))
129 (Assert (not (intern-soft foo))) 129 (Assert (not (intern-soft foo)))
130 (Assert (equal (symbol-name foo) "foo")) 130 (Assert-equal (symbol-name foo) "foo")
131 (Assert (symbolp bar)) 131 (Assert (symbolp bar))
132 (Assert (not (intern-soft bar))) 132 (Assert (not (intern-soft bar)))
133 (Assert (equal (symbol-name bar) "bar")) 133 (Assert-equal (symbol-name bar) "bar")
134 134
135 (Assert (eq foo foo2)) 135 (Assert-eq foo foo2)
136 (Assert (eq foo2 foo3)) 136 (Assert-eq foo2 foo3)
137 (Assert (eq bar bar2)) 137 (Assert-eq bar bar2)
138 (Assert (eq bar2 bar3))) 138 (Assert-eq bar2 bar3))
139 139
140 ;; Check #N=OBJECT and #N# print syntax. 140 ;; Check #N=OBJECT and #N# print syntax.
141 (let* ((foo (make-symbol "foo")) 141 (let* ((foo (make-symbol "foo"))
142 (bar (make-symbol "bar")) 142 (bar (make-symbol "bar"))
143 (list (list foo foo bar bar foo bar))) 143 (list (list foo foo bar bar foo bar)))
144 (let* ((print-gensym nil) 144 (let* ((print-gensym nil)
145 (printed-list (prin1-to-string list))) 145 (printed-list (prin1-to-string list)))
146 (Assert (equal printed-list "(foo foo bar bar foo bar)"))) 146 (Assert-equal printed-list "(foo foo bar bar foo bar)"))
147 (let* ((print-gensym t) 147 (let* ((print-gensym t)
148 (printed-list (prin1-to-string list))) 148 (printed-list (prin1-to-string list)))
149 (Assert (equal printed-list "(#1=#:foo #1# #2=#:bar #2# #1# #2#)")))) 149 (Assert-equal printed-list "(#1=#:foo #1# #2=#:bar #2# #1# #2#)")))
150 150
151 ;;----------------------------------------------------- 151 ;;-----------------------------------------------------
152 ;; Read-only symbols 152 ;; Read-only symbols
153 ;;----------------------------------------------------- 153 ;;-----------------------------------------------------
154 154
162 ;;----------------------------------------------------- 162 ;;-----------------------------------------------------
163 163
164 (let ((foo 0) 164 (let ((foo 0)
165 (bar 1)) 165 (bar 1))
166 (defvaralias 'foo 'bar) 166 (defvaralias 'foo 'bar)
167 (Assert (eq foo bar)) 167 (Assert-eq foo bar)
168 (Assert (eq foo 1)) 168 (Assert-eq foo 1)
169 (Assert (eq (variable-alias 'foo) 'bar)) 169 (Assert-eq (variable-alias 'foo) 'bar)
170 (defvaralias 'bar 'foo) 170 (defvaralias 'bar 'foo)
171 (Check-Error cyclic-variable-indirection 171 (Check-Error cyclic-variable-indirection
172 (symbol-value 'foo)) 172 (symbol-value 'foo))
173 (Check-Error cyclic-variable-indirection 173 (Check-Error cyclic-variable-indirection
174 (symbol-value 'bar)) 174 (symbol-value 'bar))
175 (defvaralias 'foo nil) 175 (defvaralias 'foo nil)
176 (Assert (eq foo 0)) 176 (Assert-eq foo 0)
177 (defvaralias 'bar nil) 177 (defvaralias 'bar nil)
178 (Assert (eq bar 1))) 178 (Assert-eq bar 1))
179 179
180 ;;----------------------------------------------------- 180 ;;-----------------------------------------------------
181 ;; Keywords 181 ;; Keywords
182 ;;----------------------------------------------------- 182 ;;-----------------------------------------------------
183 183
185 185
186 ;; In Elisp, a keyword is by definition a symbol beginning with `:' 186 ;; In Elisp, a keyword is by definition a symbol beginning with `:'
187 ;; that is interned in the global obarray. 187 ;; that is interned in the global obarray.
188 188
189 ;; In Elisp, a keyword is interned as any other symbol. 189 ;; In Elisp, a keyword is interned as any other symbol.
190 (Assert (eq (read ":foo") (intern ":foo"))) 190 (Assert-eq (read ":foo") (intern ":foo"))
191 191
192 ;; A keyword is self-quoting and evaluates to itself. 192 ;; A keyword is self-quoting and evaluates to itself.
193 (Assert (eq (eval (intern ":foo")) :foo)) 193 (Assert-eq (eval (intern ":foo")) :foo)
194 194
195 ;; Keywords are recognized as such only if interned in the global 195 ;; Keywords are recognized as such only if interned in the global
196 ;; obarray, and `keywordp' is aware of that. 196 ;; obarray, and `keywordp' is aware of that.
197 (Assert (keywordp :foo)) 197 (Assert (keywordp :foo))
198 (Assert (not (keywordp (intern ":foo" [0])))) 198 (Assert (not (keywordp (intern ":foo" [0]))))
206 206
207 ;; Interning a fresh keyword string should produce a regular 207 ;; Interning a fresh keyword string should produce a regular
208 ;; keyword. 208 ;; keyword.
209 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo")) 209 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo"))
210 (fresh-keyword (intern fresh-keyword-name))) 210 (fresh-keyword (intern fresh-keyword-name)))
211 (Assert (eq (symbol-value fresh-keyword) fresh-keyword)) 211 (Assert-eq (symbol-value fresh-keyword) fresh-keyword)
212 (Assert (keywordp fresh-keyword))) 212 (Assert (keywordp fresh-keyword)))
213 213
214 ;; Likewise, reading a fresh keyword string should produce a regular 214 ;; Likewise, reading a fresh keyword string should produce a regular
215 ;; keyword. 215 ;; keyword.
216 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo")) 216 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo"))
217 (fresh-keyword (read fresh-keyword-name))) 217 (fresh-keyword (read fresh-keyword-name)))
218 (Assert (eq (symbol-value fresh-keyword) fresh-keyword)) 218 (Assert-eq (symbol-value fresh-keyword) fresh-keyword)
219 (Assert (keywordp fresh-keyword))) 219 (Assert (keywordp fresh-keyword)))
220 220
221 ;;; Assigning to keywords 221 ;;; Assigning to keywords
222 222
223 ;; You shouldn't be able to set its value to something bogus. 223 ;; You shouldn't be able to set its value to something bogus.
234 (Assert 234 (Assert
235 (eq (set (intern ":foo" obarray) :foo) :foo)) 235 (eq (set (intern ":foo" obarray) :foo) :foo))
236 236
237 ;; But symbols not interned in the global obarray are not real 237 ;; But symbols not interned in the global obarray are not real
238 ;; keywords (in elisp): 238 ;; keywords (in elisp):
239 (Assert (eq (set (intern ":foo" [0]) 5) 5)) 239 (Assert-eq (set (intern ":foo" [0]) 5) 5)
240 240
241 ;;; Printing keywords 241 ;;; Printing keywords
242 242
243 (let ((print-gensym t)) 243 (let ((print-gensym t))
244 (Assert (equal (prin1-to-string :foo) ":foo")) 244 (Assert-equal (prin1-to-string :foo) ":foo")
245 (Assert (equal (prin1-to-string (intern ":foo")) ":foo")) 245 (Assert-equal (prin1-to-string (intern ":foo")) ":foo")
246 (Assert (equal (prin1-to-string (intern ":foo" [0])) "#::foo"))) 246 (Assert-equal (prin1-to-string (intern ":foo" [0])) "#::foo"))
247 247
248 (let ((print-gensym nil)) 248 (let ((print-gensym nil))
249 (Assert (equal (prin1-to-string :foo) ":foo")) 249 (Assert-equal (prin1-to-string :foo) ":foo")
250 (Assert (equal (prin1-to-string (intern ":foo")) ":foo")) 250 (Assert-equal (prin1-to-string (intern ":foo")) ":foo")
251 (Assert (equal (prin1-to-string (intern ":foo" [0])) ":foo"))) 251 (Assert-equal (prin1-to-string (intern ":foo" [0])) ":foo"))
252 252
253 ;; #### Add many more tests for printing and reading symbols, as well 253 ;; #### Add many more tests for printing and reading symbols, as well
254 ;; as print-gensym and print-gensym-alist! 254 ;; as print-gensym and print-gensym-alist!
255 255
256 ;;----------------------------------------------------- 256 ;;-----------------------------------------------------
268 mysym 268 mysym
269 'set-value 269 'set-value
270 (lambda (&rest args) 270 (lambda (&rest args)
271 (throw 'test-tag args))) 271 (throw 'test-tag args)))
272 (Assert (not (boundp mysym))) 272 (Assert (not (boundp mysym)))
273 (Assert (equal (catch 'test-tag 273 (Assert-equal (catch 'test-tag
274 (set mysym 'foo)) 274 (set mysym 'foo))
275 `(,mysym (foo) set nil nil))) 275 `(,mysym (foo) set nil nil))
276 (Assert (not (boundp mysym))) 276 (Assert (not (boundp mysym)))
277 (dontusethis-set-symbol-value-handler 277 (dontusethis-set-symbol-value-handler
278 mysym 278 mysym
279 'set-value 279 'set-value
280 (lambda (&rest args) (setq save (nth 1 args)))) 280 (lambda (&rest args) (setq save (nth 1 args))))
281 (set mysym 'foo) 281 (set mysym 'foo)
282 (Assert (equal save '(foo))) 282 (Assert-equal save '(foo))
283 (Assert (eq (symbol-value mysym) 'foo)) 283 (Assert-eq (symbol-value mysym) 'foo)
284 ) 284 )
285 285
286 (let ((mysym (make-symbol "test-symbol")) 286 (let ((mysym (make-symbol "test-symbol"))
287 save) 287 save)
288 (dontusethis-set-symbol-value-handler 288 (dontusethis-set-symbol-value-handler
289 mysym 289 mysym
290 'make-unbound 290 'make-unbound
291 (lambda (&rest args) 291 (lambda (&rest args)
292 (throw 'test-tag args))) 292 (throw 'test-tag args)))
293 (Assert (equal (catch 'test-tag 293 (Assert-equal (catch 'test-tag
294 (makunbound mysym)) 294 (makunbound mysym))
295 `(,mysym nil makunbound nil nil))) 295 `(,mysym nil makunbound nil nil))
296 (dontusethis-set-symbol-value-handler 296 (dontusethis-set-symbol-value-handler
297 mysym 297 mysym
298 'make-unbound 298 'make-unbound
299 (lambda (&rest args) (setq save (nth 2 args)))) 299 (lambda (&rest args) (setq save (nth 2 args))))
300 (Assert (not (boundp mysym))) 300 (Assert (not (boundp mysym)))
301 (set mysym 'bar) 301 (set mysym 'bar)
302 (Assert (null save)) 302 (Assert (null save))
303 (Assert (eq (symbol-value mysym) 'bar)) 303 (Assert-eq (symbol-value mysym) 'bar)
304 (makunbound mysym) 304 (makunbound mysym)
305 (Assert (not (boundp mysym))) 305 (Assert (not (boundp mysym)))
306 (Assert (eq save 'makunbound)) 306 (Assert-eq save 'makunbound)
307 ) 307 )
308 308
309 ;; pathname-coding-system is no more. 309 ;; pathname-coding-system is no more.
310 ; (when (featurep 'file-coding) 310 ; (when (featurep 'file-coding)
311 ; (Assert (eq pathname-coding-system file-name-coding-system)) 311 ; (Assert-eq pathname-coding-system file-name-coding-system)
312 ; (let ((val1 file-name-coding-system) 312 ; (let ((val1 file-name-coding-system)
313 ; (val2 pathname-coding-system)) 313 ; (val2 pathname-coding-system))
314 ; (Assert (eq val1 val2)) 314 ; (Assert-eq val1 val2)
315 ; (let ((file-name-coding-system 'no-conversion-dos)) 315 ; (let ((file-name-coding-system 'no-conversion-dos))
316 ; (Assert (eq file-name-coding-system 'no-conversion-dos)) 316 ; (Assert-eq file-name-coding-system 'no-conversion-dos)
317 ; (Assert (eq pathname-coding-system file-name-coding-system))) 317 ; (Assert-eq pathname-coding-system file-name-coding-system))
318 ; (let ((pathname-coding-system 'no-conversion-mac)) 318 ; (let ((pathname-coding-system 'no-conversion-mac))
319 ; (Assert (eq file-name-coding-system 'no-conversion-mac)) 319 ; (Assert-eq file-name-coding-system 'no-conversion-mac)
320 ; (Assert (eq pathname-coding-system file-name-coding-system))) 320 ; (Assert-eq pathname-coding-system file-name-coding-system))
321 ; (Assert (eq file-name-coding-system pathname-coding-system)) 321 ; (Assert-eq file-name-coding-system pathname-coding-system)
322 ; (Assert (eq val1 file-name-coding-system))) 322 ; (Assert-eq val1 file-name-coding-system))
323 ; (Assert (eq pathname-coding-system file-name-coding-system))) 323 ; (Assert-eq pathname-coding-system file-name-coding-system))
324 324
325 325
326 ;(let ((mysym (make-symbol "test-symbol"))) 326 ;(let ((mysym (make-symbol "test-symbol")))
327 ; (dontusethis-set-symbol-value-handler 327 ; (dontusethis-set-symbol-value-handler
328 ; mysym 328 ; mysym