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

Last change on this file since 14262 was 14262, checked in by rschlatte, 8 years ago

Fix (describe x 'function) for non-fbound x

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