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

Last change on this file since 13939 was 13939, checked in by Mark Evenson, 9 years ago

Fixes ticket #199: CL-METHOD failure for &AUX arguments.

DEFGENERIC specified with &AUX arguments now signals an error.

Removed badly conceived BUGS.AUX.1 test which blew up the stack due to
recursively referencing itself in the &AUX init form.

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