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

Last change on this file since 12715 was 12715, checked in by astalla, 15 years ago

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