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

Last change on this file since 616 was 616, checked in by gb, 17 years ago

Define and use COMPUTE-CLASS-PRECEDENCE-LIST. Flush initargs caches whenever
class is finalized.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 55.8 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Copyright (C) 2002-2003 Clozure Associates
5;;;   This file is part of OpenMCL.
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17;;;
18
19;;; At this point in the load sequence, the handful of extant basic classes
20;;; exist only in skeletal form (without direct or effective slot-definitions.)
21(in-package "CCL")
22
23(defun extract-slotds-with-allocation (allocation slotds)
24  (collect ((right-ones))
25    (dolist (s slotds (right-ones))
26      (if (eq (%slot-definition-allocation s) allocation)
27        (right-ones s)))))
28
29(defun extract-instance-direct-slotds (class)
30  (extract-slotds-with-allocation :instance (%class-direct-slots class)))
31
32(defun extract-class-direct-slotds (class)
33  (extract-slotds-with-allocation :class (%class-direct-slots class)))
34
35(defun extract-instance-effective-slotds (class)
36  (extract-slotds-with-allocation :instance (%class-slots class)))
37
38(defun extract-class-effective-slotds (class)
39  (extract-slotds-with-allocation :class (%class-slots class)))
40
41(defun extract-instance-and-class-slotds (slotds)
42  (collect ((instance-slots)
43            (shared-slots))
44    (dolist (s slotds (values (instance-slots) (shared-slots)))
45      (if (eq (%slot-definition-allocation s) :class)
46        (shared-slots s)
47        (instance-slots s)))))
48
49
50
51(defun direct-instance-and-class-slotds (class)
52  (extract-instance-and-class-slotds (%class-direct-slots class)))
53
54(defun effective-instance-and-class-slotds (class)
55  (extract-instance-and-class-slotds (%class-slots class)))
56
57(defun %shared-initialize (instance slot-names initargs)
58  (unless (or (listp slot-names) (eq slot-names t))
59    (report-bad-arg slot-names '(or list (eql t))))
60  ;; Check that initargs contains valid key/value pairs,
61  ;; signal a PROGRAM-ERROR otherwise.  (Yes, this is
62  ;; an obscure way to do so.)
63  (destructuring-bind (&key &allow-other-keys) initargs)
64  (let* ((wrapper (instance-class-wrapper instance))
65         (class (%wrapper-class wrapper)))
66    (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete
67      (update-obsolete-instance instance)
68      (setq wrapper (instance-class-wrapper instance)))
69    (dolist (slotd (%class-slots class))
70      (let* ((loc (%slot-definition-location slotd)))
71        (multiple-value-bind (ignore new-value foundp)
72            (get-properties initargs
73                            (%slot-definition-initargs slotd))
74          (declare (ignore ignore))
75          (if foundp
76            (progn
77              (unless (funcall (standard-effective-slot-definition.type-predicate slotd) new-value)
78                (error 'bad-slot-type-from-initarg
79                       :slot-definition slotd
80                       :instance instance
81                       :datum new-value
82                       :expected-type  (%slot-definition-type slotd)
83                       :initarg-name (car foundp)))
84              (if (consp loc)
85                (rplacd loc new-value)
86                (setf (standard-instance-instance-location-access instance loc)
87                      new-value)))
88            (if (or (eq slot-names t)
89                    (member (%slot-definition-name slotd)
90                            slot-names
91                            :test #'eq))
92              (let* ((curval (if (consp loc)
93                               (cdr loc)
94                               (%standard-instance-instance-location-access
95                                instance loc))))
96                (if (eq curval (%slot-unbound-marker))
97                  (let* ((initfunction (%slot-definition-initfunction slotd)))
98                    (if initfunction
99                      (let* ((newval (funcall initfunction)))
100                        (unless (funcall (standard-effective-slot-definition.type-predicate slotd) newval)
101                          (error 'bad-slot-type-from-initform
102                                 :slot-definition slotd
103                                 :expected-type (%slot-definition-type slotd)
104                                 :datum newval
105                                 :instance instance))
106                        (if (consp loc)
107                          (rplacd loc newval)
108                          (setf (standard-instance-instance-location-access
109                                 instance loc)
110                                newval)))))))))))))
111  instance)
112
113;;; This is redefined (to call MAKE-INSTANCE) below.
114(setf (fdefinition '%make-direct-slotd)
115      #'(lambda (slotd-class &key
116                             name
117                             initfunction
118                             initform
119                             initargs
120                             (allocation :instance)
121                             class
122                             (type t)
123                             (documentation (%slot-unbound-marker))
124                             readers
125                             writers)
126          (declare (ignore slotd-class))
127          (%instance-vector
128           (%class.own-wrapper *standard-direct-slot-definition-class*)
129           name type initfunction initform initargs allocation
130           documentation class readers writers)))
131
132;;; Also redefined below, after MAKE-INSTANCE is possible.
133(setf (fdefinition '%make-effective-slotd)
134      #'(lambda (slotd-class &key
135                             name
136                             initfunction
137                             initform
138                             initargs
139                             allocation
140                             class
141                             type
142                             documentation)
143          (declare (ignore slotd-class))
144          (%instance-vector
145           (%class.own-wrapper *standard-effective-slot-definition-class*)
146           name type initfunction initform initargs allocation
147           documentation class nil (ensure-slot-id name) #'true)))
148
149(defmethod class-slots ((class class)))
150(defmethod class-direct-slots ((class class)))
151(defmethod class-default-initargs ((class class)))
152(defmethod class-direct-default-initargs ((class class)))
153
154(defmethod direct-slot-definition-class ((class std-class) &rest initargs)
155  (declare (ignore initargs))
156  *standard-direct-slot-definition-class*)
157
158(defmethod effective-slot-definition-class ((class std-class) &rest  initargs)
159  (declare (ignore initargs))
160  *standard-effective-slot-definition-class*)
161
162(defun make-direct-slot-definition (class initargs)
163  (apply #'%make-direct-slotd
164         (apply #'direct-slot-definition-class class initargs)
165         :class class
166         initargs))
167
168(defun make-effective-slot-definition (class &rest initargs)
169  (declare (dynamic-extent initargs))
170  (apply #'%make-effective-slotd
171         (apply #'effective-slot-definition-class class initargs)
172         initargs))
173
174
175(defmethod compute-effective-slot-definition ((class slots-class)
176                                              name
177                                              direct-slots)
178 
179  (let* ((initer (dolist (s direct-slots)
180                   (when (%slot-definition-initfunction s)
181                     (return s))))
182         (documentor (dolist (s direct-slots)
183                       (when (%slot-definition-documentation s)
184                         (return s))))
185         (first (car direct-slots))
186         (initargs (let* ((initargs nil))
187                     (dolist (dslot direct-slots initargs)
188                       (dolist (dslot-arg (%slot-definition-initargs  dslot))
189                         (pushnew dslot-arg initargs :test #'eq))))))
190    (make-effective-slot-definition
191     class
192     :name name
193     :allocation (%slot-definition-allocation first)
194     :documentation (when documentor (nth-value
195                                      1
196                                      (%slot-definition-documentation
197                                       documentor)))
198     :class (%slot-definition-class first)
199     :initargs initargs
200     :initfunction (if initer (%slot-definition-initfunction initer))
201     :initform (if initer (%slot-definition-initform initer))
202     :type (or (%slot-definition-type first) t))))
203
204(defmethod compute-slots ((class slots-class))
205  (let* ((slot-name-alist ()))
206    (labels ((note-direct-slot (dslot)
207               (let* ((sname (%slot-definition-name dslot))
208                      (pair (assq sname slot-name-alist)))
209                 (if pair
210                   (push dslot (cdr pair))
211                   (push (list sname dslot) slot-name-alist))))
212             (rwalk (tail)
213               (when tail
214                 (rwalk (cdr tail))
215                 (let* ((c (car tail)))
216                   (unless (eq c *t-class*)
217                     (dolist (dslot (%class-direct-slots c))
218                       (note-direct-slot dslot)))))))
219      (rwalk (class-precedence-list class)))
220    (collect ((effective-slotds))
221      (dolist (pair (nreverse slot-name-alist) (effective-slotds))
222        (effective-slotds (compute-effective-slot-definition class (car pair) (cdr pair)))))))
223
224
225(defmethod compute-slots :around ((class std-class))
226  (let* ((cpl (%class.cpl class)))
227    (multiple-value-bind (instance-slots class-slots)
228        (extract-instance-and-class-slotds (call-next-method))
229      (setq instance-slots (sort-effective-instance-slotds instance-slots class cpl))
230      (do* ((loc 1 (1+ loc))
231            (islotds instance-slots (cdr islotds)))
232           ((null islotds))
233        (declare (fixnum loc))
234        (setf (%slot-definition-location (car islotds)) loc))
235      (dolist (eslotd class-slots)
236        (setf (%slot-definition-location eslotd) 
237              (assoc (%slot-definition-name eslotd)
238                     (%class-get (%slot-definition-class eslotd)
239                                 :class-slots)
240                     :test #'eq)))
241      (append instance-slots class-slots))))
242
243(defmethod compute-slots :around ((class structure-class))
244  (let* ((slots (call-next-method))      )
245      (do* ((loc 1 (1+ loc))
246            (islotds slots (cdr islotds)))
247           ((null islotds) slots)
248        (declare (fixnum loc))
249        (setf (%slot-definition-location (car islotds)) loc))))
250
251;;; Should eventually do something here.
252(defmethod compute-slots ((s structure-class))
253  (call-next-method))
254
255(defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
256  (declare (ignore initargs))
257  (find-class 'structure-direct-slot-definition))
258
259(defmethod effective-slot-definition-class ((class structure-class) &rest  initargs)
260  (declare (ignore initargs))
261  (find-class 'structure-effective-slot-definition))
262
263
264(defmethod compute-default-initargs ((class slots-class))
265  (let* ((initargs ()))
266    (dolist (c (%class-precedence-list class) (nreverse initargs))
267      (if (typep c 'forward-referenced-class)
268        (error
269         "Class precedence list of ~s contains FORWARD-REFERENCED-CLASS ~s ."
270         class c)
271        (dolist (i (%class-direct-default-initargs c))
272          (pushnew i initargs :test #'eq :key #'car))))))
273
274
275
276
277(defvar *update-slots-preserve-existing-wrapper* nil)
278
279(defun update-slots (class eslotds)
280  (multiple-value-bind (instance-slots class-slots)
281      (extract-instance-and-class-slotds eslotds)
282    (let* ((new-ordering
283            (let* ((v (make-array (the fixnum (length instance-slots))))
284                   (i 0))
285              (declare (simple-vector v) (fixnum i))
286              (dolist (e instance-slots v)
287                (setf (svref v i)
288                      (%slot-definition-name e))
289                (incf i))))
290           (old-wrapper (%class-own-wrapper class))
291           (old-ordering (if old-wrapper (%wrapper-instance-slots old-wrapper)))
292           (new-wrapper
293            (cond ((null old-wrapper)
294                   (%cons-wrapper class))
295                  ((and old-wrapper *update-slots-preserve-existing-wrapper*)
296                   old-wrapper)
297                  ((and (equalp old-ordering new-ordering)
298                        (null class-slots))
299                   old-wrapper)
300                  (t
301                   (make-instances-obsolete class)
302                   ;;; Is this right ?
303                   #|(%class.own-wrapper class)|#
304                   (%cons-wrapper class)))))
305      (setf (%class-slots class) eslotds)
306      (setf (%wrapper-instance-slots new-wrapper) new-ordering
307            (%wrapper-class-slots new-wrapper) (%class-get class :class-slots)
308            (%class-own-wrapper class) new-wrapper)
309      (setup-slot-lookup new-wrapper eslotds))))
310
311
312 
313(defun setup-slot-lookup (wrapper eslotds)
314  (when eslotds
315    (let* ((nslots (length eslotds))
316           (total-slot-ids (current-slot-index))
317           (small (< nslots 255))
318           (map
319            (if small
320              (make-array total-slot-ids :element-type '(unsigned-byte 8))
321              (make-array total-slot-ids :element-type '(unsigned-byte 32))))
322           (table (make-array (the fixnum (1+ nslots))))
323           (i 0))
324      (declare (fixnum nslots total-slot-ids i) (simple-vector table))
325      (setf (svref table 0) nil)
326      (dolist (slotd eslotds)
327        (incf i)
328        (setf (svref table i) slotd)
329        (setf (aref map
330                    (slot-id.index
331                     (standard-effective-slot-definition.slot-id slotd)))
332              i))
333      (let* ((lookup-f (gvector :function
334                                (%svref (if small
335                                          #'%small-map-slot-id-lookup
336                                          #'%large-map-slot-id-lookup) 0)
337                                map
338                                table
339                                (dpb 1 $lfbits-numreq
340                                     (ash -1 $lfbits-noname-bit))))
341             (class (%wrapper-class wrapper))
342             (get-f (gvector :function
343                             (%svref (if small
344                                       #'%small-slot-id-value
345                                       #'%large-slot-id-value) 0)
346                             map
347                             table
348                             class
349                             #'%maybe-std-slot-value-using-class
350                             #'%slot-id-ref-missing
351                             (dpb 2 $lfbits-numreq
352                                  (ash -1 $lfbits-noname-bit))))
353             (set-f (gvector :function
354                             (%svref (if small
355                                       #'%small-set-slot-id-value
356                                       #'%large-set-slot-id-value) 0)
357                             map
358                             table
359                             class
360                             #'%maybe-std-setf-slot-value-using-class
361                             #'%slot-id-set-missing
362                             (dpb 3 $lfbits-numreq
363                                  (ash -1 $lfbits-noname-bit)))))
364        (setf (%wrapper-slot-id->slotd wrapper) lookup-f
365              (%wrapper-slot-id-value wrapper) get-f
366              (%wrapper-set-slot-id-value wrapper) set-f
367              (%wrapper-slot-id-map wrapper) map
368              (%wrapper-slot-definition-table wrapper) table))))
369  wrapper)
370
371                       
372   
373
374(defmethod validate-superclass ((class class) (super class))
375  (or (eq super *t-class*)
376      (let* ((class-of-class (class-of class))
377             (class-of-super (class-of super)))
378        (or (eq class-of-class class-of-super)
379            (and (eq class-of-class *standard-class-class*)
380                 (eq class-of-super *funcallable-standard-class-class*))
381            (and (eq class-of-class *funcallable-standard-class-class*)
382                 (eq class-of-super *standard-class-class*))))))
383
384(defmethod validate-superclass ((class foreign-class) (super standard-class))
385  t)
386
387(defmethod validate-superclass ((class std-class) (super forward-referenced-class))
388  t)
389
390
391(defmethod add-direct-subclass ((class class) (subclass class))
392  (pushnew subclass (%class-direct-subclasses class))
393  subclass)
394
395(defmethod remove-direct-subclass ((class class) (subclass class))
396  (setf (%class-direct-subclasses class)
397        (remove subclass (%class-direct-subclasses class)))
398  subclass)
399
400(defun add-direct-subclasses (class new)
401  (dolist (n new)
402    (unless (memq class (%class-direct-subclasses  class))
403      (add-direct-subclass n class))))
404
405(defun remove-direct-subclasses (class old-supers new-supers)
406  (dolist (o old-supers)
407    (unless (memq o new-supers)
408      (remove-direct-subclass o class))))
409
410;;; Built-in classes are always finalized.
411(defmethod class-finalized-p ((class class))
412  t)
413
414;;; Standard classes are finalized if they have a wrapper and that
415;;; wrapper as an instance-slots vector; that implies that
416;;; both UPDATE-CPL and UPDATE-SLOTS have been called on the class.
417(defmethod class-finalized-p ((class std-class))
418  (let* ((w (%class-own-wrapper class)))
419    (and w (typep (%wrapper-instance-slots w) 'vector))))
420
421(defmethod finalize-inheritance ((class std-class))
422  (update-class class t))
423
424
425(defmethod finalize-inheritance ((class forward-referenced-class))
426  (error "Class ~s can't be finalized." class))
427
428(defmethod class-primary-p ((class std-class))
429  (%class-primary-p class))
430
431(defmethod (setf class-primary-p) (new (class std-class))
432  (setf (%class-primary-p class) new))
433
434(defmethod class-primary-p ((class class))
435  t)
436
437(defmethod (setf class-primary-p) (new (class class))
438  new)
439
440
441(defun forward-referenced-class-p (class)
442  (typep class 'forward-referenced-class))
443
444; This uses the primary class information to sort a class'es slots
445(defun sort-effective-instance-slotds (slotds class cpl)
446  (let (primary-slotds
447        primary-slotds-class
448        (primary-slotds-length 0))
449    (declare (fixnum primary-slotds-length))
450    (dolist (sup (cdr cpl))
451      (unless (eq sup *t-class*)     
452        (when (class-primary-p sup)
453          (let ((sup-slotds (extract-instance-effective-slotds sup)))
454            (if (null primary-slotds-class)
455              (setf primary-slotds-class sup
456                    primary-slotds sup-slotds
457                    primary-slotds-length (length sup-slotds))
458              (let ((sup-slotds-length (length sup-slotds)))
459                (do* ((i 0 (1+ i))
460                      (n (min sup-slotds-length primary-slotds-length))
461                      (sup-slotds sup-slotds (cdr sup-slotds))
462                      (primary-slotds primary-slotds (cdr primary-slotds)))
463                     ((= i n))
464                  (unless (eq (%slot-definition-name (car sup-slotds))
465                              (%slot-definition-name (car primary-slotds)))
466                    (error "While initializing ~s:~%~
467                            attempt to mix incompatible primary classes:~%~
468                            ~s and ~s"
469                           class sup primary-slotds-class)))
470                (when (> sup-slotds-length primary-slotds-length)
471                  (setq primary-slotds-class sup
472                        primary-slotds sup-slotds
473                        primary-slotds-length sup-slotds-length))))))))
474    (if (null primary-slotds-class)
475      slotds
476      (flet ((slotd-position (slotd)
477               (let* ((slotd-name (%slot-definition-name slotd)))
478                 (do* ((i 0 (1+ i))
479                       (primary-slotds primary-slotds (cdr primary-slotds)))
480                      ((= i primary-slotds-length) primary-slotds-length)
481                   (declare (fixnum i))
482                   (when (eq slotd-name
483                                (%slot-definition-name (car primary-slotds)))
484                   (return i))))))
485        (declare (dynamic-extent #'slotd-position))
486        (sort-list slotds '< #'slotd-position)))))
487
488
489
490
491(defun update-cpl (class cpl)
492  (if (class-finalized-p class)
493    (unless (equal (%class.cpl class) cpl)
494      (setf (%class.cpl class) cpl)
495      #|(force-cache-flushes class)|#)
496    (setf (%class.cpl class) cpl)))
497
498
499(defun class-has-a-forward-referenced-superclass-p (class)
500  (or (if (forward-referenced-class-p class) class)
501      (dolist (s (%class-direct-superclasses class))
502        (let* ((fwdref (class-has-a-forward-referenced-superclass-p s)))
503          (when fwdref (return fwdref))))))
504
505
506(defmethod compute-class-precedence-list ((class class))
507  (let* ((fwdref (class-has-a-forward-referenced-superclass-p class)))
508    (when fwdref
509      (error "~&Class ~s can't be finalized because at least one of its superclasses (~s) is a FORWARD-REFERENCED-CLASS." class fwdref)))
510  (compute-cpl class))
511
512;;; Classes that can't be instantiated via MAKE-INSTANCE have no
513;;; initargs caches.
514(defmethod %flush-initargs-caches ((class class))
515  )
516
517;;; Classes that have initargs caches should flush them when the
518;;; class is finalized.
519(defmethod %flush-initargs-caches ((class std-class))
520  (setf (%class.make-instance-initargs class) nil
521        (%class.reinit-initargs class) nil
522        (%class.redefined-initargs class) nil
523        (%class.changed-initargs class) nil))
524
525(defun update-class (class finalizep)
526  ;;
527  ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
528  ;; makes the class finalized.  When UPDATE-CLASS isn't called from
529  ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
530  ;; FINALIZE-INHERITANCE as per AMOP.  Note, that we can't simply
531  ;; delay the finalization when CLASS has no forward referenced
532  ;; superclasses because that causes bootstrap problems.
533  (when (and (not (or finalizep (class-finalized-p class)))
534             (not (class-has-a-forward-referenced-superclass-p class)))
535    (finalize-inheritance class)
536    (return-from update-class))
537
538  (when (or finalizep
539            (class-finalized-p class)
540            (not (class-has-a-forward-referenced-superclass-p class)))
541    (update-cpl class (compute-class-precedence-list  class))
542    ;;; This -should- be made to work for structure classes
543    (update-slots class (compute-slots class))
544    (setf (%class-default-initargs class) (compute-default-initargs class))
545    (%flush-initargs-caches class)
546    )
547  (unless finalizep
548    (dolist (sub (%class-direct-subclasses class))
549      (update-class sub nil))))
550
551(defun add-accessor-methods (class dslotds)
552  (dolist (dslotd dslotds)
553    (dolist (reader (%slot-definition-readers dslotd))
554      (add-reader-method class                     
555                         (ensure-generic-function reader)
556                         dslotd))
557    (dolist (writer (%slot-definition-writers dslotd))
558      (add-writer-method class
559                         (ensure-generic-function writer)
560                         dslotd))))
561
562(defun remove-accessor-methods (class dslotds)
563  (dolist (dslotd dslotds)
564    (dolist (reader (%slot-definition-readers dslotd))
565      (remove-reader-method class (ensure-generic-function reader :lambda-list '(x))))
566    (dolist (writer (%slot-definition-writers dslotd))
567      (remove-writer-method class (ensure-generic-function writer :lambda-list '(x y))))))
568
569(defmethod reinitialize-instance :before ((class std-class)  &key direct-superclasses)
570  (remove-accessor-methods class (%class-direct-slots class))
571  (remove-direct-subclasses class (%class-direct-superclasses class) direct-superclasses))
572   
573(defmethod shared-initialize :after
574  ((class slots-class)
575   slot-names &key
576   (direct-superclasses nil direct-superclasses-p)
577   (direct-slots nil direct-slots-p)
578   (direct-default-initargs nil direct-default-initargs-p)
579   (documentation nil doc-p)
580   (primary-p nil primary-p-p))
581  (declare (ignore slot-names))
582  (if direct-superclasses-p
583    (progn
584      (setq direct-superclasses (or direct-superclasses
585                                    (list *standard-object-class*)))
586      (dolist (superclass direct-superclasses)
587        (unless (validate-superclass class superclass)
588          (error "The class ~S was specified as a~%super-class of the class ~S;~%~
589                    but the meta-classes ~S and~%~S are incompatible."
590                 superclass class (class-of superclass) (class-of class))))
591      (setf (%class-direct-superclasses class) direct-superclasses))
592    (setq direct-superclasses (%class-direct-superclasses class)))
593  (setq direct-slots
594        (if direct-slots-p
595          (setf (%class-direct-slots class)
596                (mapcar #'(lambda (initargs)
597                            (make-direct-slot-definition class initargs))
598                        direct-slots))
599          (%class-direct-slots class)))
600  (if direct-default-initargs-p
601      (setf (%class-direct-default-initargs class)  direct-default-initargs)
602      (setq direct-default-initargs (%class-direct-default-initargs class)))
603  (let* ((class-slot-cells ()))
604    (dolist (slot direct-slots)
605      (when (eq (%slot-definition-allocation slot) :class)
606        (let* ((initfunction (%slot-definition-initfunction slot)))
607          (push (cons (%slot-definition-name slot)
608                      (if initfunction
609                        (funcall initfunction)
610                        (%slot-unbound-marker)))
611                class-slot-cells))))
612    (when class-slot-cells
613      (setf (%class-get class :class-slots) class-slot-cells)))
614  (when doc-p
615    (set-documentation class 'type documentation))
616  (when primary-p-p
617    (setf (class-primary-p class) primary-p))
618
619  (add-direct-subclasses class direct-superclasses)
620  (update-class class nil)
621  (add-accessor-methods class direct-slots))
622
623(defmethod initialize-instance :before ((class class) &key &allow-other-keys)
624  (setf (%class.ctype class) (make-class-ctype class)))
625
626(defun ensure-class-metaclass-and-initargs (class args)
627  (let* ((initargs (copy-list args))
628         (missing (cons nil nil))
629         (supplied-meta (getf initargs :metaclass missing))
630         (supplied-supers (getf initargs :direct-superclasses missing))
631         (supplied-slots (getf initargs :direct-slots missing))
632         (metaclass (cond ((not (eq supplied-meta missing))
633                           (if (typep supplied-meta 'class)
634                             supplied-meta
635                             (find-class supplied-meta)))
636                          ((or (null class)
637                               (typep class 'forward-referenced-class))
638                           *standard-class-class*)
639                          (t (class-of class)))))
640    (declare (dynamic-extent missing))
641    (flet ((fix-super (s)
642             (cond ((classp s) s)
643                   ((not (and s (symbolp s)))
644                    (error "~s is not a class or a legal class name." s))
645                   (t
646                    (or (find-class s nil)
647                        (setf (find-class s)
648                              (make-instance 'forward-referenced-class :name s))))))
649           (excise-all (keys)
650             (dolist (key keys)
651               (loop (unless (remf initargs key) (return))))))
652      (excise-all '(:metaclass :direct-superclasses :direct-slots))
653      (values metaclass
654              `(,@ (unless (eq supplied-supers missing)
655                     `(:direct-superclasses ,(mapcar #'fix-super supplied-supers)))
656                ,@ (unless (eq supplied-slots missing)
657                     `(:direct-slots ,supplied-slots))
658               ,@initargs)))))
659
660;;; This defines a new class.
661(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys)
662  (multiple-value-bind (metaclass initargs)
663      (ensure-class-metaclass-and-initargs class keys)
664    (let* ((class (apply #'make-instance metaclass :name name initargs)))     
665      (setf (find-class name) class))))
666
667(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys)
668  (multiple-value-bind (metaclass initargs)
669      (ensure-class-metaclass-and-initargs class keys)
670    (change-class class metaclass)
671    (apply #'reinitialize-instance class initargs)
672    (setf (find-class name) class)))
673           
674;;; Redefine an existing (not forward-referenced) class.
675(defmethod ensure-class-using-class ((class class) name &rest keys &key)
676  (multiple-value-bind (metaclass initargs)
677      (ensure-class-metaclass-and-initargs class keys)
678    (unless (eq (class-of class) metaclass)
679      (error "Can't change metaclass of ~s to ~s." class metaclass))
680    (apply #'reinitialize-instance class initargs)
681    (setf (find-class name) class)))
682
683
684(defun ensure-class (name &rest keys &key &allow-other-keys)
685  (apply #'ensure-class-using-class (find-class name nil) name keys))
686
687(defparameter *defclass-redefines-improperly-named-classes-pedantically* 
688   t
689  "ANSI CL expects DEFCLASS to redefine an existing class only when
690the existing class is properly named, the MOP function ENSURE-CLASS
691redefines existing classes regardless of their CLASS-NAME.  This variable
692governs whether DEFCLASS makes that distinction or not.")
693
694(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
695  (record-source-file name 'class)
696  ;; Maybe record source-file information for accessors as well
697  ;; We should probably record them as "accessors of the class", since
698  ;; there won't be any other explicit defining form associated with
699  ;; them.
700  (let* ((existing-class (find-class name nil)))
701    (when (and *defclass-redefines-improperly-named-classes-pedantically* 
702               existing-class 
703              (not (eq (class-name existing-class) name)))
704      ;; Class isn't properly named; act like it didn't exist
705      (setq existing-class nil))
706    (apply #'ensure-class-using-class existing-class name keys)))
707
708
709(defun slot-plist-from-%slotd (%slotd allocation)
710  (destructuring-bind (name initform initargs . type) %slotd
711    (let* ((initfunction (if (functionp initform)
712                           initform
713                           (if (consp initform)
714                             (constantly (car initform))))))
715      `(:name ,name :alllocation ,allocation :initargs ,initargs
716        ,@(when initfunction `(:initfunction ,initfunction :initform ',initform))
717        :type ,(or type t)))))
718
719
720
721
722(defmethod method-slot-name ((m standard-accessor-method))
723  (standard-direct-slot-definition.name (%accessor-method.slot-definition m)))
724
725
726(defun %ensure-class-preserving-wrapper (&rest args)
727  (declare (dynamic-extent args))
728  (let* ((*update-slots-preserve-existing-wrapper* t))
729    (apply #'ensure-class args)))
730
731(defun %find-direct-slotd (class name)
732  (dolist (dslotd (%class-direct-slots class)
733           (error "Direct slot definition for ~s not found in ~s" name class))
734    (when (eq (%slot-definition-name dslotd) name)
735      (return dslotd))))
736
737(defun %add-slot-readers (class-name pairs)
738  (let* ((class (find-class class-name)))
739    (dolist (pair pairs)
740      (destructuring-bind (slot-name &rest readers) pair
741        (setf (%slot-definition-readers (%find-direct-slotd class slot-name)) readers)))
742    (add-accessor-methods class (%class-direct-slots class))))
743
744(defun %add-slot-writers (class-name pairs)
745  (let* ((class (find-class class-name)))
746    (dolist (pair pairs)
747      (destructuring-bind (slot-name &rest readers) pair
748        (setf (%slot-definition-writers (%find-direct-slotd class slot-name)) readers)))
749    (add-accessor-methods class (%class-direct-slots class))))
750
751
752(%ensure-class-preserving-wrapper
753 'standard-method
754 :direct-superclasses '(method)
755 :direct-slots `((:name qualifiers :initargs (:qualifiers) :initfunction ,#'false :initform nil)
756                 (:name specializers :initargs (:specializers) :initfunction ,#'false :initform nil)
757                 (:name function :initargs (:function))
758                 (:name generic-function :initargs (:generic-function) :initfunction ,#'false :initform nil)
759                 (:name name :initargs (:name) :initfunction ,#'false :initform nil)
760                 (:name lambda-list :initform nil :initfunction ,#'false
761                  :initargs (:lambda-list)))
762 :primary-p t)
763
764(defmethod shared-initialize :after ((method standard-method)
765                                     slot-names
766                                     &key function &allow-other-keys)
767  (declare (ignore slot-names))
768  (when function
769    (let* ((inner (closure-function function)))
770      (unless (eq inner function)
771        (copy-method-function-bits inner function)))   
772    (lfun-name function method)))
773
774;;; Reader & writer methods classes.
775(%ensure-class-preserving-wrapper
776 'standard-accessor-method
777 :direct-superclasses '(standard-method)
778 :direct-slots '((:name slot-definition :initargs (:slot-definition)))
779 :primary-p t)
780
781(%ensure-class-preserving-wrapper
782 'standard-reader-method
783 :direct-superclasses '(standard-accessor-method))
784
785(%ensure-class-preserving-wrapper
786 'standard-writer-method
787 :direct-superclasses '(standard-accessor-method))
788
789(defmethod reader-method-class ((class standard-class)
790                                (dslotd standard-direct-slot-definition)
791                                &rest initargs)
792  (declare (ignore initargs))
793  *standard-reader-method-class*)
794
795(defmethod reader-method-class ((class funcallable-standard-class)
796                                (dslotd standard-direct-slot-definition)
797                                &rest initargs)
798  (declare (ignore  initargs))
799  *standard-reader-method-class*)
800
801(defmethod add-reader-method ((class slots-class) gf dslotd)
802  (let* ((initargs
803          `(:qualifiers nil
804            :specializers ,(list class)
805            :lambda-list (x)
806            :name ,(function-name gf)
807            :slot-definition ,dslotd))
808         (reader-method-class
809          (apply #'reader-method-class class dslotd initargs))
810         (method-function (create-reader-method-function
811                           class (class-prototype reader-method-class) dslotd))
812         (method (apply #'make-instance reader-method-class
813                        :function method-function
814                        initargs)))
815    (declare (dynamic-extent initargs))
816    (add-method gf method)))
817
818(defmethod remove-reader-method ((class std-class) gf)
819  (let* ((method (find-method gf () (list class) nil)))
820    (when method (remove-method gf method))))
821
822(defmethod writer-method-class ((class standard-class)
823                                (dslotd standard-direct-slot-definition)
824                                &rest initargs)
825  (declare (ignore initargs))
826  *standard-writer-method-class*)
827
828(defmethod writer-method-class ((class funcallable-standard-class)
829                                (dslotd standard-direct-slot-definition)
830                                &rest initargs)
831  (declare (ignore initargs))
832  *standard-writer-method-class*)
833
834
835(defmethod add-writer-method ((class slots-class) gf dslotd)
836  (let* ((initargs
837          `(:qualifiers nil
838            :specializers ,(list *t-class* class)
839            :lambda-list (y x)
840            :name ,(function-name gf)
841            :slot-definition ,dslotd))
842         (method-class (apply #'writer-method-class class dslotd initargs))
843         (method 
844          (apply #'make-instance
845                 method-class
846                 :function (create-writer-method-function
847                            class
848                            (class-prototype method-class)
849                            dslotd)
850                 initargs)))
851    (declare (dynamic-extent initargs))
852    (add-method gf method)))
853
854(defmethod remove-writer-method ((class std-class) gf)
855  (let* ((method (find-method gf () (list *t-class* class) nil)))
856    (when method (remove-method gf method))))
857
858;;; We can now define accessors.  Fix up the slots in the classes defined
859;;; thus far.
860
861(%add-slot-readers 'standard-method '((qualifiers method-qualifiers)
862                                      (specializers method-specializers)
863                                      (name method-name)
864                                      ;(function method-function)
865                                      (generic-function method-generic-function)
866                                      (lambda-list method-lambda-list)))
867
868(%add-slot-writers 'standard-method '((function (setf method-function))
869                                      (generic-function (setf method-generic-function))))
870
871(defmethod method-function ((m standard-method))
872  (%method.function m))
873
874
875(%add-slot-readers 'standard-accessor-method
876                   '((slot-definition accessor-method-slot-definition)))
877
878(%ensure-class-preserving-wrapper
879 'specializer
880 :direct-superclasses '(metaobject)
881 :direct-slots `((:name direct-methods
882                  :readers (specializer-direct-methods)
883                  :initform nil :initfunction ,#'false))
884 :primary-p t)
885                 
886(%ensure-class-preserving-wrapper
887 'eql-specializer
888 :direct-superclasses '(specializer)
889 :direct-slots '((:name object :initargs (:object) :readers (eql-specializer-object)))
890 :primary-p t)
891
892
893(%ensure-class-preserving-wrapper
894 'class
895 :direct-superclasses '(specializer)
896 :direct-slots
897 `((:name prototype :initform nil :initfunction ,#'false)
898   (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name))
899   (:name precedence-list :initargs (:precedence-list) :initform nil  :initfunction ,#'false)
900   (:name own-wrapper :initargs (:own-wrapper) :initform nil  :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper)))
901   (:name direct-superclasses :initargs (:direct-superclasses) :initform nil  :initfunction ,#'false :readers (class-direct-superclasses))
902   (:name direct-subclasses :initargs (:direct-subclasses) :initform nil  :initfunction ,#'false :readers (class-direct-subclasses))
903   (:name dependents :initform nil :initfunction ,#'false)
904   (:name class-ctype :initform nil :initfunction ,#'false))
905 :primary-p t)
906
907
908(%ensure-class-preserving-wrapper
909 'forward-referenced-class
910 :direct-superclasses '(class))
911
912
913
914(%ensure-class-preserving-wrapper
915 'built-in-class
916 :direct-superclasses '(class))
917
918
919(%ensure-class-preserving-wrapper
920 'slots-class
921 :direct-superclasses '(class)
922 :direct-slots `((:name direct-slots :initform nil :initfunction ,#'false
923                  :initargs (:direct-slots) :readers (class-direct-slots)
924                  :writers ((setf class-direct-slots)))
925                 (:name slots :initform nil :initfunction ,#'false
926                   :readers (class-slots))
927                 (:name kernel-p :initform nil :initfunction ,#'false)
928                 (:name direct-default-initargs :initargs (:direct-default-initargs) :initform nil  :initfunction ,#'false :readers (class-direct-default-initargs))
929                 (:name default-initargs :initform nil  :initfunction ,#'false :readers (class-default-initargs))
930                 (:name alist :initform nil  :initfunction ,#'false))
931 :primary-p t)
932
933; This class exists only so that standard-class & funcallable-standard-class
934; can inherit its slots.
935(%ensure-class-preserving-wrapper
936 'std-class
937 :direct-superclasses '(slots-class)
938 :direct-slots `(
939                 (:name make-instance-initargs :initform nil  :initfunction ,#'false)
940                 (:name reinit-initargs :initform nil  :initfunction ,#'false)
941                 (:name redefined-initargs :initform nil :initfunction ,#'false)
942                 (:name changed-initargs :initform nil  :initfunction ,#'false))
943 :primary-p t)
944
945
946
947(%ensure-class-preserving-wrapper
948 'standard-class
949 :direct-superclasses '(std-class))
950
951(%ensure-class-preserving-wrapper
952 'funcallable-standard-class
953 :direct-superclasses '(std-class))
954
955
956(%ensure-class-preserving-wrapper
957 'generic-function
958 :direct-superclasses '(metaobject funcallable-standard-object)
959 :metaclass 'funcallable-standard-class)
960
961(%ensure-class-preserving-wrapper
962 'standard-generic-function
963 :direct-superclasses '(generic-function)
964 :direct-slots `((:name name :initargs (:name) :readers (generic-function-name))
965                 (:name method-combination :initargs (:method-combination)
966                  :initform *standard-method-combination*
967                  :initfunction ,#'(lambda () *standard-method-combination*)
968                  :readers (generic-function-method-combination))
969                 (:name method-class :initargs (:method-class)
970                  :initform *standard-method-class*
971                  :initfunction ,#'(lambda () *standard-method-class*)
972                  :readers (generic-function-method-class))
973                 (:name methods :initargs (:methods)
974                  :initform nil :initfunction ,#'false
975                  :readers (generic-function-methods))
976                 (:name declarations
977                  :initargs (:declarations)
978                  :initform nil :initfunction ,#'false
979                  :readers (generic-function-declarations))
980                 (:name %lambda-list
981                  :initform :unspecified
982                  :initfunction ,(constantly :unspecified))
983                 (:name dependents
984                  :initform nil :initfunction ,#'false))
985 :metaclass 'funcallable-standard-class
986 :primary-p t)
987
988(%ensure-class-preserving-wrapper
989 'standard-generic-function
990 :direct-superclasses '(generic-function)
991
992 :metaclass 'funcallable-standard-class)
993
994(%ensure-class-preserving-wrapper
995 'structure-class
996 :direct-superclasses '(slots-class))
997
998(%ensure-class-preserving-wrapper
999 'slot-definition
1000 :direct-superclasses '(metaobject)
1001  :direct-slots `((:name name :initargs (:name) :readers (slot-definition-name)
1002                  :initform nil :initfunction ,#'false)
1003                 (:name type :initargs (:type) :readers (slot-definition-type)
1004                  :initform nil :initfunction ,#'false)
1005                 (:name initfunction :initargs (:initfunction) :readers (slot-definition-initfunction)
1006                  :initform nil :initfunction ,#'false)
1007                 (:name initform :initargs (:initform) :readers (slot-definition-initform)
1008                  :initform nil :initfunction ,#'false)
1009                 (:name initargs :initargs (:initargs) :readers (slot-definition-initargs)
1010                  :initform nil :initfunction ,#'false)
1011                 (:name allocation :initargs (:allocation) :readers (slot-definition-allocation)
1012                  :initform :instance :initfunction ,(constantly :instance))
1013                 (:name documentation :initargs (:documentation) :readers (slot-definition-documentation)
1014                  :initform nil :initfunction ,#'false)
1015                 (:name class :initargs (:class) :readers (slot-definition-class)))
1016 
1017 :primary-p t)
1018
1019(%ensure-class-preserving-wrapper
1020 'direct-slot-definition
1021 :direct-superclasses '(slot-definition)
1022 :direct-slots `((:name readers :initargs (:readers) :initform nil
1023                  :initfunction ,#'false :readers (slot-definition-readers))
1024                 (:name writers :initargs (:writers) :initform nil
1025                  :initfunction ,#'false :readers (slot-definition-writers))))
1026
1027(%ensure-class-preserving-wrapper
1028 'effective-slot-definition
1029 :direct-superclasses '(slot-definition)
1030 :direct-slots `((:name location :initform nil :initfunction ,#'false
1031                  :readers (slot-definition-location))
1032                 (:name slot-id :initform nil :initfunction ,#'false
1033                  :readers (slot-definition-slot-id))
1034                 (:name type-predicate :initform #'true
1035                  :initfunction ,#'(lambda () #'true)
1036                  :readers (slot-definition-predicate))
1037                 )
1038 
1039 :primary-p t)
1040
1041(%ensure-class-preserving-wrapper
1042 'standard-slot-definition
1043 :direct-superclasses '(slot-definition)
1044)
1045
1046
1047
1048
1049
1050
1051
1052(%ensure-class-preserving-wrapper
1053 'standard-direct-slot-definition
1054 :direct-superclasses '(standard-slot-definition direct-slot-definition)
1055)
1056
1057(%ensure-class-preserving-wrapper
1058 'standard-effective-slot-definition
1059 :direct-superclasses '(standard-slot-definition effective-slot-definition))
1060
1061                 
1062
1063
1064     
1065                             
1066
1067
1068
1069;; Fake method-combination
1070(defclass method-combination (metaobject) 
1071  ((name :accessor method-combination-name :initarg :name)))
1072
1073
1074
1075(defclass standard-method-combination (method-combination) ())
1076
1077(initialize-instance *standard-method-combination* :name 'standard)
1078
1079(setq *standard-kernel-method-class*
1080  (defclass standard-kernel-method (standard-method)
1081    ()))
1082
1083(unless *standard-method-combination*
1084  (setq *standard-method-combination*
1085        (make-instance 'standard-method-combination :name 'standard)))
1086
1087; For %compile-time-defclass
1088(defclass compile-time-class (class) ())
1089
1090
1091(defclass structure-slot-definition (slot-definition) ())
1092(defclass structure-effective-slot-definition (structure-slot-definition
1093                                               effective-slot-definition)
1094    ())
1095
1096(defclass structure-direct-slot-definition (structure-slot-definition
1097                                            direct-slot-definition)
1098    ())
1099
1100(defmethod shared-initialize :after ((class structure-class)
1101                                     slot-names
1102                                     &key
1103                                     (direct-superclasses nil direct-superclasses-p)
1104                                     &allow-other-keys)
1105  (declare (ignore slot-names))
1106  (labels ((obsolete (class)
1107             (dolist (sub (%class-direct-subclasses class)) (obsolete sub))
1108             ;;Need to save old class info in wrapper for obsolete instance access...
1109             (setf (%class.cpl class) nil)))
1110    (obsolete class)
1111    (when direct-superclasses-p
1112      (let* ((old-supers (%class-direct-superclasses class))
1113             (new-supers direct-superclasses))
1114        (dolist (c old-supers)
1115          (unless (memq c new-supers)
1116            (remove-direct-subclass c class)))
1117        (dolist (c new-supers)
1118          (unless (memq c old-supers)
1119            (add-direct-subclass c class)))
1120        (setf (%class.local-supers class) new-supers)))
1121    (unless (%class-own-wrapper class)
1122      (setf (%class-own-wrapper class) (%cons-wrapper class)))
1123    (update-cpl class (compute-cpl class))))
1124             
1125
1126                                     
1127                                     
1128; Called from DEFSTRUCT expansion.
1129(defun %define-structure-class (sd)
1130  (let* ((dslots ()))
1131    (dolist (ssd (cdr (sd-slots sd)) (setq dslots (nreverse dslots)))
1132      (let* ((type (ssd-type ssd))
1133             (refinfo (ssd-refinfo ssd)))
1134        (unless (logbitp $struct-inherited refinfo)
1135          (let* ((name (ssd-name ssd))
1136                 (initform (cadr ssd))
1137                 (initfunction (constantly initform)))
1138            (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction) dslots)))))
1139    (ensure-class (sd-name sd)
1140                  :metaclass 'structure-class
1141                  :direct-superclasses (list (or (cadr (sd-superclasses sd)) 'structure-object))
1142                  :direct-slots  dslots 
1143                  )))
1144
1145
1146
1147(defun standard-instance-access (instance location)
1148  (etypecase location
1149    (fixnum (%standard-instance-instance-location-access instance location))
1150    (cons (%cdr location))))
1151
1152(defun (setf standard-instance-access) (new instance location)
1153  (etypecase location
1154    (fixnum (setf (standard-instance-instance-location-access instance location)
1155                  new))
1156    (cons (setf (%cdr location) new))))
1157
1158(defun funcallable-standard-instance-access (instance location)
1159  (etypecase location
1160    (fixnum (%standard-generic-function-instance-location-access instance location))
1161    (cons (%cdr location))))
1162
1163(defun (setf funcallable-standard-instance-access) (new instance location)
1164  (etypecase location
1165    (fixnum (setf (%standard-generic-function-instance-location-access instance location) new))
1166    (cons (setf (%cdr location) new))))
1167
1168;;; Handle a trap from %slot-ref
1169(defun %slot-unbound-trap (slotv idx frame-ptr)
1170  (let* ((instance nil)
1171         (class nil)
1172         (slot nil))
1173    (if (and (eq (typecode slotv) ppc32::subtag-slot-vector)
1174             (setq instance (slot-vector.instance slotv))
1175             (setq slot
1176                   (find idx (class-slots (setq class (class-of instance)))
1177                         :key #'slot-definition-location)))
1178      (slot-unbound class instance (slot-definition-name slot))
1179      (%error "Unbound slot at index ~d in ~s" (list idx slotv) frame-ptr))))
1180
1181
1182;;;
1183;;; Now that CLOS is nominally bootstrapped, it's possible to redefine some
1184;;; of the functions that really should have been generic functions ...
1185(setf (fdefinition '%class-name) #'class-name
1186      (fdefinition '%class-default-initargs) #'class-default-initargs
1187      (fdefinition '%class-direct-default-initargs) #'class-direct-default-initargs
1188      (fdefinition '(setf %class-direct-default-initargs))
1189      #'(lambda (new class)
1190          (if (typep class 'slots-class)
1191            (setf (slot-value class 'direct-default-initargs) new)
1192            new))
1193      (fdefinition '%class-direct-slots) #'class-direct-slots
1194      (fdefinition '(setf %class-direct-slots))
1195                   #'(setf class-direct-slots)
1196      (fdefinition '%class-slots) #'class-slots
1197      (fdefinition '%class-direct-superclasses) #'class-direct-superclasses
1198      (fdefinition '(setf %class-direct-superclasses))
1199      #'(lambda (new class)
1200          (setf (slot-value class 'direct-superclasses) new))
1201      (fdefinition '%class-direct-subclasses) #'class-direct-subclasses
1202      (fdefinition '%class-own-wrapper) #'class-own-wrapper
1203      (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper)
1204)
1205
1206
1207
1208(setf (fdefinition '%slot-definition-name) #'slot-definition-name
1209      (fdefinition '%slot-definition-type) #'slot-definition-type
1210      (fdefinition '%slot-definition-initargs) #'slot-definition-initargs
1211      (fdefinition '%slot-definition-allocation) #'slot-definition-allocation
1212      (fdefinition '%slot-definition-location) #'slot-definition-location
1213      (fdefinition '%slot-definition-readers) #'slot-definition-readers
1214      (fdefinition '%slot-definition-writers) #'slot-definition-writers)
1215
1216
1217(setf (fdefinition '%method-qualifiers) #'method-qualifiers
1218      (fdefinition '%method-specializers) #'method-specializers
1219      (fdefinition '%method-function) #'method-function
1220      (fdefinition '(setf %method-function)) #'(setf method-function)
1221      (fdefinition '%method-gf) #'method-generic-function
1222      (fdefinition '(setf %method-gf)) #'(setf method-generic-function)
1223      (fdefinition '%method-name) #'method-name
1224      (fdefinition '%method-lambda-list) #'method-lambda-list
1225      )
1226                   
1227     
1228;;; Make a direct-slot-definition of the appropriate class.
1229(defun %make-direct-slotd (slotd-class &rest initargs)
1230  (declare (dynamic-extent initargs))
1231  (apply #'make-instance slotd-class initargs))
1232
1233;;; Likewise, for an effective-slot-definition.
1234(defun %make-effective-slotd (slotd-class &rest initargs)
1235  (declare (dynamic-extent initargs))
1236  (apply #'make-instance slotd-class initargs))
1237
1238(defmethod initialize-instance :after ((slotd effective-slot-definition) &key name)
1239  (setf (standard-effective-slot-definition.slot-id slotd)
1240        (ensure-slot-id name)))
1241 
1242(defmethod specializer-direct-generic-functions ((s specializer))
1243  (let* ((gfs ())
1244         (methods (specializer-direct-methods s)))
1245    (dolist (m methods gfs)
1246      (let* ((gf (method-generic-function m)))
1247        (when gf (pushnew gf gfs))))))
1248
1249(defmethod generic-function-lambda-list ((gf standard-generic-function))
1250  (%maybe-compute-gf-lambda-list gf (car (generic-function-methods gf))))
1251
1252(defmethod generic-function-argument-precedence-order
1253    ((gf standard-generic-function))
1254  (let* ((req (required-lambda-list-args (generic-function-lambda-list gf)))
1255         (apo (%gf-dispatch-table-precedence-list
1256               (%gf-dispatch-table gf))))
1257    (if (null apo)
1258      req
1259      (mapcar #'(lambda (n) (nth n req)) apo))))
1260
1261(defun normalize-egf-keys (keys gf)
1262  (let* ((missing (cons nil nil))
1263         (env (getf keys :environment nil)))
1264    (declare (dynamic-extent missing))
1265    (remf keys :environment)
1266    (let* ((gf-class (getf keys :generic-function-class missing))
1267           (mcomb (getf keys :method-combination missing))
1268           (method-class (getf keys :method-class missing)))
1269      (if (eq gf-class missing)
1270        (setf gf-class (if gf (class-of gf) *standard-generic-function-class*))
1271        (progn
1272          (remf keys :generic-function-class)
1273          (if (typep gf-class 'symbol)
1274            (setq gf-class
1275                  (find-class gf-class t env)))
1276          (unless (or (eq gf-class *standard-generic-function-class*)
1277                      (subtypep gf-class *generic-function-class*))
1278            (error "Class ~S is not a subclass of ~S")
1279            gf-class *generic-function-class*)))
1280      (unless (eq mcomb missing)
1281        (unless (typep mcomb 'method-combination)
1282          (setf (getf keys :method-combination)
1283                (find-method-combination (class-prototype gf-class)
1284                                         (car mcomb)
1285                                         (cdr mcomb)))))
1286      (unless (eq method-class missing)
1287        (if (typep method-class 'symbol)
1288          (setq method-class (find-class method-class t env)))
1289        (unless (subtypep method-class *method-class*)
1290          (error "~s is not a subclass of ~s" method-class *method-class*))
1291        (setf (getf keys :method-class) method-class))
1292      (values gf-class keys))))
1293   
1294(defmethod ensure-generic-function-using-class
1295    ((gf null)
1296     function-name
1297     &rest keys
1298     &key
1299     &allow-other-keys)
1300  (declare (dynamic-extent keys))
1301  (multiple-value-bind (gf-class initargs)
1302      (normalize-egf-keys keys nil)
1303    (let* ((gf (apply #'make-instance gf-class
1304                      :name function-name
1305                      initargs)))
1306      (setf (fdefinition function-name) gf))))
1307
1308(defmethod ensure-generic-function-using-class
1309    ((gf generic-function)
1310     function-name
1311     &rest keys
1312     &key
1313     &allow-other-keys)
1314  (declare (dynamic-extent keys) (ignorable function-name))
1315  (multiple-value-bind (gf-class initargs)
1316      (normalize-egf-keys keys gf)
1317    (unless (eq gf-class (class-of gf))
1318      (cerror (format nil "Change the class of ~s to ~s." gf gf-class)
1319              "The class of the existing generic function ~s is not ~s"
1320              gf gf-class))
1321    (apply #'reinitialize-instance gf initargs)))
1322
1323(defmethod initialize-instance :after ((gf standard-generic-function)
1324                                       &key
1325                                       (lambda-list nil ll-p)
1326                                       (argument-precedence-order nil apo-p)
1327                                       &allow-other-keys)
1328  (if (and apo-p (not ll-p))
1329    (error
1330     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1331  (if ll-p
1332    (progn
1333      (unless (verify-lambda-list lambda-list)
1334        (error "~s is not a valid generic function lambda list" lambda-list))
1335      (if apo-p
1336        (set-gf-arg-info gf :lambda-list lambda-list
1337                         :argument-precedence-order argument-precedence-order)
1338        (set-gf-arg-info gf :lambda-list lambda-list)))
1339    (set-gf-arg-info gf))
1340  (if (gf-arg-info-valid-p gf)
1341    (compute-dcode gf (%gf-dispatch-table gf)))
1342  gf)
1343
1344(defmethod reinitialize-instance :after ((gf standard-generic-function)
1345                                         &rest args
1346                                         &key
1347                                         (lambda-list nil ll-p)
1348                                         (argument-precedence-order nil apo-p)
1349                                         &allow-other-keys)
1350  (if (and apo-p (not ll-p))
1351    (error
1352     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1353  (if ll-p
1354    (progn
1355      (unless (verify-lambda-list lambda-list)
1356        (error "~s is not a valid generic function lambda list" lambda-list))
1357      (if apo-p
1358        (set-gf-arg-info gf :lambda-list lambda-list
1359                         :argument-precedence-order argument-precedence-order)
1360        (set-gf-arg-info gf :lambda-list lambda-list)))
1361    (set-gf-arg-info gf))
1362  (if (and (gf-arg-info-valid-p gf)
1363           args
1364           (or ll-p (cddr args)))
1365    (compute-dcode gf (%gf-dispatch-table gf)))
1366  (when (sgf.dependents gf)
1367    (map-dependents gf #'(lambda (d)
1368                           (apply #'update-dependent gf d args))))
1369  gf)
1370 
1371
1372(defun decode-method-lambda-list (method-lambda-list)
1373  (flet ((bad ()
1374           (error "Invalid lambda-list syntax in ~s" method-lambda-list)))
1375    (collect ((specnames)
1376                    (required))
1377       (do* ((tail method-lambda-list (cdr tail))
1378             (head (car tail) (car tail)))
1379            ((or (null tail) (member head lambda-list-keywords))
1380             (if (verify-lambda-list tail)
1381               (values (required) tail (specnames))
1382               (bad)))
1383         (cond ((atom head)
1384                (unless (typep head 'symbol) (bad))
1385                (required head)
1386                (specnames t))
1387               (t
1388                (unless (and (typep (car head) 'symbol)
1389                             (consp (cdr head))
1390                             (null (cddr head)))
1391                  (bad))
1392                (required (car head))
1393                (specnames (cadr head))))))))
1394 
1395(defun extract-specializer-names (method-lambda-list)
1396  (nth-value 2 (decode-method-lambda-list method-lambda-list)))
1397
1398(defun extract-lambda-list (method-lambda-list)
1399  (multiple-value-bind (required tail)
1400      (decode-method-lambda-list method-lambda-list)
1401    (nconc required tail)))
1402
1403(setf (fdefinition '%ensure-generic-function-using-class)
1404      #'ensure-generic-function-using-class)
1405
1406(defmethod shared-initialize :after ((gf generic-function) slot-names
1407                                     &key
1408                                     (documentation nil doc-p))
1409  (declare (ignore slot-names))
1410  (when doc-p
1411    (if documentation (check-type documentation string))
1412    (set-documentation gf t documentation)))
1413
1414(defmethod allocate-instance ((b built-in-class) &rest initargs)
1415  (declare (ignore initargs))
1416  (error "Can't allocate instances of BUILT-IN-CLASS."))
1417
1418(defmethod reinitialize-instance ((m method) &rest initargs)
1419  (declare (ignore initargs))
1420  (error "Can't reinitialze ~s ~s" (class-of m) m))
1421
1422(defmethod add-dependent ((class class) dependent)
1423  (pushnew dependent (%class.dependents class)))
1424
1425(defmethod add-dependent ((gf standard-generic-function) dependent)
1426  (pushnew dependent (sgf.dependents gf)))
1427
1428(defmethod remove-dependent ((class class) dependent)
1429  (setf (%class.dependents class)
1430        (delete dependent (%class.dependents class))))
1431
1432(defmethod remove-dependent ((gf standard-generic-function) dependent)
1433  (setf (sgf.dependents gf)
1434        (delete dependent (sgf.dependents gf))))
1435
1436(defmethod map-dependents ((class class) function)
1437  (dolist (d (%class.dependents class))
1438    (funcall function d)))
1439
1440(defmethod map-dependents ((gf standard-generic-function) function)
1441  (dolist (d (sgf.dependents gf))
1442    (funcall function d)))
1443
1444(defgeneric update-dependent (metaobject dependent &rest initargs))
1445
1446(defmethod reinitialize-instance :after ((class std-class) &rest initargs)
1447  (map-dependents class #'(lambda (d)
1448                            (apply #'update-dependent class d initargs))))
1449
1450
1451(defun %allocate-gf-instance (class)
1452  (unless (class-finalized-p class)
1453    (finalize-inheritance class))
1454  (let* ((wrapper (%class.own-wrapper class))
1455         (len (length (%wrapper-instance-slots wrapper)))
1456         (dt (make-gf-dispatch-table))
1457         (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))
1458         (fn (gvector :function
1459                      *gf-proto-code*
1460                      wrapper
1461                      slots
1462                      dt
1463                      #'%%0-arg-dcode
1464                      0
1465                      ;; Set the AOK (&allow-other-keys) bit without
1466                      ;; setting the KEYS bit, to indicate that we
1467                      ;; don't know anything about this gf's
1468                      ;; lambda-list.
1469                      (logior (ash 1 $lfbits-gfn-bit)
1470                              (ash 1 $lfbits-aok-bit)))))
1471    (setf (gf.hash fn) (strip-tag-to-fixnum fn)
1472          (slot-vector.instance slots) fn
1473          (%gf-dispatch-table-gf dt) fn)
1474    (push fn (population.data %all-gfs%))
1475    fn))
1476
1477(defmethod slot-value-using-class ((class structure-class)
1478                                   instance
1479                                   (slotd structure-effective-slot-definition))
1480  (let* ((loc (standard-effective-slot-definition.location slotd)))
1481      (typecase loc
1482        (fixnum
1483         (struct-ref  instance loc))
1484        (t
1485         (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1486                slotd loc (slot-definition-allocation slotd))))))
1487
1488;;; Some STRUCTURE-CLASS leftovers.
1489(defmethod (setf slot-value-using-class)
1490    (new
1491     (class structure-class)
1492     instance
1493     (slotd structure-effective-slot-definition))
1494  (let* ((loc (standard-effective-slot-definition.location slotd))
1495         (type (standard-effective-slot-definition.type slotd)))
1496    (if (and type (not (eq type t)))
1497      (unless (or (eq new (%slot-unbound-marker))
1498                  (typep new type))
1499        (setq new (require-type new type))))
1500    (typecase loc
1501      (fixnum
1502       (setf (struct-ref instance loc) new))
1503      (t
1504       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1505              slotd loc (slot-definition-allocation slotd))))))
1506
1507(defmethod slot-boundp-using-class ((class structure-class)
1508                                    instance
1509                                    (slotd structure-effective-slot-definition))
1510  (declare (ignore instance))
1511  t)
1512
1513;;; This has to be somewhere, so it might as well be here.
1514(defmethod make-load-form ((s slot-id) &optional env)
1515  (declare (ignore env))
1516  `(ensure-slot-id ,(slot-id.name s)))
1517
1518
1519(defmethod (setf class-name) (new (class class))
1520  (reinitialize-instance class :name new)
1521  new)
Note: See TracBrowser for help on using the repository browser.