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

Last change on this file since 13537 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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