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