Fix make-array transforms.
[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 quiet-funcall (fun &rest args)
60   ;; Don't give a style-warning about undefined function here.
61   `(funcall (locally (declare (muffle-conditions style-warning))
62               ,fun)
63             ,@args))
64
65 (defmacro accessor-slot-value (object slot-name &environment env)
66   (aver (constantp slot-name env))
67   (let* ((slot-name (constant-form-value slot-name env))
68          (reader-name (slot-reader-name slot-name)))
69     `(let ((.ignore. (load-time-value
70                       (ensure-accessor 'reader ',reader-name ',slot-name))))
71        (declare (ignore .ignore.))
72        (truly-the (values t &optional)
73                   (quiet-funcall #',reader-name ,object)))))
74
75 (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
76   (aver (constantp slot-name env))
77   (setq object (%macroexpand object env))
78   (let* ((slot-name (constant-form-value slot-name env))
79          (bind-object (unless (or (constantp new-value env) (atom new-value))
80                         (let* ((object-var (gensym))
81                                (bind `((,object-var ,object))))
82                           (setf object object-var)
83                           bind)))
84          (writer-name (slot-writer-name slot-name))
85          (form
86           `(let ((.ignore.
87                   (load-time-value
88                    (ensure-accessor 'writer ',writer-name ',slot-name)))
89                  (.new-value. ,new-value))
90             (declare (ignore .ignore.))
91             (quiet-funcall #',writer-name .new-value. ,object)
92             .new-value.)))
93     (if bind-object
94         `(let ,bind-object ,form)
95         form)))
96
97 (defmacro accessor-slot-boundp (object slot-name &environment env)
98   (aver (constantp slot-name env))
99   (let* ((slot-name (constant-form-value slot-name env))
100          (boundp-name (slot-boundp-name slot-name)))
101     `(let ((.ignore. (load-time-value
102                       (ensure-accessor 'boundp ',boundp-name ',slot-name))))
103       (declare (ignore .ignore.))
104       (funcall #',boundp-name ,object))))
105
106 (defun make-structure-slot-boundp-function (slotd)
107   (declare (ignore slotd))
108   (lambda (object)
109     (declare (ignore object))
110     t))
111
112 (define-condition instance-structure-protocol-error
113     (reference-condition error)
114   ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd)
115    (fun :initarg :fun :reader instance-structure-protocol-error-fun))
116   (:report
117    (lambda (c s)
118      (format s "~@<The slot ~S has neither ~S nor ~S ~
119                 allocation, so it can't be ~A by the default ~
120                 ~S method.~@:>"
121              (instance-structure-protocol-error-slotd c)
122              :instance :class
123              (cond
124                ((member (instance-structure-protocol-error-fun c)
125                         '(slot-value-using-class slot-boundp-using-class))
126                 "read")
127                (t "written"))
128              (instance-structure-protocol-error-fun c)))))
129
130 (defun instance-structure-protocol-error (slotd fun)
131   (error 'instance-structure-protocol-error
132          :slotd slotd :fun fun
133          :references (list `(:amop :generic-function ,fun)
134                            '(:amop :section (5 5 3)))))
135
136 (defun get-optimized-std-accessor-method-function (class slotd name)
137   (cond
138     ((structure-class-p class)
139      (ecase name
140        (reader (slot-definition-internal-reader-function slotd))
141        (writer (slot-definition-internal-writer-function slotd))
142        (boundp (make-structure-slot-boundp-function slotd))))
143     ((condition-class-p class)
144      (let ((info (slot-definition-info slotd)))
145        (ecase name
146          (reader (slot-info-reader info))
147          (writer (slot-info-writer info))
148          (boundp (slot-info-boundp info)))))
149     (t
150      (let* ((fsc-p (cond ((standard-class-p class) nil)
151                          ((funcallable-standard-class-p class) t)
152                          ((std-class-p class)
153                           ;; Shouldn't be using the optimized-std-accessors
154                           ;; in this case.
155                           #+nil (format t "* warning: ~S ~S~%   ~S~%"
156                                         name slotd class)
157                           nil)
158                          (t (error "~S is not a STANDARD-CLASS." class))))
159             (slot-name (slot-definition-name slotd))
160             (location (slot-definition-location slotd))
161             (function (ecase name
162                         (reader #'make-optimized-std-reader-method-function)
163                         (writer #'make-optimized-std-writer-method-function)
164                         (boundp #'make-optimized-std-boundp-method-function)))
165             ;; KLUDGE: we need this slightly hacky calling convention
166             ;; for these functions for bootstrapping reasons: see
167             ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp.  -- CSR,
168             ;; 2004-07-12
169             (value (funcall function fsc-p slotd slot-name location)))
170        (declare (type function function))
171        (values value (slot-definition-location slotd))))))
172
173 (defun make-optimized-std-reader-method-function
174     (fsc-p slotd slot-name location)
175   (declare #.*optimize-speed*)
176   (set-fun-name
177    (etypecase location
178      (fixnum
179       (if fsc-p
180           (lambda (instance)
181             (check-obsolete-instance instance)
182             (let ((value (clos-slots-ref (fsc-instance-slots instance)
183                                          location)))
184               (if (eq value +slot-unbound+)
185                   (values
186                    (slot-unbound (class-of instance) instance slot-name))
187                   value)))
188           (lambda (instance)
189             (check-obsolete-instance instance)
190             (let ((value (clos-slots-ref (std-instance-slots instance)
191                                          location)))
192               (if (eq value +slot-unbound+)
193                   (values
194                    (slot-unbound (class-of instance) instance slot-name))
195                   value)))))
196      (cons
197       (lambda (instance)
198         (check-obsolete-instance instance)
199         (let ((value (cdr location)))
200           (if (eq value +slot-unbound+)
201               (values (slot-unbound (class-of instance) instance slot-name))
202               value))))
203      (null
204       (lambda (instance)
205         (instance-structure-protocol-error slotd 'slot-value-using-class))))
206    `(reader ,slot-name)))
207
208 (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location)
209   (declare #.*optimize-speed*)
210   ;; The (WHEN SLOTD ...) gunk is for building early slot definitions.
211   (let* ((class (when slotd (slot-definition-class slotd)))
212          (safe-p (when slotd (safe-p class)))
213          (orig-wrapper (when safe-p (class-wrapper class)))
214          (info (when safe-p (slot-definition-info slotd)))
215          (writer-fun (etypecase location
216                        ;; In SAFE-P case the typechecking already validated the instance.
217                        (fixnum
218                         (if fsc-p
219                             (if safe-p
220                                 (lambda (nv instance)
221                                   (setf (clos-slots-ref (fsc-instance-slots instance)
222                                                         location)
223                                         nv))
224                                 (lambda (nv instance)
225                                   (check-obsolete-instance instance)
226                                   (setf (clos-slots-ref (fsc-instance-slots instance)
227                                                         location)
228                                         nv)))
229                             (if safe-p
230                                 (lambda (nv instance)
231                                   (setf (clos-slots-ref (std-instance-slots instance)
232                                                         location)
233                                         nv))
234                                 (lambda (nv instance)
235                                   (check-obsolete-instance instance)
236                                   (setf (clos-slots-ref (std-instance-slots instance)
237                                                         location)
238                                         nv)))))
239                        (cons
240                         (if safe-p
241                             (lambda (nv instance)
242                               (setf (cdr location) nv))
243                             (lambda (nv instance)
244                               (check-obsolete-instance instance)
245                               (setf (cdr location) nv))))
246                        (null
247                         (lambda (nv instance)
248                           (declare (ignore nv instance))
249                           (instance-structure-protocol-error
250                            slotd
251                            '(setf slot-value-using-class))))))
252          (checking-fun (when safe-p
253                          (lambda (new-value instance)
254                            ;; If we have a TYPE-CHECK-FUNCTION, call it.
255                            (let* (;; Note that the class of INSTANCE here is not
256                                   ;; neccessarily the SLOT-DEFINITION-CLASS of
257                                   ;; the SLOTD passed to M-O-S-W-M-F, since it's
258                                   ;; e.g. possible for a subclass to define a
259                                   ;; slot of the same name but with no
260                                   ;; accessors. So we may need to fetch the
261                                   ;; right SLOT-INFO from the wrapper instead of
262                                   ;; just closing over it.
263                                   (wrapper (valid-wrapper-of instance))
264                                   (typecheck
265                                    (slot-info-typecheck
266                                     (if (eq wrapper orig-wrapper)
267                                         info
268                                         (cdr (find-slot-cell wrapper slot-name))))))
269                              (when typecheck
270                                (funcall typecheck new-value)))
271                            ;; Then call the real writer.
272                            (funcall writer-fun new-value instance)))))
273     (set-fun-name (if safe-p
274                       checking-fun
275                       writer-fun)
276                   `(writer ,slot-name))))
277
278 (defun make-optimized-std-boundp-method-function
279     (fsc-p slotd slot-name location)
280   (declare #.*optimize-speed*)
281   (set-fun-name
282    (etypecase location
283      (fixnum (if fsc-p
284                  (lambda (instance)
285                    (check-obsolete-instance instance)
286                    (not (eq (clos-slots-ref (fsc-instance-slots instance)
287                                             location)
288                             +slot-unbound+)))
289                  (lambda (instance)
290                    (check-obsolete-instance instance)
291                    (not (eq (clos-slots-ref (std-instance-slots instance)
292                                             location)
293                             +slot-unbound+)))))
294      (cons (lambda (instance)
295              (check-obsolete-instance instance)
296              (not (eq (cdr location) +slot-unbound+))))
297      (null
298       (lambda (instance)
299         (instance-structure-protocol-error slotd 'slot-boundp-using-class))))
300    `(boundp ,slot-name)))
301
302 (defun make-optimized-structure-slot-value-using-class-method-function
303     (function)
304   (declare (type function function))
305   (lambda (class object slotd)
306     (declare (ignore class slotd))
307     (funcall function object)))
308
309 (defun make-optimized-structure-setf-slot-value-using-class-method-function
310     (function)
311   (declare (type function function))
312   (lambda (nv class object slotd)
313     (declare (ignore class slotd))
314     (funcall function nv object)))
315
316 (defun make-optimized-structure-slot-boundp-using-class-method-function ()
317   (lambda (class object slotd)
318     (declare (ignore class object slotd))
319     t))
320
321 (defun get-optimized-std-slot-value-using-class-method-function
322     (class slotd name)
323   (cond
324     ((structure-class-p class)
325      (ecase name
326        (reader (make-optimized-structure-slot-value-using-class-method-function
327                 (slot-definition-internal-reader-function slotd)))
328        (writer (make-optimized-structure-setf-slot-value-using-class-method-function
329                 (slot-definition-internal-writer-function slotd)))
330        (boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
331     ((condition-class-p class)
332      (let ((info (slot-definition-info slotd)))
333        (ecase name
334          (reader
335           (let ((fun (slot-info-reader info)))
336             (lambda (class object slotd)
337               (declare (ignore class slotd))
338               (funcall fun object))))
339          (writer
340           (let ((fun (slot-info-writer info)))
341             (lambda (new-value class object slotd)
342               (declare (ignore class slotd))
343               (funcall fun new-value object))))
344          (boundp
345           (let ((fun (slot-info-boundp info)))
346             (lambda (class object slotd)
347               (declare (ignore class slotd))
348               (funcall fun object)))))))
349     (t
350      (let* ((fsc-p (cond ((standard-class-p class) nil)
351                          ((funcallable-standard-class-p class) t)
352                          (t (error "~S is not a standard-class" class))))
353             (function
354              (ecase name
355                (reader
356                 #'make-optimized-std-slot-value-using-class-method-function)
357                (writer
358                 #'make-optimized-std-setf-slot-value-using-class-method-function)
359                (boundp
360                 #'make-optimized-std-slot-boundp-using-class-method-function))))
361        (declare (type function function))
362        (values (funcall function fsc-p slotd)
363                (slot-definition-location slotd))))))
364
365 (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd)
366   (declare #.*optimize-speed*)
367   (let ((location (slot-definition-location slotd))
368         (slot-name (slot-definition-name slotd)))
369     (etypecase location
370       (fixnum (if fsc-p
371                   (lambda (class instance slotd)
372                     (declare (ignore slotd))
373                     (check-obsolete-instance instance)
374                     (let ((value (clos-slots-ref (fsc-instance-slots instance)
375                                                  location)))
376                       (if (eq value +slot-unbound+)
377                           (values (slot-unbound class instance slot-name))
378                           value)))
379                   (lambda (class instance slotd)
380                     (declare (ignore slotd))
381                     (check-obsolete-instance instance)
382                     (let ((value (clos-slots-ref (std-instance-slots instance)
383                                                  location)))
384                       (if (eq value +slot-unbound+)
385                           (values (slot-unbound class instance slot-name))
386                           value)))))
387       (cons (lambda (class instance slotd)
388               (declare (ignore slotd))
389               (check-obsolete-instance instance)
390               (let ((value (cdr location)))
391                 (if (eq value +slot-unbound+)
392                     (values (slot-unbound class instance slot-name))
393                     value))))
394       (null
395        (lambda (class instance slotd)
396          (declare (ignore class instance))
397          (instance-structure-protocol-error slotd 'slot-value-using-class))))))
398
399 (defun make-optimized-std-setf-slot-value-using-class-method-function
400     (fsc-p slotd)
401   (declare #.*optimize-speed*)
402   (let* ((location (slot-definition-location slotd))
403          (class (slot-definition-class slotd))
404          (typecheck
405           (when (safe-p class)
406             (slot-info-typecheck (slot-definition-info slotd)))))
407     (macrolet ((make-mf-lambda (&body body)
408                  `(lambda (nv class instance slotd)
409                     (declare (ignore class slotd))
410                     (check-obsolete-instance instance)
411                     ,@body))
412                (make-mf-lambdas (&body body)
413                  ;; Having separate lambdas for the NULL / not-NULL cases of
414                  ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
415                  ;; for CLOS typechecking when it's not in use.
416                  `(if typecheck
417                       (make-mf-lambda
418                        (funcall (the function typecheck) nv)
419                        ,@body)
420                       (make-mf-lambda
421                        ,@body))))
422       (etypecase location
423         (fixnum
424          (if fsc-p
425              (make-mf-lambdas
426               (setf (clos-slots-ref (fsc-instance-slots instance) location)
427                     nv))
428              (make-mf-lambdas
429               (setf (clos-slots-ref (std-instance-slots instance) location)
430                     nv))))
431         (cons
432          (make-mf-lambdas (setf (cdr location) nv)))
433         (null (lambda (nv class instance slotd)
434                 (declare (ignore nv class instance))
435                 (instance-structure-protocol-error
436                  slotd '(setf slot-value-using-class))))))))
437
438 (defun make-optimized-std-slot-boundp-using-class-method-function
439     (fsc-p slotd)
440   (declare #.*optimize-speed*)
441   (let ((location (slot-definition-location slotd)))
442     (etypecase location
443       (fixnum
444        (if fsc-p
445            (lambda (class instance slotd)
446              (declare (ignore class slotd))
447              (check-obsolete-instance instance)
448              (not (eq (clos-slots-ref (fsc-instance-slots instance) location)
449                       +slot-unbound+)))
450            (lambda (class instance slotd)
451              (declare (ignore class slotd))
452              (check-obsolete-instance instance)
453              (not (eq (clos-slots-ref (std-instance-slots instance) location)
454                       +slot-unbound+)))))
455       (cons (lambda (class instance slotd)
456               (declare (ignore class slotd))
457               (check-obsolete-instance instance)
458               (not (eq (cdr location) +slot-unbound+))))
459       (null
460        (lambda (class instance slotd)
461          (declare (ignore class instance))
462          (instance-structure-protocol-error slotd
463                                             'slot-boundp-using-class))))))
464
465 (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
466   (macrolet ((emf-funcall (emf &rest args)
467                `(invoke-effective-method-function ,emf nil
468                                                   :required-args ,args)))
469     (set-fun-name
470      (case name
471        (reader (lambda (instance)
472                  (emf-funcall sdfun class instance slotd)))
473        (writer (lambda (nv instance)
474                  (emf-funcall sdfun nv class instance slotd)))
475        (boundp (lambda (instance)
476                  (emf-funcall sdfun class instance slotd))))
477      `(,name ,(class-name class) ,(slot-definition-name slotd)))))
478 \f
479 (defun maybe-class (class-or-name)
480   (when (eq **boot-state** 'complete)
481     (if (typep class-or-name 'class)
482         class-or-name
483         (find-class class-or-name nil))))
484
485 (defun make-std-reader-method-function (class-or-name slot-name)
486   (declare (ignore class-or-name))
487   (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'reader t)
488     (:standard
489      (let* ((initargs (copy-tree
490                        (make-method-function
491                         (lambda (instance)
492                           (pv-binding1 ((bug "Please report this")
493                                         (instance) (instance-slots))
494                             (instance-read-standard
495                              .pv. instance-slots 0
496                              (slot-value instance slot-name))))))))
497        (setf (getf (getf initargs 'plist) :slot-name-lists)
498              (list (list nil slot-name)))
499        initargs))
500     ((:custom :accessor)
501      (let* ((initargs (copy-tree
502                        (make-method-function
503                         (lambda (instance)
504                           (pv-binding1 ((bug "Please report this")
505                                         (instance) nil)
506                             (instance-read-custom .pv. 0 instance)))))))
507        (setf (getf (getf initargs 'plist) :slot-name-lists)
508              (list (list nil slot-name)))
509        initargs))))
510
511 (defun make-std-writer-method-function (class-or-name slot-name)
512   (let ((class (maybe-class class-or-name)))
513     (ecase (slot-access-strategy class slot-name 'writer t)
514       (:standard
515        (let ((initargs (copy-tree
516                         (if (and class (safe-p class))
517                             (make-method-function
518                              (lambda (nv instance)
519                                (pv-binding1 ((bug "Please report this")
520                                              (instance) (instance-slots))
521                                  (instance-write-standard
522                                   .pv. instance-slots 0 nv
523                                   (setf (slot-value instance slot-name) .good-new-value.)
524                                   nil t))))
525                             (make-method-function
526                              (lambda (nv instance)
527                                (pv-binding1 ((bug "Please report this")
528                                              (instance) (instance-slots))
529                                  (instance-write-standard
530                                   .pv. instance-slots 0 nv
531                                   (setf (slot-value instance slot-name) .good-new-value.)))))))))
532          (setf (getf (getf initargs 'plist) :slot-name-lists)
533                (list nil (list nil slot-name)))
534          initargs))
535      ((:custom :accessor)
536       (let ((initargs (copy-tree
537                        (make-method-function
538                         (lambda (nv instance)
539                           (pv-binding1 ((bug "Please report this")
540                                         (instance) nil)
541                             (instance-write-custom .pv. 0 instance nv)))))))
542         (setf (getf (getf initargs 'plist) :slot-name-lists)
543               (list nil (list nil slot-name)))
544         initargs)))))
545
546 (defun make-std-boundp-method-function (class-or-name slot-name)
547   (declare (ignore class-or-name))
548   (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'boundp t)
549     (:standard
550      (let ((initargs (copy-tree
551                       (make-method-function
552                        (lambda (instance)
553                          (pv-binding1 ((bug "Please report this")
554                                        (instance) (instance-slots))
555                            (instance-boundp-standard
556                             .pv. instance-slots 0
557                             (slot-boundp instance slot-name))))))))
558        (setf (getf (getf initargs 'plist) :slot-name-lists)
559              (list (list nil slot-name)))
560        initargs))
561     ((:custom :accessor)
562      (let ((initargs (copy-tree
563                       (make-method-function
564                        (lambda (instance)
565                          (pv-binding1 ((bug "Please report this")
566                                        (instance) nil)
567                            (instance-boundp-custom .pv. 0 instance)))))))
568        (setf (getf (getf initargs 'plist) :slot-name-lists)
569              (list (list nil slot-name)))
570        initargs))))
571 \f
572 ;;;; FINDING SLOT DEFINITIONS
573 ;;;
574 ;;; Historical PCL found slot definitions by iterating over
575 ;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover
576 ;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
577 ;;; list up to the desired one.
578 ;;;
579 ;;; Current SBCL hashes the effective slot definitions, and some
580 ;;; information pulled out from them into a simple-vector, with bucket
581 ;;; chains made out of plists keyed by the slot names. This fixes
582 ;;; gives O(1) performance, and avoid the GF calls.
583 ;;;
584 ;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
585 ;;; effective slot definitions and the class they pertain to, and
586 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
587 ;;;
588 ;;; The only bit of cleverness in the implementation is to make the
589 ;;; vectors fairly tight, but always longer then 0 elements:
590 ;;;
591 ;;; -- We don't want to waste huge amounts of space no these vectors,
592 ;;;    which are mostly required by things like SLOT-VALUE with a
593 ;;;    variable slot name, so a constant extension over the minimum
594 ;;;    size seems like a good choise.
595 ;;;
596 ;;; -- As long as the vector always has a length > 0
597 ;;;    FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
598 ;;;    empty vector separately: it just returns a NIL.
599 ;;;
600 ;;; In addition to the slot-definition we also store the slot-location
601 ;;; and type-check function for instances of standard metaclasses, so
602 ;;; that SLOT-VALUE &co using variable slot names can get at them
603 ;;; without additional GF calls.
604 ;;;
605 ;;; Notes:
606 ;;;   It would be probably better to store the vector in wrapper
607 ;;;   instead: one less memory indirection, one less CLOS slot
608 ;;;   access to get at it.
609 ;;;
610 ;;;   It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
611 ;;;   generic instead of checking versus STANDARD-CLASS and
612 ;;;   FUNCALLABLE-STANDARD-CLASS.
613
614 (defun find-slot-definition (class slot-name &optional errorp)
615   (unless (class-finalized-p class)
616     (or (try-finalize-inheritance class)
617         (if errorp
618             (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
619                    slot-name class)
620             (return-from find-slot-definition (values nil nil)))))
621   (dolist (slotd (class-slots class)
622            (if errorp
623                (error "No slot called ~S in ~S." slot-name class)
624                (values nil t)))
625     (when (eq slot-name (slot-definition-name slotd))
626       (return (values slotd t)))))
627
628 (defun find-slot-cell (wrapper slot-name)
629   (declare (symbol slot-name))
630   (let* ((vector (layout-slot-table wrapper))
631          (index (rem (sxhash slot-name) (length vector))))
632     (declare (simple-vector vector) (index index)
633              (optimize (sb-c::insert-array-bounds-checks 0)))
634     (do ((plist (the list (svref vector index)) (cdr plist)))
635         ((not (consp plist)))
636       (let ((key (car plist)))
637         (setf plist (cdr plist))
638         (when (eq key slot-name)
639           (return (car plist)))))))
640
641 (defun make-slot-table (class slots &optional bootstrap)
642   (let* ((n (+ (length slots) 2))
643          (vector (make-array n :initial-element nil)))
644     (flet ((add-to-vector (name slot)
645              (declare (symbol name)
646                       (optimize (sb-c::insert-array-bounds-checks 0)))
647              (let ((index (rem (sxhash name) n)))
648                (setf (svref vector index)
649                      (list* name
650                             (cons (when (or bootstrap
651                                             (and (standard-class-p class)
652                                                  (slot-accessor-std-p slot 'all)))
653                                     (if bootstrap
654                                         (early-slot-definition-location slot)
655                                         (slot-definition-location slot)))
656                                   (the slot-info
657                                     (if bootstrap
658                                         (early-slot-definition-info slot)
659                                         (slot-definition-info slot))))
660                             (svref vector index))))))
661       (if (eq 'complete **boot-state**)
662           (dolist (slot slots)
663             (add-to-vector (slot-definition-name slot) slot))
664           (dolist (slot slots)
665             (add-to-vector (early-slot-definition-name slot) slot))))
666     vector))