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

Last change on this file since 13201 was 13201, checked in by ehuelsmann, 11 years ago

Rename STD-ALLOCATE-INSTANCE to %STD-ALLOCATE-INSTANCE,
creating STD-ALLOCATE-INSTANCE which is closer to the one
specified by AMOP.

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