1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
26 (defmacro slot-symbol (slot-name type)
27 `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
28 (or (get ,slot-name ',(ecase type
29 (reader 'reader-symbol)
30 (writer 'writer-symbol)
31 (boundp 'boundp-symbol)))
32 (intern (format nil "~A ~A slot ~A"
33 (package-name (symbol-package ,slot-name))
34 (symbol-name ,slot-name)
36 *slot-accessor-name-package*))
38 (error "Non-symbol and non-interned symbol slot name accessors~
39 are not yet implemented.")
40 ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
43 (defun slot-reader-symbol (slot-name)
44 (slot-symbol slot-name reader))
46 (defun slot-writer-symbol (slot-name)
47 (slot-symbol slot-name writer))
49 (defun slot-boundp-symbol (slot-name)
50 (slot-symbol slot-name boundp))
52 (defmacro asv-funcall (sym slot-name type &rest args)
53 (declare (ignore type))
56 (no-slot ',sym ',slot-name)))
58 (defun no-slot (sym slot-name)
59 (error "No class has a slot named ~S (~S has no function binding)."
62 (defmacro accessor-slot-value (object slot-name)
63 (unless (constantp slot-name)
64 (error "~S requires its slot-name argument to be a constant"
65 'accessor-slot-value))
66 (let* ((slot-name (eval slot-name))
67 (sym (slot-reader-symbol slot-name)))
68 `(asv-funcall ,sym ,slot-name reader ,object)))
70 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
71 (unless (constantp slot-name)
72 (error "~S requires its slot-name argument to be a constant"
73 'accessor-set-slot-value))
74 (setq object (macroexpand object env))
75 (setq slot-name (macroexpand slot-name env))
76 (let* ((slot-name (eval slot-name))
77 (bindings (unless (or (constantp new-value) (atom new-value))
78 (let ((object-var (gensym)))
79 (prog1 `((,object-var ,object))
80 (setq object object-var)))))
81 (sym (slot-writer-symbol slot-name))
82 (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
84 `(let ,bindings ,form)
87 (defconstant *optimize-slot-boundp* nil)
89 (defmacro accessor-slot-boundp (object slot-name)
90 (unless (constantp slot-name)
91 (error "~S requires its slot-name argument to be a constant"
92 'accessor-slot-boundp))
93 (let* ((slot-name (eval slot-name))
94 (sym (slot-boundp-symbol slot-name)))
95 (if (not *optimize-slot-boundp*)
96 `(slot-boundp-normal ,object ',slot-name)
97 `(asv-funcall ,sym ,slot-name boundp ,object))))
99 (defun structure-slot-boundp (object)
100 (declare (ignore object))
103 (defun make-structure-slot-boundp-function (slotd)
104 (let* ((reader (slot-definition-internal-reader-function slotd))
105 (fun #'(lambda (object)
106 (not (eq (funcall reader object) *slot-unbound*)))))
107 (declare (type function reader))
110 (defun get-optimized-std-accessor-method-function (class slotd name)
111 (if (structure-class-p class)
113 (reader (slot-definition-internal-reader-function slotd))
114 (writer (slot-definition-internal-writer-function slotd))
115 (boundp (make-structure-slot-boundp-function slotd)))
116 (let* ((fsc-p (cond ((standard-class-p class) nil)
117 ((funcallable-standard-class-p class) t)
119 ;; Shouldn't be using the optimized-std-accessors
121 #+nil (format t "* warning: ~S ~S~% ~S~%"
124 (t (error "~S is not a STANDARD-CLASS." class))))
125 (slot-name (slot-definition-name slotd))
126 (index (slot-definition-location slotd))
127 (function (ecase name
128 (reader #'make-optimized-std-reader-method-function)
129 (writer #'make-optimized-std-writer-method-function)
130 (boundp #'make-optimized-std-boundp-method-function)))
131 (value (funcall function fsc-p slot-name index)))
132 (declare (type function function))
133 (values value index))))
135 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
136 (declare #.*optimize-speed*)
141 (let ((value (%instance-ref (fsc-instance-slots instance) index)))
142 (if (eq value *slot-unbound*)
143 (slot-unbound (class-of instance) instance slot-name)
146 (let ((value (%instance-ref (std-instance-slots instance) index)))
147 (if (eq value *slot-unbound*)
148 (slot-unbound (class-of instance) instance slot-name)
150 (cons #'(lambda (instance)
151 (let ((value (cdr index)))
152 (if (eq value *slot-unbound*)
153 (slot-unbound (class-of instance) instance slot-name)
155 `(reader ,slot-name)))
157 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
158 (declare #.*optimize-speed*)
162 #'(lambda (nv instance)
163 (setf (%instance-ref (fsc-instance-slots instance) index) nv))
164 #'(lambda (nv instance)
165 (setf (%instance-ref (std-instance-slots instance) index) nv))))
166 (cons #'(lambda (nv instance)
167 (declare (ignore instance))
168 (setf (cdr index) nv))))
169 `(writer ,slot-name)))
171 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
172 (declare #.*optimize-speed*)
177 (not (eq (%instance-ref (fsc-instance-slots instance)
181 (not (eq (%instance-ref (std-instance-slots instance)
184 (cons #'(lambda (instance)
185 (declare (ignore instance))
186 (not (eq (cdr index) *slot-unbound*)))))
187 `(boundp ,slot-name)))
189 (defun make-optimized-structure-slot-value-using-class-method-function (function)
190 (declare (type function function))
191 #'(lambda (class object slotd)
192 (let ((value (funcall function object)))
193 (if (eq value *slot-unbound*)
194 (slot-unbound class object (slot-definition-name slotd))
197 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
198 (declare (type function function))
199 #'(lambda (nv class object slotd)
200 (declare (ignore class slotd))
201 (funcall function nv object)))
203 (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
204 (declare (type function function))
205 #'(lambda (class object slotd)
206 (declare (ignore class slotd))
207 (not (eq (funcall function object) *slot-unbound*))))
209 (defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
210 (if (structure-class-p class)
212 (reader (make-optimized-structure-slot-value-using-class-method-function
213 (slot-definition-internal-reader-function slotd)))
214 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
215 (slot-definition-internal-writer-function slotd)))
216 (boundp (make-optimized-structure-slot-boundp-using-class-method-function
217 (slot-definition-internal-writer-function slotd))))
218 (let* ((fsc-p (cond ((standard-class-p class) nil)
219 ((funcallable-standard-class-p class) t)
220 (t (error "~S is not a standard-class" class))))
221 (slot-name (slot-definition-name slotd))
222 (index (slot-definition-location slotd))
226 #'make-optimized-std-slot-value-using-class-method-function)
228 #'make-optimized-std-setf-slot-value-using-class-method-function)
230 #'make-optimized-std-slot-boundp-using-class-method-function))))
231 (declare (type function function))
232 (values (funcall function fsc-p slot-name index) index))))
234 (defun make-optimized-std-slot-value-using-class-method-function
235 (fsc-p slot-name index)
236 (declare #.*optimize-speed*)
239 #'(lambda (class instance slotd)
240 (declare (ignore slotd))
241 (unless (fsc-instance-p instance) (error "not fsc"))
242 (let ((value (%instance-ref (fsc-instance-slots instance) index)))
243 (if (eq value *slot-unbound*)
244 (slot-unbound class instance slot-name)
246 #'(lambda (class instance slotd)
247 (declare (ignore slotd))
248 (unless (std-instance-p instance) (error "not std"))
249 (let ((value (%instance-ref (std-instance-slots instance) index)))
250 (if (eq value *slot-unbound*)
251 (slot-unbound class instance slot-name)
253 (cons #'(lambda (class instance slotd)
254 (declare (ignore slotd))
255 (let ((value (cdr index)))
256 (if (eq value *slot-unbound*)
257 (slot-unbound class instance slot-name)
260 (defun make-optimized-std-setf-slot-value-using-class-method-function
261 (fsc-p slot-name index)
262 (declare #.*optimize-speed*)
263 (declare (ignore slot-name))
266 #'(lambda (nv class instance slotd)
267 (declare (ignore class slotd))
268 (setf (%instance-ref (fsc-instance-slots instance) index) nv))
269 #'(lambda (nv class instance slotd)
270 (declare (ignore class slotd))
271 (setf (%instance-ref (std-instance-slots instance) index) nv))))
272 (cons #'(lambda (nv class instance slotd)
273 (declare (ignore class instance slotd))
274 (setf (cdr index) nv)))))
276 (defun make-optimized-std-slot-boundp-using-class-method-function
277 (fsc-p slot-name index)
278 (declare #.*optimize-speed*)
279 (declare (ignore slot-name))
282 #'(lambda (class instance slotd)
283 (declare (ignore class slotd))
284 (not (eq (%instance-ref (fsc-instance-slots instance)
287 #'(lambda (class instance slotd)
288 (declare (ignore class slotd))
289 (not (eq (%instance-ref (std-instance-slots instance)
292 (cons #'(lambda (class instance slotd)
293 (declare (ignore class instance slotd))
294 (not (eq (cdr index) *slot-unbound*))))))
296 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
297 (macrolet ((emf-funcall (emf &rest args)
298 `(invoke-effective-method-function ,emf nil ,@args)))
301 (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
302 (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
303 (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
304 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
306 (defun make-internal-reader-method-function (class-name slot-name)
307 (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
308 (make-method-function
310 (let ((wrapper (get-instance-wrapper-or-nil instance)))
312 (let* ((class (wrapper-class* wrapper))
313 (index (or (instance-slot-index wrapper slot-name)
314 (assq slot-name (wrapper-class-slots wrapper)))))
317 (let ((value (%instance-ref (get-slots instance) index)))
318 (if (eq value *slot-unbound*)
319 (slot-unbound (class-of instance) instance slot-name)
322 (let ((value (cdr index)))
323 (if (eq value *slot-unbound*)
324 (slot-unbound (class-of instance) instance slot-name)
327 (error "The wrapper for class ~S does not have the slot ~S"
329 (slot-value instance slot-name)))))))
331 (defun make-std-reader-method-function (class-name slot-name)
332 (let* ((pv-table-symbol (gensym))
334 (make-method-function
336 (pv-binding1 (.pv. .calls.
337 (symbol-value pv-table-symbol)
338 (instance) (instance-slots))
339 (instance-read-internal
340 .pv. instance-slots 1
341 (slot-value instance slot-name))))))))
342 (setf (getf (getf initargs ':plist) ':slot-name-lists)
343 (list (list nil slot-name)))
344 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
345 (list* ':method-spec `(reader-method ,class-name ,slot-name)
348 (defun make-std-writer-method-function (class-name slot-name)
349 (let* ((pv-table-symbol (gensym))
351 (make-method-function
352 (lambda (nv instance)
353 (pv-binding1 (.pv. .calls.
354 (symbol-value pv-table-symbol)
355 (instance) (instance-slots))
356 (instance-write-internal
357 .pv. instance-slots 1 nv
358 (setf (slot-value instance slot-name) nv))))))))
359 (setf (getf (getf initargs ':plist) ':slot-name-lists)
360 (list nil (list nil slot-name)))
361 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
362 (list* ':method-spec `(writer-method ,class-name ,slot-name)
365 (defun make-std-boundp-method-function (class-name slot-name)
366 (let* ((pv-table-symbol (gensym))
368 (make-method-function
370 (pv-binding1 (.pv. .calls.
371 (symbol-value pv-table-symbol)
372 (instance) (instance-slots))
373 (instance-boundp-internal
374 .pv. instance-slots 1
375 (slot-boundp instance slot-name))))))))
376 (setf (getf (getf initargs ':plist) ':slot-name-lists)
377 (list (list nil slot-name)))
378 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
379 (list* ':method-spec `(boundp-method ,class-name ,slot-name)
382 (defun initialize-internal-slot-gfs (slot-name &optional type)
383 (when (or (null type) (eq type 'reader))
384 (let* ((name (slot-reader-symbol slot-name))
385 (gf (ensure-generic-function name)))
386 (unless (generic-function-methods gf)
387 (add-reader-method *the-class-slot-object* gf slot-name))))
388 (when (or (null type) (eq type 'writer))
389 (let* ((name (slot-writer-symbol slot-name))
390 (gf (ensure-generic-function name)))
391 (unless (generic-function-methods gf)
392 (add-writer-method *the-class-slot-object* gf slot-name))))
393 (when (and *optimize-slot-boundp*
394 (or (null type) (eq type 'boundp)))
395 (let* ((name (slot-boundp-symbol slot-name))
396 (gf (ensure-generic-function name)))
397 (unless (generic-function-methods gf)
398 (add-boundp-method *the-class-slot-object* gf slot-name))))
401 (defun initialize-internal-slot-gfs* (readers writers boundps)
402 (dolist (reader readers)
403 (initialize-internal-slot-gfs reader 'reader))
404 (dolist (writer writers)
405 (initialize-internal-slot-gfs writer 'writer))
406 (dolist (boundp boundps)
407 (initialize-internal-slot-gfs boundp 'boundp)))