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

Last change on this file since 13972 was 13972, checked in by rschlatte, 9 years ago

Allow multiple declare forms in defgeneric

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