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

Last change on this file since 10027 was 10027, checked in by gb, 12 years ago

Define *ERROR-ON-GF-CLASS-REDEFINITION*, which controls whether
ENSURE-GENERIC-FUNCTION-USING-CLASS of an existing GF CERRORs
(as it traditionally has) if a :GENERIC-FUNCTION-CLASS argument
specifies a different class.

Defaults to NIL (no CERROR), which doesn't seem to conform to
what the MOP spec says about this, but which some publicly available
code seems to expect. (This is subject to change; signaling an
error here isn't necessarily worse than not doing so, and it really,
really does seem to be what the MOP says; it's arguably better to
adhere to the MOP than to have to remember and explain discrepancies.)

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