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

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

Properly initialize documentation for effective slot definitions

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