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

Last change on this file since 13877 was 13877, checked in by rschlatte, 10 years ago

Implement the dependent maintenance protocol (AMOP Sec. 5.5.6)

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