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

Last change on this file since 14498 was 14498, checked in by rschlatte, 10 years ago

Unify checks for standard classes

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