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

Last change on this file since 14060 was 14060, checked in by ehuelsmann, 9 years ago

Fix #202: ENSURE-GENERIC-FUNCTION complains about lambda list congruence
when no lambda list is provided.

Don't change the field when the argument is not provided and
when the argument is not provided, don't check for congruence.

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