Mercurial > hg > xemacs-beta

comparison tests/automated/symbol-tests.el @ 398:74fd4e045ea6 r21-2-29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-29
author cvs
date Mon, 13 Aug 2007 11:13:30 +0200
parents
children 697ef44129c6
comparison
equal deleted inserted replaced
397:f4aeb21a5bad 398:74fd4e045ea6
1 ;; Copyright (C) 1999 Free Software Foundation, Inc.
2
3 ;; Author: Hrvoje Niksic <hniksic@xemacs.org>
4 ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org>
5 ;; Created: 1999
6 ;; Keywords: tests
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF.
26
27 ;;; Commentary:
28
29 ;; Test symbols operations.
30 ;; See test-harness.el for instructions on how to run these tests.
31
32 (eval-when-compile
33 (condition-case nil
34 (require 'test-harness)
35 (file-error
36 (push "." load-path)
37 (when (and (boundp 'load-file-name) (stringp load-file-name))
38 (push (file-name-directory load-file-name) load-path))
39 (require 'test-harness))))
40
41
42 (defun ts-fresh-symbol-name (name)
43 "Return a variant of NAME (a string) that is not interned."
44 (when (intern-soft name)
45 (let ((count 1)
46 (orig name))
47 (while (progn
48 (setq name (format "%s-%d" orig count))
49 (intern-soft name))
50 (incf count))))
51 name)
52
53 ;;-----------------------------------------------------
54 ;; Creating, reading, and printing symbols
55 ;;-----------------------------------------------------
56
57 (dolist (name '("foo" "bar" ""
58 "something with space in it"
59 "a string with \0 in the middle."
60 "100" "10.0" "#<>[]]]];'\\';"
61 "!@#$%^^&*(()__"))
62 (let ((interned (intern name))
63 (uninterned (make-symbol name)))
64 (Assert (symbolp interned))
65 (Assert (symbolp uninterned))
66 (Assert (equal (symbol-name interned) name))
67 (Assert (equal (symbol-name uninterned) name))
68 (Assert (not (eq interned uninterned)))
69 (Assert (not (equal interned uninterned)))))
70
71 (flet ((check-weak-list-unique (weak-list &optional reversep)
72 "Check that elements of WEAK-LIST are referenced only there."
73 (let ((len (length (weak-list-list weak-list))))
74 (Assert (not (zerop len)))
75 (garbage-collect)
76 (Assert (eq (length (weak-list-list weak-list))
77 (if (not reversep) 0 len))))))
78 (let ((weak-list (make-weak-list))
79 (gc-cons-threshold most-positive-fixnum))
80 ;; Symbols created with `make-symbol' and `gensym' should be fresh
81 ;; and not referenced anywhere else. We check that no other
82 ;; references are available using a weak list.
83 (eval
84 ;; This statement must not be run byte-compiled, or the values
85 ;; remain referenced on the bytecode interpreter stack.
86 '(set-weak-list-list weak-list (list (make-symbol "foo") (gensym "foo"))))
87 (check-weak-list-unique weak-list)
88
89 ;; Equivalent test for `intern' and `gentemp'.
90 (eval
91 '(set-weak-list-list weak-list
92 (list (intern (ts-fresh-symbol-name "foo"))
93 (gentemp (ts-fresh-symbol-name "bar")))))
94 (check-weak-list-unique weak-list 'not)))
95
96 (Assert (not (intern-soft (make-symbol "foo"))))
97 (Assert (not (intern-soft (gensym "foo"))))
98 (Assert (intern-soft (intern (ts-fresh-symbol-name "foo"))))
99 (Assert (intern-soft (gentemp (ts-fresh-symbol-name "bar"))))
100
101 ;; Reading a symbol should intern it automatically, unless the symbol
102 ;; is marked specially.
103 (dolist (string (mapcar #'ts-fresh-symbol-name '("foo" "bar" "\\\0\\\1")))
104 (setq symbol (read string)
105 string (read (concat "\"" string "\"")))
106 (Assert (intern-soft string))
107 (Assert (intern-soft symbol))
108 (Assert (eq (intern-soft string) (intern-soft symbol))))
109
110 (let ((fresh (read (concat "#:" (ts-fresh-symbol-name "foo")))))
111 (Assert (not (intern-soft fresh))))
112
113 ;; Check #N=OBJECT and #N# read syntax.
114 (let* ((list (read "(#1=#:foo #1# #2=#:bar #2# #1# #2#)"))
115 (foo (nth 0 list))
116 (foo2 (nth 1 list))
117 (bar (nth 2 list))
118 (bar2 (nth 3 list))
119 (foo3 (nth 4 list))
120 (bar3 (nth 5 list)))
121 (Assert (symbolp foo))
122 (Assert (not (intern-soft foo)))
123 (Assert (equal (symbol-name foo) "foo"))
124 (Assert (symbolp bar))
125 (Assert (not (intern-soft bar)))
126 (Assert (equal (symbol-name bar) "bar"))
127
128 (Assert (eq foo foo2))
129 (Assert (eq foo2 foo3))
130 (Assert (eq bar bar2))
131 (Assert (eq bar2 bar3)))
132
133 ;; Check #N=OBJECT and #N# print syntax.
134 (let* ((foo (make-symbol "foo"))
135 (bar (make-symbol "bar"))
136 (list (list foo foo bar bar foo bar)))
137 (let* ((print-gensym nil)
138 (printed-list (prin1-to-string list)))
139 (Assert (equal printed-list "(foo foo bar bar foo bar)")))
140 (let* ((print-gensym t)
141 (printed-list (prin1-to-string list)))
142 (Assert (equal printed-list "(#1=#:foo #1# #2=#:bar #2# #1# #2#)"))))
143
144 ;;-----------------------------------------------------
145 ;; Read-only symbols
146 ;;-----------------------------------------------------
147
148 (Check-Error setting-constant
149 (set nil nil))
150 (Check-Error setting-constant
151 (set t nil))
152
153 ;;-----------------------------------------------------
154 ;; Variable indirections
155 ;;-----------------------------------------------------
156
157 (let ((foo 0)
158 (bar 1))
159 (defvaralias 'foo 'bar)
160 (Assert (eq foo bar))
161 (Assert (eq foo 1))
162 (Assert (eq (variable-alias 'foo) 'bar))
163 (defvaralias 'bar 'foo)
164 (Check-Error cyclic-variable-indirection
165 (symbol-value 'foo))
166 (Check-Error cyclic-variable-indirection
167 (symbol-value 'bar))
168 (defvaralias 'foo nil)
169 (Assert (eq foo 0))
170 (defvaralias 'bar nil)
171 (Assert (eq bar 1)))
172
173 ;;-----------------------------------------------------
174 ;; Keywords
175 ;;-----------------------------------------------------
176
177 ;;; Reading keywords
178
179 ;; In Elisp, a keyword is by definition a symbol beginning with `:'
180 ;; that is interned in the global obarray.
181
182 ;; In Elisp, a keyword is interned as any other symbol.
183 (Assert (eq (read ":foo") (intern ":foo")))
184
185 ;; A keyword is self-quoting and evaluates to itself.
186 (Assert (eq (eval (intern ":foo")) :foo))
187
188 ;; Keywords are recognized as such only if interned in the global
189 ;; obarray, and `keywordp' is aware of that.
190 (Assert (keywordp :foo))
191 (Assert (not (keywordp (intern ":foo" [0]))))
192
193 ;; Keywords used to be initialized at read-time, which resulted in
194 ;; (symbol-value (intern ":some-new-keyword")) signaling an error.
195 ;; Now we handle keywords at the time when the symbol is interned, so
196 ;; that (intern ":something) and (read ":something) will be
197 ;; equivalent. These tests check various operations on symbols that
198 ;; are guaranteed to be freshly interned.
199
200 ;; Interning a fresh keyword string should produce a regular
201 ;; keyword.
202 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo"))
203 (fresh-keyword (intern fresh-keyword-name)))
204 (Assert (eq (symbol-value fresh-keyword) fresh-keyword))
205 (Assert (keywordp fresh-keyword)))
206
207 ;; Likewise, reading a fresh keyword string should produce a regular
208 ;; keyword.
209 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo"))
210 (fresh-keyword (read fresh-keyword-name)))
211 (Assert (eq (symbol-value fresh-keyword) fresh-keyword))
212 (Assert (keywordp fresh-keyword)))
213
214 ;;; Assigning to keywords
215
216 ;; You shouldn't be able to set its value to something bogus.
217 (Check-Error setting-constant
218 (set :foo 5))
219
220 ;; But, for backward compatibility, setting to the same value is OK.
221 (Assert
222 (eq (set :foo :foo) :foo))
223
224 ;; Playing games with `intern' shouldn't fool us.
225 (Check-Error setting-constant
226 (set (intern ":foo" obarray) 5))
227 (Assert
228 (eq (set (intern ":foo" obarray) :foo) :foo))
229
230 ;; But symbols not interned in the global obarray are not real
231 ;; keywords (in elisp):
232 (Assert (eq (set (intern ":foo" [0]) 5) 5))
233
234 ;;; Printing keywords
235
236 (let ((print-gensym t))
237 (Assert (equal (prin1-to-string :foo) ":foo"))
238 (Assert (equal (prin1-to-string (intern ":foo")) ":foo"))
239 (Assert (equal (prin1-to-string (intern ":foo" [0])) "#::foo")))
240
241 (let ((print-gensym nil))
242 (Assert (equal (prin1-to-string :foo) ":foo"))
243 (Assert (equal (prin1-to-string (intern ":foo")) ":foo"))
244 (Assert (equal (prin1-to-string (intern ":foo" [0])) ":foo")))
245
246 ;; #### Add many more tests for printing and reading symbols, as well
247 ;; as print-gensym and print-gensym-alist!
248
249 ;;-----------------------------------------------------
250 ;; Magic symbols
251 ;;-----------------------------------------------------
252
253 ;; Magic symbols are only half implemented. However, a subset of the
254 ;; functionality is being used to implement backward compatibility or
255 ;; clearer error messages for new features such as specifiers and
256 ;; glyphs. These tests try to test that working subset.
257
258 (let ((mysym (make-symbol "test-symbol"))
259 save)
260 (dontusethis-set-symbol-value-handler
261 mysym
262 'set-value
263 (lambda (&rest args)
264 (throw 'test-tag args)))
265 (Assert (not (boundp mysym)))
266 (Assert (equal (catch 'test-tag
267 (set mysym 'foo))
268 `(,mysym (foo) set nil nil)))
269 (Assert (not (boundp mysym)))
270 (dontusethis-set-symbol-value-handler
271 mysym
272 'set-value
273 (lambda (&rest args) (setq save (nth 1 args))))
274 (set mysym 'foo)
275 (Assert (equal save '(foo)))
276 (Assert (eq (symbol-value mysym) 'foo))
277 )
278
279 (let ((mysym (make-symbol "test-symbol"))
280 save)
281 (dontusethis-set-symbol-value-handler
282 mysym
283 'make-unbound
284 (lambda (&rest args)
285 (throw 'test-tag args)))
286 (Assert (equal (catch 'test-tag
287 (makunbound mysym))
288 `(,mysym nil makunbound nil nil)))
289 (dontusethis-set-symbol-value-handler
290 mysym
291 'make-unbound
292 (lambda (&rest args) (setq save (nth 2 args))))
293 (Assert (not (boundp mysym)))
294 (set mysym 'bar)
295 (Assert (null save))
296 (Assert (eq (symbol-value mysym) 'bar))
297 (makunbound mysym)
298 (Assert (not (boundp mysym)))
299 (Assert (eq save 'makunbound))
300 )
301
302 (when (featurep 'file-coding)
303 (Assert (eq pathname-coding-system file-name-coding-system))
304 (let ((val1 file-name-coding-system)
305 (val2 pathname-coding-system))
306 (Assert (eq val1 val2))
307 (let ((file-name-coding-system 'no-conversion-dos))
308 (Assert (eq file-name-coding-system 'no-conversion-dos))
309 (Assert (eq pathname-coding-system file-name-coding-system)))
310 (let ((pathname-coding-system 'no-conversion-mac))
311 (Assert (eq file-name-coding-system 'no-conversion-mac))
312 (Assert (eq pathname-coding-system file-name-coding-system)))
313 (Assert (eq file-name-coding-system pathname-coding-system))
314 (Assert (eq val1 file-name-coding-system)))
315 (Assert (eq pathname-coding-system file-name-coding-system)))
316
317
318 ;(let ((mysym (make-symbol "test-symbol")))
319 ; (dontusethis-set-symbol-value-handler
320 ; mysym
321 ; 'make-local
322 ; (lambda (&rest args)
323 ; (throw 'test-tag args)))
324 ; (Assert (equal (catch 'test-tag
325 ; (set mysym 'foo))
326 ; `(,mysym (foo) make-local nil nil))))