source: branches/1.1.x/src/org/armedbear/lisp/clos.lisp @ 14294

Last change on this file since 14294 was 14294, checked in by Mark Evenson, 8 years ago

Backport r14293: Don't clobber class objects when re-initializing.

  • Also remove double-initialization via shared-initialize + one of

intialize-instance / reinitialize-instance.

  • Reported by Pascal Costanza
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 205.1 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; Copyright (C) 2010 Mark Evenson
5;;; $Id: clos.lisp 14294 2012-12-06 07:06:36Z mevenson $
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(export '(%defgeneric canonicalize-direct-superclasses))
56
57
58;;
59;;
60;;
61;; In order to bootstrap CLOS, first implement the required API as
62;; normal functions which only apply to the "root" metaclass
63;; STANDARD-CLASS.
64;;
65;; After putting the normal functions in place, the building blocks
66;; are in place to gradually swap the normal functions with
67;; generic functions and methods.
68;;
69;; Some functionality implemented in the temporary regular functions
70;; needs to be available later as a method definition to be dispatched
71;; to for the standard case, e.g. with arguments of type STANDARD-CLASS
72;; or STANDARD-GENERIC-FUNCTION.  To prevent repeated code, the
73;; functions are implemented in functions by the same name as the API
74;; functions, but with the STD- prefix.  These functions are sometimes
75;; used in regular code as well, either in a "fast path" or to break a
76;; circularity (e.g., within compute-discriminating-function when the
77;; user adds a method to compute-discriminating-function).
78;;
79;; When hacking this file, note that some important parts are implemented
80;; in the Java world. These Java bits can be found in the files
81;;
82;; * LispClass.java
83;; * SlotClass.java
84;; * StandardClass.java
85;; * BuiltInClass.java
86;; * StandardObject.java
87;; * StandardObjectFunctions.java
88;; * FuncallableStandardObject.java
89;; * Layout.java
90;;
91;; In case of function names, those defined on the Java side can be
92;; recognized by their prefixed percent (%) sign.
93;;
94;; The API functions need to be declaimed NOTINLINE explicitly, because
95;; that prevents inlining in the current FASL (which is allowed by the
96;; CLHS without the declaration); this is a hard requirement to in order
97;; to be able to swap the symbol's function slot with a generic function
98;; later on - with it actually being used.
99;;
100;;
101;;
102;; ### Note that the "declares all API functions as regular functions"
103;; isn't true when I write the above, but it's definitely the target.
104;;
105;; A note about AMOP: the first chapters (and the sample Closette
106;; implementation) of the book sometimes deviate from the specification.
107;; For example, in the examples slot-value-using-class has the slot name
108;; as third argument where in the specification it is the effective slot
109;; definition.  When in doubt, we aim to follow the specification, the
110;; MOP test suite at http://common-lisp.net/project/closer/features.html
111;; and the behavior of other CL implementations in preference to
112;; chapters 1-4 and appendix D.
113
114(defconstant +the-standard-class+ (find-class 'standard-class))
115(defconstant +the-funcallable-standard-class+
116  (find-class 'funcallable-standard-class))
117(defconstant +the-structure-class+ (find-class 'structure-class))
118(defconstant +the-standard-object-class+ (find-class 'standard-object))
119(defconstant +the-funcallable-standard-object-class+
120  (find-class 'funcallable-standard-object))
121(defconstant +the-standard-method-class+ (find-class 'standard-method))
122(defconstant +the-forward-referenced-class+
123  (find-class 'forward-referenced-class))
124(defconstant +the-standard-generic-function-class+
125  (find-class 'standard-generic-function))
126(defconstant +the-T-class+ (find-class 'T))
127(defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition))
128(defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition))
129(defconstant +the-standard-effective-slot-definition-class+ (find-class 'standard-effective-slot-definition))
130
131;; Don't use DEFVAR, because that disallows loading clos.lisp
132;; after compiling it: the binding won't get assigned to T anymore
133(defparameter *clos-booting* t)
134
135(defmacro define-class->%class-forwarder (name)
136  (let* (($name (if (consp name) (cadr name) name))
137         (%name (intern (concatenate 'string
138                                     "%"
139                                     (if (consp name)
140                                         (symbol-name 'set-) "")
141                                     (symbol-name $name))
142                        (symbol-package $name))))
143    `(progn
144       (declaim (notinline ,name))
145       (defun ,name (&rest args)
146         (apply #',%name args)))))
147
148;;
149;;  DEFINE PLACE HOLDER FUNCTIONS
150;;
151
152(define-class->%class-forwarder class-name)
153(define-class->%class-forwarder (setf class-name))
154(define-class->%class-forwarder class-slots)
155(define-class->%class-forwarder (setf class-slots))
156(define-class->%class-forwarder class-direct-slots)
157(define-class->%class-forwarder (setf class-direct-slots))
158(define-class->%class-forwarder class-layout)
159(define-class->%class-forwarder (setf class-layout))
160(define-class->%class-forwarder class-direct-superclasses)
161(define-class->%class-forwarder (setf class-direct-superclasses))
162(define-class->%class-forwarder class-direct-subclasses)
163(define-class->%class-forwarder (setf class-direct-subclasses))
164(define-class->%class-forwarder class-direct-methods)
165(define-class->%class-forwarder (setf class-direct-methods))
166(define-class->%class-forwarder class-precedence-list)
167(define-class->%class-forwarder (setf class-precedence-list))
168(define-class->%class-forwarder class-finalized-p)
169(define-class->%class-forwarder (setf class-finalized-p))
170(define-class->%class-forwarder class-default-initargs)
171(define-class->%class-forwarder (setf class-default-initargs))
172(define-class->%class-forwarder class-direct-default-initargs)
173(define-class->%class-forwarder (setf class-direct-default-initargs))
174
175(declaim (notinline add-direct-subclass remove-direct-subclass))
176(defun add-direct-subclass (superclass subclass)
177  (setf (class-direct-subclasses superclass)
178        (adjoin subclass (class-direct-subclasses superclass))))
179(defun remove-direct-subclass (superclass subclass)
180  (setf (class-direct-subclasses superclass)
181        (remove subclass (class-direct-subclasses superclass))))
182
183(defun fixup-standard-class-hierarchy ()
184  ;; Make the result of class-direct-subclasses for the pre-built
185  ;; classes agree with AMOP Table 5.1 (pg. 141).  This could be done in
186  ;; StandardClass.java where these classes are defined, but it's less
187  ;; painful to do it Lisp-side.
188  (flet ((add-subclasses (class subclasses)
189           (when (atom subclasses) (setf subclasses (list subclasses)))
190           (setf (class-direct-subclasses (find-class class))
191                 (union (class-direct-subclasses (find-class class))
192                        (mapcar #'find-class subclasses)))))
193    (add-subclasses t 'standard-object)
194    (add-subclasses 'function 'funcallable-standard-object)
195    (add-subclasses 'standard-object '(funcallable-standard-object metaobject))
196    (add-subclasses 'metaobject
197                    '(generic-function method slot-definition specializer))
198    (add-subclasses 'specializer '(class))
199    (add-subclasses 'funcallable-standard-object 'generic-function)
200    (add-subclasses 'generic-function 'standard-generic-function)
201    (add-subclasses 'method 'standard-method)
202    (add-subclasses 'slot-definition
203                    '(direct-slot-definition effective-slot-definition
204                      standard-slot-definition))
205    (add-subclasses 'standard-slot-definition
206                    '(standard-direct-slot-definition
207                      standard-effective-slot-definition))
208    (add-subclasses 'direct-slot-definition 'standard-direct-slot-definition)
209    (add-subclasses 'effective-slot-definition
210                    'standard-effective-slot-definition)
211    (add-subclasses 'class
212                    '(built-in-class forward-referenced-class standard-class
213                      funcallable-standard-class))))
214(fixup-standard-class-hierarchy)
215
216(defun no-applicable-method (generic-function &rest args)
217  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
218         generic-function
219         args))
220
221(defun function-keywords (method)
222  (std-function-keywords method))
223
224(declaim (notinline map-dependents))
225(defun map-dependents (metaobject function)
226  ;; stub, will be redefined later
227  (declare (ignore metaobject function))
228  nil)
229
230(defmacro push-on-end (value location)
231  `(setf ,location (nconc ,location (list ,value))))
232
233;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
234;;; which must be non-nil.
235
236(defun (setf getf*) (new-value plist key)
237  (block body
238    (do ((x plist (cddr x)))
239        ((null x))
240      (when (eq (car x) key)
241        (setf (car (cdr x)) new-value)
242        (return-from body new-value)))
243    (push-on-end key plist)
244    (push-on-end new-value plist)
245    new-value))
246
247(defun mapappend (fun &rest args)
248  (if (some #'null args)
249      ()
250      (append (apply fun (mapcar #'car args))
251              (apply #'mapappend fun (mapcar #'cdr args)))))
252
253(defun mapplist (fun x)
254  (if (null x)
255      ()
256      (cons (funcall fun (car x) (cadr x))
257            (mapplist fun (cddr x)))))
258
259(defsetf std-instance-layout %set-std-instance-layout)
260(defsetf standard-instance-access %set-standard-instance-access)
261(defun funcallable-standard-instance-access (instance location)
262  (standard-instance-access instance location))
263(defsetf funcallable-standard-instance-access %set-standard-instance-access)
264
265(defun (setf find-class) (new-value symbol &optional errorp environment)
266  (declare (ignore errorp environment))
267  (%set-find-class symbol new-value))
268
269(defun canonicalize-direct-slots (direct-slots)
270  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
271
272(defun canonicalize-direct-slot (spec)
273  (if (symbolp spec)
274      `(list :name ',spec)
275      (let ((name (car spec))
276            (initfunction nil)
277            (initform nil)
278            (initargs ())
279            (type nil)
280            (allocation nil)
281            (documentation nil)
282            (readers ())
283            (writers ())
284            (other-options ())
285            (non-std-options ()))
286        (do ((olist (cdr spec) (cddr olist)))
287            ((null olist))
288          (case (car olist)
289            (:initform
290             (when initform
291               (error 'program-error
292                      "duplicate slot option :INITFORM for slot named ~S"
293                      name))
294             (setq initfunction t)
295             (setq initform (cadr olist)))
296            (:initarg
297             (push-on-end (cadr olist) initargs))
298            (:allocation
299             (when allocation
300               (error 'program-error
301                      "duplicate slot option :ALLOCATION for slot named ~S"
302                      name))
303             (setf allocation (cadr olist))
304             (push-on-end (car olist) other-options)
305             (push-on-end (cadr olist) other-options))
306            (:type
307             (when type
308               (error 'program-error
309                      "duplicate slot option :TYPE for slot named ~S"
310                      name))
311             (setf type (cadr olist)))
312            (:documentation
313             (when documentation
314               (error 'program-error
315                      "duplicate slot option :DOCUMENTATION for slot named ~S"
316                      name))
317             (setf documentation (cadr olist)))
318            (:reader
319             (maybe-note-name-defined (cadr olist))
320             (push-on-end (cadr olist) readers))
321            (:writer
322             (maybe-note-name-defined (cadr olist))
323             (push-on-end (cadr olist) writers))
324            (:accessor
325             (maybe-note-name-defined (cadr olist))
326             (push-on-end (cadr olist) readers)
327             (push-on-end `(setf ,(cadr olist)) writers))
328            (t
329             (push-on-end (cadr olist) (getf non-std-options (car olist))))))
330        `(list
331          :name ',name
332          ,@(when initfunction
333              `(:initform ',initform
334                :initfunction ,(if (eq allocation :class)
335                                   ;; CLHS specifies the initform for a
336                                   ;; class allocation level slot needs
337                                   ;; to be evaluated in the dynamic
338                                   ;; extent of the DEFCLASS form
339                                   (let ((var (gensym)))
340                                     `(let ((,var ,initform))
341                                        (lambda () ,var)))
342                                 `(lambda () ,initform))))
343          ,@(when initargs `(:initargs ',initargs))
344          ,@(when readers `(:readers ',readers))
345          ,@(when writers `(:writers ',writers))
346          ,@(when type `(:type ',type))
347          ,@(when documentation `(:documentation ',documentation))
348          ,@other-options
349          ,@(mapcar #'(lambda (opt) (if (or (atom opt) (/= 1 (length opt)))
350                                        `',opt
351                                        `',(car opt)))
352                    non-std-options)))))
353
354(defun maybe-note-name-defined (name)
355  (when (fboundp 'note-name-defined)
356    (note-name-defined name)))
357
358(defun canonicalize-defclass-options (options)
359  (mapappend #'canonicalize-defclass-option options))
360
361(defun canonicalize-defclass-option (option)
362  (case (car option)
363    (:metaclass
364     (list ':metaclass
365           `(find-class ',(cadr option))))
366    (:default-initargs
367     (list
368      ':direct-default-initargs
369      `(list ,@(mapplist
370                #'(lambda (key value)
371                    `(list ',key ',value ,(make-initfunction value)))
372                (cdr option)))))
373    ((:documentation :report)
374     (list (car option) `',(cadr option)))
375    (t (list `(quote ,(car option)) `(quote ,(cdr option))))))
376
377(defun make-initfunction (initform)
378  `(function (lambda () ,initform)))
379
380(defun slot-definition-allocation (slot-definition)
381  (%slot-definition-allocation slot-definition))
382
383(declaim (notinline (setf slot-definition-allocation)))
384(defun (setf slot-definition-allocation) (value slot-definition)
385  (set-slot-definition-allocation slot-definition value))
386
387(defun slot-definition-initargs (slot-definition)
388  (%slot-definition-initargs slot-definition))
389
390(declaim (notinline (setf slot-definition-initargs)))
391(defun (setf slot-definition-initargs) (value slot-definition)
392  (set-slot-definition-initargs slot-definition value))
393
394(defun slot-definition-initform (slot-definition)
395  (%slot-definition-initform slot-definition))
396
397(declaim (notinline (setf slot-definition-initform)))
398(defun (setf slot-definition-initform) (value slot-definition)
399  (set-slot-definition-initform slot-definition value))
400
401(defun slot-definition-initfunction (slot-definition)
402  (%slot-definition-initfunction slot-definition))
403
404(declaim (notinline (setf slot-definition-initfunction)))
405(defun (setf slot-definition-initfunction) (value slot-definition)
406  (set-slot-definition-initfunction slot-definition value))
407
408(defun slot-definition-name (slot-definition)
409  (%slot-definition-name slot-definition))
410
411(declaim (notinline (setf slot-definition-name)))
412(defun (setf slot-definition-name) (value slot-definition)
413  (set-slot-definition-name slot-definition value))
414
415(defun slot-definition-readers (slot-definition)
416  (%slot-definition-readers slot-definition))
417
418(declaim (notinline (setf slot-definition-readers)))
419(defun (setf slot-definition-readers) (value slot-definition)
420  (set-slot-definition-readers slot-definition value))
421
422(defun slot-definition-writers (slot-definition)
423  (%slot-definition-writers slot-definition))
424
425(declaim (notinline (setf slot-definition-writers)))
426(defun (setf slot-definition-writers) (value slot-definition)
427  (set-slot-definition-writers slot-definition value))
428
429(defun slot-definition-allocation-class (slot-definition)
430  (%slot-definition-allocation-class slot-definition))
431
432(declaim (notinline (setf slot-definition-allocation-class)))
433(defun (setf slot-definition-allocation-class) (value slot-definition)
434  (set-slot-definition-allocation-class slot-definition value))
435
436(defun slot-definition-location (slot-definition)
437  (%slot-definition-location slot-definition))
438
439(declaim (notinline (setf slot-definition-location-class)))
440(defun (setf slot-definition-location) (value slot-definition)
441  (set-slot-definition-location slot-definition value))
442
443(defun slot-definition-type (slot-definition)
444  (%slot-definition-type slot-definition))
445
446(declaim (notinline (setf slot-definition-type)))
447(defun (setf slot-definition-type) (value slot-definition)
448  (set-slot-definition-type slot-definition value))
449
450(defun slot-definition-documentation (slot-definition)
451  (%slot-definition-documentation slot-definition))
452
453(declaim (notinline (setf slot-definition-documentation)))
454(defun (setf slot-definition-documentation) (value slot-definition)
455  (set-slot-definition-documentation slot-definition value))
456
457(defun init-slot-definition (slot &key name
458                                    (initargs ())
459                                    (initform nil)
460                                    (initfunction nil)
461                                    (readers ())
462                                    (writers ())
463                                    (allocation :instance)
464                                    (allocation-class nil)
465                                    (type t)
466                                    (documentation nil))
467  (setf (slot-definition-name slot) name)
468  (setf (slot-definition-initargs slot) initargs)
469  (setf (slot-definition-initform slot) initform)
470  (setf (slot-definition-initfunction slot) initfunction)
471  (setf (slot-definition-readers slot) readers)
472  (setf (slot-definition-writers slot) writers)
473  (setf (slot-definition-allocation slot) allocation)
474  (setf (slot-definition-allocation-class slot) allocation-class)
475  (setf (slot-definition-type slot) type)
476  (setf (slot-definition-documentation slot) documentation)
477  slot)
478
479(declaim (notinline direct-slot-definition-class))
480(defun direct-slot-definition-class (class &rest args)
481  (declare (ignore class args))
482  +the-standard-direct-slot-definition-class+)
483
484(defun make-direct-slot-definition (class &rest args)
485  (let ((slot-class (apply #'direct-slot-definition-class class args)))
486    (if (eq slot-class +the-standard-direct-slot-definition-class+)
487        (let ((slot (make-slot-definition +the-standard-direct-slot-definition-class+)))
488          (apply #'init-slot-definition slot :allocation-class class args)
489          slot)
490        (progn
491          (let ((slot (apply #'make-instance slot-class :allocation-class class
492                             args)))
493            slot)))))
494
495(declaim (notinline effective-slot-definition-class))
496(defun effective-slot-definition-class (class &rest args)
497  (declare (ignore class args))
498  +the-standard-effective-slot-definition-class+)
499
500(defun make-effective-slot-definition (class &rest args)
501  (let ((slot-class (apply #'effective-slot-definition-class class args)))
502    (if (eq slot-class +the-standard-effective-slot-definition-class+)
503        (let ((slot (make-slot-definition +the-standard-effective-slot-definition-class+)))
504          (apply #'init-slot-definition slot args)
505          slot)
506        (progn
507          (let ((slot (apply #'make-instance slot-class args)))
508            slot)))))
509
510;;; finalize-inheritance
511
512(declaim (notinline compute-default-initargs))
513(defun compute-default-initargs (class)
514  (std-compute-default-initargs class))
515
516(defun std-compute-default-initargs (class)
517  (delete-duplicates
518   (mapcan #'(lambda (c)
519               (copy-list
520                (class-direct-default-initargs c)))
521           (class-precedence-list class))
522   :key #'car :from-end t))
523
524(defun std-finalize-inheritance (class)
525  ;; In case the class is already finalized, return
526  ;; immediately, as per AMOP.
527  (when (class-finalized-p class)
528    (return-from std-finalize-inheritance))
529  (setf (class-precedence-list class)
530   (funcall (if (eq (class-of class) +the-standard-class+)
531                #'std-compute-class-precedence-list
532                #'compute-class-precedence-list)
533            class))
534  (setf (class-slots class)
535        (funcall (if (eq (class-of class) +the-standard-class+)
536                     #'std-compute-slots
537                     #'compute-slots) class))
538  (let ((old-layout (class-layout class))
539        (length 0)
540        (instance-slots '())
541        (shared-slots '()))
542    (dolist (slot (class-slots class))
543      (case (slot-definition-allocation slot)
544        (:instance
545         (setf (slot-definition-location slot) length)
546         (incf length)
547         (push (slot-definition-name slot) instance-slots))
548        (:class
549         (unless (slot-definition-location slot)
550           (let ((allocation-class (slot-definition-allocation-class slot)))
551             (if (eq allocation-class class)
552                 ;; We initialize class slots here so they can be
553                 ;; accessed without creating a dummy instance.
554                 (let ((initfunction (slot-definition-initfunction slot)))
555                   (setf (slot-definition-location slot)
556                         (cons (slot-definition-name slot)
557                               (if initfunction
558                                   (funcall initfunction)
559                                   +slot-unbound+))))
560                 (setf (slot-definition-location slot)
561                       (slot-location allocation-class (slot-definition-name slot))))))
562         (push (slot-definition-location slot) shared-slots))))
563    (when old-layout
564      ;; Redefined class: initialize added shared slots.
565      (dolist (location shared-slots)
566        (let* ((slot-name (car location))
567               (old-location (layout-slot-location old-layout slot-name)))
568          (unless old-location
569            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
570                   (initfunction (slot-definition-initfunction slot-definition)))
571              (when initfunction
572                (setf (cdr location) (funcall initfunction))))))))
573    (setf (class-layout class)
574          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
575  (setf (class-default-initargs class)
576        (compute-default-initargs class))
577  (setf (class-finalized-p class) t))
578
579(declaim (notinline finalize-inheritance))
580(defun finalize-inheritance (class)
581  (std-finalize-inheritance class))
582
583
584;;; Class precedence lists
585
586(defun std-compute-class-precedence-list (class)
587  (let ((classes-to-order (collect-superclasses* class)))
588    (dolist (super classes-to-order)
589      (when (typep super 'forward-referenced-class)
590        (error "Can't compute class precedence list for class ~A ~
591                which depends on forward referenced class ~A." class super)))
592    (topological-sort classes-to-order
593                      (remove-duplicates
594                       (mapappend #'local-precedence-ordering
595                                  classes-to-order))
596                      #'std-tie-breaker-rule)))
597
598;;; topological-sort implements the standard algorithm for topologically
599;;; sorting an arbitrary set of elements while honoring the precedence
600;;; constraints given by a set of (X,Y) pairs that indicate that element
601;;; X must precede element Y.  The tie-breaker procedure is called when it
602;;; is necessary to choose from multiple minimal elements; both a list of
603;;; candidates and the ordering so far are provided as arguments.
604
605(defun topological-sort (elements constraints tie-breaker)
606  (let ((remaining-constraints constraints)
607        (remaining-elements elements)
608        (result ()))
609    (loop
610      (let ((minimal-elements
611             (remove-if
612              #'(lambda (class)
613                 (member class remaining-constraints
614                         :key #'cadr))
615              remaining-elements)))
616        (when (null minimal-elements)
617          (if (null remaining-elements)
618              (return-from topological-sort result)
619              (error "Inconsistent precedence graph.")))
620        (let ((choice (if (null (cdr minimal-elements))
621                          (car minimal-elements)
622                          (funcall tie-breaker
623                                   minimal-elements
624                                   result))))
625          (setq result (append result (list choice)))
626          (setq remaining-elements
627                (remove choice remaining-elements))
628          (setq remaining-constraints
629                (remove choice
630                        remaining-constraints
631                        :test #'member)))))))
632
633;;; In the event of a tie while topologically sorting class precedence lists,
634;;; the CLOS Specification says to "select the one that has a direct subclass
635;;; rightmost in the class precedence list computed so far."  The same result
636;;; is obtained by inspecting the partially constructed class precedence list
637;;; from right to left, looking for the first minimal element to show up among
638;;; the direct superclasses of the class precedence list constituent.
639;;; (There's a lemma that shows that this rule yields a unique result.)
640
641(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
642  (dolist (cpl-constituent (reverse cpl-so-far))
643    (let* ((supers (class-direct-superclasses cpl-constituent))
644           (common (intersection minimal-elements supers)))
645      (when (not (null common))
646        (return-from std-tie-breaker-rule (car common))))))
647
648;;; This version of collect-superclasses* isn't bothered by cycles in the class
649;;; hierarchy, which sometimes happen by accident.
650
651(defun collect-superclasses* (class)
652  (labels ((all-superclasses-loop (seen superclasses)
653                                  (let ((to-be-processed
654                                         (set-difference superclasses seen)))
655                                    (if (null to-be-processed)
656                                        superclasses
657                                        (let ((class-to-process
658                                               (car to-be-processed)))
659                                          (all-superclasses-loop
660                                           (cons class-to-process seen)
661                                           (union (class-direct-superclasses
662                                                   class-to-process)
663                                                  superclasses)))))))
664          (all-superclasses-loop () (list class))))
665
666;;; The local precedence ordering of a class C with direct superclasses C_1,
667;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
668
669(defun local-precedence-ordering (class)
670  (mapcar #'list
671          (cons class
672                (butlast (class-direct-superclasses class)))
673          (class-direct-superclasses class)))
674
675;;; Slot inheritance
676
677(defun std-compute-slots (class)
678  (let* ((all-slots (nreverse ;; Slots of base class should come first
679                     (mapappend #'(lambda (c) (reverse (class-direct-slots c)))
680                                (reverse (class-precedence-list class)))))
681         (all-names (remove-duplicates
682                     (mapcar 'slot-definition-name all-slots))))
683    (mapcar #'(lambda (name)
684               (funcall
685                (if (eq (class-of class) +the-standard-class+)
686                    #'std-compute-effective-slot-definition
687                    #'compute-effective-slot-definition)
688                class
689                name
690                (remove name all-slots
691                        :key 'slot-definition-name
692                        :test-not #'eq)))
693            all-names)))
694
695(defun std-compute-effective-slot-definition (class name direct-slots)
696  (let ((initer (find-if-not #'null direct-slots
697                             :key 'slot-definition-initfunction))
698        (documentation-slot (find-if-not #'null direct-slots
699                                         :key 'slot-definition-documentation))
700        (types (delete-duplicates
701                (delete t (mapcar #'slot-definition-type direct-slots))
702                :test #'equal)))
703    (make-effective-slot-definition
704     class
705     :name name
706     :initform (if initer
707                   (slot-definition-initform initer)
708                   nil)
709     :initfunction (if initer
710                       (slot-definition-initfunction initer)
711                       nil)
712     :initargs (remove-duplicates
713                (mapappend 'slot-definition-initargs
714                           direct-slots))
715     :allocation (slot-definition-allocation (car direct-slots))
716     :allocation-class (when (slot-boundp (car direct-slots)
717                                          'sys::allocation-class)
718                         ;;for some classes created in Java
719                         ;;(e.g. SimpleCondition) this slot is unbound
720                         (slot-definition-allocation-class (car direct-slots)))
721     :type (cond ((null types) t)
722                 ((= 1 (length types)) types)
723                 (t (list* 'and types)))
724     :documentation (if documentation-slot
725                        (documentation documentation-slot t)
726                        nil))))
727
728;;; Standard instance slot access
729
730;;; N.B. The location of the effective-slots slots in the class metaobject for
731;;; standard-class must be determined without making any further slot
732;;; references.
733
734(defun find-slot-definition (class slot-name)
735  (dolist (slot (class-slots class) nil)
736    (when (eq slot-name (slot-definition-name slot))
737      (return slot))))
738
739(defun slot-location (class slot-name)
740  (let ((slot (find-slot-definition class slot-name)))
741    (if slot
742        (slot-definition-location slot)
743        nil)))
744
745(defun instance-slot-location (instance slot-name)
746  (let ((layout (std-instance-layout instance)))
747    (and layout (layout-slot-location layout slot-name))))
748
749(defun slot-value (object slot-name)
750  (let* ((class (class-of object))
751         (metaclass (class-of class)))
752    (if (or (eq metaclass +the-standard-class+)
753            (eq metaclass +the-structure-class+)
754            (eq metaclass +the-funcallable-standard-class+))
755        (std-slot-value object slot-name)
756        (slot-value-using-class class object
757                                (find-slot-definition class slot-name)))))
758
759(defsetf std-slot-value set-std-slot-value)
760
761(defun %set-slot-value (object slot-name new-value)
762  (let* ((class (class-of object))
763         (metaclass (class-of class)))
764    (if (or (eq metaclass +the-standard-class+)
765            (eq metaclass +the-structure-class+)
766            (eq metaclass +the-funcallable-standard-class+))
767        (setf (std-slot-value object slot-name) new-value)
768        (setf (slot-value-using-class class object
769                                      (find-slot-definition class slot-name))
770              new-value))))
771
772(defsetf slot-value %set-slot-value)
773
774(defun slot-boundp (object slot-name)
775  (let* ((class (class-of object))
776         (metaclass (class-of class)))
777    (if (or (eq metaclass +the-standard-class+) 
778            (eq metaclass +the-funcallable-standard-class+))
779        (std-slot-boundp object slot-name)
780        (slot-boundp-using-class class object
781                                 (find-slot-definition class slot-name)))))
782
783(defun std-slot-makunbound (instance slot-name)
784  (let ((location (instance-slot-location instance slot-name)))
785    (cond ((fixnump location)
786           (setf (standard-instance-access instance location) +slot-unbound+))
787          ((consp location)
788           (setf (cdr location) +slot-unbound+))
789          (t
790           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
791  instance)
792
793(defun slot-makunbound (object slot-name)
794  (let* ((class (class-of object))
795         (metaclass (class-of class)))
796    (if (or (eq metaclass +the-standard-class+)
797            (eq metaclass +the-funcallable-standard-class+))
798        (std-slot-makunbound object slot-name)
799        (slot-makunbound-using-class class object
800                                     (find-slot-definition class slot-name)))))
801
802(defun std-slot-exists-p (instance slot-name)
803  (not (null (find slot-name (class-slots (class-of instance))
804                   :key 'slot-definition-name))))
805
806(defun slot-exists-p (object slot-name)
807  (if (eq (class-of (class-of object)) +the-standard-class+)
808      (std-slot-exists-p object slot-name)
809      (slot-exists-p-using-class (class-of object) object slot-name)))
810
811(defun instance-slot-p (slot)
812  (eq (slot-definition-allocation slot) :instance))
813
814(defun std-allocate-instance (class)
815  (sys::%std-allocate-instance class))
816
817(defun allocate-funcallable-instance (class)
818  (let ((instance (sys::%allocate-funcallable-instance class)))
819    (set-funcallable-instance-function
820     instance
821     #'(lambda (&rest args)
822         (declare (ignore args))
823         (error 'program-error "Called a funcallable-instance with unset function.")))
824    instance))
825
826(declaim (notinline class-prototype))
827(defun class-prototype (class)
828  (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class)))
829  (std-allocate-instance class))
830
831(defun maybe-finalize-class-subtree (class)
832  (when (every #'class-finalized-p (class-direct-superclasses class))
833    (finalize-inheritance class)
834    (dolist (subclass (class-direct-subclasses class))
835      (maybe-finalize-class-subtree subclass))))
836
837(defun make-instance-standard-class (metaclass
838                                     &rest initargs
839                                     &key name direct-superclasses direct-slots
840                                       direct-default-initargs
841                                       documentation)
842  (declare (ignore metaclass))
843  (let ((class (std-allocate-instance +the-standard-class+)))
844    (unless *clos-booting*
845      (check-initargs (list #'allocate-instance #'initialize-instance)
846                      (list* class initargs)
847                      class t initargs
848                      *make-instance-initargs-cache* 'make-instance))
849    (%set-class-name name class)
850    ;; KLUDGE: necessary in define-primordial-class, otherwise
851    ;; StandardClass.getClassLayout() throws an error
852    (unless *clos-booting* (%set-class-layout nil class))
853    (%set-class-direct-subclasses ()  class)
854    (%set-class-direct-methods ()  class)
855    (%set-class-documentation class documentation)
856    (std-after-initialization-for-classes class
857                                          :direct-superclasses direct-superclasses
858                                          :direct-slots direct-slots
859                                          :direct-default-initargs direct-default-initargs)
860    class))
861
862;(defun convert-to-direct-slot-definition (class canonicalized-slot)
863;  (apply #'make-instance
864;         (apply #'direct-slot-definition-class
865;                class canonicalized-slot)
866;         canonicalized-slot))
867
868(defun canonicalize-direct-superclass-list (class direct-superclasses)
869  (cond (direct-superclasses)
870        ((subtypep (class-of class) +the-funcallable-standard-class+)
871         (list +the-funcallable-standard-object-class+))
872        ((subtypep (class-of class) +the-standard-class+)
873         (list +the-standard-object-class+))))
874
875(defun std-after-initialization-for-classes (class
876                                             &key direct-superclasses direct-slots
877                                             direct-default-initargs
878                                             &allow-other-keys)
879  (let ((supers (canonicalize-direct-superclass-list class direct-superclasses)))
880    (setf (class-direct-superclasses class) supers)
881    (dolist (superclass supers)
882      (add-direct-subclass superclass class)))
883  (let ((slots (mapcar #'(lambda (slot-properties)
884                          (apply #'make-direct-slot-definition class slot-properties))
885                       direct-slots)))
886    (setf (class-direct-slots class) slots)
887    (dolist (direct-slot slots)
888      (dolist (reader (slot-definition-readers direct-slot))
889        (add-reader-method class reader direct-slot))
890      (dolist (writer (slot-definition-writers direct-slot))
891        (add-writer-method class writer direct-slot))))
892  (setf (class-direct-default-initargs class) direct-default-initargs)
893  (maybe-finalize-class-subtree class)
894  (values))
895
896;;; Bootstrap the lower parts of the metaclass hierarchy.
897
898(defmacro define-primordial-class (name superclasses direct-slots)
899  "Primitive class definition tool.
900No non-standard metaclasses, accessor methods, duplicate slots,
901non-existent superclasses, default initargs, or other complicated stuff.
902Handle with care."
903  (let ((class (gensym)))
904    `(let ((,class (make-instance-standard-class
905                    nil
906                    :name ',name
907                    :direct-superclasses ',(mapcar #'find-class superclasses)
908                    :direct-slots ,(canonicalize-direct-slots direct-slots))))
909       (%set-find-class ',name ,class)
910       ,class)))
911
912(define-primordial-class eql-specializer (specializer)
913  ((object :initform nil)
914   (direct-methods :initform nil)))
915
916(define-primordial-class method-combination (metaobject)
917  ((sys::name :initarg :name :initform nil)
918   (sys::%documentation :initarg :documentation :initform nil)
919   (options :initarg :options :initform nil)))
920
921(define-primordial-class short-method-combination (method-combination)
922  ((operator :initarg :operator)
923   (identity-with-one-argument :initarg :identity-with-one-argument)))
924
925(define-primordial-class long-method-combination (method-combination)
926  ((sys::lambda-list :initarg :lambda-list)
927   (method-group-specs :initarg :method-group-specs)
928   (args-lambda-list :initarg :args-lambda-list)
929   (generic-function-symbol :initarg :generic-function-symbol)
930   (function :initarg :function)
931   (arguments :initarg :arguments)
932   (declarations :initarg :declarations)
933   (forms :initarg :forms)))
934
935(define-primordial-class standard-accessor-method (standard-method)
936  ((sys::%slot-definition :initarg :slot-definition :initform nil)))
937
938(define-primordial-class standard-reader-method (standard-accessor-method)
939  ())
940(defconstant +the-standard-reader-method-class+
941  (find-class 'standard-reader-method))
942
943(define-primordial-class standard-writer-method (standard-accessor-method)
944  ())
945(defconstant +the-standard-writer-method-class+
946  (find-class 'standard-writer-method))
947
948
949(defvar *extensible-built-in-classes*
950  (list (find-class 'sequence)
951        (find-class 'java:java-object)))
952
953(defvar *make-instance-initargs-cache*
954  (make-hash-table :test #'eq)
955  "Cached sets of allowable initargs, keyed on the class they belong to.")
956(defvar *reinitialize-instance-initargs-cache*
957  (make-hash-table :test #'eq)
958  "Cached sets of allowable initargs, keyed on the class they belong to.")
959
960(defun expand-long-defcombin (name args)
961  (destructuring-bind (lambda-list method-groups &rest body) args
962    `(apply #'define-long-form-method-combination
963            ',name
964            ',lambda-list
965            (list ,@(mapcar #'canonicalize-method-group-spec method-groups))
966            ',body)))
967
968;;; The class method-combination and its subclasses are defined in
969;;; StandardClass.java, but we cannot use make-instance and slot-value
970;;; yet.
971
972(defun %make-long-method-combination (&key name documentation lambda-list
973                                       method-group-specs args-lambda-list
974                                       generic-function-symbol function
975                                       arguments declarations forms)
976  (let ((instance (std-allocate-instance (find-class 'long-method-combination))))
977    (setf (std-slot-value instance 'sys::name) name)
978    (setf (std-slot-value instance 'sys:%documentation) documentation)
979    (setf (std-slot-value instance 'sys::lambda-list) lambda-list)
980    (setf (std-slot-value instance 'method-group-specs) method-group-specs)
981    (setf (std-slot-value instance 'args-lambda-list) args-lambda-list)
982    (setf (std-slot-value instance 'generic-function-symbol)
983          generic-function-symbol)
984    (setf (std-slot-value instance 'function) function)
985    (setf (std-slot-value instance 'arguments) arguments)
986    (setf (std-slot-value instance 'declarations) declarations)
987    (setf (std-slot-value instance 'forms) forms)
988    (setf (std-slot-value instance 'options) nil)
989    instance))
990
991(defun method-combination-name (method-combination)
992  (check-type method-combination method-combination)
993  (std-slot-value method-combination 'sys::name))
994
995(defun method-combination-documentation (method-combination)
996  (check-type method-combination method-combination)
997  (std-slot-value method-combination 'sys:%documentation))
998
999(defun short-method-combination-operator (method-combination)
1000  (check-type method-combination short-method-combination)
1001  (std-slot-value method-combination 'operator))
1002
1003(defun short-method-combination-identity-with-one-argument (method-combination)
1004  (check-type method-combination short-method-combination)
1005  (std-slot-value method-combination 'identity-with-one-argument))
1006
1007(defun long-method-combination-lambda-list (method-combination)
1008  (check-type method-combination long-method-combination)
1009  (std-slot-value method-combination 'sys::lambda-list))
1010
1011(defun long-method-combination-method-group-specs (method-combination)
1012  (check-type method-combination long-method-combination)
1013  (std-slot-value method-combination 'method-group-specs))
1014
1015(defun long-method-combination-args-lambda-list (method-combination)
1016  (check-type method-combination long-method-combination)
1017  (std-slot-value method-combination 'args-lambda-list))
1018
1019(defun long-method-combination-generic-function-symbol (method-combination)
1020  (check-type method-combination long-method-combination)
1021  (std-slot-value method-combination 'generic-function-symbol))
1022
1023(defun long-method-combination-function (method-combination)
1024  (check-type method-combination long-method-combination)
1025  (std-slot-value method-combination 'function))
1026
1027(defun long-method-combination-arguments (method-combination)
1028  (check-type method-combination long-method-combination)
1029  (std-slot-value method-combination 'arguments))
1030
1031(defun long-method-combination-declarations (method-combination)
1032  (check-type method-combination long-method-combination)
1033  (std-slot-value method-combination 'declarations))
1034
1035(defun long-method-combination-forms (method-combination)
1036  (check-type method-combination long-method-combination)
1037  (std-slot-value method-combination 'forms))
1038
1039
1040(defun expand-short-defcombin (whole)
1041  (let* ((name (cadr whole))
1042         (documentation
1043          (getf (cddr whole) :documentation ""))
1044         (identity-with-one-arg
1045          (getf (cddr whole) :identity-with-one-argument nil))
1046         (operator
1047          (getf (cddr whole) :operator name)))
1048    `(progn
1049       (let ((instance (std-allocate-instance
1050                        (find-class 'short-method-combination))))
1051         (setf (std-slot-value instance 'sys::name) ',name)
1052         (setf (std-slot-value instance 'sys:%documentation) ',documentation)
1053         (setf (std-slot-value instance 'operator) ',operator)
1054         (setf (std-slot-value instance 'identity-with-one-argument)
1055               ',identity-with-one-arg)
1056         (setf (std-slot-value instance 'options) nil)
1057         (setf (get ',name 'method-combination-object) instance)
1058         ',name))))
1059
1060(defmacro define-method-combination (&whole form name &rest args)
1061  (if (and (cddr form)
1062           (listp (caddr form)))
1063      (expand-long-defcombin name args)
1064      (expand-short-defcombin form)))
1065
1066(define-method-combination +      :identity-with-one-argument t)
1067(define-method-combination and    :identity-with-one-argument t)
1068(define-method-combination append :identity-with-one-argument nil)
1069(define-method-combination list   :identity-with-one-argument nil)
1070(define-method-combination max    :identity-with-one-argument t)
1071(define-method-combination min    :identity-with-one-argument t)
1072(define-method-combination nconc  :identity-with-one-argument t)
1073(define-method-combination or     :identity-with-one-argument t)
1074(define-method-combination progn  :identity-with-one-argument t)
1075
1076;;;
1077;;; long form of define-method-combination (from Sacla and XCL)
1078;;;
1079(defun method-group-p (selecter qualifiers)
1080  ;; selecter::= qualifier-pattern | predicate
1081  (etypecase selecter
1082    (list (or (equal selecter qualifiers)
1083              (let ((last (last selecter)))
1084                (when (eq '* (cdr last))
1085                  (let* ((prefix `(,@(butlast selecter) ,(car last)))
1086                         (pos (mismatch prefix qualifiers)))
1087                    (or (null pos) (= pos (length prefix))))))))
1088    ((eql *) t)
1089    (symbol (funcall (symbol-function selecter) qualifiers))))
1090
1091(defun check-variable-name (name)
1092  (flet ((valid-variable-name-p (name)
1093                                (and (symbolp name) (not (constantp name)))))
1094    (assert (valid-variable-name-p name))))
1095
1096(defun canonicalize-method-group-spec (spec)
1097  ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]])
1098  ;; long-form-option::= :description description | :order order |
1099  ;;                     :required required-p
1100  ;; a canonicalized-spec is a simple plist.
1101  (let* ((rest spec)
1102         (name (prog2 (check-variable-name (car rest))
1103                 (car rest)
1104                 (setq rest (cdr rest))))
1105         (option-names '(:description :order :required))
1106         (selecters (let ((end (or (position-if #'(lambda (it)
1107                                                   (member it option-names))
1108                                                rest)
1109                                   (length rest))))
1110                      (prog1 (subseq rest 0 end)
1111                        (setq rest (subseq rest end)))))
1112         (description (getf rest :description ""))
1113         (order (getf rest :order :most-specific-first))
1114         (required-p (getf rest :required)))
1115    `(list :name ',name
1116           :predicate (lambda (qualifiers)
1117                        (loop for item in ',selecters
1118                          thereis (method-group-p item qualifiers)))
1119           :description ',description
1120           :order ',order
1121           :required ',required-p
1122           :*-selecter ,(equal selecters '(*)))))
1123
1124(defun extract-required-part (lambda-list)
1125  (flet ((skip (key lambda-list)
1126               (if (eq (first lambda-list) key)
1127                   (cddr lambda-list)
1128                   lambda-list)))
1129    (let* ((trimmed-lambda-list
1130            (skip '&environment (skip '&whole lambda-list)))
1131           (after-required-lambda-list
1132            (member-if #'(lambda (it) (member it lambda-list-keywords))
1133                       trimmed-lambda-list)))
1134      (if after-required-lambda-list
1135        (ldiff trimmed-lambda-list after-required-lambda-list)
1136        trimmed-lambda-list))))
1137
1138(defun extract-specified-part (key lambda-list)
1139  (case key
1140    ((&eval &whole)
1141     (list (second (member key lambda-list))))
1142    (t
1143     (let ((here (cdr (member key lambda-list))))
1144       (ldiff here
1145              (member-if #'(lambda (it) (member it lambda-list-keywords))
1146                         here))))))
1147
1148(defun extract-optional-part (lambda-list)
1149  (extract-specified-part '&optional lambda-list))
1150
1151(defun parse-define-method-combination-args-lambda-list (lambda-list)
1152  ;; Define-method-combination Arguments Lambda Lists
1153  ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm
1154  (let ((required (extract-required-part lambda-list))
1155        (whole    (extract-specified-part '&whole    lambda-list))
1156        (optional (extract-specified-part '&optional lambda-list))
1157        (rest     (extract-specified-part '&rest     lambda-list))
1158        (keys     (extract-specified-part '&key      lambda-list))
1159        (aux      (extract-specified-part '&aux      lambda-list)))
1160    (values (first whole)
1161            required
1162            (mapcar #'(lambda (spec)
1163                       (if (consp spec)
1164                           `(,(first spec) ,(second spec) ,@(cddr spec))
1165                           `(,spec nil)))
1166                    optional)
1167            (first rest)
1168            (mapcar #'(lambda (spec)
1169                       (let ((key (if (consp spec) (car spec) spec))
1170                             (rest (when (consp spec) (rest spec))))
1171                         `(,(if (consp key) key `(,(make-keyword key) ,key))
1172                           ,(car rest)
1173                           ,@(cdr rest))))
1174                    keys)
1175            (mapcar #'(lambda (spec)
1176                       (if (consp spec)
1177                           `(,(first spec) ,(second spec))
1178                           `(,spec nil)))
1179                    aux))))
1180
1181(defun wrap-with-call-method-macro (gf args-var emf-form)
1182  `(macrolet
1183       ((call-method (method &optional next-method-list)
1184          `(funcall
1185            ,(cond
1186              ((listp method)
1187               (assert (eq (first method) 'make-method))
1188               ;; by generating an inline expansion we prevent allocation
1189               ;; of a method instance which will be discarded immediately
1190               ;; after reading the METHOD-FUNCTION slot
1191               (compute-method-function
1192                    `(lambda (&rest ,(gensym))
1193                       ;; the MAKE-METHOD body form gets evaluated in
1194                       ;; the null lexical environment augmented
1195                       ;; with a binding for CALL-METHOD
1196                       ,(wrap-with-call-method-macro ,gf
1197                                                     ',args-var
1198                                                     (second method)))))
1199              (t (method-function method)))
1200            ,',args-var
1201            ,(unless (null next-method-list)
1202                     ;; by not generating an emf when there are no next methods,
1203                     ;; we ensure next-method-p returns NIL
1204                     (compute-effective-method
1205                      ,gf (generic-function-method-combination ,gf)
1206                      (process-next-method-list next-method-list))))))
1207     ,emf-form))
1208
1209(defun assert-unambiguous-method-sorting (group-name methods)
1210  (let ((specializers (make-hash-table :test 'equal)))
1211    (dolist (method methods)
1212      (push method (gethash (method-specializers method) specializers)))
1213    (loop for specializer-methods being each hash-value of specializers
1214       using (hash-key method-specializers)
1215       unless (= 1 (length specializer-methods))
1216       do (error "Ambiguous method sorting in method group ~A due to multiple ~
1217                  methods with specializers ~S: ~S"
1218                 group-name method-specializers specializer-methods))))
1219
1220(defmacro with-method-groups (method-group-specs methods-form &body forms)
1221  (flet ((grouping-form (spec methods-var)
1222           (let ((predicate (coerce-to-function (getf spec :predicate)))
1223                 (group (gensym))
1224                 (leftovers (gensym))
1225                 (method (gensym)))
1226             `(let ((,group '())
1227                    (,leftovers '()))
1228                (dolist (,method ,methods-var)
1229                  (if (funcall ,predicate (method-qualifiers ,method))
1230                      (push ,method ,group)
1231                      (push ,method ,leftovers)))
1232                (ecase ,(getf spec :order)
1233                  (:most-specific-last )
1234                  (:most-specific-first (setq ,group (nreverse ,group))))
1235                ,@(when (getf spec :required)
1236                        `((when (null ,group)
1237                            (error "Method group ~S must not be empty."
1238                                   ',(getf spec :name)))))
1239                (setq ,methods-var (nreverse ,leftovers))
1240                ,group))))
1241    (let ((rest (gensym))
1242          (method (gensym)))
1243      `(let* ((,rest ,methods-form)
1244              ,@(mapcar #'(lambda (spec)
1245                           `(,(getf spec :name) ,(grouping-form spec rest)))
1246                        method-group-specs))
1247         (dolist (,method ,rest)
1248           (invalid-method-error ,method
1249                                 "Method ~S with qualifiers ~S does not belong to any method group."
1250                                 ,method (method-qualifiers ,method)))
1251         ,@(unless (and (= 1 (length method-group-specs))
1252                        (getf (car method-group-specs) :*-selecter))
1253             (mapcar #'(lambda (spec)
1254                         `(assert-unambiguous-method-sorting ',(getf spec :name) ,(getf spec :name)))
1255                     method-group-specs))
1256         ,@forms))))
1257
1258(defun method-combination-type-lambda-with-args-emf
1259    (&key args-lambda-list generic-function-symbol forms &allow-other-keys)
1260  (multiple-value-bind
1261        (whole required optional rest keys aux)
1262      (parse-define-method-combination-args-lambda-list args-lambda-list)
1263    (unless rest
1264      (when keys
1265        (setf rest (gensym))))
1266    (let* ((gf-lambda-list (gensym))
1267           (args-var (gensym))
1268           (args-len-var (gensym))
1269           (binding-forms (gensym))
1270           (needs-args-len-var (gensym))
1271           (emf-form (gensym)))
1272      `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol
1273                                           'sys::lambda-list))
1274              (nreq (length (extract-required-part ,gf-lambda-list)))
1275              (nopt (length (extract-optional-part ,gf-lambda-list)))
1276              (,binding-forms)
1277              (,needs-args-len-var)
1278              (,emf-form
1279               (let* (,@(when whole
1280                              `((,whole (progn
1281                                          (push `(,',whole ,',args-var)
1282                                                ,binding-forms)
1283                                          ',args-var))))
1284                      ,@(when rest
1285                              ;; ### TODO: use a fresh symbol for the rest
1286                              ;;   binding being generated and pushed into binding-forms
1287                              `((,rest (progn
1288                                         (push `(,',rest
1289                                                 (subseq ,',args-var
1290                                                          ,(+ nreq nopt)))
1291                                               ,binding-forms)
1292                                         ',rest))))
1293                        ,@(loop for var in required and i upfrom 0
1294                               for var-binding = (gensym)
1295                             collect `(,var (when (< ,i nreq)
1296                                              (push `(,',var-binding
1297                                                      (nth ,,i ,',args-var))
1298                                                    ,binding-forms)
1299                                              ',var-binding)))
1300                        ,@(loop for (var initform supplied-var) in optional
1301                             and i upfrom 0
1302                             for supplied-binding = (or supplied-var (gensym))
1303                             for var-binding = (gensym)
1304                             ;; check for excess parameters
1305                             ;; only assign initform if the parameter
1306                             ;; isn't in excess: the spec says explicitly
1307                             ;; to bind parameters in excess to forms evaluating
1308                             ;; to nil.
1309                             ;; This leaves initforms to be used with
1310                             ;; parameters not supplied in excess, but
1311                             ;; not available in the arguments list
1312                             ;;
1313                             ;; Also, if specified, bind "supplied-p"
1314                             collect `(,supplied-binding
1315                                       (when (< ,i nopt)
1316                                         (setq ,needs-args-len-var t)
1317                              ;; ### TODO: use a fresh symbol for the supplied binding
1318                              ;;   binding being generated and pushed into binding-forms
1319                                         (push `(,',supplied-binding
1320                                                 (< ,(+ ,i nreq) ,',args-len-var))
1321                                               ,binding-forms)
1322                                         ',supplied-binding))
1323                             collect `(,var (when (< ,i nopt)
1324                                              (push `(,',var-binding
1325                                                      (if ,',supplied-binding
1326                                                          (nth ,(+ ,i nreq)
1327                                                               ,',args-var)
1328                                                          ,',initform))
1329                                                    ,binding-forms)
1330                                              ',var-binding)))
1331                        ,@(loop for ((key var) initform supplied-var) in keys
1332                             for supplied-binding = (or supplied-var (gensym))
1333                             for var-binding = (gensym)
1334                             ;; Same as optional parameters:
1335                             ;; even though keywords can't be supplied in
1336                             ;; excess, we should bind "supplied-p" in case
1337                             ;; the key isn't supplied in the arguments list
1338                             collect `(,supplied-binding
1339                                       (progn
1340                              ;; ### TODO: use a fresh symbol for the rest
1341                              ;;   binding being generated and pushed into binding-forms
1342                                         (push `(,',supplied-binding
1343                                                 (member ,',key ,',rest))
1344                                               ,binding-forms)
1345                                         ',supplied-binding))
1346                             collect `(,var (progn
1347                                              (push `(,',var-binding
1348                                                      (if ,',supplied-binding
1349                                                          (cadr ,',supplied-binding)
1350                                                          ,',initform))
1351                                                    ,binding-forms)
1352                                              ',var-binding)))
1353                        ,@(loop for (var initform) in aux
1354                             for var-binding = (gensym)
1355                             collect `(,var (progn
1356                                              (push '(,var-binding ,initform)
1357                                                    ,binding-forms)
1358                                              ',var-binding))))
1359                 ,@forms)))
1360         `(lambda (,',args-var)
1361            ;; set up bindings to ensure the expressions to which the
1362            ;; variables of the arguments option have been bound are
1363            ;; evaluated exactly once.
1364            (let* (,@(when ,needs-args-len-var
1365                           `((,',args-len-var (length ,',args-var))))
1366                   ,@(reverse ,binding-forms))
1367              ;; This is the lambda which *is* the effective method
1368              ;; hence gets called on every method invocation
1369              ;; be as efficient in this method as we can be
1370              ,(wrap-with-call-method-macro ,generic-function-symbol
1371                                            ',args-var ,emf-form)))))))
1372
1373(defun method-combination-type-lambda
1374  (&rest all-args
1375   &key name lambda-list args-lambda-list generic-function-symbol
1376        method-group-specs declarations forms &allow-other-keys)
1377  (declare (ignore name))
1378  (let ((methods (gensym))
1379        (args-var (gensym))
1380        (emf-form (gensym)))
1381    `(lambda (,generic-function-symbol ,methods ,@lambda-list)
1382       ;; This is the lambda which computes the effective method
1383       ,@declarations
1384       (with-method-groups ,method-group-specs
1385           ,methods
1386         ,(if (null args-lambda-list)
1387              `(let ((,emf-form (progn ,@forms)))
1388                 `(lambda (,',args-var)
1389                    ;; This is the lambda which *is* the effective method
1390                    ;; hence gets called on every method invocation
1391                    ;; be as efficient in this method as we can be
1392                    ,(wrap-with-call-method-macro ,generic-function-symbol
1393                                                  ',args-var ,emf-form)))
1394              (apply #'method-combination-type-lambda-with-args-emf all-args))))))
1395
1396(defun declarationp (expr)
1397  (and (consp expr) (eq (car expr) 'DECLARE)))
1398
1399(defun long-form-method-combination-args (args)
1400  ;; define-method-combination name lambda-list (method-group-specifier*) args
1401  ;; args ::= [(:arguments . args-lambda-list)]
1402  ;;          [(:generic-function generic-function-symbol)]
1403  ;;          [[declaration* | documentation]] form*
1404  (let ((rest args))
1405    (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest))))
1406             (args-lambda-list ()
1407               (when (nextp :arguments)
1408                 (prog1 (cdr (car rest)) (setq rest (cdr rest)))))
1409             (generic-function-symbol ()
1410                (if (nextp :generic-function)
1411                    (prog1 (second (car rest)) (setq rest (cdr rest)))
1412                    (gensym)))
1413             (declaration* ()
1414               (let ((end (position-if-not #'declarationp rest)))
1415                 (when end
1416                   (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
1417             (documentation? ()
1418               (when (stringp (car rest))
1419                 (prog1 (car rest) (setq rest (cdr rest)))))
1420             (form* () rest))
1421      (let ((declarations '()))
1422        `(:args-lambda-list ,(args-lambda-list)
1423                            :generic-function-symbol ,(generic-function-symbol)
1424                            :documentation ,(prog2 (setq declarations (declaration*))
1425                                              (documentation?))
1426                            :declarations (,@declarations ,@(declaration*))
1427                            :forms ,(form*))))))
1428
1429(defun define-long-form-method-combination (name lambda-list method-group-specs
1430                                                 &rest args)
1431  (let* ((initargs `(:name ,name
1432                     :lambda-list ,lambda-list
1433                     :method-group-specs ,method-group-specs
1434                     ,@(long-form-method-combination-args args)))
1435         (lambda-expression (apply #'method-combination-type-lambda initargs)))
1436    (setf (get name 'method-combination-object)
1437          (apply '%make-long-method-combination
1438                 :function (coerce-to-function lambda-expression) initargs))
1439    name))
1440
1441(defun std-find-method-combination (gf name options)
1442  (declare (ignore gf))
1443  (when (and (eql name 'standard) options)
1444    ;; CLHS DEFGENERIC
1445    (error "The standard method combination does not accept any arguments."))
1446  (let ((mc (get name 'method-combination-object)))
1447    (cond
1448      ((null mc) (error "Method combination ~S not found" name))
1449      ((null options) mc)
1450      ((typep mc 'short-method-combination)
1451       (make-instance
1452        'short-method-combination
1453        :name name
1454        :documentation (method-combination-documentation mc)
1455        :operator (short-method-combination-operator mc)
1456        :identity-with-one-argument
1457        (short-method-combination-identity-with-one-argument mc)
1458        :options options))
1459      ((typep mc 'long-method-combination)
1460       (make-instance
1461        'long-method-combination
1462        :name name
1463        :documentation (method-combination-documentation mc)
1464        :lambda-list (long-method-combination-lambda-list mc)
1465        :method-group-specs (long-method-combination-method-group-specs mc)
1466        :args-lambda-list (long-method-combination-args-lambda-list mc)
1467        :generic-function-symbol (long-method-combination-generic-function-symbol mc)
1468        :function (long-method-combination-function mc)
1469        :arguments (long-method-combination-arguments mc)
1470        :declarations (long-method-combination-declarations mc)
1471        :forms (long-method-combination-forms mc)
1472        :options options)))))
1473
1474(declaim (notinline find-method-combination))
1475(defun find-method-combination (gf name options)
1476  (std-find-method-combination gf name options))
1477
1478(defconstant +the-standard-method-combination+
1479  (let ((instance (std-allocate-instance (find-class 'method-combination))))
1480    (setf (std-slot-value instance 'sys::name) 'standard)
1481    (setf (std-slot-value instance 'sys:%documentation)
1482          "The standard method combination.")
1483    (setf (std-slot-value instance 'options) nil)
1484    instance)
1485  "The standard method combination.
1486Do not use this object for identity since it changes between
1487compile-time and run-time.  To detect the standard method combination,
1488compare the method combination name to the symbol 'standard.")
1489(setf (get 'standard 'method-combination-object) +the-standard-method-combination+)
1490
1491(defparameter *eql-specializer-table* (make-hash-table :test 'eql))
1492
1493(defun intern-eql-specializer (object)
1494  (or (gethash object *eql-specializer-table*)
1495      (setf (gethash object *eql-specializer-table*)
1496            ;; we will be called during generic function invocation
1497            ;; setup, so have to rely on plain functions here.
1498            (let ((instance (std-allocate-instance (find-class 'eql-specializer))))
1499              (setf (std-slot-value instance 'object) object)
1500              (setf (std-slot-value instance 'direct-methods) nil)
1501              instance))))
1502
1503(defun eql-specializer-object (eql-specializer)
1504  (check-type eql-specializer eql-specializer)
1505  (std-slot-value eql-specializer 'object))
1506
1507;;; Initial versions of some method metaobject readers.  Defined on
1508;;; AMOP pg. 218ff, will be redefined when generic functions are set up.
1509
1510(defun std-method-function (method)
1511  (std-slot-value method 'sys::%function))
1512
1513(defun std-method-generic-function (method)
1514  (std-slot-value method 'sys::%generic-function))
1515
1516(defun std-method-specializers (method)
1517  (std-slot-value method 'sys::specializers))
1518
1519(defun std-method-qualifiers (method)
1520  (std-slot-value method 'sys::qualifiers))
1521
1522(defun std-accessor-method-slot-definition (accessor-method)
1523  (std-slot-value accessor-method 'sys::%slot-definition))
1524
1525;;; Additional method readers
1526(defun std-method-fast-function (method)
1527  (std-slot-value method 'sys::fast-function))
1528
1529(defun std-function-keywords (method)
1530  (values (std-slot-value method 'sys::keywords)
1531          (std-slot-value method 'sys::other-keywords-p)))
1532
1533;;; Preliminary accessor definitions, will be redefined as generic
1534;;; functions later in this file
1535
1536(declaim (notinline method-generic-function))
1537(defun method-generic-function (method)
1538  (std-method-generic-function method))
1539
1540(declaim (notinline method-function))
1541(defun method-function (method)
1542  (std-method-function method))
1543
1544(declaim (notinline method-specializers))
1545(defun method-specializers (method)
1546  (std-method-specializers method))
1547
1548(declaim (notinline method-qualifiers))
1549(defun method-qualifiers (method)
1550  (std-method-qualifiers method))
1551
1552
1553
1554;; MOP (p. 216) specifies the following reader generic functions:
1555;;   generic-function-argument-precedence-order
1556;;   generic-function-declarations
1557;;   generic-function-lambda-list
1558;;   generic-function-method-class
1559;;   generic-function-method-combination
1560;;   generic-function-methods
1561;;   generic-function-name
1562
1563;;; These are defined with % in package SYS, defined as functions here
1564;;; and redefined as generic functions once we're all set up.
1565
1566(defun generic-function-name (gf)
1567  (%generic-function-name gf))
1568
1569(defun generic-function-lambda-list (gf)
1570  (%generic-function-lambda-list gf))
1571(defsetf generic-function-lambda-list %set-generic-function-lambda-list)
1572
1573(defun (setf generic-function-documentation) (new-value gf)
1574  (set-generic-function-documentation gf new-value))
1575
1576(defun (setf generic-function-initial-methods) (new-value gf)
1577  (set-generic-function-initial-methods gf new-value))
1578
1579(defun generic-function-methods (gf)
1580  (sys:%generic-function-methods gf))
1581(defun (setf generic-function-methods) (new-value gf)
1582  (set-generic-function-methods gf new-value))
1583
1584(defun generic-function-method-class (gf)
1585  (sys:%generic-function-method-class gf))
1586(defun (setf generic-function-method-class) (new-value gf)
1587  (set-generic-function-method-class gf new-value))
1588
1589(defun generic-function-method-combination (gf)
1590  (sys:%generic-function-method-combination gf))
1591(defun (setf generic-function-method-combination) (new-value gf)
1592  (assert (typep new-value 'method-combination))
1593  (set-generic-function-method-combination gf new-value))
1594
1595(defun generic-function-argument-precedence-order (gf)
1596  (sys:%generic-function-argument-precedence-order gf))
1597(defun (setf generic-function-argument-precedence-order) (new-value gf)
1598  (set-generic-function-argument-precedence-order gf new-value))
1599
1600(declaim (ftype (function * t) classes-to-emf-table))
1601(defun classes-to-emf-table (gf)
1602  (generic-function-classes-to-emf-table gf))
1603
1604(defun (setf classes-to-emf-table) (new-value gf)
1605  (set-generic-function-classes-to-emf-table gf new-value))
1606
1607(defun (setf method-lambda-list) (new-value method)
1608  (setf (std-slot-value method 'sys::lambda-list) new-value))
1609
1610(defun (setf method-qualifiers) (new-value method)
1611  (setf (std-slot-value method 'sys::qualifiers) new-value))
1612
1613(defun method-documentation (method)
1614  (std-slot-value method 'sys:%documentation))
1615
1616(defun (setf method-documentation) (new-value method)
1617  (setf (std-slot-value method 'sys:%documentation) new-value))
1618
1619;;; defgeneric
1620
1621(defmacro defgeneric (function-name lambda-list
1622                                    &rest options-and-method-descriptions)
1623  (let ((options ())
1624        (methods ())
1625        (declarations ())
1626        (documentation nil))
1627    (dolist (item options-and-method-descriptions)
1628      (case (car item)
1629        (declare
1630         (setf declarations (append declarations (cdr item))))
1631        (:documentation
1632         (when documentation
1633           (error 'program-error
1634                  :format-control "Documentation option was specified twice for generic function ~S."
1635                  :format-arguments (list function-name)))
1636         (setf documentation t)
1637         (push item options))
1638        (:method
1639         (push
1640          `(push (defmethod ,function-name ,@(cdr item))
1641                 (generic-function-initial-methods (fdefinition ',function-name)))
1642          methods))
1643        (t
1644         (push item options))))
1645    (when declarations (push (list :declarations declarations) options))
1646    (setf options (nreverse options)
1647          methods (nreverse methods))
1648    ;;; Since DEFGENERIC currently shares its argument parsing with
1649    ;;; DEFMETHOD, we perform this check here.
1650    (when (find '&aux lambda-list)
1651      (error 'program-error
1652             :format-control "&AUX is not allowed in a generic function lambda list: ~S"
1653             :format-arguments (list lambda-list)))
1654    `(prog1
1655       (%defgeneric
1656        ',function-name
1657        :lambda-list ',lambda-list
1658        ,@(canonicalize-defgeneric-options options))
1659       ,@methods)))
1660
1661(defun canonicalize-defgeneric-options (options)
1662  (mapappend #'canonicalize-defgeneric-option options))
1663
1664(defun canonicalize-defgeneric-option (option)
1665  (case (car option)
1666    (:generic-function-class
1667     (list :generic-function-class `(find-class ',(cadr option))))
1668    (:method-class
1669     (list :method-class `(find-class ',(cadr option))))
1670    (:method-combination
1671     (list :method-combination `',(cdr option)))
1672    (:argument-precedence-order
1673     (list :argument-precedence-order `',(cdr option)))
1674    (t
1675     (list `',(car option) `',(cadr option)))))
1676
1677;; From OpenMCL (called canonicalize-argument-precedence-order there,
1678;; but AMOP specifies argument-precedence-order to return a permutation
1679;; of the required arguments, not a list of indices, so we calculate
1680;; them on demand).
1681(defun argument-precedence-order-indices (apo req)
1682  (cond ((equal apo req) nil)
1683        ((not (eql (length apo) (length req)))
1684         (error 'program-error
1685                :format-control "Specified argument precedence order ~S does not match lambda list."
1686                :format-arguments (list apo)))
1687        (t (let ((res nil))
1688             (dolist (arg apo (nreverse res))
1689               (let ((index (position arg req)))
1690                 (if (or (null index) (memq index res))
1691                     (error 'program-error
1692                            :format-control "Specified argument precedence order ~S does not match lambda list."
1693                            :format-arguments (list apo)))
1694                 (push index res)))))))
1695
1696(defun find-generic-function (name &optional (errorp t))
1697  (let ((function (and (fboundp name) (fdefinition name))))
1698    (when function
1699      (when (typep function 'generic-function)
1700        (return-from find-generic-function function))
1701      (when (and *traced-names* (find name *traced-names* :test #'equal))
1702        (setf function (untraced-function name))
1703        (when (typep function 'generic-function)
1704          (return-from find-generic-function function)))))
1705  (if errorp
1706      (error "There is no generic function named ~S." name)
1707      nil))
1708
1709(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
1710  (let* ((plist1 (analyze-lambda-list lambda-list1))
1711         (args1 (getf plist1 :required-args))
1712         (plist2 (analyze-lambda-list lambda-list2))
1713         (args2 (getf plist2 :required-args)))
1714    (= (length args1) (length args2))))
1715
1716(defun %defgeneric (function-name &rest all-keys)
1717  (when (fboundp function-name)
1718    (let ((gf (fdefinition function-name)))
1719      (when (typep gf 'generic-function)
1720        ;; Remove methods defined by previous DEFGENERIC forms, as
1721        ;; specified by CLHS, 7.7 (Macro DEFGENERIC).
1722        (dolist (method (generic-function-initial-methods gf))
1723          (if (eq  (class-of gf) +the-standard-generic-function-class+)
1724              (progn
1725                (std-remove-method gf method)
1726                (map-dependents gf
1727                                #'(lambda (dep)
1728                                    (update-dependent gf dep
1729                                                      'remove-method method))))
1730              (remove-method gf method)))
1731        (setf (generic-function-initial-methods gf) '()))))
1732  (apply 'ensure-generic-function function-name all-keys))
1733
1734;;; Bootstrap version of ensure-generic-function, handling only
1735;;; standard-generic-function.  This function is replaced later.
1736(declaim (notinline ensure-generic-function))
1737(defun ensure-generic-function (function-name
1738                                &rest all-keys
1739                                &key
1740                                (lambda-list nil lambda-list-supplied-p)
1741                                (generic-function-class +the-standard-generic-function-class+)
1742                                (method-class +the-standard-method-class+)
1743                                (method-combination +the-standard-method-combination+ mc-p)
1744                                argument-precedence-order
1745                                (documentation nil documentation-supplied-p)
1746                                &allow-other-keys)
1747  (setf all-keys (copy-list all-keys))  ; since we modify it
1748  (remf all-keys :generic-function-class)
1749  (let ((gf (find-generic-function function-name nil)))
1750    (if gf
1751        (progn
1752          (when lambda-list-supplied-p
1753            (unless (or (null (generic-function-methods gf))
1754                        (lambda-lists-congruent-p lambda-list
1755                                                  (generic-function-lambda-list gf)))
1756              (error 'simple-error
1757                     :format-control "The lambda list ~S is incompatible with the existing methods of ~S."
1758                     :format-arguments (list lambda-list gf)))
1759            (setf (generic-function-lambda-list gf) lambda-list)
1760            (let* ((plist (analyze-lambda-list lambda-list))
1761                   (required-args (getf plist ':required-args)))
1762              (%set-gf-required-args gf required-args)
1763              (%set-gf-optional-args gf (getf plist :optional-args))))
1764          (setf (generic-function-argument-precedence-order gf)
1765                (or argument-precedence-order (gf-required-args gf)))
1766          (when documentation-supplied-p
1767            (setf (generic-function-documentation gf) documentation))
1768          (finalize-standard-generic-function gf)
1769          gf)
1770        (progn
1771          (when (and (null *clos-booting*)
1772                     (and (fboundp function-name)
1773                          ;; since we're overwriting an autoloader,
1774                          ;; we're probably meant to redefine it,
1775                          ;; so throwing an error here might be a bad idea.
1776                          ;; also, resolving the symbol isn't
1777                          ;; a good option either: we've seen that lead to
1778                          ;; recursive loading of the same file
1779                          (not (autoloadp function-name))))
1780            (error 'program-error
1781                   :format-control "~A already names an ordinary function, macro, or special operator."
1782                   :format-arguments (list function-name)))
1783          (when mc-p
1784            (error "Preliminary ensure-method does not support :method-combination argument."))
1785          (setf gf (apply (if (eq generic-function-class
1786                                  +the-standard-generic-function-class+)
1787                              #'make-instance-standard-generic-function
1788                              #'make-instance)
1789                          generic-function-class
1790                          :name function-name
1791                          :method-class method-class
1792                          :method-combination method-combination
1793                          all-keys))
1794          gf))))
1795
1796(defun collect-eql-specializer-objects (generic-function)
1797  (let ((result nil))
1798    (dolist (method (generic-function-methods generic-function))
1799      (dolist (specializer (method-specializers method))
1800        (when (typep specializer 'eql-specializer)
1801          (pushnew (eql-specializer-object specializer)
1802                   result
1803                   :test 'eql))))
1804    result))
1805
1806(defun finalize-standard-generic-function (gf)
1807  (%finalize-generic-function gf)
1808  (unless (generic-function-classes-to-emf-table gf)
1809    (set-generic-function-classes-to-emf-table gf (make-hash-table :test #'equal)))
1810  (clrhash (generic-function-classes-to-emf-table gf))
1811  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
1812  (set-funcallable-instance-function
1813   gf
1814   (if (eq (class-of gf) +the-standard-generic-function-class+)
1815       (std-compute-discriminating-function gf)
1816       (compute-discriminating-function gf)))
1817  ;; FIXME Do we need to warn on redefinition somewhere else?
1818  (let ((*warn-on-redefinition* nil))
1819    (setf (fdefinition (%generic-function-name gf)) gf))
1820  (values))
1821
1822(defun make-instance-standard-generic-function (generic-function-class
1823                                                &key name lambda-list
1824                                                method-class
1825                                                method-combination
1826                                                argument-precedence-order
1827                                                declarations
1828                                                documentation)
1829  ;; to avoid circularities, we do not call generic functions in here.
1830  (declare (ignore generic-function-class))
1831  (check-argument-precedence-order lambda-list argument-precedence-order)
1832  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
1833    (%set-generic-function-name gf name)
1834    (%set-generic-function-lambda-list gf lambda-list)
1835    (set-generic-function-initial-methods gf ())
1836    (set-generic-function-methods gf ())
1837    (set-generic-function-method-class gf method-class)
1838    (set-generic-function-method-combination gf method-combination)
1839    (set-generic-function-declarations gf declarations)
1840    (set-generic-function-documentation gf documentation)
1841    (set-generic-function-classes-to-emf-table gf nil)
1842    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
1843           (required-args (getf plist ':required-args)))
1844      (%set-gf-required-args gf required-args)
1845      (%set-gf-optional-args gf (getf plist :optional-args))
1846      (set-generic-function-argument-precedence-order
1847       gf (or argument-precedence-order required-args)))
1848    (finalize-standard-generic-function gf)
1849    gf))
1850
1851(defun canonicalize-specializers (specializers)
1852  (mapcar #'canonicalize-specializer specializers))
1853
1854(defun canonicalize-specializer (specializer)
1855  (cond ((classp specializer)
1856         specializer)
1857        ((typep specializer 'eql-specializer)
1858         specializer)
1859        ((symbolp specializer)
1860         (find-class specializer))
1861        ((and (consp specializer)
1862              (eq (car specializer) 'eql))
1863         (let ((object (cadr specializer)))
1864           (when (and (consp object)
1865                      (eq (car object) 'quote))
1866             (setf object (cadr object)))
1867           (intern-eql-specializer object)))
1868        ((and (consp specializer)
1869              (eq (car specializer) 'java:jclass))
1870         (let ((jclass (eval specializer)))
1871           (java::ensure-java-class jclass)))
1872        (t
1873         (error "Unknown specializer: ~S" specializer))))
1874
1875(defun parse-defmethod (args)
1876  (let ((function-name (car args))
1877        (qualifiers ())
1878        (specialized-lambda-list ())
1879        (body ())
1880        (parse-state :qualifiers))
1881    (dolist (arg (cdr args))
1882      (ecase parse-state
1883        (:qualifiers
1884         (if (and (atom arg) (not (null arg)))
1885             (push arg qualifiers)
1886             (progn
1887               (setf specialized-lambda-list arg)
1888               (setf parse-state :body))))
1889        (:body (push arg body))))
1890    (setf qualifiers (nreverse qualifiers)
1891          body (nreverse body))
1892    (multiple-value-bind (real-body declarations documentation)
1893        (parse-body body)
1894      (values function-name
1895              qualifiers
1896              (extract-lambda-list specialized-lambda-list)
1897              (extract-specializer-names specialized-lambda-list)
1898              documentation
1899              declarations
1900              (list* 'block
1901                     (fdefinition-block-name function-name)
1902                     real-body)))))
1903
1904(defun required-portion (gf args)
1905  (let ((number-required (length (gf-required-args gf))))
1906    (when (< (length args) number-required)
1907      (error 'program-error
1908             :format-control "Not enough arguments for generic function ~S."
1909             :format-arguments (list (%generic-function-name gf))))
1910    (subseq args 0 number-required)))
1911
1912(defun extract-lambda-list (specialized-lambda-list)
1913  (let* ((plist (analyze-lambda-list specialized-lambda-list))
1914         (requireds (getf plist :required-names))
1915         (rv (getf plist :rest-var))
1916         (ks (getf plist :key-args))
1917         (keysp (getf plist :keysp))
1918         (aok (getf plist :allow-other-keys))
1919         (opts (getf plist :optional-args))
1920         (auxs (getf plist :auxiliary-args)))
1921    `(,@requireds
1922      ,@(if opts `(&optional ,@opts) ())
1923      ,@(if rv `(&rest ,rv) ())
1924      ,@(if (or ks keysp aok) `(&key ,@ks) ())
1925      ,@(if aok '(&allow-other-keys) ())
1926      ,@(if auxs `(&aux ,@auxs) ()))))
1927
1928(defun extract-specializer-names (specialized-lambda-list)
1929  (let ((plist (analyze-lambda-list specialized-lambda-list)))
1930    (getf plist ':specializers)))
1931
1932(defun get-keyword-from-arg (arg)
1933  (if (listp arg)
1934      (if (listp (car arg))
1935          (caar arg)
1936          (make-keyword (car arg)))
1937      (make-keyword arg)))
1938
1939(defun analyze-lambda-list (lambda-list)
1940  (let ((keys ())           ; Just the keywords
1941        (key-args ())       ; Keywords argument specs
1942        (keysp nil)         ;
1943        (required-names ()) ; Just the variable names
1944        (required-args ())  ; Variable names & specializers
1945        (specializers ())   ; Just the specializers
1946        (rest-var nil)
1947        (optionals ())
1948        (auxs ())
1949        (allow-other-keys nil)
1950        (state :required))
1951    (dolist (arg lambda-list)
1952      (if (member arg lambda-list-keywords)
1953          (ecase arg
1954            (&optional
1955             (unless (eq state :required)
1956               (error 'program-error
1957                      :format-control "~A followed by &OPTIONAL not allowed ~
1958                                       in lambda list ~S"
1959                      :format-arguments (list state lambda-list)))
1960             (setq state '&optional))
1961            (&rest
1962             (unless (or (eq state :required)
1963                         (eq state '&optional))
1964               (error 'program-error
1965                      :format-control "~A followed by &REST not allowed ~
1966                                       in lambda list ~S"
1967                      :format-arguments (list state lambda-list)))
1968             (setq state '&rest))
1969            (&key
1970             (unless (or (eq state :required)
1971                         (eq state '&optional)
1972                         (eq state '&rest))
1973               (error 'program-error
1974                      :format-control "~A followed by &KEY not allowed
1975                                       in lambda list ~S"
1976                      :format-arguments (list state lambda-list)))
1977             (setq keysp t)
1978             (setq state '&key))
1979            (&allow-other-keys
1980             (unless (eq state '&key)
1981               (error 'program-error
1982                      :format-control "&ALLOW-OTHER-KEYS not allowed while
1983                                       parsing ~A in lambda list ~S"
1984                      :format-arguments (list state lambda-list)))
1985             (setq allow-other-keys 't))
1986            (&aux
1987             ;; &aux comes last; any other previous state is fine
1988             (setq state '&aux)))
1989          (case state
1990            (:required
1991             (push-on-end arg required-args)
1992             (if (listp arg)
1993                 (progn (push-on-end (car arg) required-names)
1994                   (push-on-end (cadr arg) specializers))
1995                 (progn (push-on-end arg required-names)
1996                   (push-on-end 't specializers))))
1997            (&optional (push-on-end arg optionals))
1998            (&rest (setq rest-var arg))
1999            (&key
2000             (push-on-end (get-keyword-from-arg arg) keys)
2001             (push-on-end arg key-args))
2002            (&aux (push-on-end arg auxs)))))
2003    (list  :required-names required-names
2004           :required-args required-args
2005           :specializers specializers
2006           :rest-var rest-var
2007           :keywords keys
2008           :key-args key-args
2009           :keysp keysp
2010           :auxiliary-args auxs
2011           :optional-args optionals
2012           :allow-other-keys allow-other-keys)))
2013
2014#+nil
2015(defun check-method-arg-info (gf arg-info method)
2016  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
2017      (analyze-lambda-list (if (consp method)
2018                               (early-method-lambda-list method)
2019                               (method-lambda-list method)))
2020    (flet ((lose (string &rest args)
2021                 (error 'simple-program-error
2022                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
2023                        to the generic function~2I~_~S;~I~_~
2024                        but ~?~:>"
2025                        :format-arguments (list method gf string args)))
2026           (comparison-description (x y)
2027                                   (if (> x y) "more" "fewer")))
2028      (let ((gf-nreq (arg-info-number-required arg-info))
2029            (gf-nopt (arg-info-number-optional arg-info))
2030            (gf-key/rest-p (arg-info-key/rest-p arg-info))
2031            (gf-keywords (arg-info-keys arg-info)))
2032        (unless (= nreq gf-nreq)
2033          (lose
2034           "the method has ~A required arguments than the generic function."
2035           (comparison-description nreq gf-nreq)))
2036        (unless (= nopt gf-nopt)
2037          (lose
2038           "the method has ~A optional arguments than the generic function."
2039           (comparison-description nopt gf-nopt)))
2040        (unless (eq (or keysp restp) gf-key/rest-p)
2041          (lose
2042           "the method and generic function differ in whether they accept~_~
2043            &REST or &KEY arguments."))
2044        (when (consp gf-keywords)
2045          (unless (or (and restp (not keysp))
2046                      allow-other-keys-p
2047                      (every (lambda (k) (memq k keywords)) gf-keywords))
2048            (lose "the method does not accept each of the &KEY arguments~2I~_~
2049            ~S."
2050                  gf-keywords)))))))
2051
2052(defun check-method-lambda-list (name method-lambda-list gf-lambda-list)
2053  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
2054         (gf-plist (analyze-lambda-list gf-lambda-list))
2055         (gf-keysp (getf gf-plist :keysp))
2056         (gf-keywords (getf gf-plist :keywords))
2057         (method-plist (analyze-lambda-list method-lambda-list))
2058         (method-restp (not (null (memq '&rest method-lambda-list))))
2059         (method-keysp (getf method-plist :keysp))
2060         (method-keywords (getf method-plist :keywords))
2061         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
2062    (unless (= (length (getf gf-plist :required-args))
2063               (length (getf method-plist :required-args)))
2064      (error "The method-lambda-list ~S ~
2065              has the wrong number of required arguments ~
2066              for the generic function ~S." method-lambda-list name))
2067    (unless (= (length (getf gf-plist :optional-args))
2068               (length (getf method-plist :optional-args)))
2069      (error "The method-lambda-list ~S ~
2070              has the wrong number of optional arguments ~
2071              for the generic function ~S." method-lambda-list name))
2072    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
2073      (error "The method-lambda-list ~S ~
2074              and the generic function ~S ~
2075              differ in whether they accept &REST or &KEY arguments."
2076             method-lambda-list name))
2077    (when (consp gf-keywords)
2078      (unless (or (and method-restp (not method-keysp))
2079                  method-allow-other-keys-p
2080                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
2081        (error "The method-lambda-list ~S does not accept ~
2082                all of the keyword arguments defined for the ~
2083                generic function." method-lambda-list name)))))
2084
2085(defun check-argument-precedence-order (lambda-list argument-precedence-order)
2086  (when argument-precedence-order
2087    (if lambda-list
2088        ;; raising the required program-errors is a side-effect of
2089        ;; calculating the given permutation of apo vs req
2090        (argument-precedence-order-indices
2091         argument-precedence-order
2092         (getf (analyze-lambda-list lambda-list) :required-args))
2093        ;; AMOP pg. 198
2094        (error 'program-error "argument precedence order specified without lambda list"))))
2095
2096(defvar *gf-initialize-instance* nil
2097  "Cached value of the INITIALIZE-INSTANCE generic function.
2098Initialized with the true value near the end of the file.")
2099(defvar *gf-allocate-instance* nil
2100  "Cached value of the ALLOCATE-INSTANCE generic function.
2101Initialized with the true value near the end of the file.")
2102(defvar *gf-shared-initialize* nil
2103  "Cached value of the SHARED-INITIALIZE generic function.
2104Initialized with the true value near the end of the file.")
2105(defvar *gf-reinitialize-instance* nil
2106  "Cached value of the REINITIALIZE-INSTANCE generic function.
2107Initialized with the true value near the end of the file.")
2108
2109(declaim (ftype (function * method) ensure-method))
2110(defun ensure-method (name &rest all-keys)
2111  (let ((method-lambda-list (getf all-keys :lambda-list))
2112        (gf (find-generic-function name nil)))
2113    (when (or (eq gf *gf-initialize-instance*)
2114              (eq gf *gf-allocate-instance*)
2115              (eq gf *gf-shared-initialize*)
2116              (eq gf *gf-reinitialize-instance*))
2117      ;; ### Clearly, this can be targeted much more exact
2118      ;; as we only need to remove the specializing class and all
2119      ;; its subclasses from the hash.
2120      (clrhash *make-instance-initargs-cache*)
2121      (clrhash *reinitialize-instance-initargs-cache*))
2122    (if gf
2123        (check-method-lambda-list name method-lambda-list
2124                                  (generic-function-lambda-list gf))
2125        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
2126    (let ((method
2127           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
2128               (apply #'make-instance-standard-method gf all-keys)
2129               (apply #'make-instance (generic-function-method-class gf) all-keys))))
2130      (if (and
2131           (eq (generic-function-method-class gf) +the-standard-method-class+)
2132           (eq (class-of gf) +the-standard-generic-function-class+))
2133          (progn
2134            (std-add-method gf method)
2135            (map-dependents gf
2136                            #'(lambda (dep)
2137                                (update-dependent gf dep 'add-method method))))
2138          (add-method gf method))
2139      method)))
2140
2141(defun make-instance-standard-method (gf
2142                                      &key
2143                                      lambda-list
2144                                      qualifiers
2145                                      specializers
2146                                      documentation
2147                                      function
2148                                      fast-function)
2149  (declare (ignore gf))
2150  (let ((method (std-allocate-instance +the-standard-method-class+))
2151        (analyzed-args (analyze-lambda-list lambda-list)))
2152    (setf (method-lambda-list method) lambda-list)
2153    (setf (method-qualifiers method) qualifiers)
2154    (setf (std-slot-value method 'sys::specializers)
2155          (canonicalize-specializers specializers))
2156    (setf (method-documentation method) documentation)
2157    (setf (std-slot-value method 'sys::%generic-function) nil) ; set by add-method
2158    (setf (std-slot-value method 'sys::%function) function)
2159    (setf (std-slot-value method 'sys::fast-function) fast-function)
2160    (setf (std-slot-value method 'sys::keywords) (getf analyzed-args :keywords))
2161    (setf (std-slot-value method 'sys::other-keywords-p)
2162          (getf analyzed-args :allow-other-keys))
2163    method))
2164
2165;;; To be redefined as generic functions later
2166(declaim (notinline add-direct-method))
2167(defun add-direct-method (specializer method)
2168  (if (typep specializer 'eql-specializer)
2169      (pushnew method (std-slot-value specializer 'direct-methods))
2170      (pushnew method (class-direct-methods specializer))))
2171
2172(declaim (notinline remove-direct-method))
2173(defun remove-direct-method (specializer method)
2174  (if (typep specializer 'eql-specializer)
2175      (setf (std-slot-value specializer 'direct-methods)
2176            (remove method (std-slot-value specializer 'direct-methods)))
2177      (setf (class-direct-methods specializer)
2178            (remove method (class-direct-methods specializer)))))
2179
2180(defun std-add-method (gf method)
2181  ;; calls sites need to make sure that method is either a method of the
2182  ;; given gf or does not have a gf.
2183  (let ((old-method (%find-method gf (std-method-qualifiers method)
2184                                 (method-specializers method) nil)))
2185    (when old-method
2186      (if (and (eq (class-of gf) +the-standard-generic-function-class+)
2187               (eq (class-of old-method) +the-standard-method-class+))
2188          (std-remove-method gf old-method)
2189          (remove-method gf old-method))))
2190  (setf (std-slot-value method 'sys::%generic-function) gf)
2191  (push method (generic-function-methods gf))
2192  (dolist (specializer (method-specializers method))
2193    (add-direct-method specializer method))
2194  (finalize-standard-generic-function gf)
2195  gf)
2196
2197(defun std-remove-method (gf method)
2198  (setf (generic-function-methods gf)
2199        (remove method (generic-function-methods gf)))
2200  (setf (std-slot-value method 'sys::%generic-function) nil)
2201  (dolist (specializer (method-specializers method))
2202    (remove-direct-method specializer method))
2203  (finalize-standard-generic-function gf)
2204  gf)
2205
2206(defun %find-method (gf qualifiers specializers &optional (errorp t))
2207  ;; "If the specializers argument does not correspond in length to the number
2208  ;; of required arguments of the generic-function, an an error of type ERROR
2209  ;; is signaled."
2210  (unless (= (length specializers) (length (gf-required-args gf)))
2211    (error "The specializers argument has length ~S, but ~S has ~S required parameters."
2212           (length specializers)
2213           gf
2214           (length (gf-required-args gf))))
2215  (let* ((canonical-specializers (canonicalize-specializers specializers))
2216         (method
2217          (find-if #'(lambda (method)
2218                      (and (equal qualifiers
2219                                  (method-qualifiers method))
2220                           (equal canonical-specializers
2221                                  (method-specializers method))))
2222                   (generic-function-methods gf))))
2223    (if (and (null method) errorp)
2224        (error "No such method for ~S." (%generic-function-name gf))
2225        method)))
2226
2227(defun fast-callable-p (gf)
2228  (and (eq (method-combination-name (generic-function-method-combination gf))
2229           'standard)
2230       (null (intersection (%generic-function-lambda-list gf)
2231                           '(&rest &optional &key &allow-other-keys &aux)))))
2232
2233(declaim (ftype (function * t) slow-method-lookup-1))
2234
2235(declaim (ftype (function (t t t) t) slow-reader-lookup))
2236(defun slow-reader-lookup (gf layout slot-name)
2237  (let ((location (layout-slot-location layout slot-name)))
2238    (cache-slot-location gf layout location)
2239    location))
2240
2241(defun std-compute-discriminating-function (gf)
2242  ;; In this function, we know that gf is of class
2243  ;; standard-generic-function, so we call various
2244  ;; sys:%generic-function-foo readers to break circularities.
2245  (cond
2246    ((and (= (length (sys:%generic-function-methods gf)) 1)
2247          (eq (type-of (car (sys:%generic-function-methods gf))) 'standard-reader-method)
2248          (eq (type-of (car (std-method-specializers (%car (sys:%generic-function-methods gf))))) 'standard-class))
2249     ;; we are standard and can elide slot-value(-using-class)
2250     (let* ((method (%car (sys:%generic-function-methods gf)))
2251            (class (car (std-method-specializers method)))
2252            (slot-name (slot-definition-name (accessor-method-slot-definition method))))
2253       #'(lambda (arg)
2254           (declare (optimize speed))
2255           (let* ((layout (std-instance-layout arg))
2256                  (location (get-cached-slot-location gf layout)))
2257             (unless location
2258               (unless (simple-typep arg class)
2259                 ;; FIXME no applicable method
2260                 (error 'simple-type-error
2261                        :datum arg
2262                        :expected-type class))
2263               (setf location (slow-reader-lookup gf layout slot-name)))
2264             (let ((value (if (consp location)
2265                              (cdr location) ; :allocation :class
2266                              (funcallable-standard-instance-access arg location))))
2267               (if (eq value +slot-unbound+)
2268                   ;; fix SLOT-UNBOUND.5 from ansi test suite
2269                   (nth-value 0 (slot-unbound class arg slot-name))
2270                   value))))))
2271
2272    (t
2273     (let* ((emf-table (classes-to-emf-table gf))
2274            (number-required (length (gf-required-args gf)))
2275            (lambda-list (%generic-function-lambda-list gf))
2276            (exact (null (intersection lambda-list
2277                                       '(&rest &optional &key
2278                                         &allow-other-keys))))
2279            (no-aux (null (some 
2280                           (lambda (method) 
2281                             (find '&aux (std-slot-value method 'sys::lambda-list)))
2282                           (sys:%generic-function-methods gf)))))
2283       (if (and exact
2284                no-aux)
2285           (cond
2286             ((= number-required 1)
2287              (cond
2288                ((and (eq (method-combination-name (sys:%generic-function-method-combination gf)) 'standard)
2289                      (= (length (sys:%generic-function-methods gf)) 1)
2290                      (std-method-fast-function (%car (sys:%generic-function-methods gf))))
2291                 (let* ((method (%car (sys:%generic-function-methods gf)))
2292                        (specializer (car (std-method-specializers method)))
2293                        (function (std-method-fast-function method)))
2294                   (if (typep specializer 'eql-specializer)
2295                       (let ((specializer-object (eql-specializer-object specializer)))
2296                         #'(lambda (arg)
2297                             (declare (optimize speed))
2298                             (if (eql arg specializer-object)
2299                                 (funcall function arg)
2300                                 (no-applicable-method gf (list arg)))))
2301                       #'(lambda (arg)
2302                           (declare (optimize speed))
2303                           (unless (simple-typep arg specializer)
2304                             ;; FIXME no applicable method
2305                             (error 'simple-type-error
2306                                    :datum arg
2307                                    :expected-type specializer))
2308                           (funcall function arg)))))
2309                (t
2310                 #'(lambda (arg)
2311                     (declare (optimize speed))
2312                     (let* ((specialization
2313                             (%get-arg-specialization gf arg))
2314                            (emfun (or (gethash1 specialization
2315                                                 emf-table)
2316                                       (slow-method-lookup-1
2317                                        gf arg specialization))))
2318                       (if emfun
2319                           (funcall emfun (list arg))
2320                           (apply #'no-applicable-method gf (list arg))))))))
2321             ((= number-required 2)
2322              #'(lambda (arg1 arg2)
2323                  (declare (optimize speed))
2324                  (let* ((args (list arg1 arg2))
2325                         (emfun (get-cached-emf gf args)))
2326                    (if emfun
2327                        (funcall emfun args)
2328                        (slow-method-lookup gf args)))))
2329             ((= number-required 3)
2330              #'(lambda (arg1 arg2 arg3)
2331                  (declare (optimize speed))
2332                  (let* ((args (list arg1 arg2 arg3))
2333                         (emfun (get-cached-emf gf args)))
2334                    (if emfun
2335                        (funcall emfun args)
2336                        (slow-method-lookup gf args)))))
2337             (t
2338              #'(lambda (&rest args)
2339                  (declare (optimize speed))
2340                  (let ((len (length args)))
2341                    (unless (= len number-required)
2342                      (error 'program-error
2343                             :format-control "Not enough arguments for generic function ~S."
2344                             :format-arguments (list (%generic-function-name gf)))))
2345                  (let ((emfun (get-cached-emf gf args)))
2346                    (if emfun
2347                        (funcall emfun args)
2348                        (slow-method-lookup gf args))))))
2349           ;;           (let ((non-key-args (+ number-required
2350           ;;                                  (length (gf-optional-args gf))))))
2351           #'(lambda (&rest args)
2352               (declare (optimize speed))
2353               (let ((len (length args)))
2354                 (unless (>= len number-required)
2355                   (error 'program-error
2356                          :format-control "Not enough arguments for generic function ~S."
2357                          :format-arguments (list (%generic-function-name gf)))))
2358               (let ((emfun (get-cached-emf gf args)))
2359                 (if emfun
2360                     (funcall emfun args)
2361                     (slow-method-lookup gf args)))))))))
2362
2363(defun sort-methods (methods gf required-classes)
2364  (if (or (null methods) (null (%cdr methods)))
2365      methods
2366      (sort methods
2367            (if (eq (class-of gf) +the-standard-generic-function-class+)
2368                (let ((method-indices
2369                       (argument-precedence-order-indices
2370                        (generic-function-argument-precedence-order gf)
2371                        (getf (analyze-lambda-list (generic-function-lambda-list gf))
2372                              ':required-args))))
2373                  #'(lambda (m1 m2)
2374                      (std-method-more-specific-p
2375                       m1 m2 required-classes method-indices)))
2376                #'(lambda (m1 m2)
2377                    (method-more-specific-p gf m1 m2 required-classes))))))
2378
2379(defun method-applicable-p (method args)
2380  (do* ((specializers (method-specializers method) (cdr specializers))
2381        (args args (cdr args)))
2382       ((null specializers) t)
2383    (let ((specializer (car specializers)))
2384      (if (typep specializer 'eql-specializer)
2385          (unless (eql (car args) (eql-specializer-object specializer))
2386            (return nil))
2387          (unless (subclassp (class-of (car args)) specializer)
2388            (return nil))))))
2389
2390(defun std-compute-applicable-methods (gf args)
2391  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
2392        (methods '()))
2393    (dolist (method (generic-function-methods gf))
2394      (when (method-applicable-p method args)
2395        (push method methods)))
2396    (sort-methods methods gf required-classes)))
2397
2398(declaim (notinline compute-applicable-methods))
2399(defun compute-applicable-methods (gf args)
2400  (std-compute-applicable-methods gf args))
2401
2402;;; METHOD-APPLICABLE-USING-CLASSES-P
2403;;;
2404;;; If the first return value is T, METHOD is definitely applicable to
2405;;; arguments that are instances of CLASSES.  If the first value is
2406;;; NIL and the second value is T, METHOD is definitely not applicable
2407;;; to arguments that are instances of CLASSES; if the second value is
2408;;; NIL the applicability of METHOD cannot be determined by inspecting
2409;;; the classes of its arguments only.
2410;;;
2411(defun method-applicable-using-classes-p (method classes)
2412  (do* ((specializers (method-specializers method) (cdr specializers))
2413        (classes classes (cdr classes))
2414        (knownp t))
2415       ((null specializers)
2416        (if knownp (values t t) (values nil nil)))
2417    (let ((specializer (car specializers)))
2418      (if (typep specializer 'eql-specializer)
2419          (if (eql (class-of (eql-specializer-object specializer)) 
2420                   (car classes))
2421              (setf knownp nil)
2422              (return (values nil t)))
2423          (unless (subclassp (car classes) specializer)
2424            (return (values nil t)))))))
2425
2426(defun check-applicable-method-keyword-args (gf args
2427                                             keyword-args
2428                                             applicable-keywords)
2429  (when (oddp (length keyword-args))
2430    (error 'program-error
2431           :format-control "Odd number of keyword arguments in call to ~S ~
2432with arguments list ~S"
2433           :format-arguments (list gf args)))
2434  (unless (getf keyword-args :allow-other-keys)
2435    (loop for key in keyword-args by #'cddr
2436       unless (or (member key applicable-keywords)
2437                  (eq key :allow-other-keys))
2438       do (error 'program-error
2439                 :format-control "Invalid keyword argument ~S in call ~
2440to ~S with argument list ~S."
2441                 :format-arguments (list key gf args)))))
2442
2443(defun compute-applicable-keywords (gf applicable-methods)
2444  (let ((applicable-keywords
2445         (getf (analyze-lambda-list (generic-function-lambda-list gf))
2446               :keywords)))
2447    (loop for method in applicable-methods
2448       do (multiple-value-bind
2449                (keywords allow-other-keys)
2450              (function-keywords method)
2451            (when allow-other-keys
2452              (setf applicable-keywords :any)
2453              (return))
2454            (setf applicable-keywords
2455                  (union applicable-keywords keywords))))
2456    applicable-keywords))
2457
2458(defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args
2459                                          applicable-keywords)
2460  #'(lambda (args)
2461      (check-applicable-method-keyword-args
2462         gf args
2463         (nthcdr non-keyword-args args) applicable-keywords)
2464      (funcall emfun args)))
2465
2466(defun slow-method-lookup (gf args)
2467  (let ((applicable-methods
2468          (if (eq (class-of gf) +the-standard-generic-function-class+)
2469              (std-compute-applicable-methods gf args)
2470              (or (compute-applicable-methods-using-classes gf (mapcar #'class-of args))
2471                  (compute-applicable-methods gf args)))))
2472    (if applicable-methods
2473        (let* ((emfun (funcall (if (eq (class-of gf)
2474                                       +the-standard-generic-function-class+)
2475                                   #'std-compute-effective-method
2476                                   #'compute-effective-method)
2477                               gf (generic-function-method-combination gf)
2478                               applicable-methods))
2479               (non-keyword-args (+ (length (gf-required-args gf))
2480                                    (length (gf-optional-args gf))))
2481               (gf-lambda-list (generic-function-lambda-list gf))
2482               (checks-required (and (member '&key gf-lambda-list)
2483                                     (not (member '&allow-other-keys
2484                                                  gf-lambda-list))))
2485              (applicable-keywords
2486               (when checks-required
2487                 ;; Don't do applicable keyword checks when this is
2488                 ;; one of the 'exceptional four' or when the gf allows
2489                 ;; other keywords.
2490                 (compute-applicable-keywords gf applicable-methods))))
2491          (when (and checks-required
2492                     (not (eq applicable-keywords :any)))
2493            (setf emfun
2494                  (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args
2495                                                     applicable-keywords)))
2496          (cache-emf gf args emfun)
2497          (funcall emfun args))
2498        (apply #'no-applicable-method gf args))))
2499
2500(defun slow-method-lookup-1 (gf arg arg-specialization)
2501  (let ((applicable-methods
2502          (if (eq (class-of gf) +the-standard-generic-function-class+)
2503              (std-compute-applicable-methods gf (list arg))
2504              (or (compute-applicable-methods-using-classes gf (list (class-of arg)))
2505                  (compute-applicable-methods gf (list arg))))))
2506    (if applicable-methods
2507        (let ((emfun (funcall (if (eq (class-of gf)
2508                                      +the-standard-generic-function-class+)
2509                                  #'std-compute-effective-method
2510                                  #'compute-effective-method)
2511                              gf (generic-function-method-combination gf)
2512                              applicable-methods)))
2513          (when emfun
2514            (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
2515          emfun))))
2516
2517(defun sub-specializer-p (c1 c2 c-arg)
2518  (find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
2519
2520(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
2521  (if argument-precedence-order
2522      (let ((specializers-1 (std-method-specializers method1))
2523            (specializers-2 (std-method-specializers method2)))
2524        (dolist (index argument-precedence-order)
2525          (let ((spec1 (nth index specializers-1))
2526                (spec2 (nth index specializers-2)))
2527            (unless (eq spec1 spec2)
2528              (cond ((typep spec1 'eql-specializer)
2529                     (return t))
2530                    ((typep spec2 'eql-specializer)
2531                     (return nil))
2532                    (t
2533                     (return (sub-specializer-p spec1 spec2
2534                                                (nth index required-classes)))))))))
2535      (do ((specializers-1 (std-method-specializers method1) (cdr specializers-1))
2536           (specializers-2 (std-method-specializers method2) (cdr specializers-2))
2537           (classes required-classes (cdr classes)))
2538          ((null specializers-1) nil)
2539        (let ((spec1 (car specializers-1))
2540              (spec2 (car specializers-2)))
2541          (unless (eq spec1 spec2)
2542            (cond ((typep spec1 'eql-specializer)
2543                   (return t))
2544                  ((typep spec2 'eql-specializer)
2545                   (return nil))
2546                  (t
2547                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))
2548
2549(defun primary-method-p (method)
2550  (null (intersection '(:before :after :around) (method-qualifiers method))))
2551
2552(defun before-method-p (method)
2553  (equal '(:before) (method-qualifiers method)))
2554
2555(defun after-method-p (method)
2556  (equal '(:after) (method-qualifiers method)))
2557
2558(defun around-method-p (method)
2559  (equal '(:around) (method-qualifiers method)))
2560
2561(defun process-next-method-list (next-method-list)
2562  (mapcar #'(lambda (next-method-form)
2563              (cond
2564                ((listp next-method-form)
2565                 (assert (eq (first next-method-form) 'make-method))
2566                 (let* ((rest-sym (gensym)))
2567                   (make-instance-standard-method
2568                    nil ;; ignored
2569                    :lambda-list (list '&rest rest-sym)
2570                    :function (compute-method-function `(lambda (&rest ,rest-sym)
2571                                                          ,(second next-method-form))))))
2572                (t
2573                 (assert (typep next-method-form 'method))
2574                 next-method-form)))
2575          next-method-list))
2576
2577(defun std-compute-effective-method (gf method-combination methods)
2578  (assert (typep method-combination 'method-combination))
2579  (let* ((mc-name (method-combination-name method-combination))
2580         (options (slot-value method-combination 'options))
2581         (order (car options))
2582         (primaries '())
2583         (arounds '())
2584         around
2585         emf-form
2586         (long-method-combination-p
2587          (typep method-combination 'long-method-combination)))
2588    (unless long-method-combination-p
2589      (dolist (m methods)
2590        (let ((qualifiers (method-qualifiers m)))
2591          (cond ((null qualifiers)
2592                 (if (eq mc-name 'standard)
2593                     (push m primaries)
2594                     (error "Method combination type mismatch: missing qualifier for method combination ~S." method-combination)))
2595                ((cdr qualifiers)
2596                 (error "Invalid method qualifiers."))
2597                ((eq (car qualifiers) :around)
2598                 (push m arounds))
2599                ((eq (car qualifiers) mc-name)
2600                 (push m primaries))
2601                ((memq (car qualifiers) '(:before :after)))
2602                (t
2603                 (error "Invalid method qualifiers."))))))
2604    (unless (eq order :most-specific-last)
2605      (setf primaries (nreverse primaries)))
2606    (setf arounds (nreverse arounds))
2607    (setf around (car arounds))
2608    (when (and (null primaries) (not long-method-combination-p))
2609      (error "No primary methods for the generic function ~S." gf))
2610    (cond
2611      (around
2612       (let ((next-emfun
2613              (funcall
2614               (if (eq (class-of gf) +the-standard-generic-function-class+)
2615                   #'std-compute-effective-method
2616                   #'compute-effective-method)
2617               gf method-combination (remove around methods))))
2618         (setf emf-form
2619               (generate-emf-lambda (method-function around) next-emfun))))
2620      ((eq mc-name 'standard)
2621       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
2622              (befores (remove-if-not #'before-method-p methods))
2623              (reverse-afters
2624               (reverse (remove-if-not #'after-method-p methods))))
2625         (setf emf-form
2626               (cond
2627                 ((and (null befores) (null reverse-afters))
2628                  (let ((fast-function (std-method-fast-function (car primaries))))
2629                    (if fast-function
2630                        (ecase (length (gf-required-args gf))
2631                          (1
2632                           #'(lambda (args)
2633                               (declare (optimize speed))
2634                               (funcall fast-function (car args))))
2635                          (2
2636                           #'(lambda (args)
2637                               (declare (optimize speed))
2638                               (funcall fast-function (car args) (cadr args)))))
2639                        (generate-emf-lambda (std-method-function (car primaries))
2640                                             next-emfun))))
2641                 (t
2642                  (let ((method-function (method-function (car primaries))))
2643                    #'(lambda (args)
2644                        (declare (optimize speed))
2645                        (dolist (before befores)
2646                          (funcall (method-function before) args nil))
2647                        (multiple-value-prog1
2648                            (funcall method-function args next-emfun)
2649                          (dolist (after reverse-afters)
2650                            (funcall (method-function after) args nil))))))))))
2651      (long-method-combination-p
2652       (let ((function (long-method-combination-function method-combination))
2653             (arguments (slot-value method-combination 'options)))
2654         (assert function)
2655         (setf emf-form
2656               (if arguments
2657                   (apply function gf methods arguments)
2658                   (funcall function gf methods)))))
2659      (t
2660       (unless (typep method-combination 'short-method-combination)
2661         (error "Unsupported method combination type ~A." mc-name))
2662       (let ((operator (short-method-combination-operator method-combination))
2663             (ioa (short-method-combination-identity-with-one-argument method-combination)))
2664         (setf emf-form
2665               (if (and ioa (null (cdr primaries)))
2666                   (generate-emf-lambda (method-function (car primaries)) nil)
2667                   `(lambda (args)
2668                      (,operator ,@(mapcar
2669                                    (lambda (primary)
2670                                      `(funcall ,(method-function primary) args nil))
2671                                    primaries))))))))
2672    (assert (not (null emf-form)))
2673    (or #+nil (ignore-errors (autocompile emf-form))
2674        (coerce-to-function emf-form))))
2675
2676(defun generate-emf-lambda (method-function next-emfun)
2677  #'(lambda (args)
2678      (declare (optimize speed))
2679      (funcall method-function args next-emfun)))
2680
2681;;; compute an effective method function from a list of primary methods:
2682
2683(defun compute-primary-emfun (methods)
2684  (if (null methods)
2685      nil
2686      (let ((next-emfun (compute-primary-emfun (cdr methods))))
2687        #'(lambda (args)
2688           (funcall (std-method-function (car methods)) args next-emfun)))))
2689
2690(defvar *call-next-method-p*)
2691(defvar *next-method-p-p*)
2692
2693(defun walk-form (form)
2694  (cond ((atom form)
2695         (cond ((eq form 'call-next-method)
2696                (setf *call-next-method-p* t))
2697               ((eq form 'next-method-p)
2698                (setf *next-method-p-p* t))))
2699        (t
2700         (walk-form (%car form))
2701         (walk-form (%cdr form)))))
2702
2703(defun compute-method-function (lambda-expression)
2704  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
2705        (body (cddr lambda-expression))
2706        (*call-next-method-p* nil)
2707        (*next-method-p-p* nil))
2708    (multiple-value-bind (body declarations) (parse-body body)
2709      (let ((ignorable-vars '()))
2710        (dolist (var lambda-list)
2711          (if (memq var lambda-list-keywords)
2712              (return)
2713              (push var ignorable-vars)))
2714        (push `(declare (ignorable ,@ignorable-vars)) declarations))
2715      (walk-form body)
2716      (cond ((or *call-next-method-p* *next-method-p-p*)
2717             `(lambda (args next-emfun)
2718                (flet ((call-next-method (&rest cnm-args)
2719                         (if (null next-emfun)
2720                             (error "No next method for generic function.")
2721                             (funcall next-emfun (or cnm-args args))))
2722                       (next-method-p ()
2723                         (not (null next-emfun))))
2724                  (declare (ignorable (function call-next-method)
2725                                      (function next-method-p)))
2726                  (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
2727            ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
2728             ;; Required parameters only.
2729             (case (length lambda-list)
2730               (1
2731                `(lambda (args next-emfun)
2732                   (declare (ignore next-emfun))
2733                   (let ((,(%car lambda-list) (%car args)))
2734                     (declare (ignorable ,(%car lambda-list)))
2735                     ,@declarations ,@body)))
2736               (2
2737                `(lambda (args next-emfun)
2738                   (declare (ignore next-emfun))
2739                   (let ((,(%car lambda-list) (%car args))
2740                         (,(%cadr lambda-list) (%cadr args)))
2741                     (declare (ignorable ,(%car lambda-list)
2742                                         ,(%cadr lambda-list)))
2743                     ,@declarations ,@body)))
2744               (3
2745                `(lambda (args next-emfun)
2746                   (declare (ignore next-emfun))
2747                   (let ((,(%car lambda-list) (%car args))
2748                         (,(%cadr lambda-list) (%cadr args))
2749                         (,(%caddr lambda-list) (%caddr args)))
2750                     (declare (ignorable ,(%car lambda-list)
2751                                         ,(%cadr lambda-list)
2752                                         ,(%caddr lambda-list)))
2753                     ,@declarations ,@body)))
2754               (t
2755                `(lambda (args next-emfun)
2756                   (declare (ignore next-emfun))
2757                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
2758            (t
2759             `(lambda (args next-emfun)
2760                (declare (ignore next-emfun))
2761                (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
2762
2763(defun compute-method-fast-function (lambda-expression)
2764  (let ((lambda-list (allow-other-keys (cadr lambda-expression))))
2765    (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))
2766      (return-from compute-method-fast-function nil))
2767    ;; Only required args.
2768    (let ((body (cddr lambda-expression))
2769          (*call-next-method-p* nil)
2770          (*next-method-p-p* nil))
2771      (multiple-value-bind (body declarations) (parse-body body)
2772        (walk-form body)
2773        (when (or *call-next-method-p* *next-method-p-p*)
2774          (return-from compute-method-fast-function nil))
2775        (let ((decls `(declare (ignorable ,@lambda-list))))
2776          (setf lambda-expression
2777                (list* (car lambda-expression)
2778                       (cadr lambda-expression)
2779                       decls
2780                       (cddr lambda-expression))))
2781        (case (length lambda-list)
2782          (1
2783;;            `(lambda (args next-emfun)
2784;;               (let ((,(%car lambda-list) (%car args)))
2785;;                 (declare (ignorable ,(%car lambda-list)))
2786;;                 ,@declarations ,@body)))
2787           lambda-expression)
2788          (2
2789;;            `(lambda (args next-emfun)
2790;;               (let ((,(%car lambda-list) (%car args))
2791;;                     (,(%cadr lambda-list) (%cadr args)))
2792;;                 (declare (ignorable ,(%car lambda-list)
2793;;                                     ,(%cadr lambda-list)))
2794;;                 ,@declarations ,@body)))
2795           lambda-expression)
2796;;           (3
2797;;            `(lambda (args next-emfun)
2798;;               (let ((,(%car lambda-list) (%car args))
2799;;                     (,(%cadr lambda-list) (%cadr args))
2800;;                     (,(%caddr lambda-list) (%caddr args)))
2801;;                 (declare (ignorable ,(%car lambda-list)
2802;;                                     ,(%cadr lambda-list)
2803;;                                     ,(%caddr lambda-list)))
2804;;                 ,@declarations ,@body)))
2805          (t
2806           nil))))))
2807
2808(declaim (notinline make-method-lambda))
2809(defun make-method-lambda (generic-function method lambda-expression env)
2810  (declare (ignore generic-function method env))
2811  (values (compute-method-function lambda-expression) nil))
2812
2813
2814;; From CLHS section 7.6.5:
2815;; "When a generic function or any of its methods mentions &key in a lambda
2816;; list, the specific set of keyword arguments accepted by the generic function
2817;; varies according to the applicable methods. The set of keyword arguments
2818;; accepted by the generic function for a particular call is the union of the
2819;; keyword arguments accepted by all applicable methods and the keyword
2820;; arguments mentioned after &key in the generic function definition, if any."
2821;; Adapted from Sacla.
2822(defun allow-other-keys (lambda-list)
2823  (if (and (member '&key lambda-list)
2824           (not (member '&allow-other-keys lambda-list)))
2825      (let* ((key-end (or (position '&aux lambda-list) (length lambda-list)))
2826             (aux-part (subseq lambda-list key-end)))
2827        `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
2828      lambda-list))
2829
2830(defmacro defmethod (&rest args &environment env)
2831  (multiple-value-bind
2832      (function-name qualifiers lambda-list specializers documentation declarations body)
2833      (parse-defmethod args)
2834    (let* ((specializers-form '())
2835           (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
2836           (gf (or (find-generic-function function-name nil)
2837                   (class-prototype (find-class 'standard-generic-function))))
2838           (method-function
2839             (make-method-lambda gf (class-prototype (generic-function-method-class gf))
2840                                 lambda-expression env))
2841           (fast-function (compute-method-fast-function lambda-expression))
2842           )
2843      (dolist (specializer specializers)
2844        (cond ((and (consp specializer) (eq (car specializer) 'eql))
2845               (push `(list 'eql ,(cadr specializer)) specializers-form))
2846              (t
2847               (push `',specializer specializers-form))))
2848      (setf specializers-form `(list ,@(nreverse specializers-form)))
2849      `(progn
2850         (ensure-method ',function-name
2851                        :lambda-list ',lambda-list
2852                        :qualifiers ',qualifiers
2853                        :specializers (canonicalize-specializers ,specializers-form)
2854                        ,@(if documentation `(:documentation ,documentation))
2855                        :function (function ,method-function)
2856                        ,@(if fast-function `(:fast-function (function ,fast-function)))
2857                        )))))
2858
2859;;; Reader and writer methods
2860
2861(defun make-instance-standard-accessor-method (method-class
2862                                               &key
2863                                               lambda-list
2864                                               qualifiers
2865                                               specializers
2866                                               documentation
2867                                               function
2868                                               fast-function
2869                                               slot-definition)
2870  (let ((method (std-allocate-instance method-class)))
2871    (setf (method-lambda-list method) lambda-list)
2872    (setf (method-qualifiers method) qualifiers)
2873    (setf (std-slot-value method 'sys::specializers)
2874          (canonicalize-specializers specializers))
2875    (setf (method-documentation method) documentation)
2876    (setf (std-slot-value method 'sys::%generic-function) nil)
2877    (setf (std-slot-value method 'sys::%function) function)
2878    (setf (std-slot-value method 'sys::fast-function) fast-function)
2879    (setf (std-slot-value method 'sys::%slot-definition) slot-definition)
2880    (setf (std-slot-value method 'sys::keywords) nil)
2881    (setf (std-slot-value method 'sys::other-keywords-p) nil)
2882    method))
2883
2884(defun add-reader-method (class function-name slot-definition)
2885  (let* ((slot-name (slot-definition-name slot-definition))
2886         (lambda-expression
2887          (if (eq (class-of class) +the-standard-class+)
2888              `(lambda (object) (std-slot-value object ',slot-name))
2889              `(lambda (object) (slot-value object ',slot-name))))
2890         (method-function (compute-method-function lambda-expression))
2891         (fast-function (compute-method-fast-function lambda-expression))
2892         (method-lambda-list '(object))
2893         (gf (find-generic-function function-name nil))
2894         (initargs `(:lambda-list ,method-lambda-list
2895                     :qualifiers ()
2896                     :specializers (,class)
2897                     :function ,(if (autoloadp 'compile)
2898                                    method-function
2899                                    (autocompile method-function))
2900                     :fast-function ,(if (autoloadp 'compile)
2901                                         fast-function
2902                                         (autocompile fast-function))
2903                     :slot-definition ,slot-definition))
2904         (method-class (if (eq class +the-standard-class+)
2905                           +the-standard-reader-method-class+
2906                           (apply #'reader-method-class class slot-definition
2907                                  initargs))))
2908    ;; required by AMOP pg. 225
2909    (assert (subtypep method-class +the-standard-reader-method-class+))
2910    (if gf
2911        (check-method-lambda-list function-name
2912                                  method-lambda-list
2913                                  (generic-function-lambda-list gf))
2914        (setf gf (ensure-generic-function function-name
2915                                          :lambda-list method-lambda-list)))
2916    (let ((method
2917           (if (eq method-class +the-standard-reader-method-class+)
2918               (apply #'make-instance-standard-accessor-method method-class
2919                      initargs)
2920               (apply #'make-instance method-class
2921                      :generic-function nil ; handled by add-method
2922                      initargs))))
2923      (if (eq (class-of gf) +the-standard-generic-function-class+)
2924          (progn
2925            (std-add-method gf method)
2926            (map-dependents gf
2927                            #'(lambda (dep)
2928                                (update-dependent gf dep 'add-method method))))
2929          (add-method gf method))
2930      method)))
2931
2932(defun add-writer-method (class function-name slot-definition)
2933  (let* ((slot-name (slot-definition-name slot-definition))
2934         (lambda-expression
2935          (if (eq (class-of class) +the-standard-class+)
2936              `(lambda (new-value object)
2937                 (setf (std-slot-value object ',slot-name) new-value))
2938              `(lambda (new-value object)
2939                 (setf (slot-value object ',slot-name) new-value))))
2940         (method-function (compute-method-function lambda-expression))
2941         (fast-function (compute-method-fast-function lambda-expression))
2942         (method-lambda-list '(new-value object))
2943         (gf (find-generic-function function-name nil))
2944         (initargs `(:lambda-list ,method-lambda-list
2945                     :qualifiers ()
2946                     :specializers (,+the-T-class+ ,class)
2947                     :function ,(if (autoloadp 'compile)
2948                                    method-function
2949                                    (autocompile method-function))
2950                     :fast-function ,(if (autoloadp 'compile)
2951                                         fast-function
2952                                         (autocompile fast-function))
2953                     :slot-definition ,slot-definition))
2954         (method-class (if (eq class +the-standard-class+)
2955                           +the-standard-writer-method-class+
2956                           (apply #'writer-method-class class slot-definition
2957                                  initargs))))
2958    ;; required by AMOP pg. 242
2959    (assert (subtypep method-class +the-standard-writer-method-class+))
2960    (if gf
2961        (check-method-lambda-list function-name
2962                                  method-lambda-list
2963                                  (generic-function-lambda-list gf))
2964        (setf gf (ensure-generic-function function-name
2965                                          :lambda-list method-lambda-list)))
2966    (let ((method
2967           (if (eq method-class +the-standard-writer-method-class+)
2968               (apply #'make-instance-standard-accessor-method method-class
2969                      initargs)
2970               (apply #'make-instance method-class
2971                      :generic-function nil ; handled by add-method
2972                      initargs))))
2973      (if (eq (class-of gf) +the-standard-generic-function-class+)
2974          (progn
2975            (std-add-method gf method)
2976            (map-dependents gf
2977                            #'(lambda (dep)
2978                                (update-dependent gf dep 'add-method method))))
2979          (add-method gf method))
2980      method)))
2981
2982(defmacro atomic-defgeneric (function-name &rest rest)
2983  "Macro to define a generic function and 'swap it into place' after
2984it's been fully defined with all its methods.
2985
2986Note: the user should really use the (:method ..) method description
2987way of defining methods; there's not much use in atomically defining
2988generic functions without providing sensible behaviour."
2989  (let ((temp-sym (gensym)))
2990    `(progn
2991       (defgeneric ,temp-sym ,@rest)
2992       (let ((gf (symbol-function ',temp-sym)))
2993         ;; FIXME (rudi 2012-07-08): fset gets the source location info
2994         ;; to charpos 23 always (but (setf fdefinition) leaves the
2995         ;; outdated source position in place, which is even worse).
2996         (fset ',function-name gf)
2997         (%set-generic-function-name gf ',function-name)
2998         (fmakunbound ',temp-sym)
2999         gf))))
3000
3001(defmacro redefine-class-forwarder (name slot &optional body-alist)
3002  "Define a generic function on a temporary symbol as an accessor
3003for the slot `slot'. Then, when definition is complete (including
3004allocation of methods), swap the definition in place.
3005
3006`body-alist' can be used to override the default method bodies for given
3007metaclasses.  In substitute method bodies, `class' names the class
3008instance and, for setters, `new-value' the new value."
3009  (let* ((setterp (consp name))
3010         (%name
3011          (intern (concatenate 'string
3012                               "%"
3013                               (if setterp (symbol-name 'set-) "")
3014                               (symbol-name (if setterp (cadr name) name)))
3015                  (find-package "SYS")))
3016         (bodies
3017          (append body-alist
3018                  (if setterp
3019                      `((built-in-class . (,%name new-value class))
3020                        (forward-referenced-class . (,%name new-value class))
3021                        (structure-class . (,%name new-value class))
3022                        (standard-class . (setf (slot-value class ',slot)
3023                                                new-value))
3024                        (funcallable-standard-class . (setf (slot-value class ',slot)
3025                                                            new-value)))
3026                      `((built-in-class . (,%name class))
3027                        (forward-referenced-class . (,%name class))
3028                        (structure-class . (,%name class))
3029                        (standard-class . (slot-value class ',slot))
3030                        (funcallable-standard-class . (slot-value class ',slot)))))))
3031    `(atomic-defgeneric ,name (,@(when setterp (list 'new-value)) class)
3032        ,@(mapcar #'(lambda (class-name)
3033                      `(:method (,@(when setterp (list 'new-value))
3034                                 (class ,class-name))
3035                         ,(cdr (assoc class-name bodies))))
3036                  '(built-in-class forward-referenced-class structure-class
3037                    standard-class funcallable-standard-class)))))
3038
3039
3040(redefine-class-forwarder class-name name)
3041;;; AMOP pg. 230
3042(redefine-class-forwarder (setf class-name) name
3043   ((standard-class . (progn (reinitialize-instance class :name new-value) new-value))
3044    (funcallable-standard-class . (progn (reinitialize-instance class :name new-value) new-value))))
3045(redefine-class-forwarder class-slots slots)
3046(redefine-class-forwarder (setf class-slots) slots)
3047(redefine-class-forwarder class-direct-slots direct-slots)
3048(redefine-class-forwarder (setf class-direct-slots) direct-slots)
3049(redefine-class-forwarder class-layout layout)
3050(redefine-class-forwarder (setf class-layout) layout)
3051(redefine-class-forwarder class-direct-superclasses direct-superclasses)
3052(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
3053(redefine-class-forwarder class-direct-subclasses direct-subclasses)
3054(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
3055(redefine-class-forwarder class-direct-methods direct-methods)
3056(redefine-class-forwarder (setf class-direct-methods) direct-methods)
3057(redefine-class-forwarder class-precedence-list precedence-list)
3058(redefine-class-forwarder (setf class-precedence-list) precedence-list)
3059(redefine-class-forwarder class-finalized-p finalized-p)
3060(redefine-class-forwarder (setf class-finalized-p) finalized-p)
3061(redefine-class-forwarder class-default-initargs default-initargs)
3062(redefine-class-forwarder (setf class-default-initargs) default-initargs)
3063(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
3064(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
3065
3066;;; Class definition
3067
3068(defun check-duplicate-slots (slots)
3069  (flet ((canonical-slot-name (canonical-slot)
3070           (getf canonical-slot :name)))
3071    (dolist (s1 slots)
3072      (let ((name1 (canonical-slot-name s1)))
3073        (dolist (s2 (cdr (memq s1 slots)))
3074          (when (eq name1 (canonical-slot-name s2))
3075            (error 'program-error "Duplicate slot ~S" name1)))))))
3076
3077(defun check-duplicate-default-initargs (initargs)
3078  (let ((names ()))
3079    (dolist (initarg initargs)
3080      (push (car initarg) names))
3081    (do* ((names names (cdr names))
3082          (name (car names) (car names)))
3083         ((null names))
3084      (when (memq name (cdr names))
3085        (error 'program-error
3086               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
3087               :format-arguments (list name))))))
3088
3089(defun canonicalize-direct-superclasses (direct-superclasses)
3090  (let ((classes '()))
3091    (dolist (class-specifier direct-superclasses)
3092      (let ((class (if (classp class-specifier)
3093                       class-specifier
3094                       (find-class class-specifier nil))))
3095        (unless class
3096          (setf class (make-instance +the-forward-referenced-class+
3097                                     :name class-specifier))
3098          (setf (find-class class-specifier) class))
3099        (when (and (typep class 'built-in-class)
3100                   (not (member class *extensible-built-in-classes*)))
3101          (error "Attempt to define a subclass of built-in-class ~S."
3102                 class-specifier))
3103        (push class classes)))
3104    (nreverse classes)))
3105
3106(atomic-defgeneric add-direct-subclass (superclass subclass)
3107  (:method ((superclass class) (subclass class))
3108    (setf (class-direct-subclasses superclass)
3109          (adjoin subclass (class-direct-subclasses superclass)))))
3110
3111(atomic-defgeneric remove-direct-subclass (superclass subclass)
3112  (:method ((superclass class) (subclass class))
3113    (setf (class-direct-subclasses superclass)
3114          (remove subclass (class-direct-subclasses superclass)))))
3115
3116 ;;; AMOP pg. 182
3117(defun ensure-class (name &rest all-keys &key &allow-other-keys)
3118  (let ((class (find-class name nil)))
3119    ;; CLHS DEFCLASS: "If a class with the same proper name already
3120    ;; exists [...] the existing class is redefined."  Ansi-tests
3121    ;; CLASS-0309 and CLASS-0310.1 demand this behavior.
3122    (if (and class (eql (class-name class) name))
3123        (apply #'ensure-class-using-class class name all-keys)
3124        (apply #'ensure-class-using-class nil name all-keys))))
3125
3126;;; AMOP pg. 183ff.
3127(defgeneric ensure-class-using-class (class name &key direct-default-initargs
3128                                      direct-slots direct-superclasses
3129                                      metaclass &allow-other-keys))
3130
3131(defmethod ensure-class-using-class :before (class name  &key direct-slots
3132                                             direct-default-initargs 
3133                                             &allow-other-keys)
3134  (check-duplicate-slots direct-slots)
3135  (check-duplicate-default-initargs direct-default-initargs))
3136
3137(defmethod ensure-class-using-class ((class null) name &rest all-keys
3138                                     &key (metaclass +the-standard-class+)
3139                                     direct-superclasses
3140                                     &allow-other-keys)
3141  (setf all-keys (copy-list all-keys))  ; since we modify it
3142  (remf all-keys :metaclass)
3143  (unless (classp metaclass) (setf metaclass (find-class metaclass)))
3144  (let ((class (apply (if (eq metaclass +the-standard-class+)
3145                          #'make-instance-standard-class
3146                          #'make-instance)
3147                      metaclass :name name
3148                      :direct-superclasses (canonicalize-direct-superclasses
3149                                            direct-superclasses)
3150                      all-keys)))
3151    (%set-find-class name class)
3152    class))
3153
3154(defmethod ensure-class-using-class ((class built-in-class) name &rest all-keys
3155                                     &key &allow-other-keys)
3156  (declare (ignore all-keys))
3157  (error "The symbol ~S names a built-in class." name))
3158
3159(defmethod ensure-class-using-class ((class forward-referenced-class) name
3160                                     &rest all-keys
3161                                     &key (metaclass +the-standard-class+)
3162                                     direct-superclasses &allow-other-keys)
3163  (setf all-keys (copy-list all-keys))  ; since we modify it
3164  (remf all-keys :metaclass)
3165  (unless (classp metaclass) (setf metaclass (find-class metaclass)))
3166  (apply #'change-class class metaclass all-keys)
3167  (apply #'reinitialize-instance class
3168         :name name
3169         :direct-superclasses (canonicalize-direct-superclasses
3170                               direct-superclasses)
3171         all-keys)
3172  class)
3173
3174(defmethod ensure-class-using-class ((class class) name
3175                                     &rest all-keys
3176                                     &key (metaclass +the-standard-class+ metaclassp)
3177                                     direct-superclasses
3178                                     &allow-other-keys)
3179  (declare (ignore name))
3180  (setf all-keys (copy-list all-keys))  ; since we modify it
3181  (remf all-keys :metaclass)
3182  (unless (classp metaclass) (setf metaclass (find-class metaclass)))
3183  (when (and metaclassp (not (eq (class-of class) metaclass)))
3184    (error 'program-error
3185           "Trying to redefine class ~S with different metaclass."
3186           (class-name class)))
3187  (apply #'reinitialize-instance class
3188         :direct-superclasses (canonicalize-direct-superclasses direct-superclasses)
3189         all-keys)
3190  class)
3191
3192(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
3193  (unless (>= (length form) 3)
3194    (error 'program-error "Wrong number of arguments for DEFCLASS."))
3195  (check-declaration-type name)
3196  `(ensure-class ',name
3197                 :direct-superclasses
3198                 (canonicalize-direct-superclasses ',direct-superclasses)
3199                 :direct-slots
3200                 ,(canonicalize-direct-slots direct-slots)
3201                 ,@(canonicalize-defclass-options options)))
3202
3203
3204;;; AMOP pg. 180
3205(defgeneric direct-slot-definition-class (class &rest initargs))
3206
3207(defmethod direct-slot-definition-class ((class class) &rest initargs)
3208  (declare (ignore initargs))
3209  +the-standard-direct-slot-definition-class+)
3210
3211;;; AMOP pg. 181
3212(defgeneric effective-slot-definition-class (class &rest initargs))
3213
3214(defmethod effective-slot-definition-class ((class class) &rest initargs)
3215  (declare (ignore initargs))
3216  +the-standard-effective-slot-definition-class+)
3217
3218;;; AMOP pg. 224
3219(defgeneric reader-method-class (class direct-slot &rest initargs))
3220
3221(defmethod reader-method-class ((class standard-class)
3222                                (direct-slot standard-direct-slot-definition)
3223                                &rest initargs)
3224  (declare (ignore initargs))
3225  +the-standard-reader-method-class+)
3226
3227(defmethod reader-method-class ((class funcallable-standard-class)
3228                                (direct-slot standard-direct-slot-definition)
3229                                &rest initargs)
3230  (declare (ignore initargs))
3231  +the-standard-reader-method-class+)
3232
3233;;; AMOP pg. 242
3234(defgeneric writer-method-class (class direct-slot &rest initargs))
3235
3236(defmethod writer-method-class ((class standard-class)
3237                                (direct-slot standard-direct-slot-definition)
3238                                &rest initargs)
3239  (declare (ignore initargs))
3240  +the-standard-writer-method-class+)
3241
3242(defmethod writer-method-class ((class funcallable-standard-class)
3243                                (direct-slot standard-direct-slot-definition)
3244                                &rest initargs)
3245  (declare (ignore initargs))
3246  +the-standard-writer-method-class+)
3247
3248(atomic-defgeneric documentation (x doc-type)
3249    (:method ((x symbol) doc-type)
3250        (%documentation x doc-type))
3251    (:method ((x function) doc-type)
3252        (%documentation x doc-type)))
3253
3254(atomic-defgeneric (setf documentation) (new-value x doc-type)
3255    (:method (new-value (x symbol) doc-type)
3256        (%set-documentation x doc-type new-value))
3257    (:method (new-value (x function) doc-type)
3258        (%set-documentation x doc-type new-value)))
3259
3260
3261;; FIXME This should be a weak hashtable!
3262(defvar *list-documentation-hashtable* (make-hash-table :test #'equal))
3263
3264(defmethod documentation ((x list) (doc-type (eql 'function)))
3265  (let ((alist (gethash x *list-documentation-hashtable*)))
3266    (and alist (cdr (assoc doc-type alist)))))
3267
3268(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
3269  (let ((alist (gethash x *list-documentation-hashtable*)))
3270    (and alist (cdr (assoc doc-type alist)))))
3271
3272(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
3273  (let* ((alist (gethash x *list-documentation-hashtable*))
3274         (entry (and alist (assoc doc-type alist))))
3275    (cond (entry
3276           (setf (cdr entry) new-value))
3277          (t
3278           (setf (gethash x *list-documentation-hashtable*)
3279                 (push (cons doc-type new-value) alist)))))
3280  new-value)
3281
3282(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
3283  (let* ((alist (gethash x *list-documentation-hashtable*))
3284         (entry (and alist (assoc doc-type alist))))
3285    (cond (entry
3286           (setf (cdr entry) new-value))
3287          (t
3288           (setf (gethash x *list-documentation-hashtable*)
3289                 (push (cons doc-type new-value) alist)))))
3290  new-value)
3291
3292(defmethod documentation ((x class) (doc-type (eql 't)))
3293  (class-documentation x))
3294
3295(defmethod documentation ((x class) (doc-type (eql 'type)))
3296  (class-documentation x))
3297
3298(defmethod (setf documentation) (new-value (x class) (doc-type (eql 't)))
3299  (%set-class-documentation x new-value))
3300
3301(defmethod (setf documentation) (new-value (x class) (doc-type (eql 'type)))
3302  (%set-class-documentation x new-value))
3303
3304(defmethod documentation ((x structure-class) (doc-type (eql 't)))
3305  (%documentation x t))
3306
3307(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
3308  (%documentation x t))
3309
3310(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
3311  (%set-documentation x t new-value))
3312
3313(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
3314  (%set-documentation x t new-value))
3315
3316(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
3317  (generic-function-documentation x))
3318
3319(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
3320  (setf (generic-function-documentation x) new-value))
3321
3322(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
3323  (generic-function-documentation x))
3324
3325(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
3326  (setf (generic-function-documentation x) new-value))
3327
3328(defmethod documentation ((x standard-method) (doc-type (eql 't)))
3329  (method-documentation x))
3330
3331(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
3332  (setf (method-documentation x) new-value))
3333
3334(defmethod documentation ((x standard-slot-definition) (doc-type (eql 't)))
3335  (slot-definition-documentation x))
3336
3337(defmethod (setf documentation) (new-value (x standard-slot-definition) (doc-type (eql 't)))
3338  (setf (slot-definition-documentation x) new-value))
3339
3340(defmethod documentation ((x package) (doc-type (eql 't)))
3341  (%documentation x doc-type))
3342
3343(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
3344  (%set-documentation x doc-type new-value))
3345
3346(defmethod documentation ((x symbol) (doc-type (eql 'function)))
3347  (if (and (fboundp x) (typep (fdefinition x) 'generic-function))
3348      (documentation (fdefinition x) doc-type)
3349      (%documentation x doc-type)))
3350
3351(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'function)))
3352  (if (and (fboundp x) (typep (fdefinition x) 'generic-function))
3353      (setf (documentation (fdefinition x) 'function) new-value)
3354      (%set-documentation x 'function new-value)))
3355
3356(defmethod documentation ((x symbol) (doc-type (eql 'type)))
3357  (let ((class (find-class x nil)))
3358    (if class
3359        (documentation class t)
3360        (%documentation x 'type))))
3361
3362(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
3363  (%documentation x 'structure))
3364
3365(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
3366  (let ((class (find-class x nil)))
3367    (if class
3368        (setf (documentation class t) new-value)
3369        (%set-documentation x 'type new-value))))
3370
3371(defmethod (setf documentation) (new-value (x symbol)
3372                                 (doc-type (eql 'structure)))
3373  (%set-documentation x 'structure new-value))
3374
3375;;; Applicable methods
3376
3377(atomic-defgeneric compute-applicable-methods (gf args)
3378  (:method ((gf standard-generic-function) args)
3379    (std-compute-applicable-methods gf args)))
3380
3381(defgeneric compute-applicable-methods-using-classes (gf classes)
3382  (:method ((gf standard-generic-function) classes)
3383    (let ((methods '()))
3384      (dolist (method (generic-function-methods gf))
3385  (multiple-value-bind (applicable knownp)
3386      (method-applicable-using-classes-p method classes)
3387    (cond (applicable
3388     (push method methods))
3389    ((not knownp)
3390     (return-from compute-applicable-methods-using-classes
3391       (values nil nil))))))
3392      (values (sort-methods methods gf classes)
3393        t))))
3394
3395
3396;;; Slot access
3397;;;
3398;;; See AMOP pg. 156ff. for an overview.
3399;;;
3400;;; AMOP specifies these generic functions to dispatch on slot objects
3401;;; (with the exception of slot-exists-p-using-class), although its
3402;;; sample implementation Closette dispatches on slot names.  We let
3403;;; slot-value and friends call their gf counterparts with the effective
3404;;; slot definition, but leave the definitions dispatching on slot name
3405;;; in place for user convenience.
3406
3407;;; AMOP pg. 235
3408(defgeneric slot-value-using-class (class instance slot))
3409
3410(defmethod slot-value-using-class ((class standard-class) instance (slot symbol))
3411  (std-slot-value instance slot))
3412(defmethod slot-value-using-class ((class standard-class) instance
3413                                   (slot standard-effective-slot-definition))
3414  (let* ((location (slot-definition-location slot))
3415         (value (if (consp location)
3416                    (cdr location)      ; :allocation :class
3417                    (standard-instance-access instance location))))
3418    (if (eq value +slot-unbound+)
3419        ;; fix SLOT-UNBOUND.5 from ansi test suite
3420        (nth-value 0 (slot-unbound class instance (slot-definition-name slot)))
3421        value)))
3422
3423(defmethod slot-value-using-class ((class funcallable-standard-class)
3424                                   instance (slot symbol))
3425  (std-slot-value instance slot))
3426(defmethod slot-value-using-class ((class funcallable-standard-class) instance
3427                                   (slot standard-effective-slot-definition))
3428  (let* ((location (slot-definition-location slot))
3429         (value (if (consp location)
3430                    (cdr location)      ; :allocation :class
3431                    (funcallable-standard-instance-access instance location))))
3432    (if (eq value +slot-unbound+)
3433        ;; fix SLOT-UNBOUND.5 from ansi test suite
3434        (nth-value 0 (slot-unbound class instance (slot-definition-name slot)))
3435        value)))
3436
3437(defmethod slot-value-using-class ((class structure-class) instance
3438                                   (slot symbol))
3439  (std-slot-value instance slot))
3440(defmethod slot-value-using-class ((class structure-class) instance
3441                                   (slot standard-effective-slot-definition))
3442  (std-slot-value instance (slot-definition-name slot)))
3443
3444;;; AMOP pg. 231
3445(defgeneric (setf slot-value-using-class) (new-value class instance slot))
3446
3447(defmethod (setf slot-value-using-class) (new-value
3448                                          (class standard-class)
3449                                          instance
3450                                          (slot symbol))
3451  (setf (std-slot-value instance slot) new-value))
3452(defmethod (setf slot-value-using-class) (new-value
3453                                          (class standard-class)
3454                                          instance
3455                                          (slot standard-effective-slot-definition))
3456  (let ((location (slot-definition-location slot)))
3457    (if (consp location)                ; :allocation :class
3458        (setf (cdr location) new-value)
3459        (setf (standard-instance-access instance location) new-value))))
3460
3461(defmethod (setf slot-value-using-class) (new-value
3462                                          (class funcallable-standard-class)
3463                                          instance
3464                                          (slot symbol))
3465  (setf (std-slot-value instance slot) new-value))
3466(defmethod (setf slot-value-using-class) (new-value
3467                                          (class funcallable-standard-class)
3468                                          instance
3469                                          (slot standard-effective-slot-definition))
3470  (let ((location (slot-definition-location slot)))
3471    (if (consp location)                ; :allocation :class
3472        (setf (cdr location) new-value)
3473        (setf (funcallable-standard-instance-access instance location)
3474              new-value))))
3475
3476(defmethod (setf slot-value-using-class) (new-value
3477                                          (class structure-class)
3478                                          instance
3479                                          (slot symbol))
3480  (setf (std-slot-value instance slot) new-value))
3481(defmethod (setf slot-value-using-class) (new-value
3482                                          (class structure-class)
3483                                          instance
3484                                          (slot standard-effective-slot-definition))
3485  (setf (std-slot-value instance (slot-definition-name slot)) new-value))
3486
3487;;; slot-exists-p-using-class is not specified by AMOP, and obviously
3488;;; cannot be specialized on the slot type.  Hence, its implementation
3489;;; differs from slot-(boundp|makunbound|value)-using-class
3490(defgeneric slot-exists-p-using-class (class instance slot-name))
3491
3492(defmethod slot-exists-p-using-class (class instance slot-name)
3493  nil)
3494
3495(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
3496  (std-slot-exists-p instance slot-name))
3497(defmethod slot-exists-p-using-class ((class funcallable-standard-class) instance slot-name)
3498  (std-slot-exists-p instance slot-name))
3499
3500(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
3501  (dolist (dsd (class-slots class))
3502    (when (eq (sys::dsd-name dsd) slot-name)
3503      (return-from slot-exists-p-using-class t)))
3504  nil)
3505
3506
3507(defgeneric slot-boundp-using-class (class instance slot))
3508(defmethod slot-boundp-using-class ((class standard-class) instance (slot symbol))
3509  (std-slot-boundp instance slot))
3510(defmethod slot-boundp-using-class ((class standard-class) instance
3511                                    (slot standard-effective-slot-definition))
3512  (let ((location (slot-definition-location slot)))
3513    (if (consp location)
3514        (not (eq (cdr location) +slot-unbound+)) ; :allocation :class
3515        (not (eq (standard-instance-access instance location) +slot-unbound+)))))
3516
3517(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance
3518                                    (slot symbol))
3519  (std-slot-boundp instance slot))
3520(defmethod slot-boundp-using-class ((class funcallable-standard-class) instance
3521                                    (slot standard-effective-slot-definition))
3522  (let ((location (slot-definition-location slot)))
3523    (if (consp location)
3524        (not (eq (cdr location) +slot-unbound+)) ; :allocation :class
3525        (not (eq (funcallable-standard-instance-access instance location)
3526                 +slot-unbound+)))))
3527
3528(defmethod slot-boundp-using-class ((class structure-class) instance slot)
3529  "Structure slots can't be unbound, so this method always returns T."
3530  (declare (ignore class instance slot))
3531  t)
3532
3533(defgeneric slot-makunbound-using-class (class instance slot))
3534(defmethod slot-makunbound-using-class ((class standard-class)
3535                                        instance
3536                                        (slot symbol))
3537  (std-slot-makunbound instance slot))
3538(defmethod slot-makunbound-using-class ((class standard-class)
3539                                        instance
3540                                        (slot standard-effective-slot-definition))
3541  (let ((location (slot-definition-location slot)))
3542    (if (consp location)
3543        (setf (cdr location) +slot-unbound+)
3544        (setf (standard-instance-access instance location) +slot-unbound+))))
3545
3546(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
3547                                        instance
3548                                        (slot symbol))
3549  (std-slot-makunbound instance slot))
3550(defmethod slot-makunbound-using-class ((class funcallable-standard-class)
3551                                        instance
3552                                        (slot symbol))
3553  (let ((location (slot-definition-location slot)))
3554    (if (consp location)
3555        (setf (cdr location) +slot-unbound+)
3556        (setf (funcallable-standard-instance-access instance location)
3557              +slot-unbound+))))
3558
3559(defmethod slot-makunbound-using-class ((class structure-class)
3560                                        instance
3561                                        slot)
3562  (declare (ignore class instance slot))
3563  (error "Structure slots can't be unbound"))
3564
3565(defgeneric slot-missing (class instance slot-name operation &optional new-value))
3566
3567(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
3568  (declare (ignore new-value))
3569  (error "The slot ~S is missing from the class ~S." slot-name class))
3570
3571(defgeneric slot-unbound (class instance slot-name))
3572
3573(defmethod slot-unbound ((class t) instance slot-name)
3574  (error 'unbound-slot :instance instance :name slot-name))
3575
3576;;; Instance creation and initialization
3577
3578;;; AMOP pg. 168ff.
3579(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
3580
3581(defmethod allocate-instance ((class standard-class) &rest initargs)
3582  (declare (ignore initargs))
3583  (std-allocate-instance class))
3584
3585(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs)
3586  (declare (ignore initargs))
3587  (allocate-funcallable-instance class))
3588
3589(defmethod allocate-instance ((class structure-class) &rest initargs)
3590  (declare (ignore initargs))
3591  (%make-structure (class-name class)
3592                   (make-list (length (class-slots class))
3593                              :initial-element +slot-unbound+)))
3594
3595(defmethod allocate-instance ((class built-in-class) &rest initargs)
3596  (declare (ignore initargs))
3597  (error "Cannot allocate instances of a built-in class: ~S" class))
3598
3599(defmethod allocate-instance :before ((class class) &rest initargs)
3600  (declare (ignore initargs))
3601  (unless (class-finalized-p class)
3602    (finalize-inheritance class)))
3603
3604;; "The set of valid initialization arguments for a class is the set of valid
3605;; initialization arguments that either fill slots or supply arguments to
3606;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
3607;; 7.1.2
3608
3609(defun calculate-allowable-initargs (gf-list args instance
3610                                             shared-initialize-param
3611                                             initargs)
3612  (let* ((methods
3613          (nconc
3614             (std-compute-applicable-methods #'shared-initialize
3615                                             (list* instance
3616                                                    shared-initialize-param
3617                                                    initargs))
3618             (mapcan #'(lambda (gf)
3619                         (if (eq (class-of gf)
3620                                 +the-standard-generic-function-class+)
3621                             (std-compute-applicable-methods gf args)
3622                             (compute-applicable-methods gf args)))
3623                     gf-list)))
3624         (method-keyword-args
3625          (reduce #'merge-initargs-sets
3626                  (mapcar #'method-lambda-list methods)
3627                  :key #'extract-lambda-list-keywords
3628                  :initial-value nil))
3629         (slots-initargs
3630          (mapappend #'slot-definition-initargs
3631                     (class-slots (class-of instance)))))
3632    (merge-initargs-sets
3633     (merge-initargs-sets slots-initargs method-keyword-args)
3634     '(:allow-other-keys))))  ;; allow-other-keys is always allowed
3635
3636(defun check-initargs (gf-list args instance
3637                       shared-initialize-param initargs
3638                       cache call-site)
3639  "Checks the validity of `initargs' for the generic functions in `gf-list'
3640when called with `args' by calculating the applicable methods for each gf.
3641The applicable methods for SHARED-INITIALIZE based on `instance',
3642`shared-initialize-param' and `initargs' are added to the list of
3643applicable methods."
3644  (when (oddp (length initargs))
3645    (error 'program-error
3646           :format-control "Odd number of keyword arguments."))
3647  (unless (getf initargs :allow-other-keys)
3648    (multiple-value-bind (allowable-initargs present-p)
3649                         (when cache
3650                           (gethash (class-of instance) cache))
3651       (unless present-p
3652         (setf allowable-initargs
3653               (calculate-allowable-initargs gf-list args instance
3654                                             shared-initialize-param initargs))
3655         (when cache
3656           (setf (gethash (class-of instance) cache)
3657                 allowable-initargs)))
3658       (unless (eq t allowable-initargs)
3659         (do* ((tail initargs (cddr tail))
3660               (initarg (car tail) (car tail)))
3661              ((null tail))
3662              (unless (memq initarg allowable-initargs)
3663                (error 'program-error
3664                       :format-control "Invalid initarg ~S in call to ~S with arglist ~S."
3665                       :format-arguments (list initarg call-site args))))))))
3666
3667(defun merge-initargs-sets (list1 list2)
3668  (cond
3669   ((eq list1 t)  t)
3670   ((eq list2 t)  t)
3671   (t             (union list1 list2))))
3672
3673(defun extract-lambda-list-keywords (lambda-list)
3674  "Returns a list of keywords acceptable as keyword arguments,
3675or T when any keyword is acceptable due to presence of
3676&allow-other-keys."
3677  (when (member '&allow-other-keys lambda-list)
3678    (return-from extract-lambda-list-keywords t))
3679  (loop with keyword-args = (cdr (memq '&key lambda-list))
3680        for key in keyword-args
3681        when (eq key '&aux) do (loop-finish)
3682        when (eq key '&allow-other-keys) do (return t)
3683        when (listp key) do (setq key (car key))
3684        collect (if (symbolp key)
3685                    (make-keyword key)
3686                  (car key))))
3687
3688
3689(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
3690
3691(defmethod make-instance :before ((class class) &rest initargs)
3692  (when (oddp (length initargs))
3693    (error 'program-error :format-control "Odd number of keyword arguments."))
3694  (unless (class-finalized-p class)
3695    (finalize-inheritance class)))
3696
3697(defun augment-initargs-with-defaults (class initargs)
3698  (let ((default-initargs '()))
3699    (dolist (initarg (class-default-initargs class))
3700      (let ((key (first initarg))
3701            (fn (third initarg)))
3702        (when (eq (getf initargs key +slot-unbound+) +slot-unbound+)
3703          (push key default-initargs)
3704          (push (funcall fn) default-initargs))))
3705    (append initargs (nreverse default-initargs))))
3706
3707(defmethod make-instance ((class standard-class) &rest initargs)
3708  (setf initargs (augment-initargs-with-defaults class initargs))
3709  (let ((instance (std-allocate-instance class)))
3710    (check-initargs (list #'allocate-instance #'initialize-instance)
3711                    (list* instance initargs)
3712                    instance t initargs
3713                    *make-instance-initargs-cache* 'make-instance)
3714    (apply #'initialize-instance instance initargs)
3715    instance))
3716
3717(defmethod make-instance ((class funcallable-standard-class) &rest initargs)
3718  (setf initargs (augment-initargs-with-defaults class initargs))
3719  (let ((instance (allocate-funcallable-instance class)))
3720    (check-initargs (list #'allocate-instance #'initialize-instance)
3721                    (list* instance initargs)
3722                    instance t initargs
3723                    *make-instance-initargs-cache* 'make-instance)
3724    (apply #'initialize-instance instance initargs)
3725    instance))
3726
3727(defmethod make-instance ((class symbol) &rest initargs)
3728  (apply #'make-instance (find-class class) initargs))
3729
3730(defgeneric initialize-instance (instance &rest initargs
3731                                          &key &allow-other-keys))
3732
3733(defmethod initialize-instance ((instance standard-object) &rest initargs)
3734  (apply #'shared-initialize instance t initargs))
3735
3736(defgeneric reinitialize-instance (instance &rest initargs
3737                                            &key &allow-other-keys))
3738
3739;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the
3740;; validity of initargs and signals an error if an initarg is supplied that is
3741;; not declared as valid. The method then calls the generic function SHARED-
3742;; INITIALIZE with the following arguments: the instance, nil (which means no
3743;; slots should be initialized according to their initforms), and the initargs
3744;; it received."
3745(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
3746  (check-initargs (list #'reinitialize-instance) (list* instance initargs)
3747                  instance () initargs
3748                  *reinitialize-instance-initargs-cache* 'reinitialize-instance)
3749  (apply #'shared-initialize instance () initargs))
3750
3751(defun std-shared-initialize (instance slot-names all-keys)
3752  (when (oddp (length all-keys))
3753    (error 'program-error :format-control "Odd number of keyword arguments."))
3754  ;; do a quick scan of the arguments list to see if it's a real
3755  ;; 'initialization argument list' (which is not the same as
3756  ;; checking initarg validity
3757  (do* ((tail all-keys (cddr tail))
3758        (initarg (car tail) (car tail)))
3759      ((null tail))
3760    (unless (symbolp initarg)
3761      (error 'program-error
3762             :format-control "Initarg ~S not a symbol."
3763             :format-arguments (list initarg))))
3764  (dolist (slot (class-slots (class-of instance)))
3765    (let ((slot-name (slot-definition-name slot)))
3766      (multiple-value-bind (init-key init-value foundp)
3767          (get-properties all-keys (slot-definition-initargs slot))
3768        (if foundp
3769            (setf (std-slot-value instance slot-name) init-value)
3770            (unless (std-slot-boundp instance slot-name)
3771              (let ((initfunction (slot-definition-initfunction slot)))
3772                (when (and initfunction (or (eq slot-names t)
3773                                            (memq slot-name slot-names)))
3774                  (setf (std-slot-value instance slot-name)
3775                        (funcall initfunction)))))))))
3776  instance)
3777
3778(defgeneric shared-initialize (instance slot-names
3779                                        &rest initargs
3780                                        &key &allow-other-keys))
3781
3782(defmethod shared-initialize ((instance standard-object) slot-names
3783                              &rest initargs)
3784  (std-shared-initialize instance slot-names initargs))
3785
3786(defmethod shared-initialize ((slot slot-definition) slot-names
3787                              &rest args
3788                              &key name initargs initform initfunction
3789                              readers writers allocation
3790                              &allow-other-keys)
3791  ;;Keyword args are duplicated from init-slot-definition only to have
3792  ;;them checked.
3793  (declare (ignore slot-names)) ;;TODO?
3794  (declare (ignore name initargs initform initfunction readers writers allocation))
3795  ;;For built-in slots
3796  (apply #'init-slot-definition slot :allow-other-keys t args)
3797  ;;For user-defined slots
3798  (call-next-method))
3799
3800;;; change-class
3801
3802(defgeneric change-class (instance new-class &key &allow-other-keys))
3803
3804(defmethod change-class ((old-instance standard-object) (new-class standard-class)
3805                         &rest initargs)
3806  (let ((old-slots (class-slots (class-of old-instance)))
3807        (new-slots (class-slots new-class))
3808        (new-instance (allocate-instance new-class)))
3809    ;; "The values of local slots specified by both the class CTO and the class
3810    ;; CFROM are retained. If such a local slot was unbound, it remains
3811    ;; unbound."
3812    (dolist (new-slot new-slots)
3813      (when (instance-slot-p new-slot)
3814        (let* ((slot-name (slot-definition-name new-slot))
3815               (old-slot (find slot-name old-slots :key 'slot-definition-name)))
3816          ;; "The values of slots specified as shared in the class CFROM and as
3817          ;; local in the class CTO are retained."
3818          (when (and old-slot (slot-boundp old-instance slot-name))
3819            (setf (slot-value new-instance slot-name)
3820                  (slot-value old-instance slot-name))))))
3821    (swap-slots old-instance new-instance)
3822    (rotatef (std-instance-layout new-instance)
3823             (std-instance-layout old-instance))
3824    (apply #'update-instance-for-different-class
3825           new-instance old-instance initargs)
3826    old-instance))
3827
3828(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
3829  (apply #'change-class instance (find-class new-class) initargs))
3830
3831(defgeneric update-instance-for-different-class (old new
3832                                                     &rest initargs
3833                                                     &key &allow-other-keys))
3834
3835(defmethod update-instance-for-different-class
3836  ((old standard-object) (new standard-object) &rest initargs)
3837  (let ((added-slots
3838         (remove-if #'(lambda (slot-name)
3839                       (slot-exists-p old slot-name))
3840                    (mapcar 'slot-definition-name
3841                            (class-slots (class-of new))))))
3842    (check-initargs (list #'update-instance-for-different-class)
3843                    (list old new initargs)
3844                    new added-slots initargs
3845                    nil 'update-instance-for-different-class)
3846    (apply #'shared-initialize new added-slots initargs)))
3847
3848;;; make-instances-obsolete
3849
3850(defgeneric make-instances-obsolete (class))
3851
3852(defmethod make-instances-obsolete ((class standard-class))
3853  (%make-instances-obsolete class))
3854(defmethod make-instances-obsolete ((class funcallable-standard-class))
3855  (%make-instances-obsolete class))
3856(defmethod make-instances-obsolete ((class symbol))
3857  (make-instances-obsolete (find-class class))
3858  class)
3859
3860;;; update-instance-for-redefined-class
3861
3862(defgeneric update-instance-for-redefined-class (instance
3863                                                 added-slots
3864                                                 discarded-slots
3865                                                 property-list
3866                                                 &rest initargs
3867                                                 &key
3868                                                 &allow-other-keys))
3869
3870(defmethod update-instance-for-redefined-class ((instance standard-object)
3871            added-slots
3872            discarded-slots
3873            property-list
3874            &rest initargs)
3875  (check-initargs (list #'update-instance-for-redefined-class)
3876                  (list* instance added-slots discarded-slots
3877                         property-list initargs)
3878                  instance added-slots initargs
3879                  nil 'update-instance-for-redefined-class)
3880  (apply #'shared-initialize instance added-slots initargs))
3881
3882;;;  Methods having to do with class metaobjects.
3883
3884(defmethod initialize-instance :after ((class standard-class) &rest args)
3885  (apply #'std-after-initialization-for-classes class args))
3886
3887(defmethod initialize-instance :after ((class funcallable-standard-class)
3888                                       &rest args)
3889  (apply #'std-after-initialization-for-classes class args))
3890
3891(defmethod reinitialize-instance :before ((class standard-class)
3892                                          &rest all-keys
3893                                          &key direct-superclasses)
3894  (check-initargs (list #'allocate-instance
3895                        #'initialize-instance)
3896                  (list* class all-keys)
3897                  class t all-keys
3898                  nil 'reinitialize-instance)
3899  (dolist (superclass (set-difference (class-direct-superclasses class)
3900                                      direct-superclasses))
3901    (remove-direct-subclass superclass class))
3902  (dolist (superclass (set-difference direct-superclasses
3903                                      (class-direct-superclasses class)))
3904    (add-direct-subclass superclass class)))
3905
3906(defmethod reinitialize-instance :before ((class funcallable-standard-class)
3907                                          &rest all-keys
3908                                          &key direct-superclasses)
3909  (check-initargs (list #'allocate-instance
3910                        #'initialize-instance)
3911                  (list* class all-keys)
3912                  class t all-keys
3913                  nil 'reinitialize-instance)
3914  (dolist (superclass (set-difference (class-direct-superclasses class)
3915                                      direct-superclasses))
3916    (remove-direct-subclass superclass class))
3917  (dolist (superclass (set-difference direct-superclasses
3918                                      (class-direct-superclasses class)))
3919    (add-direct-subclass superclass class)))
3920
3921(defun std-after-reinitialization-for-classes (class
3922                                               &rest all-keys
3923                                               &key (direct-superclasses nil direct-superclasses-p)
3924                                               (direct-slots nil direct-slots-p)
3925                                               (direct-default-initargs nil direct-default-initargs-p)
3926                                               &allow-other-keys)
3927  (remhash class *make-instance-initargs-cache*)
3928  (remhash class *reinitialize-instance-initargs-cache*)
3929  (%make-instances-obsolete class)
3930  (setf (class-finalized-p class) nil)
3931  (when direct-superclasses-p
3932    (let* ((old-supers (class-direct-superclasses class))
3933           (new-supers (canonicalize-direct-superclass-list
3934                        class direct-superclasses)))
3935      (setf (class-direct-superclasses class) new-supers)
3936      (dolist (old-superclass (set-difference old-supers new-supers))
3937        (remove-direct-subclass old-superclass class))
3938      (dolist (new-superclass (set-difference new-supers old-supers))
3939        (add-direct-subclass new-superclass class))))
3940  (when direct-slots-p
3941    ;; FIXME: maybe remove old reader and writer methods?
3942    (let ((slots (mapcar #'(lambda (slot-properties)
3943                             (apply #'make-direct-slot-definition class slot-properties))
3944                         direct-slots)))
3945      (setf (class-direct-slots class) slots)
3946      (dolist (direct-slot slots)
3947        (dolist (reader (slot-definition-readers direct-slot))
3948          (add-reader-method class reader direct-slot))
3949        (dolist (writer (slot-definition-writers direct-slot))
3950          (add-writer-method class writer direct-slot)))))
3951  (when direct-default-initargs-p
3952    (setf (class-direct-default-initargs class) direct-default-initargs))
3953  (maybe-finalize-class-subtree class)
3954  (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys))))
3955
3956(defmethod reinitialize-instance :after ((class standard-class)
3957                                         &rest all-keys)
3958  (apply #'std-after-reinitialization-for-classes class all-keys))
3959
3960(defmethod reinitialize-instance :after ((class funcallable-standard-class)
3961                                         &rest all-keys)
3962  (apply #'std-after-reinitialization-for-classes class all-keys))
3963
3964(defmethod reinitialize-instance :after ((gf standard-generic-function)
3965                                         &rest all-keys)
3966  (map-dependents gf #'(lambda (dep) (update-dependent gf dep all-keys))))
3967
3968;;; Finalize inheritance
3969
3970(atomic-defgeneric finalize-inheritance (class)
3971    (:method ((class standard-class))
3972       (std-finalize-inheritance class))
3973    (:method ((class funcallable-standard-class))
3974       (std-finalize-inheritance class)))
3975
3976;;; Default initargs
3977
3978;;; AMOP pg. 174
3979(atomic-defgeneric compute-default-initargs (class)
3980  (:method ((class standard-class))
3981    (std-compute-default-initargs class))
3982  (:method ((class funcallable-standard-class))
3983    (std-compute-default-initargs class)))
3984
3985;;; Class precedence lists
3986
3987(defgeneric compute-class-precedence-list (class))
3988(defmethod compute-class-precedence-list ((class standard-class))
3989  (std-compute-class-precedence-list class))
3990(defmethod compute-class-precedence-list ((class funcallable-standard-class))
3991  (std-compute-class-precedence-list class))
3992
3993;;; Slot inheritance
3994
3995(defgeneric compute-slots (class))
3996(defmethod compute-slots ((class standard-class))
3997  (std-compute-slots class))
3998(defmethod compute-slots ((class funcallable-standard-class))
3999  (std-compute-slots class))
4000
4001(defgeneric compute-effective-slot-definition (class name direct-slots))
4002(defmethod compute-effective-slot-definition
4003  ((class standard-class) name direct-slots)
4004  (std-compute-effective-slot-definition class name direct-slots))
4005(defmethod compute-effective-slot-definition
4006  ((class funcallable-standard-class) name direct-slots)
4007  (std-compute-effective-slot-definition class name direct-slots))
4008
4009;;; Methods having to do with generic function invocation.
4010
4011(defgeneric compute-discriminating-function (gf))
4012(defmethod compute-discriminating-function ((gf standard-generic-function))
4013  (std-compute-discriminating-function gf))
4014
4015(defgeneric method-more-specific-p (gf method1 method2 required-classes))
4016
4017(defmethod method-more-specific-p ((gf standard-generic-function)
4018                                   method1 method2 required-classes)
4019  (let ((method-indices
4020         (argument-precedence-order-indices
4021          (generic-function-argument-precedence-order gf)
4022          (getf (analyze-lambda-list (generic-function-lambda-list gf))
4023                ':required-args))))
4024    (std-method-more-specific-p method1 method2 required-classes method-indices)))
4025
4026;;; AMOP pg. 176
4027(defgeneric compute-effective-method (gf method-combination methods))
4028(defmethod compute-effective-method ((gf standard-generic-function) method-combination methods)
4029  (std-compute-effective-method gf method-combination methods))
4030
4031(defgeneric compute-applicable-methods (gf args))
4032(defmethod compute-applicable-methods ((gf standard-generic-function) args)
4033  (std-compute-applicable-methods gf args))
4034
4035;;; AMOP pg. 207
4036(atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment)
4037  (:method ((generic-function standard-generic-function)
4038            (method standard-method)
4039            lambda-expression environment)
4040    (declare (ignore environment))
4041    (values (compute-method-function lambda-expression) nil)))
4042
4043
4044;;; Slot definition accessors
4045
4046(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
4047  `(let (($cl (class-of ,slot-definition)))
4048     (case $cl
4049       ((+the-standard-slot-definition-class+
4050         +the-standard-direct-slot-definition-class+
4051         +the-standard-effective-slot-definition-class+)
4052        ,std-form)
4053       (t ,generic-form))))
4054
4055(atomic-defgeneric slot-definition-allocation (slot-definition)
4056  (:method ((slot-definition slot-definition))
4057    (slot-definition-dispatch slot-definition
4058      (%slot-definition-allocation slot-definition)
4059      (slot-value slot-definition 'sys::allocation))))
4060
4061(atomic-defgeneric (setf slot-definition-allocation) (value slot-definition)
4062  (:method (value (slot-definition slot-definition))
4063    (slot-definition-dispatch slot-definition
4064      (set-slot-definition-allocation slot-definition value)
4065      (setf (slot-value slot-definition 'sys::allocation) value))))
4066
4067(atomic-defgeneric slot-definition-initargs (slot-definition)
4068  (:method ((slot-definition slot-definition))
4069    (slot-definition-dispatch slot-definition
4070      (%slot-definition-initargs slot-definition)
4071      (slot-value slot-definition 'sys::initargs))))
4072
4073(atomic-defgeneric slot-definition-initform (slot-definition)
4074  (:method ((slot-definition slot-definition))
4075    (slot-definition-dispatch slot-definition
4076      (%slot-definition-initform slot-definition)
4077      (slot-value slot-definition 'sys::initform))))
4078
4079(atomic-defgeneric (setf slot-definition-initform) (value slot-definition)
4080  (:method (value (slot-definition slot-definition))
4081    (slot-definition-dispatch slot-definition
4082      (set-slot-definition-initform slot-definition value)
4083      (setf (slot-value slot-definition 'sys::initform) value))))
4084
4085(atomic-defgeneric slot-definition-initfunction (slot-definition)
4086  (:method ((slot-definition slot-definition))
4087    (slot-definition-dispatch slot-definition
4088      (%slot-definition-initfunction slot-definition)
4089      (slot-value slot-definition 'sys::initfunction))))
4090
4091(atomic-defgeneric (setf slot-definition-initfunction) (value slot-definition)
4092  (:method (value (slot-definition slot-definition))
4093    (slot-definition-dispatch slot-definition
4094      (set-slot-definition-initfunction slot-definition value)
4095      (setf (slot-value slot-definition 'sys::initfunction) value))))
4096
4097(atomic-defgeneric slot-definition-name (slot-definition)
4098  (:method ((slot-definition slot-definition))
4099    (slot-definition-dispatch slot-definition
4100      (%slot-definition-name slot-definition)
4101      (slot-value slot-definition 'sys::name))))
4102
4103(atomic-defgeneric (setf slot-definition-name) (value slot-definition)
4104  (:method (value (slot-definition slot-definition))
4105    (slot-definition-dispatch slot-definition
4106      (set-slot-definition-name slot-definition value)
4107      (setf (slot-value slot-definition 'sys::name) value))))
4108
4109(atomic-defgeneric slot-definition-readers (slot-definition)
4110  (:method ((slot-definition slot-definition))
4111    (slot-definition-dispatch slot-definition
4112      (%slot-definition-readers slot-definition)
4113      (slot-value slot-definition 'sys::readers))))
4114
4115(atomic-defgeneric (setf slot-definition-readers) (value slot-definition)
4116  (:method (value (slot-definition slot-definition))
4117    (slot-definition-dispatch slot-definition
4118      (set-slot-definition-readers slot-definition value)
4119      (setf (slot-value slot-definition 'sys::readers) value))))
4120
4121(atomic-defgeneric slot-definition-writers (slot-definition)
4122  (:method ((slot-definition slot-definition))
4123    (slot-definition-dispatch slot-definition
4124      (%slot-definition-writers slot-definition)
4125      (slot-value slot-definition 'sys::writers))))
4126
4127(atomic-defgeneric (setf slot-definition-writers) (value slot-definition)
4128  (:method (value (slot-definition slot-definition))
4129    (slot-definition-dispatch slot-definition
4130      (set-slot-definition-writers slot-definition value)
4131      (setf (slot-value slot-definition 'sys::writers) value))))
4132
4133(atomic-defgeneric slot-definition-allocation-class (slot-definition)
4134  (:method ((slot-definition slot-definition))
4135    (slot-definition-dispatch slot-definition
4136      (%slot-definition-allocation-class slot-definition)
4137      (slot-value slot-definition 'sys::allocation-class))))
4138
4139(atomic-defgeneric (setf slot-definition-allocation-class)
4140                       (value slot-definition)
4141  (:method (value (slot-definition slot-definition))
4142    (slot-definition-dispatch slot-definition
4143      (set-slot-definition-allocation-class slot-definition value)
4144      (setf (slot-value slot-definition 'sys::allocation-class) value))))
4145
4146(atomic-defgeneric slot-definition-location (slot-definition)
4147  (:method ((slot-definition slot-definition))
4148    (slot-definition-dispatch slot-definition
4149      (%slot-definition-location slot-definition)
4150      (slot-value slot-definition 'sys::location))))
4151
4152(atomic-defgeneric (setf slot-definition-location) (value slot-definition)
4153  (:method (value (slot-definition slot-definition))
4154    (slot-definition-dispatch slot-definition
4155      (set-slot-definition-location slot-definition value)
4156      (setf (slot-value slot-definition 'sys::location) value))))
4157
4158(atomic-defgeneric slot-definition-type (slot-definition)
4159  (:method ((slot-definition slot-definition))
4160    (slot-definition-dispatch slot-definition
4161      (%slot-definition-type slot-definition)
4162      (slot-value slot-definition 'sys::%type))))
4163
4164(atomic-defgeneric (setf slot-definition-type) (value slot-definition)
4165  (:method (value (slot-definition slot-definition))
4166    (slot-definition-dispatch slot-definition
4167      (set-slot-definition-type slot-definition value)
4168      (setf (slot-value slot-definition 'sys::%type) value))))
4169
4170(atomic-defgeneric slot-definition-documentation (slot-definition)
4171  (:method ((slot-definition slot-definition))
4172    (slot-definition-dispatch slot-definition
4173      (%slot-definition-documentation slot-definition)
4174      (slot-value slot-definition 'sys:%documentation))))
4175
4176(atomic-defgeneric (setf slot-definition-documentation) (value slot-definition)
4177  (:method (value (slot-definition slot-definition))
4178    (slot-definition-dispatch slot-definition
4179      (set-slot-definition-documentation slot-definition value)
4180      (setf (slot-value slot-definition 'sys:%documentation) value))))
4181
4182
4183;;; Conditions.
4184
4185(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
4186  (let ((parent-types (or parent-types '(condition)))
4187        (report nil))
4188    (dolist (option options)
4189      (when (eq (car option) :report)
4190        (setf report (cadr option))
4191  (setf options (delete option options :test #'equal))
4192        (return)))
4193    (typecase report
4194      (null
4195       `(progn
4196          (defclass ,name ,parent-types ,slot-specs ,@options)
4197          ',name))
4198      (string
4199       `(progn
4200          (defclass ,name ,parent-types ,slot-specs ,@options)
4201          (defmethod print-object ((condition ,name) stream)
4202            (if *print-escape*
4203                (call-next-method)
4204                (progn (write-string ,report stream) condition)))
4205          ',name))
4206      (t
4207       `(progn
4208          (defclass ,name ,parent-types ,slot-specs ,@options)
4209          (defmethod print-object ((condition ,name) stream)
4210            (if *print-escape*
4211                (call-next-method)
4212                (funcall #',report condition stream)))
4213          ',name)))))
4214
4215(defun make-condition (type &rest initargs)
4216  (or (%make-condition type initargs)
4217      (let ((class (if (symbolp type) (find-class type) type)))
4218        (apply #'make-instance class initargs))))
4219
4220;; Adapted from SBCL.
4221;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
4222(defun coerce-to-condition (datum arguments default-type fun-name)
4223  (cond ((typep datum 'condition)
4224         (when arguments
4225           (error 'simple-type-error
4226                  :datum arguments
4227                  :expected-type 'null
4228                  :format-control "You may not supply additional arguments when giving ~S to ~S."
4229                  :format-arguments (list datum fun-name)))
4230         datum)
4231        ((symbolp datum)
4232         (apply #'make-condition datum arguments))
4233        ((or (stringp datum) (functionp datum))
4234         (make-condition default-type
4235                         :format-control datum
4236                         :format-arguments arguments))
4237        (t
4238         (error 'simple-type-error
4239                :datum datum
4240                :expected-type '(or symbol string)
4241                :format-control "Bad argument to ~S: ~S."
4242                :format-arguments (list fun-name datum)))))
4243
4244(defgeneric make-load-form (object &optional environment))
4245
4246(defmethod make-load-form ((object t) &optional environment)
4247  (declare (ignore environment))
4248  (apply #'no-applicable-method #'make-load-form (list object)))
4249
4250(defmethod make-load-form ((class class) &optional environment)
4251  (declare (ignore environment))
4252  (let ((name (class-name class)))
4253    (unless (and name (eq (find-class name nil) class))
4254      (error 'simple-type-error
4255             :format-control "Can't use anonymous or undefined class as a constant: ~S."
4256             :format-arguments (list class)))
4257    `(find-class ',name)))
4258
4259(defun invalid-method-error (method format-control &rest args)
4260  (let ((message (apply #'format nil format-control args)))
4261    (error "Invalid method error for ~S:~%    ~A" method message)))
4262
4263(defun method-combination-error (format-control &rest args)
4264  (let ((message (apply #'format nil format-control args)))
4265    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
4266
4267
4268(atomic-defgeneric no-applicable-method (generic-function &rest args)
4269  (:method (generic-function &rest args)
4270      (error "There is no applicable method for the generic function ~S ~
4271              when called with arguments ~S."
4272             generic-function
4273             args)))
4274
4275
4276;;; FIXME (rudi 2012-01-28): this can be a function, it only needs to
4277;;; use standard accessor functions
4278(defgeneric find-method (generic-function
4279                         qualifiers
4280                         specializers
4281                         &optional errorp))
4282
4283(defmethod find-method ((generic-function standard-generic-function)
4284                        qualifiers specializers &optional (errorp t))
4285  (%find-method generic-function qualifiers specializers errorp))
4286
4287(defgeneric find-method ((generic-function symbol)
4288                         qualifiers specializers &optional (errorp t))
4289  (find-method (find-generic-function generic-function errorp)
4290               qualifiers specializers errorp))
4291
4292;;; AMOP pg. 167
4293(defgeneric add-method (generic-function method))
4294
4295(defmethod add-method :before ((generic-function generic-function)
4296                               (method method))
4297  (when (and (method-generic-function method)
4298             (not (eql generic-function (method-generic-function method))))
4299    (error 'simple-error
4300           :format-control "~S is already a method of ~S, cannot add to ~S."
4301           :format-arguments (list method (method-generic-function method)
4302                                   generic-function)))
4303  (check-method-lambda-list (generic-function-name generic-function)
4304                            (method-lambda-list method)
4305                            (generic-function-lambda-list generic-function)))
4306
4307(defmethod add-method ((generic-function standard-generic-function)
4308                       (method standard-method))
4309  (std-add-method generic-function method))
4310
4311(defmethod add-method :after ((generic-function generic-function)
4312                              (method method))
4313  (map-dependents generic-function
4314                  #'(lambda (dep) (update-dependent generic-function dep
4315                                                    'add-method method))))
4316
4317(defgeneric remove-method (generic-function method))
4318
4319(defmethod remove-method ((generic-function standard-generic-function)
4320                          (method standard-method))
4321  (std-remove-method generic-function method))
4322
4323(defmethod remove-method :after ((generic-function generic-function)
4324                                 (method method))
4325  (map-dependents generic-function
4326                  #'(lambda (dep) (update-dependent generic-function dep
4327                                                    'remove-method method))))
4328
4329;; See describe.lisp.
4330(defgeneric describe-object (object stream))
4331
4332;; FIXME
4333(defgeneric no-next-method (generic-function method &rest args))
4334
4335(atomic-defgeneric function-keywords (method)
4336  (:method ((method standard-method))
4337    (std-function-keywords method)))
4338
4339(setf *gf-initialize-instance* (symbol-function 'initialize-instance))
4340(setf *gf-allocate-instance* (symbol-function 'allocate-instance))
4341(setf *gf-shared-initialize* (symbol-function 'shared-initialize))
4342(setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance))
4343(setf *clos-booting* nil)
4344
4345(atomic-defgeneric class-prototype (class)
4346  (:method ((class standard-class))
4347    (allocate-instance class))
4348  (:method ((class funcallable-standard-class))
4349    (allocate-instance class))
4350  (:method ((class structure-class))
4351    (allocate-instance class))
4352  (:method :before (class)
4353    (unless (class-finalized-p class)
4354      (error "~@<~S is not finalized.~:@>" class))))
4355
4356
4357
4358
4359
4360(defmethod shared-initialize :before ((instance generic-function)
4361                                      slot-names
4362                                      &key lambda-list argument-precedence-order
4363                                      &allow-other-keys)
4364  (check-argument-precedence-order lambda-list argument-precedence-order))
4365
4366(defmethod shared-initialize :after ((instance standard-generic-function)
4367                                     slot-names
4368                                     &key lambda-list argument-precedence-order
4369                                     &allow-other-keys)
4370  (let* ((plist (analyze-lambda-list lambda-list))
4371         (required-args (getf plist ':required-args)))
4372    (%set-gf-required-args instance required-args)
4373    (%set-gf-optional-args instance (getf plist :optional-args))
4374    (set-generic-function-argument-precedence-order
4375     instance (or argument-precedence-order required-args)))
4376  (when (eq (generic-function-method-combination instance) 'standard)
4377    ;; fix up "naked" (make-instance 'standard-generic-function) -- gfs
4378    ;; created via defgeneric have that slot initalized properly
4379    (set-generic-function-method-combination instance
4380                                             +the-standard-method-combination+))
4381  (finalize-standard-generic-function instance))
4382
4383;;; Readers for generic function metaobjects
4384;;; AMOP pg. 216ff.
4385(atomic-defgeneric generic-function-argument-precedence-order (generic-function)
4386  (:method ((generic-function standard-generic-function))
4387    (sys:%generic-function-argument-precedence-order generic-function)))
4388
4389(atomic-defgeneric generic-function-declarations (generic-function)
4390  (:method ((generic-function standard-generic-function))
4391    (sys:%generic-function-declarations generic-function)))
4392
4393(atomic-defgeneric generic-function-lambda-list (generic-function)
4394  (:method ((generic-function standard-generic-function))
4395    (sys:%generic-function-lambda-list generic-function)))
4396
4397(atomic-defgeneric generic-function-method-class (generic-function)
4398  (:method ((generic-function standard-generic-function))
4399    (sys:%generic-function-method-class generic-function)))
4400
4401(atomic-defgeneric generic-function-method-combination (generic-function)
4402  (:method ((generic-function standard-generic-function))
4403    (sys:%generic-function-method-combination generic-function)))
4404
4405(atomic-defgeneric generic-function-methods (generic-function)
4406  (:method ((generic-function standard-generic-function))
4407    (sys:%generic-function-methods generic-function)))
4408
4409(atomic-defgeneric generic-function-name (generic-function)
4410  (:method ((generic-function standard-generic-function))
4411    (sys:%generic-function-name generic-function)))
4412
4413;;; AMOP pg. 231
4414(defgeneric (setf generic-function-name) (new-value gf)
4415  (:method (new-value (gf generic-function))
4416    (reinitialize-instance gf :name new-value)))
4417
4418;;; Readers for Method Metaobjects
4419;;; AMOP pg. 218ff.
4420
4421(atomic-defgeneric method-function (method)
4422  (:method ((method standard-method))
4423    (std-method-function method)))
4424
4425(atomic-defgeneric method-generic-function (method)
4426  (:method ((method standard-method))
4427    (std-method-generic-function method)))
4428
4429(atomic-defgeneric method-lambda-list (method)
4430  (:method ((method standard-method))
4431    (std-slot-value method 'sys::lambda-list)))
4432
4433(atomic-defgeneric method-specializers (method)
4434  (:method ((method standard-method))
4435    (std-method-specializers method)))
4436
4437(atomic-defgeneric method-qualifiers (method)
4438  (:method ((method standard-method))
4439    (std-method-qualifiers method)))
4440
4441(atomic-defgeneric accessor-method-slot-definition (method)
4442  (:method ((method standard-accessor-method))
4443    (std-accessor-method-slot-definition method)))
4444
4445
4446;;; find-method-combination
4447
4448;;; AMOP pg. 191
4449(atomic-defgeneric find-method-combination (gf name options)
4450  (:method (gf (name symbol) options)
4451    (std-find-method-combination gf name options)))
4452
4453;;; specializer-direct-method and friends.
4454
4455;;; AMOP pg. 237
4456(defgeneric specializer-direct-generic-functions (specializer))
4457
4458(defmethod specializer-direct-generic-functions ((specializer class))
4459  (delete-duplicates (mapcar #'method-generic-function
4460                             (class-direct-methods specializer))))
4461
4462(defmethod specializer-direct-generic-functions ((specializer eql-specializer))
4463  (delete-duplicates (mapcar #'method-generic-function
4464                             (slot-value specializer 'direct-methods))))
4465
4466;;; AMOP pg. 238
4467(defgeneric specializer-direct-methods (specializer))
4468
4469(defmethod specializer-direct-methods ((specializer class))
4470  (class-direct-methods specializer))
4471
4472(defmethod specializer-direct-methods ((specializer eql-specializer))
4473  (slot-value specializer 'direct-methods))
4474
4475;;; AMOP pg. 165
4476(atomic-defgeneric add-direct-method (specializer method)
4477  (:method ((specializer class) (method method))
4478    (pushnew method (class-direct-methods specializer)))
4479  (:method ((specializer eql-specializer) (method method))
4480    (pushnew method (slot-value specializer 'direct-methods))))
4481
4482
4483;;; AMOP pg. 227
4484(atomic-defgeneric remove-direct-method (specializer method)
4485  (:method ((specializer class) (method method))
4486    (setf (class-direct-methods specializer)
4487          (remove method (class-direct-methods specializer))))
4488  (:method ((specializer eql-specializer) (method method))
4489    (setf (slot-value specializer 'direct-methods)
4490          (remove method (slot-value specializer 'direct-methods)))))
4491
4492;;; The Dependent Maintenance Protocol (AMOP pg. 160ff.)
4493
4494(defvar *dependents* (make-hash-table :test 'eq :weakness :key))
4495
4496;;; AMOP pg. 164
4497(defgeneric add-dependent (metaobject dependent))
4498(defmethod add-dependent ((metaobject standard-class) dependent)
4499  (pushnew dependent (gethash metaobject *dependents* nil)))
4500(defmethod add-dependent ((metaobject funcallable-standard-class) dependent)
4501  (pushnew dependent (gethash metaobject *dependents* nil)))
4502(defmethod add-dependent ((metaobject standard-generic-function) dependent)
4503  (pushnew dependent (gethash metaobject *dependents* nil)))
4504
4505;;; AMOP pg. 225
4506(defgeneric remove-dependent (metaobject dependent))
4507(defmethod remove-dependent ((metaobject standard-class) dependent)
4508  (setf (gethash metaobject *dependents*)
4509        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
4510(defmethod remove-dependent ((metaobject funcallable-standard-class) dependent)
4511  (setf (gethash metaobject *dependents*)
4512        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
4513(defmethod remove-dependent ((metaobject standard-generic-function) dependent)
4514  (setf (gethash metaobject *dependents*)
4515        (delete dependent (gethash metaobject *dependents* nil) :test #'eq)))
4516
4517;;; AMOP pg. 210
4518(atomic-defgeneric map-dependents (metaobject function)
4519  (:method ((metaobject standard-class) function)
4520    (dolist (dependent (gethash metaobject *dependents* nil))
4521      (funcall function dependent)))
4522  (:method ((metaobject funcallable-standard-class) function)
4523    (dolist (dependent (gethash metaobject *dependents* nil))
4524      (funcall function dependent)))
4525  (:method ((metaobject standard-generic-function) function)
4526    (dolist (dependent (gethash metaobject *dependents* nil))
4527      (funcall function dependent))))
4528
4529;;; AMOP pg. 239
4530(defgeneric update-dependent (metaobject dependent &rest initargs))
4531
4532
4533;;; ensure-generic-function(-using-class), AMOP pg. 185ff.
4534(defgeneric ensure-generic-function-using-class (generic-function function-name
4535                                                 &key
4536                                                   argument-precedence-order
4537                                                   declarations documentation
4538                                                   generic-function-class
4539                                                   lambda-list method-class
4540                                                   method-combination
4541                                                   name
4542                                                 &allow-other-keys))
4543
4544(defmethod ensure-generic-function-using-class
4545    ((generic-function generic-function)
4546     function-name
4547     &rest all-keys
4548     &key (generic-function-class (class-of generic-function))
4549     (lambda-list nil lambda-list-supplied-p)
4550     (method-class (generic-function-method-class generic-function))
4551     (method-combination (generic-function-method-combination generic-function))
4552     &allow-other-keys)
4553  (setf all-keys (copy-list all-keys))  ; since we modify it
4554  (remf all-keys :generic-function-class)
4555  (unless (classp generic-function-class)
4556    (setf generic-function-class (find-class generic-function-class)))
4557  (unless (classp method-class) (setf method-class (find-class method-class)))
4558  (unless (eq generic-function-class (class-of generic-function))
4559    (error "The class ~S is incompatible with the existing class (~S) of ~S."
4560           generic-function-class (class-of generic-function) generic-function))
4561  (when lambda-list-supplied-p
4562    (unless (or (null (generic-function-methods generic-function))
4563                (lambda-lists-congruent-p lambda-list
4564                                          (generic-function-lambda-list generic-function)))
4565      (error "The lambda list ~S is incompatible with the existing methods of ~S."
4566             lambda-list generic-function)))
4567  (unless (or (null (generic-function-methods generic-function))
4568              (eq method-class (generic-function-method-class generic-function)))
4569    (error "The method class ~S is incompatible with the existing methods of ~S."
4570           method-class generic-function))
4571  (unless (typep method-combination 'method-combination)
4572    (setf method-combination
4573          (find-method-combination generic-function
4574                                   (car method-combination)
4575                                   (cdr method-combination))))
4576  (apply #'reinitialize-instance generic-function
4577         :method-combination method-combination
4578         :method-class method-class
4579         all-keys)
4580  generic-function)
4581
4582(defmethod ensure-generic-function-using-class ((generic-function null)
4583                                                function-name
4584                                                &rest all-keys
4585                                                &key (generic-function-class +the-standard-generic-function-class+)
4586                                                  (method-class +the-standard-method-class+)
4587                                                  (method-combination +the-standard-method-combination+)
4588                                                &allow-other-keys)
4589  (setf all-keys (copy-list all-keys))  ; since we modify it
4590  (remf all-keys :generic-function-class)
4591  (unless (classp generic-function-class)
4592    (setf generic-function-class (find-class generic-function-class)))
4593  (unless (classp method-class) (setf method-class (find-class method-class)))