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 (check-obsolete-instance instance)
103 (let ((value (clos-slots-ref (fsc-instance-slots instance)
105 (if (eq value +slot-unbound+)
106 (slot-unbound (class-of instance) instance slot-name)
109 (check-obsolete-instance instance)
110 (let ((value (clos-slots-ref (std-instance-slots instance)
112 (if (eq value +slot-unbound+)
113 (slot-unbound (class-of instance) instance slot-name)
115 (cons (lambda (instance)
116 (check-obsolete-instance instance)
117 (let ((value (cdr index)))
118 (if (eq value +slot-unbound+)
119 (slot-unbound (class-of instance) instance slot-name)
121 `(reader ,slot-name)))
123 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
124 (declare #.*optimize-speed*)
128 (lambda (nv instance)
129 (check-obsolete-instance instance)
130 (setf (clos-slots-ref (fsc-instance-slots instance) index)
132 (lambda (nv instance)
133 (check-obsolete-instance instance)
134 (setf (clos-slots-ref (std-instance-slots instance) index)
136 (cons (lambda (nv instance)
137 (check-obsolete-instance instance)
138 (setf (cdr index) nv))))
139 `(writer ,slot-name)))
141 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
142 (declare #.*optimize-speed*)
147 (check-obsolete-instance instance)
148 (not (eq (clos-slots-ref (fsc-instance-slots instance)
152 (check-obsolete-instance instance)
153 (not (eq (clos-slots-ref (std-instance-slots instance)
156 (cons (lambda (instance)
157 (check-obsolete-instance instance)
158 (not (eq (cdr index) +slot-unbound+)))))
159 `(boundp ,slot-name)))
161 (defun make-optimized-structure-slot-value-using-class-method-function (function)
162 (declare (type function function))
163 (lambda (class object slotd)
164 (declare (ignore class slotd))
165 (funcall function object)))
167 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
168 (declare (type function function))
169 (lambda (nv class object slotd)
170 (declare (ignore class slotd))
171 (funcall function nv object)))
173 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
174 (lambda (class object slotd)
175 (declare (ignore class object slotd))
178 (defun get-optimized-std-slot-value-using-class-method-function (class
181 (if (structure-class-p class)
183 (reader (make-optimized-structure-slot-value-using-class-method-function
184 (slot-definition-internal-reader-function slotd)))
185 (writer (make-optimized-structure-setf-slot-value-using-class-method-function
186 (slot-definition-internal-writer-function slotd)))
187 (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))
188 (let* ((fsc-p (cond ((standard-class-p class) nil)
189 ((funcallable-standard-class-p class) t)
190 (t (error "~S is not a standard-class" class))))
191 (slot-name (slot-definition-name slotd))
192 (index (slot-definition-location slotd))
196 #'make-optimized-std-slot-value-using-class-method-function)
198 #'make-optimized-std-setf-slot-value-using-class-method-function)
200 #'make-optimized-std-slot-boundp-using-class-method-function))))
201 (declare (type function function))
202 (values (funcall function fsc-p slot-name index) index))))
204 (defun make-optimized-std-slot-value-using-class-method-function
205 (fsc-p slot-name index)
206 (declare #.*optimize-speed*)
209 (lambda (class instance slotd)
210 (declare (ignore slotd))
211 (check-obsolete-instance instance)
212 (let ((value (clos-slots-ref (fsc-instance-slots instance)
214 (if (eq value +slot-unbound+)
215 (slot-unbound class instance slot-name)
217 (lambda (class instance slotd)
218 (declare (ignore slotd))
219 (check-obsolete-instance instance)
220 (let ((value (clos-slots-ref (std-instance-slots instance)
222 (if (eq value +slot-unbound+)
223 (slot-unbound class instance slot-name)
225 (cons (lambda (class instance slotd)
226 (declare (ignore slotd))
227 (check-obsolete-instance instance)
228 (let ((value (cdr index)))
229 (if (eq value +slot-unbound+)
230 (slot-unbound class instance slot-name)
233 (defun make-optimized-std-setf-slot-value-using-class-method-function
234 (fsc-p slot-name index)
235 (declare #.*optimize-speed*)
236 (declare (ignore slot-name))
239 (lambda (nv class instance slotd)
240 (declare (ignore class slotd))
241 (check-obsolete-instance instance)
242 (setf (clos-slots-ref (fsc-instance-slots instance) index)
244 (lambda (nv class instance slotd)
245 (declare (ignore class slotd))
246 (check-obsolete-instance instance)
247 (setf (clos-slots-ref (std-instance-slots instance) index)
249 (cons (lambda (nv class instance slotd)
250 (declare (ignore class slotd))
251 (check-obsolete-instance instance)
252 (setf (cdr index) nv)))))
254 (defun make-optimized-std-slot-boundp-using-class-method-function
255 (fsc-p slot-name index)
256 (declare #.*optimize-speed*)
257 (declare (ignore slot-name))
260 (lambda (class instance slotd)
261 (declare (ignore class slotd))
262 (check-obsolete-instance instance)
263 (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
265 (lambda (class instance slotd)
266 (declare (ignore class slotd))
267 (check-obsolete-instance instance)
268 (not (eq (clos-slots-ref (std-instance-slots instance) index)
270 (cons (lambda (class instance slotd)
271 (declare (ignore class slotd))
272 (check-obsolete-instance instance)
273 (not (eq (cdr index) +slot-unbound+))))))
275 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
276 (macrolet ((emf-funcall (emf &rest args)
277 `(invoke-effective-method-function ,emf nil ,@args)))
280 (reader (lambda (instance)
281 (emf-funcall sdfun class instance slotd)))
282 (writer (lambda (nv instance)
283 (emf-funcall sdfun nv class instance slotd)))
284 (boundp (lambda (instance)
285 (emf-funcall sdfun class instance slotd))))
286 `(,name ,(class-name class) ,(slot-definition-name slotd)))))
288 (defun make-internal-reader-method-function (class-name slot-name)
289 (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
290 (make-method-function
292 (let ((wrapper (get-instance-wrapper-or-nil instance)))
294 (let* ((class (wrapper-class* wrapper))
295 (index (or (instance-slot-index wrapper slot-name)
297 (wrapper-class-slots wrapper)))))
300 (let ((value (clos-slots-ref (get-slots instance)
302 (if (eq value +slot-unbound+)
303 (slot-unbound (class-of instance)
308 (let ((value (cdr index)))
309 (if (eq value +slot-unbound+)
310 (slot-unbound (class-of instance)
315 (error "~@<The wrapper for class ~S does not have ~
318 (slot-value instance slot-name)))))))
320 (defun make-std-reader-method-function (class-name slot-name)
321 (let* ((pv-table-symbol (gensym))
323 (make-method-function
325 (pv-binding1 (.pv. .calls.
326 (symbol-value pv-table-symbol)
327 (instance) (instance-slots))
328 (instance-read-internal
329 .pv. instance-slots 1
330 (slot-value instance slot-name))))))))
331 (setf (getf (getf initargs :plist) :slot-name-lists)
332 (list (list nil slot-name)))
333 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
334 (list* :method-spec `(reader-method ,class-name ,slot-name)
337 (defun make-std-writer-method-function (class-name slot-name)
338 (let* ((pv-table-symbol (gensym))
340 (make-method-function
341 (lambda (nv instance)
342 (pv-binding1 (.pv. .calls.
343 (symbol-value pv-table-symbol)
344 (instance) (instance-slots))
345 (instance-write-internal
346 .pv. instance-slots 1 nv
347 (setf (slot-value instance slot-name) nv))))))))
348 (setf (getf (getf initargs :plist) :slot-name-lists)
349 (list nil (list nil slot-name)))
350 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
351 (list* :method-spec `(writer-method ,class-name ,slot-name)
354 (defun make-std-boundp-method-function (class-name slot-name)
355 (let* ((pv-table-symbol (gensym))
357 (make-method-function
359 (pv-binding1 (.pv. .calls.
360 (symbol-value pv-table-symbol)
361 (instance) (instance-slots))
362 (instance-boundp-internal
363 .pv. instance-slots 1
364 (slot-boundp instance slot-name))))))))
365 (setf (getf (getf initargs :plist) :slot-name-lists)
366 (list (list nil slot-name)))
367 (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
368 (list* :method-spec `(boundp-method ,class-name ,slot-name)
371 (defun initialize-internal-slot-gfs (slot-name &optional type)
372 (when (or (null type) (eq type 'reader))
373 (let* ((name (slot-reader-symbol slot-name))
374 (gf (ensure-generic-function name)))
375 (unless (generic-function-methods gf)
376 (add-reader-method *the-class-slot-object* gf slot-name))))
377 (when (or (null type) (eq type 'writer))
378 (let* ((name (slot-writer-symbol slot-name))
379 (gf (ensure-generic-function name)))
380 (unless (generic-function-methods gf)
381 (add-writer-method *the-class-slot-object* gf slot-name))))
384 (defun initialize-internal-slot-gfs* (readers writers boundps)
385 (dolist (reader readers)
386 (initialize-internal-slot-gfs reader 'reader))
387 (dolist (writer writers)
388 (initialize-internal-slot-gfs writer 'writer))
389 (dolist (boundp boundps)
390 (initialize-internal-slot-gfs boundp 'boundp)))