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

Last change on this file since 12586 was 12586, checked in by ehuelsmann, 13 years ago

Reduce function dispatch speed with 6% by

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