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))))
+ − 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
440
+ − 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.
428
+ − 257
440
+ − 258 (let ((mysym (make-symbol "test-symbol"))
+ − 259 save)
428
+ − 260 (dontusethis-set-symbol-value-handler
+ − 261 mysym
+ − 262 'set-value
+ − 263 (lambda (&rest args)
+ − 264 (throw 'test-tag args)))
440
+ − 265 (Assert (not (boundp mysym)))
428
+ − 266 (Assert (equal (catch 'test-tag
+ − 267 (set mysym 'foo))
440
+ − 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 )
428
+ − 278
440
+ − 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
826
+ − 302 ;; pathname-coding-system is no more.
+ − 303 ; (when (featurep 'file-coding)
+ − 304 ; (Assert (eq pathname-coding-system file-name-coding-system))
+ − 305 ; (let ((val1 file-name-coding-system)
+ − 306 ; (val2 pathname-coding-system))
+ − 307 ; (Assert (eq val1 val2))
+ − 308 ; (let ((file-name-coding-system 'no-conversion-dos))
+ − 309 ; (Assert (eq file-name-coding-system 'no-conversion-dos))
+ − 310 ; (Assert (eq pathname-coding-system file-name-coding-system)))
+ − 311 ; (let ((pathname-coding-system 'no-conversion-mac))
+ − 312 ; (Assert (eq file-name-coding-system 'no-conversion-mac))
+ − 313 ; (Assert (eq pathname-coding-system file-name-coding-system)))
+ − 314 ; (Assert (eq file-name-coding-system pathname-coding-system))
+ − 315 ; (Assert (eq val1 file-name-coding-system)))
+ − 316 ; (Assert (eq pathname-coding-system file-name-coding-system)))
440
+ − 317
428
+ − 318
+ − 319 ;(let ((mysym (make-symbol "test-symbol")))
+ − 320 ; (dontusethis-set-symbol-value-handler
+ − 321 ; mysym
+ − 322 ; 'make-local
+ − 323 ; (lambda (&rest args)
+ − 324 ; (throw 'test-tag args)))
+ − 325 ; (Assert (equal (catch 'test-tag
+ − 326 ; (set mysym 'foo))
440
+ − 327 ; `(,mysym (foo) make-local nil nil))))