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

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

Don't short-circuit slot readers for subclasses of standard-class

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