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

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

add fast writer methods

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