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

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

Revert previous commit.

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