Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[5d4902]: src / code / symbol.lisp Maximize Restore History

Download this file

symbol.lisp    262 lines (227 with data), 8.9 kB

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