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

Last change on this file since 14841 was 14558, checked in by gb, 9 years ago

Change subprims origin to #x04002000 on Android.

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