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