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

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

ADD-READER/WRITER-METHOD: less specialized. Turn a few early accessors
into GFs; writer methods on some slots.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 54.9 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(defmethod class-primary-p ((class std-class))
425  (%class-primary-p class))
426
427(defmethod (setf class-primary-p) (new (class std-class))
428  (setf (%class-primary-p class) new))
429
430(defmethod class-primary-p ((class class))
431  t)
432
433(defmethod (setf class-primary-p) (new (class class))
434  new)
435
436
437(defun forward-referenced-class-p (class)
438  (typep class 'forward-referenced-class))
439
440; This uses the primary class information to sort a class'es slots
441(defun sort-effective-instance-slotds (slotds class cpl)
442  (let (primary-slotds
443        primary-slotds-class
444        (primary-slotds-length 0))
445    (declare (fixnum primary-slotds-length))
446    (dolist (sup (cdr cpl))
447      (unless (eq sup *t-class*)     
448        (when (class-primary-p sup)
449          (let ((sup-slotds (extract-instance-effective-slotds sup)))
450            (if (null primary-slotds-class)
451              (setf primary-slotds-class sup
452                    primary-slotds sup-slotds
453                    primary-slotds-length (length sup-slotds))
454              (let ((sup-slotds-length (length sup-slotds)))
455                (do* ((i 0 (1+ i))
456                      (n (min sup-slotds-length primary-slotds-length))
457                      (sup-slotds sup-slotds (cdr sup-slotds))
458                      (primary-slotds primary-slotds (cdr primary-slotds)))
459                     ((= i n))
460                  (unless (eq (%slot-definition-name (car sup-slotds))
461                              (%slot-definition-name (car primary-slotds)))
462                    (error "While initializing ~s:~%~
463                            attempt to mix incompatible primary classes:~%~
464                            ~s and ~s"
465                           class sup primary-slotds-class)))
466                (when (> sup-slotds-length primary-slotds-length)
467                  (setq primary-slotds-class sup
468                        primary-slotds sup-slotds
469                        primary-slotds-length sup-slotds-length))))))))
470    (if (null primary-slotds-class)
471      slotds
472      (flet ((slotd-position (slotd)
473               (let* ((slotd-name (%slot-definition-name slotd)))
474                 (do* ((i 0 (1+ i))
475                       (primary-slotds primary-slotds (cdr primary-slotds)))
476                      ((= i primary-slotds-length) primary-slotds-length)
477                   (declare (fixnum i))
478                   (when (eq slotd-name
479                                (%slot-definition-name (car primary-slotds)))
480                   (return i))))))
481        (declare (dynamic-extent #'slotd-position))
482        (sort-list slotds '< #'slotd-position)))))
483
484(defun class-has-a-forward-referenced-superclass-p (class)
485  (or (forward-referenced-class-p class)
486      (some #'class-has-a-forward-referenced-superclass-p
487            (%class-direct-superclasses class))))
488
489(defun update-cpl (class cpl)
490  (if (class-finalized-p class)
491    (unless (equal (%class.cpl class) cpl)
492      (setf (%class.cpl class) cpl)
493      #|(force-cache-flushes class)|#)
494    (setf (%class.cpl class) cpl)))
495
496
497
498(defun update-class (class finalizep)
499  ;;
500  ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
501  ;; makes the class finalized.  When UPDATE-CLASS isn't called from
502  ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
503  ;; FINALIZE-INHERITANCE as per AMOP.  Note, that we can't simply
504  ;; delay the finalization when CLASS has no forward referenced
505  ;; superclasses because that causes bootstrap problems.
506  (when (and (not (or finalizep (class-finalized-p class)))
507             (not (class-has-a-forward-referenced-superclass-p class)))
508    (finalize-inheritance class)
509    (return-from update-class))
510
511  (when (or finalizep
512            (class-finalized-p class)
513            (not (class-has-a-forward-referenced-superclass-p class)))
514    (update-cpl class (compute-cpl  class))
515    ;;; This -should- be made to work for structure classes
516    (update-slots class (compute-slots class))
517    (setf (%class-default-initargs class) (compute-default-initargs class))
518    )
519  (unless finalizep
520    (dolist (sub (%class-direct-subclasses class))
521      (update-class sub nil))))
522
523(defun add-accessor-methods (class dslotds)
524  (dolist (dslotd dslotds)
525    (dolist (reader (%slot-definition-readers dslotd))
526      (add-reader-method class                     
527                         (ensure-generic-function reader)
528                         dslotd))
529    (dolist (writer (%slot-definition-writers dslotd))
530      (add-writer-method class
531                         (ensure-generic-function writer)
532                         dslotd))))
533
534(defun remove-accessor-methods (class dslotds)
535  (dolist (dslotd dslotds)
536    (dolist (reader (%slot-definition-readers dslotd))
537      (remove-reader-method class (ensure-generic-function reader :lambda-list '(x))))
538    (dolist (writer (%slot-definition-writers dslotd))
539      (remove-writer-method class (ensure-generic-function writer :lambda-list '(x y))))))
540
541(defmethod reinitialize-instance :before ((class std-class)  &key direct-superclasses)
542  (remove-accessor-methods class (%class-direct-slots class))
543  (remove-direct-subclasses class (%class-direct-superclasses class) direct-superclasses))
544   
545(defmethod shared-initialize :after
546  ((class slots-class)
547   slot-names &key
548   (direct-superclasses nil direct-superclasses-p)
549   (direct-slots nil direct-slots-p)
550   (direct-default-initargs nil direct-default-initargs-p)
551   (documentation nil doc-p)
552   (primary-p nil primary-p-p))
553  (declare (ignore slot-names))
554  (if direct-superclasses-p
555    (progn
556      (setq direct-superclasses (or direct-superclasses
557                                    (list *standard-object-class*)))
558      (dolist (superclass direct-superclasses)
559        (unless (validate-superclass class superclass)
560          (error "The class ~S was specified as a~%super-class of the class ~S;~%~
561                    but the meta-classes ~S and~%~S are incompatible."
562                 superclass class (class-of superclass) (class-of class))))
563      (setf (%class-direct-superclasses class) direct-superclasses))
564    (setq direct-superclasses (%class-direct-superclasses class)))
565  (setq direct-slots
566        (if direct-slots-p
567          (setf (%class-direct-slots class)
568                (mapcar #'(lambda (initargs)
569                            (make-direct-slot-definition class initargs))
570                        direct-slots))
571          (%class-direct-slots class)))
572  (if direct-default-initargs-p
573      (setf (%class-direct-default-initargs class)  direct-default-initargs)
574      (setq direct-default-initargs (%class-direct-default-initargs class)))
575  (let* ((class-slot-cells ()))
576    (dolist (slot direct-slots)
577      (when (eq (%slot-definition-allocation slot) :class)
578        (let* ((initfunction (%slot-definition-initfunction slot)))
579          (push (cons (%slot-definition-name slot)
580                      (if initfunction
581                        (funcall initfunction)
582                        (%slot-unbound-marker)))
583                class-slot-cells))))
584    (when class-slot-cells
585      (setf (%class-get class :class-slots) class-slot-cells)))
586  (when doc-p
587    (set-documentation class 'type documentation))
588  (when primary-p-p
589    (setf (class-primary-p class) primary-p))
590
591  (add-direct-subclasses class direct-superclasses)
592  (update-class class nil)
593  (add-accessor-methods class direct-slots))
594
595(defmethod initialize-instance :before ((class class) &key &allow-other-keys)
596  (setf (%class.ctype class) (make-class-ctype class)))
597
598(defun ensure-class-metaclass-and-initargs (class args)
599  (let* ((initargs (copy-list args))
600         (missing (cons nil nil))
601         (supplied-meta (getf initargs :metaclass missing))
602         (supplied-supers (getf initargs :direct-superclasses missing))
603         (supplied-slots (getf initargs :direct-slots missing))
604         (metaclass (cond ((not (eq supplied-meta missing))
605                           (if (typep supplied-meta 'class)
606                             supplied-meta
607                             (find-class supplied-meta)))
608                          ((or (null class)
609                               (typep class 'forward-referenced-class))
610                           *standard-class-class*)
611                          (t (class-of class)))))
612    (declare (dynamic-extent missing))
613    (flet ((fix-super (s)
614             (cond ((classp s) s)
615                   ((not (and s (symbolp s)))
616                    (error "~s is not a class or a legal class name." s))
617                   (t
618                    (or (find-class s nil)
619                        (setf (find-class s)
620                              (make-instance 'forward-referenced-class :name s))))))
621           (excise-all (keys)
622             (dolist (key keys)
623               (loop (unless (remf initargs key) (return))))))
624      (excise-all '(:metaclass :direct-superclasses :direct-slots))
625      (values metaclass
626              `(,@ (unless (eq supplied-supers missing)
627                     `(:direct-superclasses ,(mapcar #'fix-super supplied-supers)))
628                ,@ (unless (eq supplied-slots missing)
629                     `(:direct-slots ,supplied-slots))
630               ,@initargs)))))
631
632;;; This defines a new class.
633(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys)
634  (multiple-value-bind (metaclass initargs)
635      (ensure-class-metaclass-and-initargs class keys)
636    (let* ((class (apply #'make-instance metaclass :name name initargs)))     
637      (setf (find-class name) class))))
638
639(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys)
640  (multiple-value-bind (metaclass initargs)
641      (ensure-class-metaclass-and-initargs class keys)
642    (change-class class metaclass)
643    (apply #'reinitialize-instance class initargs)
644    (setf (find-class name) class)))
645           
646;;; Redefine an existing (not forward-referenced) class.
647(defmethod ensure-class-using-class ((class class) name &rest keys &key)
648  (multiple-value-bind (metaclass initargs)
649      (ensure-class-metaclass-and-initargs class keys)
650    (unless (eq (class-of class) metaclass)
651      (error "Can't change metaclass of ~s to ~s." class metaclass))
652    (apply #'reinitialize-instance class initargs)
653    (setf (find-class name) class)))
654
655
656(defun ensure-class (name &rest keys &key &allow-other-keys)
657  (apply #'ensure-class-using-class (find-class name nil) name keys))
658
659(defparameter *defclass-redefines-improperly-named-classes-pedantically* 
660   t
661  "ANSI CL expects DEFCLASS to redefine an existing class only when
662the existing class is properly named, the MOP function ENSURE-CLASS
663redefines existing classes regardless of their CLASS-NAME.  This variable
664governs whether DEFCLASS makes that distinction or not.")
665
666(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
667  (record-source-file name 'class)
668  ;; Maybe record source-file information for accessors as well
669  ;; We should probably record them as "accessors of the class", since
670  ;; there won't be any other explicit defining form associated with
671  ;; them.
672  (let* ((existing-class (find-class name nil)))
673    (when (and *defclass-redefines-improperly-named-classes-pedantically* 
674               existing-class 
675              (not (eq (class-name existing-class) name)))
676      ;; Class isn't properly named; act like it didn't exist
677      (setq existing-class nil))
678    (apply #'ensure-class-using-class existing-class name keys)))
679
680
681(defun slot-plist-from-%slotd (%slotd allocation)
682  (destructuring-bind (name initform initargs . type) %slotd
683    (let* ((initfunction (if (functionp initform)
684                           initform
685                           (if (consp initform)
686                             (constantly (car initform))))))
687      `(:name ,name :alllocation ,allocation :initargs ,initargs
688        ,@(when initfunction `(:initfunction ,initfunction :initform ',initform))
689        :type ,(or type t)))))
690
691
692
693
694(defmethod method-slot-name ((m standard-accessor-method))
695  (standard-direct-slot-definition.name (%accessor-method.slot-definition m)))
696
697
698(defun %ensure-class-preserving-wrapper (&rest args)
699  (declare (dynamic-extent args))
700  (let* ((*update-slots-preserve-existing-wrapper* t))
701    (apply #'ensure-class args)))
702
703(defun %find-direct-slotd (class name)
704  (dolist (dslotd (%class-direct-slots class)
705           (error "Direct slot definition for ~s not found in ~s" name class))
706    (when (eq (%slot-definition-name dslotd) name)
707      (return dslotd))))
708
709(defun %add-slot-readers (class-name pairs)
710  (let* ((class (find-class class-name)))
711    (dolist (pair pairs)
712      (destructuring-bind (slot-name &rest readers) pair
713        (setf (%slot-definition-readers (%find-direct-slotd class slot-name)) readers)))
714    (add-accessor-methods class (%class-direct-slots class))))
715
716(defun %add-slot-writers (class-name pairs)
717  (let* ((class (find-class class-name)))
718    (dolist (pair pairs)
719      (destructuring-bind (slot-name &rest readers) pair
720        (setf (%slot-definition-writers (%find-direct-slotd class slot-name)) readers)))
721    (add-accessor-methods class (%class-direct-slots class))))
722
723
724(%ensure-class-preserving-wrapper
725 'standard-method
726 :direct-superclasses '(method)
727 :direct-slots `((:name qualifiers :initargs (:qualifiers) :initfunction ,#'false :initform nil)
728                 (:name specializers :initargs (:specializers) :initfunction ,#'false :initform nil)
729                 (:name function :initargs (:function))
730                 (:name generic-function :initargs (:generic-function) :initfunction ,#'false :initform nil)
731                 (:name name :initargs (:name) :initfunction ,#'false :initform nil)
732                 (:name lambda-list :initform nil :initfunction ,#'false
733                  :initargs (:lambda-list)))
734 :primary-p t)
735
736(defmethod shared-initialize :after ((method standard-method)
737                                     slot-names
738                                     &key function &allow-other-keys)
739  (declare (ignore slot-names))
740  (when function
741    (let* ((inner (closure-function function)))
742      (unless (eq inner function)
743        (copy-method-function-bits inner function)))   
744    (lfun-name function method)))
745
746;;; Reader & writer methods classes.
747(%ensure-class-preserving-wrapper
748 'standard-accessor-method
749 :direct-superclasses '(standard-method)
750 :direct-slots '((:name slot-definition :initargs (:slot-definition)))
751 :primary-p t)
752
753(%ensure-class-preserving-wrapper
754 'standard-reader-method
755 :direct-superclasses '(standard-accessor-method))
756
757(%ensure-class-preserving-wrapper
758 'standard-writer-method
759 :direct-superclasses '(standard-accessor-method))
760
761(defmethod reader-method-class ((class standard-class)
762                                (dslotd standard-direct-slot-definition)
763                                &rest initargs)
764  (declare (ignore initargs))
765  *standard-reader-method-class*)
766
767(defmethod reader-method-class ((class funcallable-standard-class)
768                                (dslotd standard-direct-slot-definition)
769                                &rest initargs)
770  (declare (ignore  initargs))
771  *standard-reader-method-class*)
772
773(defmethod add-reader-method ((class slots-class) gf dslotd)
774  (let* ((initargs
775          `(:qualifiers nil
776            :specializers ,(list class)
777            :lambda-list (x)
778            :name ,(function-name gf)
779            :slot-definition ,dslotd))
780         (reader-method-class
781          (apply #'reader-method-class class dslotd initargs))
782         (method-function (create-reader-method-function
783                           class (class-prototype reader-method-class) dslotd))
784         (method (apply #'make-instance reader-method-class
785                        :function method-function
786                        initargs)))
787    (declare (dynamic-extent initargs))
788    (add-method gf method)))
789
790(defmethod remove-reader-method ((class std-class) gf)
791  (let* ((method (find-method gf () (list class) nil)))
792    (when method (remove-method gf method))))
793
794(defmethod writer-method-class ((class standard-class)
795                                (dslotd standard-direct-slot-definition)
796                                &rest initargs)
797  (declare (ignore initargs))
798  *standard-writer-method-class*)
799
800(defmethod writer-method-class ((class funcallable-standard-class)
801                                (dslotd standard-direct-slot-definition)
802                                &rest initargs)
803  (declare (ignore initargs))
804  *standard-writer-method-class*)
805
806
807(defmethod add-writer-method ((class slots-class) gf dslotd)
808  (let* ((initargs
809          `(:qualifiers nil
810            :specializers ,(list *t-class* class)
811            :lambda-list (y x)
812            :name ,(function-name gf)
813            :slot-definition ,dslotd))
814         (method-class (apply #'writer-method-class class dslotd initargs))
815         (method 
816          (apply #'make-instance
817                 method-class
818                 :function (create-writer-method-function
819                            class
820                            (class-prototype method-class)
821                            dslotd)
822                 initargs)))
823    (declare (dynamic-extent initargs))
824    (add-method gf method)))
825
826(defmethod remove-writer-method ((class std-class) gf)
827  (let* ((method (find-method gf () (list *t-class* class) nil)))
828    (when method (remove-method gf method))))
829
830;;; We can now define accessors.  Fix up the slots in the classes defined
831;;; thus far.
832
833(%add-slot-readers 'standard-method '((qualifiers method-qualifiers)
834                                      (specializers method-specializers)
835                                      (name method-name)
836                                      ;(function method-function)
837                                      (generic-function method-generic-function)
838                                      (lambda-list method-lambda-list)))
839
840(%add-slot-writers 'standard-method '((function (setf method-function))
841                                      (generic-function (setf method-generic-function))))
842
843(defmethod method-function ((m standard-method))
844  (%method.function m))
845
846
847(%add-slot-readers 'standard-accessor-method
848                   '((slot-definition accessor-method-slot-definition)))
849
850(%ensure-class-preserving-wrapper
851 'specializer
852 :direct-superclasses '(metaobject)
853 :direct-slots `((:name direct-methods
854                  :readers (specializer-direct-methods)
855                  :initform nil :initfunction ,#'false))
856 :primary-p t)
857                 
858(%ensure-class-preserving-wrapper
859 'eql-specializer
860 :direct-superclasses '(specializer)
861 :direct-slots '((:name object :initargs (:object) :readers (eql-specializer-object)))
862 :primary-p t)
863
864
865(%ensure-class-preserving-wrapper
866 'class
867 :direct-superclasses '(specializer)
868 :direct-slots
869 `((:name prototype :initform nil :initfunction ,#'false)
870   (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name))
871   (:name precedence-list :initargs (:precedence-list) :initform nil  :initfunction ,#'false)
872   (:name own-wrapper :initargs (:own-wrapper) :initform nil  :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper)))
873   (:name direct-superclasses :initargs (:direct-superclasses) :initform nil  :initfunction ,#'false :readers (class-direct-superclasses))
874   (:name direct-subclasses :initargs (:direct-subclasses) :initform nil  :initfunction ,#'false :readers (class-direct-subclasses))
875   (:name dependents :initform nil :initfunction ,#'false)
876   (:name class-ctype :initform nil :initfunction ,#'false))
877 :primary-p t)
878
879
880(%ensure-class-preserving-wrapper
881 'forward-referenced-class
882 :direct-superclasses '(class))
883
884
885
886(%ensure-class-preserving-wrapper
887 'built-in-class
888 :direct-superclasses '(class))
889
890
891(%ensure-class-preserving-wrapper
892 'slots-class
893 :direct-superclasses '(class)
894 :direct-slots `((:name direct-slots :initform nil :initfunction ,#'false
895                  :initargs (:direct-slots) :readers (class-direct-slots)
896                  :writers ((setf class-direct-slots)))
897                 (:name slots :initform nil :initfunction ,#'false
898                   :readers (class-slots))
899                 (:name kernel-p :initform nil :initfunction ,#'false)
900                 (:name direct-default-initargs :initargs (:direct-default-initargs) :initform nil  :initfunction ,#'false :readers (class-direct-default-initargs))
901                 (:name default-initargs :initform nil  :initfunction ,#'false :readers (class-default-initargs))
902                 (:name alist :initform nil  :initfunction ,#'false))
903 :primary-p t)
904
905; This class exists only so that standard-class & funcallable-standard-class
906; can inherit its slots.
907(%ensure-class-preserving-wrapper
908 'std-class
909 :direct-superclasses '(slots-class)
910 :direct-slots `(
911                 (:name make-instance-initargs :initform nil  :initfunction ,#'false)
912                 (:name reinit-initargs :initform nil  :initfunction ,#'false)
913                 (:name redefined-initargs :initform nil :initfunction ,#'false)
914                 (:name changed-initargs :initform nil  :initfunction ,#'false))
915 :primary-p t)
916
917
918
919(%ensure-class-preserving-wrapper
920 'standard-class
921 :direct-superclasses '(std-class))
922
923(%ensure-class-preserving-wrapper
924 'funcallable-standard-class
925 :direct-superclasses '(std-class))
926
927
928(%ensure-class-preserving-wrapper
929 'generic-function
930 :direct-superclasses '(metaobject funcallable-standard-object)
931 :metaclass 'funcallable-standard-class)
932
933(%ensure-class-preserving-wrapper
934 'standard-generic-function
935 :direct-superclasses '(generic-function)
936 :direct-slots `((:name name :initargs (:name) :readers (generic-function-name))
937                 (:name method-combination :initargs (:method-combination)
938                  :initform *standard-method-combination*
939                  :initfunction ,#'(lambda () *standard-method-combination*)
940                  :readers (generic-function-method-combination))
941                 (:name method-class :initargs (:method-class)
942                  :initform *standard-method-class*
943                  :initfunction ,#'(lambda () *standard-method-class*)
944                  :readers (generic-function-method-class))
945                 (:name methods :initargs (:methods)
946                  :initform nil :initfunction ,#'false
947                  :readers (generic-function-methods))
948                 (:name declarations
949                  :initargs (:declarations)
950                  :initform nil :initfunction ,#'false
951                  :readers (generic-function-declarations))
952                 (:name %lambda-list
953                  :initform :unspecified
954                  :initfunction ,(constantly :unspecified))
955                 (:name dependents
956                  :initform nil :initfunction ,#'false))
957 :metaclass 'funcallable-standard-class
958 :primary-p t)
959
960(%ensure-class-preserving-wrapper
961 'standard-generic-function
962 :direct-superclasses '(generic-function)
963
964 :metaclass 'funcallable-standard-class)
965
966(%ensure-class-preserving-wrapper
967 'structure-class
968 :direct-superclasses '(slots-class))
969
970(%ensure-class-preserving-wrapper
971 'slot-definition
972 :direct-superclasses '(metaobject)
973  :direct-slots `((:name name :initargs (:name) :readers (slot-definition-name)
974                  :initform nil :initfunction ,#'false)
975                 (:name type :initargs (:type) :readers (slot-definition-type)
976                  :initform nil :initfunction ,#'false)
977                 (:name initfunction :initargs (:initfunction) :readers (slot-definition-initfunction)
978                  :initform nil :initfunction ,#'false)
979                 (:name initform :initargs (:initform) :readers (slot-definition-initform)
980                  :initform nil :initfunction ,#'false)
981                 (:name initargs :initargs (:initargs) :readers (slot-definition-initargs)
982                  :initform nil :initfunction ,#'false)
983                 (:name allocation :initargs (:allocation) :readers (slot-definition-allocation)
984                  :initform :instance :initfunction ,(constantly :instance))
985                 (:name documentation :initargs (:documentation) :readers (slot-definition-documentation)
986                  :initform nil :initfunction ,#'false)
987                 (:name class :initargs (:class) :readers (slot-definition-class)))
988 
989 :primary-p t)
990
991(%ensure-class-preserving-wrapper
992 'direct-slot-definition
993 :direct-superclasses '(slot-definition)
994 :direct-slots `((:name readers :initargs (:readers) :initform nil
995                  :initfunction ,#'false :readers (slot-definition-readers))
996                 (:name writers :initargs (:writers) :initform nil
997                  :initfunction ,#'false :readers (slot-definition-writers))))
998
999(%ensure-class-preserving-wrapper
1000 'effective-slot-definition
1001 :direct-superclasses '(slot-definition)
1002 :direct-slots `((:name location :initform nil :initfunction ,#'false
1003                  :readers (slot-definition-location))
1004                 (:name slot-id :initform nil :initfunction ,#'false
1005                  :readers (slot-definition-slot-id))
1006                 (:name type-predicate :initform #'true
1007                  :initfunction ,#'(lambda () #'true)
1008                  :readers (slot-definition-predicate))
1009                 )
1010 
1011 :primary-p t)
1012
1013(%ensure-class-preserving-wrapper
1014 'standard-slot-definition
1015 :direct-superclasses '(slot-definition)
1016)
1017
1018
1019
1020
1021
1022
1023
1024(%ensure-class-preserving-wrapper
1025 'standard-direct-slot-definition
1026 :direct-superclasses '(standard-slot-definition direct-slot-definition)
1027)
1028
1029(%ensure-class-preserving-wrapper
1030 'standard-effective-slot-definition
1031 :direct-superclasses '(standard-slot-definition effective-slot-definition))
1032
1033                 
1034
1035
1036     
1037                             
1038
1039
1040
1041;; Fake method-combination
1042(defclass method-combination (metaobject) 
1043  ((name :accessor method-combination-name :initarg :name)))
1044
1045
1046
1047(defclass standard-method-combination (method-combination) ())
1048
1049(initialize-instance *standard-method-combination* :name 'standard)
1050
1051(setq *standard-kernel-method-class*
1052  (defclass standard-kernel-method (standard-method)
1053    ()))
1054
1055(unless *standard-method-combination*
1056  (setq *standard-method-combination*
1057        (make-instance 'standard-method-combination :name 'standard)))
1058
1059; For %compile-time-defclass
1060(defclass compile-time-class (class) ())
1061
1062
1063(defclass structure-slot-definition (slot-definition) ())
1064(defclass structure-effective-slot-definition (structure-slot-definition
1065                                               effective-slot-definition)
1066    ())
1067
1068(defclass structure-direct-slot-definition (structure-slot-definition
1069                                            direct-slot-definition)
1070    ())
1071
1072(defmethod shared-initialize :after ((class structure-class)
1073                                     slot-names
1074                                     &key
1075                                     (direct-superclasses nil direct-superclasses-p)
1076                                     &allow-other-keys)
1077  (declare (ignore slot-names))
1078  (labels ((obsolete (class)
1079             (dolist (sub (%class-direct-subclasses class)) (obsolete sub))
1080             ;;Need to save old class info in wrapper for obsolete instance access...
1081             (setf (%class.cpl class) nil)))
1082    (obsolete class)
1083    (when direct-superclasses-p
1084      (let* ((old-supers (%class-direct-superclasses class))
1085             (new-supers direct-superclasses))
1086        (dolist (c old-supers)
1087          (unless (memq c new-supers)
1088            (remove-direct-subclass c class)))
1089        (dolist (c new-supers)
1090          (unless (memq c old-supers)
1091            (add-direct-subclass c class)))
1092        (setf (%class.local-supers class) new-supers)))
1093    (unless (%class-own-wrapper class)
1094      (setf (%class-own-wrapper class) (%cons-wrapper class)))
1095    (update-cpl class (compute-cpl class))))
1096             
1097
1098                                     
1099                                     
1100; Called from DEFSTRUCT expansion.
1101(defun %define-structure-class (sd)
1102  (let* ((dslots ()))
1103    (dolist (ssd (cdr (sd-slots sd)) (setq dslots (nreverse dslots)))
1104      (let* ((type (ssd-type ssd))
1105             (refinfo (ssd-refinfo ssd)))
1106        (unless (logbitp $struct-inherited refinfo)
1107          (let* ((name (ssd-name ssd))
1108                 (initform (cadr ssd))
1109                 (initfunction (constantly initform)))
1110            (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction) dslots)))))
1111    (ensure-class (sd-name sd)
1112                  :metaclass 'structure-class
1113                  :direct-superclasses (list (or (cadr (sd-superclasses sd)) 'structure-object))
1114                  :direct-slots  dslots 
1115                  )))
1116
1117
1118
1119(defun standard-instance-access (instance location)
1120  (etypecase location
1121    (fixnum (%standard-instance-instance-location-access instance location))
1122    (cons (%cdr location))))
1123
1124(defun (setf standard-instance-access) (new instance location)
1125  (etypecase location
1126    (fixnum (setf (standard-instance-instance-location-access instance location)
1127                  new))
1128    (cons (setf (%cdr location) new))))
1129
1130(defun funcallable-standard-instance-access (instance location)
1131  (etypecase location
1132    (fixnum (%standard-generic-function-instance-location-access instance location))
1133    (cons (%cdr location))))
1134
1135(defun (setf funcallable-standard-instance-access) (new instance location)
1136  (etypecase location
1137    (fixnum (setf (%standard-generic-function-instance-location-access instance location) new))
1138    (cons (setf (%cdr location) new))))
1139
1140;;; Handle a trap from %slot-ref
1141(defun %slot-unbound-trap (slotv idx frame-ptr)
1142  (let* ((instance nil)
1143         (class nil)
1144         (slot nil))
1145    (if (and (eq (typecode slotv) ppc32::subtag-slot-vector)
1146             (setq instance (slot-vector.instance slotv))
1147             (setq slot
1148                   (find idx (class-slots (setq class (class-of instance)))
1149                         :key #'slot-definition-location)))
1150      (slot-unbound class instance (slot-definition-name slot))
1151      (%error "Unbound slot at index ~d in ~s" (list idx slotv) frame-ptr))))
1152
1153
1154;;;
1155;;; Now that CLOS is nominally bootstrapped, it's possible to redefine some
1156;;; of the functions that really should have been generic functions ...
1157(setf (fdefinition '%class-name) #'class-name
1158      (fdefinition '%class-default-initargs) #'class-default-initargs
1159      (fdefinition '%class-direct-default-initargs) #'class-direct-default-initargs
1160      (fdefinition '(setf %class-direct-default-initargs))
1161      #'(lambda (new class)
1162          (if (typep class 'slots-class)
1163            (setf (slot-value class 'direct-default-initargs) new)
1164            new))
1165      (fdefinition '%class-direct-slots) #'class-direct-slots
1166      (fdefinition '(setf %class-direct-slots))
1167                   #'(setf class-direct-slots)
1168      (fdefinition '%class-slots) #'class-slots
1169      (fdefinition '%class-direct-superclasses) #'class-direct-superclasses
1170      (fdefinition '(setf %class-direct-superclasses))
1171      #'(lambda (new class)
1172          (setf (slot-value class 'direct-superclasses) new))
1173      (fdefinition '%class-direct-subclasses) #'class-direct-subclasses
1174      (fdefinition '%class-own-wrapper) #'class-own-wrapper
1175      (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper)
1176)
1177
1178
1179
1180(setf (fdefinition '%slot-definition-name) #'slot-definition-name
1181      (fdefinition '%slot-definition-type) #'slot-definition-type
1182      (fdefinition '%slot-definition-initargs) #'slot-definition-initargs
1183      (fdefinition '%slot-definition-allocation) #'slot-definition-allocation
1184      (fdefinition '%slot-definition-location) #'slot-definition-location
1185      (fdefinition '%slot-definition-readers) #'slot-definition-readers
1186      (fdefinition '%slot-definition-writers) #'slot-definition-writers)
1187
1188
1189(setf (fdefinition '%method-qualifiers) #'method-qualifiers
1190      (fdefinition '%method-specializers) #'method-specializers
1191      (fdefinition '%method-function) #'method-function
1192      (fdefinition '(setf %method-function)) #'(setf method-function)
1193      (fdefinition '%method-gf) #'method-generic-function
1194      (fdefinition '(setf %method-gf)) #'(setf method-generic-function)
1195      (fdefinition '%method-name) #'method-name
1196      (fdefinition '%method-lambda-list) #'method-lambda-list
1197      )
1198                   
1199     
1200;;; Make a direct-slot-definition of the appropriate class.
1201(defun %make-direct-slotd (slotd-class &rest initargs)
1202  (declare (dynamic-extent initargs))
1203  (apply #'make-instance slotd-class initargs))
1204
1205;;; Likewise, for an effective-slot-definition.
1206(defun %make-effective-slotd (slotd-class &rest initargs)
1207  (declare (dynamic-extent initargs))
1208  (apply #'make-instance slotd-class initargs))
1209
1210(defmethod initialize-instance :after ((slotd effective-slot-definition) &key name)
1211  (setf (standard-effective-slot-definition.slot-id slotd)
1212        (ensure-slot-id name)))
1213 
1214(defmethod specializer-direct-generic-functions ((s specializer))
1215  (let* ((gfs ())
1216         (methods (specializer-direct-methods s)))
1217    (dolist (m methods gfs)
1218      (let* ((gf (method-generic-function m)))
1219        (when gf (pushnew gf gfs))))))
1220
1221(defmethod generic-function-lambda-list ((gf standard-generic-function))
1222  (%maybe-compute-gf-lambda-list gf (car (generic-function-methods gf))))
1223
1224(defmethod generic-function-argument-precedence-order
1225    ((gf standard-generic-function))
1226  (let* ((req (required-lambda-list-args (generic-function-lambda-list gf)))
1227         (apo (%gf-dispatch-table-precedence-list
1228               (%gf-dispatch-table gf))))
1229    (if (null apo)
1230      req
1231      (mapcar #'(lambda (n) (nth n req)) apo))))
1232
1233(defun normalize-egf-keys (keys gf)
1234  (let* ((missing (cons nil nil))
1235         (env (getf keys :environment nil)))
1236    (declare (dynamic-extent missing))
1237    (remf keys :environment)
1238    (let* ((gf-class (getf keys :generic-function-class missing))
1239           (mcomb (getf keys :method-combination missing))
1240           (method-class (getf keys :method-class missing)))
1241      (if (eq gf-class missing)
1242        (setf gf-class (if gf (class-of gf) *standard-generic-function-class*))
1243        (progn
1244          (remf keys :generic-function-class)
1245          (if (typep gf-class 'symbol)
1246            (setq gf-class
1247                  (find-class gf-class t env)))
1248          (unless (or (eq gf-class *standard-generic-function-class*)
1249                      (subtypep gf-class *generic-function-class*))
1250            (error "Class ~S is not a subclass of ~S")
1251            gf-class *generic-function-class*)))
1252      (unless (eq mcomb missing)
1253        (unless (typep mcomb 'method-combination)
1254          (setf (getf keys :method-combination)
1255                (find-method-combination (class-prototype gf-class)
1256                                         (car mcomb)
1257                                         (cdr mcomb)))))
1258      (unless (eq method-class missing)
1259        (if (typep method-class 'symbol)
1260          (setq method-class (find-class method-class t env)))
1261        (unless (subtypep method-class *method-class*)
1262          (error "~s is not a subclass of ~s" method-class *method-class*))
1263        (setf (getf keys :method-class) method-class))
1264      (values gf-class keys))))
1265   
1266(defmethod ensure-generic-function-using-class
1267    ((gf null)
1268     function-name
1269     &rest keys
1270     &key
1271     &allow-other-keys)
1272  (declare (dynamic-extent keys))
1273  (multiple-value-bind (gf-class initargs)
1274      (normalize-egf-keys keys nil)
1275    (let* ((gf (apply #'make-instance gf-class
1276                      :name function-name
1277                      initargs)))
1278      (setf (fdefinition function-name) gf))))
1279
1280(defmethod ensure-generic-function-using-class
1281    ((gf generic-function)
1282     function-name
1283     &rest keys
1284     &key
1285     &allow-other-keys)
1286  (declare (dynamic-extent keys) (ignorable function-name))
1287  (multiple-value-bind (gf-class initargs)
1288      (normalize-egf-keys keys gf)
1289    (unless (eq gf-class (class-of gf))
1290      (cerror (format nil "Change the class of ~s to ~s." gf gf-class)
1291              "The class of the existing generic function ~s is not ~s"
1292              gf gf-class))
1293    (apply #'reinitialize-instance gf initargs)))
1294
1295(defmethod initialize-instance :after ((gf standard-generic-function)
1296                                       &key
1297                                       (lambda-list nil ll-p)
1298                                       (argument-precedence-order nil apo-p)
1299                                       &allow-other-keys)
1300  (if (and apo-p (not ll-p))
1301    (error
1302     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1303  (if ll-p
1304    (progn
1305      (unless (verify-lambda-list lambda-list)
1306        (error "~s is not a valid generic function lambda list" lambda-list))
1307      (if apo-p
1308        (set-gf-arg-info gf :lambda-list lambda-list
1309                         :argument-precedence-order argument-precedence-order)
1310        (set-gf-arg-info gf :lambda-list lambda-list)))
1311    (set-gf-arg-info gf))
1312  (if (gf-arg-info-valid-p gf)
1313    (compute-dcode gf (%gf-dispatch-table gf)))
1314  gf)
1315
1316(defmethod reinitialize-instance :after ((gf standard-generic-function)
1317                                         &rest args
1318                                         &key
1319                                         (lambda-list nil ll-p)
1320                                         (argument-precedence-order nil apo-p)
1321                                         &allow-other-keys)
1322  (if (and apo-p (not ll-p))
1323    (error
1324     "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST"))
1325  (if ll-p
1326    (progn
1327      (unless (verify-lambda-list lambda-list)
1328        (error "~s is not a valid generic function lambda list" lambda-list))
1329      (if apo-p
1330        (set-gf-arg-info gf :lambda-list lambda-list
1331                         :argument-precedence-order argument-precedence-order)
1332        (set-gf-arg-info gf :lambda-list lambda-list)))
1333    (set-gf-arg-info gf))
1334  (if (and (gf-arg-info-valid-p gf)
1335           args
1336           (or ll-p (cddr args)))
1337    (compute-dcode gf (%gf-dispatch-table gf)))
1338  (when (sgf.dependents gf)
1339    (map-dependents gf #'(lambda (d)
1340                           (apply #'update-dependent gf d args))))
1341  gf)
1342 
1343
1344(defun decode-method-lambda-list (method-lambda-list)
1345  (flet ((bad ()
1346           (error "Invalid lambda-list syntax in ~s" method-lambda-list)))
1347    (collect ((specnames)
1348                    (required))
1349       (do* ((tail method-lambda-list (cdr tail))
1350             (head (car tail) (car tail)))
1351            ((or (null tail) (member head lambda-list-keywords))
1352             (if (verify-lambda-list tail)
1353               (values (required) tail (specnames))
1354               (bad)))
1355         (cond ((atom head)
1356                (unless (typep head 'symbol) (bad))
1357                (required head)
1358                (specnames t))
1359               (t
1360                (unless (and (typep (car head) 'symbol)
1361                             (consp (cdr head))
1362                             (null (cddr head)))
1363                  (bad))
1364                (required (car head))
1365                (specnames (cadr head))))))))
1366 
1367(defun extract-specializer-names (method-lambda-list)
1368  (nth-value 2 (decode-method-lambda-list method-lambda-list)))
1369
1370(defun extract-lambda-list (method-lambda-list)
1371  (multiple-value-bind (required tail)
1372      (decode-method-lambda-list method-lambda-list)
1373    (nconc required tail)))
1374
1375(setf (fdefinition '%ensure-generic-function-using-class)
1376      #'ensure-generic-function-using-class)
1377
1378(defmethod shared-initialize :after ((gf generic-function) slot-names
1379                                     &key
1380                                     (documentation nil doc-p))
1381  (declare (ignore slot-names))
1382  (when doc-p
1383    (if documentation (check-type documentation string))
1384    (set-documentation gf t documentation)))
1385
1386(defmethod allocate-instance ((b built-in-class) &rest initargs)
1387  (declare (ignore initargs))
1388  (error "Can't allocate instances of BUILT-IN-CLASS."))
1389
1390(defmethod reinitialize-instance ((m method) &rest initargs)
1391  (declare (ignore initargs))
1392  (error "Can't reinitialze ~s ~s" (class-of m) m))
1393
1394(defmethod add-dependent ((class class) dependent)
1395  (pushnew dependent (%class.dependents class)))
1396
1397(defmethod add-dependent ((gf standard-generic-function) dependent)
1398  (pushnew dependent (sgf.dependents gf)))
1399
1400(defmethod remove-dependent ((class class) dependent)
1401  (setf (%class.dependents class)
1402        (delete dependent (%class.dependents class))))
1403
1404(defmethod remove-dependent ((gf standard-generic-function) dependent)
1405  (setf (sgf.dependents gf)
1406        (delete dependent (sgf.dependents gf))))
1407
1408(defmethod map-dependents ((class class) function)
1409  (dolist (d (%class.dependents class))
1410    (funcall function d)))
1411
1412(defmethod map-dependents ((gf standard-generic-function) function)
1413  (dolist (d (sgf.dependents gf))
1414    (funcall function d)))
1415
1416(defgeneric update-dependent (metaobject dependent &rest initargs))
1417
1418(defmethod reinitialize-instance :after ((class std-class) &rest initargs)
1419  (map-dependents class #'(lambda (d)
1420                            (apply #'update-dependent class d initargs))))
1421
1422(defmethod finalize-inheritance ((fwc forward-referenced-class))
1423  (error "~s can't be finalized." fwc))
1424
1425(defun %allocate-gf-instance (class)
1426  (unless (class-finalized-p class)
1427    (finalize-inheritance class))
1428  (let* ((wrapper (%class.own-wrapper class))
1429         (len (length (%wrapper-instance-slots wrapper)))
1430         (dt (make-gf-dispatch-table))
1431         (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))
1432         (fn (gvector :function
1433                      *gf-proto-code*
1434                      wrapper
1435                      slots
1436                      dt
1437                      #'%%0-arg-dcode
1438                      0
1439                      ;; Set the AOK (&allow-other-keys) bit without
1440                      ;; setting the KEYS bit, to indicate that we
1441                      ;; don't know anything about this gf's
1442                      ;; lambda-list.
1443                      (logior (ash 1 $lfbits-gfn-bit)
1444                              (ash 1 $lfbits-aok-bit)))))
1445    (setf (gf.hash fn) (strip-tag-to-fixnum fn)
1446          (slot-vector.instance slots) fn
1447          (%gf-dispatch-table-gf dt) fn)
1448    (push fn (population.data %all-gfs%))
1449    fn))
1450
1451(defmethod slot-value-using-class ((class structure-class)
1452                                   instance
1453                                   (slotd structure-effective-slot-definition))
1454  (let* ((loc (standard-effective-slot-definition.location slotd)))
1455      (typecase loc
1456        (fixnum
1457         (struct-ref  instance loc))
1458        (t
1459         (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1460                slotd loc (slot-definition-allocation slotd))))))
1461
1462;;; Some STRUCTURE-CLASS leftovers.
1463(defmethod (setf slot-value-using-class)
1464    (new
1465     (class structure-class)
1466     instance
1467     (slotd structure-effective-slot-definition))
1468  (let* ((loc (standard-effective-slot-definition.location slotd))
1469         (type (standard-effective-slot-definition.type slotd)))
1470    (if (and type (not (eq type t)))
1471      (unless (or (eq new (%slot-unbound-marker))
1472                  (typep new type))
1473        (setq new (require-type new type))))
1474    (typecase loc
1475      (fixnum
1476       (setf (struct-ref instance loc) new))
1477      (t
1478       (error "Slot definition ~s has invalid location ~s (allocation ~s)."
1479              slotd loc (slot-definition-allocation slotd))))))
1480
1481(defmethod slot-boundp-using-class ((class structure-class)
1482                                    instance
1483                                    (slotd structure-effective-slot-definition))
1484  (declare (ignore instance))
1485  t)
1486
1487;;; This has to be somewhere, so it might as well be here.
1488(defmethod make-load-form ((s slot-id) &optional env)
1489  (declare (ignore env))
1490  `(ensure-slot-id ,(slot-id.name s)))
1491
1492
1493(defmethod (setf class-name) (new (class class))
1494  (reinitialize-instance class :name new)
1495  new)
Note: See TracBrowser for help on using the repository browser.