0.9.5.58:
[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 (define-condition instance-structure-protocol-error
142     (reference-condition error)
143   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
144    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
145   (:report
146    (lambda (c s)
147      (format s "~@<The slot ~S has neither ~S nor ~S ~
148                 allocation, so it can't be ~A by the default ~
149                 ~S method.~@:>"
150              (instance-structure-protocol-error-slotd c)
151              :instance :class
152              (cond
153                ((member (instance-structure-protocol-error-fun c)
154                         '(slot-value-using-class slot-boundp-using-class))
155                 "read")
156                (t "written"))
157              (instance-structure-protocol-error-fun c)))))
158
159 (defun instance-structure-protocol-error (slotd fun)
160   (error 'instance-structure-protocol-error
161          :slotd slotd :fun fun
162          :references (list `(:amop :generic-function ,fun)
163                            '(:amop :section (5 5 3)))))
164
165 (defun get-optimized-std-accessor-method-function (class slotd name)
166   (cond
167     ((structure-class-p class)
168      (ecase name
169        (reader (slot-definition-internal-reader-function slotd))
170        (writer (slot-definition-internal-writer-function slotd))
171        (boundp (make-structure-slot-boundp-function slotd))))
172     ((condition-class-p class)
173      (ecase name
174        (reader (slot-definition-reader-function slotd))
175        (writer (slot-definition-writer-function slotd))
176        (boundp (slot-definition-boundp-function slotd))))
177     (t
178      (let* ((fsc-p (cond ((standard-class-p class) nil)
179                          ((funcallable-standard-class-p class) t)
180                          ((std-class-p class)
181                           ;; Shouldn't be using the optimized-std-accessors
182                           ;; in this case.
183                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
184                                         name slotd class)
185                           nil)
186                          (t (error "~S is not a STANDARD-CLASS." class))))
187             (slot-name (slot-definition-name slotd))
188             (location (slot-definition-location slotd))
189             (function (ecase name
190                         (reader #'make-optimized-std-reader-method-function)
191                         (writer #'make-optimized-std-writer-method-function)
192                         (boundp #'make-optimized-std-boundp-method-function)))
193             ;; KLUDGE: we need this slightly hacky calling convention
194             ;; for these functions for bootstrapping reasons: see
195             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
196             ;; 2004-07-12
197             (value (funcall function fsc-p slotd slot-name location)))
198        (declare (type function function))
199        (values value (slot-definition-location slotd))))))
200
201 (defun make-optimized-std-reader-method-function
202     (fsc-p slotd slot-name location)
203   (declare #.*optimize-speed*)
204   (set-fun-name
205    (etypecase location
206      (fixnum
207       (if fsc-p
208           (lambda (instance)
209             (check-obsolete-instance instance)
210             (let ((value (clos-slots-ref (fsc-instance-slots instance)
211                                          location)))
212               (if (eq value +slot-unbound+)
213                   (values
214                    (slot-unbound (class-of instance) instance slot-name))
215                   value)))
216           (lambda (instance)
217             (check-obsolete-instance instance)
218             (let ((value (clos-slots-ref (std-instance-slots instance)
219                                          location)))
220               (if (eq value +slot-unbound+)
221                   (values
222                    (slot-unbound (class-of instance) instance slot-name))
223                   value)))))
224      (cons
225       (lambda (instance)
226         (check-obsolete-instance instance)
227         (let ((value (cdr location)))
228           (if (eq value +slot-unbound+)
229               (values (slot-unbound (class-of instance) instance slot-name))
230               value))))
231      (null
232       (lambda (instance)
233         (instance-structure-protocol-error slotd 'slot-value-using-class))))
234    `(reader ,slot-name)))
235
236 (defun make-optimized-std-writer-method-function
237     (fsc-p slotd slot-name location)
238   (declare #.*optimize-speed*)
239   (set-fun-name
240    (etypecase location
241      (fixnum (if fsc-p
242                  (lambda (nv instance)
243                    (check-obsolete-instance instance)
244                    (setf (clos-slots-ref (fsc-instance-slots instance)
245                                          location)
246                          nv))
247                  (lambda (nv instance)
248                    (check-obsolete-instance instance)
249                    (setf (clos-slots-ref (std-instance-slots instance)
250                                          location)
251                          nv))))
252      (cons (lambda (nv instance)
253              (check-obsolete-instance instance)
254              (setf (cdr location) nv)))
255      (null
256       (lambda (nv instance)
257         (declare (ignore nv))
258         (instance-structure-protocol-error slotd
259                                            '(setf slot-value-using-class)))))
260    `(writer ,slot-name)))
261
262 (defun make-optimized-std-boundp-method-function
263     (fsc-p slotd slot-name location)
264   (declare #.*optimize-speed*)
265   (set-fun-name
266    (etypecase location
267      (fixnum (if fsc-p
268                  (lambda (instance)
269                    (check-obsolete-instance instance)
270                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
271                                             location)
272                             +slot-unbound+)))
273                  (lambda (instance)
274                    (check-obsolete-instance instance)
275                    (not (eq (clos-slots-ref (std-instance-slots instance)
276                                             location)
277                             +slot-unbound+)))))
278      (cons (lambda (instance)
279              (check-obsolete-instance instance)
280              (not (eq (cdr location) +slot-unbound+))))
281      (null
282       (lambda (instance)
283         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
284    `(boundp ,slot-name)))
285
286 (defun make-optimized-structure-slot-value-using-class-method-function
287     (function)
288   (declare (type function function))
289   (lambda (class object slotd)
290     (declare (ignore class slotd))
291     (funcall function object)))
292
293 (defun make-optimized-structure-setf-slot-value-using-class-method-function
294     (function)
295   (declare (type function function))
296   (lambda (nv class object slotd)
297     (declare (ignore class slotd))
298     (funcall function nv object)))
299
300 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
301   (lambda (class object slotd)
302     (declare (ignore class object slotd))
303     t))
304
305 (defun get-optimized-std-slot-value-using-class-method-function
306     (class slotd name)
307   (cond
308     ((structure-class-p class)
309      (ecase name
310        (reader (make-optimized-structure-slot-value-using-class-method-function
311                 (slot-definition-internal-reader-function slotd)))
312        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
313                 (slot-definition-internal-writer-function slotd)))
314        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
315     ((condition-class-p class)
316      (ecase name
317        (reader
318         (let ((fun (slot-definition-reader-function slotd)))
319           (declare (type function fun))
320           (lambda (class object slotd)
321             (declare (ignore class slotd))
322             (funcall fun object))))
323        (writer
324         (let ((fun (slot-definition-writer-function slotd)))
325           (declare (type function fun))
326           (lambda (new-value class object slotd)
327             (declare (ignore class slotd))
328             (funcall fun new-value object))))
329        (boundp
330         (let ((fun (slot-definition-boundp-function slotd)))
331           (declare (type function fun))
332           (lambda (class object slotd)
333             (declare (ignore class slotd))
334             (funcall fun object))))))
335     (t
336      (let* ((fsc-p (cond ((standard-class-p class) nil)
337                          ((funcallable-standard-class-p class) t)
338                          (t (error "~S is not a standard-class" class))))
339             (function
340              (ecase name
341                (reader
342                 #'make-optimized-std-slot-value-using-class-method-function)
343                (writer
344                 #'make-optimized-std-setf-slot-value-using-class-method-function)
345                (boundp
346                 #'make-optimized-std-slot-boundp-using-class-method-function))))
347        (declare (type function function))
348        (values (funcall function fsc-p slotd)
349                (slot-definition-location slotd))))))
350
351 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
352   (declare #.*optimize-speed*)
353   (let ((location (slot-definition-location slotd))
354         (slot-name (slot-definition-name slotd)))
355     (etypecase location
356       (fixnum (if fsc-p
357                   (lambda (class instance slotd)
358                     (declare (ignore slotd))
359                     (check-obsolete-instance instance)
360                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
361                                                  location)))
362                       (if (eq value +slot-unbound+)
363                           (values (slot-unbound class instance slot-name))
364                           value)))
365                   (lambda (class instance slotd)
366                     (declare (ignore slotd))
367                     (check-obsolete-instance instance)
368                     (let ((value (clos-slots-ref (std-instance-slots instance)
369                                                  location)))
370                       (if (eq value +slot-unbound+)
371                           (values (slot-unbound class instance slot-name))
372                           value)))))
373       (cons (lambda (class instance slotd)
374               (declare (ignore slotd))
375               (check-obsolete-instance instance)
376               (let ((value (cdr location)))
377                 (if (eq value +slot-unbound+)
378                     (values (slot-unbound class instance slot-name))
379                     value))))
380       (null
381        (lambda (class instance slotd)
382          (declare (ignore class instance))
383          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
384
385 (defun make-optimized-std-setf-slot-value-using-class-method-function
386     (fsc-p slotd)
387   (declare #.*optimize-speed*)
388   (let ((location (slot-definition-location slotd)))
389     (etypecase location
390       (fixnum
391        (if fsc-p
392            (lambda (nv class instance slotd)
393              (declare (ignore class slotd))
394              (check-obsolete-instance instance)
395              (setf (clos-slots-ref (fsc-instance-slots instance) location)
396                    nv))
397            (lambda (nv class instance slotd)
398              (declare (ignore class slotd))
399              (check-obsolete-instance instance)
400              (setf (clos-slots-ref (std-instance-slots instance) location)
401                    nv))))
402       (cons (lambda (nv class instance slotd)
403               (declare (ignore class slotd))
404               (check-obsolete-instance instance)
405               (setf (cdr location) nv)))
406       (null (lambda (nv class instance slotd)
407               (declare (ignore nv class instance))
408               (instance-structure-protocol-error
409                slotd '(setf slot-value-using-class)))))))
410
411 (defun make-optimized-std-slot-boundp-using-class-method-function
412     (fsc-p slotd)
413   (declare #.*optimize-speed*)
414   (let ((location (slot-definition-location slotd)))
415     (etypecase location
416       (fixnum
417        (if fsc-p
418            (lambda (class instance slotd)
419              (declare (ignore class slotd))
420              (check-obsolete-instance instance)
421              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
422                       +slot-unbound+)))
423            (lambda (class instance slotd)
424              (declare (ignore class slotd))
425              (check-obsolete-instance instance)
426              (not (eq (clos-slots-ref (std-instance-slots instance) location)
427                       +slot-unbound+)))))
428       (cons (lambda (class instance slotd)
429               (declare (ignore class slotd))
430               (check-obsolete-instance instance)
431               (not (eq (cdr location) +slot-unbound+))))
432       (null
433        (lambda (class instance slotd)
434          (declare (ignore class instance))
435          (instance-structure-protocol-error slotd
436                                             'slot-boundp-using-class))))))
437
438 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
439   (macrolet ((emf-funcall (emf &rest args)
440                `(invoke-effective-method-function ,emf nil ,@args)))
441     (set-fun-name
442      (case name
443        (reader (lambda (instance)
444                  (emf-funcall sdfun class instance slotd)))
445        (writer (lambda (nv instance)
446                  (emf-funcall sdfun nv class instance slotd)))
447        (boundp (lambda (instance)
448                  (emf-funcall sdfun class instance slotd))))
449      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
450
451 (defun make-internal-reader-method-function (class-name slot-name)
452   (list* :method-spec `(internal-reader-method ,class-name ,slot-name)
453          (make-method-function
454           (lambda (instance)
455             (let ((wrapper (get-instance-wrapper-or-nil instance)))
456               (if wrapper
457                   (let* ((class (wrapper-class* wrapper))
458                          (index (or (instance-slot-index wrapper slot-name)
459                                     (assq slot-name
460                                           (wrapper-class-slots wrapper)))))
461                     (typecase index
462                       (fixnum
463                        (let ((value (clos-slots-ref (get-slots instance)
464                                                     index)))
465                          (if (eq value +slot-unbound+)
466                              (values (slot-unbound (class-of instance)
467                                                    instance
468                                                    slot-name))
469                              value)))
470                       (cons
471                        (let ((value (cdr index)))
472                          (if (eq value +slot-unbound+)
473                              (values (slot-unbound (class-of instance)
474                                                    instance
475                                                    slot-name))
476                              value)))
477                       (t
478                        (error "~@<The wrapper for class ~S does not have ~
479                                the slot ~S~@:>"
480                               class slot-name))))
481                   (slot-value instance slot-name)))))))
482 \f
483 (defun make-std-reader-method-function (class-name slot-name)
484   (let* ((pv-table-symbol (gensym))
485          (initargs (copy-tree
486                     (make-method-function
487                      (lambda (instance)
488                        (pv-binding1 (.pv. .calls.
489                                           (symbol-value pv-table-symbol)
490                                           (instance) (instance-slots))
491                          (instance-read-internal
492                           .pv. instance-slots 1
493                           (slot-value instance slot-name))))))))
494     (setf (getf (getf initargs :plist) :slot-name-lists)
495           (list (list nil slot-name)))
496     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
497     (list* :method-spec `(reader-method ,class-name ,slot-name)
498            initargs)))
499
500 (defun make-std-writer-method-function (class-name slot-name)
501   (let* ((pv-table-symbol (gensym))
502          (initargs (copy-tree
503                     (make-method-function
504                      (lambda (nv instance)
505                        (pv-binding1 (.pv. .calls.
506                                           (symbol-value pv-table-symbol)
507                                           (instance) (instance-slots))
508                          (instance-write-internal
509                           .pv. instance-slots 1 nv
510                           (setf (slot-value instance slot-name) nv))))))))
511     (setf (getf (getf initargs :plist) :slot-name-lists)
512           (list nil (list nil slot-name)))
513     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
514     (list* :method-spec `(writer-method ,class-name ,slot-name)
515            initargs)))
516
517 (defun make-std-boundp-method-function (class-name slot-name)
518   (let* ((pv-table-symbol (gensym))
519          (initargs (copy-tree
520                     (make-method-function
521                      (lambda (instance)
522                        (pv-binding1 (.pv. .calls.
523                                           (symbol-value pv-table-symbol)
524                                           (instance) (instance-slots))
525                           (instance-boundp-internal
526                            .pv. instance-slots 1
527                            (slot-boundp instance slot-name))))))))
528     (setf (getf (getf initargs :plist) :slot-name-lists)
529           (list (list nil slot-name)))
530     (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
531     (list* :method-spec `(boundp-method ,class-name ,slot-name)
532            initargs)))
533
534 (defun initialize-internal-slot-gfs (slot-name &optional type)
535   (macrolet ((frob (type name-fun add-fun ll)
536                `(when (or (null type) (eq type ',type))
537                  (let* ((name (,name-fun slot-name))
538                         (gf (ensure-generic-function name
539                                                      :lambda-list ',ll))
540                         (methods (generic-function-methods gf)))
541                    (when (or (null methods)
542                              (plist-value gf 'slot-missing-method))
543                      (setf (plist-value gf 'slot-missing-method) nil)
544                      (,add-fun *the-class-slot-object* gf slot-name))))))
545     (frob reader slot-reader-name add-reader-method (object))
546     (frob writer slot-writer-name add-writer-method (new-value object))
547     (frob boundp slot-boundp-name add-boundp-method (object))))