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

Last change on this file since 12738 was 12738, checked in by astalla, 12 years ago

Initial support for custom slot definition metaobjects in MOP.

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