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

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

Don't redefine metaclasses

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