0.8.0.78:
[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 (defun ensure-accessor (type fun-name slot-name)
27   (labels ((slot-missing-fun (slot-name type)
28              (let* ((method-type (ecase type
29                                    (slot-value 'reader-method)
30                                    (setf 'writer-method)
31                                    (slot-boundp 'boundp-method)))
32                     (initargs
33                      (copy-tree
34                       (ecase type
35                         (slot-value
36                          (make-method-function
37                           (lambda (obj)
38                             (values
39                              (slot-missing (class-of obj) obj slot-name
40                                            'slot-value)))))
41                         (slot-boundp
42                          (make-method-function
43                           (lambda (obj)
44                             (not (not
45                                   (slot-missing (class-of obj) obj slot-name
46                                                 'slot-boundp))))))
47                         (setf
48                          (make-method-function
49                           (lambda (val obj)
50                             (slot-missing (class-of obj) obj slot-name
51                                           'setf val)
52                             val)))))))
53                (setf (getf (getf initargs :plist) :slot-name-lists)
54                      (list (list nil slot-name)))
55                (setf (getf (getf initargs :plist) :pv-table-symbol)
56                      (gensym))
57                (list* :method-spec (list method-type 'slot-object slot-name)
58                       initargs)))
59            (add-slot-missing-method (gf slot-name type)
60              (multiple-value-bind (class lambda-list specializers)
61                  (ecase type
62                    (slot-value
63                     (values 'standard-reader-method
64                             '(object)
65                             (list *the-class-slot-object*)))
66                    (slot-boundp
67                     (values 'standard-boundp-method
68                             '(object)
69                             (list *the-class-slot-object*)))
70                    (setf
71                     (values 'standard-writer-method
72                             '(new-value object)
73                             (list *the-class-t* *the-class-slot-object*))))
74                (add-method gf (make-a-method class
75                                              ()
76                                              lambda-list
77                                              specializers
78                                              (slot-missing-fun slot-name type)
79                                              "generated slot-missing method"
80                                              slot-name)))))
81         (unless (fboundp fun-name)
82       (let ((gf (ensure-generic-function fun-name)))
83         (ecase type
84           (reader (add-slot-missing-method gf slot-name 'slot-value))
85           (boundp (add-slot-missing-method gf slot-name 'slot-boundp))
86           (writer (add-slot-missing-method gf slot-name 'setf)))
87         (setf (plist-value gf 'slot-missing-method) t))
88       t)))
89
90 (defmacro accessor-slot-value (object slot-name)
91   (aver (constantp slot-name))
92   (let* ((slot-name (eval slot-name))
93          (reader-name (slot-reader-name slot-name)))
94     `(let ((.ignore. (load-time-value
95                       (ensure-accessor 'reader ',reader-name ',slot-name))))
96       (declare (ignore .ignore.))
97       (funcall #',reader-name ,object))))
98
99 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
100   (aver (constantp slot-name))
101   (setq object (macroexpand object env))
102   (setq slot-name (macroexpand slot-name env))
103   (let* ((slot-name (eval slot-name))
104          (bindings (unless (or (constantp new-value) (atom new-value))
105                      (let ((object-var (gensym)))
106                        (prog1 `((,object-var ,object))
107                          (setq object object-var)))))
108          (writer-name (slot-writer-name slot-name))
109          (form
110           `(let ((.ignore.
111                   (load-time-value
112                    (ensure-accessor 'writer ',writer-name ',slot-name)))
113                  (.new-value. ,new-value))
114             (declare (ignore .ignore.))
115             (funcall #',writer-name .new-value. ,object)
116             .new-value.)))
117     (if bindings
118         `(let ,bindings ,form)
119         form)))
120
121 (defmacro accessor-slot-boundp (object slot-name)
122   (aver (constantp slot-name))
123   (let* ((slot-name (eval slot-name))
124          (boundp-name (slot-boundp-name slot-name)))
125     `(let ((.ignore. (load-time-value
126                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))
127       (declare (ignore .ignore.))
128       (funcall #',boundp-name ,object))))
129
130 (defun make-structure-slot-boundp-function (slotd)
131   (declare (ignore slotd))
132   (lambda (object)
133     (declare (ignore object))
134     t))
135
136 (defun get-optimized-std-accessor-method-function (class slotd name)
137   (cond
138     ((structure-class-p class)
139      (ecase name
140        (reader (slot-definition-internal-reader-function slotd))
141        (writer (slot-definition-internal-writer-function slotd))
142        (boundp (make-structure-slot-boundp-function slotd))))
143     ((condition-class-p class)
144      (ecase name
145        (reader (slot-definition-reader-function slotd))
146        (writer (slot-definition-writer-function slotd))
147        (boundp (slot-definition-boundp-function slotd))))
148     (t
149      (let* ((fsc-p (cond ((standard-class-p class) nil)
150                          ((funcallable-standard-class-p class) t)
151                          ((std-class-p class)
152                           ;; Shouldn't be using the optimized-std-accessors
153                           ;; in this case.
154                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
155                                         name slotd class)
156                           nil)
157                          (t (error "~S is not a STANDARD-CLASS." class))))
158             (slot-name (slot-definition-name slotd))
159             (index (slot-definition-location slotd))
160             (function (ecase name
161                         (reader #'make-optimized-std-reader-method-function)
162                         (writer #'make-optimized-std-writer-method-function)
163                         (boundp #'make-optimized-std-boundp-method-function)))
164             (value (funcall function fsc-p slot-name index)))
165        (declare (type function function))
166        (values value index)))))
167
168 (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
169   (declare #.*optimize-speed*)
170   (set-fun-name
171    (etypecase index
172      (fixnum
173       (if fsc-p
174           (lambda (instance)
175             (check-obsolete-instance instance)
176             (let ((value (clos-slots-ref (fsc-instance-slots instance) index)))
177               (if (eq value +slot-unbound+)
178                   (values
179                    (slot-unbound (class-of instance) instance slot-name))
180                   value)))
181           (lambda (instance)
182             (check-obsolete-instance instance)
183             (let ((value (clos-slots-ref (std-instance-slots instance) index)))
184               (if (eq value +slot-unbound+)
185                   (values
186                    (slot-unbound (class-of instance) instance slot-name))
187                   value)))))
188      (cons
189       (lambda (instance)
190         (check-obsolete-instance instance)
191         (let ((value (cdr index)))
192           (if (eq value +slot-unbound+)
193               (values (slot-unbound (class-of instance) instance slot-name))
194               value)))))
195    `(reader ,slot-name)))
196
197 (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
198   (declare #.*optimize-speed*)
199   (set-fun-name
200    (etypecase index
201      (fixnum (if fsc-p
202                  (lambda (nv instance)
203                    (check-obsolete-instance instance)
204                    (setf (clos-slots-ref (fsc-instance-slots instance) index)
205                          nv))
206                  (lambda (nv instance)
207                    (check-obsolete-instance instance)
208                    (setf (clos-slots-ref (std-instance-slots instance) index)
209                          nv))))
210      (cons   (lambda (nv instance)
211                (check-obsolete-instance instance)
212                (setf (cdr index) nv))))
213    `(writer ,slot-name)))
214
215 (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
216   (declare #.*optimize-speed*)
217   (set-fun-name
218    (etypecase index
219      (fixnum (if fsc-p
220                  (lambda (instance)
221                    (check-obsolete-instance instance)
222                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
223                                             index)
224                             +slot-unbound+)))
225                  (lambda (instance)
226                    (check-obsolete-instance instance)
227                    (not (eq (clos-slots-ref (std-instance-slots instance)
228                                             index)
229                             +slot-unbound+)))))
230      (cons (lambda (instance)
231              (check-obsolete-instance instance)
232              (not (eq (cdr index) +slot-unbound+)))))
233    `(boundp ,slot-name)))
234
235 (defun make-optimized-structure-slot-value-using-class-method-function (function)
236   (declare (type function function))
237   (lambda (class object slotd)
238     (declare (ignore class slotd))
239     (funcall function object)))
240
241 (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
242   (declare (type function function))
243   (lambda (nv class object slotd)
244     (declare (ignore class slotd))
245     (funcall function nv object)))
246
247 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
248   (lambda (class object slotd)
249     (declare (ignore class object slotd))
250     t))
251
252 (defun get-optimized-std-slot-value-using-class-method-function
253     (class slotd name)
254   (cond
255     ((structure-class-p class)
256      (ecase name
257        (reader (make-optimized-structure-slot-value-using-class-method-function
258                 (slot-definition-internal-reader-function slotd)))
259        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
260                 (slot-definition-internal-writer-function slotd)))
261        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
262     ((condition-class-p class)
263      (ecase name
264        (reader
265         (let ((fun (slot-definition-reader-function slotd)))
266           (declare (type function fun))
267           (lambda (class object slotd)
268             (declare (ignore class slotd))
269             (funcall fun object))))
270        (writer
271         (let ((fun (slot-definition-writer-function slotd)))
272           (declare (type function fun))
273           (lambda (new-value class object slotd)
274             (declare (ignore class slotd))
275             (funcall fun new-value object))))
276        (boundp
277         (let ((fun (slot-definition-boundp-function slotd)))
278           (declare (type function fun))
279           (lambda (class object slotd)
280             (declare (ignore class slotd))
281             (funcall fun object))))))
282     (t
283      (let* ((fsc-p (cond ((standard-class-p class) nil)
284                          ((funcallable-standard-class-p class) t)
285                          (t (error "~S is not a standard-class" class))))
286             (slot-name (slot-definition-name slotd))
287             (index (slot-definition-location slotd))
288             (function
289              (ecase name
290                (reader
291                 #'make-optimized-std-slot-value-using-class-method-function)
292                (writer
293                 #'make-optimized-std-setf-slot-value-using-class-method-function)
294                (boundp
295                 #'make-optimized-std-slot-boundp-using-class-method-function))))
296        (declare (type function function))
297        (values (funcall function fsc-p slot-name index) index)))))
298
299 (defun make-optimized-std-slot-value-using-class-method-function
300     (fsc-p slot-name index)
301   (declare #.*optimize-speed*)
302   (etypecase index
303     (fixnum (if fsc-p
304                 (lambda (class instance slotd)
305                   (declare (ignore slotd))
306                   (check-obsolete-instance instance)
307                   (let ((value (clos-slots-ref (fsc-instance-slots instance)
308                                                index)))
309                     (if (eq value +slot-unbound+)
310                         (values (slot-unbound class instance slot-name))
311                         value)))
312                 (lambda (class instance slotd)
313                   (declare (ignore slotd))
314                   (check-obsolete-instance instance)
315                   (let ((value (clos-slots-ref (std-instance-slots instance)
316                                                index)))
317                     (if (eq value +slot-unbound+)
318                         (values (slot-unbound class instance slot-name))
319                         value)))))
320     (cons   (lambda (class instance slotd)
321               (declare (ignore slotd))
322               (check-obsolete-instance instance)
323               (let ((value (cdr index)))
324                 (if (eq value +slot-unbound+)
325                     (values (slot-unbound class instance slot-name))
326                     value))))))
327
328 (defun make-optimized-std-setf-slot-value-using-class-method-function
329     (fsc-p slot-name index)
330   (declare #.*optimize-speed*)
331   (declare (ignore slot-name))
332   (etypecase index
333     (fixnum (if fsc-p
334                 (lambda (nv class instance slotd)
335                   (declare (ignore class slotd))
336                   (check-obsolete-instance instance)
337                   (setf (clos-slots-ref (fsc-instance-slots instance) index)
338                         nv))
339                 (lambda (nv class instance slotd)
340                   (declare (ignore class slotd))
341                   (check-obsolete-instance instance)
342                   (setf (clos-slots-ref (std-instance-slots instance) index)
343                         nv))))
344     (cons  (lambda (nv class instance slotd)
345              (declare (ignore class slotd))
346              (check-obsolete-instance instance)
347              (setf (cdr index) nv)))))
348
349 (defun make-optimized-std-slot-boundp-using-class-method-function
350     (fsc-p slot-name index)
351   (declare #.*optimize-speed*)
352   (declare (ignore slot-name))
353   (etypecase index
354     (fixnum (if fsc-p
355                 (lambda (class instance slotd)
356                   (declare (ignore class slotd))
357                   (check-obsolete-instance instance)
358                   (not (eq (clos-slots-ref (fsc-instance-slots instance) index)
359                            +slot-unbound+)))
360                 (lambda (class instance slotd)
361                   (declare (ignore class slotd))
362                   (check-obsolete-instance instance)
363                   (not (eq (clos-slots-ref (std-instance-slots instance) index)
364                            +slot-unbound+)))))
365     (cons   (lambda (class instance slotd)
366               (declare (ignore class slotd))
367               (check-obsolete-instance instance)
368               (not (eq (cdr index) +slot-unbound+))))))
369
370 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
371   (macrolet ((emf-funcall (emf &rest args)
372                `(invoke-effective-method-function ,emf nil ,@args)))
373     (set-fun-name
374      (case name
375        (reader (lambda (instance)
376                  (emf-funcall sdfun class instance slotd)))
377        (writer (lambda (nv instance)
378                  (emf-funcall sdfun nv class instance slotd)))
379        (boundp (lambda (instance)
380                  (emf-funcall sdfun class instance slotd))))
381      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
382
383 (defun make-internal-reader-method-function (class-name slot-name)
384   (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
385          (make-method-function
386           (lambda (instance)
387             (let ((wrapper (get-instance-wrapper-or-nil instance)))
388               (if wrapper
389                   (let* ((class (wrapper-class* wrapper))
390                          (index (or (instance-slot-index wrapper slot-name)
391                                     (assq slot-name
392                                           (wrapper-class-slots wrapper)))))
393                     (typecase index
394                       (fixnum   
395                        (let ((value (clos-slots-ref (get-slots instance)
396                                                     index)))
397                          (if (eq value +slot-unbound+)
398                              (values (slot-unbound (class-of instance)
399                                                    instance
400                                                    slot-name))
401                              value)))
402                       (cons
403                        (let ((value (cdr index)))
404                          (if (eq value +slot-unbound+)
405                              (values (slot-unbound (class-of instance)
406                                                    instance
407                                                    slot-name))
408                              value)))
409                       (t
410                        (error "~@<The wrapper for class ~S does not have ~
411                                the slot ~S~@:>"
412                               class slot-name))))
413                   (slot-value instance slot-name)))))))
414 \f
415 (defun make-std-reader-method-function (class-name slot-name)
416   (let* ((pv-table-symbol (gensym))
417          (initargs (copy-tree
418                     (make-method-function
419                      (lambda (instance)
420                        (pv-binding1 (.pv. .calls.
421                                           (symbol-value pv-table-symbol)
422                                           (instance) (instance-slots))
423                          (instance-read-internal
424                           .pv. instance-slots 1
425                           (slot-value instance slot-name))))))))
426     (setf (getf (getf initargs :plist) :slot-name-lists)
427           (list (list nil slot-name)))
428     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
429     (list* :method-spec `(reader-method ,class-name ,slot-name)
430            initargs)))
431
432 (defun make-std-writer-method-function (class-name slot-name)
433   (let* ((pv-table-symbol (gensym))
434          (initargs (copy-tree
435                     (make-method-function
436                      (lambda (nv instance)
437                        (pv-binding1 (.pv. .calls.
438                                           (symbol-value pv-table-symbol)
439                                           (instance) (instance-slots))
440                          (instance-write-internal
441                           .pv. instance-slots 1 nv
442                           (setf (slot-value instance slot-name) nv))))))))
443     (setf (getf (getf initargs :plist) :slot-name-lists)
444           (list nil (list nil slot-name)))
445     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
446     (list* :method-spec `(writer-method ,class-name ,slot-name)
447            initargs)))
448
449 (defun make-std-boundp-method-function (class-name slot-name)
450   (let* ((pv-table-symbol (gensym))
451          (initargs (copy-tree
452                     (make-method-function
453                      (lambda (instance)
454                        (pv-binding1 (.pv. .calls.
455                                           (symbol-value pv-table-symbol)
456                                           (instance) (instance-slots))
457                           (instance-boundp-internal
458                            .pv. instance-slots 1
459                            (slot-boundp instance slot-name))))))))
460     (setf (getf (getf initargs :plist) :slot-name-lists)
461           (list (list nil slot-name)))
462     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
463     (list* :method-spec `(boundp-method ,class-name ,slot-name)
464            initargs)))
465
466 (defun initialize-internal-slot-gfs (slot-name &optional type)
467   (macrolet ((frob (type name-fun add-fun)
468                `(when (or (null type) (eq type ',type))
469                  (let* ((name (,name-fun slot-name))
470                         (gf (ensure-generic-function name))
471                         (methods (generic-function-methods gf)))
472                    (when (or (null methods)
473                              (plist-value gf 'slot-missing-method))
474                      (setf (plist-value gf 'slot-missing-method) nil)
475                      (,add-fun *the-class-slot-object* gf slot-name))))))
476     (frob reader slot-reader-name add-reader-method)
477     (frob writer slot-writer-name add-writer-method)
478     (frob boundp slot-boundp-name add-boundp-method)))