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

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

minor refactorings in the vicinity of standard-generic-function.

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