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

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

Create ATOMIC-DEFGENERIC macro, in order to eliminate FMAKUNBOUND calls
and the resulting windows where no function is bound to symbols which
are the most essential building blocks in CLOS/AMOP.

Note: This change should help making CLOS bootstrapping less
confusing and less tedious to hack.

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