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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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