0.7.6.21:
[sbcl.git] / src / pcl / slots-boot.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
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
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
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
18 ;;;; control laws.
19 ;;;;
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
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 (defmacro asv-funcall (sym slot-name type &rest args)
27   (declare (ignore type))
28   `(if (fboundp ',sym)
29        (,sym ,@args)
30        (no-slot ',sym ',slot-name)))
31
32 (defun no-slot (sym slot-name)
33   (error "No class has a slot named ~S (~S has no function binding)."
34          slot-name sym))
35
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)))
43
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)))
57     (if bindings
58         `(let ,bindings ,form)
59         form)))
60
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)))
67
68 (defun structure-slot-boundp (object)
69   (declare (ignore object))
70   t)
71
72 (defun make-structure-slot-boundp-function (slotd)
73   (let* ((reader (slot-definition-internal-reader-function slotd))
74          (fun (lambda (object)
75                 (not (eq (funcall reader object) +slot-unbound+)))))
76     (declare (type function reader))
77     fun))
78
79 (defun get-optimized-std-accessor-method-function (class slotd name)
80   (if (structure-class-p class)
81       (ecase name
82         (reader (slot-definition-internal-reader-function slotd))
83         (writer (slot-definition-internal-writer-function slotd))
84         (boundp (make-structure-slot-boundp-function slotd)))
85       (let* ((fsc-p (cond ((standard-class-p class) nil)
86                           ((funcallable-standard-class-p class) t)
87                           ((std-class-p class)
88                            ;; Shouldn't be using the optimized-std-accessors
89                            ;; in this case.
90                            #+nil (format t "* warning: ~S ~S~%   ~S~%"
91                                    name slotd class)
92                            nil)
93                           (t (error "~S is not a STANDARD-CLASS." class))))
94              (slot-name (slot-definition-name slotd))
95              (index (slot-definition-location slotd))
96              (function (ecase name
97                          (reader #'make-optimized-std-reader-method-function)
98                          (writer #'make-optimized-std-writer-method-function)
99                          (boundp #'make-optimized-std-boundp-method-function)))
100              (value (funcall function fsc-p slot-name index)))
101         (declare (type function function))
102         (values value index))))
103
104 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
105   (declare #.*optimize-speed*)
106   (set-fun-name
107    (etypecase index
108      (fixnum (if fsc-p
109                  (lambda (instance)
110                    (let ((value (clos-slots-ref (fsc-instance-slots instance)
111                                                 index)))
112                      (if (eq value +slot-unbound+)
113                          (slot-unbound (class-of instance) instance slot-name)
114                          value)))
115                  (lambda (instance)
116                    (let ((value (clos-slots-ref (std-instance-slots instance)
117                                               index)))
118                      (if (eq value +slot-unbound+)
119                          (slot-unbound (class-of instance) instance slot-name)
120                          value)))))
121      (cons   (lambda (instance)
122                (let ((value (cdr index)))
123                  (if (eq value +slot-unbound+)
124                      (slot-unbound (class-of instance) instance slot-name)
125                      value)))))
126    `(reader ,slot-name)))
127
128 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
129   (declare #.*optimize-speed*)
130   (set-fun-name
131    (etypecase index
132      (fixnum (if fsc-p
133                  (lambda (nv instance)
134                    (setf (clos-slots-ref (fsc-instance-slots instance) index)
135                          nv))
136                  (lambda (nv instance)
137                    (setf (clos-slots-ref (std-instance-slots instance) index)
138                          nv))))
139      (cons   (lambda (nv instance)
140                (declare (ignore instance))
141                (setf (cdr index) nv))))
142    `(writer ,slot-name)))
143
144 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
145   (declare #.*optimize-speed*)
146   (set-fun-name
147    (etypecase index
148      (fixnum (if fsc-p
149                  (lambda (instance)
150                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
151                                             index)
152                             +slot-unbound+)))
153                  (lambda (instance)
154                    (not (eq (clos-slots-ref (std-instance-slots instance)
155                                             index)
156                             +slot-unbound+)))))
157      (cons (lambda (instance)
158              (declare (ignore instance))
159              (not (eq (cdr index) +slot-unbound+)))))
160    `(boundp ,slot-name)))
161
162 (defun make-optimized-structure-slot-value-using-class-method-function (function)
163   (declare (type function function))
164   (lambda (class object slotd)
165     (let ((value (funcall function object)))
166       (if (eq value +slot-unbound+)
167           (slot-unbound class object (slot-definition-name slotd))
168           value))))
169
170 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
171   (declare (type function function))
172   (lambda (nv class object slotd)
173     (declare (ignore class slotd))
174     (funcall function nv object)))
175
176 (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
177   (declare (type function function))
178   (lambda (class object slotd)
179     (declare (ignore class slotd))
180     (not (eq (funcall function object) +slot-unbound+))))
181
182 (defun get-optimized-std-slot-value-using-class-method-function (class
183                                                                  slotd
184                                                                  name)
185   (if (structure-class-p class)
186       (ecase name
187         (reader (make-optimized-structure-slot-value-using-class-method-function
188                  (slot-definition-internal-reader-function slotd)))
189         (writer (make-optimized-structure-setf-slot-value-using-class-method-function
190                  (slot-definition-internal-writer-function slotd)))
191         (boundp (make-optimized-structure-slot-boundp-using-class-method-function
192                  (slot-definition-internal-writer-function slotd))))
193       (let* ((fsc-p (cond ((standard-class-p class) nil)
194                           ((funcallable-standard-class-p class) t)
195                           (t (error "~S is not a standard-class" class))))
196              (slot-name (slot-definition-name slotd))
197              (index (slot-definition-location slotd))
198              (function
199               (ecase name
200                 (reader
201                  #'make-optimized-std-slot-value-using-class-method-function)
202                 (writer
203                  #'make-optimized-std-setf-slot-value-using-class-method-function)
204                 (boundp
205                  #'make-optimized-std-slot-boundp-using-class-method-function))))
206         (declare (type function function))
207         (values (funcall function fsc-p slot-name index) index))))
208
209 (defun make-optimized-std-slot-value-using-class-method-function
210     (fsc-p slot-name index)
211   (declare #.*optimize-speed*)
212   (etypecase index
213     (fixnum (if fsc-p
214                 (lambda (class instance slotd)
215                   (declare (ignore slotd))
216                   (unless (fsc-instance-p instance) (error "not fsc"))
217                   (let ((value (clos-slots-ref (fsc-instance-slots instance)
218                                                index)))
219                     (if (eq value +slot-unbound+)
220                         (slot-unbound class instance slot-name)
221                         value)))
222                 (lambda (class instance slotd)
223                   (declare (ignore slotd))
224                   (unless (std-instance-p instance) (error "not std"))
225                   (let ((value (clos-slots-ref (std-instance-slots instance)
226                                                index)))
227                     (if (eq value +slot-unbound+)
228                         (slot-unbound class instance slot-name)
229                         value)))))
230     (cons   (lambda (class instance slotd)
231               (declare (ignore slotd))
232               (let ((value (cdr index)))
233                 (if (eq value +slot-unbound+)
234                     (slot-unbound class instance slot-name)
235                     value))))))
236
237 (defun make-optimized-std-setf-slot-value-using-class-method-function
238     (fsc-p slot-name index)
239   (declare #.*optimize-speed*)
240   (declare (ignore slot-name))
241   (etypecase index
242     (fixnum (if fsc-p
243                 (lambda (nv class instance slotd)
244                   (declare (ignore class slotd))
245                   (setf (clos-slots-ref (fsc-instance-slots instance) index)
246                         nv))
247                 (lambda (nv class instance slotd)
248                   (declare (ignore class slotd))
249                   (setf (clos-slots-ref (std-instance-slots instance) index)
250                         nv))))
251     (cons  (lambda (nv class instance slotd)
252              (declare (ignore class instance slotd))
253              (setf (cdr index) nv)))))
254
255 (defun make-optimized-std-slot-boundp-using-class-method-function
256     (fsc-p slot-name index)
257   (declare #.*optimize-speed*)
258   (declare (ignore slot-name))
259   (etypecase index
260     (fixnum (if fsc-p
261                 (lambda (class instance slotd)
262                   (declare (ignore class slotd))
263                   (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
264                            +slot-unbound+)))
265                 (lambda (class instance slotd)
266                   (declare (ignore class slotd))
267                   (not (eq (clos-slots-ref (std-instance-slots instance) index)
268                            +slot-unbound+)))))
269     (cons   (lambda (class instance slotd)
270               (declare (ignore class instance slotd))
271               (not (eq (cdr index) +slot-unbound+))))))
272
273 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
274   (macrolet ((emf-funcall (emf &rest args)
275                `(invoke-effective-method-function ,emf nil ,@args)))
276     (set-fun-name
277      (case name
278        (reader (lambda (instance)
279                  (emf-funcall sdfun class instance slotd)))
280        (writer (lambda (nv instance)
281                  (emf-funcall sdfun nv class instance slotd)))
282        (boundp (lambda (instance)
283                  (emf-funcall sdfun class instance slotd))))
284      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
285
286 (defun make-internal-reader-method-function (class-name slot-name)
287   (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
288          (make-method-function
289           (lambda (instance)
290             (let ((wrapper (get-instance-wrapper-or-nil instance)))
291               (if wrapper
292                   (let* ((class (wrapper-class* wrapper))
293                          (index (or (instance-slot-index wrapper slot-name)
294                                     (assq slot-name
295                                           (wrapper-class-slots wrapper)))))
296                     (typecase index
297                       (fixnum   
298                        (let ((value (clos-slots-ref (get-slots instance)
299                                                     index)))
300                          (if (eq value +slot-unbound+)
301                              (slot-unbound (class-of instance)
302                                            instance
303                                            slot-name)
304                              value)))
305                       (cons
306                        (let ((value (cdr index)))
307                          (if (eq value +slot-unbound+)
308                              (slot-unbound (class-of instance)
309                                            instance
310                                            slot-name)
311                              value)))
312                       (t
313                        (error "~@<The wrapper for class ~S does not have ~
314                                the slot ~S~@:>"
315                               class slot-name))))
316                   (slot-value instance slot-name)))))))
317 \f
318 (defun make-std-reader-method-function (class-name slot-name)
319   (let* ((pv-table-symbol (gensym))
320          (initargs (copy-tree
321                     (make-method-function
322                      (lambda (instance)
323                        (pv-binding1 (.pv. .calls.
324                                           (symbol-value pv-table-symbol)
325                                           (instance) (instance-slots))
326                          (instance-read-internal
327                           .pv. instance-slots 1
328                           (slot-value instance slot-name))))))))
329     (setf (getf (getf initargs :plist) :slot-name-lists)
330           (list (list nil slot-name)))
331     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
332     (list* :method-spec `(reader-method ,class-name ,slot-name)
333            initargs)))
334
335 (defun make-std-writer-method-function (class-name slot-name)
336   (let* ((pv-table-symbol (gensym))
337          (initargs (copy-tree
338                     (make-method-function
339                      (lambda (nv instance)
340                        (pv-binding1 (.pv. .calls.
341                                           (symbol-value pv-table-symbol)
342                                           (instance) (instance-slots))
343                          (instance-write-internal
344                           .pv. instance-slots 1 nv
345                           (setf (slot-value instance slot-name) nv))))))))
346     (setf (getf (getf initargs :plist) :slot-name-lists)
347           (list nil (list nil slot-name)))
348     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
349     (list* :method-spec `(writer-method ,class-name ,slot-name)
350            initargs)))
351
352 (defun make-std-boundp-method-function (class-name slot-name)
353   (let* ((pv-table-symbol (gensym))
354          (initargs (copy-tree
355                     (make-method-function
356                      (lambda (instance)
357                        (pv-binding1 (.pv. .calls.
358                                           (symbol-value pv-table-symbol)
359                                           (instance) (instance-slots))
360                           (instance-boundp-internal
361                            .pv. instance-slots 1
362                            (slot-boundp instance slot-name))))))))
363     (setf (getf (getf initargs :plist) :slot-name-lists)
364           (list (list nil slot-name)))
365     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
366     (list* :method-spec `(boundp-method ,class-name ,slot-name)
367            initargs)))
368
369 (defun initialize-internal-slot-gfs (slot-name &optional type)
370   (when (or (null type) (eq type 'reader))
371     (let* ((name (slot-reader-symbol slot-name))
372            (gf (ensure-generic-function name)))
373       (unless (generic-function-methods gf)
374         (add-reader-method *the-class-slot-object* gf slot-name))))
375   (when (or (null type) (eq type 'writer))
376     (let* ((name (slot-writer-symbol slot-name))
377            (gf (ensure-generic-function name)))
378       (unless (generic-function-methods gf)
379         (add-writer-method *the-class-slot-object* gf slot-name))))
380   nil)
381
382 (defun initialize-internal-slot-gfs* (readers writers boundps)
383   (dolist (reader readers)
384     (initialize-internal-slot-gfs reader 'reader))
385   (dolist (writer writers)
386     (initialize-internal-slot-gfs writer 'writer))
387   (dolist (boundp boundps)
388     (initialize-internal-slot-gfs boundp 'boundp)))