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
29 (defmacro slot-symbol (slot-name type)
30 `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
31 (or (get ,slot-name ',(ecase type
32 (reader 'reader-symbol)
33 (writer 'writer-symbol)
34 (boundp 'boundp-symbol)))
35 (intern (format nil "~A ~A slot ~A"
36 (package-name (symbol-package ,slot-name))
37 (symbol-name ,slot-name)
39 *slot-accessor-name-package*))
41 (error "Non-symbol and non-interned symbol slot name accessors~
42 are not yet implemented.")
43 ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
46 (defun slot-reader-symbol (slot-name)
47 (slot-symbol slot-name reader))
49 (defun slot-writer-symbol (slot-name)
50 (slot-symbol slot-name writer))
52 (defun slot-boundp-symbol (slot-name)
53 (slot-symbol slot-name boundp))
55 (defmacro asv-funcall (sym slot-name type &rest args)
56 (declare (ignore type))
59 (no-slot ',sym ',slot-name)))
61 (defun no-slot (sym slot-name)
62 (error "No class has a slot named ~S (~S has no function binding)."
65 (defmacro accessor-slot-value (object slot-name)
66 (unless (constantp slot-name)
67 (error "~S requires its slot-name argument to be a constant"
68 'accessor-slot-value))
69 (let* ((slot-name (eval slot-name))
70 (sym (slot-reader-symbol slot-name)))
71 `(asv-funcall ,sym ,slot-name reader ,object)))
73 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
74 (unless (constantp slot-name)
75 (error "~S requires its slot-name argument to be a constant"
76 'accessor-set-slot-value))
77 (setq object (macroexpand object env))
78 (setq slot-name (macroexpand slot-name env))
79 (let* ((slot-name (eval slot-name))
80 (bindings (unless (or (constantp new-value) (atom new-value))
81 (let ((object-var (gensym)))
82 (prog1 `((,object-var ,object))
83 (setq object object-var)))))
84 (sym (slot-writer-symbol slot-name))
85 (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
87 `(let ,bindings ,form)
90 (defconstant *optimize-slot-boundp* nil)
92 (defmacro accessor-slot-boundp (object slot-name)
93 (unless (constantp slot-name)
94 (error "~S requires its slot-name argument to be a constant"
95 'accessor-slot-boundp))
96 (let* ((slot-name (eval slot-name))
97 (sym (slot-boundp-symbol slot-name)))
98 (if (not *optimize-slot-boundp*)
99 `(slot-boundp-normal ,object ',slot-name)
100 `(asv-funcall ,sym ,slot-name boundp ,object))))
102 (defun structure-slot-boundp (object)
103 (declare (ignore object))
106 (defun make-structure-slot-boundp-function (slotd)
107 (let* ((reader (slot-definition-internal-reader-function slotd))
108 (fun #'(lambda (object)
109 (not (eq (funcall reader object) *slot-unbound*)))))
110 (declare (type function reader))
113 (defun get-optimized-std-accessor-method-function (class slotd name)
114 (if (structure-class-p class)
116 (reader (slot-definition-internal-reader-function slotd))
117 (writer (slot-definition-internal-writer-function slotd))
118 (boundp (make-structure-slot-boundp-function slotd)))
119 (let* ((fsc-p (cond ((standard-class-p class) nil)
120 ((funcallable-standard-class-p class) t)
122 ;; Shouldn't be using the optimized-std-accessors
124 #+nil (format t "* warning: ~S ~S~% ~S~%"
127 (t (error "~S is not a STANDARD-CLASS." class))))
128 (slot-name (slot-definition-name slotd))
129 (index (slot-definition-location slotd))
130 (function (ecase name
131 (reader #'make-optimized-std-reader-method-function)
132 (writer #'make-optimized-std-writer-method-function)
133 (boundp #'make-optimized-std-boundp-method-function)))
134 (value (funcall function fsc-p slot-name index)))
135 (declare (type function function))
136 (values value index))))
138 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
139 (declare #.*optimize-speed*)
144 (let ((value (%instance-ref (fsc-instance-slots instance) index)))
145 (if (eq value *slot-unbound*)
146 (slot-unbound (class-of instance) instance slot-name)
149 (let ((value (%instance-ref (std-instance-slots instance) index)))
150 (if (eq value *slot-unbound*)
151 (slot-unbound (class-of instance) instance slot-name)
153 (cons #'(lambda (instance)
154 (let ((value (cdr index)))
155 (if (eq value *slot-unbound*)
156 (slot-unbound (class-of instance) instance slot-name)
158 `(reader ,slot-name)))
160 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
161 (declare #.*optimize-speed*)
165 #'(lambda (nv instance)
166 (setf (%instance-ref (fsc-instance-slots instance) index) nv))
167 #'(lambda (nv instance)
168 (setf (%instance-ref (std-instance-slots instance) index) nv))))
169 (cons #'(lambda (nv instance)
170 (declare (ignore instance))
171 (setf (cdr index) nv))))
172 `(writer ,slot-name)))
174 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
175 (declare #.*optimize-speed*)
180 (not (eq (%instance-ref (fsc-instance-slots instance)
184 (not (eq (%instance-ref (std-instance-slots instance)
187 (cons #'(lambda (instance)
188 (declare (ignore instance))
189 (not (eq (cdr index) *slot-unbound*)))))
190 `(boundp ,slot-name)))
192 (defun make-optimized-structure-slot-value-using-class-method-function (function)
193 (declare (type function function))
194 #'(lambda (class object slotd)
195 (let ((value (funcall function object)))
196 (if (eq value *slot-unbound*)
197 (slot-unbound class object (slot-definition-name slotd))
200 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
201 (declare (type function function))
202 #'(lambda (nv class object slotd)
203 (declare (ignore class slotd))
204 (funcall function nv object)))
206 (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
207 (declare (type function function))
208 #'(lambda (class object slotd)
209 (declare (ignore class slotd))
210 (not (eq (funcall function object) *slot-unbound*))))
212 (defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
213 (if (structure-class-p class)
215 (reader (make-optimized-structure-slot-value-using-class-method-function
216 (slot-definition-internal-reader-function slotd)))
217 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
218 (slot-definition-internal-writer-function slotd)))
219 (boundp (make-optimized-structure-slot-boundp-using-class-method-function
220 (slot-definition-internal-writer-function slotd))))
221 (let* ((fsc-p (cond ((standard-class-p class) nil)
222 ((funcallable-standard-class-p class) t)
223 (t (error "~S is not a standard-class" class))))
224 (slot-name (slot-definition-name slotd))
225 (index (slot-definition-location slotd))
229 #'make-optimized-std-slot-value-using-class-method-function)
231 #'make-optimized-std-setf-slot-value-using-class-method-function)
233 #'make-optimized-std-slot-boundp-using-class-method-function))))
234 (declare (type function function))
235 (values (funcall function fsc-p slot-name index) index))))
237 (defun make-optimized-std-slot-value-using-class-method-function
238 (fsc-p slot-name index)
239 (declare #.*optimize-speed*)
242 #'(lambda (class instance slotd)
243 (declare (ignore slotd))
244 (unless (fsc-instance-p instance) (error "not fsc"))
245 (let ((value (%instance-ref (fsc-instance-slots instance) index)))
246 (if (eq value *slot-unbound*)
247 (slot-unbound class instance slot-name)
249 #'(lambda (class instance slotd)
250 (declare (ignore slotd))
251 (unless (std-instance-p instance) (error "not std"))
252 (let ((value (%instance-ref (std-instance-slots instance) index)))
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 (%instance-ref (fsc-instance-slots instance) index) nv))
272 #'(lambda (nv class instance slotd)
273 (declare (ignore class slotd))
274 (setf (%instance-ref (std-instance-slots instance) index) nv))))
275 (cons #'(lambda (nv class instance slotd)
276 (declare (ignore class instance slotd))
277 (setf (cdr index) nv)))))
279 (defun make-optimized-std-slot-boundp-using-class-method-function
280 (fsc-p slot-name index)
281 (declare #.*optimize-speed*)
282 (declare (ignore slot-name))
285 #'(lambda (class instance slotd)
286 (declare (ignore class slotd))
287 (not (eq (%instance-ref (fsc-instance-slots instance)
290 #'(lambda (class instance slotd)
291 (declare (ignore class slotd))
292 (not (eq (%instance-ref (std-instance-slots instance)
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) (emf-funcall sdfun class instance slotd)))
305 (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
306 (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
307 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
309 (defun make-internal-reader-method-function (class-name slot-name)
310 (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
311 (make-method-function
313 (let ((wrapper (get-instance-wrapper-or-nil instance)))
315 (let* ((class (wrapper-class* wrapper))
316 (index (or (instance-slot-index wrapper slot-name)
317 (assq slot-name (wrapper-class-slots wrapper)))))
320 (let ((value (%instance-ref (get-slots instance) index)))
321 (if (eq value *slot-unbound*)
322 (slot-unbound (class-of instance) instance slot-name)
325 (let ((value (cdr index)))
326 (if (eq value *slot-unbound*)
327 (slot-unbound (class-of instance) instance slot-name)
330 (error "The wrapper for class ~S does not have the slot ~S"
332 (slot-value instance slot-name)))))))
334 (defun make-std-reader-method-function (class-name slot-name)
335 (let* ((pv-table-symbol (gensym))
337 (make-method-function
339 (pv-binding1 (.pv. .calls.
340 (symbol-value pv-table-symbol)
341 (instance) (instance-slots))
342 (instance-read-internal
343 .pv. instance-slots 1
344 (slot-value instance slot-name))))))))
345 (setf (getf (getf initargs ':plist) ':slot-name-lists)
346 (list (list nil slot-name)))
347 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
348 (list* ':method-spec `(reader-method ,class-name ,slot-name)
351 (defun make-std-writer-method-function (class-name slot-name)
352 (let* ((pv-table-symbol (gensym))
354 (make-method-function
355 (lambda (nv instance)
356 (pv-binding1 (.pv. .calls.
357 (symbol-value pv-table-symbol)
358 (instance) (instance-slots))
359 (instance-write-internal
360 .pv. instance-slots 1 nv
361 (setf (slot-value instance slot-name) nv))))))))
362 (setf (getf (getf initargs ':plist) ':slot-name-lists)
363 (list nil (list nil slot-name)))
364 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
365 (list* ':method-spec `(writer-method ,class-name ,slot-name)
368 (defun make-std-boundp-method-function (class-name slot-name)
369 (let* ((pv-table-symbol (gensym))
371 (make-method-function
373 (pv-binding1 (.pv. .calls.
374 (symbol-value pv-table-symbol)
375 (instance) (instance-slots))
376 (instance-boundp-internal
377 .pv. instance-slots 1
378 (slot-boundp instance slot-name))))))))
379 (setf (getf (getf initargs ':plist) ':slot-name-lists)
380 (list (list nil slot-name)))
381 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
382 (list* ':method-spec `(boundp-method ,class-name ,slot-name)
385 (defun initialize-internal-slot-gfs (slot-name &optional type)
386 (when (or (null type) (eq type 'reader))
387 (let* ((name (slot-reader-symbol slot-name))
388 (gf (ensure-generic-function name)))
389 (unless (generic-function-methods gf)
390 (add-reader-method *the-class-slot-object* gf slot-name))))
391 (when (or (null type) (eq type 'writer))
392 (let* ((name (slot-writer-symbol slot-name))
393 (gf (ensure-generic-function name)))
394 (unless (generic-function-methods gf)
395 (add-writer-method *the-class-slot-object* gf slot-name))))
396 (when (and *optimize-slot-boundp*
397 (or (null type) (eq type 'boundp)))
398 (let* ((name (slot-boundp-symbol slot-name))
399 (gf (ensure-generic-function name)))
400 (unless (generic-function-methods gf)
401 (add-boundp-method *the-class-slot-object* gf slot-name))))
404 (defun initialize-internal-slot-gfs* (readers writers boundps)
405 (dolist (reader readers)
406 (initialize-internal-slot-gfs reader 'reader))
407 (dolist (writer writers)
408 (initialize-internal-slot-gfs writer 'writer))
409 (dolist (boundp boundps)
410 (initialize-internal-slot-gfs boundp 'boundp)))