1.0.9: release, will be tagged as sbcl_1_0_9
[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 (let ((reader-specializers '(slot-object))
27       (writer-specializers '(t slot-object)))
28   (defun ensure-accessor (type fun-name slot-name)
29     (unless (fboundp fun-name)
30       (multiple-value-bind (lambda-list specializers method-class initargs doc)
31           (ecase type
32             ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING
33             ;; behaviour for non-slot-objects too?
34             (reader
35              (values '(object) reader-specializers 'global-reader-method
36                      (make-std-reader-method-function 'slot-object slot-name)
37                      "automatically-generated reader method"))
38             (writer
39              (values '(new-value object) writer-specializers
40                      'global-writer-method
41                      (make-std-writer-method-function 'slot-object slot-name)
42                      "automatically-generated writer method"))
43             (boundp
44              (values '(object) reader-specializers 'global-boundp-method
45                      (make-std-boundp-method-function 'slot-object slot-name)
46                      "automatically-generated boundp method")))
47         (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list)))
48           (add-method gf (make-a-method method-class
49                                         () lambda-list specializers
50                                         initargs doc :slot-name slot-name)))))
51     t)
52   ;; KLUDGE: this is maybe PCL bootstrap mechanism #6 or #7, invented
53   ;; by CSR in June 2007.  Making the bootstrap sane is getting higher
54   ;; on the "TODO: URGENT" list.
55   (defun !fix-ensure-accessor-specializers ()
56     (setf reader-specializers (mapcar #'find-class reader-specializers))
57     (setf writer-specializers (mapcar #'find-class writer-specializers))))
58
59 (defmacro accessor-slot-value (object slot-name &environment env)
60   (aver (constantp slot-name env))
61   (let* ((slot-name (constant-form-value slot-name env))
62          (reader-name (slot-reader-name slot-name)))
63     `(let ((.ignore. (load-time-value
64                       (ensure-accessor 'reader ',reader-name ',slot-name))))
65       (declare (ignore .ignore.))
66       (truly-the (values t &optional)
67                  (funcall #',reader-name ,object)))))
68
69 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
70   (aver (constantp slot-name env))
71   (setq object (macroexpand object env))
72   (let* ((slot-name (constant-form-value slot-name env))
73          (bind-object (unless (or (constantp new-value env) (atom new-value))
74                         (let* ((object-var (gensym))
75                                (bind `((,object-var ,object))))
76                           (setf object object-var)
77                           bind)))
78          (writer-name (slot-writer-name slot-name))
79          (form
80           `(let ((.ignore.
81                   (load-time-value
82                    (ensure-accessor 'writer ',writer-name ',slot-name)))
83                  (.new-value. ,new-value))
84             (declare (ignore .ignore.))
85             (funcall #',writer-name .new-value. ,object)
86             .new-value.)))
87     (if bind-object
88         `(let ,bind-object ,form)
89         form)))
90
91 (defmacro accessor-slot-boundp (object slot-name &environment env)
92   (aver (constantp slot-name env))
93   (let* ((slot-name (constant-form-value slot-name env))
94          (boundp-name (slot-boundp-name slot-name)))
95     `(let ((.ignore. (load-time-value
96                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))
97       (declare (ignore .ignore.))
98       (funcall #',boundp-name ,object))))
99
100 (defun make-structure-slot-boundp-function (slotd)
101   (declare (ignore slotd))
102   (lambda (object)
103     (declare (ignore object))
104     t))
105
106 (define-condition instance-structure-protocol-error
107     (reference-condition error)
108   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
109    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
110   (:report
111    (lambda (c s)
112      (format s "~@<The slot ~S has neither ~S nor ~S ~
113                 allocation, so it can't be ~A by the default ~
114                 ~S method.~@:>"
115              (instance-structure-protocol-error-slotd c)
116              :instance :class
117              (cond
118                ((member (instance-structure-protocol-error-fun c)
119                         '(slot-value-using-class slot-boundp-using-class))
120                 "read")
121                (t "written"))
122              (instance-structure-protocol-error-fun c)))))
123
124 (defun instance-structure-protocol-error (slotd fun)
125   (error 'instance-structure-protocol-error
126          :slotd slotd :fun fun
127          :references (list `(:amop :generic-function ,fun)
128                            '(:amop :section (5 5 3)))))
129
130 (defun get-optimized-std-accessor-method-function (class slotd name)
131   (cond
132     ((structure-class-p class)
133      (ecase name
134        (reader (slot-definition-internal-reader-function slotd))
135        (writer (slot-definition-internal-writer-function slotd))
136        (boundp (make-structure-slot-boundp-function slotd))))
137     ((condition-class-p class)
138      (ecase name
139        (reader (slot-definition-reader-function slotd))
140        (writer (slot-definition-writer-function slotd))
141        (boundp (slot-definition-boundp-function slotd))))
142     (t
143      (let* ((fsc-p (cond ((standard-class-p class) nil)
144                          ((funcallable-standard-class-p class) t)
145                          ((std-class-p class)
146                           ;; Shouldn't be using the optimized-std-accessors
147                           ;; in this case.
148                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
149                                         name slotd class)
150                           nil)
151                          (t (error "~S is not a STANDARD-CLASS." class))))
152             (slot-name (slot-definition-name slotd))
153             (location (slot-definition-location slotd))
154             (function (ecase name
155                         (reader #'make-optimized-std-reader-method-function)
156                         (writer #'make-optimized-std-writer-method-function)
157                         (boundp #'make-optimized-std-boundp-method-function)))
158             ;; KLUDGE: we need this slightly hacky calling convention
159             ;; for these functions for bootstrapping reasons: see
160             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
161             ;; 2004-07-12
162             (value (funcall function fsc-p slotd slot-name location)))
163        (declare (type function function))
164        (values value (slot-definition-location slotd))))))
165
166 (defun make-optimized-std-reader-method-function
167     (fsc-p slotd slot-name location)
168   (declare #.*optimize-speed*)
169   (set-fun-name
170    (etypecase location
171      (fixnum
172       (if fsc-p
173           (lambda (instance)
174             (check-obsolete-instance instance)
175             (let ((value (clos-slots-ref (fsc-instance-slots instance)
176                                          location)))
177               (if (eq value +slot-unbound+)
178                   (values
179                    (slot-unbound (class-of instance) instance slot-name))
180                   value)))
181           (lambda (instance)
182             (check-obsolete-instance instance)
183             (let ((value (clos-slots-ref (std-instance-slots instance)
184                                          location)))
185               (if (eq value +slot-unbound+)
186                   (values
187                    (slot-unbound (class-of instance) instance slot-name))
188                   value)))))
189      (cons
190       (lambda (instance)
191         (check-obsolete-instance instance)
192         (let ((value (cdr location)))
193           (if (eq value +slot-unbound+)
194               (values (slot-unbound (class-of instance) instance slot-name))
195               value))))
196      (null
197       (lambda (instance)
198         (instance-structure-protocol-error slotd 'slot-value-using-class))))
199    `(reader ,slot-name)))
200
201 (defun make-optimized-std-writer-method-function
202     (fsc-p slotd slot-name location)
203   (declare #.*optimize-speed*)
204   (let* ((safe-p (and slotd
205                       (slot-definition-class slotd)
206                       (safe-p (slot-definition-class slotd))))
207          (writer-fun (etypecase location
208                        (fixnum (if fsc-p
209                                    (lambda (nv instance)
210                                      (check-obsolete-instance instance)
211                                      (setf (clos-slots-ref (fsc-instance-slots instance)
212                                                            location)
213                                            nv))
214                                    (lambda (nv instance)
215                                      (check-obsolete-instance instance)
216                                      (setf (clos-slots-ref (std-instance-slots instance)
217                                                            location)
218                                            nv))))
219                        (cons (lambda (nv instance)
220                                (check-obsolete-instance instance)
221                                (setf (cdr location) nv)))
222                        (null
223                         (lambda (nv instance)
224                           (declare (ignore nv instance))
225                           (instance-structure-protocol-error
226                            slotd
227                            '(setf slot-value-using-class))))))
228          (checking-fun (lambda (new-value instance)
229                          (check-obsolete-instance instance)
230                          ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it.
231                          (let* (;; Note that this CLASS is not neccessarily
232                                 ;; the SLOT-DEFINITION-CLASS of the
233                                 ;; SLOTD passed to M-O-S-W-M-F, since it's
234                                 ;; e.g. possible for a subclass to define
235                                 ;; a slot of the same name but with no
236                                 ;; accessors. So we need to fetch the SLOTD
237                                 ;; when CHECKING-FUN is called, instead of
238                                 ;; just closing over it.
239                                 (class (class-of instance))
240                                 (slotd (find-slot-definition class slot-name))
241                                 (type-check-function
242                                  (when slotd
243                                    (slot-definition-type-check-function slotd))))
244                            (when type-check-function
245                              (funcall type-check-function new-value)))
246                          ;; Then call the real writer.
247                          (funcall writer-fun new-value instance))))
248     (set-fun-name (if safe-p
249                       checking-fun
250                       writer-fun)
251                   `(writer ,slot-name))))
252
253 (defun make-optimized-std-boundp-method-function
254     (fsc-p slotd slot-name location)
255   (declare #.*optimize-speed*)
256   (set-fun-name
257    (etypecase location
258      (fixnum (if fsc-p
259                  (lambda (instance)
260                    (check-obsolete-instance instance)
261                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
262                                             location)
263                             +slot-unbound+)))
264                  (lambda (instance)
265                    (check-obsolete-instance instance)
266                    (not (eq (clos-slots-ref (std-instance-slots instance)
267                                             location)
268                             +slot-unbound+)))))
269      (cons (lambda (instance)
270              (check-obsolete-instance instance)
271              (not (eq (cdr location) +slot-unbound+))))
272      (null
273       (lambda (instance)
274         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
275    `(boundp ,slot-name)))
276
277 (defun make-optimized-structure-slot-value-using-class-method-function
278     (function)
279   (declare (type function function))
280   (lambda (class object slotd)
281     (declare (ignore class slotd))
282     (funcall function object)))
283
284 (defun make-optimized-structure-setf-slot-value-using-class-method-function
285     (function)
286   (declare (type function function))
287   (lambda (nv class object slotd)
288     (declare (ignore class slotd))
289     (funcall function nv object)))
290
291 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
292   (lambda (class object slotd)
293     (declare (ignore class object slotd))
294     t))
295
296 (defun get-optimized-std-slot-value-using-class-method-function
297     (class slotd name)
298   (cond
299     ((structure-class-p class)
300      (ecase name
301        (reader (make-optimized-structure-slot-value-using-class-method-function
302                 (slot-definition-internal-reader-function slotd)))
303        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
304                 (slot-definition-internal-writer-function slotd)))
305        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
306     ((condition-class-p class)
307      (ecase name
308        (reader
309         (let ((fun (slot-definition-reader-function slotd)))
310           (declare (type function fun))
311           (lambda (class object slotd)
312             (declare (ignore class slotd))
313             (funcall fun object))))
314        (writer
315         (let ((fun (slot-definition-writer-function slotd)))
316           (declare (type function fun))
317           (lambda (new-value class object slotd)
318             (declare (ignore class slotd))
319             (funcall fun new-value object))))
320        (boundp
321         (let ((fun (slot-definition-boundp-function slotd)))
322           (declare (type function fun))
323           (lambda (class object slotd)
324             (declare (ignore class slotd))
325             (funcall fun object))))))
326     (t
327      (let* ((fsc-p (cond ((standard-class-p class) nil)
328                          ((funcallable-standard-class-p class) t)
329                          (t (error "~S is not a standard-class" class))))
330             (function
331              (ecase name
332                (reader
333                 #'make-optimized-std-slot-value-using-class-method-function)
334                (writer
335                 #'make-optimized-std-setf-slot-value-using-class-method-function)
336                (boundp
337                 #'make-optimized-std-slot-boundp-using-class-method-function))))
338        (declare (type function function))
339        (values (funcall function fsc-p slotd)
340                (slot-definition-location slotd))))))
341
342 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
343   (declare #.*optimize-speed*)
344   (let ((location (slot-definition-location slotd))
345         (slot-name (slot-definition-name slotd)))
346     (etypecase location
347       (fixnum (if fsc-p
348                   (lambda (class instance slotd)
349                     (declare (ignore slotd))
350                     (check-obsolete-instance instance)
351                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
352                                                  location)))
353                       (if (eq value +slot-unbound+)
354                           (values (slot-unbound class instance slot-name))
355                           value)))
356                   (lambda (class instance slotd)
357                     (declare (ignore slotd))
358                     (check-obsolete-instance instance)
359                     (let ((value (clos-slots-ref (std-instance-slots instance)
360                                                  location)))
361                       (if (eq value +slot-unbound+)
362                           (values (slot-unbound class instance slot-name))
363                           value)))))
364       (cons (lambda (class instance slotd)
365               (declare (ignore slotd))
366               (check-obsolete-instance instance)
367               (let ((value (cdr location)))
368                 (if (eq value +slot-unbound+)
369                     (values (slot-unbound class instance slot-name))
370                     value))))
371       (null
372        (lambda (class instance slotd)
373          (declare (ignore class instance))
374          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
375
376 (defun make-optimized-std-setf-slot-value-using-class-method-function
377     (fsc-p slotd)
378   (declare #.*optimize-speed*)
379   (let ((location (slot-definition-location slotd))
380         (type-check-function
381          (when (and slotd
382                     (slot-definition-class slotd)
383                     (safe-p (slot-definition-class slotd)))
384            (slot-definition-type-check-function slotd))))
385     (macrolet ((make-mf-lambda (&body body)
386                  `(lambda (nv class instance slotd)
387                     (declare (ignore class slotd))
388                     (check-obsolete-instance instance)
389                     ,@body))
390                (make-mf-lambdas (&body body)
391                  ;; Having separate lambdas for the NULL / not-NULL cases of
392                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
393                  ;; for CLOS typechecking when it's not in use.
394                  `(if type-check-function
395                       (make-mf-lambda
396                        (funcall (the function type-check-function) nv)
397                        ,@body)
398                       (make-mf-lambda
399                        ,@body))))
400       (etypecase location
401         (fixnum
402          (if fsc-p
403              (make-mf-lambdas
404               (setf (clos-slots-ref (fsc-instance-slots instance) location)
405                     nv))
406              (make-mf-lambdas
407               (setf (clos-slots-ref (std-instance-slots instance) location)
408                     nv))))
409         (cons
410          (make-mf-lambdas (setf (cdr location) nv)))
411         (null (lambda (nv class instance slotd)
412                 (declare (ignore nv class instance))
413                 (instance-structure-protocol-error
414                  slotd '(setf slot-value-using-class))))))))
415
416 (defun make-optimized-std-slot-boundp-using-class-method-function
417     (fsc-p slotd)
418   (declare #.*optimize-speed*)
419   (let ((location (slot-definition-location slotd)))
420     (etypecase location
421       (fixnum
422        (if fsc-p
423            (lambda (class instance slotd)
424              (declare (ignore class slotd))
425              (check-obsolete-instance instance)
426              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
427                       +slot-unbound+)))
428            (lambda (class instance slotd)
429              (declare (ignore class slotd))
430              (check-obsolete-instance instance)
431              (not (eq (clos-slots-ref (std-instance-slots instance) location)
432                       +slot-unbound+)))))
433       (cons (lambda (class instance slotd)
434               (declare (ignore class slotd))
435               (check-obsolete-instance instance)
436               (not (eq (cdr location) +slot-unbound+))))
437       (null
438        (lambda (class instance slotd)
439          (declare (ignore class instance))
440          (instance-structure-protocol-error slotd
441                                             'slot-boundp-using-class))))))
442
443 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
444   (macrolet ((emf-funcall (emf &rest args)
445                `(invoke-effective-method-function ,emf nil
446                                                   :required-args ,args)))
447     (set-fun-name
448      (case name
449        (reader (lambda (instance)
450                  (emf-funcall sdfun class instance slotd)))
451        (writer (lambda (nv instance)
452                  (emf-funcall sdfun nv class instance slotd)))
453        (boundp (lambda (instance)
454                  (emf-funcall sdfun class instance slotd))))
455      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
456 \f
457 (defun make-std-reader-method-function (class-or-name slot-name)
458   (declare (ignore class-or-name))
459   (let* ((initargs (copy-tree
460                     (make-method-function
461                      (lambda (instance)
462                        (pv-binding1 (.pv. .calls.
463                                           (bug "Please report this")
464                                           (instance) (instance-slots))
465                          (instance-read-internal
466                           .pv. instance-slots 0
467                           (slot-value instance slot-name))))))))
468     (setf (getf (getf initargs 'plist) :slot-name-lists)
469           (list (list nil slot-name)))
470     initargs))
471
472 (defun make-std-writer-method-function (class-or-name slot-name)
473   (let* ((class (when (eq *boot-state* 'complete)
474                   (if (typep class-or-name 'class)
475                       class-or-name
476                       (find-class class-or-name nil))))
477          (safe-p (and class
478                       (safe-p class)))
479          (check-fun (lambda (new-value instance)
480                       (let* ((class (class-of instance))
481                              (slotd (find-slot-definition class slot-name))
482                              (type-check-function
483                               (when slotd
484                                 (slot-definition-type-check-function slotd))))
485                         (when type-check-function
486                           (funcall type-check-function new-value)))))
487          (initargs (copy-tree
488                     (if safe-p
489                         (make-method-function
490                          (lambda (nv instance)
491                            (funcall check-fun nv instance)
492                            (pv-binding1 (.pv. .calls.
493                                               (bug "Please report this")
494                                               (instance) (instance-slots))
495                              (instance-write-internal
496                               .pv. instance-slots 0 nv
497                               (setf (slot-value instance slot-name) nv)))))
498                         (make-method-function
499                          (lambda (nv instance)
500                            (pv-binding1 (.pv. .calls.
501                                               (bug "Please report this")
502                                               (instance) (instance-slots))
503                              (instance-write-internal
504                               .pv. instance-slots 0 nv
505                               (setf (slot-value instance slot-name) nv)))))))))
506     (setf (getf (getf initargs 'plist) :slot-name-lists)
507           (list nil (list nil slot-name)))
508     initargs))
509
510 (defun make-std-boundp-method-function (class-or-name slot-name)
511   (declare (ignore class-or-name))
512   (let* ((initargs (copy-tree
513                     (make-method-function
514                      (lambda (instance)
515                        (pv-binding1 (.pv. .calls.
516                                           (bug "Please report this")
517                                           (instance) (instance-slots))
518                           (instance-boundp-internal
519                            .pv. instance-slots 0
520                            (slot-boundp instance slot-name))))))))
521     (setf (getf (getf initargs 'plist) :slot-name-lists)
522           (list (list nil slot-name)))
523     initargs))
524 \f
525 ;;;; FINDING SLOT DEFINITIONS
526 ;;;
527 ;;; Historical PCL found slot definitions by iterating over
528 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
529 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
530 ;;; list up to the desired one.
531 ;;;
532 ;;; As of 1.0.7.26 SBCL hashes the effective slot definitions into a
533 ;;; simple-vector, with bucket chains made out of plists keyed by the
534 ;;; slot names. This fixes gives O(1) performance, and avoid the GF
535 ;;; calls.
536 ;;;
537 ;;; MAKE-SLOT-VECTOR constructs the hashed vector out of a list of
538 ;;; effective slot definitions, and FIND-SLOT-DEFINITION knows how to
539 ;;; look up slots in that vector.
540 ;;;
541 ;;; The only bit of cleverness in the implementation is to make the
542 ;;; vectors fairly tight, but always longer then 0 elements:
543 ;;;
544 ;;; -- We don't want to waste huge amounts of space no these vectors,
545 ;;;    which are mostly required by things like SLOT-VALUE with a
546 ;;;    variable slot name, so a constant extension over the minimum
547 ;;;    size seems like a good choise.
548 ;;;
549 ;;; -- As long as the vector always has a length > 0
550 ;;;    FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
551 ;;;    empty vector separately: it just returns a NIL.
552
553 (defun find-slot-definition (class slot-name)
554   (declare (symbol slot-name))
555   (let* ((vector (class-slot-vector class))
556          (index (rem (sxhash slot-name) (length vector))))
557     (declare (simple-vector vector) (index index)
558              (optimize (sb-c::insert-array-bounds-checks 0)))
559     (do ((plist (the list (svref vector index)) (cdr plist)))
560         ((not (consp plist)))
561       (let ((key (car plist)))
562         (setf plist (cdr plist))
563         (when (eq key slot-name)
564           (return (car plist)))))))
565
566 (defun make-slot-vector (slots)
567   (let* ((n (+ (length slots) 2))
568          (vector (make-array n :initial-element nil)))
569     (flet ((add-to-vector (name slot)
570              (declare (symbol name)
571                       (optimize (sb-c::insert-array-bounds-checks 0)))
572              (setf (svref vector (rem (sxhash name) n))
573                    (list* name slot (svref vector (rem (sxhash name) n))))))
574       (if (eq 'complete *boot-state*)
575          (dolist (slot slots)
576            (add-to-vector (slot-definition-name slot) slot))
577          (dolist (slot slots)
578            (add-to-vector (early-slot-definition-name slot) slot))))
579     vector))