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 asv-funcall (sym slot-name type &rest args)
27 (declare (ignore type))
30 (no-slot ',sym ',slot-name)))
32 (defun no-slot (sym slot-name)
33 (error "No class has a slot named ~S (~S has no function binding)."
36 (defmacro accessor-slot-value (object slot-name)
37 (unless (constantp slot-name)
38 (error "~S requires its slot-name argument to be a constant"
39 'accessor-slot-value))
40 (let* ((slot-name (eval slot-name))
41 (sym (slot-reader-symbol slot-name)))
42 `(asv-funcall ,sym ,slot-name reader ,object)))
44 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
45 (unless (constantp slot-name)
46 (error "~S requires its slot-name argument to be a constant"
47 'accessor-set-slot-value))
48 (setq object (macroexpand object env))
49 (setq slot-name (macroexpand slot-name env))
50 (let* ((slot-name (eval slot-name))
51 (bindings (unless (or (constantp new-value) (atom new-value))
52 (let ((object-var (gensym)))
53 (prog1 `((,object-var ,object))
54 (setq object object-var)))))
55 (sym (slot-writer-symbol slot-name))
56 (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
58 `(let ,bindings ,form)
61 (defmacro accessor-slot-boundp (object slot-name)
62 (unless (constantp slot-name)
63 (error "~S requires its slot-name argument to be a constant"
64 'accessor-slot-boundp))
65 (let ((slot-name (eval slot-name)))
66 `(slot-boundp-normal ,object ',slot-name)))
68 (defun make-structure-slot-boundp-function (slotd)
69 (lambda (object) (declare (ignore object)) t))
71 (defun get-optimized-std-accessor-method-function (class slotd name)
72 (if (structure-class-p class)
74 (reader (slot-definition-internal-reader-function slotd))
75 (writer (slot-definition-internal-writer-function slotd))
76 (boundp (make-structure-slot-boundp-function slotd)))
77 (let* ((fsc-p (cond ((standard-class-p class) nil)
78 ((funcallable-standard-class-p class) t)
80 ;; Shouldn't be using the optimized-std-accessors
82 #+nil (format t "* warning: ~S ~S~% ~S~%"
85 (t (error "~S is not a STANDARD-CLASS." class))))
86 (slot-name (slot-definition-name slotd))
87 (index (slot-definition-location slotd))
89 (reader #'make-optimized-std-reader-method-function)
90 (writer #'make-optimized-std-writer-method-function)
91 (boundp #'make-optimized-std-boundp-method-function)))
92 (value (funcall function fsc-p slot-name index)))
93 (declare (type function function))
94 (values value index))))
96 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
97 (declare #.*optimize-speed*)
102 (let ((value (clos-slots-ref (fsc-instance-slots instance)
104 (if (eq value +slot-unbound+)
105 (slot-unbound (class-of instance) instance slot-name)
108 (let ((value (clos-slots-ref (std-instance-slots instance)
110 (if (eq value +slot-unbound+)
111 (slot-unbound (class-of instance) instance slot-name)
113 (cons (lambda (instance)
114 (let ((value (cdr index)))
115 (if (eq value +slot-unbound+)
116 (slot-unbound (class-of instance) instance slot-name)
118 `(reader ,slot-name)))
120 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
121 (declare #.*optimize-speed*)
125 (lambda (nv instance)
126 (setf (clos-slots-ref (fsc-instance-slots instance) index)
128 (lambda (nv instance)
129 (setf (clos-slots-ref (std-instance-slots instance) index)
131 (cons (lambda (nv instance)
132 (declare (ignore instance))
133 (setf (cdr index) nv))))
134 `(writer ,slot-name)))
136 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
137 (declare #.*optimize-speed*)
142 (not (eq (clos-slots-ref (fsc-instance-slots instance)
146 (not (eq (clos-slots-ref (std-instance-slots instance)
149 (cons (lambda (instance)
150 (declare (ignore instance))
151 (not (eq (cdr index) +slot-unbound+)))))
152 `(boundp ,slot-name)))
154 (defun make-optimized-structure-slot-value-using-class-method-function (function)
155 (declare (type function function))
156 (lambda (class object slotd)
157 (declare (ignore class slotd))
158 (funcall function object)))
160 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
161 (declare (type function function))
162 (lambda (nv class object slotd)
163 (declare (ignore class slotd))
164 (funcall function nv object)))
166 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
167 (lambda (class object slotd)
168 (declare (ignore class object slotd))
171 (defun get-optimized-std-slot-value-using-class-method-function (class
174 (if (structure-class-p class)
176 (reader (make-optimized-structure-slot-value-using-class-method-function
177 (slot-definition-internal-reader-function slotd)))
178 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
179 (slot-definition-internal-writer-function slotd)))
180 (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))
181 (let* ((fsc-p (cond ((standard-class-p class) nil)
182 ((funcallable-standard-class-p class) t)
183 (t (error "~S is not a standard-class" class))))
184 (slot-name (slot-definition-name slotd))
185 (index (slot-definition-location slotd))
189 #'make-optimized-std-slot-value-using-class-method-function)
191 #'make-optimized-std-setf-slot-value-using-class-method-function)
193 #'make-optimized-std-slot-boundp-using-class-method-function))))
194 (declare (type function function))
195 (values (funcall function fsc-p slot-name index) index))))
197 (defun make-optimized-std-slot-value-using-class-method-function
198 (fsc-p slot-name index)
199 (declare #.*optimize-speed*)
202 (lambda (class instance slotd)
203 (declare (ignore slotd))
204 (unless (fsc-instance-p instance) (error "not fsc"))
205 (let ((value (clos-slots-ref (fsc-instance-slots instance)
207 (if (eq value +slot-unbound+)
208 (slot-unbound class instance slot-name)
210 (lambda (class instance slotd)
211 (declare (ignore slotd))
212 (unless (std-instance-p instance) (error "not std"))
213 (let ((value (clos-slots-ref (std-instance-slots instance)
215 (if (eq value +slot-unbound+)
216 (slot-unbound class instance slot-name)
218 (cons (lambda (class instance slotd)
219 (declare (ignore slotd))
220 (let ((value (cdr index)))
221 (if (eq value +slot-unbound+)
222 (slot-unbound class instance slot-name)
225 (defun make-optimized-std-setf-slot-value-using-class-method-function
226 (fsc-p slot-name index)
227 (declare #.*optimize-speed*)
228 (declare (ignore slot-name))
231 (lambda (nv class instance slotd)
232 (declare (ignore class slotd))
233 (setf (clos-slots-ref (fsc-instance-slots instance) index)
235 (lambda (nv class instance slotd)
236 (declare (ignore class slotd))
237 (setf (clos-slots-ref (std-instance-slots instance) index)
239 (cons (lambda (nv class instance slotd)
240 (declare (ignore class instance slotd))
241 (setf (cdr index) nv)))))
243 (defun make-optimized-std-slot-boundp-using-class-method-function
244 (fsc-p slot-name index)
245 (declare #.*optimize-speed*)
246 (declare (ignore slot-name))
249 (lambda (class instance slotd)
250 (declare (ignore class slotd))
251 (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
253 (lambda (class instance slotd)
254 (declare (ignore class slotd))
255 (not (eq (clos-slots-ref (std-instance-slots instance) index)
257 (cons (lambda (class instance slotd)
258 (declare (ignore class instance slotd))
259 (not (eq (cdr index) +slot-unbound+))))))
261 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
262 (macrolet ((emf-funcall (emf &rest args)
263 `(invoke-effective-method-function ,emf nil ,@args)))
266 (reader (lambda (instance)
267 (emf-funcall sdfun class instance slotd)))
268 (writer (lambda (nv instance)
269 (emf-funcall sdfun nv class instance slotd)))
270 (boundp (lambda (instance)
271 (emf-funcall sdfun class instance slotd))))
272 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
274 (defun make-internal-reader-method-function (class-name slot-name)
275 (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
276 (make-method-function
278 (let ((wrapper (get-instance-wrapper-or-nil instance)))
280 (let* ((class (wrapper-class* wrapper))
281 (index (or (instance-slot-index wrapper slot-name)
283 (wrapper-class-slots wrapper)))))
286 (let ((value (clos-slots-ref (get-slots instance)
288 (if (eq value +slot-unbound+)
289 (slot-unbound (class-of instance)
294 (let ((value (cdr index)))
295 (if (eq value +slot-unbound+)
296 (slot-unbound (class-of instance)
301 (error "~@<The wrapper for class ~S does not have ~
304 (slot-value instance slot-name)))))))
306 (defun make-std-reader-method-function (class-name slot-name)
307 (let* ((pv-table-symbol (gensym))
309 (make-method-function
311 (pv-binding1 (.pv. .calls.
312 (symbol-value pv-table-symbol)
313 (instance) (instance-slots))
314 (instance-read-internal
315 .pv. instance-slots 1
316 (slot-value instance slot-name))))))))
317 (setf (getf (getf initargs :plist) :slot-name-lists)
318 (list (list nil slot-name)))
319 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
320 (list* :method-spec `(reader-method ,class-name ,slot-name)
323 (defun make-std-writer-method-function (class-name slot-name)
324 (let* ((pv-table-symbol (gensym))
326 (make-method-function
327 (lambda (nv instance)
328 (pv-binding1 (.pv. .calls.
329 (symbol-value pv-table-symbol)
330 (instance) (instance-slots))
331 (instance-write-internal
332 .pv. instance-slots 1 nv
333 (setf (slot-value instance slot-name) nv))))))))
334 (setf (getf (getf initargs :plist) :slot-name-lists)
335 (list nil (list nil slot-name)))
336 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
337 (list* :method-spec `(writer-method ,class-name ,slot-name)
340 (defun make-std-boundp-method-function (class-name slot-name)
341 (let* ((pv-table-symbol (gensym))
343 (make-method-function
345 (pv-binding1 (.pv. .calls.
346 (symbol-value pv-table-symbol)
347 (instance) (instance-slots))
348 (instance-boundp-internal
349 .pv. instance-slots 1
350 (slot-boundp instance slot-name))))))))
351 (setf (getf (getf initargs :plist) :slot-name-lists)
352 (list (list nil slot-name)))
353 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
354 (list* :method-spec `(boundp-method ,class-name ,slot-name)
357 (defun initialize-internal-slot-gfs (slot-name &optional type)
358 (when (or (null type) (eq type 'reader))
359 (let* ((name (slot-reader-symbol slot-name))
360 (gf (ensure-generic-function name)))
361 (unless (generic-function-methods gf)
362 (add-reader-method *the-class-slot-object* gf slot-name))))
363 (when (or (null type) (eq type 'writer))
364 (let* ((name (slot-writer-symbol slot-name))
365 (gf (ensure-generic-function name)))
366 (unless (generic-function-methods gf)
367 (add-writer-method *the-class-slot-object* gf slot-name))))
370 (defun initialize-internal-slot-gfs* (readers writers boundps)
371 (dolist (reader readers)
372 (initialize-internal-slot-gfs reader 'reader))
373 (dolist (writer writers)
374 (initialize-internal-slot-gfs writer 'writer))
375 (dolist (boundp boundps)
376 (initialize-internal-slot-gfs boundp 'boundp)))