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 (defun boundp (symbol)
  27   #!+sb-doc
  28   "Return non-NIL if SYMBOL is bound to a value."
  29   (boundp symbol))
  30
  31 (defun set (symbol new-value)
  32   #!+sb-doc
  33   "Set SYMBOL's value cell to NEW-VALUE."
  34   (declare (type symbol symbol))
  35   (about-to-modify-symbol-value symbol)
  36   (%set-symbol-value symbol new-value))
  37
  38 (defun %set-symbol-value (symbol new-value)
  39   (%set-symbol-value symbol new-value))
  40
  41 (defun makunbound (symbol)
  42   #!+sb-doc
  43   "Make SYMBOL unbound, removing any value it may currently have."
  44   (with-single-package-locked-error (:symbol symbol "unbinding the symbol ~A")
  45     (set symbol
  46          (%primitive sb!c:make-other-immediate-type
  47                      0
  48                      sb!vm:unbound-marker-widetag))
  49     symbol))
  50
  51 ;;; Return the built-in hash value for SYMBOL.
  52 (defun symbol-hash (symbol)
  53   (symbol-hash symbol))
  54
  55 (defun symbol-function (symbol)
  56   #!+sb-doc
  57   "Return SYMBOL's current function definition. Settable with SETF."
  58   (%coerce-name-to-fun symbol))
  59
  60 (defun (setf symbol-function) (new-value symbol)
  61   (declare (type symbol symbol) (type function new-value))
  62   (with-single-package-locked-error
  63       (:symbol symbol "setting the symbol-function of ~A")
  64     (setf (%coerce-name-to-fun symbol) new-value)))
  65
  66 (defun symbol-plist (symbol)
  67   #!+sb-doc
  68   "Return SYMBOL's property list."
  69   (symbol-plist symbol))
  70
  71 (defun %set-symbol-plist (symbol new-value)
  72   (setf (symbol-plist symbol) new-value))
  73
  74 (defun symbol-name (symbol)
  75   #!+sb-doc
  76   "Return SYMBOL's name as a string."
  77   (symbol-name symbol))
  78
  79 (defun symbol-package (symbol)
  80   #!+sb-doc
  81   "Return the package SYMBOL was interned in, or NIL if none."
  82   (symbol-package symbol))
  83
  84 (defun %set-symbol-package (symbol package)
  85   (declare (type symbol symbol))
  86   (%set-symbol-package symbol package))
  87
  88 (defun make-symbol (string)
  89   #!+sb-doc
  90   "Make and return a new symbol with the STRING as its print name."
  91   (declare (type string string))
  92   (%make-symbol (if (simple-string-p string)
  93                     string
  94                     (subseq string 0))))
  95
  96 (defun get (symbol indicator &optional (default nil))
  97   #!+sb-doc
  98   "Look on the property list of SYMBOL for the specified INDICATOR. If this
  99   is found, return the associated value, else return DEFAULT."
 100   (get3 symbol indicator default))
 101
 102 (defun get2 (symbol indicator)
 103   (get3 symbol indicator nil))
 104 #|
 105   (let (cdr-pl)
 106     (do ((pl (symbol-plist symbol) (cdr cdr-pl)))
 107         ((atom pl) nil)
 108       (setf cdr-pl (cdr pl))
 109       (cond ((atom cdr-pl)
 110              (error "~S has an odd number of items in its property list."
 111                     symbol))
 112             ((eq (car pl) indicator)
 113              (return (car cdr-pl)))))))
 114 |#
 115
 116 (defun get3 (symbol indicator default)
 117   (let (cdr-pl)
 118     (do ((pl (symbol-plist symbol) (cdr cdr-pl)))
 119         ((atom pl) default)
 120       (setq cdr-pl (cdr pl))
 121       (cond ((atom cdr-pl)
 122              (error "~S has an odd number of items in its property list."
 123                     symbol))
 124             ((eq (car pl) indicator)
 125              (return (car cdr-pl)))))))
 126
 127 (defun %put (symbol indicator value)
 128   #!+sb-doc
 129   "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
 130   Returns VALUE."
 131   (do ((pl (symbol-plist symbol) (cddr pl)))
 132       ((endp pl)
 133        (setf (symbol-plist symbol)
 134              (list* indicator value (symbol-plist symbol)))
 135        value)
 136     (cond ((endp (cdr pl))
 137            (error "~S has an odd number of items in its property list."
 138                   symbol))
 139           ((eq (car pl) indicator)
 140            (rplaca (cdr pl) value)
 141            (return value)))))
 142
 143 (defun remprop (symbol indicator)
 144   #!+sb-doc
 145   "Look on property list of SYMBOL for property with specified
 146   INDICATOR. If found, splice this indicator and its value out of
 147   the plist, and return the tail of the original list starting with
 148   INDICATOR. If not found, return () with no side effects.
 149
 150   NOTE: The ANSI specification requires REMPROP to return true (not false)
 151   or false (the symbol NIL). Portable code should not rely on any other value."
 152   (do ((pl (symbol-plist symbol) (cddr pl))
 153        (prev nil pl))
 154       ((atom pl) nil)
 155     (cond ((atom (cdr pl))
 156            (error "~S has an odd number of items in its property list."
 157                   symbol))
 158           ((eq (car pl) indicator)
 159            (cond (prev (rplacd (cdr prev) (cddr pl)))
 160                  (t
 161                   (setf (symbol-plist symbol) (cddr pl))))
 162            (return pl)))))
 163
 164 (defun getf (place indicator &optional (default ()))
 165   #!+sb-doc
 166   "Search the property list stored in Place for an indicator EQ to INDICATOR.
 167   If one is found, return the corresponding value, else return DEFAULT."
 168   (do ((plist place (cddr plist)))
 169       ((null plist) default)
 170     (cond ((atom (cdr plist))
 171            (error 'simple-type-error
 172                   :format-control "malformed property list: ~S."
 173                   :format-arguments (list place)
 174                   :datum (cdr plist)
 175                   :expected-type 'cons))
 176           ((eq (car plist) indicator)
 177            (return (cadr plist))))))
 178
 179 (defun %putf (place property new-value)
 180   (declare (type list place))
 181   (do ((plist place (cddr plist)))
 182       ((endp plist) (list* property new-value place))
 183     (declare (type list plist))
 184     (when (eq (car plist) property)
 185       (setf (cadr plist) new-value)
 186       (return place))))
 187
 188 (defun get-properties (place indicator-list)
 189   #!+sb-doc
 190   "Like GETF, except that INDICATOR-LIST is a list of indicators which will
 191   be looked for in the property list stored in PLACE. Three values are
 192   returned, see manual for details."
 193   (do ((plist place (cddr plist)))
 194       ((null plist) (values nil nil nil))
 195     (cond ((atom (cdr plist))
 196            (error 'simple-type-error
 197                   :format-control "malformed property list: ~S."
 198                   :format-arguments (list place)
 199                   :datum (cdr plist)
 200                   :expected-type 'cons))
 201           ((memq (car plist) indicator-list)
 202            (return (values (car plist) (cadr plist) plist))))))
 203
 204 (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
 205   #!+sb-doc
 206   "Make and return a new uninterned symbol with the same print name
 207   as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound
 208   nor fbound and has no properties, else it has a copy of SYMBOL's
 209   function, value and property list."
 210   (declare (type symbol symbol))
 211   (setq new-symbol (make-symbol (symbol-name symbol)))
 212   (when copy-props
 213     (%set-symbol-value new-symbol
 214                        (%primitive sb!c:fast-symbol-value symbol))
 215     (setf (symbol-plist new-symbol)
 216           (copy-list (symbol-plist symbol)))
 217     (when (fboundp symbol)
 218       (setf (symbol-function new-symbol) (symbol-function symbol))))
 219   new-symbol)
 220
 221 ;;; FIXME: This declaration should be redundant.
 222 (declaim (special *keyword-package*))
 223
 224 (defun keywordp (object)
 225   #!+sb-doc
 226   "Return true if Object is a symbol in the \"KEYWORD\" package."
 227   (and (symbolp object)
 228        (eq (symbol-package object) *keyword-package*)))
 229 \f
 230 ;;;; GENSYM and friends
 231
 232 (defvar *gensym-counter* 0
 233   #!+sb-doc
 234   "counter for generating unique GENSYM symbols")
 235 (declaim (type unsigned-byte *gensym-counter*))
 236
 237 (defun gensym (&optional (thing "G"))
 238   #!+sb-doc
 239   "Creates a new uninterned symbol whose name is a prefix string (defaults
 240    to \"G\"), followed by a decimal number. Thing, when supplied, will
 241    alter the prefix if it is a string, or be used for the decimal number
 242    if it is a number, of this symbol. The default value of the number is
 243    the current value of *gensym-counter* which is incremented each time
 244    it is used."
 245   (let ((old *gensym-counter*))
 246     (unless (numberp thing)
 247       (let ((new (etypecase old
 248                    (index (1+ old))
 249                    (unsigned-byte (1+ old)))))
 250         (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
 251         (setq *gensym-counter* new)))
 252     (multiple-value-bind (prefix int)
 253         (etypecase thing
 254           (simple-string (values thing old))
 255           (fixnum (values "G" thing))
 256           (string (values (coerce thing 'simple-string) old)))
 257       (declare (simple-string prefix))
 258       (make-symbol
 259        (concatenate 'simple-string prefix
 260                     (the simple-string
 261                          (quick-integer-to-string int)))))))
 262
 263 (defvar *gentemp-counter* 0)
 264 (declaim (type unsigned-byte *gentemp-counter*))
 265
 266 (defun gentemp (&optional (prefix "T") (package (sane-package)))
 267   #!+sb-doc
 268   "Creates a new symbol interned in package PACKAGE with the given PREFIX."
 269   (declare (type string prefix))
 270   (loop
 271     (let ((*print-base* 10)
 272           (*print-radix* nil)
 273           (*print-pretty* nil)
 274           (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*))))
 275       (multiple-value-bind (symbol existsp) (find-symbol new-pname package)
 276         (declare (ignore symbol))
 277         (unless existsp (return (values (intern new-pname package))))))))