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

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

Beginning support for non-standard method metaclasses

... canonicalize specializers in defmethod macroexpansion, instead of in

the bowels of make-instance-standard-method.

... handle non-standard method metaclass in more places

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