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 (defmacro accessor-slot-boundp (object slot-name)
88 (unless (constantp slot-name)
89 (error "~S requires its slot-name argument to be a constant"
90 'accessor-slot-boundp))
91 (let ((slot-name (eval slot-name)))
92 `(slot-boundp-normal ,object ',slot-name)))
94 (defun structure-slot-boundp (object)
95 (declare (ignore object))
98 (defun make-structure-slot-boundp-function (slotd)
99 (let* ((reader (slot-definition-internal-reader-function slotd))
100 (fun #'(lambda (object)
101 (not (eq (funcall reader object) +slot-unbound+)))))
102 (declare (type function reader))
105 (defun get-optimized-std-accessor-method-function (class slotd name)
106 (if (structure-class-p class)
108 (reader (slot-definition-internal-reader-function slotd))
109 (writer (slot-definition-internal-writer-function slotd))
110 (boundp (make-structure-slot-boundp-function slotd)))
111 (let* ((fsc-p (cond ((standard-class-p class) nil)
112 ((funcallable-standard-class-p class) t)
114 ;; Shouldn't be using the optimized-std-accessors
116 #+nil (format t "* warning: ~S ~S~% ~S~%"
119 (t (error "~S is not a STANDARD-CLASS." class))))
120 (slot-name (slot-definition-name slotd))
121 (index (slot-definition-location slotd))
122 (function (ecase name
123 (reader #'make-optimized-std-reader-method-function)
124 (writer #'make-optimized-std-writer-method-function)
125 (boundp #'make-optimized-std-boundp-method-function)))
126 (value (funcall function fsc-p slot-name index)))
127 (declare (type function function))
128 (values value index))))
130 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
131 (declare #.*optimize-speed*)
136 (let ((value (clos-slots-ref (fsc-instance-slots instance)
138 (if (eq value +slot-unbound+)
139 (slot-unbound (class-of instance) instance slot-name)
142 (let ((value (clos-slots-ref (std-instance-slots instance)
144 (if (eq value +slot-unbound+)
145 (slot-unbound (class-of instance) instance slot-name)
147 (cons (lambda (instance)
148 (let ((value (cdr index)))
149 (if (eq value +slot-unbound+)
150 (slot-unbound (class-of instance) instance slot-name)
152 `(reader ,slot-name)))
154 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
155 (declare #.*optimize-speed*)
159 (lambda (nv instance)
160 (setf (clos-slots-ref (fsc-instance-slots instance) index)
162 (lambda (nv instance)
163 (setf (clos-slots-ref (std-instance-slots instance) index)
165 (cons (lambda (nv instance)
166 (declare (ignore instance))
167 (setf (cdr index) nv))))
168 `(writer ,slot-name)))
170 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
171 (declare #.*optimize-speed*)
176 (not (eq (clos-slots-ref (fsc-instance-slots instance)
180 (not (eq (clos-slots-ref (std-instance-slots instance)
183 (cons #'(lambda (instance)
184 (declare (ignore instance))
185 (not (eq (cdr index) +slot-unbound+)))))
186 `(boundp ,slot-name)))
188 (defun make-optimized-structure-slot-value-using-class-method-function (function)
189 (declare (type function function))
190 (lambda (class object slotd)
191 (let ((value (funcall function object)))
192 (if (eq value +slot-unbound+)
193 (slot-unbound class object (slot-definition-name slotd))
196 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
197 (declare (type function function))
198 #'(lambda (nv class object slotd)
199 (declare (ignore class slotd))
200 (funcall function nv object)))
202 (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
203 (declare (type function function))
204 #'(lambda (class object slotd)
205 (declare (ignore class slotd))
206 (not (eq (funcall function object) +slot-unbound+))))
208 (defun get-optimized-std-slot-value-using-class-method-function (class
211 (if (structure-class-p class)
213 (reader (make-optimized-structure-slot-value-using-class-method-function
214 (slot-definition-internal-reader-function slotd)))
215 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
216 (slot-definition-internal-writer-function slotd)))
217 (boundp (make-optimized-structure-slot-boundp-using-class-method-function
218 (slot-definition-internal-writer-function slotd))))
219 (let* ((fsc-p (cond ((standard-class-p class) nil)
220 ((funcallable-standard-class-p class) t)
221 (t (error "~S is not a standard-class" class))))
222 (slot-name (slot-definition-name slotd))
223 (index (slot-definition-location slotd))
227 #'make-optimized-std-slot-value-using-class-method-function)
229 #'make-optimized-std-setf-slot-value-using-class-method-function)
231 #'make-optimized-std-slot-boundp-using-class-method-function))))
232 (declare (type function function))
233 (values (funcall function fsc-p slot-name index) index))))
235 (defun make-optimized-std-slot-value-using-class-method-function
236 (fsc-p slot-name index)
237 (declare #.*optimize-speed*)
240 (lambda (class instance slotd)
241 (declare (ignore slotd))
242 (unless (fsc-instance-p instance) (error "not fsc"))
243 (let ((value (clos-slots-ref (fsc-instance-slots instance)
245 (if (eq value +slot-unbound+)
246 (slot-unbound class instance slot-name)
248 (lambda (class instance slotd)
249 (declare (ignore slotd))
250 (unless (std-instance-p instance) (error "not std"))
251 (let ((value (clos-slots-ref (std-instance-slots instance)
253 (if (eq value +slot-unbound+)
254 (slot-unbound class instance slot-name)
256 (cons (lambda (class instance slotd)
257 (declare (ignore slotd))
258 (let ((value (cdr index)))
259 (if (eq value +slot-unbound+)
260 (slot-unbound class instance slot-name)
263 (defun make-optimized-std-setf-slot-value-using-class-method-function
264 (fsc-p slot-name index)
265 (declare #.*optimize-speed*)
266 (declare (ignore slot-name))
269 (lambda (nv class instance slotd)
270 (declare (ignore class slotd))
271 (setf (clos-slots-ref (fsc-instance-slots instance) index)
273 (lambda (nv class instance slotd)
274 (declare (ignore class slotd))
275 (setf (clos-slots-ref (std-instance-slots instance) index)
277 (cons (lambda (nv class instance slotd)
278 (declare (ignore class instance slotd))
279 (setf (cdr index) nv)))))
281 (defun make-optimized-std-slot-boundp-using-class-method-function
282 (fsc-p slot-name index)
283 (declare #.*optimize-speed*)
284 (declare (ignore slot-name))
287 (lambda (class instance slotd)
288 (declare (ignore class slotd))
289 (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
291 (lambda (class instance slotd)
292 (declare (ignore class slotd))
293 (not (eq (clos-slots-ref (std-instance-slots instance) index)
295 (cons (lambda (class instance slotd)
296 (declare (ignore class instance slotd))
297 (not (eq (cdr index) +slot-unbound+))))))
299 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
300 (macrolet ((emf-funcall (emf &rest args)
301 `(invoke-effective-method-function ,emf nil ,@args)))
304 (reader (lambda (instance)
305 (emf-funcall sdfun class instance slotd)))
306 (writer (lambda (nv instance)
307 (emf-funcall sdfun nv class instance slotd)))
308 (boundp (lambda (instance)
309 (emf-funcall sdfun class instance slotd))))
310 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
312 (defun make-internal-reader-method-function (class-name slot-name)
313 (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
314 (make-method-function
316 (let ((wrapper (get-instance-wrapper-or-nil instance)))
318 (let* ((class (wrapper-class* wrapper))
319 (index (or (instance-slot-index wrapper slot-name)
321 (wrapper-class-slots wrapper)))))
324 (let ((value (clos-slots-ref (get-slots instance)
326 (if (eq value +slot-unbound+)
327 (slot-unbound (class-of instance)
332 (let ((value (cdr index)))
333 (if (eq value +slot-unbound+)
334 (slot-unbound (class-of instance)
339 (error "~@<The wrapper for class ~S does not have ~
342 (slot-value instance slot-name)))))))
344 (defun make-std-reader-method-function (class-name slot-name)
345 (let* ((pv-table-symbol (gensym))
347 (make-method-function
349 (pv-binding1 (.pv. .calls.
350 (symbol-value pv-table-symbol)
351 (instance) (instance-slots))
352 (instance-read-internal
353 .pv. instance-slots 1
354 (slot-value instance slot-name))))))))
355 (setf (getf (getf initargs ':plist) ':slot-name-lists)
356 (list (list nil slot-name)))
357 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
358 (list* ':method-spec `(reader-method ,class-name ,slot-name)
361 (defun make-std-writer-method-function (class-name slot-name)
362 (let* ((pv-table-symbol (gensym))
364 (make-method-function
365 (lambda (nv instance)
366 (pv-binding1 (.pv. .calls.
367 (symbol-value pv-table-symbol)
368 (instance) (instance-slots))
369 (instance-write-internal
370 .pv. instance-slots 1 nv
371 (setf (slot-value instance slot-name) nv))))))))
372 (setf (getf (getf initargs ':plist) ':slot-name-lists)
373 (list nil (list nil slot-name)))
374 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
375 (list* ':method-spec `(writer-method ,class-name ,slot-name)
378 (defun make-std-boundp-method-function (class-name slot-name)
379 (let* ((pv-table-symbol (gensym))
381 (make-method-function
383 (pv-binding1 (.pv. .calls.
384 (symbol-value pv-table-symbol)
385 (instance) (instance-slots))
386 (instance-boundp-internal
387 .pv. instance-slots 1
388 (slot-boundp instance slot-name))))))))
389 (setf (getf (getf initargs ':plist) ':slot-name-lists)
390 (list (list nil slot-name)))
391 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
392 (list* ':method-spec `(boundp-method ,class-name ,slot-name)
395 (defun initialize-internal-slot-gfs (slot-name &optional type)
396 (when (or (null type) (eq type 'reader))
397 (let* ((name (slot-reader-symbol slot-name))
398 (gf (ensure-generic-function name)))
399 (unless (generic-function-methods gf)
400 (add-reader-method *the-class-slot-object* gf slot-name))))
401 (when (or (null type) (eq type 'writer))
402 (let* ((name (slot-writer-symbol slot-name))
403 (gf (ensure-generic-function name)))
404 (unless (generic-function-methods gf)
405 (add-writer-method *the-class-slot-object* gf slot-name))))
408 (defun initialize-internal-slot-gfs* (readers writers boundps)
409 (dolist (reader readers)
410 (initialize-internal-slot-gfs reader 'reader))
411 (dolist (writer writers)
412 (initialize-internal-slot-gfs writer 'writer))
413 (dolist (boundp boundps)
414 (initialize-internal-slot-gfs boundp 'boundp)))