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