source: trunk/abcl/src/org/armedbear/lisp/clos.lisp @ 12756

Last change on this file since 12756 was 12756, checked in by astalla, 13 years ago

Simple slot-* support for structures.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 113.7 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: clos.lisp 12756 2010-06-17 20:14:10Z astalla $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Originally based on Closette.
33
34;;; Closette Version 1.0 (February 10, 1991)
35;;;
36;;; Copyright (c) 1990, 1991 Xerox Corporation.
37;;; All rights reserved.
38;;;
39;;; Use and copying of this software and preparation of derivative works
40;;; based upon this software are permitted.  Any distribution of this
41;;; software or derivative works must comply with all applicable United
42;;; States export control laws.
43;;;
44;;; This software is made available AS IS, and Xerox Corporation makes no
45;;; warranty about the software, its performance or its conformity to any
46;;; specification.
47;;;
48;;; Closette is an implementation of a subset of CLOS with a metaobject
49;;; protocol as described in "The Art of The Metaobject Protocol",
50;;; MIT Press, 1991.
51
52(in-package #:mop)
53
54(export '(class-precedence-list class-slots))
55(defconstant +the-standard-class+ (find-class 'standard-class))
56(defconstant +the-structure-class+ (find-class 'structure-class))
57(defconstant +the-standard-object-class+ (find-class 'standard-object))
58(defconstant +the-standard-method-class+ (find-class 'standard-method))
59(defconstant +the-standard-reader-method-class+
60  (find-class 'standard-reader-method))
61(defconstant +the-standard-generic-function-class+
62  (find-class 'standard-generic-function))
63(defconstant +the-T-class+ (find-class 'T))
64(defconstant +the-slot-definition-class+ (find-class 'slot-definition))
65(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
66(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
67
68;; Don't use DEFVAR, because that disallows loading clos.lisp
69;; after compiling it: the binding won't get assigned to T anymore
70(defparameter *clos-booting* t)
71
72(defmacro define-class->%class-forwarder (name)
73  (let* (($name (if (consp name) (cadr name) name))
74         (%name (intern (concatenate 'string
75                                     "%"
76                                     (if (consp name)
77                                         (symbol-name 'set-) "")
78                                     (symbol-name $name))
79                        (symbol-package $name))))
80    `(progn
81       (declaim (notinline ,name))
82       (defun ,name (&rest args)
83         (apply #',%name args)))))
84
85(define-class->%class-forwarder class-name)
86(define-class->%class-forwarder (setf class-name))
87(define-class->%class-forwarder class-slots)
88(define-class->%class-forwarder (setf class-slots))
89(define-class->%class-forwarder class-direct-slots)
90(define-class->%class-forwarder (setf class-direct-slots))
91(define-class->%class-forwarder class-layout)
92(define-class->%class-forwarder (setf class-layout))
93(define-class->%class-forwarder class-direct-superclasses)
94(define-class->%class-forwarder (setf class-direct-superclasses))
95(define-class->%class-forwarder class-direct-subclasses)
96(define-class->%class-forwarder (setf class-direct-subclasses))
97(define-class->%class-forwarder class-direct-methods)
98(define-class->%class-forwarder (setf class-direct-methods))
99(define-class->%class-forwarder class-precedence-list)
100(define-class->%class-forwarder (setf class-precedence-list))
101(define-class->%class-forwarder class-finalized-p)
102(define-class->%class-forwarder (setf class-finalized-p))
103(define-class->%class-forwarder class-default-initargs)
104(define-class->%class-forwarder (setf class-default-initargs))
105(define-class->%class-forwarder class-direct-default-initargs)
106(define-class->%class-forwarder (setf class-direct-default-initargs))
107
108(defun no-applicable-method (generic-function &rest args)
109  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
110         generic-function
111         args))
112
113
114
115(defmacro push-on-end (value location)
116  `(setf ,location (nconc ,location (list ,value))))
117
118;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
119;;; which must be non-nil.
120
121(defun (setf getf*) (new-value plist key)
122  (block body
123    (do ((x plist (cddr x)))
124        ((null x))
125      (when (eq (car x) key)
126        (setf (car (cdr x)) new-value)
127        (return-from body new-value)))
128    (push-on-end key plist)
129    (push-on-end new-value plist)
130    new-value))
131
132(defun mapappend (fun &rest args)
133  (if (some #'null args)
134      ()
135      (append (apply fun (mapcar #'car args))
136              (apply #'mapappend fun (mapcar #'cdr args)))))
137
138(defun mapplist (fun x)
139  (if (null x)
140      ()
141      (cons (funcall fun (car x) (cadr x))
142            (mapplist fun (cddr x)))))
143
144(defsetf std-instance-layout %set-std-instance-layout)
145(defsetf standard-instance-access %set-standard-instance-access)
146
147(defun (setf find-class) (new-value symbol &optional errorp environment)
148  (declare (ignore errorp environment))
149  (%set-find-class symbol new-value))
150
151(defun canonicalize-direct-slots (direct-slots)
152  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
153
154(defun canonicalize-direct-slot (spec)
155  (if (symbolp spec)
156      `(list :name ',spec)
157      (let ((name (car spec))
158            (initfunction nil)
159            (initform nil)
160            (initargs ())
161            (type nil)
162            (allocation nil)
163            (documentation nil)
164            (readers ())
165            (writers ())
166            (other-options ()))
167        (do ((olist (cdr spec) (cddr olist)))
168            ((null olist))
169          (case (car olist)
170            (:initform
171             (when initform
172               (error 'program-error
173                      "duplicate slot option :INITFORM for slot named ~S"
174                      name))
175             (setq initfunction
176                   `(function (lambda () ,(cadr olist))))
177             (setq initform `',(cadr olist)))
178            (:initarg
179             (push-on-end (cadr olist) initargs))
180            (:allocation
181             (when allocation
182               (error 'program-error
183                      "duplicate slot option :ALLOCATION for slot named ~S"
184                      name))
185             (setf allocation (cadr olist))
186             (push-on-end (car olist) other-options)
187             (push-on-end (cadr olist) other-options))
188            (:type
189             (when type
190               (error 'program-error
191                      "duplicate slot option :TYPE for slot named ~S"
192                      name))
193             (setf type (cadr olist))) ;; FIXME type is ignored
194            (:documentation
195             (when documentation
196               (error 'program-error
197                      "duplicate slot option :DOCUMENTATION for slot named ~S"
198                      name))
199             (setf documentation (cadr olist))) ;; FIXME documentation is ignored
200            (:reader
201             (maybe-note-name-defined (cadr olist))
202             (push-on-end (cadr olist) readers))
203            (:writer
204             (maybe-note-name-defined (cadr olist))
205             (push-on-end (cadr olist) writers))
206            (:accessor
207             (maybe-note-name-defined (cadr olist))
208             (push-on-end (cadr olist) readers)
209             (push-on-end `(setf ,(cadr olist)) writers))
210            (t
211             (error 'program-error
212                    "invalid initialization argument ~S for slot named ~S"
213                    (car olist) name))))
214        `(list
215          :name ',name
216          ,@(when initfunction
217              `(:initform ,initform
218                          :initfunction ,initfunction))
219          ,@(when initargs `(:initargs ',initargs))
220          ,@(when readers `(:readers ',readers))
221          ,@(when writers `(:writers ',writers))
222          ,@other-options))))
223
224(defun maybe-note-name-defined (name)
225  (when (fboundp 'note-name-defined)
226    (note-name-defined name)))
227
228(defun canonicalize-direct-superclasses (direct-superclasses)
229  (let ((classes '()))
230    (dolist (class-specifier direct-superclasses)
231      (if (classp class-specifier)
232          (push class-specifier classes)
233          (let ((class (find-class class-specifier nil)))
234            (unless class
235              (setf class (make-forward-referenced-class class-specifier)))
236            (push class classes))))
237    (nreverse classes)))
238
239(defun canonicalize-defclass-options (options)
240  (mapappend #'canonicalize-defclass-option options))
241
242(defun canonicalize-defclass-option (option)
243  (case (car option)
244    (:metaclass
245     (list ':metaclass
246           `(find-class ',(cadr option))))
247    (:default-initargs
248     (list
249      ':direct-default-initargs
250      `(list ,@(mapappend
251                #'(lambda (x) x)
252                (mapplist
253                 #'(lambda (key value)
254                    `(',key ,(make-initfunction value)))
255                 (cdr option))))))
256    ((:documentation :report)
257     (list (car option) `',(cadr option)))
258    (t (list (car option) `(quote ,(cdr option))))))
259;     (error 'program-error
260;            :format-control "invalid DEFCLASS option ~S"
261;            :format-arguments (list (car option))))))
262
263(defun make-initfunction (initform)
264  `(function (lambda () ,initform)))
265
266(defun slot-definition-allocation (slot-definition)
267  (%slot-definition-allocation slot-definition))
268
269(defun (setf slot-definition-allocation) (value slot-definition)
270  (set-slot-definition-allocation slot-definition value))
271
272(defun slot-definition-initargs (slot-definition)
273  (%slot-definition-initargs slot-definition))
274
275(defun (setf slot-definition-initargs) (value slot-definition)
276  (set-slot-definition-initargs slot-definition value))
277
278(defun slot-definition-initform (slot-definition)
279  (%slot-definition-initform slot-definition))
280
281(defun (setf slot-definition-initform) (value slot-definition)
282  (set-slot-definition-initform slot-definition value))
283
284(defun slot-definition-initfunction (slot-definition)
285  (%slot-definition-initfunction slot-definition))
286
287(defun (setf slot-definition-initfunction) (value slot-definition)
288  (set-slot-definition-initfunction slot-definition value))
289
290(defun slot-definition-name (slot-definition)
291  (%slot-definition-name slot-definition))
292
293(defun (setf slot-definition-name) (value slot-definition)
294  (set-slot-definition-name slot-definition value))
295
296(defun slot-definition-readers (slot-definition)
297  (%slot-definition-readers slot-definition))
298
299(defun (setf slot-definition-readers) (value slot-definition)
300  (set-slot-definition-readers slot-definition value))
301
302(defun slot-definition-writers (slot-definition)
303  (%slot-definition-writers slot-definition))
304
305(defun (setf slot-definition-writers) (value slot-definition)
306  (set-slot-definition-writers slot-definition value))
307
308(defun slot-definition-allocation-class (slot-definition)
309  (%slot-definition-allocation-class slot-definition))
310
311(defun (setf slot-definition-allocation-class) (value slot-definition)
312  (set-slot-definition-allocation-class slot-definition value))
313
314(defun init-slot-definition (slot &key name
315           (initargs ())
316           (initform nil)
317           (initfunction nil)
318           (readers ())
319           (writers ())
320           (allocation :instance)
321           (allocation-class nil)
322           &allow-other-keys)
323  (setf (slot-definition-name slot) name)
324  (setf (slot-definition-initargs slot) initargs)
325  (setf (slot-definition-initform slot) initform)
326  (setf (slot-definition-initfunction slot) initfunction)
327  (setf (slot-definition-readers slot) readers)
328  (setf (slot-definition-writers slot) writers)
329  (setf (slot-definition-allocation slot) allocation)
330  (setf (slot-definition-allocation-class slot) allocation-class)
331  slot)
332
333(defun make-direct-slot-definition (class &rest args)
334  (let ((slot-class (direct-slot-definition-class class)))
335    (if (eq slot-class +the-direct-slot-definition-class+)
336  (let ((slot (make-slot-definition +the-direct-slot-definition-class+)))
337    (apply #'init-slot-definition slot :allocation-class class args)
338    slot)
339  (progn
340    (let ((slot (apply #'make-instance slot-class :allocation-class class
341           args)))
342      slot)))))
343
344(defun make-effective-slot-definition (class &rest args)
345  (let ((slot-class (effective-slot-definition-class class)))
346    (if (eq slot-class +the-effective-slot-definition-class+)
347  (let ((slot (make-slot-definition +the-effective-slot-definition-class+)))
348    (apply #'init-slot-definition slot args)
349    slot)
350  (progn
351    (let ((slot (apply #'make-instance slot-class args)))
352      slot)))))
353
354;;; finalize-inheritance
355
356(defun std-compute-class-default-initargs (class)
357  (mapcan #'(lambda (c)
358              (copy-list
359               (class-direct-default-initargs c)))
360          (class-precedence-list class)))
361
362(defun std-finalize-inheritance (class)
363  (setf (class-precedence-list class)
364   (funcall (if (eq (class-of class) +the-standard-class+)
365                #'std-compute-class-precedence-list
366                #'compute-class-precedence-list)
367            class))
368  (dolist (class (class-precedence-list class))
369    (when (typep class 'forward-referenced-class)
370      (return-from std-finalize-inheritance)))
371  (setf (class-slots class)
372                   (funcall (if (eq (class-of class) +the-standard-class+)
373                                #'std-compute-slots
374                     #'compute-slots) class))
375  (let ((old-layout (class-layout class))
376        (length 0)
377        (instance-slots '())
378        (shared-slots '()))
379    (dolist (slot (class-slots class))
380      (case (slot-definition-allocation slot)
381        (:instance
382         (set-slot-definition-location slot length)
383         (incf length)
384         (push (slot-definition-name slot) instance-slots))
385        (:class
386         (unless (%slot-definition-location slot)
387           (let ((allocation-class (%slot-definition-allocation-class slot)))
388             (set-slot-definition-location slot
389                                           (if (eq allocation-class class)
390                                               (cons (slot-definition-name slot) +slot-unbound+)
391                                               (slot-location allocation-class (slot-definition-name slot))))))
392         (push (%slot-definition-location slot) shared-slots))))
393    (when old-layout
394      ;; Redefined class: initialize added shared slots.
395      (dolist (location shared-slots)
396        (let* ((slot-name (car location))
397               (old-location (layout-slot-location old-layout slot-name)))
398          (unless old-location
399            (let* ((slot-definition (find slot-name (class-slots class) :key #'slot-definition-name))
400                   (initfunction (slot-definition-initfunction slot-definition)))
401              (when initfunction
402                (setf (cdr location) (funcall initfunction))))))))
403    (setf (class-layout class)
404          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
405  (setf (class-default-initargs class)
406        (std-compute-class-default-initargs class))
407  (setf (class-finalized-p class) t))
408
409;;; Class precedence lists
410
411(defun std-compute-class-precedence-list (class)
412  (let ((classes-to-order (collect-superclasses* class)))
413    (topological-sort classes-to-order
414                      (remove-duplicates
415                       (mapappend #'local-precedence-ordering
416                                  classes-to-order))
417                      #'std-tie-breaker-rule)))
418
419;;; topological-sort implements the standard algorithm for topologically
420;;; sorting an arbitrary set of elements while honoring the precedence
421;;; constraints given by a set of (X,Y) pairs that indicate that element
422;;; X must precede element Y.  The tie-breaker procedure is called when it
423;;; is necessary to choose from multiple minimal elements; both a list of
424;;; candidates and the ordering so far are provided as arguments.
425
426(defun topological-sort (elements constraints tie-breaker)
427  (let ((remaining-constraints constraints)
428        (remaining-elements elements)
429        (result ()))
430    (loop
431      (let ((minimal-elements
432             (remove-if
433              #'(lambda (class)
434                 (member class remaining-constraints
435                         :key #'cadr))
436              remaining-elements)))
437        (when (null minimal-elements)
438          (if (null remaining-elements)
439              (return-from topological-sort result)
440              (error "Inconsistent precedence graph.")))
441        (let ((choice (if (null (cdr minimal-elements))
442                          (car minimal-elements)
443                          (funcall tie-breaker
444                                   minimal-elements
445                                   result))))
446          (setq result (append result (list choice)))
447          (setq remaining-elements
448                (remove choice remaining-elements))
449          (setq remaining-constraints
450                (remove choice
451                        remaining-constraints
452                        :test #'member)))))))
453
454;;; In the event of a tie while topologically sorting class precedence lists,
455;;; the CLOS Specification says to "select the one that has a direct subclass
456;;; rightmost in the class precedence list computed so far."  The same result
457;;; is obtained by inspecting the partially constructed class precedence list
458;;; from right to left, looking for the first minimal element to show up among
459;;; the direct superclasses of the class precedence list constituent.
460;;; (There's a lemma that shows that this rule yields a unique result.)
461
462(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
463  (dolist (cpl-constituent (reverse cpl-so-far))
464    (let* ((supers (class-direct-superclasses cpl-constituent))
465           (common (intersection minimal-elements supers)))
466      (when (not (null common))
467        (return-from std-tie-breaker-rule (car common))))))
468
469;;; This version of collect-superclasses* isn't bothered by cycles in the class
470;;; hierarchy, which sometimes happen by accident.
471
472(defun collect-superclasses* (class)
473  (labels ((all-superclasses-loop (seen superclasses)
474                                  (let ((to-be-processed
475                                         (set-difference superclasses seen)))
476                                    (if (null to-be-processed)
477                                        superclasses
478                                        (let ((class-to-process
479                                               (car to-be-processed)))
480                                          (all-superclasses-loop
481                                           (cons class-to-process seen)
482                                           (union (class-direct-superclasses
483                                                   class-to-process)
484                                                  superclasses)))))))
485          (all-superclasses-loop () (list class))))
486
487;;; The local precedence ordering of a class C with direct superclasses C_1,
488;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
489
490(defun local-precedence-ordering (class)
491  (mapcar #'list
492          (cons class
493                (butlast (class-direct-superclasses class)))
494          (class-direct-superclasses class)))
495
496;;; Slot inheritance
497
498(defun std-compute-slots (class)
499  (let* ((all-slots (mapappend #'class-direct-slots
500                               (class-precedence-list class)))
501         (all-names (remove-duplicates
502                     (mapcar #'slot-definition-name all-slots))))
503    (mapcar #'(lambda (name)
504               (funcall
505                (if (eq (class-of class) +the-standard-class+)
506                    #'std-compute-effective-slot-definition
507                    #'compute-effective-slot-definition)
508                class
509                (remove name all-slots
510                        :key #'slot-definition-name
511                        :test-not #'eq)))
512            all-names)))
513
514(defun std-compute-effective-slot-definition (class direct-slots)
515  (let ((initer (find-if-not #'null direct-slots
516                             :key #'slot-definition-initfunction)))
517    (make-effective-slot-definition
518     class
519     :name (slot-definition-name (car direct-slots))
520     :initform (if initer
521                   (slot-definition-initform initer)
522                   nil)
523     :initfunction (if initer
524                       (slot-definition-initfunction initer)
525                       nil)
526     :initargs (remove-duplicates
527                (mapappend #'slot-definition-initargs
528                           direct-slots))
529     :allocation (slot-definition-allocation (car direct-slots))
530     :allocation-class (%slot-definition-allocation-class (car direct-slots)))))
531
532;;; Standard instance slot access
533
534;;; N.B. The location of the effective-slots slots in the class metaobject for
535;;; standard-class must be determined without making any further slot
536;;; references.
537
538(defun find-slot-definition (class slot-name)
539  (dolist (slot (class-slots class) nil)
540    (when (eq slot-name (slot-definition-name slot))
541      (return slot))))
542
543(defun slot-location (class slot-name)
544  (let ((slot (find-slot-definition class slot-name)))
545    (if slot
546        (%slot-definition-location slot)
547        nil)))
548
549(defun instance-slot-location (instance slot-name)
550  (let ((layout (std-instance-layout instance)))
551    (and layout (layout-slot-location layout slot-name))))
552
553(defun slot-value (object slot-name)
554  (if (or (eq (class-of (class-of object)) +the-standard-class+)
555    (eq (class-of (class-of object)) +the-structure-class+))
556      (std-slot-value object slot-name)
557      (slot-value-using-class (class-of object) object slot-name)))
558
559(defsetf std-slot-value set-std-slot-value)
560
561(defun %set-slot-value (object slot-name new-value)
562  (if (or (eq (class-of (class-of object)) +the-standard-class+)
563    (eq (class-of (class-of object)) +the-structure-class+))
564      (setf (std-slot-value object slot-name) new-value)
565      (set-slot-value-using-class new-value (class-of object)
566                                  object slot-name)))
567
568(defsetf slot-value %set-slot-value)
569
570(defun slot-boundp (object slot-name)
571  (if (eq (class-of (class-of object)) +the-standard-class+)
572      (std-slot-boundp object slot-name)
573      (slot-boundp-using-class (class-of object) object slot-name)))
574
575(defun std-slot-makunbound (instance slot-name)
576  (let ((location (instance-slot-location instance slot-name)))
577    (cond ((fixnump location)
578           (setf (standard-instance-access instance location) +slot-unbound+))
579          ((consp location)
580           (setf (cdr location) +slot-unbound+))
581          (t
582           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
583  instance)
584
585(defun slot-makunbound (object slot-name)
586  (if (eq (class-of (class-of object)) +the-standard-class+)
587      (std-slot-makunbound object slot-name)
588      (slot-makunbound-using-class (class-of object) object slot-name)))
589
590(defun std-slot-exists-p (instance slot-name)
591  (not (null (find slot-name (class-slots (class-of instance))
592                   :key #'slot-definition-name))))
593
594(defun slot-exists-p (object slot-name)
595  (if (eq (class-of (class-of object)) +the-standard-class+)
596      (std-slot-exists-p object slot-name)
597      (slot-exists-p-using-class (class-of object) object slot-name)))
598
599(defun instance-slot-p (slot)
600  (eq (slot-definition-allocation slot) :instance))
601
602(defun make-instance-standard-class (metaclass
603             &rest initargs
604                                     &key name direct-superclasses direct-slots
605                                     direct-default-initargs
606                                     documentation)
607  (declare (ignore metaclass))
608  (let ((class (std-allocate-instance +the-standard-class+)))
609    (check-initargs class t initargs)
610    (%set-class-name name class)
611    (%set-class-layout nil class)
612    (%set-class-direct-subclasses ()  class)
613    (%set-class-direct-methods ()  class)
614    (%set-class-documentation class documentation)
615    (std-after-initialization-for-classes class
616                                          :direct-superclasses direct-superclasses
617                                          :direct-slots direct-slots
618                                          :direct-default-initargs direct-default-initargs)
619    class))
620
621;(defun convert-to-direct-slot-definition (class canonicalized-slot)
622;  (apply #'make-instance
623;         (apply #'direct-slot-definition-class
624;                class canonicalized-slot)
625;         canonicalized-slot))
626
627(defun std-after-initialization-for-classes (class
628                                             &key direct-superclasses direct-slots
629                                             direct-default-initargs
630                                             &allow-other-keys)
631  (let ((supers (or direct-superclasses
632                    (list +the-standard-object-class+))))
633    (setf (class-direct-superclasses class) supers)
634    (dolist (superclass supers)
635      (pushnew class (class-direct-subclasses superclass))))
636  (let ((slots (mapcar #'(lambda (slot-properties)
637                          (apply #'make-direct-slot-definition class slot-properties))
638                       direct-slots)))
639    (setf (class-direct-slots class) slots)
640    (dolist (direct-slot slots)
641      (dolist (reader (%slot-definition-readers direct-slot))
642        (add-reader-method class reader (slot-definition-name direct-slot)))
643      (dolist (writer (%slot-definition-writers direct-slot))
644        (add-writer-method class writer (slot-definition-name direct-slot)))))
645  (setf (class-direct-default-initargs class) direct-default-initargs)
646  (funcall (if (eq (class-of class) +the-standard-class+)
647               #'std-finalize-inheritance
648               #'finalize-inheritance)
649           class)
650  (values))
651
652(defun canonical-slot-name (canonical-slot)
653  (getf canonical-slot :name))
654
655(defvar *extensible-built-in-classes*
656  (list (find-class 'sequence)
657        (find-class 'java:java-object)))
658
659(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
660  ;; Check for duplicate slots.
661  (remf all-keys :metaclass)
662  (let ((slots (getf all-keys :direct-slots)))
663    (dolist (s1 slots)
664      (let ((name1 (canonical-slot-name s1)))
665        (dolist (s2 (cdr (memq s1 slots)))
666          (when (eq name1 (canonical-slot-name s2))
667            (error 'program-error "Duplicate slot ~S" name1))))))
668  ;; Check for duplicate argument names in :DEFAULT-INITARGS.
669  (let ((names ()))
670    (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
671          (name (car initargs) (car initargs)))
672         ((null initargs))
673      (push name names))
674    (do* ((names names (cdr names))
675          (name (car names) (car names)))
676         ((null names))
677      (when (memq name (cdr names))
678        (error 'program-error
679               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
680               :format-arguments (list name)))))
681  (let ((direct-superclasses (getf all-keys :direct-superclasses)))
682    (dolist (class direct-superclasses)
683      (when (and (typep class 'built-in-class)
684     (not (member class *extensible-built-in-classes*)))
685        (error "Attempt to define a subclass of a built-in-class: ~S" class))))
686  (let ((old-class (find-class name nil)))
687    (cond ((and old-class (eq name (class-name old-class)))
688           (cond ((typep old-class 'built-in-class)
689                  (error "The symbol ~S names a built-in class." name))
690                 ((typep old-class 'forward-referenced-class)
691                  (let ((new-class (apply #'make-instance-standard-class
692                                          +the-standard-class+
693                                          :name name all-keys)))
694                    (%set-find-class name new-class)
695                    (dolist (subclass (class-direct-subclasses old-class))
696                      (setf (class-direct-superclasses subclass)
697                            (substitute new-class old-class
698                                        (class-direct-superclasses subclass))))
699                    new-class))
700                 (t
701                  ;; We're redefining the class.
702                  (%make-instances-obsolete old-class)
703      (check-initargs old-class t all-keys)
704                  (apply #'std-after-initialization-for-classes old-class all-keys)
705                  old-class)))
706          (t
707           (let ((class (apply (if metaclass
708                                   #'make-instance
709                                   #'make-instance-standard-class)
710                               (or metaclass
711                                   +the-standard-class+)
712                               :name name all-keys)))
713             (%set-find-class name class)
714             class)))))
715
716(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
717  (unless (>= (length form) 3)
718    (error 'program-error "Wrong number of arguments for DEFCLASS."))
719  (check-declaration-type name)
720  `(ensure-class ',name
721                 :direct-superclasses
722                 (canonicalize-direct-superclasses ',direct-superclasses)
723                 :direct-slots
724                 ,(canonicalize-direct-slots direct-slots)
725                 ,@(canonicalize-defclass-options options)))
726
727(eval-when (:compile-toplevel :load-toplevel :execute)
728  (defstruct method-combination
729    name
730    operator
731    identity-with-one-argument
732    documentation)
733
734  (defun expand-short-defcombin (whole)
735    (let* ((name (cadr whole))
736           (documentation
737            (getf (cddr whole) :documentation ""))
738           (identity-with-one-arg
739            (getf (cddr whole) :identity-with-one-argument nil))
740           (operator
741            (getf (cddr whole) :operator name)))
742      `(progn
743         (setf (get ',name 'method-combination-object)
744               (make-method-combination :name ',name
745                                        :operator ',operator
746                                        :identity-with-one-argument ',identity-with-one-arg
747                                        :documentation ',documentation))
748         ',name)))
749
750  (defun expand-long-defcombin (whole)
751    (declare (ignore whole))
752    (error "The long form of DEFINE-METHOD-COMBINATION is not implemented.")))
753
754(defmacro define-method-combination (&whole form &rest args)
755  (declare (ignore args))
756  (if (and (cddr form)
757           (listp (caddr form)))
758      (expand-long-defcombin form)
759      (expand-short-defcombin form)))
760
761(define-method-combination +      :identity-with-one-argument t)
762(define-method-combination and    :identity-with-one-argument t)
763(define-method-combination append :identity-with-one-argument nil)
764(define-method-combination list   :identity-with-one-argument nil)
765(define-method-combination max    :identity-with-one-argument t)
766(define-method-combination min    :identity-with-one-argument t)
767(define-method-combination nconc  :identity-with-one-argument t)
768(define-method-combination or     :identity-with-one-argument t)
769(define-method-combination progn  :identity-with-one-argument t)
770
771(defstruct eql-specializer
772  object)
773
774(defparameter *eql-specializer-table* (make-hash-table :test 'eql))
775
776(defun intern-eql-specializer (object)
777  (or (gethash object *eql-specializer-table*)
778      (setf (gethash object *eql-specializer-table*)
779            (make-eql-specializer :object object))))
780
781;; MOP (p. 216) specifies the following reader generic functions:
782;;   generic-function-argument-precedence-order
783;;   generic-function-declarations
784;;   generic-function-lambda-list
785;;   generic-function-method-class
786;;   generic-function-method-combination
787;;   generic-function-methods
788;;   generic-function-name
789
790(defun generic-function-lambda-list (gf)
791  (%generic-function-lambda-list gf))
792(defsetf generic-function-lambda-list %set-generic-function-lambda-list)
793
794(defun (setf generic-function-documentation) (new-value gf)
795  (set-generic-function-documentation gf new-value))
796
797(defun (setf generic-function-initial-methods) (new-value gf)
798  (set-generic-function-initial-methods gf new-value))
799
800(defun (setf generic-function-methods) (new-value gf)
801  (set-generic-function-methods gf new-value))
802
803(defun (setf generic-function-method-class) (new-value gf)
804  (set-generic-function-method-class gf new-value))
805
806(defun (setf generic-function-method-combination) (new-value gf)
807  (set-generic-function-method-combination gf new-value))
808
809(defun (setf generic-function-argument-precedence-order) (new-value gf)
810  (set-generic-function-argument-precedence-order gf new-value))
811
812(declaim (ftype (function * t) classes-to-emf-table))
813(defun classes-to-emf-table (gf)
814  (generic-function-classes-to-emf-table gf))
815
816(defun (setf classes-to-emf-table) (new-value gf)
817  (set-generic-function-classes-to-emf-table gf new-value))
818
819(defun (setf method-lambda-list) (new-value method)
820  (set-method-lambda-list method new-value))
821
822(defun (setf method-qualifiers) (new-value method)
823  (set-method-qualifiers method new-value))
824
825(defun (setf method-documentation) (new-value method)
826  (set-method-documentation method new-value))
827
828;;; defgeneric
829
830(defmacro defgeneric (function-name lambda-list
831                                    &rest options-and-method-descriptions)
832  (let ((options ())
833        (methods ())
834        (documentation nil))
835    (dolist (item options-and-method-descriptions)
836      (case (car item)
837        (declare) ; FIXME
838        (:documentation
839         (when documentation
840           (error 'program-error
841                  :format-control "Documentation option was specified twice for generic function ~S."
842                  :format-arguments (list function-name)))
843         (setf documentation t)
844         (push item options))
845        (:method
846         (push
847          `(push (defmethod ,function-name ,@(cdr item))
848                 (generic-function-initial-methods (fdefinition ',function-name)))
849          methods))
850        (t
851         (push item options))))
852    (setf options (nreverse options)
853          methods (nreverse methods))
854    `(prog1
855       (%defgeneric
856        ',function-name
857        :lambda-list ',lambda-list
858        ,@(canonicalize-defgeneric-options options))
859       ,@methods)))
860
861(defun canonicalize-defgeneric-options (options)
862  (mapappend #'canonicalize-defgeneric-option options))
863
864(defun canonicalize-defgeneric-option (option)
865  (case (car option)
866    (:generic-function-class
867     (list :generic-function-class `(find-class ',(cadr option))))
868    (:method-class
869     (list :method-class `(find-class ',(cadr option))))
870    (:method-combination
871     (list :method-combination `',(cdr option)))
872    (:argument-precedence-order
873     (list :argument-precedence-order `',(cdr option)))
874    (t
875     (list `',(car option) `',(cadr option)))))
876
877;; From OpenMCL.
878(defun canonicalize-argument-precedence-order (apo req)
879  (cond ((equal apo req) nil)
880        ((not (eql (length apo) (length req)))
881         (error 'program-error
882                :format-control "Specified argument precedence order ~S does not match lambda list."
883                :format-arguments (list apo)))
884        (t (let ((res nil))
885             (dolist (arg apo (nreverse res))
886               (let ((index (position arg req)))
887                 (if (or (null index) (memq index res))
888                     (error 'program-error
889                            :format-control "Specified argument precedence order ~S does not match lambda list."
890                            :format-arguments (list apo)))
891                 (push index res)))))))
892
893(defun find-generic-function (name &optional (errorp t))
894  (let ((function (and (fboundp name) (fdefinition name))))
895    (when function
896      (when (typep function 'generic-function)
897        (return-from find-generic-function function))
898      (when (and *traced-names* (find name *traced-names* :test #'equal))
899        (setf function (untraced-function name))
900        (when (typep function 'generic-function)
901          (return-from find-generic-function function)))))
902  (if errorp
903      (error "There is no generic function named ~S." name)
904      nil))
905
906(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
907  (let* ((plist1 (analyze-lambda-list lambda-list1))
908         (args1 (getf plist1 :required-args))
909         (plist2 (analyze-lambda-list lambda-list2))
910         (args2 (getf plist2 :required-args)))
911    (= (length args1) (length args2))))
912
913(defun %defgeneric (function-name &rest all-keys)
914  (when (fboundp function-name)
915    (let ((gf (fdefinition function-name)))
916      (when (typep gf 'generic-function)
917        ;; Remove methods defined by previous DEFGENERIC forms.
918        (dolist (method (generic-function-initial-methods gf))
919          (%remove-method gf method))
920        (setf (generic-function-initial-methods gf) '()))))
921  (apply 'ensure-generic-function function-name all-keys))
922
923(defun ensure-generic-function (function-name
924                                &rest all-keys
925                                &key
926                                lambda-list
927                                (generic-function-class +the-standard-generic-function-class+)
928                                (method-class +the-standard-method-class+)
929                                (method-combination 'standard)
930                                (argument-precedence-order nil apo-p)
931                                documentation
932                                &allow-other-keys)
933  (when (autoloadp function-name)
934    (resolve function-name))
935  (let ((gf (find-generic-function function-name nil)))
936    (if gf
937        (progn
938          (unless (or (null (generic-function-methods gf))
939                      (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf)))
940            (error 'simple-error
941                   :format-control "The lambda list ~S is incompatible with the existing methods of ~S."
942                   :format-arguments (list lambda-list gf)))
943          (setf (generic-function-lambda-list gf) lambda-list)
944          (setf (generic-function-documentation gf) documentation)
945          (let* ((plist (analyze-lambda-list lambda-list))
946                 (required-args (getf plist ':required-args)))
947            (%set-gf-required-args gf required-args)
948            (when apo-p
949              (setf (generic-function-argument-precedence-order gf)
950                    (if argument-precedence-order
951                        (canonicalize-argument-precedence-order argument-precedence-order
952                                                                required-args)
953                        nil)))
954            (finalize-generic-function gf))
955          gf)
956        (progn
957          (when (and (null *clos-booting*)
958                     (fboundp function-name))
959            (error 'program-error
960                   :format-control "~A already names an ordinary function, macro, or special operator."
961                   :format-arguments (list function-name)))
962          (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
963                              #'make-instance-standard-generic-function
964                              #'make-instance)
965                          generic-function-class
966                          :name function-name
967                          :method-class method-class
968                          :method-combination method-combination
969                          all-keys))
970          gf))))
971
972(defun initial-discriminating-function (gf args)
973  (set-funcallable-instance-function
974   gf
975   (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
976                #'std-compute-discriminating-function
977                #'compute-discriminating-function)
978            gf))
979  (apply gf args))
980
981(defun collect-eql-specializer-objects (generic-function)
982  (let ((result nil))
983    (dolist (method (generic-function-methods generic-function))
984      (dolist (specializer (%method-specializers method))
985        (when (typep specializer 'eql-specializer)
986          (pushnew (eql-specializer-object specializer)
987                   result
988                   :test 'eql))))
989    result))
990
991(defun finalize-generic-function (gf)
992  (%finalize-generic-function gf)
993  (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
994  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
995  (set-funcallable-instance-function
996   gf #'(lambda (&rest args)
997          (initial-discriminating-function gf args)))
998  ;; FIXME Do we need to warn on redefinition somewhere else?
999  (let ((*warn-on-redefinition* nil))
1000    (setf (fdefinition (%generic-function-name gf)) gf))
1001  (values))
1002
1003(defun make-instance-standard-generic-function (generic-function-class
1004                                                &key name lambda-list
1005                                                method-class
1006                                                method-combination
1007                                                argument-precedence-order
1008                                                documentation)
1009  (declare (ignore generic-function-class))
1010  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
1011    (%set-generic-function-name gf name)
1012    (setf (generic-function-lambda-list gf) lambda-list)
1013    (setf (generic-function-initial-methods gf) ())
1014    (setf (generic-function-methods gf) ())
1015    (setf (generic-function-method-class gf) method-class)
1016    (setf (generic-function-method-combination gf) method-combination)
1017    (setf (generic-function-documentation gf) documentation)
1018    (setf (classes-to-emf-table gf) nil)
1019    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
1020           (required-args (getf plist ':required-args)))
1021      (%set-gf-required-args gf required-args)
1022      (setf (generic-function-argument-precedence-order gf)
1023            (if argument-precedence-order
1024                (canonicalize-argument-precedence-order argument-precedence-order
1025                                                        required-args)
1026                nil)))
1027    (finalize-generic-function gf)
1028    gf))
1029
1030(defun canonicalize-specializers (specializers)
1031  (mapcar #'canonicalize-specializer specializers))
1032
1033(defun canonicalize-specializer (specializer)
1034  (cond ((classp specializer)
1035         specializer)
1036        ((eql-specializer-p specializer)
1037         specializer)
1038        ((symbolp specializer)
1039         (find-class specializer))
1040        ((and (consp specializer)
1041              (eq (car specializer) 'eql))
1042         (let ((object (cadr specializer)))
1043           (when (and (consp object)
1044                      (eq (car object) 'quote))
1045             (setf object (cadr object)))
1046           (intern-eql-specializer object)))
1047  ((and (consp specializer)
1048              (eq (car specializer) 'java:jclass))
1049         (let ((jclass (eval specializer)))
1050     (java::ensure-java-class jclass)))
1051        (t
1052         (error "Unknown specializer: ~S" specializer))))
1053
1054(defun parse-defmethod (args)
1055  (let ((function-name (car args))
1056        (qualifiers ())
1057        (specialized-lambda-list ())
1058        (body ())
1059        (parse-state :qualifiers))
1060    (dolist (arg (cdr args))
1061      (ecase parse-state
1062        (:qualifiers
1063         (if (and (atom arg) (not (null arg)))
1064             (push arg qualifiers)
1065             (progn
1066               (setf specialized-lambda-list arg)
1067               (setf parse-state :body))))
1068        (:body (push arg body))))
1069    (setf qualifiers (nreverse qualifiers)
1070          body (nreverse body))
1071    (multiple-value-bind (real-body declarations documentation)
1072        (parse-body body)
1073      (values function-name
1074              qualifiers
1075              (extract-lambda-list specialized-lambda-list)
1076              (extract-specializers specialized-lambda-list)
1077              documentation
1078              declarations
1079              (list* 'block
1080                     (fdefinition-block-name function-name)
1081                     real-body)))))
1082
1083(defun required-portion (gf args)
1084  (let ((number-required (length (gf-required-args gf))))
1085    (when (< (length args) number-required)
1086      (error 'program-error
1087             :format-control "Not enough arguments for generic function ~S."
1088             :format-arguments (list (%generic-function-name gf))))
1089    (subseq args 0 number-required)))
1090
1091(defun extract-lambda-list (specialized-lambda-list)
1092  (let* ((plist (analyze-lambda-list specialized-lambda-list))
1093         (requireds (getf plist :required-names))
1094         (rv (getf plist :rest-var))
1095         (ks (getf plist :key-args))
1096         (keysp (getf plist :keysp))
1097         (aok (getf plist :allow-other-keys))
1098         (opts (getf plist :optional-args))
1099         (auxs (getf plist :auxiliary-args)))
1100    `(,@requireds
1101      ,@(if rv `(&rest ,rv) ())
1102      ,@(if (or ks keysp aok) `(&key ,@ks) ())
1103      ,@(if aok '(&allow-other-keys) ())
1104      ,@(if opts `(&optional ,@opts) ())
1105      ,@(if auxs `(&aux ,@auxs) ()))))
1106
1107(defun extract-specializers (specialized-lambda-list)
1108  (let ((plist (analyze-lambda-list specialized-lambda-list)))
1109    (getf plist ':specializers)))
1110
1111(defun get-keyword-from-arg (arg)
1112  (if (listp arg)
1113      (if (listp (car arg))
1114          (caar arg)
1115          (make-keyword (car arg)))
1116      (make-keyword arg)))
1117
1118(defun analyze-lambda-list (lambda-list)
1119  (let ((keys ())           ; Just the keywords
1120        (key-args ())       ; Keywords argument specs
1121        (keysp nil)         ;
1122        (required-names ()) ; Just the variable names
1123        (required-args ())  ; Variable names & specializers
1124        (specializers ())   ; Just the specializers
1125        (rest-var nil)
1126        (optionals ())
1127        (auxs ())
1128        (allow-other-keys nil)
1129        (state :parsing-required))
1130    (dolist (arg lambda-list)
1131      (if (member arg lambda-list-keywords)
1132          (ecase arg
1133            (&optional
1134             (setq state :parsing-optional))
1135            (&rest
1136             (setq state :parsing-rest))
1137            (&key
1138             (setq keysp t)
1139             (setq state :parsing-key))
1140            (&allow-other-keys
1141             (setq allow-other-keys 't))
1142            (&aux
1143             (setq state :parsing-aux)))
1144          (case state
1145            (:parsing-required
1146             (push-on-end arg required-args)
1147             (if (listp arg)
1148                 (progn (push-on-end (car arg) required-names)
1149                   (push-on-end (cadr arg) specializers))
1150                 (progn (push-on-end arg required-names)
1151                   (push-on-end 't specializers))))
1152            (:parsing-optional (push-on-end arg optionals))
1153            (:parsing-rest (setq rest-var arg))
1154            (:parsing-key
1155             (push-on-end (get-keyword-from-arg arg) keys)
1156             (push-on-end arg key-args))
1157            (:parsing-aux (push-on-end arg auxs)))))
1158    (list  :required-names required-names
1159           :required-args required-args
1160           :specializers specializers
1161           :rest-var rest-var
1162           :keywords keys
1163           :key-args key-args
1164           :keysp keysp
1165           :auxiliary-args auxs
1166           :optional-args optionals
1167           :allow-other-keys allow-other-keys)))
1168
1169#+nil
1170(defun check-method-arg-info (gf arg-info method)
1171  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1172      (analyze-lambda-list (if (consp method)
1173                               (early-method-lambda-list method)
1174                               (method-lambda-list method)))
1175    (flet ((lose (string &rest args)
1176                 (error 'simple-program-error
1177                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
1178                        to the generic function~2I~_~S;~I~_~
1179                        but ~?~:>"
1180                        :format-arguments (list method gf string args)))
1181           (comparison-description (x y)
1182                                   (if (> x y) "more" "fewer")))
1183      (let ((gf-nreq (arg-info-number-required arg-info))
1184            (gf-nopt (arg-info-number-optional arg-info))
1185            (gf-key/rest-p (arg-info-key/rest-p arg-info))
1186            (gf-keywords (arg-info-keys arg-info)))
1187        (unless (= nreq gf-nreq)
1188          (lose
1189           "the method has ~A required arguments than the generic function."
1190           (comparison-description nreq gf-nreq)))
1191        (unless (= nopt gf-nopt)
1192          (lose
1193           "the method has ~A optional arguments than the generic function."
1194           (comparison-description nopt gf-nopt)))
1195        (unless (eq (or keysp restp) gf-key/rest-p)
1196          (lose
1197           "the method and generic function differ in whether they accept~_~
1198            &REST or &KEY arguments."))
1199        (when (consp gf-keywords)
1200          (unless (or (and restp (not keysp))
1201                      allow-other-keys-p
1202                      (every (lambda (k) (memq k keywords)) gf-keywords))
1203            (lose "the method does not accept each of the &KEY arguments~2I~_~
1204            ~S."
1205                  gf-keywords)))))))
1206
1207(defun check-method-lambda-list (method-lambda-list gf-lambda-list)
1208  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
1209         (gf-plist (analyze-lambda-list gf-lambda-list))
1210         (gf-keysp (getf gf-plist :keysp))
1211         (gf-keywords (getf gf-plist :keywords))
1212         (method-plist (analyze-lambda-list method-lambda-list))
1213         (method-restp (not (null (memq '&rest method-lambda-list))))
1214         (method-keysp (getf method-plist :keysp))
1215         (method-keywords (getf method-plist :keywords))
1216         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1217    (unless (= (length (getf gf-plist :required-args))
1218               (length (getf method-plist :required-args)))
1219      (error "The method has the wrong number of required arguments for the generic function."))
1220    (unless (= (length (getf gf-plist :optional-args))
1221               (length (getf method-plist :optional-args)))
1222      (error "The method has the wrong number of optional arguments for the generic function."))
1223    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1224      (error "The method and the generic function differ in whether they accept &REST or &KEY arguments."))
1225    (when (consp gf-keywords)
1226      (unless (or (and method-restp (not method-keysp))
1227                  method-allow-other-keys-p
1228                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
1229        (error "The method does not accept all of the keyword arguments defined for the generic function.")))))
1230
1231(declaim (ftype (function * method) ensure-method))
1232(defun ensure-method (name &rest all-keys)
1233  (let ((method-lambda-list (getf all-keys :lambda-list))
1234        (gf (find-generic-function name nil)))
1235    (if gf
1236        (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf))
1237        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
1238    (let ((method
1239           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
1240               (apply #'make-instance-standard-method gf all-keys)
1241               (apply #'make-instance (generic-function-method-class gf) all-keys))))
1242      (%add-method gf method)
1243      method)))
1244
1245(defun make-instance-standard-method (gf
1246                                      &key
1247                                      lambda-list
1248                                      qualifiers
1249                                      specializers
1250                                      documentation
1251                                      function
1252                                      fast-function)
1253  (declare (ignore gf))
1254  (let ((method (std-allocate-instance +the-standard-method-class+)))
1255    (setf (method-lambda-list method) lambda-list)
1256    (setf (method-qualifiers method) qualifiers)
1257    (%set-method-specializers method (canonicalize-specializers specializers))
1258    (setf (method-documentation method) documentation)
1259    (%set-method-generic-function method nil)
1260    (%set-method-function method function)
1261    (%set-method-fast-function method fast-function)
1262    method))
1263
1264(defun %add-method (gf method)
1265  (when (%method-generic-function method)
1266    (error 'simple-error
1267           :format-control "ADD-METHOD: ~S is a method of ~S."
1268           :format-arguments (list method (%method-generic-function method))))
1269  ;; Remove existing method with same qualifiers and specializers (if any).
1270  (let ((old-method (%find-method gf (method-qualifiers method)
1271                                 (%method-specializers method) nil)))
1272    (when old-method
1273      (%remove-method gf old-method)))
1274  (%set-method-generic-function method gf)
1275  (push method (generic-function-methods gf))
1276  (dolist (specializer (%method-specializers method))
1277    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1278      (pushnew method (class-direct-methods specializer))))
1279  (finalize-generic-function gf)
1280  gf)
1281
1282(defun %remove-method (gf method)
1283  (setf (generic-function-methods gf)
1284        (remove method (generic-function-methods gf)))
1285  (%set-method-generic-function method nil)
1286  (dolist (specializer (%method-specializers method))
1287    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1288      (setf (class-direct-methods specializer)
1289            (remove method (class-direct-methods specializer)))))
1290  (finalize-generic-function gf)
1291  gf)
1292
1293(defun %find-method (gf qualifiers specializers &optional (errorp t))
1294  ;; "If the specializers argument does not correspond in length to the number
1295  ;; of required arguments of the generic-function, an an error of type ERROR
1296  ;; is signaled."
1297  (unless (= (length specializers) (length (gf-required-args gf)))
1298    (error "The specializers argument has length ~S, but ~S has ~S required parameters."
1299           (length specializers)
1300           gf
1301           (length (gf-required-args gf))))
1302  (let* ((canonical-specializers (canonicalize-specializers specializers))
1303         (method
1304          (find-if #'(lambda (method)
1305                      (and (equal qualifiers
1306                                  (method-qualifiers method))
1307                           (equal canonical-specializers
1308                                  (%method-specializers method))))
1309                   (generic-function-methods gf))))
1310    (if (and (null method) errorp)
1311        (error "No such method for ~S." (%generic-function-name gf))
1312        method)))
1313
1314(defun fast-callable-p (gf)
1315  (and (eq (generic-function-method-combination gf) 'standard)
1316       (null (intersection (%generic-function-lambda-list gf)
1317                           '(&rest &optional &key &allow-other-keys &aux)))))
1318
1319(declaim (ftype (function * t) slow-method-lookup-1))
1320
1321(declaim (ftype (function (t t t) t) slow-reader-lookup))
1322(defun slow-reader-lookup (gf layout slot-name)
1323  (let ((location (layout-slot-location layout slot-name)))
1324    (cache-slot-location gf layout location)
1325    location))
1326
1327(defun std-compute-discriminating-function (gf)
1328  (let ((code
1329         (cond
1330           ((and (= (length (generic-function-methods gf)) 1)
1331                 (typep (car (generic-function-methods gf)) 'standard-reader-method))
1332            ;;                 (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
1333
1334            (let* ((method (%car (generic-function-methods gf)))
1335                   (class (car (%method-specializers method)))
1336                   (slot-name (reader-method-slot-name method)))
1337              #'(lambda (arg)
1338                  (declare (optimize speed))
1339                  (let* ((layout (std-instance-layout arg))
1340                         (location (get-cached-slot-location gf layout)))
1341                    (unless location
1342                      (unless (simple-typep arg class)
1343                        ;; FIXME no applicable method
1344                        (error 'simple-type-error
1345                               :datum arg
1346                               :expected-type class))
1347                      (setf location (slow-reader-lookup gf layout slot-name)))
1348                    (if (consp location)
1349                        ;; Shared slot.
1350                        (cdr location)
1351                        (standard-instance-access arg location))))))
1352
1353           (t
1354            (let* ((emf-table (classes-to-emf-table gf))
1355                   (number-required (length (gf-required-args gf)))
1356                   (lambda-list (%generic-function-lambda-list gf))
1357                   (exact (null (intersection lambda-list
1358                                              '(&rest &optional &key
1359                                                &allow-other-keys &aux)))))
1360              (if exact
1361                  (cond
1362                    ((= number-required 1)
1363                     (cond
1364                       ((and (eq (generic-function-method-combination gf) 'standard)
1365                             (= (length (generic-function-methods gf)) 1))
1366                        (let* ((method (%car (generic-function-methods gf)))
1367                               (specializer (car (%method-specializers method)))
1368                               (function (or (%method-fast-function method)
1369                                             (%method-function method))))
1370                          (if (eql-specializer-p specializer)
1371                              (let ((specializer-object (eql-specializer-object specializer)))
1372                                #'(lambda (arg)
1373                                    (declare (optimize speed))
1374                                    (if (eql arg specializer-object)
1375                                        (funcall function arg)
1376                                        (no-applicable-method gf (list arg)))))
1377                              #'(lambda (arg)
1378                                  (declare (optimize speed))
1379                                  (unless (simple-typep arg specializer)
1380                                    ;; FIXME no applicable method
1381                                    (error 'simple-type-error
1382                                           :datum arg
1383                                           :expected-type specializer))
1384                                  (funcall function arg)))))
1385                       (t
1386                        #'(lambda (arg)
1387                            (declare (optimize speed))
1388                            (let* ((specialization
1389                                    (%get-arg-specialization gf arg))
1390                                   (emfun (or (gethash1 specialization
1391                                                        emf-table)
1392                                              (slow-method-lookup-1
1393                                               gf arg specialization))))
1394                              (if emfun
1395                                  (funcall emfun (list arg))
1396                                  (apply #'no-applicable-method gf (list arg))))))))
1397                    ((= number-required 2)
1398                     #'(lambda (arg1 arg2)
1399                         (declare (optimize speed))
1400                         (let* ((args (list arg1 arg2))
1401                                (emfun (get-cached-emf gf args)))
1402                           (if emfun
1403                               (funcall emfun args)
1404                               (slow-method-lookup gf args)))))
1405                    ((= number-required 3)
1406                     #'(lambda (arg1 arg2 arg3)
1407                         (declare (optimize speed))
1408                         (let* ((args (list arg1 arg2 arg3))
1409                                (emfun (get-cached-emf gf args)))
1410                           (if emfun
1411                               (funcall emfun args)
1412                               (slow-method-lookup gf args)))))
1413                    (t
1414                     #'(lambda (&rest args)
1415                         (declare (optimize speed))
1416                         (let ((len (length args)))
1417                           (unless (= len number-required)
1418                             (error 'program-error
1419                                    :format-control "Not enough arguments for generic function ~S."
1420                                    :format-arguments (list (%generic-function-name gf)))))
1421                         (let ((emfun (get-cached-emf gf args)))
1422                           (if emfun
1423                               (funcall emfun args)
1424                               (slow-method-lookup gf args))))))
1425                  #'(lambda (&rest args)
1426                      (declare (optimize speed))
1427                      (let ((len (length args)))
1428                        (unless (>= len number-required)
1429                          (error 'program-error
1430                                 :format-control "Not enough arguments for generic function ~S."
1431                                 :format-arguments (list (%generic-function-name gf)))))
1432                      (let ((emfun (get-cached-emf gf args)))
1433                        (if emfun
1434                            (funcall emfun args)
1435                            (slow-method-lookup gf args))))))))))
1436
1437    code))
1438
1439(defun sort-methods (methods gf required-classes)
1440  (if (or (null methods) (null (%cdr methods)))
1441      methods
1442      (sort methods
1443      (if (eq (class-of gf) +the-standard-generic-function-class+)
1444    #'(lambda (m1 m2)
1445        (std-method-more-specific-p m1 m2 required-classes
1446            (generic-function-argument-precedence-order gf)))
1447    #'(lambda (m1 m2)
1448        (method-more-specific-p gf m1 m2 required-classes))))))
1449
1450(defun method-applicable-p (method args)
1451  (do* ((specializers (%method-specializers method) (cdr specializers))
1452        (args args (cdr args)))
1453       ((null specializers) t)
1454    (let ((specializer (car specializers)))
1455      (if (typep specializer 'eql-specializer)
1456          (unless (eql (car args) (eql-specializer-object specializer))
1457            (return nil))
1458          (unless (subclassp (class-of (car args)) specializer)
1459            (return nil))))))
1460
1461(defun %compute-applicable-methods (gf args)
1462  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
1463        (methods '()))
1464    (dolist (method (generic-function-methods gf))
1465      (when (method-applicable-p method args)
1466        (push method methods)))
1467    (sort-methods methods gf required-classes)))
1468
1469;;; METHOD-APPLICABLE-USING-CLASSES-P
1470;;;
1471;;; If the first return value is T, METHOD is definitely applicable to
1472;;; arguments that are instances of CLASSES.  If the first value is
1473;;; NIL and the second value is T, METHOD is definitely not applicable
1474;;; to arguments that are instances of CLASSES; if the second value is
1475;;; NIL the applicability of METHOD cannot be determined by inspecting
1476;;; the classes of its arguments only.
1477;;;
1478(defun method-applicable-using-classes-p (method classes)
1479  (do* ((specializers (%method-specializers method) (cdr specializers))
1480  (classes classes (cdr classes))
1481  (knownp t))
1482       ((null specializers)
1483  (if knownp (values t t) (values nil nil)))
1484    (let ((specializer (car specializers)))
1485      (if (typep specializer 'eql-specializer)
1486    (if (eql (class-of (eql-specializer-object specializer)) 
1487       (car classes))
1488        (setf knownp nil)
1489        (return (values nil t)))
1490    (unless (subclassp (car classes) specializer)
1491      (return (values nil t)))))))
1492
1493(defun slow-method-lookup (gf args)
1494  (let ((applicable-methods (%compute-applicable-methods gf args)))
1495    (if applicable-methods
1496        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1497                                  #'std-compute-effective-method-function
1498                                  #'compute-effective-method-function)
1499                              gf applicable-methods)))
1500          (cache-emf gf args emfun)
1501          (funcall emfun args))
1502        (apply #'no-applicable-method gf args))))
1503
1504(defun slow-method-lookup-1 (gf arg arg-specialization)
1505  (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
1506    (if applicable-methods
1507        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1508                                  #'std-compute-effective-method-function
1509                                  #'compute-effective-method-function)
1510                              gf applicable-methods)))
1511          (when emfun
1512            (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
1513          emfun))))
1514
1515(defun sub-specializer-p (c1 c2 c-arg)
1516  (find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
1517
1518(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
1519  (if argument-precedence-order
1520      (let ((specializers-1 (%method-specializers method1))
1521            (specializers-2 (%method-specializers method2)))
1522        (dolist (index argument-precedence-order)
1523          (let ((spec1 (nth index specializers-1))
1524                (spec2 (nth index specializers-2)))
1525            (unless (eq spec1 spec2)
1526              (cond ((eql-specializer-p spec1)
1527                     (return t))
1528                    ((eql-specializer-p spec2)
1529                     (return nil))
1530                    (t
1531                     (return (sub-specializer-p spec1 spec2
1532                                                (nth index required-classes)))))))))
1533      (do ((specializers-1 (%method-specializers method1) (cdr specializers-1))
1534           (specializers-2 (%method-specializers method2) (cdr specializers-2))
1535           (classes required-classes (cdr classes)))
1536          ((null specializers-1) nil)
1537        (let ((spec1 (car specializers-1))
1538              (spec2 (car specializers-2)))
1539          (unless (eq spec1 spec2)
1540            (cond ((eql-specializer-p spec1)
1541                   (return t))
1542                  ((eql-specializer-p spec2)
1543                   (return nil))
1544                  (t
1545                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))
1546
1547(defun primary-method-p (method)
1548  (null (intersection '(:before :after :around) (method-qualifiers method))))
1549
1550(defun before-method-p (method)
1551  (equal '(:before) (method-qualifiers method)))
1552
1553(defun after-method-p (method)
1554  (equal '(:after) (method-qualifiers method)))
1555
1556(defun around-method-p (method)
1557  (equal '(:around) (method-qualifiers method)))
1558
1559(defun std-compute-effective-method-function (gf methods)
1560  (let* ((mc (generic-function-method-combination gf))
1561         (mc-name (if (atom mc) mc (%car mc)))
1562         (options (if (atom mc) '() (%cdr mc)))
1563         (order (car options))
1564         (primaries '())
1565         (arounds '())
1566         around
1567         emf-form)
1568    (dolist (m methods)
1569      (let ((qualifiers (method-qualifiers m)))
1570        (cond ((null qualifiers)
1571               (if (eq mc-name 'standard)
1572                   (push m primaries)
1573                   (error "Method combination type mismatch.")))
1574              ((cdr qualifiers)
1575               (error "Invalid method qualifiers."))
1576              ((eq (car qualifiers) :around)
1577               (push m arounds))
1578              ((eq (car qualifiers) mc-name)
1579               (push m primaries))
1580              ((memq (car qualifiers) '(:before :after)))
1581              (t
1582               (error "Invalid method qualifiers.")))))
1583    (unless (eq order :most-specific-last)
1584      (setf primaries (nreverse primaries)))
1585    (setf arounds (nreverse arounds))
1586    (setf around (car arounds))
1587    (when (null primaries)
1588      (error "No primary methods for the generic function ~S." gf))
1589    (cond
1590      (around
1591       (let ((next-emfun
1592              (funcall
1593               (if (eq (class-of gf) +the-standard-generic-function-class+)
1594                   #'std-compute-effective-method-function
1595                   #'compute-effective-method-function)
1596               gf (remove around methods))))
1597         (setf emf-form
1598;;;           `(lambda (args)
1599;;;          (funcall ,(%method-function around) args ,next-emfun))
1600               (generate-emf-lambda (%method-function around) next-emfun)
1601               )))
1602      ((eq mc-name 'standard)
1603       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
1604              (befores (remove-if-not #'before-method-p methods))
1605              (reverse-afters
1606               (reverse (remove-if-not #'after-method-p methods))))
1607         (setf emf-form
1608               (cond
1609                 ((and (null befores) (null reverse-afters))
1610                  (let ((fast-function (%method-fast-function (car primaries))))
1611
1612                    (if fast-function
1613                        (ecase (length (gf-required-args gf))
1614                          (1
1615                           #'(lambda (args)
1616                               (declare (optimize speed))
1617                               (funcall fast-function (car args))))
1618                          (2
1619                           #'(lambda (args)
1620                               (declare (optimize speed))
1621                               (funcall fast-function (car args) (cadr args)))))
1622                        ;;                               `(lambda (args)
1623                        ;;                                  (declare (optimize speed))
1624                        ;;                                  (funcall ,(%method-function (car primaries)) args ,next-emfun))
1625                        (generate-emf-lambda (%method-function (car primaries))
1626                                             next-emfun))))
1627                 (t
1628                  (let ((method-function (%method-function (car primaries))))
1629
1630                    #'(lambda (args)
1631                        (declare (optimize speed))
1632                        (dolist (before befores)
1633                          (funcall (%method-function before) args nil))
1634                        (multiple-value-prog1
1635                            (funcall method-function args next-emfun)
1636                          (dolist (after reverse-afters)
1637                            (funcall (%method-function after) args nil))))))))))
1638          (t
1639           (let ((mc-obj (get mc-name 'method-combination-object)))
1640             (unless mc-obj
1641               (error "Unsupported method combination type ~A." mc-name))
1642             (let* ((operator (method-combination-operator mc-obj))
1643                    (ioa (method-combination-identity-with-one-argument mc-obj)))
1644               (setf emf-form
1645                     (if (and (null (cdr primaries))
1646                              (not (null ioa)))
1647;;                          `(lambda (args)
1648;;                             (funcall ,(%method-function (car primaries)) args nil))
1649                         (generate-emf-lambda (%method-function (car primaries)) nil)
1650                         `(lambda (args)
1651                            (,operator ,@(mapcar
1652                                          (lambda (primary)
1653                                            `(funcall ,(%method-function primary) args nil))
1654                                          primaries)))))))))
1655    (or (ignore-errors (autocompile emf-form))
1656        (coerce-to-function emf-form))))
1657
1658(defun generate-emf-lambda (method-function next-emfun)
1659  #'(lambda (args)
1660      (declare (optimize speed))
1661      (funcall method-function args next-emfun)))
1662
1663;;; compute an effective method function from a list of primary methods:
1664
1665(defun compute-primary-emfun (methods)
1666  (if (null methods)
1667      nil
1668      (let ((next-emfun (compute-primary-emfun (cdr methods))))
1669        #'(lambda (args)
1670           (funcall (%method-function (car methods)) args next-emfun)))))
1671
1672(defvar *call-next-method-p*)
1673(defvar *next-method-p-p*)
1674
1675(defun walk-form (form)
1676  (cond ((atom form)
1677         (cond ((eq form 'call-next-method)
1678                (setf *call-next-method-p* t))
1679               ((eq form 'next-method-p)
1680                (setf *next-method-p-p* t))))
1681        (t
1682         (walk-form (%car form))
1683         (walk-form (%cdr form)))))
1684
1685(defun compute-method-function (lambda-expression)
1686  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
1687        (body (cddr lambda-expression))
1688        (*call-next-method-p* nil)
1689        (*next-method-p-p* nil))
1690    (multiple-value-bind (body declarations) (parse-body body)
1691      (let ((ignorable-vars '()))
1692        (dolist (var lambda-list)
1693          (if (memq var lambda-list-keywords)
1694              (return)
1695              (push var ignorable-vars)))
1696        (push `(declare (ignorable ,@ignorable-vars)) declarations))
1697      (walk-form body)
1698      (cond ((or *call-next-method-p* *next-method-p-p*)
1699             `(lambda (args next-emfun)
1700                (flet ((call-next-method (&rest cnm-args)
1701                         (if (null next-emfun)
1702                             (error "No next method for generic function.")
1703                             (funcall next-emfun (or cnm-args args))))
1704                       (next-method-p ()
1705                         (not (null next-emfun))))
1706                  (declare (ignorable (function call-next-method)
1707                                      (function next-method-p)))
1708                  (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
1709            ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
1710             ;; Required parameters only.
1711             (case (length lambda-list)
1712               (1
1713                `(lambda (args next-emfun)
1714                   (declare (ignore next-emfun))
1715                   (let ((,(%car lambda-list) (%car args)))
1716                     (declare (ignorable ,(%car lambda-list)))
1717                     ,@declarations ,@body)))
1718               (2
1719                `(lambda (args next-emfun)
1720                   (declare (ignore next-emfun))
1721                   (let ((,(%car lambda-list) (%car args))
1722                         (,(%cadr lambda-list) (%cadr args)))
1723                     (declare (ignorable ,(%car lambda-list)
1724                                         ,(%cadr lambda-list)))
1725                     ,@declarations ,@body)))
1726               (3
1727                `(lambda (args next-emfun)
1728                   (declare (ignore next-emfun))
1729                   (let ((,(%car lambda-list) (%car args))
1730                         (,(%cadr lambda-list) (%cadr args))
1731                         (,(%caddr lambda-list) (%caddr args)))
1732                     (declare (ignorable ,(%car lambda-list)
1733                                         ,(%cadr lambda-list)
1734                                         ,(%caddr lambda-list)))
1735                     ,@declarations ,@body)))
1736               (t
1737                `(lambda (args next-emfun)
1738                   (declare (ignore next-emfun))
1739                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
1740            (t
1741             `(lambda (args next-emfun)
1742                (declare (ignore next-emfun))
1743                (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
1744
1745(defun compute-method-fast-function (lambda-expression)
1746  (let ((lambda-list (allow-other-keys (cadr lambda-expression))))
1747    (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))
1748      (return-from compute-method-fast-function nil))
1749    ;; Only required args.
1750    (let ((body (cddr lambda-expression))
1751          (*call-next-method-p* nil)
1752          (*next-method-p-p* nil))
1753      (multiple-value-bind (body declarations) (parse-body body)
1754        (walk-form body)
1755        (when (or *call-next-method-p* *next-method-p-p*)
1756          (return-from compute-method-fast-function nil))
1757        (let ((decls `(declare (ignorable ,@lambda-list))))
1758          (setf lambda-expression
1759                (list* (car lambda-expression)
1760                       (cadr lambda-expression)
1761                       decls
1762                       (cddr lambda-expression))))
1763        (case (length lambda-list)
1764          (1
1765;;            `(lambda (args next-emfun)
1766;;               (let ((,(%car lambda-list) (%car args)))
1767;;                 (declare (ignorable ,(%car lambda-list)))
1768;;                 ,@declarations ,@body)))
1769           lambda-expression)
1770          (2
1771;;            `(lambda (args next-emfun)
1772;;               (let ((,(%car lambda-list) (%car args))
1773;;                     (,(%cadr lambda-list) (%cadr args)))
1774;;                 (declare (ignorable ,(%car lambda-list)
1775;;                                     ,(%cadr lambda-list)))
1776;;                 ,@declarations ,@body)))
1777           lambda-expression)
1778;;           (3
1779;;            `(lambda (args next-emfun)
1780;;               (let ((,(%car lambda-list) (%car args))
1781;;                     (,(%cadr lambda-list) (%cadr args))
1782;;                     (,(%caddr lambda-list) (%caddr args)))
1783;;                 (declare (ignorable ,(%car lambda-list)
1784;;                                     ,(%cadr lambda-list)
1785;;                                     ,(%caddr lambda-list)))
1786;;                 ,@declarations ,@body)))
1787          (t
1788           nil))))))
1789
1790;; From CLHS section 7.6.5:
1791;; "When a generic function or any of its methods mentions &key in a lambda
1792;; list, the specific set of keyword arguments accepted by the generic function
1793;; varies according to the applicable methods. The set of keyword arguments
1794;; accepted by the generic function for a particular call is the union of the
1795;; keyword arguments accepted by all applicable methods and the keyword
1796;; arguments mentioned after &key in the generic function definition, if any."
1797;; Adapted from Sacla.
1798(defun allow-other-keys (lambda-list)
1799  (if (and (member '&key lambda-list)
1800           (not (member '&allow-other-keys lambda-list)))
1801      (let* ((key-end (or (position '&aux lambda-list) (length lambda-list)))
1802             (aux-part (subseq lambda-list key-end)))
1803        `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
1804      lambda-list))
1805
1806(defmacro defmethod (&rest args)
1807  (multiple-value-bind
1808      (function-name qualifiers lambda-list specializers documentation declarations body)
1809      (parse-defmethod args)
1810    (let* ((specializers-form '())
1811           (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
1812           (method-function (compute-method-function lambda-expression))
1813           (fast-function (compute-method-fast-function lambda-expression))
1814           )
1815      (dolist (specializer specializers)
1816        (cond ((and (consp specializer) (eq (car specializer) 'eql))
1817               (push `(list 'eql ,(cadr specializer)) specializers-form))
1818              (t
1819               (push `',specializer specializers-form))))
1820      (setf specializers-form `(list ,@(nreverse specializers-form)))
1821      `(progn
1822         (ensure-method ',function-name
1823                        :lambda-list ',lambda-list
1824                        :qualifiers ',qualifiers
1825                        :specializers ,specializers-form
1826                        ,@(if documentation `(:documentation ,documentation))
1827                        :function (function ,method-function)
1828                        ,@(if fast-function `(:fast-function (function ,fast-function)))
1829                        )))))
1830
1831;;; Reader and writer methods
1832
1833(defun make-instance-standard-reader-method (gf
1834                                             &key
1835                                             lambda-list
1836                                             qualifiers
1837                                             specializers
1838                                             documentation
1839                                             function
1840                                             fast-function
1841                                             slot-name)
1842  (declare (ignore gf))
1843  (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
1844    (setf (method-lambda-list method) lambda-list)
1845    (setf (method-qualifiers method) qualifiers)
1846    (%set-method-specializers method (canonicalize-specializers specializers))
1847    (setf (method-documentation method) documentation)
1848    (%set-method-generic-function method nil)
1849    (%set-method-function method function)
1850    (%set-method-fast-function method fast-function)
1851    (set-reader-method-slot-name method slot-name)
1852    method))
1853
1854(defun add-reader-method (class function-name slot-name)
1855  (let* ((lambda-expression
1856          (if (eq (class-of class) +the-standard-class+)
1857              `(lambda (object) (std-slot-value object ',slot-name))
1858              `(lambda (object) (slot-value object ',slot-name))))
1859         (method-function (compute-method-function lambda-expression))
1860         (fast-function (compute-method-fast-function lambda-expression)))
1861    (let ((method-lambda-list '(object))
1862          (gf (find-generic-function function-name nil)))
1863      (if gf
1864          (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf))
1865          (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list)))
1866      (let ((method
1867             (make-instance-standard-reader-method gf
1868                                                   :lambda-list '(object)
1869                                                   :qualifiers ()
1870                                                   :specializers (list class)
1871                                                   :function (if (autoloadp 'compile)
1872                                                                 method-function
1873                                                                 (autocompile method-function))
1874                                                   :fast-function (if (autoloadp 'compile)
1875                                                                      fast-function
1876                                                                      (autocompile fast-function))
1877                                                   :slot-name slot-name)))
1878        (%add-method gf method)
1879        method))))
1880
1881(defun add-writer-method (class function-name slot-name)
1882  (let* ((lambda-expression
1883          (if (eq (class-of class) +the-standard-class+)
1884              `(lambda (new-value object)
1885                 (setf (std-slot-value object ',slot-name) new-value))
1886              `(lambda (new-value object)
1887                 (setf (slot-value object ',slot-name) new-value))))
1888         (method-function (compute-method-function lambda-expression))
1889         (fast-function (compute-method-fast-function lambda-expression))
1890         )
1891    (ensure-method function-name
1892                   :lambda-list '(new-value object)
1893                   :qualifiers ()
1894                   :specializers (list +the-T-class+ class)
1895;;                    :function `(function ,method-function)
1896                   :function (if (autoloadp 'compile)
1897                                 method-function
1898                                 (autocompile method-function))
1899                   :fast-function (if (autoloadp 'compile)
1900                                      fast-function
1901                                      (autocompile fast-function))
1902                   )))
1903
1904(defmacro redefine-class-forwarder (name slot &optional alternative-name)
1905  (let* (($name (if (consp name) (cadr name) name))
1906         (%name (intern (concatenate 'string
1907                                     "%"
1908                                     (if (consp name)
1909                                         (symbol-name 'set-) "")
1910                                     (symbol-name $name))
1911                        (find-package "SYS"))))
1912    (unless alternative-name
1913      (setf alternative-name name))
1914    (if (consp name)
1915        `(progn ;; setter
1916           (defgeneric ,alternative-name (new-value class))
1917           (defmethod ,alternative-name (new-value (class built-in-class))
1918             (,%name new-value class))
1919           (defmethod ,alternative-name (new-value (class forward-referenced-class))
1920             (,%name new-value class))
1921           (defmethod ,alternative-name (new-value (class structure-class))
1922             (,%name new-value class))
1923           (defmethod ,alternative-name (new-value (class standard-class))
1924             (setf (slot-value class ',slot) new-value))
1925           ,@(unless (eq name alternative-name)
1926                     `((setf (get ',$name 'SETF-FUNCTION)
1927                             (symbol-function ',alternative-name))))
1928           )
1929        `(progn ;; getter
1930           (defgeneric ,alternative-name (class))
1931           (defmethod ,alternative-name ((class built-in-class))
1932             (,%name class))
1933           (defmethod ,alternative-name ((class forward-referenced-class))
1934             (,%name class))
1935           (defmethod ,alternative-name ((class structure-class))
1936             (,%name class))
1937           (defmethod ,alternative-name ((class standard-class))
1938             (slot-value class ',slot))
1939           ,@(unless (eq name alternative-name)
1940                     `((setf (symbol-function ',$name)
1941                             (symbol-function ',alternative-name))))
1942           ) )))
1943
1944(redefine-class-forwarder class-name name)
1945(redefine-class-forwarder (setf class-name) name)
1946(redefine-class-forwarder class-slots slots)
1947(redefine-class-forwarder (setf class-slots) slots)
1948(redefine-class-forwarder class-direct-slots direct-slots)
1949(redefine-class-forwarder (setf class-direct-slots) direct-slots)
1950(redefine-class-forwarder class-layout layout)
1951(redefine-class-forwarder (setf class-layout) layout)
1952(redefine-class-forwarder class-direct-superclasses direct-superclasses)
1953(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
1954(redefine-class-forwarder class-direct-subclasses direct-subclasses)
1955(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
1956(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
1957(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
1958(redefine-class-forwarder class-precedence-list precedence-list)
1959(redefine-class-forwarder (setf class-precedence-list) precedence-list)
1960(redefine-class-forwarder class-finalized-p finalized-p)
1961(redefine-class-forwarder (setf class-finalized-p) finalized-p)
1962(redefine-class-forwarder class-default-initargs default-initargs)
1963(redefine-class-forwarder (setf class-default-initargs) default-initargs)
1964(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
1965(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
1966
1967(defgeneric direct-slot-definition-class (class &rest initargs))
1968
1969(defmethod direct-slot-definition-class ((class class) &rest initargs)
1970  (declare (ignore initargs))
1971  +the-direct-slot-definition-class+)
1972
1973(defgeneric effective-slot-definition-class (class &rest initargs))
1974
1975(defmethod effective-slot-definition-class ((class class) &rest initargs)
1976  (declare (ignore initargs))
1977  +the-effective-slot-definition-class+)
1978
1979(fmakunbound 'documentation)
1980(defgeneric documentation (x doc-type))
1981
1982(defgeneric (setf documentation) (new-value x doc-type))
1983
1984(defmethod documentation ((x symbol) doc-type)
1985  (%documentation x doc-type))
1986
1987(defmethod (setf documentation) (new-value (x symbol) doc-type)
1988  (%set-documentation x doc-type new-value))
1989
1990(defmethod documentation ((x function) doc-type)
1991  (%documentation x doc-type))
1992
1993(defmethod (setf documentation) (new-value (x function) doc-type)
1994  (%set-documentation x doc-type new-value))
1995
1996;; FIXME This should be a weak hashtable!
1997(defvar *list-documentation-hashtable* (make-hash-table :test #'equal))
1998
1999(defmethod documentation ((x list) (doc-type (eql 'function)))
2000  (let ((alist (gethash x *list-documentation-hashtable*)))
2001    (and alist (cdr (assoc doc-type alist)))))
2002
2003(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
2004  (let ((alist (gethash x *list-documentation-hashtable*)))
2005    (and alist (cdr (assoc doc-type alist)))))
2006
2007(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
2008  (let* ((alist (gethash x *list-documentation-hashtable*))
2009         (entry (and alist (assoc doc-type alist))))
2010    (cond (entry
2011           (setf (cdr entry) new-value))
2012          (t
2013           (setf (gethash x *list-documentation-hashtable*)
2014                 (push (cons doc-type new-value) alist)))))
2015  new-value)
2016
2017(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
2018  (let* ((alist (gethash x *list-documentation-hashtable*))
2019         (entry (and alist (assoc doc-type alist))))
2020    (cond (entry
2021           (setf (cdr entry) new-value))
2022          (t
2023           (setf (gethash x *list-documentation-hashtable*)
2024                 (push (cons doc-type new-value) alist)))))
2025  new-value)
2026
2027(defmethod documentation ((x standard-class) (doc-type (eql 't)))
2028  (class-documentation x))
2029
2030(defmethod documentation ((x standard-class) (doc-type (eql 'type)))
2031  (class-documentation x))
2032
2033(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't)))
2034  (%set-class-documentation x new-value))
2035
2036(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type)))
2037  (%set-class-documentation x new-value))
2038
2039(defmethod documentation ((x structure-class) (doc-type (eql 't)))
2040  (%documentation x doc-type))
2041
2042(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
2043  (%documentation x doc-type))
2044
2045(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
2046  (%set-documentation x doc-type new-value))
2047
2048(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
2049  (%set-documentation x doc-type new-value))
2050
2051(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
2052  (generic-function-documentation x))
2053
2054(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
2055  (setf (generic-function-documentation x) new-value))
2056
2057(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
2058  (generic-function-documentation x))
2059
2060(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
2061  (setf (generic-function-documentation x) new-value))
2062
2063(defmethod documentation ((x standard-method) (doc-type (eql 't)))
2064  (method-documentation x))
2065
2066(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
2067  (setf (method-documentation x) new-value))
2068
2069(defmethod documentation ((x package) (doc-type (eql 't)))
2070  (%documentation x doc-type))
2071
2072(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
2073  (%set-documentation x doc-type new-value))
2074
2075;;; Applicable methods
2076
2077(defgeneric compute-applicable-methods (gf args)
2078  (:method ((gf standard-generic-function) args)
2079    (%compute-applicable-methods gf args)))
2080
2081(defgeneric compute-applicable-methods-using-classes (gf classes)
2082  (:method ((gf standard-generic-function) classes)
2083    (let ((methods '()))
2084      (dolist (method (generic-function-methods gf))
2085  (multiple-value-bind (applicable knownp)
2086      (method-applicable-using-classes-p method classes)
2087    (cond (applicable
2088     (push method methods))
2089    ((not knownp)
2090     (return-from compute-applicable-methods-using-classes
2091       (values nil nil))))))
2092      (values (sort-methods methods gf classes)
2093        t))))
2094
2095(export '(compute-applicable-methods
2096    compute-applicable-methods-using-classes))
2097
2098
2099;;; Slot access
2100
2101(defun set-slot-value-using-class (new-value class instance slot-name)
2102  (declare (ignore class)) ; FIXME
2103  (setf (std-slot-value instance slot-name) new-value))
2104
2105(defgeneric slot-value-using-class (class instance slot-name))
2106
2107(defmethod slot-value-using-class ((class standard-class) instance slot-name)
2108  (std-slot-value instance slot-name))
2109
2110(defmethod slot-value-using-class ((class structure-class) instance slot-name)
2111  (std-slot-value instance slot-name))
2112
2113(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
2114
2115(defmethod (setf slot-value-using-class) (new-value
2116                                          (class standard-class)
2117                                          instance
2118                                          slot-name)
2119  (setf (std-slot-value instance slot-name) new-value))
2120
2121(defmethod (setf slot-value-using-class) (new-value
2122                                          (class structure-class)
2123                                          instance
2124                                          slot-name)
2125  (setf (std-slot-value instance slot-name) new-value))
2126
2127(defgeneric slot-exists-p-using-class (class instance slot-name))
2128
2129(defmethod slot-exists-p-using-class (class instance slot-name)
2130  nil)
2131
2132(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
2133  (std-slot-exists-p instance slot-name))
2134
2135(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
2136  (dolist (dsd (class-slots class))
2137    (when (eq (sys::dsd-name dsd) slot-name)
2138      (return-from slot-exists-p-using-class t)))
2139  nil)
2140
2141(defgeneric slot-boundp-using-class (class instance slot-name))
2142(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
2143  (std-slot-boundp instance slot-name))
2144(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
2145  "Structure slots can't be unbound, so this method always returns T."
2146  (declare (ignore class instance slot-name))
2147  t)
2148
2149(defgeneric slot-makunbound-using-class (class instance slot-name))
2150(defmethod slot-makunbound-using-class ((class standard-class)
2151                                        instance
2152                                        slot-name)
2153  (std-slot-makunbound instance slot-name))
2154(defmethod slot-makunbound-using-class ((class structure-class)
2155                                        instance
2156                                        slot-name)
2157  (declare (ignore class instance slot-name))
2158  (error "Structure slots can't be unbound"))
2159
2160(defgeneric slot-missing (class instance slot-name operation &optional new-value))
2161
2162(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
2163  (declare (ignore new-value))
2164  (error "The slot ~S is missing from the class ~S." slot-name class))
2165
2166(defgeneric slot-unbound (class instance slot-name))
2167
2168(defmethod slot-unbound ((class t) instance slot-name)
2169  (error 'unbound-slot :instance instance :name slot-name))
2170
2171;;; Instance creation and initialization
2172
2173(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
2174
2175(defmethod allocate-instance ((class standard-class) &rest initargs)
2176  (declare (ignore initargs))
2177  (std-allocate-instance class))
2178
2179(defmethod allocate-instance ((class structure-class) &rest initargs)
2180  (declare (ignore initargs))
2181  (%make-structure (class-name class)
2182                   (make-list (length (class-slots class))
2183                              :initial-element +slot-unbound+)))
2184
2185;; "The set of valid initialization arguments for a class is the set of valid
2186;; initialization arguments that either fill slots or supply arguments to
2187;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
2188;; 7.1.2
2189
2190(defun check-initargs (instance shared-initialize-param initargs)
2191  (when (oddp (length initargs))
2192    (error 'program-error
2193           :format-control "Odd number of keyword arguments."))
2194  (unless (getf initargs :allow-other-keys)
2195    (let ((methods 
2196     (nconc 
2197      (compute-applicable-methods 
2198       #'shared-initialize
2199       (if initargs
2200     `(,instance ,shared-initialize-param ,@initargs)
2201         (list instance shared-initialize-param)))
2202      (compute-applicable-methods 
2203       #'initialize-instance
2204       (if initargs
2205     `(,instance ,@initargs)
2206         (list instance)))))
2207    (slots (class-slots (class-of instance))))
2208      (do* ((tail initargs (cddr tail))
2209            (initarg (car tail) (car tail)))
2210           ((null tail))
2211        (unless (or (valid-initarg-p initarg slots)
2212        (valid-methodarg-p initarg methods)
2213                    (eq initarg :allow-other-keys))
2214          (error 'program-error
2215                 :format-control "Invalid initarg ~S."
2216                 :format-arguments (list initarg)))))))
2217
2218(defun valid-methodarg-p (initarg methods)
2219  (when (symbolp initarg)
2220    (dolist (method methods nil)
2221      (let ((valid-initargs (method-lambda-list method)))
2222  (when (find (symbol-value initarg) valid-initargs 
2223         :test #'(lambda (a b)
2224             (if (listp b)
2225           (string= a (car b))
2226         (or
2227          (string= a b)
2228          (string= b "&ALLOW-OTHER-KEYS")))))
2229
2230    (return t))))))
2231
2232(defun valid-initarg-p (initarg slots)
2233  (dolist (slot slots nil)
2234    (let ((valid-initargs (slot-definition-initargs slot)))
2235      (when (memq initarg valid-initargs)
2236        (return t)))))
2237
2238(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
2239
2240(defmethod make-instance ((class standard-class) &rest initargs)
2241  (when (oddp (length initargs))
2242    (error 'program-error :format-control "Odd number of keyword arguments."))
2243  (unless (class-finalized-p class)
2244    (std-finalize-inheritance class))
2245  (let ((class-default-initargs (class-default-initargs class)))
2246    (when class-default-initargs
2247      (let ((default-initargs '()))
2248        (do* ((list class-default-initargs (cddr list))
2249              (key (car list) (car list))
2250              (fn (cadr list) (cadr list)))
2251             ((null list))
2252          (when (eq (getf initargs key 'not-found) 'not-found)
2253            (setf default-initargs (append default-initargs (list key (funcall fn))))))
2254        (setf initargs (append initargs default-initargs)))))
2255
2256  (let ((instance (std-allocate-instance class)))
2257    (check-initargs instance t initargs)
2258    (apply #'initialize-instance instance initargs)
2259    instance))
2260
2261(defmethod make-instance ((class symbol) &rest initargs)
2262  (apply #'make-instance (find-class class) initargs))
2263
2264(defgeneric initialize-instance (instance &key))
2265
2266(defmethod initialize-instance ((instance standard-object) &rest initargs)
2267  (apply #'shared-initialize instance t initargs))
2268
2269(defgeneric reinitialize-instance (instance &key))
2270
2271;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the
2272;; validity of initargs and signals an error if an initarg is supplied that is
2273;; not declared as valid. The method then calls the generic function SHARED-
2274;; INITIALIZE with the following arguments: the instance, nil (which means no
2275;; slots should be initialized according to their initforms), and the initargs
2276;; it received."
2277(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2278  (apply #'shared-initialize instance () initargs))
2279
2280(defun std-shared-initialize (instance slot-names all-keys)
2281  (when (oddp (length all-keys))
2282    (error 'program-error :format-control "Odd number of keyword arguments."))
2283  (do* ((tail all-keys (cddr tail))
2284  (initarg (car tail) (car tail)))
2285      ((null tail))
2286    (when (and initarg (not (symbolp initarg)))
2287      (error 'program-error
2288       :format-control "Invalid initarg ~S."
2289       :format-arguments (list initarg))))
2290  (dolist (slot (class-slots (class-of instance)))
2291    (let ((slot-name (slot-definition-name slot)))
2292      (multiple-value-bind (init-key init-value foundp)
2293          (get-properties all-keys (slot-definition-initargs slot))
2294        (if foundp
2295            (setf (std-slot-value instance slot-name) init-value)
2296            (unless (std-slot-boundp instance slot-name)
2297              (let ((initfunction (slot-definition-initfunction slot)))
2298                (when (and initfunction (or (eq slot-names t)
2299                                            (memq slot-name slot-names)))
2300                  (setf (std-slot-value instance slot-name)
2301                        (funcall initfunction)))))))))
2302  instance)
2303
2304(defgeneric shared-initialize (instance slot-names &key))
2305
2306(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
2307  (std-shared-initialize instance slot-names initargs))
2308
2309(defmethod shared-initialize ((slot slot-definition) slot-names
2310            &rest args
2311            &key name initargs initform initfunction
2312            readers writers allocation
2313            &allow-other-keys)
2314  ;;Keyword args are duplicated from init-slot-definition only to have
2315  ;;them checked.
2316  (declare (ignore slot-names)) ;;TODO?
2317  (declare (ignore name initargs initform initfunction readers writers allocation))
2318  (apply #'init-slot-definition slot args))
2319
2320;;; change-class
2321
2322(defgeneric change-class (instance new-class &key))
2323
2324(defmethod change-class ((old-instance standard-object) (new-class standard-class)
2325                         &rest initargs)
2326  (let ((old-slots (class-slots (class-of old-instance)))
2327        (new-slots (class-slots new-class))
2328        (new-instance (allocate-instance new-class)))
2329    ;; "The values of local slots specified by both the class CTO and the class
2330    ;; CFROM are retained. If such a local slot was unbound, it remains
2331    ;; unbound."
2332    (dolist (new-slot new-slots)
2333      (when (instance-slot-p new-slot)
2334        (let* ((slot-name (slot-definition-name new-slot))
2335               (old-slot (find slot-name old-slots :key #'slot-definition-name)))
2336          ;; "The values of slots specified as shared in the class CFROM and as
2337          ;; local in the class CTO are retained."
2338          (when (and old-slot (slot-boundp old-instance slot-name))
2339            (setf (slot-value new-instance slot-name)
2340                  (slot-value old-instance slot-name))))))
2341    (swap-slots old-instance new-instance)
2342    (rotatef (std-instance-layout new-instance)
2343             (std-instance-layout old-instance))
2344    (apply #'update-instance-for-different-class
2345           new-instance old-instance initargs)
2346    old-instance))
2347
2348(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
2349  (apply #'change-class instance (find-class new-class) initargs))
2350
2351(defgeneric update-instance-for-different-class (old new &key))
2352
2353(defmethod update-instance-for-different-class
2354  ((old standard-object) (new standard-object) &rest initargs)
2355  (let ((added-slots
2356         (remove-if #'(lambda (slot-name)
2357                       (slot-exists-p old slot-name))
2358                    (mapcar #'slot-definition-name
2359                            (class-slots (class-of new))))))
2360    (check-initargs new added-slots initargs)
2361    (apply #'shared-initialize new added-slots initargs)))
2362
2363;;; make-instances-obsolete
2364
2365(defgeneric make-instances-obsolete (class))
2366
2367(defmethod make-instances-obsolete ((class standard-class))
2368  (%make-instances-obsolete class))
2369
2370(defmethod make-instances-obsolete ((class symbol))
2371  (make-instances-obsolete (find-class class))
2372  class)
2373
2374;;; update-instance-for-redefined-class
2375
2376(defgeneric update-instance-for-redefined-class (instance
2377                                                 added-slots
2378                                                 discarded-slots
2379                                                 property-list
2380                                                 &rest initargs
2381                                                 &key
2382                                                 &allow-other-keys))
2383
2384(defmethod update-instance-for-redefined-class ((instance standard-object)
2385            added-slots
2386            discarded-slots
2387            property-list
2388            &rest initargs)
2389  (check-initargs instance added-slots initargs)
2390  (apply #'shared-initialize instance added-slots initargs))
2391
2392;;;  Methods having to do with class metaobjects.
2393
2394(defmethod initialize-instance :after ((class standard-class) &rest args)
2395  (apply #'std-after-initialization-for-classes class args))
2396
2397;;; Finalize inheritance
2398
2399(defgeneric finalize-inheritance (class))
2400
2401(defmethod finalize-inheritance ((class standard-class))
2402  (std-finalize-inheritance class))
2403
2404;;; Class precedence lists
2405
2406(defgeneric compute-class-precedence-list (class))
2407(defmethod compute-class-precedence-list ((class standard-class))
2408  (std-compute-class-precedence-list class))
2409
2410;;; Slot inheritance
2411
2412(defgeneric compute-slots (class))
2413(defmethod compute-slots ((class standard-class))
2414  (std-compute-slots class))
2415
2416(defgeneric compute-effective-slot-definition (class direct-slots))
2417(defmethod compute-effective-slot-definition
2418  ((class standard-class) direct-slots)
2419  (std-compute-effective-slot-definition class direct-slots))
2420
2421;;; Methods having to do with generic function metaobjects.
2422
2423(defmethod initialize-instance :after ((gf standard-generic-function) &key)
2424  (finalize-generic-function gf))
2425
2426;;; Methods having to do with generic function invocation.
2427
2428(defgeneric compute-discriminating-function (gf))
2429(defmethod compute-discriminating-function ((gf standard-generic-function))
2430  (std-compute-discriminating-function gf))
2431
2432(defgeneric method-more-specific-p (gf method1 method2 required-classes))
2433
2434(defmethod method-more-specific-p ((gf standard-generic-function)
2435                                   method1 method2 required-classes)
2436  (std-method-more-specific-p method1 method2 required-classes
2437                              (generic-function-argument-precedence-order gf)))
2438
2439(defgeneric compute-effective-method-function (gf methods))
2440(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
2441  (std-compute-effective-method-function gf methods))
2442
2443(defgeneric compute-applicable-methods (gf args))
2444(defmethod compute-applicable-methods ((gf standard-generic-function) args)
2445  (%compute-applicable-methods gf args))
2446
2447;;; Slot definition accessors
2448
2449(map nil (lambda (sym)
2450     (fmakunbound sym) ;;we need to redefine them as GFs
2451     (fmakunbound `(setf ,sym))
2452     (export sym))
2453  '(slot-definition-allocation 
2454    slot-definition-initargs
2455    slot-definition-initform
2456    slot-definition-initfunction
2457    slot-definition-name
2458    slot-definition-readers
2459    slot-definition-writers
2460    slot-definition-allocation-class))
2461
2462(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
2463  `(let (($cl (class-of ,slot-definition)))
2464     (case $cl
2465       ((+the-slot-definition-class+
2466   +the-direct-slot-definition-class+
2467   +the-effective-slot-definition-class+)
2468  ,std-form)
2469       (t ,generic-form))))
2470
2471(defgeneric slot-definition-allocation (slot-definition)
2472  (:method ((slot-definition slot-definition))
2473    (slot-definition-dispatch slot-definition
2474      (%slot-definition-allocation slot-definition)
2475      (slot-value slot-definition 'sys::allocation))))
2476
2477(defgeneric (setf slot-definition-allocation) (value slot-definition)
2478  (:method (value (slot-definition slot-definition))
2479    (slot-definition-dispatch slot-definition
2480      (set-slot-definition-allocation slot-definition value)
2481      (setf (slot-value slot-definition 'sys::allocation) value))))
2482
2483(defgeneric slot-definition-initargs (slot-definition)
2484  (:method ((slot-definition slot-definition))
2485    (slot-definition-dispatch slot-definition
2486      (%slot-definition-initargs slot-definition)
2487      (slot-value slot-definition 'sys::initargs))))
2488
2489(defgeneric (setf slot-definition-initargs) (value slot-definition)
2490  (:method (value (slot-definition slot-definition))
2491    (slot-definition-dispatch slot-definition
2492      (set-slot-definition-initargs slot-definition value)
2493      (setf (slot-value slot-definition 'sys::initargs) value))))
2494
2495(defgeneric slot-definition-initform (slot-definition)
2496  (:method ((slot-definition slot-definition))
2497    (slot-definition-dispatch slot-definition
2498      (%slot-definition-initform slot-definition)
2499      (slot-value slot-definition 'sys::initform))))
2500
2501(defgeneric (setf slot-definition-initform) (value slot-definition)
2502  (:method (value (slot-definition slot-definition))
2503    (slot-definition-dispatch slot-definition
2504      (set-slot-definition-initform slot-definition value)
2505      (setf (slot-value slot-definition 'sys::initform) value))))
2506
2507(defgeneric slot-definition-initfunction (slot-definition)
2508  (:method ((slot-definition slot-definition))
2509    (slot-definition-dispatch slot-definition
2510      (%slot-definition-initfunction slot-definition)
2511      (slot-value slot-definition 'sys::initfunction))))
2512
2513(defgeneric (setf slot-definition-initfunction) (value slot-definition)
2514  (:method (value (slot-definition slot-definition))
2515    (slot-definition-dispatch slot-definition
2516      (set-slot-definition-initfunction slot-definition value)
2517      (setf (slot-value slot-definition 'sys::initfunction) value))))
2518
2519(defgeneric slot-definition-name (slot-definition)
2520  (:method ((slot-definition slot-definition))
2521    (slot-definition-dispatch slot-definition
2522      (%slot-definition-name slot-definition)
2523      (slot-value slot-definition 'sys::name))))
2524
2525(defgeneric (setf slot-definition-name) (value slot-definition)
2526  (:method (value (slot-definition slot-definition))
2527    (slot-definition-dispatch slot-definition
2528      (set-slot-definition-name slot-definition value)
2529      (setf (slot-value slot-definition 'sys::name) value))))
2530
2531(defgeneric slot-definition-readers (slot-definition)
2532  (:method ((slot-definition slot-definition))
2533    (slot-definition-dispatch slot-definition
2534      (%slot-definition-readers slot-definition)
2535      (slot-value slot-definition 'sys::readers))))
2536
2537(defgeneric (setf slot-definition-readers) (value slot-definition)
2538  (:method (value (slot-definition slot-definition))
2539    (slot-definition-dispatch slot-definition
2540      (set-slot-definition-readers slot-definition value)
2541      (setf (slot-value slot-definition 'sys::readers) value))))
2542
2543(defgeneric slot-definition-writers (slot-definition)
2544  (:method ((slot-definition slot-definition))
2545    (slot-definition-dispatch slot-definition
2546      (%slot-definition-writers slot-definition)
2547      (slot-value slot-definition 'sys::writers))))
2548
2549(defgeneric (setf slot-definition-writers) (value slot-definition)
2550  (:method (value (slot-definition slot-definition))
2551    (slot-definition-dispatch slot-definition
2552      (set-slot-definition-writers slot-definition value)
2553      (setf (slot-value slot-definition 'sys::writers) value))))
2554
2555(defgeneric slot-definition-allocation-class (slot-definition)
2556  (:method ((slot-definition slot-definition))
2557    (slot-definition-dispatch slot-definition
2558      (%slot-definition-allocation-class slot-definition)
2559      (slot-value slot-definition 'sys::allocation-class))))
2560
2561(defgeneric (setf slot-definition-allocation-class) (value slot-definition)
2562  (:method (value (slot-definition slot-definition))
2563    (slot-definition-dispatch slot-definition
2564      (set-slot-definition-allocation-class slot-definition value)
2565      (setf (slot-value slot-definition 'sys::allocation-class) value))))
2566
2567;;; No %slot-definition-type.
2568
2569
2570;;; Conditions.
2571
2572(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
2573  (let ((parent-types (or parent-types '(condition)))
2574        (report nil))
2575    (dolist (option options)
2576      (when (eq (car option) :report)
2577        (setf report (cadr option))
2578  (setf options (delete option options :test #'equal))
2579        (return)))
2580    (typecase report
2581      (null
2582       `(progn
2583          (defclass ,name ,parent-types ,slot-specs ,@options)
2584          ',name))
2585      (string
2586       `(progn
2587          (defclass ,name ,parent-types ,slot-specs ,@options)
2588          (defmethod print-object ((condition ,name) stream)
2589            (if *print-escape*
2590                (call-next-method)
2591                (progn (write-string ,report stream) condition)))
2592          ',name))
2593      (t
2594       `(progn
2595          (defclass ,name ,parent-types ,slot-specs ,@options)
2596          (defmethod print-object ((condition ,name) stream)
2597            (if *print-escape*
2598                (call-next-method)
2599                (funcall #',report condition stream)))
2600          ',name)))))
2601
2602(defun make-condition (type &rest initargs)
2603  (or (%make-condition type initargs)
2604      (let ((class (if (symbolp type) (find-class type) type)))
2605        (apply #'make-instance class initargs))))
2606
2607;; Adapted from SBCL.
2608;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
2609(defun coerce-to-condition (datum arguments default-type fun-name)
2610  (cond ((typep datum 'condition)
2611         (when arguments
2612           (error 'simple-type-error
2613                  :datum arguments
2614                  :expected-type 'null
2615                  :format-control "You may not supply additional arguments when giving ~S to ~S."
2616                  :format-arguments (list datum fun-name)))
2617         datum)
2618        ((symbolp datum)
2619         (apply #'make-condition datum arguments))
2620        ((or (stringp datum) (functionp datum))
2621         (make-condition default-type
2622                         :format-control datum
2623                         :format-arguments arguments))
2624        (t
2625         (error 'simple-type-error
2626                :datum datum
2627                :expected-type '(or symbol string)
2628                :format-control "Bad argument to ~S: ~S."
2629                :format-arguments (list fun-name datum)))))
2630
2631(defgeneric make-load-form (object &optional environment))
2632
2633(defmethod make-load-form ((object t) &optional environment)
2634  (declare (ignore environment))
2635  (apply #'no-applicable-method #'make-load-form (list object)))
2636
2637(defmethod make-load-form ((class class) &optional environment)
2638  (declare (ignore environment))
2639  (let ((name (class-name class)))
2640    (unless (and name (eq (find-class name nil) class))
2641      (error 'simple-type-error
2642             :format-control "Can't use anonymous or undefined class as a constant: ~S."
2643             :format-arguments (list class)))
2644    `(find-class ',name)))
2645
2646(defun invalid-method-error (method format-control &rest args)
2647  (let ((message (apply #'format nil format-control args)))
2648    (error "Invalid method error for ~S:~%    ~A" method message)))
2649
2650(defun method-combination-error (format-control &rest args)
2651  (let ((message (apply #'format nil format-control args)))
2652    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
2653
2654(fmakunbound 'no-applicable-method)
2655(defgeneric no-applicable-method (generic-function &rest args))
2656
2657(defmethod no-applicable-method (generic-function &rest args)
2658  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
2659         generic-function
2660         args))
2661
2662(defgeneric find-method (generic-function
2663                         qualifiers
2664                         specializers
2665                         &optional errorp))
2666
2667(defmethod find-method ((generic-function standard-generic-function)
2668      qualifiers specializers &optional (errorp t))
2669  (%find-method generic-function qualifiers specializers errorp))
2670
2671(defgeneric add-method (generic-function method))
2672
2673(defmethod add-method ((generic-function standard-generic-function) (method method))
2674  (let ((method-lambda-list (method-lambda-list method))
2675        (gf-lambda-list (generic-function-lambda-list generic-function)))
2676    (check-method-lambda-list method-lambda-list gf-lambda-list))
2677  (%add-method generic-function method))
2678
2679(defgeneric remove-method (generic-function method))
2680
2681(defmethod remove-method ((generic-function standard-generic-function) method)
2682  (%remove-method generic-function method))
2683
2684;; See describe.lisp.
2685(defgeneric describe-object (object stream))
2686
2687;; FIXME
2688(defgeneric no-next-method (generic-function method &rest args))
2689
2690;; FIXME
2691(defgeneric function-keywords (method))
2692
2693(setf *clos-booting* nil)
2694
2695(defgeneric class-prototype (class))
2696
2697(defmethod class-prototype :before (class)
2698  (unless (class-finalized-p class)
2699    (error "~@<~S is not finalized.~:@>" class)))
2700
2701(defmethod class-prototype ((class standard-class))
2702  (allocate-instance class))
2703
2704(defmethod class-prototype ((class structure-class))
2705  (allocate-instance class))
2706
2707(provide 'clos)
Note: See TracBrowser for help on using the repository browser.