source: branches/0.20.x/abcl/src/org/armedbear/lisp/clos.lisp

Last change on this file was 12665, checked in by ehuelsmann, 15 years ago

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