src/code/symbol.lisp

   1 ;;;; code to manipulate symbols (but not packages, which are handled
   2 ;;;; elsewhere)
   3 ;;;;
   4 ;;;; Many of these definitions are trivial interpreter entries to
   5 ;;;; functions open-coded by the compiler.
   6
   7 ;;;; This software is part of the SBCL system. See the README file for
   8 ;;;; more information.
   9 ;;;;
  10 ;;;; This software is derived from the CMU CL system, which was
  11 ;;;; written at Carnegie Mellon University and released into the
  12 ;;;; public domain. The software is in the public domain and is
  13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  14 ;;;; files for more information.
  15
  16 (in-package "SB!IMPL")
  17
  18 (declaim (maybe-inline get get2 get3 %put getf remprop %putf get-properties keywordp))
  19
  20 (defun symbol-value (symbol)
  21   #!+sb-doc
  22   "Return SYMBOL's current bound value."
  23   (declare (optimize (safety 1)))
  24   (symbol-value symbol))
  25
  26 #-sb-xc-host
  27 (define-compiler-macro symbol-value (&whole form symbol &environment env)
  28   (when (sb!xc:constantp symbol env)
  29     (let ((name (constant-form-value symbol env)))
  30       (when (symbolp name)
  31         (check-deprecated-variable name))))
  32   form)
  33
  34 (defun boundp (symbol)
  35   #!+sb-doc
  36   "Return non-NIL if SYMBOL is bound to a value."
  37   (boundp symbol))
  38
  39 (defun set (symbol new-value)
  40   #!+sb-doc
  41   "Set SYMBOL's value cell to NEW-VALUE."
  42   (declare (type symbol symbol))
  43   (about-to-modify-symbol-value symbol 'set new-value)
  44   (%set-symbol-value symbol new-value))
  45
  46 (defun %set-symbol-value (symbol new-value)
  47   (%set-symbol-value symbol new-value))
  48
  49 (defun symbol-global-value (symbol)
  50   #!+sb-doc
  51   "Return the SYMBOL's current global value. Identical to SYMBOL-VALUE,
  52 in single-threaded builds: in multithreaded builds bound values are
  53 distinct from the global value. Can also be SETF."
  54   (declare (optimize (safety 1)))
  55   (symbol-global-value symbol))
  56
  57 (defun set-symbol-global-value (symbol new-value)
  58   (about-to-modify-symbol-value symbol 'set new-value)
  59   (sb!kernel:%set-symbol-global-value symbol new-value))
  60
  61 (declaim (inline %makunbound))
  62 (defun %makunbound (symbol)
  63   (%set-symbol-value symbol (%primitive sb!c:make-unbound-marker)))
  64
  65 (defun makunbound (symbol)
  66   #!+sb-doc
  67   "Make SYMBOL unbound, removing any value it may currently have."
  68   (with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A")
  69     (when (and (info :variable :always-bound symbol))
  70       (error "Can't make ~A variable unbound: ~S" 'always-bound symbol))
  71     (about-to-modify-symbol-value symbol 'makunbound)
  72     (%makunbound symbol)
  73     symbol))
  74
  75 ;;; Return the built-in hash value for SYMBOL.
  76 (defun symbol-hash (symbol)
  77   (symbol-hash symbol))
  78
  79 (defun symbol-function (symbol)
  80   #!+sb-doc
  81   "Return SYMBOL's current function definition. Settable with SETF."
  82   (%coerce-name-to-fun symbol))
  83
  84 (defun (setf symbol-function) (new-value symbol)
  85   (declare (type symbol symbol) (type function new-value))
  86   (with-single-package-locked-error
  87       (:symbol symbol "setting the symbol-function of ~A")
  88     (setf (%coerce-name-to-fun symbol) new-value)))
  89
  90 (defun symbol-plist (symbol)
  91   #!+sb-doc
  92   "Return SYMBOL's property list."
  93   (symbol-plist symbol))
  94
  95 (defun %set-symbol-plist (symbol new-value)
  96   (setf (symbol-plist symbol) new-value))
  97
  98 (defun symbol-name (symbol)
  99   #!+sb-doc
 100   "Return SYMBOL's name as a string."
 101   (symbol-name symbol))
 102
 103 (defun symbol-package (symbol)
 104   #!+sb-doc
 105   "Return the package SYMBOL was interned in, or NIL if none."
 106   (symbol-package symbol))
 107
 108 (defun %set-symbol-package (symbol package)
 109   (declare (type symbol symbol))
 110   (%set-symbol-package symbol package))
 111
 112 (defun make-symbol (string)
 113   #!+sb-doc
 114   "Make and return a new symbol with the STRING as its print name."
 115   (declare (type string string))
 116   (%make-symbol (if (simple-string-p string)
 117                     string
 118                     (subseq string 0))))
 119
 120 (defun get (symbol indicator &optional (default nil))
 121   #!+sb-doc
 122   "Look on the property list of SYMBOL for the specified INDICATOR. If this
 123   is found, return the associated value, else return DEFAULT."
 124   (get3 symbol indicator default))
 125
 126 (defun get2 (symbol indicator)
 127   (get3 symbol indicator nil))
 128 #|
 129   (let (cdr-pl)
 130     (do ((pl (symbol-plist symbol) (cdr cdr-pl)))
 131         ((atom pl) nil)
 132       (setf cdr-pl (cdr pl))
 133       (cond ((atom cdr-pl)
 134              (error "~S has an odd number of items in its property list."
 135                     symbol))
 136             ((eq (car pl) indicator)
 137              (return (car cdr-pl)))))))
 138 |#
 139
 140 (defun get3 (symbol indicator default)
 141   (let (cdr-pl)
 142     (do ((pl (symbol-plist symbol) (cdr cdr-pl)))
 143         ((atom pl) default)
 144       (setq cdr-pl (cdr pl))
 145       (cond ((atom cdr-pl)
 146              (error "~S has an odd number of items in its property list."
 147                     symbol))
 148             ((eq (car pl) indicator)
 149              (return (car cdr-pl)))))))
 150
 151 (defun %put (symbol indicator value)
 152   #!+sb-doc
 153   "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
 154   Returns VALUE."
 155   (do ((pl (symbol-plist symbol) (cddr pl)))
 156       ((endp pl)
 157        (setf (symbol-plist symbol)
 158              (list* indicator value (symbol-plist symbol)))
 159        value)
 160     (cond ((endp (cdr pl))
 161            (error "~S has an odd number of items in its property list."
 162                   symbol))
 163           ((eq (car pl) indicator)
 164            (rplaca (cdr pl) value)
 165            (return value)))))
 166
 167 (defun remprop (symbol indicator)
 168   #!+sb-doc
 169   "Look on property list of SYMBOL for property with specified
 170   INDICATOR. If found, splice this indicator and its value out of
 171   the plist, and return the tail of the original list starting with
 172   INDICATOR. If not found, return () with no side effects.
 173
 174   NOTE: The ANSI specification requires REMPROP to return true (not false)
 175   or false (the symbol NIL). Portable code should not rely on any other value."
 176   (do ((pl (symbol-plist symbol) (cddr pl))
 177        (prev nil pl))
 178       ((atom pl) nil)
 179     (cond ((atom (cdr pl))
 180            (error "~S has an odd number of items in its property list."
 181                   symbol))
 182           ((eq (car pl) indicator)
 183            (cond (prev (rplacd (cdr prev) (cddr pl)))
 184                  (t
 185                   (setf (symbol-plist symbol) (cddr pl))))
 186            (return pl)))))
 187
 188 (defun getf (place indicator &optional (default ()))
 189   #!+sb-doc
 190   "Search the property list stored in PLACE for an indicator EQ to INDICATOR.
 191   If one is found, return the corresponding value, else return DEFAULT."
 192   (do ((plist place (cddr plist)))
 193       ((null plist) default)
 194     (cond ((atom (cdr plist))
 195            (error 'simple-type-error
 196                   :format-control "malformed property list: ~S."
 197                   :format-arguments (list place)
 198                   :datum (cdr plist)
 199                   :expected-type 'cons))
 200           ((eq (car plist) indicator)
 201            (return (cadr plist))))))
 202
 203 (defun %putf (place property new-value)
 204   (declare (type list place))
 205   (do ((plist place (cddr plist)))
 206       ((endp plist) (list* property new-value place))
 207     (declare (type list plist))
 208     (when (eq (car plist) property)
 209       (setf (cadr plist) new-value)
 210       (return place))))
 211
 212 (defun get-properties (place indicator-list)
 213   #!+sb-doc
 214   "Like GETF, except that INDICATOR-LIST is a list of indicators which will
 215   be looked for in the property list stored in PLACE. Three values are
 216   returned, see manual for details."
 217   (do ((plist place (cddr plist)))
 218       ((null plist) (values nil nil nil))
 219     (cond ((atom (cdr plist))
 220            (error 'simple-type-error
 221                   :format-control "malformed property list: ~S."
 222                   :format-arguments (list place)
 223                   :datum (cdr plist)
 224                   :expected-type 'cons))
 225           ((memq (car plist) indicator-list)
 226            (return (values (car plist) (cadr plist) plist))))))
 227
 228 (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
 229   #!+sb-doc
 230   "Make and return a new uninterned symbol with the same print name
 231   as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound
 232   nor fbound and has no properties, else it has a copy of SYMBOL's
 233   function, value and property list."
 234   (declare (type symbol symbol))
 235   (setq new-symbol (make-symbol (symbol-name symbol)))
 236   (when copy-props
 237     (%set-symbol-value new-symbol
 238                        (%primitive sb!c:fast-symbol-value symbol))
 239     (setf (symbol-plist new-symbol)
 240           (copy-list (symbol-plist symbol)))
 241     (when (fboundp symbol)
 242       (setf (symbol-function new-symbol) (symbol-function symbol))))
 243   new-symbol)
 244
 245 ;;; FIXME: This declaration should be redundant.
 246 (declaim (special *keyword-package*))
 247
 248 (defun keywordp (object)
 249   #!+sb-doc
 250   "Return true if Object is a symbol in the \"KEYWORD\" package."
 251   (and (symbolp object)
 252        (eq (symbol-package object) *keyword-package*)))
 253 \f
 254 ;;;; GENSYM and friends
 255
 256 (defun %make-symbol-name (prefix counter)
 257   (with-output-to-string (s)
 258     (write-string prefix s)
 259     (%output-integer-in-base counter 10 s)))
 260
 261 (defvar *gensym-counter* 0
 262   #!+sb-doc
 263   "counter for generating unique GENSYM symbols")
 264 (declaim (type unsigned-byte *gensym-counter*))
 265
 266 (defun gensym (&optional (thing "G"))
 267   #!+sb-doc
 268   "Creates a new uninterned symbol whose name is a prefix string (defaults
 269    to \"G\"), followed by a decimal number. Thing, when supplied, will
 270    alter the prefix if it is a string, or be used for the decimal number
 271    if it is a number, of this symbol. The default value of the number is
 272    the current value of *gensym-counter* which is incremented each time
 273    it is used."
 274   (let ((old *gensym-counter*))
 275     (unless (numberp thing)
 276       (let ((new (etypecase old
 277                    (index (1+ old))
 278                    (unsigned-byte (1+ old)))))
 279         (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
 280         (setq *gensym-counter* new)))
 281     (multiple-value-bind (prefix int)
 282         (etypecase thing
 283           (simple-string (values thing old))
 284           (unsigned-byte (values "G" thing))
 285           (string (values (coerce thing 'simple-string) old)))
 286       (declare (simple-string prefix))
 287       (make-symbol (%make-symbol-name prefix int)))))
 288
 289 (defvar *gentemp-counter* 0)
 290 (declaim (type unsigned-byte *gentemp-counter*))
 291
 292 (defun gentemp (&optional (prefix "T") (package (sane-package)))
 293   #!+sb-doc
 294   "Creates a new symbol interned in package PACKAGE with the given PREFIX."
 295   (declare (type string prefix))
 296   (loop for name = (%make-symbol-name prefix (incf *gentemp-counter*))
 297         while (nth-value 1 (find-symbol name package))
 298         finally (return (values (intern name package)))))
 299
 300 ;;; This function is to be called just before a change which would affect the
 301 ;;; symbol value. We don't absolutely have to call this function before such
 302 ;;; changes, since such changes to constants are given as undefined behavior,
 303 ;;; it's nice to do so. To circumvent this you need code like this:
 304 ;;;
 305 ;;;   (defvar foo)
 306 ;;;   (defun set-foo (x) (setq foo x))
 307 ;;;   (defconstant foo 42)
 308 ;;;   (set-foo 13)
 309 ;;;   foo => 13, (constantp 'foo) => t
 310 ;;;
 311 ;;; ...in which case you frankly deserve to lose.
 312 (defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind)
 313   (declare (symbol symbol))
 314   (flet ((describe-action ()
 315            (ecase action
 316              (set "set SYMBOL-VALUE of ~S")
 317              (progv "bind ~S")
 318              (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S")
 319              (defconstant "define ~S as a constant")
 320              (makunbound "make ~S unbound"))))
 321     (let ((kind (info :variable :kind symbol)))
 322       (multiple-value-bind (what continue)
 323           (cond ((eq :constant kind)
 324                  (cond ((eq symbol t)
 325                         (values "Veritas aeterna. (can't ~@?)" nil))
 326                        ((eq symbol nil)
 327                         (values "Nihil ex nihil. (can't ~@?)" nil))
 328                        ((keywordp symbol)
 329                         (values "Can't ~@?." nil))
 330                        (t
 331                         (values "Constant modification: attempt to ~@?." t))))
 332                 ((and bind (eq :global kind))
 333                  (values "Can't ~@? (global variable)." nil)))
 334         (when what
 335           (if continue
 336               (cerror "Modify the constant." what (describe-action) symbol)
 337               (error what (describe-action) symbol)))
 338         (when valuep
 339           ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to
 340           ;; check.
 341           (let ((type (info :variable :type symbol)))
 342             (unless (sb!kernel::%%typep new-value type nil)
 343               (let ((spec (type-specifier type)))
 344                 (error 'simple-type-error
 345                        :format-control "~@<Cannot ~@? to ~S, not of type ~S.~:@>"
 346                        :format-arguments (list (describe-action) symbol new-value spec)
 347                        :datum new-value
 348                        :expected-type spec))))))))
 349   (values))