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

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

Implement compute-default-initargs

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