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