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