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

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

Correct default superclass for funcallable-standard-classes

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