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