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

Last change on this file was 15743, checked in by Mark Evenson, 5 months ago

Fix CLOS change propagation for all subclasses

c.f. <https://github.com/armedbear/abcl/issues/630>

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