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 (sym (slot-boundp-symbol slot-name)))
93 `(slot-boundp-normal ,object ',slot-name)))
95 (defun structure-slot-boundp (object)
96 (declare (ignore object))
99 (defun make-structure-slot-boundp-function (slotd)
100 (let* ((reader (slot-definition-internal-reader-function slotd))
101 (fun #'(lambda (object)
102 (not (eq (funcall reader object) +slot-unbound+)))))
103 (declare (type function reader))
106 (defun get-optimized-std-accessor-method-function (class slotd name)
107 (if (structure-class-p class)
109 (reader (slot-definition-internal-reader-function slotd))
110 (writer (slot-definition-internal-writer-function slotd))
111 (boundp (make-structure-slot-boundp-function slotd)))
112 (let* ((fsc-p (cond ((standard-class-p class) nil)
113 ((funcallable-standard-class-p class) t)
115 ;; Shouldn't be using the optimized-std-accessors
117 #+nil (format t "* warning: ~S ~S~% ~S~%"
120 (t (error "~S is not a STANDARD-CLASS." class))))
121 (slot-name (slot-definition-name slotd))
122 (index (slot-definition-location slotd))
123 (function (ecase name
124 (reader #'make-optimized-std-reader-method-function)
125 (writer #'make-optimized-std-writer-method-function)
126 (boundp #'make-optimized-std-boundp-method-function)))
127 (value (funcall function fsc-p slot-name index)))
128 (declare (type function function))
129 (values value index))))
131 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
132 (declare #.*optimize-speed*)
137 (let ((value (clos-slots-ref (fsc-instance-slots instance)
139 (if (eq value +slot-unbound+)
140 (slot-unbound (class-of instance) instance slot-name)
143 (let ((value (clos-slots-ref (std-instance-slots instance)
145 (if (eq value +slot-unbound+)
146 (slot-unbound (class-of instance) instance slot-name)
148 (cons (lambda (instance)
149 (let ((value (cdr index)))
150 (if (eq value +slot-unbound+)
151 (slot-unbound (class-of instance) instance slot-name)
153 `(reader ,slot-name)))
155 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
156 (declare #.*optimize-speed*)
160 (lambda (nv instance)
161 (setf (clos-slots-ref (fsc-instance-slots instance) index)
163 (lambda (nv instance)
164 (setf (clos-slots-ref (std-instance-slots instance) index)
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 (clos-slots-ref (fsc-instance-slots instance)
181 (not (eq (clos-slots-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
212 (if (structure-class-p class)
214 (reader (make-optimized-structure-slot-value-using-class-method-function
215 (slot-definition-internal-reader-function slotd)))
216 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
217 (slot-definition-internal-writer-function slotd)))
218 (boundp (make-optimized-structure-slot-boundp-using-class-method-function
219 (slot-definition-internal-writer-function slotd))))
220 (let* ((fsc-p (cond ((standard-class-p class) nil)
221 ((funcallable-standard-class-p class) t)
222 (t (error "~S is not a standard-class" class))))
223 (slot-name (slot-definition-name slotd))
224 (index (slot-definition-location slotd))
228 #'make-optimized-std-slot-value-using-class-method-function)
230 #'make-optimized-std-setf-slot-value-using-class-method-function)
232 #'make-optimized-std-slot-boundp-using-class-method-function))))
233 (declare (type function function))
234 (values (funcall function fsc-p slot-name index) index))))
236 (defun make-optimized-std-slot-value-using-class-method-function
237 (fsc-p slot-name index)
238 (declare #.*optimize-speed*)
241 (lambda (class instance slotd)
242 (declare (ignore slotd))
243 (unless (fsc-instance-p instance) (error "not fsc"))
244 (let ((value (clos-slots-ref (fsc-instance-slots instance)
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 (clos-slots-ref (std-instance-slots instance)
254 (if (eq value +slot-unbound+)
255 (slot-unbound class instance slot-name)
257 (cons (lambda (class instance slotd)
258 (declare (ignore slotd))
259 (let ((value (cdr index)))
260 (if (eq value +slot-unbound+)
261 (slot-unbound class instance slot-name)
264 (defun make-optimized-std-setf-slot-value-using-class-method-function
265 (fsc-p slot-name index)
266 (declare #.*optimize-speed*)
267 (declare (ignore slot-name))
270 (lambda (nv class instance slotd)
271 (declare (ignore class slotd))
272 (setf (clos-slots-ref (fsc-instance-slots instance) index)
274 (lambda (nv class instance slotd)
275 (declare (ignore class slotd))
276 (setf (clos-slots-ref (std-instance-slots instance) index)
278 (cons (lambda (nv class instance slotd)
279 (declare (ignore class instance slotd))
280 (setf (cdr index) nv)))))
282 (defun make-optimized-std-slot-boundp-using-class-method-function
283 (fsc-p slot-name index)
284 (declare #.*optimize-speed*)
285 (declare (ignore slot-name))
288 (lambda (class instance slotd)
289 (declare (ignore class slotd))
290 (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
292 (lambda (class instance slotd)
293 (declare (ignore class slotd))
294 (not (eq (clos-slots-ref (std-instance-slots instance) index)
296 (cons (lambda (class instance slotd)
297 (declare (ignore class instance slotd))
298 (not (eq (cdr index) +slot-unbound+))))))
300 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
301 (macrolet ((emf-funcall (emf &rest args)
302 `(invoke-effective-method-function ,emf nil ,@args)))
305 (reader (lambda (instance)
306 (emf-funcall sdfun class instance slotd)))
307 (writer (lambda (nv instance)
308 (emf-funcall sdfun nv class instance slotd)))
309 (boundp (lambda (instance)
310 (emf-funcall sdfun class instance slotd))))
311 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
313 (defun make-internal-reader-method-function (class-name slot-name)
314 (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
315 (make-method-function
317 (let ((wrapper (get-instance-wrapper-or-nil instance)))
319 (let* ((class (wrapper-class* wrapper))
320 (index (or (instance-slot-index wrapper slot-name)
322 (wrapper-class-slots wrapper)))))
325 (let ((value (clos-slots-ref (get-slots instance)
327 (if (eq value +slot-unbound+)
328 (slot-unbound (class-of instance)
333 (let ((value (cdr index)))
334 (if (eq value +slot-unbound+)
335 (slot-unbound (class-of instance)
340 (error "~@<The wrapper for class ~S does not have ~
343 (slot-value instance slot-name)))))))
345 (defun make-std-reader-method-function (class-name slot-name)
346 (let* ((pv-table-symbol (gensym))
348 (make-method-function
350 (pv-binding1 (.pv. .calls.
351 (symbol-value pv-table-symbol)
352 (instance) (instance-slots))
353 (instance-read-internal
354 .pv. instance-slots 1
355 (slot-value instance slot-name))))))))
356 (setf (getf (getf initargs ':plist) ':slot-name-lists)
357 (list (list nil slot-name)))
358 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
359 (list* ':method-spec `(reader-method ,class-name ,slot-name)
362 (defun make-std-writer-method-function (class-name slot-name)
363 (let* ((pv-table-symbol (gensym))
365 (make-method-function
366 (lambda (nv instance)
367 (pv-binding1 (.pv. .calls.
368 (symbol-value pv-table-symbol)
369 (instance) (instance-slots))
370 (instance-write-internal
371 .pv. instance-slots 1 nv
372 (setf (slot-value instance slot-name) nv))))))))
373 (setf (getf (getf initargs ':plist) ':slot-name-lists)
374 (list nil (list nil slot-name)))
375 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
376 (list* ':method-spec `(writer-method ,class-name ,slot-name)
379 (defun make-std-boundp-method-function (class-name slot-name)
380 (let* ((pv-table-symbol (gensym))
382 (make-method-function
384 (pv-binding1 (.pv. .calls.
385 (symbol-value pv-table-symbol)
386 (instance) (instance-slots))
387 (instance-boundp-internal
388 .pv. instance-slots 1
389 (slot-boundp instance slot-name))))))))
390 (setf (getf (getf initargs ':plist) ':slot-name-lists)
391 (list (list nil slot-name)))
392 (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
393 (list* ':method-spec `(boundp-method ,class-name ,slot-name)
396 (defun initialize-internal-slot-gfs (slot-name &optional type)
397 (when (or (null type) (eq type 'reader))
398 (let* ((name (slot-reader-symbol slot-name))
399 (gf (ensure-generic-function name)))
400 (unless (generic-function-methods gf)
401 (add-reader-method *the-class-slot-object* gf slot-name))))
402 (when (or (null type) (eq type 'writer))
403 (let* ((name (slot-writer-symbol slot-name))
404 (gf (ensure-generic-function name)))
405 (unless (generic-function-methods gf)
406 (add-writer-method *the-class-slot-object* gf slot-name))))
409 (defun initialize-internal-slot-gfs* (readers writers boundps)
410 (dolist (reader readers)
411 (initialize-internal-slot-gfs reader 'reader))
412 (dolist (writer writers)
413 (initialize-internal-slot-gfs writer 'writer))
414 (dolist (boundp boundps)
415 (initialize-internal-slot-gfs boundp 'boundp)))