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