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

Last change on this file since 14862 was 14862, checked in by gb, 8 years ago

UNOPTIMIZE-DEPENDENTS undoes reader-method optimization.

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