|
428
|
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))))
|
|
1413
|
74 (if (string-match "Using the new GC algorithms."
|
|
|
75 Installation-string)
|
|
|
76 (Implementation-Incomplete-Expect-Failure
|
|
|
77 (Assert (not (zerop len)))
|
|
|
78 (garbage-collect)
|
|
|
79 (Assert (eq (length (weak-list-list weak-list))
|
|
|
80 (if (not reversep) 0 len))))
|
|
|
81 (Assert (not (zerop len)))
|
|
|
82 (garbage-collect)
|
|
|
83 (Assert (eq (length (weak-list-list weak-list))
|
|
|
84 (if (not reversep) 0 len)))))))
|
|
428
|
85 (let ((weak-list (make-weak-list))
|
|
|
86 (gc-cons-threshold most-positive-fixnum))
|
|
|
87 ;; Symbols created with `make-symbol' and `gensym' should be fresh
|
|
|
88 ;; and not referenced anywhere else. We check that no other
|
|
|
89 ;; references are available using a weak list.
|
|
|
90 (eval
|
|
|
91 ;; This statement must not be run byte-compiled, or the values
|
|
|
92 ;; remain referenced on the bytecode interpreter stack.
|
|
|
93 '(set-weak-list-list weak-list (list (make-symbol "foo") (gensym "foo"))))
|
|
|
94 (check-weak-list-unique weak-list)
|
|
|
95
|
|
|
96 ;; Equivalent test for `intern' and `gentemp'.
|
|
|
97 (eval
|
|
|
98 '(set-weak-list-list weak-list
|
|
|
99 (list (intern (ts-fresh-symbol-name "foo"))
|
|
|
100 (gentemp (ts-fresh-symbol-name "bar")))))
|
|
|
101 (check-weak-list-unique weak-list 'not)))
|
|
|
102
|
|
|
103 (Assert (not (intern-soft (make-symbol "foo"))))
|
|
|
104 (Assert (not (intern-soft (gensym "foo"))))
|
|
|
105 (Assert (intern-soft (intern (ts-fresh-symbol-name "foo"))))
|
|
|
106 (Assert (intern-soft (gentemp (ts-fresh-symbol-name "bar"))))
|
|
|
107
|
|
|
108 ;; Reading a symbol should intern it automatically, unless the symbol
|
|
|
109 ;; is marked specially.
|
|
|
110 (dolist (string (mapcar #'ts-fresh-symbol-name '("foo" "bar" "\\\0\\\1")))
|
|
|
111 (setq symbol (read string)
|
|
|
112 string (read (concat "\"" string "\"")))
|
|
|
113 (Assert (intern-soft string))
|
|
|
114 (Assert (intern-soft symbol))
|
|
|
115 (Assert (eq (intern-soft string) (intern-soft symbol))))
|
|
|
116
|
|
|
117 (let ((fresh (read (concat "#:" (ts-fresh-symbol-name "foo")))))
|
|
|
118 (Assert (not (intern-soft fresh))))
|
|
|
119
|
|
|
120 ;; Check #N=OBJECT and #N# read syntax.
|
|
|
121 (let* ((list (read "(#1=#:foo #1# #2=#:bar #2# #1# #2#)"))
|
|
|
122 (foo (nth 0 list))
|
|
|
123 (foo2 (nth 1 list))
|
|
|
124 (bar (nth 2 list))
|
|
|
125 (bar2 (nth 3 list))
|
|
|
126 (foo3 (nth 4 list))
|
|
|
127 (bar3 (nth 5 list)))
|
|
|
128 (Assert (symbolp foo))
|
|
|
129 (Assert (not (intern-soft foo)))
|
|
|
130 (Assert (equal (symbol-name foo) "foo"))
|
|
|
131 (Assert (symbolp bar))
|
|
|
132 (Assert (not (intern-soft bar)))
|
|
|
133 (Assert (equal (symbol-name bar) "bar"))
|
|
|
134
|
|
|
135 (Assert (eq foo foo2))
|
|
|
136 (Assert (eq foo2 foo3))
|
|
|
137 (Assert (eq bar bar2))
|
|
|
138 (Assert (eq bar2 bar3)))
|
|
|
139
|
|
|
140 ;; Check #N=OBJECT and #N# print syntax.
|
|
|
141 (let* ((foo (make-symbol "foo"))
|
|
|
142 (bar (make-symbol "bar"))
|
|
|
143 (list (list foo foo bar bar foo bar)))
|
|
|
144 (let* ((print-gensym nil)
|
|
|
145 (printed-list (prin1-to-string list)))
|
|
|
146 (Assert (equal printed-list "(foo foo bar bar foo bar)")))
|
|
|
147 (let* ((print-gensym t)
|
|
|
148 (printed-list (prin1-to-string list)))
|
|
|
149 (Assert (equal printed-list "(#1=#:foo #1# #2=#:bar #2# #1# #2#)"))))
|
|
|
150
|
|
|
151 ;;-----------------------------------------------------
|
|
|
152 ;; Read-only symbols
|
|
|
153 ;;-----------------------------------------------------
|
|
|
154
|
|
|
155 (Check-Error setting-constant
|
|
|
156 (set nil nil))
|
|
|
157 (Check-Error setting-constant
|
|
|
158 (set t nil))
|
|
|
159
|
|
|
160 ;;-----------------------------------------------------
|
|
|
161 ;; Variable indirections
|
|
|
162 ;;-----------------------------------------------------
|
|
|
163
|
|
|
164 (let ((foo 0)
|
|
|
165 (bar 1))
|
|
|
166 (defvaralias 'foo 'bar)
|
|
|
167 (Assert (eq foo bar))
|
|
|
168 (Assert (eq foo 1))
|
|
|
169 (Assert (eq (variable-alias 'foo) 'bar))
|
|
|
170 (defvaralias 'bar 'foo)
|
|
|
171 (Check-Error cyclic-variable-indirection
|
|
|
172 (symbol-value 'foo))
|
|
|
173 (Check-Error cyclic-variable-indirection
|
|
|
174 (symbol-value 'bar))
|
|
|
175 (defvaralias 'foo nil)
|
|
|
176 (Assert (eq foo 0))
|
|
|
177 (defvaralias 'bar nil)
|
|
|
178 (Assert (eq bar 1)))
|
|
|
179
|
|
|
180 ;;-----------------------------------------------------
|
|
|
181 ;; Keywords
|
|
|
182 ;;-----------------------------------------------------
|
|
|
183
|
|
|
184 ;;; Reading keywords
|
|
|
185
|
|
|
186 ;; In Elisp, a keyword is by definition a symbol beginning with `:'
|
|
|
187 ;; that is interned in the global obarray.
|
|
|
188
|
|
|
189 ;; In Elisp, a keyword is interned as any other symbol.
|
|
|
190 (Assert (eq (read ":foo") (intern ":foo")))
|
|
|
191
|
|
|
192 ;; A keyword is self-quoting and evaluates to itself.
|
|
|
193 (Assert (eq (eval (intern ":foo")) :foo))
|
|
|
194
|
|
|
195 ;; Keywords are recognized as such only if interned in the global
|
|
|
196 ;; obarray, and `keywordp' is aware of that.
|
|
|
197 (Assert (keywordp :foo))
|
|
|
198 (Assert (not (keywordp (intern ":foo" [0]))))
|
|
|
199
|
|
|
200 ;; Keywords used to be initialized at read-time, which resulted in
|
|
|
201 ;; (symbol-value (intern ":some-new-keyword")) signaling an error.
|
|
|
202 ;; Now we handle keywords at the time when the symbol is interned, so
|
|
|
203 ;; that (intern ":something) and (read ":something) will be
|
|
|
204 ;; equivalent. These tests check various operations on symbols that
|
|
|
205 ;; are guaranteed to be freshly interned.
|
|
|
206
|
|
|
207 ;; Interning a fresh keyword string should produce a regular
|
|
|
208 ;; keyword.
|
|
|
209 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo"))
|
|
|
210 (fresh-keyword (intern fresh-keyword-name)))
|
|
|
211 (Assert (eq (symbol-value fresh-keyword) fresh-keyword))
|
|
|
212 (Assert (keywordp fresh-keyword)))
|
|
|
213
|
|
|
214 ;; Likewise, reading a fresh keyword string should produce a regular
|
|
|
215 ;; keyword.
|
|
|
216 (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo"))
|
|
|
217 (fresh-keyword (read fresh-keyword-name)))
|
|
|
218 (Assert (eq (symbol-value fresh-keyword) fresh-keyword))
|
|
|
219 (Assert (keywordp fresh-keyword)))
|
|
|
220
|
|
|
221 ;;; Assigning to keywords
|
|
|
222
|
|
|
223 ;; You shouldn't be able to set its value to something bogus.
|
|
|
224 (Check-Error setting-constant
|
|
|
225 (set :foo 5))
|
|
|
226
|
|
|
227 ;; But, for backward compatibility, setting to the same value is OK.
|
|
|
228 (Assert
|
|
|
229 (eq (set :foo :foo) :foo))
|
|
|
230
|
|
|
231 ;; Playing games with `intern' shouldn't fool us.
|
|
|
232 (Check-Error setting-constant
|
|
|
233 (set (intern ":foo" obarray) 5))
|
|
|
234 (Assert
|
|
|
235 (eq (set (intern ":foo" obarray) :foo) :foo))
|
|
|
236
|
|
|
237 ;; But symbols not interned in the global obarray are not real
|
|
|
238 ;; keywords (in elisp):
|
|
|
239 (Assert (eq (set (intern ":foo" [0]) 5) 5))
|
|
|
240
|
|
|
241 ;;; Printing keywords
|
|
|
242
|
|
|
243 (let ((print-gensym t))
|
|
|
244 (Assert (equal (prin1-to-string :foo) ":foo"))
|
|
|
245 (Assert (equal (prin1-to-string (intern ":foo")) ":foo"))
|
|
|
246 (Assert (equal (prin1-to-string (intern ":foo" [0])) "#::foo")))
|
|
|
247
|
|
|
248 (let ((print-gensym nil))
|
|
|
249 (Assert (equal (prin1-to-string :foo) ":foo"))
|
|
|
250 (Assert (equal (prin1-to-string (intern ":foo")) ":foo"))
|
|
|
251 (Assert (equal (prin1-to-string (intern ":foo" [0])) ":foo")))
|
|
|
252
|
|
|
253 ;; #### Add many more tests for printing and reading symbols, as well
|
|
|
254 ;; as print-gensym and print-gensym-alist!
|
|
|
255
|
|
|
256 ;;-----------------------------------------------------
|
|
|
257 ;; Magic symbols
|
|
|
258 ;;-----------------------------------------------------
|
|
|
259
|
|
440
|
260 ;; Magic symbols are only half implemented. However, a subset of the
|
|
|
261 ;; functionality is being used to implement backward compatibility or
|
|
|
262 ;; clearer error messages for new features such as specifiers and
|
|
|
263 ;; glyphs. These tests try to test that working subset.
|
|
428
|
264
|
|
440
|
265 (let ((mysym (make-symbol "test-symbol"))
|
|
|
266 save)
|
|
428
|
267 (dontusethis-set-symbol-value-handler
|
|
|
268 mysym
|
|
|
269 'set-value
|
|
|
270 (lambda (&rest args)
|
|
|
271 (throw 'test-tag args)))
|
|
440
|
272 (Assert (not (boundp mysym)))
|
|
428
|
273 (Assert (equal (catch 'test-tag
|
|
|
274 (set mysym 'foo))
|
|
440
|
275 `(,mysym (foo) set nil nil)))
|
|
|
276 (Assert (not (boundp mysym)))
|
|
|
277 (dontusethis-set-symbol-value-handler
|
|
|
278 mysym
|
|
|
279 'set-value
|
|
|
280 (lambda (&rest args) (setq save (nth 1 args))))
|
|
|
281 (set mysym 'foo)
|
|
|
282 (Assert (equal save '(foo)))
|
|
|
283 (Assert (eq (symbol-value mysym) 'foo))
|
|
|
284 )
|
|
428
|
285
|
|
440
|
286 (let ((mysym (make-symbol "test-symbol"))
|
|
|
287 save)
|
|
|
288 (dontusethis-set-symbol-value-handler
|
|
|
289 mysym
|
|
|
290 'make-unbound
|
|
|
291 (lambda (&rest args)
|
|
|
292 (throw 'test-tag args)))
|
|
|
293 (Assert (equal (catch 'test-tag
|
|
|
294 (makunbound mysym))
|
|
|
295 `(,mysym nil makunbound nil nil)))
|
|
|
296 (dontusethis-set-symbol-value-handler
|
|
|
297 mysym
|
|
|
298 'make-unbound
|
|
|
299 (lambda (&rest args) (setq save (nth 2 args))))
|
|
|
300 (Assert (not (boundp mysym)))
|
|
|
301 (set mysym 'bar)
|
|
|
302 (Assert (null save))
|
|
|
303 (Assert (eq (symbol-value mysym) 'bar))
|
|
|
304 (makunbound mysym)
|
|
|
305 (Assert (not (boundp mysym)))
|
|
|
306 (Assert (eq save 'makunbound))
|
|
|
307 )
|
|
|
308
|
|
826
|
309 ;; pathname-coding-system is no more.
|
|
|
310 ; (when (featurep 'file-coding)
|
|
|
311 ; (Assert (eq pathname-coding-system file-name-coding-system))
|
|
|
312 ; (let ((val1 file-name-coding-system)
|
|
|
313 ; (val2 pathname-coding-system))
|
|
|
314 ; (Assert (eq val1 val2))
|
|
|
315 ; (let ((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)))
|
|
|
318 ; (let ((pathname-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)))
|
|
|
321 ; (Assert (eq file-name-coding-system pathname-coding-system))
|
|
|
322 ; (Assert (eq val1 file-name-coding-system)))
|
|
|
323 ; (Assert (eq pathname-coding-system file-name-coding-system)))
|
|
440
|
324
|
|
428
|
325
|
|
|
326 ;(let ((mysym (make-symbol "test-symbol")))
|
|
|
327 ; (dontusethis-set-symbol-value-handler
|
|
|
328 ; mysym
|
|
|
329 ; 'make-local
|
|
|
330 ; (lambda (&rest args)
|
|
|
331 ; (throw 'test-tag args)))
|
|
|
332 ; (Assert (equal (catch 'test-tag
|
|
|
333 ; (set mysym 'foo))
|
|
440
|
334 ; `(,mysym (foo) make-local nil nil))))
|
