git.chise.org Git - chise/xemacs-chise.git.1/blob - tests/automated/symbol-tests.el

   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))))