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

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

Untabify.

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