source: trunk/source/level-1/l1-clos.lisp @ 12085

Last change on this file since 12085 was 12045, checked in by gz, 10 years ago

Extend the mechanism used to warn about undefined and duplicate functions in a
compilation unit to do the same for types, use it for types defined by
deftype/defstruct/defclass.

Also make proclaim-type err on invalid types and warn about undefined ones.

Tighten up assorted type/ftype declaration checking. This in turn unleashed
a bunch of test suite tests requiring errors on conflicts between DECLARATION
declarations and types, so I put in checks for those as well.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 104.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Copyright (C) 2002-2003 Clozure Associates
5;;;   This file is part of OpenMCL.
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17;;;
18
19;;; At this point in the load sequence, the handful of extant basic classes
20;;; exist only in skeletal form (without direct or effective slot-definitions.)
21
22(in-package "CCL")
23
24(defun extract-slotds-with-allocation (allocation slotds)
25  (collect ((right-ones))
26    (dolist (s slotds (right-ones))
27      (if (eq (%slot-definition-allocation s) allocation)
28        (right-ones s)))))
29
30(defun extract-instance-direct-slotds (class)
31  (extract-slotds-with-allocation :instance (%class-direct-slots class)))
32
33(defun extract-class-direct-slotds (class)
34  (extract-slotds-with-allocation :class (%class-direct-slots class)))
35
36(defun extract-instance-effective-slotds (class)
37  (extract-slotds-with-allocation :instance (%class-slots class)))
38
39(defun extract-class-effective-slotds (class)
40  (extract-slotds-with-allocation :class (%class-slots class)))
41
42(defun extract-instance-and-class-slotds (slotds)
43  (collect ((instance-slots)
44            (shared-slots))
45    (dolist (s slotds (values (instance-slots) (shared-slots)))
46      (if (eq (%slot-definition-allocation s) :class)
47        (shared-slots s)
48        (instance-slots s)))))
49
50
51
52(defun direct-instance-and-class-slotds (class)
53  (extract-instance-and-class-slotds (%class-direct-slots class)))
54
55(defun effective-instance-and-class-slotds (class)
56  (extract-instance-and-class-slotds (%class-slots class)))
57
58(defun %early-shared-initialize (instance slot-names initargs)
59  (unless (or (listp slot-names) (eq slot-names t))
60    (report-bad-arg slot-names '(or list (eql t))))
61  ;; Check that initargs contains valid key/value pairs,
62  ;; signal a PROGRAM-ERROR otherwise.  (Yes, this is
63  ;; an obscure way to do so.)
64  (destructuring-bind (&key &allow-other-keys) initargs)
65  (let* ((wrapper (instance-class-wrapper instance))
66         (class (%wrapper-class wrapper)))
67    (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete
68      (update-obsolete-instance instance)
69      (setq wrapper (instance-class-wrapper instance)))
70    (dolist (slotd (%class-slots class))
71      (let* ((loc (%slot-definition-location slotd)))
72        (multiple-value-bind (ignore new-value foundp)
73            (get-properties initargs
74                            (%slot-definition-initargs slotd))
75          (declare (ignore ignore))
76          (if foundp
77            (progn
78              (unless (funcall (standard-effective-slot-definition.type-predicate slotd) new-value)
79                (error 'bad-slot-type-from-initarg
80                       :slot-definition slotd
81                       :instance instance
82                       :datum new-value
83                       :expected-type  (%slot-definition-type slotd)
84                       :initarg-name (car foundp)))
85              (if (consp loc)
86                (rplacd loc new-value)
87                (setf (standard-instance-instance-location-access instance loc)
88                      new-value)))
89            (if (or (eq slot-names t)
90                    (member (%slot-definition-name slotd)
91                            slot-names
92                            :test #'eq))
93              (let* ((curval (if (consp loc)
94                               (cdr loc)
95                               (%standard-instance-instance-location-access
96                                instance loc))))
97                (if (eq curval (%slot-unbound-marker))
98                  (let* ((initfunction (%slot-definition-initfunction slotd)))
99                    (if initfunction
100                      (let* ((newval (funcall initfunction)))
101                        (unless (funcall (standard-effective-slot-definition.type-predicate slotd) newval)
102                          (error 'bad-slot-type-from-initform
103                                 :slot-definition slotd
104                                 :expected-type (%slot-definition-type slotd)
105                                 :datum newval
106                                 :instance instance))
107                        (if (consp loc)
108                          (rplacd loc newval)
109                          (setf (standard-instance-instance-location-access
110                                 instance loc)
111                                newval)))))))))))))
112  instance)
113
114(setf (fdefinition '%shared-initialize) #'%early-shared-initialize)
115
116;;; This is redefined (to call MAKE-INSTANCE) below.
117(setf (fdefinition '%make-direct-slotd)
118      #'(lambda (slotd-class &key
119                             name
120                             initfunction
121                             initform
122                             initargs
123                             (allocation :instance)
124                             class
125                             (type t)
126                             (documentation (%slot-unbound-marker))
127                             readers
128                             writers)
129          (declare (ignore slotd-class))
130          (%instance-vector
131           (%class.own-wrapper *standard-direct-slot-definition-class*)
132           name type initfunction initform initargs allocation
133           documentation class readers writers)))
134
135;;; Also redefined below, after MAKE-INSTANCE is possible.
136(setf (fdefinition '%make-effective-slotd)
137      #'(lambda (slotd-class &key
138                             name
139                             initfunction
140                             initform
141                             initargs
142                             allocation
143                             class
144                             type
145                             documentation)
146          (declare (ignore slotd-class))
147          (%instance-vector
148           (%class.own-wrapper *standard-effective-slot-definition-class*)
149           name type initfunction initform initargs allocation
150           documentation class nil (ensure-slot-id name) #'true)))
151
152
153(defmethod compile-time-class-p ((class class)) nil)
154
155(defmethod direct-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
156  (unless (member allocation '(:instance :class))
157    (report-bad-arg allocation '(member (:instance :class))))
158  *standard-direct-slot-definition-class*)
159
160(defmethod effective-slot-definition-class ((class std-class) &key (allocation :instance) &allow-other-keys)
161  (unless (member allocation '(:instance :class))
162    (report-bad-arg allocation '(member (:instance :class))))
163  *standard-effective-slot-definition-class*)
164
165(defun make-direct-slot-definition (class initargs)
166  (apply #'%make-direct-slotd
167         (apply #'direct-slot-definition-class class initargs)
168         :class class
169         initargs))
170
171(defun make-effective-slot-definition (class &rest initargs)
172  (declare (dynamic-extent initargs))
173  (apply #'%make-effective-slotd
174         (apply #'effective-slot-definition-class class initargs)
175         initargs))
176
177;; Bootstrapping version, replaced in l1-typesys
178(fset 'standardized-type-specifier
179      (nlambda bootstrapping-standardized-type-specifier (spec)
180        (when (and (consp spec)
181                   (memq (%car spec) '(and or))
182                   (consp (%cdr spec))
183                   (null (%cddr spec)))
184          (setq spec (%cadr spec)))
185        (if (consp spec)
186          (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec)))
187          (or (cdr (assoc spec '((string . base-string))))
188              spec))))
189
190;;; The type of an effective slot definition is the intersection of
191;;; the types of the direct slot definitions it's initialized from.
192(defun dslotd-type-intersection (direct-slots)
193  (or (dolist (dslotd direct-slots t)
194        (unless (eq t (%slot-definition-type dslotd))
195          (return)))
196      (standardized-type-specifier
197       (if (cdr direct-slots)
198         `(and ,@(mapcar #'(lambda (d) (or (%slot-definition-type d) t))
199                         direct-slots))
200         (%slot-definition-type (car direct-slots))))))
201
202(defmethod compute-effective-slot-definition ((class slots-class)
203                                              name
204                                              direct-slots)
205 
206  (let* ((initer (dolist (s direct-slots)
207                   (when (%slot-definition-initfunction s)
208                     (return s))))
209         (documentor (dolist (s direct-slots)
210                       (when (%slot-definition-documentation s)
211                         (return s))))
212         (first (car direct-slots))
213         (initargs (let* ((initargs nil))
214                     (dolist (dslot direct-slots initargs)
215                       (dolist (dslot-arg (%slot-definition-initargs  dslot))
216                         (pushnew dslot-arg initargs :test #'eq))))))
217    (make-effective-slot-definition
218     class
219     :name name
220     :allocation (%slot-definition-allocation first)
221     :documentation (when documentor (nth-value
222                                      1
223                                      (%slot-definition-documentation
224                                       documentor)))
225     :class (%slot-definition-class first)
226     :initargs initargs
227     :initfunction (if initer (%slot-definition-initfunction initer))
228     :initform (if initer (%slot-definition-initform initer))
229     :type (dslotd-type-intersection direct-slots))))
230
231(defmethod compute-slots ((class slots-class))
232  (let* ((slot-name-alist ()))
233    (labels ((note-direct-slot (dslot)
234               (let* ((sname (%slot-definition-name dslot))
235                      (pair (assq sname slot-name-alist)))
236                 (if pair
237                   (push dslot (cdr pair))
238                   (push (list sname dslot) slot-name-alist))))
239             (rwalk (tail)
240               (when tail
241                 (rwalk (cdr tail))
242                 (let* ((c (car tail)))
243                   (unless (eq c *t-class*)
244                     (dolist (dslot (%class-direct-slots c))
245                       (note-direct-slot dslot)))))))
246      (rwalk (class-precedence-list class)))
247    (collect ((effective-slotds))
248      (dolist (pair (nreverse slot-name-alist) (effective-slotds))
249        (effective-slotds (compute-effective-slot-definition class (car pair) (cdr pair)))))))
250
251
252(defmethod compute-slots :around ((class std-class))
253  (let* ((cpl (%class.cpl class)))
254    (multiple-value-bind (instance-slots class-slots)
255        (extract-instance-and-class-slotds (call-next-method))
256      (setq instance-slots (sort-effective-instance-slotds instance-slots class cpl))
257      (do* ((loc 1 (1+ loc))
258            (islotds instance-slots (cdr islotds)))
259           ((null islotds))
260        (declare (fixnum loc))
261        (setf (%slot-definition-location (car islotds)) loc))
262      (dolist (eslotd class-slots)
263        (setf (%slot-definition-location eslotd) 
264              (assoc (%slot-definition-name eslotd)
265                     (%class-get (%slot-definition-class eslotd)
266                                 :class-slots)
267                     :test #'eq)))
268      (append instance-slots class-slots))))
269
270(defmethod compute-slots :around ((class structure-class))
271  (let* ((slots (call-next-method))      )
272      (do* ((loc 1 (1+ loc))
273            (islotds slots (cdr islotds)))
274           ((null islotds) slots)
275        (declare (fixnum loc))
276        (setf (%slot-definition-location (car islotds)) loc))))
277
278;;; Should eventually do something here.
279;(defmethod compute-slots ((s structure-class))
280;  (call-next-method))
281
282(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
283  (declare (ignore initargs))
284  (find-class 'structure-direct-slot-definition))
285
286(defmethod effective-slot-definition-class ((class structure-class) &rest  initargs)
287  (declare (ignore initargs))
288  (find-class 'structure-effective-slot-definition))
289
290
291(defmethod compute-default-initargs ((class slots-class))
292  (let* ((initargs ()))
293    (dolist (c (%class-precedence-list class) (nreverse initargs))
294      (if (typep c 'forward-referenced-class)
295        (error
296         "Class precedence list of ~s contains FORWARD-REFERENCED-CLASS ~s ."
297         class c)
298        (dolist (i (%class-direct-default-initargs c))
299          (pushnew i initargs :test #'eq :key #'car))))))
300
301
302
303
304(defvar *update-slots-preserve-existing-wrapper* nil)
305
306(defvar *optimized-dependents* (make-hash-table :test 'eq :weak :key)
307  "Hash table mapping a class to a list of all objects that have been optimized to
308   depend in some way on the layout of the class")
309
310(defun note-class-dependent (class gf)
311  (pushnew gf (gethash class *optimized-dependents*)))
312
313(defun unoptimize-dependents (class)
314  (pessimize-make-instance-for-class-name (%class-name class))
315  (loop for obj in (gethash class *optimized-dependents*)
316        do (etypecase obj
317             (standard-generic-function
318              (clear-gf-dispatch-table (%gf-dispatch-table obj))
319              (compute-dcode obj)))))
320
321(defun update-slots (class eslotds)
322  (let* ((instance-slots (extract-slotds-with-allocation :instance eslotds))
323         (new-ordering
324          (let* ((v (make-array (the fixnum (length instance-slots))))
325                 (i 0))
326            (declare (simple-vector v) (fixnum i))
327            (dolist (e instance-slots v)
328              (setf (svref v i)
329                    (%slot-definition-name e))
330              (incf i))))
331         (old-wrapper (%class-own-wrapper class))
332         (new-wrapper
333          (cond ((null old-wrapper)
334                 (%cons-wrapper class))
335                ((and old-wrapper *update-slots-preserve-existing-wrapper*)
336                 old-wrapper)
337                (t
338                 (unoptimize-dependents class)
339                 (make-instances-obsolete class)
340                 (%cons-wrapper class)))))
341    (setf (%class-slots class) eslotds)
342    (setf (%wrapper-instance-slots new-wrapper) new-ordering
343          (%wrapper-class-slots new-wrapper) (%class-get class :class-slots)
344          (%class-own-wrapper class) new-wrapper)
345    (setup-slot-lookup new-wrapper eslotds)))
346
347
348 
349(defun setup-slot-lookup (wrapper eslotds)
350  (when eslotds
351    (let* ((nslots (length eslotds))
352           (total-slot-ids (current-slot-index))
353           (small (< nslots 255))
354           (map
355            (if small
356              (make-array total-slot-ids :element-type '(unsigned-byte 8))
357              (make-array total-slot-ids :element-type '(unsigned-byte 32))))
358           (table (make-array (the fixnum (1+ nslots))))
359           (i 0))
360      (declare (fixnum nslots total-slot-ids i) (simple-vector table))
361      (setf (svref table 0) nil)
362      (dolist (slotd eslotds)
363        (incf i)
364        (setf (svref table i) slotd)
365        (if small
366          (locally (declare (type (simple-array (unsigned-byte 8) (*)) map))
367            (setf (aref map
368                        (slot-id.index
369                         (standard-effective-slot-definition.slot-id slotd)))
370                  i))
371          (locally (declare (type (simple-array (unsigned-byte 32) (*)) map))
372            (setf (aref map
373                        (slot-id.index
374                         (standard-effective-slot-definition.slot-id slotd)))
375                  i))))
376      (let* ((lookup-f
377              #+ppc-target
378              (gvector :function
379                                (%svref (if small
380                                          #'%small-map-slot-id-lookup
381                                          #'%large-map-slot-id-lookup) 0)
382                                map
383                                table
384                                (dpb 1 $lfbits-numreq
385                                     (ash -1 $lfbits-noname-bit)))
386              #+x86-target
387              (%clone-x86-function (if small
388                                          #'%small-map-slot-id-lookup
389                                          #'%large-map-slot-id-lookup)
390                                   map
391                                   table
392                                   (dpb 1 $lfbits-numreq
393                                     (ash -1 $lfbits-noname-bit))))
394             (class (%wrapper-class wrapper))
395             (get-f
396              #+ppc-target
397              (gvector :function
398                       (%svref (if small
399                                 #'%small-slot-id-value
400                                 #'%large-slot-id-value) 0)
401                       map
402                       table
403                       class
404                       #'%maybe-std-slot-value-using-class
405                       #'%slot-id-ref-missing
406                       (dpb 2 $lfbits-numreq
407                            (ash -1 $lfbits-noname-bit)))
408              #+x86-target
409              (%clone-x86-function (if small
410                                     #'%small-slot-id-value
411                                     #'%large-slot-id-value)
412                                   map
413                                   table
414                                   class
415                                   #'%maybe-std-slot-value-using-class
416                                   #'%slot-id-ref-missing
417                                   (dpb 2 $lfbits-numreq
418                                        (ash -1 $lfbits-noname-bit))))
419             (set-f
420              #+ppc-target
421              (gvector :function
422                       (%svref (if small
423                                 #'%small-set-slot-id-value
424                                 #'%large-set-slot-id-value) 0)
425                       map
426                       table
427                       class
428                       #'%maybe-std-setf-slot-value-using-class
429                       #'%slot-id-set-missing
430                       (dpb 3 $lfbits-numreq
431                            (ash -1 $lfbits-noname-bit)))
432              #+x86-target
433              (%clone-x86-function
434               (if small
435                 #'%small-set-slot-id-value
436                 #'%large-set-slot-id-value)
437               map
438               table
439               class
440               #'%maybe-std-setf-slot-value-using-class
441               #'%slot-id-set-missing
442               (dpb 3 $lfbits-numreq
443                    (ash -1 $lfbits-noname-bit)))))
444        (setf (%wrapper-slot-id->slotd wrapper) lookup-f
445              (%wrapper-slot-id-value wrapper) get-f
446              (%wrapper-set-slot-id-value wrapper) set-f
447              (%wrapper-slot-id-map wrapper) map
448              (%wrapper-slot-definition-table wrapper) table))))
449  wrapper)
450
451                       
452   
453
454(defmethod validate-superclass ((class class) (super class))
455  (or (eq super *t-class*)
456      (let* ((class-of-class (class-of class))
457             (class-of-super (class-of super)))
458        (or (eq class-of-class class-of-super)
459            (and (eq class-of-class *standard-class-class*)
460                 (eq class-of-super *funcallable-standard-class-class*))
461            (and (eq class-of-class *funcallable-standard-class-class*)
462                 (eq class-of-super *standard-class-class*))))))
463
464(defmethod validate-superclass ((class foreign-class) (super standard-class))
465  t)
466
467(defmethod validate-superclass ((class std-class) (super forward-referenced-class))
468  t)
469
470
471(defmethod add-direct-subclass ((class class) (subclass class))
472  (pushnew subclass (%class-direct-subclasses class))
473  subclass)
474
475(defmethod remove-direct-subclass ((class class) (subclass class))
476  (setf (%class-direct-subclasses class)
477        (remove subclass (%class-direct-subclasses class)))
478  subclass)
479
480(defun add-direct-subclasses (class new)
481  (dolist (n new)
482    (unless (memq class (%class-direct-subclasses  class))
483      (add-direct-subclass n class))))
484
485(defun remove-direct-subclasses (class old-supers new-supers)
486  (dolist (o old-supers)
487    (unless (memq o new-supers)
488      (remove-direct-subclass o class))))
489
490;;; Built-in classes are always finalized.
491(defmethod class-finalized-p ((class class))
492  t)
493
494;;; Standard classes are finalized if they have a wrapper and that
495;;; wrapper has an instance-slots vector; that implies that
496;;; both UPDATE-CPL and UPDATE-SLOTS have been called on the class.
497(defmethod class-finalized-p ((class std-class))
498  (let* ((w (%class-own-wrapper class)))
499    (and w (typep (%wrapper-instance-slots w) 'vector))))
500
501(defmethod finalize-inheritance ((class std-class))
502  (update-class class t))
503
504
505(defmethod finalize-inheritance ((class forward-referenced-class))
506  (error "Class ~s can't be finalized." class))
507
508(defmethod class-primary-p ((class slots-class))
509  (%class-primary-p class))
510
511(defmethod (setf class-primary-p) (new (class std-class))
512  (setf (%class-primary-p class) new))
513
514(defmethod class-primary-p ((class class))
515  t)
516
517(defmethod (setf class-primary-p) (new (class class))
518  new)
519
520
521(defun forward-referenced-class-p (class)
522  (and (%standard-instance-p class)
523       (eq (%class-of-instance class) *forward-referenced-class-class*)))
524
525;;; This uses the primary class information to sort the slots of a class.
526(defun sort-effective-instance-slotds (slotds class cpl)
527  (let (primary-slotds
528        primary-slotds-class
529        (primary-slotds-length 0))
530    (declare (fixnum primary-slotds-length))
531    (dolist (sup (cdr cpl))
532      (unless (eq sup *t-class*)     
533        (when (class-primary-p sup)
534          (let ((sup-slotds (extract-instance-effective-slotds sup)))
535            (if (null primary-slotds-class)
536              (setf primary-slotds-class sup
537                    primary-slotds sup-slotds
538                    primary-slotds-length (length sup-slotds))
539              (let ((sup-slotds-length (length sup-slotds)))
540                (do* ((i 0 (1+ i))
541                      (n (min sup-slotds-length primary-slotds-length))
542                      (sup-slotds sup-slotds (cdr sup-slotds))
543                      (primary-slotds primary-slotds (cdr primary-slotds)))
544                     ((= i n))
545                  (unless (eq (%slot-definition-name (car sup-slotds))
546                              (%slot-definition-name (car primary-slotds)))
547                    (error "While initializing ~s:~%~
548                            attempt to mix incompatible primary classes:~%~
549                            ~s and ~s"
550                           class sup primary-slotds-class)))
551                (when (> sup-slotds-length primary-slotds-length)
552                  (setq primary-slotds-class sup
553                        primary-slotds sup-slotds
554                        primary-slotds-length sup-slotds-length))))))))
555    (if (null primary-slotds-class)
556      slotds
557      (flet ((slotd-position (slotd)
558               (let* ((slotd-name (%slot-definition-name slotd)))
559                 (do* ((i 0 (1+ i))
560                       (primary-slotds primary-slotds (cdr primary-slotds)))
561                      ((= i primary-slotds-length) primary-slotds-length)
562                   (declare (fixnum i))
563                   (when (eq slotd-name
564                                (%slot-definition-name (car primary-slotds)))
565                   (return i))))))
566        (declare (dynamic-extent #'slotd-position))
567        (sort-list slotds '< #'slotd-position)))))
568
569
570
571
572(defun update-cpl (class cpl)
573  (if (class-finalized-p class)
574    (unless (equal (%class.cpl class) cpl)
575      (setf (%class.cpl class) cpl)
576      #|(force-cache-flushes class)|#)
577    (setf (%class.cpl class) cpl))
578  cpl)
579
580
581(defun class-has-a-forward-referenced-superclass-p (original)
582  (labels ((scan-forward-refs (class seen)
583             (unless (memq class seen)
584               (or (if (forward-referenced-class-p class) class)
585                   (let ((seen (cons class seen)))
586                     (declare (dynamic-extent seen))
587                     (dolist (s (%class-direct-superclasses class))
588                       (when (eq s original)
589                         (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class))
590                       (let* ((fwdref (scan-forward-refs s seen)))
591                         (when fwdref (return fwdref)))))))))
592    (or (compile-time-class-p original)
593        (scan-forward-refs original ()))))
594
595(defun class-forward-referenced-superclasses (original)
596  (labels ((scan-forward-refs (class seen fwdrefs)
597             (unless (memq class seen)
598               (if (forward-referenced-class-p class)
599                 (push class fwdrefs)
600                 (let ((seen (cons class seen)))
601                   (declare (dynamic-extent seen))
602                   (dolist (s (%class-direct-superclasses class))
603                     (when (eq s original)
604                       (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class))
605                     (setq fwdrefs (scan-forward-refs s seen fwdrefs))))))
606             fwdrefs))
607    (scan-forward-refs original () ())))
608 
609
610
611(defmethod compute-class-precedence-list ((class class))
612  (let* ((fwdrefs (class-forward-referenced-superclasses class)))
613    (if fwdrefs
614      (if (cdr fwdrefs)
615        (error "Class ~s can't be finalized because superclasses ~s are not defined yet"
616               class (mapcar #'%class-name fwdrefs))
617        (error "Class ~s can't be finalized because superclass ~s is not defined yet"
618               class (%class-name (car fwdrefs))))
619      (compute-cpl class))))
620
621;;; Classes that can't be instantiated via MAKE-INSTANCE have no
622;;; initargs caches.
623(defmethod %flush-initargs-caches ((class class))
624  )
625
626;;; Classes that have initargs caches should flush them when the
627;;; class is finalized.
628(defmethod %flush-initargs-caches ((class std-class))
629  (setf (%class.make-instance-initargs class) nil
630        (%class.reinit-initargs class) nil
631        (%class.redefined-initargs class) nil
632        (%class.changed-initargs class) nil))
633
634(defun update-class (class finalizep)
635  ;;
636  ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
637  ;; makes the class finalized.  When UPDATE-CLASS isn't called from
638  ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
639  ;; FINALIZE-INHERITANCE as per AMOP.  Note, that we can't simply
640  ;; delay the finalization when CLASS has no forward referenced
641  ;; superclasses because that causes bootstrap problems.
642  (when (and (not (or finalizep (class-finalized-p class)))
643             (not (class-has-a-forward-referenced-superclass-p class)))
644    (finalize-inheritance class)
645    (return-from update-class))
646  (when (or finalizep (class-finalized-p class))
647    (let* ((cpl (update-cpl class (compute-class-precedence-list  class))))
648      ;; This -should- be made to work for structure classes
649      (update-slots class (compute-slots class))
650      (setf (%class-default-initargs class) (compute-default-initargs class))
651      (%flush-initargs-caches class)
652      (let* ((wrapper (%class-own-wrapper class)))
653        (when wrapper
654          (setf (%wrapper-cpl wrapper) cpl
655                (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl))))))
656  (unless finalizep
657    (dolist (sub (%class-direct-subclasses class))
658      (update-class sub nil))))
659
660(defun add-accessor-methods (class dslotds)
661  (dolist (dslotd dslotds)
662    (dolist (reader (%slot-definition-readers dslotd))
663      (add-reader-method class
664                         (ensure-generic-function reader)
665                         dslotd))
666    (dolist (writer (%slot-definition-writers dslotd))
667      (add-writer-method class
668                         (ensure-generic-function writer)
669                         dslotd))))
670
671(defun remove-accessor-methods (class dslotds)
672  (dolist (dslotd dslotds)
673    (dolist (reader (%slot-definition-readers dslotd))
674      (remove-reader-method class (ensure-generic-function reader :lambda-list '(x))))
675    (dolist (writer (%slot-definition-writers dslotd))
676      (remove-writer-method class (ensure-generic-function writer :lambda-list '(x y))))))
677
678(defmethod reinitialize-instance :before ((class std-class)  &key direct-superclasses)
679  (remove-accessor-methods class (%class-direct-slots class))
680  (remove-direct-subclasses class (%class-direct-superclasses class) direct-superclasses))
681   
682(defmethod shared-initialize :after
683  ((class slots-class)
684   slot-names &key
685   (direct-superclasses nil direct-superclasses-p)
686   (direct-slots nil direct-slots-p)
687   (direct-default-initargs nil direct-default-initargs-p)
688   (documentation nil doc-p)
689   (primary-p nil primary-p-p))
690  (if (or direct-superclasses-p (eq slot-names t))
691    (progn
692      (setq direct-superclasses
693            (or direct-superclasses
694                (list (if (typep class 'funcallable-standard-class)
695                        *funcallable-standard-object-class*
696                        *standard-object-class*))))
697      (dolist (superclass direct-superclasses)
698        (unless (validate-superclass class superclass)
699          (error "The class ~S was specified as a~%super-class of the class ~S;~%~
700                    but the meta-classes ~S and~%~S are incompatible."
701                 superclass class (class-of superclass) (class-of class))))
702      (setf (%class-direct-superclasses class) direct-superclasses))
703    (setq direct-superclasses (%class-direct-superclasses class)))
704  (setq direct-slots
705        (if direct-slots-p
706          (setf (%class-direct-slots class)
707                (mapcar #'(lambda (initargs)
708                            (make-direct-slot-definition class initargs))
709                        direct-slots))
710          (%class-direct-slots class)))
711  (if direct-default-initargs-p
712    (setf (%class-direct-default-initargs class)  direct-default-initargs)
713    (setq direct-default-initargs (%class-direct-default-initargs class)))
714  (let* ((new-class-slot-cells ())
715         (old-class-slot-cells (%class-get class :class-slots)))
716    (dolist (slot direct-slots)
717      (when (eq (%slot-definition-allocation slot) :class)
718        (let* ((slot-name (%slot-definition-name slot))
719               (pair (assq slot-name old-class-slot-cells)))
720          ;;; If the slot existed as a class slot in the old
721          ;;; class, retain the definition (even if it's unbound.)
722          (unless pair
723            (let* ((initfunction (%slot-definition-initfunction slot)))
724              (setq pair (cons slot-name
725                               (if initfunction
726                                 (funcall initfunction)
727                                 (%slot-unbound-marker))))))
728          (push pair new-class-slot-cells))))
729    (when new-class-slot-cells
730      (setf (%class-get class :class-slots) new-class-slot-cells)))
731  (when doc-p
732    (set-documentation class 'type documentation))
733  (when primary-p-p
734    (setf (class-primary-p class) primary-p))
735
736  (add-direct-subclasses class direct-superclasses)
737  (update-class class nil)
738  (add-accessor-methods class direct-slots))
739
740(defmethod initialize-instance :before ((class class) &key &allow-other-keys)
741  (setf (%class-ordinal class) (%next-class-ordinal))
742  (setf (%class.ctype class) (make-class-ctype class)))
743
744(defun ensure-class-metaclass-and-initargs (class args)
745  (let* ((initargs (copy-list args))
746         (missing (cons nil nil))
747         (supplied-meta (getf initargs :metaclass missing))
748         (supplied-supers (getf initargs :direct-superclasses missing))
749         (supplied-slots (getf initargs :direct-slots missing))
750         (metaclass (cond ((not (eq supplied-meta missing))
751                           (if (typep supplied-meta 'class)
752                             supplied-meta
753                             (find-class supplied-meta)))
754                          ((or (null class)
755                               (typep class 'forward-referenced-class))
756                           *standard-class-class*)
757                          (t (class-of class)))))
758    (declare (dynamic-extent missing))
759    (flet ((fix-super (s)
760             (cond ((classp s) s)
761                   ((not (and s (symbolp s)))
762                    (error "~s is not a class or a legal class name." s))
763                   (t
764                    (or (find-class s nil)
765                        (setf (find-class s)
766                              (make-instance 'forward-referenced-class :name s))))))
767           (excise-all (keys)
768             (dolist (key keys)
769               (loop (unless (remf initargs key) (return))))))
770      (excise-all '(:metaclass :direct-superclasses :direct-slots))
771      (values metaclass
772              `(,@ (unless (eq supplied-supers missing)
773                     `(:direct-superclasses ,(mapcar #'fix-super supplied-supers)))
774                ,@ (unless (eq supplied-slots missing)
775                     `(:direct-slots ,supplied-slots))
776               ,@initargs)))))
777
778
779;;; This defines a new class.
780(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys)
781  (multiple-value-bind (metaclass initargs)
782      (ensure-class-metaclass-and-initargs class keys)
783    (let* ((class (apply #'make-instance metaclass :name name initargs)))
784      (setf (find-class name) class))))
785
786(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys)
787  (multiple-value-bind (metaclass initargs)
788      (ensure-class-metaclass-and-initargs class keys)
789    (apply #'change-class class metaclass initargs)
790    (apply #'reinitialize-instance class initargs)
791    (setf (find-class name) class)))
792           
793;; Can't go with optimize-make-instance-for-class-name because
794;; ensure-class-using-class is called before that is defined.
795(defun pessimize-make-instance-for-class-name (class-name)
796  (let ((cell (find-class-cell class-name nil)))
797    (when cell
798      (init-class-cell-instantiator cell))))
799
800(defun init-class-cell-instantiator (cell)
801  (when cell
802    (setf (class-cell-instantiate cell) '%make-instance)
803    (setf (class-cell-extra cell) nil)))
804
805;;; Redefine an existing (not forward-referenced) class.
806(defmethod ensure-class-using-class ((class class) name &rest keys &key)
807  (multiple-value-bind (metaclass initargs)
808      (ensure-class-metaclass-and-initargs class keys)
809    (unless (eq (class-of class) metaclass)
810      (error "Can't change metaclass of ~s to ~s." class metaclass))
811    (apply #'reinitialize-instance class initargs)
812    (setf (find-class name) class)))
813
814
815(defun ensure-class (name &rest keys &key &allow-other-keys)
816  (declare (dynamic-extent keys))
817  (apply #'ensure-class-using-class (find-class name nil) name keys))
818
819(defparameter *defclass-redefines-improperly-named-classes-pedantically* 
820   t
821  "ANSI CL expects DEFCLASS to redefine an existing class only when
822the existing class is properly named, the MOP function ENSURE-CLASS
823redefines existing classes regardless of their CLASS-NAME.  This variable
824governs whether DEFCLASS makes that distinction or not.")
825
826(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
827  (declare (dynamic-extent keys))
828  (record-source-file name 'class)
829  (let* ((existing-class (find-class name nil)))
830    (when (and *defclass-redefines-improperly-named-classes-pedantically* 
831               existing-class 
832               (not (eq (class-name existing-class) name)))
833      ;; Class isn't properly named; act like it didn't exist
834      (setq existing-class nil))
835    (apply #'ensure-class-using-class existing-class name keys)))
836
837
838
839
840(defmethod method-slot-name ((m standard-accessor-method))
841  (standard-direct-slot-definition.name (%accessor-method.slot-definition m)))
842
843
844(defun %ensure-class-preserving-wrapper (&rest args)
845  (declare (dynamic-extent args))
846  (let* ((*update-slots-preserve-existing-wrapper* t))
847    (apply #'ensure-class args)))
848
849(defun %find-direct-slotd (class name)
850  (dolist (dslotd (%class-direct-slots class)
851           (error "Direct slot definition for ~s not found in ~s" name class))
852    (when (eq (%slot-definition-name dslotd) name)
853      (return dslotd))))
854
855(defun %add-slot-readers (class-name pairs)
856  (let* ((class (find-class class-name)))
857    (dolist (pair pairs)
858      (destructuring-bind (slot-name &rest readers) pair
859        (setf (%slot-definition-readers (%find-direct-slotd class slot-name)) readers)))
860    (add-accessor-methods class (%class-direct-slots class))))
861
862(defun %add-slot-writers (class-name pairs)
863  (let* ((class (find-class class-name)))
864    (dolist (pair pairs)
865      (destructuring-bind (slot-name &rest readers) pair
866        (setf (%slot-definition-writers (%find-direct-slotd class slot-name)) readers)))
867    (add-accessor-methods class (%class-direct-slots class))))
868
869
870(%ensure-class-preserving-wrapper
871 'standard-method
872 :direct-superclasses '(method)
873 :direct-slots `((:name qualifiers :initargs (:qualifiers) :initfunction ,#'false :initform nil)
874                 (:name specializers :initargs (:specializers) :initfunction ,#'false :initform nil)
875                 (:name function :initargs (:function))
876                 (:name generic-function :initargs (:generic-function) :initfunction ,#'false :initform nil)
877                 (:name name :initargs (:name) :initfunction ,#'false :initform nil)
878                 (:name lambda-list :initform nil :initfunction ,#'false
879                  :initargs (:lambda-list)))
880 :primary-p t)
881
882(defmethod shared-initialize :after ((method standard-method)
883                                     slot-names
884                                     &key function &allow-other-keys)
885  (declare (ignore slot-names))
886  (when function
887    (let* ((inner (closure-function function)))
888      (unless (eq inner function)
889        (copy-method-function-bits inner function)))   
890    (lfun-name function method)))
891
892;;; Reader & writer methods classes.
893(%ensure-class-preserving-wrapper
894 'standard-accessor-method
895 :direct-superclasses '(standard-method)
896 :direct-slots '((:name slot-definition :initargs (:slot-definition)))
897 :primary-p t)
898
899(%ensure-class-preserving-wrapper
900 'standard-reader-method
901 :direct-superclasses '(standard-accessor-method))
902
903(%ensure-class-preserving-wrapper
904 'standard-writer-method
905 :direct-superclasses '(standard-accessor-method))
906
907(defmethod reader-method-class ((class standard-class)
908                                (dslotd standard-direct-slot-definition)
909                                &rest initargs)
910  (declare (ignore initargs))
911  *standard-reader-method-class*)
912
913(defmethod reader-method-class ((class funcallable-standard-class)
914                                (dslotd standard-direct-slot-definition)
915                                &rest initargs)
916  (declare (ignore  initargs))
917  *standard-reader-method-class*)
918
919(defmethod add-reader-method ((class slots-class) gf dslotd)
920  (let* ((initargs
921          `(:qualifiers nil
922            :specializers ,(list class)
923            :lambda-list (,(or (%class-name class) 'instance))
924            :name ,(function-name gf)
925            :slot-definition ,dslotd))
926         (reader-method-class
927          (apply #'reader-method-class class dslotd initargs))
928         (method-function (create-reader-method-function
929                           class (class-prototype reader-method-class) dslotd))
930         (method (apply #'make-instance reader-method-class
931                        :function method-function
932                        initargs)))
933    (declare (dynamic-extent initargs))
934    (record-source-file method 'reader-method)
935    (add-method gf method)))
936
937(defmethod remove-reader-method ((class std-class) gf)
938  (let* ((method (find-method gf () (list class) nil)))
939    (when method (remove-method gf method))))
940
941(defmethod writer-method-class ((class standard-class)
942                                (dslotd standard-direct-slot-definition)
943                                &rest initargs)
944  (declare (ignore initargs))
945  *standard-writer-method-class*)
946
947(defmethod writer-method-class ((class funcallable-standard-class)
948                                (dslotd standard-direct-slot-definition)
949                                &rest initargs)
950  (declare (ignore initargs))
951  *standard-writer-method-class*)
952
953
954(defmethod add-writer-method ((class slots-class) gf dslotd)
955  (let* ((initargs
956          `(:qualifiers nil
957            :specializers ,(list *t-class* class)
958            :lambda-list (new-value ,(or (%class-name class) 'instance))
959            :name ,(function-name gf)
960            :slot-definition ,dslotd))
961         (method-class (apply #'writer-method-class class dslotd initargs))
962         (method 
963          (apply #'make-instance
964                 method-class
965                 :function (create-writer-method-function
966                            class
967                            (class-prototype method-class)
968                            dslotd)
969                 initargs)))
970    (declare (dynamic-extent initargs))
971    (record-source-file method 'writer-method)
972    (add-method gf method)))
973
974(defmethod remove-writer-method ((class std-class) gf)
975  (let* ((method (find-method gf () (list *t-class* class) nil)))
976    (when method (remove-method gf method))))
977
978;;; We can now define accessors.  Fix up the slots in the classes defined
979;;; thus far.
980
981(%add-slot-readers 'standard-method '((qualifiers method-qualifiers)
982                                      (specializers method-specializers)
983                                      (name method-name)
984                                      ;(function method-function)
985                                      (generic-function method-generic-function)
986                                      (lambda-list method-lambda-list)))
987
988(%add-slot-writers 'standard-method '((function (setf method-function))
989                                      (generic-function (setf method-generic-function))))
990
991
992(defmethod method-function ((m standard-method))
993  (%method.function m))
994
995
996(%add-slot-readers 'standard-accessor-method
997                   '((slot-definition accessor-method-slot-definition)))
998
999
1000(%ensure-class-preserving-wrapper
1001 'specializer
1002 :direct-superclasses '(metaobject)
1003 :direct-slots `((:name direct-methods
1004                  :readers (specializer-direct-methods)
1005                  :initform nil :initfunction ,#'false))
1006 :primary-p t)
1007                 
1008(%ensure-class-preserving-wrapper
1009 'eql-specializer
1010 :direct-superclasses '(specializer)
1011 :direct-slots '((:name object :initargs (:object) :readers (eql-specializer-object)))
1012 :primary-p t)
1013
1014
1015(%ensure-class-preserving-wrapper
1016 'class
1017 :direct-superclasses '(specializer)
1018 :direct-slots
1019 `((:name prototype :initform nil :initfunction ,#'false)
1020   (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name))
1021   (:name precedence-list :initform nil  :initfunction ,#'false)
1022   (:name own-wrapper :initform nil  :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper)))
1023   (:name direct-superclasses  :initform nil  :initfunction ,#'false :readers (class-direct-superclasses))
1024   (:name direct-subclasses  :initform nil  :initfunction ,#'false :readers (class-direct-subclasses))
1025   (:name dependents :initform nil :initfunction ,#'false)
1026   (:name class-ctype :initform nil :initfunction ,#'false)
1027   (:name direct-slots :initform nil :initfunction ,#'false
1028                  :readers (class-direct-slots)
1029                  :writers ((setf class-direct-slots)))
1030   (:name slots :initform nil :initfunction ,#'false
1031    :readers (class-slots)
1032    :writers ((setf class-slots)))
1033   (:name info :initform (cons nil nil) :initfunction ,(lambda () (cons nil nil)) :readers (class-info))
1034   (:name direct-default-initargs  :initform nil  :initfunction ,#'false :readers (class-direct-default-initargs))
1035   (:name default-initargs :initform nil  :initfunction ,#'false :readers (class-default-initargs)))
1036 :primary-p t)
1037
1038(%ensure-class-preserving-wrapper
1039 'forward-referenced-class
1040 :direct-superclasses '(class))
1041
1042
1043
1044(%ensure-class-preserving-wrapper
1045 'built-in-class
1046 :direct-superclasses '(class))
1047
1048
1049(%ensure-class-preserving-wrapper
1050 'slots-class
1051 :direct-superclasses '(class)
1052 :direct-slots `((:name alist :initform nil  :initfunction ,#'false))
1053 :primary-p t)
1054
1055;;; This class exists only so that standard-class & funcallable-standard-class
1056;;; can inherit its slots.
1057(%ensure-class-preserving-wrapper
1058 'std-class
1059 :direct-superclasses '(slots-class)
1060 :direct-slots `(
1061                 (:name make-instance-initargs :initform nil  :initfunction ,#'false)
1062                 (:name reinit-initargs :initform nil  :initfunction ,#'false)
1063                 (:name redefined-initargs :initform nil :initfunction ,#'false)
1064                 (:name changed-initargs :initform nil  :initfunction ,#'false))
1065 :primary-p t)
1066
1067
1068
1069(%ensure-class-preserving-wrapper
1070 'standard-class
1071 :direct-superclasses '(std-class))
1072
1073(%ensure-class-preserving-wrapper
1074 'funcallable-standard-class
1075 :direct-superclasses '(std-class))
1076
1077
1078(%ensure-class-preserving-wrapper
1079 'funcallable-standard-object
1080#||
1081 :direct-superclasses '(standard-object function)
1082||#
1083 :direct-slots `((:name name :initargs (:name) :readers (generic-function-name)))
1084 :metaclass 'funcallable-standard-class)
1085
1086(%ensure-class-preserving-wrapper
1087 'generic-function
1088 :direct-superclasses '(metaobject funcallable-standard-object)
1089 :direct-slots `(
1090                 (:name method-combination :initargs (:method-combination)
1091                  :initform *standard-method-combination*
1092                  :initfunction ,#'(lambda () *standard-method-combination*)
1093                  :readers (generic-function-method-combination))
1094                 (:name method-class :initargs (:method-class)
1095                  :initform *standard-method-class*
1096                  :initfunction ,#'(lambda () *standard-method-class*)
1097                  :readers (generic-function-method-class))
1098                 (:name methods :initargs (:methods)
1099                  :initform nil :initfunction ,#'false
1100                  :readers (generic-function-methods))
1101                 (:name declarations
1102                  :initargs (:declarations)
1103                  :initform nil :initfunction ,#'false
1104                  :readers (generic-function-declarations))
1105                 (:name %lambda-list
1106                  :initform :unspecified
1107                  :initfunction ,(constantly :unspecified))
1108                 (:name dependents
1109                  :initform nil :initfunction ,#'false)) 
1110 :metaclass 'funcallable-standard-class)
1111
1112
1113
1114(%ensure-class-preserving-wrapper
1115 'standard-generic-function
1116 :direct-superclasses '(generic-function)
1117
1118 :metaclass 'funcallable-standard-class
1119 :primary-p t)
1120
1121(%ensure-class-preserving-wrapper
1122 'standard-generic-function
1123 :direct-superclasses '(generic-function)
1124
1125 :metaclass 'funcallable-standard-class)
1126
1127(%ensure-class-preserving-wrapper
1128 'structure-class
1129 :direct-superclasses '(slots-class))
1130
1131(%ensure-class-preserving-wrapper
1132 'slot-definition
1133 :direct-superclasses '(metaobject)
1134  :direct-slots `((:name name :initargs (:name) :readers (slot-definition-name)
1135                  :initform nil :initfunction ,#'false)
1136                 (:name type :initargs (:type) :readers (slot-definition-type)
1137                  :initform t :initfunction ,#'true)
1138                 (:name initfunction :initargs (:initfunction) :readers (slot-definition-initfunction)
1139                  :initform nil :initfunction ,#'false)
1140                 (:name initform :initargs (:initform) :readers (slot-definition-initform)
1141                  :initform nil :initfunction ,#'false)
1142                 (:name initargs :initargs (:initargs) :readers (slot-definition-initargs)
1143                  :initform nil :initfunction ,#'false)
1144                 (:name allocation :initargs (:allocation) :readers (slot-definition-allocation)
1145                  :initform :instance :initfunction ,(constantly :instance))
1146                 (:name documentation :initargs (:documentation) :readers (slot-definition-documentation)
1147                  :initform nil :initfunction ,#'false)
1148                 (:name class :initargs (:class) :readers (slot-definition-class)))
1149 
1150 :primary-p t)
1151
1152(%ensure-class-preserving-wrapper
1153 'direct-slot-definition
1154 :direct-superclasses '(slot-definition)
1155 :direct-slots `((:name readers :initargs (:readers) :initform nil
1156                  :initfunction ,#'false :readers (slot-definition-readers))
1157                 (:name writers :initargs (:writers) :initform nil
1158                  :initfunction ,#'false :readers (slot-definition-writers))))
1159
1160(%ensure-class-preserving-wrapper
1161 'effective-slot-definition
1162 :direct-superclasses '(slot-definition)
1163 :direct-slots `((:name location :initform nil :initfunction ,#'false
1164                  :readers (slot-definition-location))
1165                 (:name slot-id :initform nil :initfunction ,#'false
1166                  :readers (slot-definition-slot-id))
1167                 (:name type-predicate :initform nil
1168                  :initfunction ,#'false
1169                  :readers (slot-definition-predicate))
1170                 )
1171 
1172 :primary-p t)
1173
1174(%ensure-class-preserving-wrapper
1175 'standard-slot-definition
1176 :direct-superclasses '(slot-definition)
1177)
1178
1179
1180
1181
1182
1183
1184
1185(%ensure-class-preserving-wrapper
1186 'standard-direct-slot-definition
1187 :direct-superclasses '(standard-slot-definition direct-slot-definition)
1188)
1189
1190(%ensure-class-preserving-wrapper
1191 'standard-effective-slot-definition
1192 :direct-superclasses '(standard-slot-definition effective-slot-definition))
1193
1194                 
1195
1196
1197     
1198                             
1199
1200
1201
1202;;; Fake method-combination, redefined in lib;method-combination.
1203(unless *type-system-initialized*
1204 (defclass method-combination (metaobject) 
1205   ((name :initarg :name))))
1206
1207
1208
1209
1210(defclass standard-method-combination (method-combination) ())
1211
1212(initialize-instance *standard-method-combination* :name 'standard)
1213
1214(setq *standard-kernel-method-class*
1215  (defclass standard-kernel-method (standard-method)
1216    ()))
1217
1218(unless *standard-method-combination*
1219  (setq *standard-method-combination*
1220        (make-instance 'standard-method-combination :name 'standard)))
1221
1222;;; For %compile-time-defclass
1223(defclass compile-time-class (class) ())
1224
1225(defmethod compile-time-class-p ((class compile-time-class))
1226  t)
1227
1228(defmethod class-finalized-p ((class compile-time-class))
1229  nil)
1230
1231
1232(defclass structure-slot-definition (slot-definition) ())
1233(defclass structure-effective-slot-definition (structure-slot-definition
1234                                               effective-slot-definition)
1235    ())
1236
1237(defclass structure-direct-slot-definition (structure-slot-definition
1238                                            direct-slot-definition)
1239    ())
1240
1241(defmethod shared-initialize :after ((class structure-class)
1242                                     slot-names
1243                                     &key
1244                                     (direct-superclasses nil direct-superclasses-p)
1245                                     &allow-other-keys)
1246  (declare (ignore slot-names))
1247  (labels ((obsolete (class)
1248             (dolist (sub (%class-direct-subclasses class)) (obsolete sub))
1249             ;;Need to save old class info in wrapper for obsolete
1250             ;;instance access...
1251             (setf (%class.cpl class) nil)))
1252    (obsolete class)
1253    (when direct-superclasses-p
1254      (let* ((old-supers (%class-direct-superclasses class))
1255             (new-supers direct-superclasses))
1256        (dolist (c old-supers)
1257          (unless (memq c new-supers)
1258            (remove-direct-subclass c class)))
1259        (dolist (c new-supers)
1260          (unless (memq c old-supers)
1261            (add-direct-subclass c class)))
1262        (setf (%class.local-supers class) new-supers)))
1263    (let* ((wrapper (or (%class-own-wrapper class)
1264                        (setf (%class-own-wrapper class) (%cons-wrapper class))))
1265           (cpl (compute-cpl class)))
1266      (setf (%class.cpl class) cpl)
1267      (setf (%wrapper-cpl wrapper) cpl
1268            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)))))
1269             
1270
1271                                     
1272                                     
1273;;; Called from DEFSTRUCT expansion.
1274(defun %define-structure-class (sd)
1275  (let* ((dslots ()))
1276    (dolist (ssd (cdr (sd-slots sd)) (setq dslots (nreverse dslots)))
1277      (let* ((type (ssd-type ssd))
1278             (refinfo (ssd-refinfo ssd)))
1279        (unless (logbitp $struct-inherited refinfo)
1280          (let* ((name (ssd-name ssd))
1281                 (initform (cadr ssd))
1282                 (initfunction (constantly initform)))
1283            (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction :initargs ,(list (make-keyword name))) dslots)))))
1284    (ensure-class (sd-name sd)
1285                  :metaclass 'structure-class
1286                  :direct-superclasses (list (or (cadr (sd-superclasses sd)) 'structure-object))
1287                  :direct-slots  dslots 
1288                  )))
1289
1290
1291(defun standard-instance-access (instance location)
1292  (etypecase location
1293    (fixnum (%standard-instance-instance-location-access instance location))
1294    (cons (%cdr location))))
1295
1296(defun (setf standard-instance-access) (new instance location)
1297  (etypecase location
1298    (fixnum (setf (standard-instance-instance-location-access instance location)
1299                  new))
1300    (cons (setf (%cdr location) new))))
1301
1302(defun funcallable-standard-instance-access (instance location)
1303  (etypecase location
1304    (fixnum (%standard-generic-function-instance-location-access instance location))
1305    (cons (%cdr location))))
1306
1307(defun (setf funcallable-standard-instance-access) (new instance location)
1308  (etypecase location
1309    (fixnum (setf (%standard-generic-function-instance-location-access instance location) new))
1310    (cons (setf (%cdr location) new))))
1311
1312;;; Handle a trap from %slot-ref
1313(defun %slot-unbound-trap (slotv idx frame-ptr)
1314  (let* ((instance nil)
1315         (class nil)
1316         (slot nil))
1317    (if (and (eq (typecode slotv) target::subtag-slot-vector)
1318             (setq instance (slot-vector.instance slotv))
1319             (setq slot
1320                   (find idx (class-slots (setq class (class-of instance)))
1321                         :key #'slot-definition-location)))
1322      (slot-unbound class instance (slot-definition-name slot))
1323      (%error "Unbound slot at index ~d in ~s" (list idx slotv) frame-ptr))))
1324
1325
1326;;;
1327;;; Now that CLOS is nominally bootstrapped, it's possible to redefine some
1328;;; of the functions that really should have been generic functions ...
1329(setf (fdefinition '%class-name) #'class-name
1330      (fdefinition '%class-default-initargs) #'class-default-initargs
1331      (fdefinition '%class-direct-default-initargs) #'class-direct-default-initargs
1332      (fdefinition '(setf %class-direct-default-initargs))
1333      #'(lambda (new class)
1334          (if (typep class 'slots-class)
1335            (setf (slot-value class 'direct-default-initargs) new)
1336            new))
1337      (fdefinition '%class-direct-slots) #'class-direct-slots
1338      (fdefinition '(setf %class-direct-slots))
1339                   #'(setf class-direct-slots)
1340      (fdefinition '%class-slots) #'class-slots
1341      (fdefinition '%class-direct-superclasses) #'class-direct-superclasses
1342      (fdefinition '(setf %class-direct-superclasses))
1343      #'(lambda (new class)
1344          (setf (slot-value class 'direct-superclasses) new))
1345      (fdefinition '%class-direct-subclasses) #'class-direct-subclasses
1346      ;(fdefinition '%class-own-wrapper) #'class-own-wrapper
1347      (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper)
1348)
1349
1350
1351
1352(setf (fdefinition '%slot-definition-name) #'slot-definition-name
1353      (fdefinition '%slot-definition-type) #'slot-definition-type
1354      (fdefinition '%slot-definition-initargs) #'slot-definition-initargs
1355      (fdefinition '%slot-definition-allocation) #'slot-definition-allocation
1356      (fdefinition '%slot-definition-location) #'slot-definition-location
1357      (fdefinition '%slot-definition-readers) #'slot-definition-readers
1358      (fdefinition '%slot-definition-writers) #'slot-definition-writers)
1359
1360
1361(setf (fdefinition '%method-qualifiers) #'method-qualifiers
1362      (fdefinition '%method-specializers) #'method-specializers
1363      (fdefinition '%method-function) #'method-function
1364      (fdefinition '(setf %method-function)) #'(setf method-function)
1365      (fdefinition '%method-gf) #'method-generic-function
1366      (fdefinition '(setf %method-gf)) #'(setf method-generic-function)
1367      (fdefinition '%method-name) #'method-name
1368      (fdefinition '%method-lambda-list) #'method-lambda-list
1369      )
1370
1371(setf (fdefinition '%add-method) #'add-method)
1372                   
1373     
1374;;; Make a direct-slot-definition of the appropriate class.
1375(defun %make-direct-slotd (slotd-class &rest initargs)
1376  (declare (dynamic-extent initargs))
1377  (apply #'make-instance slotd-class initargs))
1378
1379;;; Likewise, for an effective-slot-definition.
1380(defun %make-effective-slotd (slotd-class &rest initargs)
1381  (declare (dynamic-extent initargs))
1382  (apply #'make-instance slotd-class initargs))
1383
1384;;; Likewise, for methods
1385(defun %make-method-instance (class &rest initargs)
1386  (apply #'make-instance class initargs))
1387
1388(defmethod initialize-instance :after ((slotd effective-slot-definition) &key name)
1389  (setf (standard-effective-slot-definition.slot-id slotd)
1390        (ensure-slot-id name)))
1391
1392 
1393(defmethod specializer-direct-generic-functions ((s specializer))
1394  (let* ((gfs ())
1395         (methods (specializer-direct-methods s)))
1396    (dolist (m methods gfs)
1397      (let* ((gf (method-generic-function m)))
1398        (when gf (pushnew gf gfs))))))
1399
1400(defmethod generic-function-lambda-list ((gf standard-generic-function))
1401  (%maybe-compute-gf-lambda-list gf (car (generic-function-methods gf))))
1402
1403(defmethod generic-function-argument-precedence-order
1404    ((gf standard-generic-function))
1405  (let* ((req (required-lambda-list-args (generic-function-lambda-list gf)))
1406         (apo (%gf-dispatch-table-precedence-list
1407               (%gf-dispatch-table gf))))
1408    (if (null apo)
1409      req
1410      (mapcar #'(lambda (n) (nth n req)) apo))))
1411
1412(defun normalize-egf-keys (keys gf)
1413  (let* ((missing (cons nil nil))
1414         (env (getf keys :environment nil)))
1415    (declare (dynamic-extent missing))
1416    (remf keys :environment)
1417    (let* ((gf-class (getf keys :generic-function-class missing))
1418           (mcomb (getf keys :method-combination missing))
1419           (method-class (getf keys :method-class missing)))
1420      (if (eq gf-class missing)
1421        (setf gf-class (if gf (class-of gf) *standard-generic-function-class*))
1422        (progn
1423          (remf keys :generic-function-class)
1424          (if (typep gf-class 'symbol)
1425            (setq gf-class
1426                  (find-class gf-class t env)))
1427          (unless (or (eq gf-class *standard-generic-function-class*)
1428                      (subtypep gf-class *generic-function-class*))
1429            (error "Class ~S is not a subclass of ~S"
1430                   gf-class *generic-function-class*))))
1431      (unless (eq mcomb missing)
1432        (unless (typep mcomb 'method-combination)
1433          (setf (getf keys :method-combination)
1434                (find-method-combination (class-prototype gf-class)
1435                                         (car mcomb)
1436                                         (cdr mcomb)))))
1437      (unless (eq method-class missing)
1438        (if (typep method-class 'symbol)
1439          (setq method-class (find-class method-class t env)))
1440        (unless (subtypep method-class *method-class*)
1441          (error "~s is not a subclass of ~s" method-class *method-class*))
1442        (setf (getf keys :method-class) method-class))
1443      (values gf-class keys))))
1444   
1445(defmethod ensure-generic-function-using-class
1446    ((gf null)
1447     function-name
1448     &rest keys
1449     &key
1450     &allow-other-keys)
1451  (declare (dynamic-extent keys))
1452  (multiple-value-bind (gf-class initargs)
1453      (normalize-egf-keys keys nil)
1454    (let* ((gf (apply #'make-instance gf-class
1455                      :name function-name
1456                      initargs)))
1457      (setf (fdefinition function-name) gf))))
1458
1459(defparameter *error-on-gf-class-redefinition* nil
1460  "The MOP spec requires ENSURE-GENERIC-FUNCTION-USING-CLASS of an
1461   existing gf to signal an error if the :GENERIC-FUNCTION-CLASS
1462   argument specifies a class other than the existing gf's class.
1463   ANSI CL allows this kind of redefinition if the classes are
1464   \"compatible\", but doesn't define what compatibility means
1465   in this case.  When *ERROR-ON-GF-CLASS-REDEFINITION* is true,
1466   a continuable error is signaled.
1467
1468   Historically, Clozure CL CERRORed, but didn't offer a useful
1469   CHANGE-CLASS method that would change the GF's class")
1470
1471(defmethod ensure-generic-function-using-class
1472    ((gf generic-function)
1473     function-name
1474     &rest keys
1475     &key
1476     &allow-other-keys)
1477  (declare (dynamic-extent keys) (ignorable function-name))
1478  (multiple-value-bind (gf-class initargs)
1479      (normalize-egf-keys keys gf)
1480    (unless (eq gf-class (class-of gf))
1481      (when *error-on-gf-class-redefinition*
1482        (cerror (format nil "Change the class of ~s to ~s." gf gf-class)
1483                "The class of the existing generic function ~s is not ~s"
1484                gf gf-class))
1485      (change-class gf gf-class))
1486    (apply #'reinitialize-instance gf initargs)))
1487
1488
1489(defmethod initialize-instance :before ((instance generic-function)
1490                                       &key &allow-other-keys)
1491  (setf (%gf-dcode instance)  #'%%0-arg-dcode))
1492
1493(defmethod initialize-instance :after ((gf standard-generic-function)
1494                                       &key
1495                                       (lambda-list nil ll-p)
1496                                       (argument-precedence-order nil apo-p)
1497                                       &allow-other-keys)
1498  (if (and apo-p (not ll-p))
1499    (error
1500     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1501  (if ll-p
1502    (progn
1503      (unless (verify-lambda-list lambda-list)
1504        (error "~s is not a valid generic function lambda list" lambda-list))
1505      (if apo-p
1506        (set-gf-arg-info gf :lambda-list lambda-list
1507                         :argument-precedence-order argument-precedence-order)
1508        (set-gf-arg-info gf :lambda-list lambda-list)))
1509    (set-gf-arg-info gf))
1510  (if (gf-arg-info-valid-p gf)
1511    (compute-dcode gf (%gf-dispatch-table gf)))
1512  gf)
1513
1514(defmethod reinitialize-instance :after ((gf standard-generic-function)
1515                                         &rest args
1516                                         &key
1517                                         (lambda-list nil ll-p)
1518                                         (argument-precedence-order nil apo-p)
1519                                         &allow-other-keys)
1520  (if (and apo-p (not ll-p))
1521    (error
1522     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1523  (if ll-p
1524    (progn
1525      (unless (verify-lambda-list lambda-list)
1526        (error "~s is not a valid generic function lambda list" lambda-list))
1527      (if apo-p
1528        (set-gf-arg-info gf :lambda-list lambda-list
1529                         :argument-precedence-order argument-precedence-order)
1530        (set-gf-arg-info gf :lambda-list lambda-list)))
1531    (set-gf-arg-info gf))
1532  (if (and (gf-arg-info-valid-p gf)
1533           args
1534           (or ll-p (cddr args)))
1535    (compute-dcode gf (%gf-dispatch-table gf)))
1536  (when (sgf.dependents gf)
1537    (map-dependents gf #'(lambda (d)
1538                           (apply #'update-dependent gf d args))))
1539  gf)
1540 
1541
1542(defun decode-method-lambda-list (method-lambda-list)
1543  (flet ((bad ()
1544           (error "Invalid lambda-list syntax in ~s" method-lambda-list)))
1545    (collect ((specnames)
1546                    (required))
1547       (do* ((tail method-lambda-list (cdr tail))
1548             (head (car tail) (car tail)))
1549            ((or (null tail) (member head lambda-list-keywords))
1550             (if (verify-lambda-list tail)
1551               (values (required) tail (specnames))
1552               (bad)))
1553         (cond ((atom head)
1554                (unless (typep head 'symbol) (bad))
1555                (required head)
1556                (specnames t))
1557               (t
1558                (unless (and (typep (car head) 'symbol)
1559                             (consp (cdr head))
1560                             (null (cddr head)))
1561                  (bad))
1562                (required (car head))
1563                (specnames (cadr head))))))))
1564 
1565(defun extract-specializer-names (method-lambda-list)
1566  (nth-value 2 (decode-method-lambda-list method-lambda-list)))
1567
1568(defun extract-lambda-list (method-lambda-list)
1569  (multiple-value-bind (required tail)
1570      (decode-method-lambda-list method-lambda-list)
1571    (nconc required tail)))
1572
1573(setf (fdefinition '%ensure-generic-function-using-class)
1574      #'ensure-generic-function-using-class)
1575
1576
1577(defmethod shared-initialize :after ((gf generic-function) slot-names
1578                                     &key
1579                                     (documentation nil doc-p))
1580  (declare (ignore slot-names))
1581  (when doc-p
1582    (if documentation (check-type documentation string))
1583    (set-documentation gf t documentation)))
1584
1585
1586
1587
1588(defmethod allocate-instance ((b built-in-class) &rest initargs)
1589  (declare (ignore initargs))
1590  (error "Can't allocate instances of BUILT-IN-CLASS."))
1591
1592(defmethod reinitialize-instance ((m method) &rest initargs)
1593  (declare (ignore initargs))
1594  (error "Can't reinitialze ~s ~s" (class-of m) m))
1595
1596(defmethod add-dependent ((class class) dependent)
1597  (pushnew dependent (%class.dependents class)))
1598
1599(defmethod add-dependent ((gf standard-generic-function) dependent)
1600  (pushnew dependent (sgf.dependents gf)))
1601
1602(defmethod remove-dependent ((class class) dependent)
1603  (setf (%class.dependents class)
1604        (delete dependent (%class.dependents class))))
1605
1606(defmethod remove-dependent ((gf standard-generic-function) dependent)
1607  (setf (sgf.dependents gf)
1608        (delete dependent (sgf.dependents gf))))
1609
1610(defmethod map-dependents ((class class) function)
1611  (dolist (d (%class.dependents class))
1612    (funcall function d)))
1613
1614(defmethod map-dependents ((gf standard-generic-function) function)
1615  (dolist (d (sgf.dependents gf))
1616    (funcall function d)))
1617
1618(defgeneric update-dependent (metaobject dependent &rest initargs))
1619
1620(defmethod reinitialize-instance :after ((class std-class) &rest initargs)
1621  (map-dependents class #'(lambda (d)
1622                            (apply #'update-dependent class d initargs))))
1623
1624
1625(defun %allocate-gf-instance (class)
1626  (unless (class-finalized-p class)
1627    (finalize-inheritance class))
1628  (let* ((wrapper (%class.own-wrapper class))
1629         (gf-p (member *generic-function-class* (%class-cpl class)))
1630         (len (length (%wrapper-instance-slots wrapper)))
1631         (dt (if gf-p (make-gf-dispatch-table)))
1632         (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))
1633         (fn
1634          #+ppc-target
1635           (gvector :function
1636                    *unset-fin-code*
1637                    wrapper
1638                    slots
1639                    dt
1640                    #'false
1641                    0
1642                    (logior (ash 1 $lfbits-gfn-bit)
1643                            (ash 1 $lfbits-aok-bit)))
1644           #+x86-target
1645           (%clone-x86-function #'unset-fin-trampoline
1646                                wrapper
1647                                slots
1648                                dt
1649                                #'false
1650                                0
1651                                (logior (ash 1 $lfbits-gfn-bit)
1652                                        (ash 1 $lfbits-aok-bit)))))
1653    (setf 
1654          (slot-vector.instance slots) fn)
1655    (when dt
1656      (setf (%gf-dispatch-table-gf dt) fn))
1657    (if gf-p
1658      (push fn (population.data %all-gfs%)))
1659    fn))
1660
1661
1662(defmethod slot-value-using-class ((class structure-class)
1663                                   instance
1664                                   (slotd structure-effective-slot-definition))
1665  (let* ((loc (standard-effective-slot-definition.location slotd)))
1666      (typecase loc
1667        (fixnum
1668         (struct-ref  instance loc))
1669        (t
1670         (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1671                slotd loc (slot-definition-allocation slotd))))))
1672
1673;;; Some STRUCTURE-CLASS leftovers.
1674(defmethod (setf slot-value-using-class)
1675    (new
1676     (class structure-class)
1677     instance
1678     (slotd structure-effective-slot-definition))
1679  (let* ((loc (standard-effective-slot-definition.location slotd))
1680         (type (standard-effective-slot-definition.type slotd)))
1681    (if (and type (not (eq type t)))
1682      (unless (or (eq new (%slot-unbound-marker))
1683                  (typep new type))
1684        (setq new (require-type new type))))
1685    (typecase loc
1686      (fixnum
1687       (setf (struct-ref instance loc) new))
1688      (t
1689       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1690              slotd loc (slot-definition-allocation slotd))))))
1691
1692(defmethod slot-boundp-using-class ((class structure-class)
1693                                    instance
1694                                    (slotd structure-effective-slot-definition))
1695  (declare (ignore instance))
1696  t)
1697
1698;;; This has to be somewhere, so it might as well be here.
1699(defmethod make-load-form ((s slot-id) &optional env)
1700  (declare (ignore env))
1701  `(ensure-slot-id ,(slot-id.name s)))
1702
1703(defmethod make-load-form ((c class-cell) &optional env)
1704  (declare (ignore env))
1705  `(find-class-cell ',(class-cell-name c) t))
1706
1707
1708
1709(defmethod (setf class-name) (new (class class))
1710  (check-type new symbol)
1711  (when (and (standard-instance-p class)
1712             (%class-kernel-p class)
1713             (not (eq new (%class.name class)))
1714             *warn-if-redefine-kernel*)
1715    (cerror "Change the name of ~s to ~s."
1716            "The class ~s may be a critical part of the system;
1717changing its name to ~s may have serious consequences." class new))
1718  (let* ((old-name (class-name class)))
1719    (if (eq (find-class old-name nil) class)
1720      (progn
1721        (setf (info-type-kind old-name) nil)
1722        (clear-type-cache))))
1723  (when (eq (find-class new nil) class)
1724    (when (%deftype-expander new)
1725      (cerror "Change the name of ~S anyway, removing the DEFTYPE definition."
1726              "Changing the name of ~S to ~S would conflict with the type defined by DEFTYPE."
1727              class new)
1728      (%deftype new nil nil))
1729    (setf (info-type-kind new) :instance)
1730    (clear-type-cache))
1731  (reinitialize-instance class :name new)
1732  (setf (%class-proper-name class)
1733        (if (eq (find-class new nil) class)
1734          new))
1735  new)
1736
1737
1738;;; From Tim Moore, as part of a set of patches to support funcallable
1739;;; instances.
1740
1741;;; Support for objects with metaclass funcallable-instance-class that are not
1742;;; standard-generic-function. The objects still look a lot like generic
1743;;; functions, complete with vestigial dispatch
1744;;; tables. set-funcallable-instance-function will work on generic functions,
1745;;; though after that it won't be much of a generic function.
1746
1747
1748
1749
1750
1751(defun set-funcallable-instance-function (funcallable-instance function)
1752  (unless (typep funcallable-instance 'funcallable-standard-object)
1753    (error "~S is not a funcallable instance" funcallable-instance))
1754  (unless (functionp function)
1755    (error "~S is not a function" function))
1756  (setf (%gf-dcode funcallable-instance) function))
1757
1758(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys)
1759  (error "Can't reinitialize ~s" slotd))
1760
1761(defmethod (setf generic-function-name) (new-name (gf generic-function))
1762  (reinitialize-instance gf :name new-name))
1763
1764;;; Are we CLOS yet ?
1765
1766(defun %shared-initialize (instance slot-names initargs)
1767  (unless (or (listp slot-names) (eq slot-names t))
1768    (report-bad-arg slot-names '(or list (eql t))))
1769  ;; Check that initargs contains valid key/value pairs,
1770  ;; signal a PROGRAM-ERROR otherwise.  (Yes, this is
1771  ;; an obscure way to do so.)
1772  (destructuring-bind (&key &allow-other-keys) initargs)
1773  ;; I'm not sure if there's a more portable way of detecting
1774  ;; obsolete instances.  This'll eventually call
1775  ;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS if it needs to.
1776  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
1777                    (instance.class-wrapper instance)
1778                    (instance-class-wrapper instance)))
1779         (class (%wrapper-class wrapper)))
1780    (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete
1781      (update-obsolete-instance instance))
1782    ;; Now loop over all of the class's effective slot definitions.
1783    (dolist (slotd (class-slots class))
1784      ;; Anything that inherits from STANDARD-EFFECTIVE-SLOT-DEFINITION
1785      ;; in OpenMCL will have a CCL::TYPE-PREDICATE slot.  It's not
1786      ;; well-defined to inherit from EFFECTIVE-SLOT-DEFINITION without
1787      ;; also inheriting from STANDARD-EFFECTIVE-SLOT-DEFINITION,
1788      ;; and I'd rather not check here.  If you really want to
1789      ;; create that kind of slot definition, write your own SHARED-INITIALIZE
1790      ;; method for classes that use such slot definitions ...
1791      (let* ((predicate (slot-definition-predicate slotd)))
1792        (multiple-value-bind (ignore new-value foundp)
1793            (get-properties initargs (slot-definition-initargs slotd))
1794          (declare (ignore ignore))
1795          (cond (foundp
1796                 ;; an initarg for the slot was passed to this function
1797                 ;; Typecheck the new-value, then call
1798                 ;; (SETF SLOT-VALUE-USING-CLASS)
1799                 (unless (or (null predicate)
1800                             (funcall predicate new-value))
1801                   (error 'bad-slot-type-from-initarg
1802                          :slot-definition slotd
1803                          :instance instance
1804                          :datum new-value
1805                          :expected-type  (slot-definition-type slotd)
1806                          :initarg-name (car foundp)))
1807                 (setf (slot-value-using-class class instance slotd) new-value))
1808                ((and (or (eq slot-names t)
1809                          (member (slot-definition-name slotd)
1810                                  slot-names
1811                                  :test #'eq))
1812                      (not (slot-boundp-using-class class instance slotd)))
1813                 ;; If the slot name is among the specified slot names, or
1814                 ;; we're reinitializing all slots, and the slot is currently
1815                 ;; unbound in the instance, set the slot's value based
1816                 ;; on the initfunction (which captures the :INITFORM).
1817                 (let* ((initfunction (slot-definition-initfunction slotd)))
1818                   (if initfunction
1819                     (let* ((newval (funcall initfunction)))
1820                       (unless (or (null predicate)
1821                                   (funcall predicate newval))
1822                         (error 'bad-slot-type-from-initform
1823                                :slot-definition slotd
1824                                :expected-type (slot-definition-type slotd)
1825                                :datum newval
1826                                :instance instance))
1827                       (setf (slot-value-using-class class instance slotd)
1828                             newval))))))))))
1829  instance)
1830
1831(defmethod shared-initialize ((struct structure-object) slot-names &rest initargs)
1832  (unless (eq slot-names t)
1833    (error "Structure instance ~s can't be reinitialized." struct))
1834  (dolist (slotd (class-slots (class-cell-class (car (%svref struct 0)))))
1835    (let* ((predicate (slot-definition-predicate slotd))
1836           (location (slot-definition-location slotd)))
1837      (declare (fixnum location))
1838      (multiple-value-bind (ignore new-value foundp)
1839          (get-properties initargs (slot-definition-initargs slotd))
1840        (declare (ignore ignore))
1841        (cond (foundp
1842               ;; an initarg for the slot was passed to this function
1843               ;; Typecheck the new-value, then call
1844               ;; (SETF SLOT-VALUE-USING-CLASS)
1845               (unless (or (null predicate)
1846                           (funcall predicate new-value))
1847                 (error 'bad-slot-type-from-initarg
1848                        :slot-definition slotd
1849                        :instance struct
1850                        :datum new-value
1851                        :expected-type  (slot-definition-type slotd)
1852                          :initarg-name (car foundp)))
1853                 (setf (struct-ref struct location) new-value))
1854                (t
1855                 ;; If the slot name is among the specified slot names, or
1856                 ;; we're reinitializing all slots, and the slot is currently
1857                 ;; unbound in the instance, set the slot's value based
1858                 ;; on the initfunction (which captures the :INITFORM).
1859                 (let* ((initfunction (slot-definition-initfunction slotd)))
1860                   (if initfunction
1861                     (let* ((newval (funcall initfunction)))
1862                       (unless (or (null predicate)
1863                                   (funcall predicate newval))
1864                         (error 'bad-slot-type-from-initform
1865                                :slot-definition slotd
1866                                :expected-type (slot-definition-type slotd)
1867                                :datum newval
1868                                :instance struct))
1869                       (setf (struct-ref struct location) newval)))))))))
1870  struct)
1871
1872(defmethod initialize-instance ((struct structure-object) &rest initargs &key &allow-other-keys)
1873  (declare (dynamic-extent initargs))
1874  (apply #'shared-initialize struct t initargs))
1875
1876(defmethod make-instance ((class structure-class)  &rest initargs &key &allow-other-keys)
1877  (declare (dynamic-extent initargs))
1878  (let* ((struct (apply #'allocate-instance class initargs)))
1879    (apply #'initialize-instance struct initargs)))
1880
1881   
1882
1883;;; Sometimes you can do a lot better at generic function dispatch than the
1884;;; default. This supports that for the one-arg-dcode case.
1885(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t))
1886  nil)
1887
1888(defun optimize-generic-function-dispatching ()
1889  (dolist (gf (population.data %all-gfs%))
1890    (optimize-dispatching-for-gf gf)))
1891
1892(defun optimize-dispatching-for-gf (gf)
1893  (let* ((dcode (%gf-dcode gf))
1894         (name (function-name dcode)))
1895    (when (or (eq name '%%one-arg-dcode)
1896              (eq name '%%nth-arg-dcode))
1897      (let ((methods (generic-function-methods gf)))
1898        (when (and methods (null (cdr methods)))
1899          (when (or (eq #'%%one-arg-dcode dcode)
1900                    (and (eq #'%%nth-arg-dcode dcode)
1901                         (let ((spec (method-specializers (car methods)))
1902                               (argnum (%gf-dispatch-table-argnum
1903                                        (%gf-dispatch-table gf))))
1904                           (and (eql 2 (length spec))
1905                                (and (eql argnum 1) (eq (car spec) *t-class*))))))
1906            (override-one-method-one-arg-dcode gf (car methods))))))))
1907
1908(defparameter *unique-reader-dcode-functions* t)
1909
1910;;; dcode for a GF with a single reader method which accesses
1911;;; a slot in a class that has no subclasses (that restriction
1912;;; makes typechecking simpler and also ensures that the slot's
1913;;; location is correct.)
1914(defun singleton-reader-dcode (dt instance)
1915  (declare (optimize (speed 3) (safety 0)))
1916  (let* ((wrapper (%svref dt %gf-dispatch-table-first-data))
1917         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
1918    (if (eq (if (eq (typecode instance) target::subtag-instance)
1919              (instance.class-wrapper instance))
1920            wrapper)
1921      (%slot-ref (instance.slots instance) location)
1922      (cond ((and (eq (typecode instance) target::subtag-instance)
1923                  (eq 0 (%wrapper-hash-index (instance.class-wrapper instance)))
1924                  (progn (update-obsolete-instance instance)
1925                         (eq (instance.class-wrapper instance) wrapper)))
1926             (%slot-ref (instance.slots instance) location))
1927            (t (no-applicable-method (%gf-dispatch-table-gf dt) instance))))))
1928(register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*)
1929
1930;;; Dcode for a GF whose methods are all reader-methods which access a
1931;;; slot in one or more classes which have multiple subclasses, all of
1932;;; which (by luck or design) have the same slot-definition location.
1933(defun reader-constant-location-dcode (dt instance)
1934  (declare (optimize (speed 3) (safety 0)))
1935    (if (memq (if (eq (typecode instance) target::subtag-instance)
1936              (%class-of-instance instance))
1937              (%svref dt %gf-dispatch-table-first-data))
1938      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1939      (no-applicable-method (%gf-dispatch-table-gf dt) instance)))
1940(register-dcode-proto #'reader-constant-location-dcode *gf-proto-one-arg*)
1941
1942;;; Dcode for a GF whose methods are all reader-methods which access a
1943;;; slot in one or more classes which have multiple subclasses, all of
1944;;; which (by luck or design) have the same slot-definition location.
1945;;; The number of classes for which the method is applicable is
1946;;; potentially large, but all are subclasses of a single class
1947(defun reader-constant-location-inherited-from-single-class-dcode (dt instance)
1948  (declare (optimize (speed 3) (safety 0)))
1949  (let* ((defining-class-ordinal (%svref dt %gf-dispatch-table-first-data))
1950         (bits  (let* ((wrapper
1951                        (if (eq (typecode instance) target::subtag-instance)
1952                          (instance.class-wrapper instance))))
1953                  (when wrapper (or (%wrapper-cpl-bits wrapper)
1954                                    (make-cpl-bits (%inited-class-cpl
1955                                                    (%wrapper-class wrapper))))))))
1956    (declare (fixnum defining-class-ordinal))
1957    (if (and bits
1958             (< defining-class-ordinal (the fixnum (uvsize bits)))
1959             (not (eql 0 (sbit bits defining-class-ordinal))))
1960      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
1961      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
1962(register-dcode-proto #'reader-constant-location-inherited-from-single-class-dcode *gf-proto-one-arg*)
1963
1964;;; It may be faster to make individual functions that take their
1965;;; "parameters" (defining class ordinal, slot location) as constants.
1966;;; It may not be.  Use *unique-reader-dcode-functions* to decide
1967;;; whether or not to do so.
1968(defun make-reader-constant-location-inherited-from-single-class-dcode
1969    (defining-class-ordinal location gf)
1970  (if *unique-reader-dcode-functions*
1971    (let* ((gf-name (function-name gf)))
1972      (values
1973       (%make-function 
1974        `(slot-reader for ,gf-name)
1975        `(lambda (instance)
1976          (locally (declare (optimize (speed 3) (safety 0)))
1977            (let* ((bits (let* ((wrapper
1978                                 (if (eq (typecode instance) target::subtag-instance)
1979                                   (instance.class-wrapper instance))))
1980                           (when wrapper (or (%wrapper-cpl-bits wrapper)
1981                                             (make-cpl-bits (%inited-class-cpl
1982                                                             (%wrapper-class wrapper))))))))
1983              (if (and bits
1984                       (< ,defining-class-ordinal (the fixnum (uvsize bits)))
1985                       (not (eql 0 (sbit bits ,defining-class-ordinal))))
1986                (%slot-ref (instance.slots instance) ,location)
1987                (no-applicable-method (function ,gf-name) instance)))))
1988        nil)
1989       #'funcallable-trampoline))
1990    (let* ((dt (gf.dispatch-table gf)))
1991      (setf (%svref dt %gf-dispatch-table-first-data)
1992            defining-class-ordinal
1993            (%svref dt (1+ %gf-dispatch-table-first-data))
1994            location)
1995      (values
1996       (dcode-for-gf gf #'reader-constant-location-inherited-from-single-class-dcode)
1997       (cdr (assq #'reader-constant-location-inherited-from-single-class-dcode dcode-proto-alist))))))
1998
1999;;; Dcode for a GF whose methods are all reader-methods which access a
2000;;; slot in one or more classes which have multiple subclasses, all of
2001;;; which (by luck or design) have the same slot-definition location.
2002;;; The number of classes is for which the method is applicable is
2003;;; large, but all are subclasses of one of a (small) set of defining classes.
2004(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance)
2005  (declare (optimize (speed 3) (safety 0)))
2006  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
2007                    (instance.class-wrapper instance)))
2008         (bits (if wrapper (or (%wrapper-cpl-bits wrapper)
2009                               (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
2010         (nbits (if bits (uvsize bits) 0)))
2011    (declare (fixnum nbits))
2012    (if (dolist (ordinal (%svref dt %gf-dispatch-table-first-data))
2013          (declare (fixnum ordinal))
2014          (when (and (< ordinal nbits)
2015                     (not (eql 0 (sbit bits ordinal))))
2016            (return t)))
2017      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
2018      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
2019(register-dcode-proto #'reader-constant-location-inherited-from-multiple-classes-dcode *gf-proto-one-arg*)
2020
2021
2022;;; Similar to the case above, but we use an alist to map classes
2023;;; to their non-constant locations.
2024(defun reader-variable-location-dcode (dt instance)
2025  (declare (optimize (speed 3) (safety 0)))
2026  (let* ((alist (%svref dt %gf-dispatch-table-first-data))
2027         (location (cdr
2028                    (assq
2029                     (if (eq (typecode instance) target::subtag-instance)
2030                       (%class-of-instance instance))
2031                     alist))))
2032    (if location
2033      (%slot-ref (instance.slots instance) location)
2034      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
2035(register-dcode-proto #'reader-variable-location-dcode *gf-proto-one-arg*)
2036
2037(defun class-and-slot-location-alist (classes slot-name)
2038  (let* ((alist nil))
2039    (labels ((add-class (c)
2040               (unless (assq c alist)
2041                 (let* ((slots (class-slots c)))
2042                   (unless slots
2043                     (finalize-inheritance c)
2044                     (setq slots (class-slots c)))
2045                   (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist))
2046                 (dolist (sub (class-direct-subclasses c))
2047                   (add-class sub)))))
2048      (dolist (class classes) (add-class class))
2049      ;; Building the alist the way that we have should often approximate
2050      ;; this ordering; the idea is that leaf classes are more likely to
2051      ;; be instantiated than non-leaves.
2052      (sort alist (lambda (c1 c2)
2053                    (< (length (class-direct-subclasses c1))
2054                       (length (class-direct-subclasses c2))))
2055            :key #'car))))
2056
2057;;; Return a list of all classes in CLASS-LIST that aren't subclasses
2058;;; of any other class in the list.
2059(defun remove-subclasses-from-class-list (class-list)
2060  (if (null (cdr class-list))
2061    class-list
2062    (collect ((unique))
2063      (dolist (class class-list (unique))
2064        (when (dolist (other class-list t)
2065                (unless (eq class other)
2066                  (when (subtypep class other) (return nil))))
2067          (unique class))))))
2068
2069
2070;;; Try to replace gf dispatch with something faster in f.
2071(defun %snap-reader-method (f &key (redefinable t))
2072  (when (slot-boundp f 'methods)
2073    (let* ((methods (generic-function-methods f)))
2074      (when (and methods
2075                 (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods)
2076                 (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods)
2077                 (every (lambda (m) (null (method-qualifiers m))) methods))
2078        (let* ((m0 (car methods))
2079               (name (slot-definition-name (accessor-method-slot-definition m0))))
2080          (when (every (lambda (m)
2081                         (eq name (slot-definition-name (accessor-method-slot-definition m))))
2082                       (cdr methods))
2083            ;; All methods are *STANDARD-READER-METHODS* that
2084            ;; access the same slot name.  Build an alist of
2085            ;; mapping all subclasses of all classes on which those
2086            ;; methods are specialized to the effective slot's
2087            ;; location in that subclass.
2088            (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m)))
2089                                    methods))
2090                   (alist (class-and-slot-location-alist classes name))
2091                   (loc (cdar alist))
2092                   (dt (gf.dispatch-table f)))
2093              ;; Only try to handle the case where all slots have
2094              ;; :allocation :instance (and all locations - the CDRs
2095              ;; of the alist pairs - are small, positive fixnums.
2096              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
2097                (when redefinable
2098                  (loop for (c . nil) in alist
2099                        do (note-class-dependent c f)))
2100                (clear-gf-dispatch-table dt)
2101                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
2102                (cond ((null (cdr alist))
2103                       ;; Method is only applicable to a single class.
2104                       (destructuring-bind (class . location) (car alist)
2105                         (setf (%svref dt %gf-dispatch-table-first-data) (%class.own-wrapper class)
2106                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
2107                               (gf.dcode f) (dcode-for-gf f #'singleton-reader-dcode))))
2108                      ((dolist (other (cdr alist) t)
2109                         (unless (eq (cdr other) loc)
2110                           (return)))
2111                       ;; All classes have the slot in the same location,
2112                       ;; by luck or design.
2113                       (cond
2114                         ((< (length alist) 10)
2115                          ;; Only a small number of classes, just do MEMQ
2116                          (setf (%svref dt %gf-dispatch-table-first-data)
2117                                (mapcar #'car alist)
2118                                (%svref dt (1+ %gf-dispatch-table-first-data))
2119                                loc
2120                                (gf.dcode f) (dcode-for-gf f #'reader-constant-location-dcode)))
2121                         ((null (cdr (setq classes (remove-subclasses-from-class-list classes))))
2122                          ;; Lots of classes, all subclasses of a single class
2123                          (multiple-value-bind (dcode trampoline)
2124                              (make-reader-constant-location-inherited-from-single-class-dcode (%class-ordinal (car classes)) loc f)
2125                            (setf (gf.dcode f) dcode)
2126                            (replace-function-code f trampoline)))
2127                         (t
2128                          ;; Multple classes.  We should probably check
2129                          ;; to see they're disjoint
2130                          (setf (%svref dt %gf-dispatch-table-first-data)
2131                                (mapcar #'%class-ordinal classes)
2132                                (%svref dt (1+ %gf-dispatch-table-first-data))
2133                                loc
2134                                (gf.dcode f)
2135                                (dcode-for-gf f #'reader-constant-location-inherited-from-multiple-classes-dcode)))))
2136                      (t
2137                       ;; Multiple classes; the slot's location varies.
2138                       (setf (%svref dt %gf-dispatch-table-first-data)
2139                             alist
2140                             
2141                             (gf.dcode f) (dcode-for-gf f #'reader-variable-location-dcode))))))))))))
2142
2143;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T)
2144;;; specializers are all EQL specializers whose objects are symbols.
2145;;; The effective method applicable for each symbol is stored on the
2146;;; plist of the symbol under a property EQ to the dispatch table (which
2147;;; is mostly ignored, otherwise.)
2148(defun %%1st-arg-eql-method-hack-dcode (dt args)
2149  (let* ((sym (if (listp args) (car args)(%lexpr-ref args (%lexpr-count args) 0)))
2150         (mf (if (symbolp sym) (get sym dt))))
2151    (if mf
2152      (if (listp args)
2153        (apply mf args)
2154        (%apply-lexpr-tail-wise mf args))
2155      ;;; Let %%1st-arg-dcode deal with it.
2156      (%%1st-arg-dcode dt args))))
2157(register-dcode-proto #'%%1st-arg-eql-method-hack-dcode *gf-proto*)
2158
2159(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2)
2160  (let* ((mf (if (typep arg1 'symbol) (get arg1 dt))))
2161    (if mf
2162      (funcall mf arg1 arg2)
2163      (%%1st-two-arg-dcode dt arg1 arg2))))
2164(register-dcode-proto #'%%1st-two-arg-eql-method-hack-dcode *gf-proto-two-arg*)
2165
2166(defun %%one-arg-eql-method-hack-dcode (dt arg)
2167  (let* ((mf (if (typep arg 'symbol) (get arg dt))))
2168    (if mf
2169      (funcall mf arg))))
2170(register-dcode-proto #'%%one-arg-eql-method-hack-dcode *gf-proto-one-arg*)
2171
2172(defun install-eql-method-hack-dcode (gf)
2173  (let* ((bits (inner-lfun-bits gf))
2174         (nreq (ldb $lfbits-numreq bits))
2175         (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits)))
2176                          (logbitp $lfbits-rest-bit bits)
2177                          (logbitp $lfbits-restv-bit bits)
2178                          (logbitp $lfbits-keys-bit bits)
2179                          (logbitp $lfbits-aok-bit bits))))
2180    (setf (%gf-dcode gf)
2181          (dcode-for-gf gf
2182                        (cond ((and (eql nreq 1) (null other-args?))
2183                               #'%%one-arg-eql-method-hack-dcode)
2184                              ((and (eql nreq 2) (null other-args?))
2185                               #'%%1st-two-arg-eql-method-hack-dcode)
2186                              (t
2187                               #'%%1st-arg-eql-method-hack-dcode))))))
2188
2189(defun maybe-hack-eql-methods (gf)
2190  (let* ((methods (generic-function-methods gf)))
2191    (when (and methods
2192               (every #'(lambda (method)
2193                          (let* ((specializers (method-specializers method))
2194                                      (first (car specializers)))
2195                                 (and (typep first 'eql-specializer)
2196                                      (typep (eql-specializer-object first) 'symbol)
2197                                      (dolist (s (cdr specializers) t)
2198                                        (unless (eq s *t-class*)
2199                                          (return nil)))
2200                                      (null (cdr (compute-applicable-methods gf (cons (eql-specializer-object first) (make-list (length (cdr specializers))))))))))
2201                      methods))
2202      (let* ((dt (%gf-dispatch-table gf)))
2203        (dolist (m methods)
2204          (let* ((sym (eql-specializer-object (car (method-specializers m))))
2205                 (f (method-function m)))
2206            (setf (get sym dt) f)))
2207        (install-eql-method-hack-dcode gf)
2208        t))))
2209
2210
2211           
2212                           
2213;;; Return a list of :after methods for INITIALIZE-INSTANCE on the
2214;;; class's prototype, and a boolean that's true if no other qualified
2215;;; methods are defined and at most one primary one.
2216(defun initialize-instance-after-methods (proto class)
2217  (let* ((method-list (compute-method-list (sort-methods
2218                            (compute-applicable-methods #'initialize-instance (list proto))
2219                            (list (class-precedence-list class))))))
2220    (if (atom method-list)
2221      (values nil t)
2222      (if (and (null (car method-list))
2223               (null (cdddr method-list)))
2224        (values (cadr method-list) t)
2225        ;; :around or :before methods, or more than one primary method, give up
2226        (values nil nil)))))
2227
2228(defparameter *typecheck-slots-in-optimized-make-instance* t)
2229
2230
2231;;; Return a lambda form or NIL.
2232(defun make-instantiate-lambda-for-class-cell (cell)
2233  (let* ((class (class-cell-class cell))
2234         (after-methods nil))
2235    (when (and (typep class 'standard-class)
2236               (progn (unless (class-finalized-p class)
2237                        (finalize-inheritance class))
2238                      t)
2239               (null (cdr (compute-applicable-methods #'allocate-instance (list class))))
2240               (let* ((proto (class-prototype class)))
2241                 (and (multiple-value-bind (afters ok)
2242                          (initialize-instance-after-methods proto class)
2243                        (when ok
2244                          (setq after-methods afters)
2245                          t))
2246                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
2247      (let* ((slotds (sort (copy-list (class-slots class))
2248                           #'(lambda (x y)
2249                               (if (consp x) x (if (consp y) y (< x y))))
2250                           :key #'slot-definition-location))
2251             (default-initargs (class-default-initargs class)))
2252        (collect ((keys)
2253                  (binds)
2254                  (class-binds)
2255                  (ignorable)
2256                  (class-slot-inits)
2257                  (after-method-forms)
2258                  (forms))
2259          (flet ((generate-type-check (form type &optional spvar)
2260                   (if (or (null *typecheck-slots-in-optimized-make-instance*)
2261                           (eq type t)
2262                           (and (quoted-form-p type) (eq (cadr type) t)))
2263                     form
2264                     (if spvar
2265                       `(if ,spvar
2266                         (require-type ,form ',type)
2267                         ,form)
2268                       `(require-type ,form ',type)))))
2269            (dolist (slot slotds)
2270              (let* ((initargs (slot-definition-initargs slot))
2271                     (initfunction (slot-definition-initfunction slot))
2272                     (initform (slot-definition-initform slot))
2273                     (location (slot-definition-location slot))
2274                     (location-var nil)
2275                     (class-init-p nil)
2276                     (one-initarg-p (null (cdr initargs)))
2277                     (name (slot-definition-name slot))
2278                     (type (slot-definition-type slot)))
2279                (when (consp location)
2280                  (setq location-var (gensym "LOCATION")))
2281                (when initfunction
2282                  (setq initform
2283                        (if (self-evaluating-p initform)
2284                            initform
2285                            `(funcall ,initfunction))))
2286                (cond ((null initargs)
2287                       (let ((initial-value-form
2288                              (if initfunction
2289                                  (generate-type-check initform type)
2290                                  `(%slot-unbound-marker))))
2291                         (if location-var
2292                             (when initfunction
2293                               (setq class-init-p t)
2294                               (class-slot-inits
2295                                `(when (eq (%slot-unbound-marker) (cdr ,location-var))
2296                                   (setf (cdr ,location-var) ,initial-value-form))))
2297                             (forms initial-value-form))))
2298                      (t (collect ((cond-clauses))
2299                           (let ((last-cond-clause nil))
2300                             (dolist (initarg initargs)
2301                               (let* ((spvar nil)
2302                                      (name (if one-initarg-p
2303                                                name
2304                                                (gensym (string name))))
2305                                      (initial-value-form
2306                                       (if (and initfunction
2307                                                one-initarg-p
2308                                                (null location-var))
2309                                           initform
2310                                           (progn
2311                                             (when initarg
2312                                               (setq spvar (make-symbol
2313                                                            (concatenate
2314                                                             'string
2315                                                             (string initarg)
2316                                                             "-P"))))
2317                                             (and one-initarg-p
2318                                                  (null location-var)
2319                                                  (if initfunction
2320                                                      initform
2321                                                      `(%slot-unbound-marker))))))
2322                                      (default (assq initarg default-initargs))
2323                                      (default-value-form nil))
2324                                 (when spvar (ignorable spvar))
2325                                 (when default
2326                                   (destructuring-bind (form function)
2327                                       (cdr default)
2328                                     (setq default-value-form
2329                                           (if (or (quoted-form-p form)
2330                                                   (self-evaluating-p form))
2331                                               form
2332                                               `(funcall ,function)))))
2333                                 (keys (list*
2334                                        (list initarg name)
2335                                        (if (and default one-initarg-p (null location-var))
2336                                            default-value-form
2337                                            initial-value-form)
2338                                        (if spvar (list spvar))))
2339                                 (if one-initarg-p
2340                                   (if location-var
2341                                     (progn
2342                                       (setq class-init-p t)
2343                                       (class-slot-inits
2344                                        `(if ,spvar
2345                                           (setf (cdr ,location-var)
2346                                                 ,(generate-type-check
2347                                                   name type))
2348                                           ,(if default
2349                                              `(setf (cdr ,location-var)
2350                                                     ,(generate-type-check
2351                                                       default type))
2352                                              (when initfunction
2353                                                `(when (eq (%slot-unbound-marker)
2354                                                           (cdr ,location-var))
2355                                                   (setf (cdr ,location-var)
2356                                                         ,(generate-type-check
2357                                                           initform type))))))))
2358                                     (forms `,(generate-type-check name type spvar)))
2359                                     (progn (cond-clauses `(,spvar ,name))
2360                                            (when (and default (null last-cond-clause))
2361                                              (setq last-cond-clause
2362                                                    `(t ,default)))))))
2363                             (when (cond-clauses)
2364                               (when last-cond-clause
2365                                 (cond-clauses last-cond-clause))
2366                               (cond ((null location-var)
2367                                      (unless last-cond-clause
2368                                        (cond-clauses `(t ,initform)))
2369                                      (forms (generate-type-check
2370                                              `(cond ,@(cond-clauses))
2371                                              type)))
2372                                     (t
2373                                      (let ((initform-p-var
2374                                             (unless last-cond-clause
2375                                               (make-symbol "INITFORM-P")))
2376                                            (value-var (make-symbol "VALUE")))
2377                                        (unless last-cond-clause
2378                                          (cond-clauses
2379                                           `(t (setq ,initform-p-var t)
2380                                               ,(if initfunction
2381                                                    initform
2382                                                    `(%slot-unbound-marker)))))
2383                                        (setq class-init-p t)
2384                                        (class-slot-inits
2385                                         `(let* (,@(and initform-p-var
2386                                                        (list `(,initform-p-var nil)))
2387                                                 (,value-var
2388                                                  ,(generate-type-check
2389                                                    `(cond ,@(cond-clauses)) type)))
2390                                            (when
2391                                                ,(if initform-p-var
2392                                                     `(or (null ,initform-p-var)
2393                                                          (and (eq (cdr ,location-var)
2394                                                                   (%slot-unbound-marker))
2395                                                               (not (eq ,value-var
2396                                                                        (%slot-unbound-marker)))))
2397                                                     t)
2398                                                (setf (cdr ,location-var) ,value-var))))))))))))
2399                (when class-init-p
2400                  (class-binds `(,location-var
2401                                 (load-time-value
2402                                  (slot-definition-location ',slot))))))))
2403          (let* ((cell (make-symbol "CLASS-CELL"))
2404                 (args (make-symbol "ARGS"))
2405                 (slots (make-symbol "SLOTS"))
2406                 (instance (make-symbol "INSTANCE")))
2407            (dolist (after after-methods)
2408              (after-method-forms `(apply ,(method-function after) ,instance ,args)))
2409            (when after-methods
2410              (after-method-forms instance))
2411            (binds `(,slots (gvector :slot-vector nil ,@(forms))))
2412            (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
2413            `(lambda (,cell ,@(when after-methods `(&rest ,args)) &key ,@(keys) ,@(when after-methods '(&allow-other-keys)))
2414              (declare (ignorable ,@(ignorable)))
2415              ,@(when after-methods `((declare (dynamic-extent ,args))))
2416              (let (,@(class-binds))
2417                ,@(class-slot-inits))
2418              (let* (,@(binds))
2419                (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
2420                      (%svref ,slots 0) ,instance)
2421                ,@(after-method-forms)))))))))
2422
2423(defun optimize-make-instance-for-class-cell (cell)
2424  (init-class-cell-instantiator cell)
2425  (let* ((lambda (make-instantiate-lambda-for-class-cell cell)))
2426    (when lambda
2427      (setf (class-cell-instantiate cell) (compile nil lambda)
2428            (class-cell-extra cell) (%class.own-wrapper
2429                                     (class-cell-class cell)))
2430      t)))
2431
2432(defun optimize-make-instance-for-class-name (class-name)
2433  (optimize-make-instance-for-class-cell (find-class-cell class-name t)))
2434
2435(defun optimize-named-class-make-instance-methods ()
2436  (maphash (lambda (class-name class-cell)
2437             (handler-case (optimize-make-instance-for-class-cell class-cell)
2438               (error (c)
2439                      (warn "error optimizing make-instance for ~s:~&~a"
2440                            class-name c))))
2441           %find-classes%))
2442
2443;; Redefined from bootstrapping verison in l1-clos-boot.lisp
2444;; Remove the make-instance optimization if the user is adding
2445;; a method on initialize-instance, allocate-instance, or shared-initialize
2446(defun maybe-remove-make-instance-optimization (gfn method)
2447  (when (or (eq gfn #'allocate-instance)
2448            (eq gfn #'initialize-instance)
2449            (eq gfn #'shared-initialize))
2450    (let ((specializer (car (method-specializers method))))
2451      (when (typep specializer 'class)
2452        (labels ((clear (class)
2453                   (pessimize-make-instance-for-class-name (class-name class))
2454                   (dolist (sub (%class-direct-subclasses class))
2455                     (clear sub))))
2456          (clear specializer))))))
2457
2458;;; Iterate over all known GFs; try to optimize their dcode in cases
2459;;; involving reader methods.
2460
2461(defun snap-reader-methods (&key known-sealed-world
2462                                 (check-conflicts t)
2463                                 (optimize-make-instance t))
2464  (declare (ignore check-conflicts)
2465           (ignore known-sealed-world))
2466  (when optimize-make-instance
2467    (optimize-named-class-make-instance-methods))
2468  (let* ((ngf 0)
2469         (nwin 0))
2470    (dolist (f (population.data %all-gfs%))
2471      (incf ngf)
2472      (when (%snap-reader-method f)
2473        (incf nwin)))
2474    (values ngf nwin 0)))
2475
2476(defun register-non-dt-dcode-function (f)
2477  (flet ((symbol-or-function-name (x)
2478           (etypecase x
2479             (symbol x)
2480             (function (function-name x)))))
2481    (let* ((already (member (symbol-or-function-name f) *non-dt-dcode-functions* :key #'symbol-or-function-name)))
2482      (if already
2483        (setf (car already) f)
2484        (push f *non-dt-dcode-functions*))
2485      f)))
2486
2487(defun pessimize-clos ()
2488  ;; Undo MAKE-INSTANCE optimization
2489  (maphash (lambda (class-name class-cell)
2490             (declare (ignore class-name))
2491             (init-class-cell-instantiator class-cell))
2492           %find-classes%)
2493  ;; Un-snap reader methods, undo other GF optimizations.
2494  (dolist (f (population-data %all-gfs%))
2495    (let* ((dt (%gf-dispatch-table f)))
2496      (clear-gf-dispatch-table dt)
2497      (compute-dcode f))))
2498
2499;;; If there's a single method (with standard method combination) on
2500;;; GF and all of that method's arguments are specialized to the T
2501;;; class - and if the method doesn't accept &key or do any
2502;;; next-method things - we can just have the generic function call
2503;;; the method-function
2504(defun dcode-for-universally-applicable-singleton (gf)
2505  (when (eq (generic-function-method-combination gf)
2506            *standard-method-combination*)
2507    (let* ((methods (generic-function-methods gf))
2508           (method (car methods)))
2509      (when (and method
2510                 (null (cdr methods))
2511                 (null (method-qualifiers method))
2512                 (not (logtest (logior (ash 1 $lfbits-keys-bit)
2513                                       (ash 1 $lfbits-nextmeth-bit))
2514                                 (lfun-bits (method-function method))))
2515                 (dolist (spec (method-specializers method) t)
2516                   (unless (eq spec *t-class*)
2517                     (return nil))))
2518        (method-function method)))))
2519
2520(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton)
Note: See TracBrowser for help on using the repository browser.