/[cmucl]/src/code/symbol.lisp
ViewVC logotype

Contents of /src/code/symbol.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.45 - (show annotations)
Tue Apr 20 17:57:45 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.44: +9 -9 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Log: code.log; Package: Lisp -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/symbol.lisp,v 1.45 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Symbol manipulating functions for Spice Lisp.
13 ;;;
14 ;;; Written by Scott Fahlman.
15 ;;; Hacked on and maintained by Skef Wholey.
16 ;;;
17 ;;; Many of these are trivial interpreter entries to functions
18 ;;; open-coded by the compiler.
19 ;;;
20 (in-package "LISP")
21 (intl:textdomain "cmucl")
22
23 (export '(get remprop symbol-plist getf get-properties symbol-name
24 make-symbol copy-symbol gensym gentemp *gensym-counter*
25 symbol-package keywordp makunbound symbol-value symbol-function
26 boundp set))
27
28 (in-package "KERNEL")
29 (export '(%set-symbol-value %set-symbol-plist %set-symbol-package fset))
30
31 (in-package "LISP")
32
33 (declaim (maybe-inline get %put getf remprop %putf get-properties keywordp))
34
35 (defun symbol-value (variable)
36 "VARIABLE must evaluate to a symbol. This symbol's current special
37 value is returned."
38 (declare (optimize (safety 1)))
39 (symbol-value variable))
40
41 (defun boundp (variable)
42 "VARIABLE must evaluate to a symbol. Return NIL if this symbol is
43 unbound, T if it has a value."
44 (boundp variable))
45
46 (defun set (variable new-value)
47 "VARIABLE must evaluate to a symbol. This symbol's special value cell is
48 set to the specified new value."
49 (declare (type symbol variable))
50 (cond ((null variable)
51 (simple-program-error (intl:gettext "Nihil ex nihil, can't set NIL.")))
52 ((eq variable t)
53 (simple-program-error (intl:gettext "Veritas aeterna, can't set T.")))
54 ((and (boundp '*keyword-package*)
55 (keywordp variable))
56 (simple-program-error (intl:gettext "Can't set keywords.")))
57 (t
58 (%set-symbol-value variable new-value))))
59
60 (defun %set-symbol-value (symbol new-value)
61 (%set-symbol-value symbol new-value))
62
63 (defun makunbound (variable)
64 "VARIABLE must evaluate to a symbol. This symbol is made unbound,
65 removing any value it may currently have."
66 (set variable
67 (%primitive make-other-immediate-type 0 vm:unbound-marker-type))
68 variable)
69
70 (defun symbol-function (variable)
71 "VARIABLE must evaluate to a symbol. This symbol's current definition
72 is returned. Settable with SETF."
73 (raw-definition variable))
74
75 (defun fset (symbol new-value)
76 (declare (type symbol symbol) (type function new-value))
77 (setf (raw-definition symbol) new-value))
78
79
80 (defun symbol-plist (variable)
81 "VARIABLE must evaluate to a symbol. Return its property list."
82 (symbol-plist variable))
83
84 (defun %set-symbol-plist (symbol new-value)
85 (setf (symbol-plist symbol) new-value))
86
87 (defun symbol-name (variable)
88 "VARIABLE must evaluate to a symbol. Return its print name."
89 (symbol-name variable))
90
91 (defun symbol-package (variable)
92 "VARIABLE must evaluate to a symbol. Return its package."
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 "Make and return a new symbol with the STRING as its print name."
101 #-(or gengc x86 amd64 sparc ppc) (make-symbol string)
102 #+gengc (%make-symbol (random most-positive-fixnum) string)
103 ;; Initialize the symbol-hash to -1 to make this fast. It will get
104 ;; computed correctly later on.
105 #+(or sparc x86 amd64 ppc )
106 (%make-symbol -1 (coerce #-unicode string
107 #+unicode (string-to-nfc string)
108 'simple-string)))
109
110 #+(or gengc x86 amd64 sparc ppc)
111 (defun symbol-hash (symbol)
112 "Return the hash value for symbol."
113 (symbol-hash symbol))
114
115 #+(or sparc ppc)
116 (defun (setf symbol-hash) (symbol hash)
117 (kernel::%set-symbol-hash symbol hash))
118
119 (defun get (symbol indicator &optional (default nil))
120 "Look on the property list of SYMBOL for the specified INDICATOR. If this
121 is found, return the associated value, else return DEFAULT."
122 (do ((pl (symbol-plist symbol) (cddr pl)))
123 ((atom pl) default)
124 (cond ((atom (cdr pl))
125 (simple-program-error
126 (intl:gettext "~S has an odd number of items in its property list.") symbol))
127 ((eq (car pl) indicator)
128 (return (cadr pl))))))
129
130 (defun %put (symbol indicator value)
131 "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
132 Returns VALUE."
133 (do ((pl (symbol-plist symbol) (cddr pl)))
134 ((endp pl)
135 (setf (symbol-plist symbol)
136 (list* indicator value (symbol-plist symbol)))
137 value)
138 (cond ((endp (cdr pl))
139 (simple-program-error
140 (intl:gettext "~S has an odd number of items in its property list.") symbol))
141 ((eq (car pl) indicator)
142 (rplaca (cdr pl) value)
143 (return value)))))
144
145 (defun remprop (symbol indicator)
146 "Look on property list of SYMBOL for property with specified
147 INDICATOR. If found, splice this indicator and its value out of
148 the plist, and return the tail of the original list starting with
149 INDICATOR. If not found, return () with no side effects.
150
151 NOTE: The ANSI specification requires REMPROP to return true (not false)
152 or false (the symbol NIL). Portable code should not rely on any other value."
153 (do ((pl (symbol-plist symbol) (cddr pl))
154 (prev nil pl))
155 ((atom pl) nil)
156 (cond ((atom (cdr pl))
157 (simple-program-error
158 (intl:gettext "~S has an odd number of items in its property list.") symbol))
159 ((eq (car pl) indicator)
160 (cond (prev (rplacd (cdr prev) (cddr pl)))
161 (t
162 (setf (symbol-plist symbol) (cddr pl))))
163 (return pl)))))
164
165 (defun valid-property-list-p (list)
166 (let ((result (proper-list-p list)))
167 (and result (evenp result))))
168
169 (defun getf (place indicator &optional (default ()))
170 "Searches the property list stored in Place for an indicator EQ to Indicator.
171 If one is found, the corresponding value is returned, else the Default is
172 returned."
173 (do ((plist place (cddr plist)))
174 ((null plist) default)
175 (cond ((atom (cdr plist))
176 (error 'simple-type-error
177 :datum place
178 :expected-type '(satisfies valid-property-list-p)
179 :format-control (intl:gettext "Malformed property list: ~S")
180 :format-arguments (list place)))
181 ((eq (car plist) indicator)
182 (return (cadr plist))))))
183
184 (defun %putf (place property new-value)
185 (declare (type list place))
186 (do ((plist place (cddr plist)))
187 ((endp plist) (list* property new-value place))
188 (declare (type list plist))
189 (when (eq (car plist) property)
190 (setf (cadr plist) new-value)
191 (return place))))
192
193
194 (defun get-properties (place indicator-list)
195 "Like GETF, except that Indicator-List is a list of indicators which will
196 be looked for in the property list stored in Place. Three values are
197 returned, see manual for details."
198 (do ((plist place (cddr plist)))
199 ((null plist) (values nil nil nil))
200 (cond ((atom (cdr plist))
201 (error 'simple-type-error
202 :datum place
203 :expected-type '(satisfies valid-property-list-p)
204 :format-control (intl:gettext "Malformed property list: ~S")
205 :format-arguments (list place)))
206 ((memq (car plist) indicator-list)
207 (return (values (car plist) (cadr plist) plist))))))
208
209 (defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
210 "Make and return a new uninterned symbol with the same print name
211 as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound
212 nor fbound and has no properties, else it has a copy of SYMBOL's
213 function, value and property list."
214 (declare (type symbol symbol))
215 (setq new-symbol (make-symbol (symbol-name symbol)))
216 (when copy-props
217 (%set-symbol-value new-symbol (%primitive fast-symbol-value symbol))
218 (setf (symbol-plist new-symbol) (copy-list (symbol-plist symbol)))
219 (when (fboundp symbol)
220 (setf (symbol-function new-symbol) (symbol-function symbol))))
221 new-symbol)
222
223 (declaim (special *keyword-package*))
224
225 (defun keywordp (object)
226 "Returns true if Object is a symbol in the keyword package."
227 (and (symbolp object)
228 (eq (symbol-package object) *keyword-package*)))
229
230
231 ;;;; Gensym and friends.
232
233 (defvar *gensym-counter* 0
234 "Counter for generating unique GENSYM symbols.")
235 (declaim (type unsigned-byte *gensym-counter*))
236
237 (defun gensym (&optional (thing "G"))
238 "Creates a new uninterned symbol whose name is a prefix string (defaults
239 to \"G\"), followed by a decimal number. Thing, when supplied, will
240 alter the prefix if it is a string, or be used for the decimal number
241 if it is a number, of this symbol. The default value of the number is
242 the current value of *gensym-counter* which is incremented each time
243 it is used."
244 (let ((old *gensym-counter*))
245 (unless (numberp thing)
246 (let ((new (etypecase old
247 (index (1+ old))
248 (unsigned-byte (1+ old)))))
249 (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
250 (setq *gensym-counter* new)))
251 (multiple-value-bind
252 (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 index *gentemp-counter*))
265
266 (defun gentemp (&optional (prefix "T") (package *package*))
267 "Creates a new symbol interned in package Package with the given Prefix."
268 (loop
269 (let* ((*print-base* 10)
270 (*print-radix* nil)
271 (*print-pretty* nil)
272 (new-pname (format nil "~A~D"
273 prefix (incf *gentemp-counter*))))
274 (multiple-value-bind (symbol existsp)
275 (find-symbol new-pname package)
276 (declare (ignore symbol))
277 (unless existsp (return (values (intern new-pname package))))))))

  ViewVC Help
Powered by ViewVC 1.1.5