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

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

Small cleanup of atomic-defgeneric

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