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

Last change on this file since 12758 was 12758, checked in by astalla, 12 years ago

Custom slot definition: slot-location managed like the other slot properties.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 115.2 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; $Id: clos.lisp 12758 2010-06-18 23:15:52Z astalla $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32;;; Originally based on Closette.
33
34;;; Closette Version 1.0 (February 10, 1991)
35;;;
36;;; Copyright (c) 1990, 1991 Xerox Corporation.
37;;; All rights reserved.
38;;;
39;;; Use and copying of this software and preparation of derivative works
40;;; based upon this software are permitted.  Any distribution of this
41;;; software or derivative works must comply with all applicable United
42;;; States export control laws.
43;;;
44;;; This software is made available AS IS, and Xerox Corporation makes no
45;;; warranty about the software, its performance or its conformity to any
46;;; specification.
47;;;
48;;; Closette is an implementation of a subset of CLOS with a metaobject
49;;; protocol as described in "The Art of The Metaobject Protocol",
50;;; MIT Press, 1991.
51
52(in-package #:mop)
53
54(export '(class-precedence-list class-slots))
55(defconstant +the-standard-class+ (find-class 'standard-class))
56(defconstant +the-structure-class+ (find-class 'structure-class))
57(defconstant +the-standard-object-class+ (find-class 'standard-object))
58(defconstant +the-standard-method-class+ (find-class 'standard-method))
59(defconstant +the-standard-reader-method-class+
60  (find-class 'standard-reader-method))
61(defconstant +the-standard-generic-function-class+
62  (find-class 'standard-generic-function))
63(defconstant +the-T-class+ (find-class 'T))
64(defconstant +the-slot-definition-class+ (find-class 'slot-definition))
65(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
66(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
67
68;; Don't use DEFVAR, because that disallows loading clos.lisp
69;; after compiling it: the binding won't get assigned to T anymore
70(defparameter *clos-booting* t)
71
72(defmacro define-class->%class-forwarder (name)
73  (let* (($name (if (consp name) (cadr name) name))
74         (%name (intern (concatenate 'string
75                                     "%"
76                                     (if (consp name)
77                                         (symbol-name 'set-) "")
78                                     (symbol-name $name))
79                        (symbol-package $name))))
80    `(progn
81       (declaim (notinline ,name))
82       (defun ,name (&rest args)
83         (apply #',%name args)))))
84
85(define-class->%class-forwarder class-name)
86(define-class->%class-forwarder (setf class-name))
87(define-class->%class-forwarder class-slots)
88(define-class->%class-forwarder (setf class-slots))
89(define-class->%class-forwarder class-direct-slots)
90(define-class->%class-forwarder (setf class-direct-slots))
91(define-class->%class-forwarder class-layout)
92(define-class->%class-forwarder (setf class-layout))
93(define-class->%class-forwarder class-direct-superclasses)
94(define-class->%class-forwarder (setf class-direct-superclasses))
95(define-class->%class-forwarder class-direct-subclasses)
96(define-class->%class-forwarder (setf class-direct-subclasses))
97(define-class->%class-forwarder class-direct-methods)
98(define-class->%class-forwarder (setf class-direct-methods))
99(define-class->%class-forwarder class-precedence-list)
100(define-class->%class-forwarder (setf class-precedence-list))
101(define-class->%class-forwarder class-finalized-p)
102(define-class->%class-forwarder (setf class-finalized-p))
103(define-class->%class-forwarder class-default-initargs)
104(define-class->%class-forwarder (setf class-default-initargs))
105(define-class->%class-forwarder class-direct-default-initargs)
106(define-class->%class-forwarder (setf class-direct-default-initargs))
107
108(defun no-applicable-method (generic-function &rest args)
109  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
110         generic-function
111         args))
112
113
114
115(defmacro push-on-end (value location)
116  `(setf ,location (nconc ,location (list ,value))))
117
118;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
119;;; which must be non-nil.
120
121(defun (setf getf*) (new-value plist key)
122  (block body
123    (do ((x plist (cddr x)))
124        ((null x))
125      (when (eq (car x) key)
126        (setf (car (cdr x)) new-value)
127        (return-from body new-value)))
128    (push-on-end key plist)
129    (push-on-end new-value plist)
130    new-value))
131
132(defun mapappend (fun &rest args)
133  (if (some #'null args)
134      ()
135      (append (apply fun (mapcar #'car args))
136              (apply #'mapappend fun (mapcar #'cdr args)))))
137
138(defun mapplist (fun x)
139  (if (null x)
140      ()
141      (cons (funcall fun (car x) (cadr x))
142            (mapplist fun (cddr x)))))
143
144(defsetf std-instance-layout %set-std-instance-layout)
145(defsetf standard-instance-access %set-standard-instance-access)
146
147(defun (setf find-class) (new-value symbol &optional errorp environment)
148  (declare (ignore errorp environment))
149  (%set-find-class symbol new-value))
150
151(defun canonicalize-direct-slots (direct-slots)
152  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
153
154(defun canonicalize-direct-slot (spec)
155  (if (symbolp spec)
156      `(list :name ',spec)
157      (let ((name (car spec))
158            (initfunction nil)
159            (initform nil)
160            (initargs ())
161            (type nil)
162            (allocation nil)
163            (documentation nil)
164            (readers ())
165            (writers ())
166            (other-options ())
167      (non-std-options ()))
168        (do ((olist (cdr spec) (cddr olist)))
169            ((null olist))
170          (case (car olist)
171            (:initform
172             (when initform
173               (error 'program-error
174                      "duplicate slot option :INITFORM for slot named ~S"
175                      name))
176             (setq initfunction
177                   `(function (lambda () ,(cadr olist))))
178             (setq initform `',(cadr olist)))
179            (:initarg
180             (push-on-end (cadr olist) initargs))
181            (:allocation
182             (when allocation
183               (error 'program-error
184                      "duplicate slot option :ALLOCATION for slot named ~S"
185                      name))
186             (setf allocation (cadr olist))
187             (push-on-end (car olist) other-options)
188             (push-on-end (cadr olist) other-options))
189            (:type
190             (when type
191               (error 'program-error
192                      "duplicate slot option :TYPE for slot named ~S"
193                      name))
194             (setf type (cadr olist))) ;; FIXME type is ignored
195            (:documentation
196             (when documentation
197               (error 'program-error
198                      "duplicate slot option :DOCUMENTATION for slot named ~S"
199                      name))
200             (setf documentation (cadr olist))) ;; FIXME documentation is ignored
201            (:reader
202             (maybe-note-name-defined (cadr olist))
203             (push-on-end (cadr olist) readers))
204            (:writer
205             (maybe-note-name-defined (cadr olist))
206             (push-on-end (cadr olist) writers))
207            (:accessor
208             (maybe-note-name-defined (cadr olist))
209             (push-on-end (cadr olist) readers)
210             (push-on-end `(setf ,(cadr olist)) writers))
211            (t
212       (push-on-end (car olist) non-std-options)
213             (push-on-end (cadr olist) non-std-options))))
214;     (error 'program-error
215;                    "invalid initialization argument ~S for slot named ~S"
216;                    (car olist) name))
217        `(list
218          :name ',name
219          ,@(when initfunction
220              `(:initform ,initform
221                          :initfunction ,initfunction))
222          ,@(when initargs `(:initargs ',initargs))
223          ,@(when readers `(:readers ',readers))
224          ,@(when writers `(:writers ',writers))
225          ,@other-options
226    ,@non-std-options))))
227
228(defun maybe-note-name-defined (name)
229  (when (fboundp 'note-name-defined)
230    (note-name-defined name)))
231
232(defun canonicalize-direct-superclasses (direct-superclasses)
233  (let ((classes '()))
234    (dolist (class-specifier direct-superclasses)
235      (if (classp class-specifier)
236          (push class-specifier classes)
237          (let ((class (find-class class-specifier nil)))
238            (unless class
239              (setf class (make-forward-referenced-class class-specifier)))
240            (push class classes))))
241    (nreverse classes)))
242
243(defun canonicalize-defclass-options (options)
244  (mapappend #'canonicalize-defclass-option options))
245
246(defun canonicalize-defclass-option (option)
247  (case (car option)
248    (:metaclass
249     (list ':metaclass
250           `(find-class ',(cadr option))))
251    (:default-initargs
252     (list
253      ':direct-default-initargs
254      `(list ,@(mapappend
255                #'(lambda (x) x)
256                (mapplist
257                 #'(lambda (key value)
258                    `(',key ,(make-initfunction value)))
259                 (cdr option))))))
260    ((:documentation :report)
261     (list (car option) `',(cadr option)))
262    (t (list (car option) `(quote ,(cdr option))))))
263;     (error 'program-error
264;            :format-control "invalid DEFCLASS option ~S"
265;            :format-arguments (list (car option))))))
266
267(defun make-initfunction (initform)
268  `(function (lambda () ,initform)))
269
270(defun slot-definition-allocation (slot-definition)
271  (%slot-definition-allocation slot-definition))
272
273(declaim (notinline (setf slot-definition-allocation)))
274(defun (setf slot-definition-allocation) (value slot-definition)
275  (set-slot-definition-allocation slot-definition value))
276
277(defun slot-definition-initargs (slot-definition)
278  (%slot-definition-initargs slot-definition))
279
280(declaim (notinline (setf slot-definition-initargs)))
281(defun (setf slot-definition-initargs) (value slot-definition)
282  (set-slot-definition-initargs slot-definition value))
283
284(defun slot-definition-initform (slot-definition)
285  (%slot-definition-initform slot-definition))
286
287(declaim (notinline (setf slot-definition-initform)))
288(defun (setf slot-definition-initform) (value slot-definition)
289  (set-slot-definition-initform slot-definition value))
290
291(defun slot-definition-initfunction (slot-definition)
292  (%slot-definition-initfunction slot-definition))
293
294(declaim (notinline (setf slot-definition-initfunction)))
295(defun (setf slot-definition-initfunction) (value slot-definition)
296  (set-slot-definition-initfunction slot-definition value))
297
298(defun slot-definition-name (slot-definition)
299  (%slot-definition-name slot-definition))
300
301(declaim (notinline (setf slot-definition-name)))
302(defun (setf slot-definition-name) (value slot-definition)
303  (set-slot-definition-name slot-definition value))
304
305(defun slot-definition-readers (slot-definition)
306  (%slot-definition-readers slot-definition))
307
308(declaim (notinline (setf slot-definition-readers)))
309(defun (setf slot-definition-readers) (value slot-definition)
310  (set-slot-definition-readers slot-definition value))
311
312(defun slot-definition-writers (slot-definition)
313  (%slot-definition-writers slot-definition))
314
315(declaim (notinline (setf slot-definition-writers)))
316(defun (setf slot-definition-writers) (value slot-definition)
317  (set-slot-definition-writers slot-definition value))
318
319(defun slot-definition-allocation-class (slot-definition)
320  (%slot-definition-allocation-class slot-definition))
321
322(declaim (notinline (setf slot-definition-allocation-class)))
323(defun (setf slot-definition-allocation-class) (value slot-definition)
324  (set-slot-definition-allocation-class slot-definition value))
325
326(defun slot-definition-location (slot-definition)
327  (%slot-definition-location slot-definition))
328
329(declaim (notinline (setf slot-definition-location-class)))
330(defun (setf slot-definition-location) (value slot-definition)
331  (set-slot-definition-location slot-definition value))
332
333(defun init-slot-definition (slot &key name
334           (initargs ())
335           (initform nil)
336           (initfunction nil)
337           (readers ())
338           (writers ())
339           (allocation :instance)
340           (allocation-class nil)
341           &allow-other-keys)
342  (setf (slot-definition-name slot) name)
343  (setf (slot-definition-initargs slot) initargs)
344  (setf (slot-definition-initform slot) initform)
345  (setf (slot-definition-initfunction slot) initfunction)
346  (setf (slot-definition-readers slot) readers)
347  (setf (slot-definition-writers slot) writers)
348  (setf (slot-definition-allocation slot) allocation)
349  (setf (slot-definition-allocation-class slot) allocation-class)
350  slot)
351
352(defun make-direct-slot-definition (class &rest args)
353  (let ((slot-class (direct-slot-definition-class class)))
354    (if (eq slot-class +the-direct-slot-definition-class+)
355  (let ((slot (make-slot-definition +the-direct-slot-definition-class+)))
356    (apply #'init-slot-definition slot :allocation-class class args)
357    slot)
358  (progn
359    (let ((slot (apply #'make-instance slot-class :allocation-class class
360           args)))
361      slot)))))
362
363(defun make-effective-slot-definition (class &rest args)
364  (let ((slot-class (effective-slot-definition-class class)))
365    (if (eq slot-class +the-effective-slot-definition-class+)
366  (let ((slot (make-slot-definition +the-effective-slot-definition-class+)))
367    (apply #'init-slot-definition slot args)
368    slot)
369  (progn
370    (let ((slot (apply #'make-instance slot-class args)))
371      slot)))))
372
373;;; finalize-inheritance
374
375(defun std-compute-class-default-initargs (class)
376  (mapcan #'(lambda (c)
377              (copy-list
378               (class-direct-default-initargs c)))
379          (class-precedence-list class)))
380
381(defun std-finalize-inheritance (class)
382  (setf (class-precedence-list class)
383   (funcall (if (eq (class-of class) +the-standard-class+)
384                #'std-compute-class-precedence-list
385                #'compute-class-precedence-list)
386            class))
387  (dolist (class (class-precedence-list class))
388    (when (typep class 'forward-referenced-class)
389      (return-from std-finalize-inheritance)))
390  (setf (class-slots class)
391                   (funcall (if (eq (class-of class) +the-standard-class+)
392                                #'std-compute-slots
393                     #'compute-slots) class))
394  (let ((old-layout (class-layout class))
395        (length 0)
396        (instance-slots '())
397        (shared-slots '()))
398    (dolist (slot (class-slots class))
399      (case (slot-definition-allocation slot)
400        (:instance
401         (setf (slot-definition-location slot) length)
402         (incf length)
403         (push (slot-definition-name slot) instance-slots))
404        (:class
405         (unless (slot-definition-location slot)
406           (let ((allocation-class (slot-definition-allocation-class slot)))
407             (setf (slot-definition-location slot)
408       (if (eq allocation-class class)
409           (cons (slot-definition-name slot) +slot-unbound+)
410           (slot-location allocation-class (slot-definition-name slot))))))
411         (push (slot-definition-location slot) shared-slots))))
412    (when old-layout
413      ;; Redefined class: initialize added shared slots.
414      (dolist (location shared-slots)
415        (let* ((slot-name (car location))
416               (old-location (layout-slot-location old-layout slot-name)))
417          (unless old-location
418            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
419                   (initfunction (slot-definition-initfunction slot-definition)))
420              (when initfunction
421                (setf (cdr location) (funcall initfunction))))))))
422    (setf (class-layout class)
423          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
424  (setf (class-default-initargs class)
425        (std-compute-class-default-initargs class))
426  (setf (class-finalized-p class) t))
427
428;;; Class precedence lists
429
430(defun std-compute-class-precedence-list (class)
431  (let ((classes-to-order (collect-superclasses* class)))
432    (topological-sort classes-to-order
433                      (remove-duplicates
434                       (mapappend #'local-precedence-ordering
435                                  classes-to-order))
436                      #'std-tie-breaker-rule)))
437
438;;; topological-sort implements the standard algorithm for topologically
439;;; sorting an arbitrary set of elements while honoring the precedence
440;;; constraints given by a set of (X,Y) pairs that indicate that element
441;;; X must precede element Y.  The tie-breaker procedure is called when it
442;;; is necessary to choose from multiple minimal elements; both a list of
443;;; candidates and the ordering so far are provided as arguments.
444
445(defun topological-sort (elements constraints tie-breaker)
446  (let ((remaining-constraints constraints)
447        (remaining-elements elements)
448        (result ()))
449    (loop
450      (let ((minimal-elements
451             (remove-if
452              #'(lambda (class)
453                 (member class remaining-constraints
454                         :key #'cadr))
455              remaining-elements)))
456        (when (null minimal-elements)
457          (if (null remaining-elements)
458              (return-from topological-sort result)
459              (error "Inconsistent precedence graph.")))
460        (let ((choice (if (null (cdr minimal-elements))
461                          (car minimal-elements)
462                          (funcall tie-breaker
463                                   minimal-elements
464                                   result))))
465          (setq result (append result (list choice)))
466          (setq remaining-elements
467                (remove choice remaining-elements))
468          (setq remaining-constraints
469                (remove choice
470                        remaining-constraints
471                        :test #'member)))))))
472
473;;; In the event of a tie while topologically sorting class precedence lists,
474;;; the CLOS Specification says to "select the one that has a direct subclass
475;;; rightmost in the class precedence list computed so far."  The same result
476;;; is obtained by inspecting the partially constructed class precedence list
477;;; from right to left, looking for the first minimal element to show up among
478;;; the direct superclasses of the class precedence list constituent.
479;;; (There's a lemma that shows that this rule yields a unique result.)
480
481(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
482  (dolist (cpl-constituent (reverse cpl-so-far))
483    (let* ((supers (class-direct-superclasses cpl-constituent))
484           (common (intersection minimal-elements supers)))
485      (when (not (null common))
486        (return-from std-tie-breaker-rule (car common))))))
487
488;;; This version of collect-superclasses* isn't bothered by cycles in the class
489;;; hierarchy, which sometimes happen by accident.
490
491(defun collect-superclasses* (class)
492  (labels ((all-superclasses-loop (seen superclasses)
493                                  (let ((to-be-processed
494                                         (set-difference superclasses seen)))
495                                    (if (null to-be-processed)
496                                        superclasses
497                                        (let ((class-to-process
498                                               (car to-be-processed)))
499                                          (all-superclasses-loop
500                                           (cons class-to-process seen)
501                                           (union (class-direct-superclasses
502                                                   class-to-process)
503                                                  superclasses)))))))
504          (all-superclasses-loop () (list class))))
505
506;;; The local precedence ordering of a class C with direct superclasses C_1,
507;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
508
509(defun local-precedence-ordering (class)
510  (mapcar #'list
511          (cons class
512                (butlast (class-direct-superclasses class)))
513          (class-direct-superclasses class)))
514
515;;; Slot inheritance
516
517(defun std-compute-slots (class)
518  (let* ((all-slots (mapappend #'class-direct-slots
519                               (class-precedence-list class)))
520         (all-names (remove-duplicates
521                     (mapcar 'slot-definition-name all-slots))))
522    (mapcar #'(lambda (name)
523               (funcall
524                (if (eq (class-of class) +the-standard-class+)
525                    #'std-compute-effective-slot-definition
526                    #'compute-effective-slot-definition)
527                class
528                (remove name all-slots
529                        :key 'slot-definition-name
530                        :test-not #'eq)))
531            all-names)))
532
533(defun std-compute-effective-slot-definition (class direct-slots)
534  (let ((initer (find-if-not #'null direct-slots
535                             :key 'slot-definition-initfunction)))
536    (make-effective-slot-definition
537     class
538     :name (slot-definition-name (car direct-slots))
539     :initform (if initer
540                   (slot-definition-initform initer)
541                   nil)
542     :initfunction (if initer
543                       (slot-definition-initfunction initer)
544                       nil)
545     :initargs (remove-duplicates
546                (mapappend 'slot-definition-initargs
547                           direct-slots))
548     :allocation (slot-definition-allocation (car direct-slots))
549     :allocation-class (when (slot-boundp (car direct-slots)
550            'sys::allocation-class)
551       ;;for some classes created in Java
552       ;;(e.g. SimpleCondition) this slot is unbound
553       (slot-definition-allocation-class (car direct-slots))))))
554
555;;; Standard instance slot access
556
557;;; N.B. The location of the effective-slots slots in the class metaobject for
558;;; standard-class must be determined without making any further slot
559;;; references.
560
561(defun find-slot-definition (class slot-name)
562  (dolist (slot (class-slots class) nil)
563    (when (eq slot-name (slot-definition-name slot))
564      (return slot))))
565
566(defun slot-location (class slot-name)
567  (let ((slot (find-slot-definition class slot-name)))
568    (if slot
569        (slot-definition-location slot)
570        nil)))
571
572(defun instance-slot-location (instance slot-name)
573  (let ((layout (std-instance-layout instance)))
574    (and layout (layout-slot-location layout slot-name))))
575
576(defun slot-value (object slot-name)
577  (if (or (eq (class-of (class-of object)) +the-standard-class+)
578    (eq (class-of (class-of object)) +the-structure-class+))
579      (std-slot-value object slot-name)
580      (slot-value-using-class (class-of object) object slot-name)))
581
582(defsetf std-slot-value set-std-slot-value)
583
584(defun %set-slot-value (object slot-name new-value)
585  (if (or (eq (class-of (class-of object)) +the-standard-class+)
586    (eq (class-of (class-of object)) +the-structure-class+))
587      (setf (std-slot-value object slot-name) new-value)
588      (set-slot-value-using-class new-value (class-of object)
589                                  object slot-name)))
590
591(defsetf slot-value %set-slot-value)
592
593(defun slot-boundp (object slot-name)
594  (if (eq (class-of (class-of object)) +the-standard-class+)
595      (std-slot-boundp object slot-name)
596      (slot-boundp-using-class (class-of object) object slot-name)))
597
598(defun std-slot-makunbound (instance slot-name)
599  (let ((location (instance-slot-location instance slot-name)))
600    (cond ((fixnump location)
601           (setf (standard-instance-access instance location) +slot-unbound+))
602          ((consp location)
603           (setf (cdr location) +slot-unbound+))
604          (t
605           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
606  instance)
607
608(defun slot-makunbound (object slot-name)
609  (if (eq (class-of (class-of object)) +the-standard-class+)
610      (std-slot-makunbound object slot-name)
611      (slot-makunbound-using-class (class-of object) object slot-name)))
612
613(defun std-slot-exists-p (instance slot-name)
614  (not (null (find slot-name (class-slots (class-of instance))
615                   :key 'slot-definition-name))))
616
617(defun slot-exists-p (object slot-name)
618  (if (eq (class-of (class-of object)) +the-standard-class+)
619      (std-slot-exists-p object slot-name)
620      (slot-exists-p-using-class (class-of object) object slot-name)))
621
622(defun instance-slot-p (slot)
623  (eq (slot-definition-allocation slot) :instance))
624
625(defun make-instance-standard-class (metaclass
626             &rest initargs
627                                     &key name direct-superclasses direct-slots
628                                     direct-default-initargs
629                                     documentation)
630  (declare (ignore metaclass))
631  (let ((class (std-allocate-instance +the-standard-class+)))
632    (check-initargs class t initargs)
633    (%set-class-name name class)
634    (%set-class-layout nil class)
635    (%set-class-direct-subclasses ()  class)
636    (%set-class-direct-methods ()  class)
637    (%set-class-documentation class documentation)
638    (std-after-initialization-for-classes class
639                                          :direct-superclasses direct-superclasses
640                                          :direct-slots direct-slots
641                                          :direct-default-initargs direct-default-initargs)
642    class))
643
644;(defun convert-to-direct-slot-definition (class canonicalized-slot)
645;  (apply #'make-instance
646;         (apply #'direct-slot-definition-class
647;                class canonicalized-slot)
648;         canonicalized-slot))
649
650(defun std-after-initialization-for-classes (class
651                                             &key direct-superclasses direct-slots
652                                             direct-default-initargs
653                                             &allow-other-keys)
654  (let ((supers (or direct-superclasses
655                    (list +the-standard-object-class+))))
656    (setf (class-direct-superclasses class) supers)
657    (dolist (superclass supers)
658      (pushnew class (class-direct-subclasses superclass))))
659  (let ((slots (mapcar #'(lambda (slot-properties)
660                          (apply #'make-direct-slot-definition class slot-properties))
661                       direct-slots)))
662    (setf (class-direct-slots class) slots)
663    (dolist (direct-slot slots)
664      (dolist (reader (slot-definition-readers direct-slot))
665        (add-reader-method class reader (slot-definition-name direct-slot)))
666      (dolist (writer (slot-definition-writers direct-slot))
667        (add-writer-method class writer (slot-definition-name direct-slot)))))
668  (setf (class-direct-default-initargs class) direct-default-initargs)
669  (funcall (if (eq (class-of class) +the-standard-class+)
670               #'std-finalize-inheritance
671               #'finalize-inheritance)
672           class)
673  (values))
674
675(defun canonical-slot-name (canonical-slot)
676  (getf canonical-slot :name))
677
678(defvar *extensible-built-in-classes*
679  (list (find-class 'sequence)
680        (find-class 'java:java-object)))
681
682(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
683  ;; Check for duplicate slots.
684  (remf all-keys :metaclass)
685  (let ((slots (getf all-keys :direct-slots)))
686    (dolist (s1 slots)
687      (let ((name1 (canonical-slot-name s1)))
688        (dolist (s2 (cdr (memq s1 slots)))
689          (when (eq name1 (canonical-slot-name s2))
690            (error 'program-error "Duplicate slot ~S" name1))))))
691  ;; Check for duplicate argument names in :DEFAULT-INITARGS.
692  (let ((names ()))
693    (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
694          (name (car initargs) (car initargs)))
695         ((null initargs))
696      (push name names))
697    (do* ((names names (cdr names))
698          (name (car names) (car names)))
699         ((null names))
700      (when (memq name (cdr names))
701        (error 'program-error
702               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
703               :format-arguments (list name)))))
704  (let ((direct-superclasses (getf all-keys :direct-superclasses)))
705    (dolist (class direct-superclasses)
706      (when (and (typep class 'built-in-class)
707     (not (member class *extensible-built-in-classes*)))
708        (error "Attempt to define a subclass of a built-in-class: ~S" class))))
709  (let ((old-class (find-class name nil)))
710    (cond ((and old-class (eq name (class-name old-class)))
711           (cond ((typep old-class 'built-in-class)
712                  (error "The symbol ~S names a built-in class." name))
713                 ((typep old-class 'forward-referenced-class)
714                  (let ((new-class (apply #'make-instance-standard-class
715                                          +the-standard-class+
716                                          :name name all-keys)))
717                    (%set-find-class name new-class)
718                    (dolist (subclass (class-direct-subclasses old-class))
719                      (setf (class-direct-superclasses subclass)
720                            (substitute new-class old-class
721                                        (class-direct-superclasses subclass))))
722                    new-class))
723                 (t
724                  ;; We're redefining the class.
725                  (%make-instances-obsolete old-class)
726      (check-initargs old-class t all-keys)
727                  (apply #'std-after-initialization-for-classes old-class all-keys)
728                  old-class)))
729          (t
730           (let ((class (apply (if metaclass
731                                   #'make-instance
732                                   #'make-instance-standard-class)
733                               (or metaclass
734                                   +the-standard-class+)
735                               :name name all-keys)))
736             (%set-find-class name class)
737             class)))))
738
739(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
740  (unless (>= (length form) 3)
741    (error 'program-error "Wrong number of arguments for DEFCLASS."))
742  (check-declaration-type name)
743  `(ensure-class ',name
744                 :direct-superclasses
745                 (canonicalize-direct-superclasses ',direct-superclasses)
746                 :direct-slots
747                 ,(canonicalize-direct-slots direct-slots)
748                 ,@(canonicalize-defclass-options options)))
749
750(eval-when (:compile-toplevel :load-toplevel :execute)
751  (defstruct method-combination
752    name
753    operator
754    identity-with-one-argument
755    documentation)
756
757  (defun expand-short-defcombin (whole)
758    (let* ((name (cadr whole))
759           (documentation
760            (getf (cddr whole) :documentation ""))
761           (identity-with-one-arg
762            (getf (cddr whole) :identity-with-one-argument nil))
763           (operator
764            (getf (cddr whole) :operator name)))
765      `(progn
766         (setf (get ',name 'method-combination-object)
767               (make-method-combination :name ',name
768                                        :operator ',operator
769                                        :identity-with-one-argument ',identity-with-one-arg
770                                        :documentation ',documentation))
771         ',name)))
772
773  (defun expand-long-defcombin (whole)
774    (declare (ignore whole))
775    (error "The long form of DEFINE-METHOD-COMBINATION is not implemented.")))
776
777(defmacro define-method-combination (&whole form &rest args)
778  (declare (ignore args))
779  (if (and (cddr form)
780           (listp (caddr form)))
781      (expand-long-defcombin form)
782      (expand-short-defcombin form)))
783
784(define-method-combination +      :identity-with-one-argument t)
785(define-method-combination and    :identity-with-one-argument t)
786(define-method-combination append :identity-with-one-argument nil)
787(define-method-combination list   :identity-with-one-argument nil)
788(define-method-combination max    :identity-with-one-argument t)
789(define-method-combination min    :identity-with-one-argument t)
790(define-method-combination nconc  :identity-with-one-argument t)
791(define-method-combination or     :identity-with-one-argument t)
792(define-method-combination progn  :identity-with-one-argument t)
793
794(defstruct eql-specializer
795  object)
796
797(defparameter *eql-specializer-table* (make-hash-table :test 'eql))
798
799(defun intern-eql-specializer (object)
800  (or (gethash object *eql-specializer-table*)
801      (setf (gethash object *eql-specializer-table*)
802            (make-eql-specializer :object object))))
803
804;; MOP (p. 216) specifies the following reader generic functions:
805;;   generic-function-argument-precedence-order
806;;   generic-function-declarations
807;;   generic-function-lambda-list
808;;   generic-function-method-class
809;;   generic-function-method-combination
810;;   generic-function-methods
811;;   generic-function-name
812
813(defun generic-function-lambda-list (gf)
814  (%generic-function-lambda-list gf))
815(defsetf generic-function-lambda-list %set-generic-function-lambda-list)
816
817(defun (setf generic-function-documentation) (new-value gf)
818  (set-generic-function-documentation gf new-value))
819
820(defun (setf generic-function-initial-methods) (new-value gf)
821  (set-generic-function-initial-methods gf new-value))
822
823(defun (setf generic-function-methods) (new-value gf)
824  (set-generic-function-methods gf new-value))
825
826(defun (setf generic-function-method-class) (new-value gf)
827  (set-generic-function-method-class gf new-value))
828
829(defun (setf generic-function-method-combination) (new-value gf)
830  (set-generic-function-method-combination gf new-value))
831
832(defun (setf generic-function-argument-precedence-order) (new-value gf)
833  (set-generic-function-argument-precedence-order gf new-value))
834
835(declaim (ftype (function * t) classes-to-emf-table))
836(defun classes-to-emf-table (gf)
837  (generic-function-classes-to-emf-table gf))
838
839(defun (setf classes-to-emf-table) (new-value gf)
840  (set-generic-function-classes-to-emf-table gf new-value))
841
842(defun (setf method-lambda-list) (new-value method)
843  (set-method-lambda-list method new-value))
844
845(defun (setf method-qualifiers) (new-value method)
846  (set-method-qualifiers method new-value))
847
848(defun (setf method-documentation) (new-value method)
849  (set-method-documentation method new-value))
850
851;;; defgeneric
852
853(defmacro defgeneric (function-name lambda-list
854                                    &rest options-and-method-descriptions)
855  (let ((options ())
856        (methods ())
857        (documentation nil))
858    (dolist (item options-and-method-descriptions)
859      (case (car item)
860        (declare) ; FIXME
861        (:documentation
862         (when documentation
863           (error 'program-error
864                  :format-control "Documentation option was specified twice for generic function ~S."
865                  :format-arguments (list function-name)))
866         (setf documentation t)
867         (push item options))
868        (:method
869         (push
870          `(push (defmethod ,function-name ,@(cdr item))
871                 (generic-function-initial-methods (fdefinition ',function-name)))
872          methods))
873        (t
874         (push item options))))
875    (setf options (nreverse options)
876          methods (nreverse methods))
877    `(prog1
878       (%defgeneric
879        ',function-name
880        :lambda-list ',lambda-list
881        ,@(canonicalize-defgeneric-options options))
882       ,@methods)))
883
884(defun canonicalize-defgeneric-options (options)
885  (mapappend #'canonicalize-defgeneric-option options))
886
887(defun canonicalize-defgeneric-option (option)
888  (case (car option)
889    (:generic-function-class
890     (list :generic-function-class `(find-class ',(cadr option))))
891    (:method-class
892     (list :method-class `(find-class ',(cadr option))))
893    (:method-combination
894     (list :method-combination `',(cdr option)))
895    (:argument-precedence-order
896     (list :argument-precedence-order `',(cdr option)))
897    (t
898     (list `',(car option) `',(cadr option)))))
899
900;; From OpenMCL.
901(defun canonicalize-argument-precedence-order (apo req)
902  (cond ((equal apo req) nil)
903        ((not (eql (length apo) (length req)))
904         (error 'program-error
905                :format-control "Specified argument precedence order ~S does not match lambda list."
906                :format-arguments (list apo)))
907        (t (let ((res nil))
908             (dolist (arg apo (nreverse res))
909               (let ((index (position arg req)))
910                 (if (or (null index) (memq index res))
911                     (error 'program-error
912                            :format-control "Specified argument precedence order ~S does not match lambda list."
913                            :format-arguments (list apo)))
914                 (push index res)))))))
915
916(defun find-generic-function (name &optional (errorp t))
917  (let ((function (and (fboundp name) (fdefinition name))))
918    (when function
919      (when (typep function 'generic-function)
920        (return-from find-generic-function function))
921      (when (and *traced-names* (find name *traced-names* :test #'equal))
922        (setf function (untraced-function name))
923        (when (typep function 'generic-function)
924          (return-from find-generic-function function)))))
925  (if errorp
926      (error "There is no generic function named ~S." name)
927      nil))
928
929(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
930  (let* ((plist1 (analyze-lambda-list lambda-list1))
931         (args1 (getf plist1 :required-args))
932         (plist2 (analyze-lambda-list lambda-list2))
933         (args2 (getf plist2 :required-args)))
934    (= (length args1) (length args2))))
935
936(defun %defgeneric (function-name &rest all-keys)
937  (when (fboundp function-name)
938    (let ((gf (fdefinition function-name)))
939      (when (typep gf 'generic-function)
940        ;; Remove methods defined by previous DEFGENERIC forms.
941        (dolist (method (generic-function-initial-methods gf))
942          (%remove-method gf method))
943        (setf (generic-function-initial-methods gf) '()))))
944  (apply 'ensure-generic-function function-name all-keys))
945
946(defun ensure-generic-function (function-name
947                                &rest all-keys
948                                &key
949                                lambda-list
950                                (generic-function-class +the-standard-generic-function-class+)
951                                (method-class +the-standard-method-class+)
952                                (method-combination 'standard)
953                                (argument-precedence-order nil apo-p)
954                                documentation
955                                &allow-other-keys)
956  (when (autoloadp function-name)
957    (resolve function-name))
958  (let ((gf (find-generic-function function-name nil)))
959    (if gf
960        (progn
961          (unless (or (null (generic-function-methods gf))
962                      (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf)))
963            (error 'simple-error
964                   :format-control "The lambda list ~S is incompatible with the existing methods of ~S."
965                   :format-arguments (list lambda-list gf)))
966          (setf (generic-function-lambda-list gf) lambda-list)
967          (setf (generic-function-documentation gf) documentation)
968          (let* ((plist (analyze-lambda-list lambda-list))
969                 (required-args (getf plist ':required-args)))
970            (%set-gf-required-args gf required-args)
971            (when apo-p
972              (setf (generic-function-argument-precedence-order gf)
973                    (if argument-precedence-order
974                        (canonicalize-argument-precedence-order argument-precedence-order
975                                                                required-args)
976                        nil)))
977            (finalize-generic-function gf))
978          gf)
979        (progn
980          (when (and (null *clos-booting*)
981                     (fboundp function-name))
982            (error 'program-error
983                   :format-control "~A already names an ordinary function, macro, or special operator."
984                   :format-arguments (list function-name)))
985          (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
986                              #'make-instance-standard-generic-function
987                              #'make-instance)
988                          generic-function-class
989                          :name function-name
990                          :method-class method-class
991                          :method-combination method-combination
992                          all-keys))
993          gf))))
994
995(defun initial-discriminating-function (gf args)
996  (set-funcallable-instance-function
997   gf
998   (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
999                #'std-compute-discriminating-function
1000                #'compute-discriminating-function)
1001            gf))
1002  (apply gf args))
1003
1004(defun collect-eql-specializer-objects (generic-function)
1005  (let ((result nil))
1006    (dolist (method (generic-function-methods generic-function))
1007      (dolist (specializer (%method-specializers method))
1008        (when (typep specializer 'eql-specializer)
1009          (pushnew (eql-specializer-object specializer)
1010                   result
1011                   :test 'eql))))
1012    result))
1013
1014(defun finalize-generic-function (gf)
1015  (%finalize-generic-function gf)
1016  (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
1017  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
1018  (set-funcallable-instance-function
1019   gf #'(lambda (&rest args)
1020          (initial-discriminating-function gf args)))
1021  ;; FIXME Do we need to warn on redefinition somewhere else?
1022  (let ((*warn-on-redefinition* nil))
1023    (setf (fdefinition (%generic-function-name gf)) gf))
1024  (values))
1025
1026(defun make-instance-standard-generic-function (generic-function-class
1027                                                &key name lambda-list
1028                                                method-class
1029                                                method-combination
1030                                                argument-precedence-order
1031                                                documentation)
1032  (declare (ignore generic-function-class))
1033  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
1034    (%set-generic-function-name gf name)
1035    (setf (generic-function-lambda-list gf) lambda-list)
1036    (setf (generic-function-initial-methods gf) ())
1037    (setf (generic-function-methods gf) ())
1038    (setf (generic-function-method-class gf) method-class)
1039    (setf (generic-function-method-combination gf) method-combination)
1040    (setf (generic-function-documentation gf) documentation)
1041    (setf (classes-to-emf-table gf) nil)
1042    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
1043           (required-args (getf plist ':required-args)))
1044      (%set-gf-required-args gf required-args)
1045      (setf (generic-function-argument-precedence-order gf)
1046            (if argument-precedence-order
1047                (canonicalize-argument-precedence-order argument-precedence-order
1048                                                        required-args)
1049                nil)))
1050    (finalize-generic-function gf)
1051    gf))
1052
1053(defun canonicalize-specializers (specializers)
1054  (mapcar #'canonicalize-specializer specializers))
1055
1056(defun canonicalize-specializer (specializer)
1057  (cond ((classp specializer)
1058         specializer)
1059        ((eql-specializer-p specializer)
1060         specializer)
1061        ((symbolp specializer)
1062         (find-class specializer))
1063        ((and (consp specializer)
1064              (eq (car specializer) 'eql))
1065         (let ((object (cadr specializer)))
1066           (when (and (consp object)
1067                      (eq (car object) 'quote))
1068             (setf object (cadr object)))
1069           (intern-eql-specializer object)))
1070  ((and (consp specializer)
1071              (eq (car specializer) 'java:jclass))
1072         (let ((jclass (eval specializer)))
1073     (java::ensure-java-class jclass)))
1074        (t
1075         (error "Unknown specializer: ~S" specializer))))
1076
1077(defun parse-defmethod (args)
1078  (let ((function-name (car args))
1079        (qualifiers ())
1080        (specialized-lambda-list ())
1081        (body ())
1082        (parse-state :qualifiers))
1083    (dolist (arg (cdr args))
1084      (ecase parse-state
1085        (:qualifiers
1086         (if (and (atom arg) (not (null arg)))
1087             (push arg qualifiers)
1088             (progn
1089               (setf specialized-lambda-list arg)
1090               (setf parse-state :body))))
1091        (:body (push arg body))))
1092    (setf qualifiers (nreverse qualifiers)
1093          body (nreverse body))
1094    (multiple-value-bind (real-body declarations documentation)
1095        (parse-body body)
1096      (values function-name
1097              qualifiers
1098              (extract-lambda-list specialized-lambda-list)
1099              (extract-specializers specialized-lambda-list)
1100              documentation
1101              declarations
1102              (list* 'block
1103                     (fdefinition-block-name function-name)
1104                     real-body)))))
1105
1106(defun required-portion (gf args)
1107  (let ((number-required (length (gf-required-args gf))))
1108    (when (< (length args) number-required)
1109      (error 'program-error
1110             :format-control "Not enough arguments for generic function ~S."
1111             :format-arguments (list (%generic-function-name gf))))
1112    (subseq args 0 number-required)))
1113
1114(defun extract-lambda-list (specialized-lambda-list)
1115  (let* ((plist (analyze-lambda-list specialized-lambda-list))
1116         (requireds (getf plist :required-names))
1117         (rv (getf plist :rest-var))
1118         (ks (getf plist :key-args))
1119         (keysp (getf plist :keysp))
1120         (aok (getf plist :allow-other-keys))
1121         (opts (getf plist :optional-args))
1122         (auxs (getf plist :auxiliary-args)))
1123    `(,@requireds
1124      ,@(if rv `(&rest ,rv) ())
1125      ,@(if (or ks keysp aok) `(&key ,@ks) ())
1126      ,@(if aok '(&allow-other-keys) ())
1127      ,@(if opts `(&optional ,@opts) ())
1128      ,@(if auxs `(&aux ,@auxs) ()))))
1129
1130(defun extract-specializers (specialized-lambda-list)
1131  (let ((plist (analyze-lambda-list specialized-lambda-list)))
1132    (getf plist ':specializers)))
1133
1134(defun get-keyword-from-arg (arg)
1135  (if (listp arg)
1136      (if (listp (car arg))
1137          (caar arg)
1138          (make-keyword (car arg)))
1139      (make-keyword arg)))
1140
1141(defun analyze-lambda-list (lambda-list)
1142  (let ((keys ())           ; Just the keywords
1143        (key-args ())       ; Keywords argument specs
1144        (keysp nil)         ;
1145        (required-names ()) ; Just the variable names
1146        (required-args ())  ; Variable names & specializers
1147        (specializers ())   ; Just the specializers
1148        (rest-var nil)
1149        (optionals ())
1150        (auxs ())
1151        (allow-other-keys nil)
1152        (state :parsing-required))
1153    (dolist (arg lambda-list)
1154      (if (member arg lambda-list-keywords)
1155          (ecase arg
1156            (&optional
1157             (setq state :parsing-optional))
1158            (&rest
1159             (setq state :parsing-rest))
1160            (&key
1161             (setq keysp t)
1162             (setq state :parsing-key))
1163            (&allow-other-keys
1164             (setq allow-other-keys 't))
1165            (&aux
1166             (setq state :parsing-aux)))
1167          (case state
1168            (:parsing-required
1169             (push-on-end arg required-args)
1170             (if (listp arg)
1171                 (progn (push-on-end (car arg) required-names)
1172                   (push-on-end (cadr arg) specializers))
1173                 (progn (push-on-end arg required-names)
1174                   (push-on-end 't specializers))))
1175            (:parsing-optional (push-on-end arg optionals))
1176            (:parsing-rest (setq rest-var arg))
1177            (:parsing-key
1178             (push-on-end (get-keyword-from-arg arg) keys)
1179             (push-on-end arg key-args))
1180            (:parsing-aux (push-on-end arg auxs)))))
1181    (list  :required-names required-names
1182           :required-args required-args
1183           :specializers specializers
1184           :rest-var rest-var
1185           :keywords keys
1186           :key-args key-args
1187           :keysp keysp
1188           :auxiliary-args auxs
1189           :optional-args optionals
1190           :allow-other-keys allow-other-keys)))
1191
1192#+nil
1193(defun check-method-arg-info (gf arg-info method)
1194  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1195      (analyze-lambda-list (if (consp method)
1196                               (early-method-lambda-list method)
1197                               (method-lambda-list method)))
1198    (flet ((lose (string &rest args)
1199                 (error 'simple-program-error
1200                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
1201                        to the generic function~2I~_~S;~I~_~
1202                        but ~?~:>"
1203                        :format-arguments (list method gf string args)))
1204           (comparison-description (x y)
1205                                   (if (> x y) "more" "fewer")))
1206      (let ((gf-nreq (arg-info-number-required arg-info))
1207            (gf-nopt (arg-info-number-optional arg-info))
1208            (gf-key/rest-p (arg-info-key/rest-p arg-info))
1209            (gf-keywords (arg-info-keys arg-info)))
1210        (unless (= nreq gf-nreq)
1211          (lose
1212           "the method has ~A required arguments than the generic function."
1213           (comparison-description nreq gf-nreq)))
1214        (unless (= nopt gf-nopt)
1215          (lose
1216           "the method has ~A optional arguments than the generic function."
1217           (comparison-description nopt gf-nopt)))
1218        (unless (eq (or keysp restp) gf-key/rest-p)
1219          (lose
1220           "the method and generic function differ in whether they accept~_~
1221            &REST or &KEY arguments."))
1222        (when (consp gf-keywords)
1223          (unless (or (and restp (not keysp))
1224                      allow-other-keys-p
1225                      (every (lambda (k) (memq k keywords)) gf-keywords))
1226            (lose "the method does not accept each of the &KEY arguments~2I~_~
1227            ~S."
1228                  gf-keywords)))))))
1229
1230(defun check-method-lambda-list (method-lambda-list gf-lambda-list)
1231  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
1232         (gf-plist (analyze-lambda-list gf-lambda-list))
1233         (gf-keysp (getf gf-plist :keysp))
1234         (gf-keywords (getf gf-plist :keywords))
1235         (method-plist (analyze-lambda-list method-lambda-list))
1236         (method-restp (not (null (memq '&rest method-lambda-list))))
1237         (method-keysp (getf method-plist :keysp))
1238         (method-keywords (getf method-plist :keywords))
1239         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1240    (unless (= (length (getf gf-plist :required-args))
1241               (length (getf method-plist :required-args)))
1242      (error "The method has the wrong number of required arguments for the generic function."))
1243    (unless (= (length (getf gf-plist :optional-args))
1244               (length (getf method-plist :optional-args)))
1245      (error "The method has the wrong number of optional arguments for the generic function."))
1246    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1247      (error "The method and the generic function differ in whether they accept &REST or &KEY arguments."))
1248    (when (consp gf-keywords)
1249      (unless (or (and method-restp (not method-keysp))
1250                  method-allow-other-keys-p
1251                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
1252        (error "The method does not accept all of the keyword arguments defined for the generic function.")))))
1253
1254(declaim (ftype (function * method) ensure-method))
1255(defun ensure-method (name &rest all-keys)
1256  (let ((method-lambda-list (getf all-keys :lambda-list))
1257        (gf (find-generic-function name nil)))
1258    (if gf
1259        (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf))
1260        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
1261    (let ((method
1262           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
1263               (apply #'make-instance-standard-method gf all-keys)
1264               (apply #'make-instance (generic-function-method-class gf) all-keys))))
1265      (%add-method gf method)
1266      method)))
1267
1268(defun make-instance-standard-method (gf
1269                                      &key
1270                                      lambda-list
1271                                      qualifiers
1272                                      specializers
1273                                      documentation
1274                                      function
1275                                      fast-function)
1276  (declare (ignore gf))
1277  (let ((method (std-allocate-instance +the-standard-method-class+)))
1278    (setf (method-lambda-list method) lambda-list)
1279    (setf (method-qualifiers method) qualifiers)
1280    (%set-method-specializers method (canonicalize-specializers specializers))
1281    (setf (method-documentation method) documentation)
1282    (%set-method-generic-function method nil)
1283    (%set-method-function method function)
1284    (%set-method-fast-function method fast-function)
1285    method))
1286
1287(defun %add-method (gf method)
1288  (when (%method-generic-function method)
1289    (error 'simple-error
1290           :format-control "ADD-METHOD: ~S is a method of ~S."
1291           :format-arguments (list method (%method-generic-function method))))
1292  ;; Remove existing method with same qualifiers and specializers (if any).
1293  (let ((old-method (%find-method gf (method-qualifiers method)
1294                                 (%method-specializers method) nil)))
1295    (when old-method
1296      (%remove-method gf old-method)))
1297  (%set-method-generic-function method gf)
1298  (push method (generic-function-methods gf))
1299  (dolist (specializer (%method-specializers method))
1300    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1301      (pushnew method (class-direct-methods specializer))))
1302  (finalize-generic-function gf)
1303  gf)
1304
1305(defun %remove-method (gf method)
1306  (setf (generic-function-methods gf)
1307        (remove method (generic-function-methods gf)))
1308  (%set-method-generic-function method nil)
1309  (dolist (specializer (%method-specializers method))
1310    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1311      (setf (class-direct-methods specializer)
1312            (remove method (class-direct-methods specializer)))))
1313  (finalize-generic-function gf)
1314  gf)
1315
1316(defun %find-method (gf qualifiers specializers &optional (errorp t))
1317  ;; "If the specializers argument does not correspond in length to the number
1318  ;; of required arguments of the generic-function, an an error of type ERROR
1319  ;; is signaled."
1320  (unless (= (length specializers) (length (gf-required-args gf)))
1321    (error "The specializers argument has length ~S, but ~S has ~S required parameters."
1322           (length specializers)
1323           gf
1324           (length (gf-required-args gf))))
1325  (let* ((canonical-specializers (canonicalize-specializers specializers))
1326         (method
1327          (find-if #'(lambda (method)
1328                      (and (equal qualifiers
1329                                  (method-qualifiers method))
1330                           (equal canonical-specializers
1331                                  (%method-specializers method))))
1332                   (generic-function-methods gf))))
1333    (if (and (null method) errorp)
1334        (error "No such method for ~S." (%generic-function-name gf))
1335        method)))
1336
1337(defun fast-callable-p (gf)
1338  (and (eq (generic-function-method-combination gf) 'standard)
1339       (null (intersection (%generic-function-lambda-list gf)
1340                           '(&rest &optional &key &allow-other-keys &aux)))))
1341
1342(declaim (ftype (function * t) slow-method-lookup-1))
1343
1344(declaim (ftype (function (t t t) t) slow-reader-lookup))
1345(defun slow-reader-lookup (gf layout slot-name)
1346  (let ((location (layout-slot-location layout slot-name)))
1347    (cache-slot-location gf layout location)
1348    location))
1349
1350(defun std-compute-discriminating-function (gf)
1351  (let ((code
1352         (cond
1353           ((and (= (length (generic-function-methods gf)) 1)
1354                 (typep (car (generic-function-methods gf)) 'standard-reader-method))
1355            ;;                 (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
1356
1357            (let* ((method (%car (generic-function-methods gf)))
1358                   (class (car (%method-specializers method)))
1359                   (slot-name (reader-method-slot-name method)))
1360              #'(lambda (arg)
1361                  (declare (optimize speed))
1362                  (let* ((layout (std-instance-layout arg))
1363                         (location (get-cached-slot-location gf layout)))
1364                    (unless location
1365                      (unless (simple-typep arg class)
1366                        ;; FIXME no applicable method
1367                        (error 'simple-type-error
1368                               :datum arg
1369                               :expected-type class))
1370                      (setf location (slow-reader-lookup gf layout slot-name)))
1371                    (if (consp location)
1372                        ;; Shared slot.
1373                        (cdr location)
1374                        (standard-instance-access arg location))))))
1375
1376           (t
1377            (let* ((emf-table (classes-to-emf-table gf))
1378                   (number-required (length (gf-required-args gf)))
1379                   (lambda-list (%generic-function-lambda-list gf))
1380                   (exact (null (intersection lambda-list
1381                                              '(&rest &optional &key
1382                                                &allow-other-keys &aux)))))
1383              (if exact
1384                  (cond
1385                    ((= number-required 1)
1386                     (cond
1387                       ((and (eq (generic-function-method-combination gf) 'standard)
1388                             (= (length (generic-function-methods gf)) 1))
1389                        (let* ((method (%car (generic-function-methods gf)))
1390                               (specializer (car (%method-specializers method)))
1391                               (function (or (%method-fast-function method)
1392                                             (%method-function method))))
1393                          (if (eql-specializer-p specializer)
1394                              (let ((specializer-object (eql-specializer-object specializer)))
1395                                #'(lambda (arg)
1396                                    (declare (optimize speed))
1397                                    (if (eql arg specializer-object)
1398                                        (funcall function arg)
1399                                        (no-applicable-method gf (list arg)))))
1400                              #'(lambda (arg)
1401                                  (declare (optimize speed))
1402                                  (unless (simple-typep arg specializer)
1403                                    ;; FIXME no applicable method
1404                                    (error 'simple-type-error
1405                                           :datum arg
1406                                           :expected-type specializer))
1407                                  (funcall function arg)))))
1408                       (t
1409                        #'(lambda (arg)
1410                            (declare (optimize speed))
1411                            (let* ((specialization
1412                                    (%get-arg-specialization gf arg))
1413                                   (emfun (or (gethash1 specialization
1414                                                        emf-table)
1415                                              (slow-method-lookup-1
1416                                               gf arg specialization))))
1417                              (if emfun
1418                                  (funcall emfun (list arg))
1419                                  (apply #'no-applicable-method gf (list arg))))))))
1420                    ((= number-required 2)
1421                     #'(lambda (arg1 arg2)
1422                         (declare (optimize speed))
1423                         (let* ((args (list arg1 arg2))
1424                                (emfun (get-cached-emf gf args)))
1425                           (if emfun
1426                               (funcall emfun args)
1427                               (slow-method-lookup gf args)))))
1428                    ((= number-required 3)
1429                     #'(lambda (arg1 arg2 arg3)
1430                         (declare (optimize speed))
1431                         (let* ((args (list arg1 arg2 arg3))
1432                                (emfun (get-cached-emf gf args)))
1433                           (if emfun
1434                               (funcall emfun args)
1435                               (slow-method-lookup gf args)))))
1436                    (t
1437                     #'(lambda (&rest args)
1438                         (declare (optimize speed))
1439                         (let ((len (length args)))
1440                           (unless (= len number-required)
1441                             (error 'program-error
1442                                    :format-control "Not enough arguments for generic function ~S."
1443                                    :format-arguments (list (%generic-function-name gf)))))
1444                         (let ((emfun (get-cached-emf gf args)))
1445                           (if emfun
1446                               (funcall emfun args)
1447                               (slow-method-lookup gf args))))))
1448                  #'(lambda (&rest args)
1449                      (declare (optimize speed))
1450                      (let ((len (length args)))
1451                        (unless (>= len number-required)
1452                          (error 'program-error
1453                                 :format-control "Not enough arguments for generic function ~S."
1454                                 :format-arguments (list (%generic-function-name gf)))))
1455                      (let ((emfun (get-cached-emf gf args)))
1456                        (if emfun
1457                            (funcall emfun args)
1458                            (slow-method-lookup gf args))))))))))
1459
1460    code))
1461
1462(defun sort-methods (methods gf required-classes)
1463  (if (or (null methods) (null (%cdr methods)))
1464      methods
1465      (sort methods
1466      (if (eq (class-of gf) +the-standard-generic-function-class+)
1467    #'(lambda (m1 m2)
1468        (std-method-more-specific-p m1 m2 required-classes
1469            (generic-function-argument-precedence-order gf)))
1470    #'(lambda (m1 m2)
1471        (method-more-specific-p gf m1 m2 required-classes))))))
1472
1473(defun method-applicable-p (method args)
1474  (do* ((specializers (%method-specializers method) (cdr specializers))
1475        (args args (cdr args)))
1476       ((null specializers) t)
1477    (let ((specializer (car specializers)))
1478      (if (typep specializer 'eql-specializer)
1479          (unless (eql (car args) (eql-specializer-object specializer))
1480            (return nil))
1481          (unless (subclassp (class-of (car args)) specializer)
1482            (return nil))))))
1483
1484(defun %compute-applicable-methods (gf args)
1485  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
1486        (methods '()))
1487    (dolist (method (generic-function-methods gf))
1488      (when (method-applicable-p method args)
1489        (push method methods)))
1490    (sort-methods methods gf required-classes)))
1491
1492;;; METHOD-APPLICABLE-USING-CLASSES-P
1493;;;
1494;;; If the first return value is T, METHOD is definitely applicable to
1495;;; arguments that are instances of CLASSES.  If the first value is
1496;;; NIL and the second value is T, METHOD is definitely not applicable
1497;;; to arguments that are instances of CLASSES; if the second value is
1498;;; NIL the applicability of METHOD cannot be determined by inspecting
1499;;; the classes of its arguments only.
1500;;;
1501(defun method-applicable-using-classes-p (method classes)
1502  (do* ((specializers (%method-specializers method) (cdr specializers))
1503  (classes classes (cdr classes))
1504  (knownp t))
1505       ((null specializers)
1506  (if knownp (values t t) (values nil nil)))
1507    (let ((specializer (car specializers)))
1508      (if (typep specializer 'eql-specializer)
1509    (if (eql (class-of (eql-specializer-object specializer)) 
1510       (car classes))
1511        (setf knownp nil)
1512        (return (values nil t)))
1513    (unless (subclassp (car classes) specializer)
1514      (return (values nil t)))))))
1515
1516(defun slow-method-lookup (gf args)
1517  (let ((applicable-methods (%compute-applicable-methods gf args)))
1518    (if applicable-methods
1519        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1520                                  #'std-compute-effective-method-function
1521                                  #'compute-effective-method-function)
1522                              gf applicable-methods)))
1523          (cache-emf gf args emfun)
1524          (funcall emfun args))
1525        (apply #'no-applicable-method gf args))))
1526
1527(defun slow-method-lookup-1 (gf arg arg-specialization)
1528  (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
1529    (if applicable-methods
1530        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1531                                  #'std-compute-effective-method-function
1532                                  #'compute-effective-method-function)
1533                              gf applicable-methods)))
1534          (when emfun
1535            (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
1536          emfun))))
1537
1538(defun sub-specializer-p (c1 c2 c-arg)
1539  (find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
1540
1541(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
1542  (if argument-precedence-order
1543      (let ((specializers-1 (%method-specializers method1))
1544            (specializers-2 (%method-specializers method2)))
1545        (dolist (index argument-precedence-order)
1546          (let ((spec1 (nth index specializers-1))
1547                (spec2 (nth index specializers-2)))
1548            (unless (eq spec1 spec2)
1549              (cond ((eql-specializer-p spec1)
1550                     (return t))
1551                    ((eql-specializer-p spec2)
1552                     (return nil))
1553                    (t
1554                     (return (sub-specializer-p spec1 spec2
1555                                                (nth index required-classes)))))))))
1556      (do ((specializers-1 (%method-specializers method1) (cdr specializers-1))
1557           (specializers-2 (%method-specializers method2) (cdr specializers-2))
1558           (classes required-classes (cdr classes)))
1559          ((null specializers-1) nil)
1560        (let ((spec1 (car specializers-1))
1561              (spec2 (car specializers-2)))
1562          (unless (eq spec1 spec2)
1563            (cond ((eql-specializer-p spec1)
1564                   (return t))
1565                  ((eql-specializer-p spec2)
1566                   (return nil))
1567                  (t
1568                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))
1569
1570(defun primary-method-p (method)
1571  (null (intersection '(:before :after :around) (method-qualifiers method))))
1572
1573(defun before-method-p (method)
1574  (equal '(:before) (method-qualifiers method)))
1575
1576(defun after-method-p (method)
1577  (equal '(:after) (method-qualifiers method)))
1578
1579(defun around-method-p (method)
1580  (equal '(:around) (method-qualifiers method)))
1581
1582(defun std-compute-effective-method-function (gf methods)
1583  (let* ((mc (generic-function-method-combination gf))
1584         (mc-name (if (atom mc) mc (%car mc)))
1585         (options (if (atom mc) '() (%cdr mc)))
1586         (order (car options))
1587         (primaries '())
1588         (arounds '())
1589         around
1590         emf-form)
1591    (dolist (m methods)
1592      (let ((qualifiers (method-qualifiers m)))
1593        (cond ((null qualifiers)
1594               (if (eq mc-name 'standard)
1595                   (push m primaries)
1596                   (error "Method combination type mismatch.")))
1597              ((cdr qualifiers)
1598               (error "Invalid method qualifiers."))
1599              ((eq (car qualifiers) :around)
1600               (push m arounds))
1601              ((eq (car qualifiers) mc-name)
1602               (push m primaries))
1603              ((memq (car qualifiers) '(:before :after)))
1604              (t
1605               (error "Invalid method qualifiers.")))))
1606    (unless (eq order :most-specific-last)
1607      (setf primaries (nreverse primaries)))
1608    (setf arounds (nreverse arounds))
1609    (setf around (car arounds))
1610    (when (null primaries)
1611      (error "No primary methods for the generic function ~S." gf))
1612    (cond
1613      (around
1614       (let ((next-emfun
1615              (funcall
1616               (if (eq (class-of gf) +the-standard-generic-function-class+)
1617                   #'std-compute-effective-method-function
1618                   #'compute-effective-method-function)
1619               gf (remove around methods))))
1620         (setf emf-form
1621;;;           `(lambda (args)
1622;;;          (funcall ,(%method-function around) args ,next-emfun))
1623               (generate-emf-lambda (%method-function around) next-emfun)
1624               )))
1625      ((eq mc-name 'standard)
1626       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
1627              (befores (remove-if-not #'before-method-p methods))
1628              (reverse-afters
1629               (reverse (remove-if-not #'after-method-p methods))))
1630         (setf emf-form
1631               (cond
1632                 ((and (null befores) (null reverse-afters))
1633                  (let ((fast-function (%method-fast-function (car primaries))))
1634
1635                    (if fast-function
1636                        (ecase (length (gf-required-args gf))
1637                          (1
1638                           #'(lambda (args)
1639                               (declare (optimize speed))
1640                               (funcall fast-function (car args))))
1641                          (2
1642                           #'(lambda (args)
1643                               (declare (optimize speed))
1644                               (funcall fast-function (car args) (cadr args)))))
1645                        ;;                               `(lambda (args)
1646                        ;;                                  (declare (optimize speed))
1647                        ;;                                  (funcall ,(%method-function (car primaries)) args ,next-emfun))
1648                        (generate-emf-lambda (%method-function (car primaries))
1649                                             next-emfun))))
1650                 (t
1651                  (let ((method-function (%method-function (car primaries))))
1652
1653                    #'(lambda (args)
1654                        (declare (optimize speed))
1655                        (dolist (before befores)
1656                          (funcall (%method-function before) args nil))
1657                        (multiple-value-prog1
1658                            (funcall method-function args next-emfun)
1659                          (dolist (after reverse-afters)
1660                            (funcall (%method-function after) args nil))))))))))
1661          (t
1662           (let ((mc-obj (get mc-name 'method-combination-object)))
1663             (unless mc-obj
1664               (error "Unsupported method combination type ~A." mc-name))
1665             (let* ((operator (method-combination-operator mc-obj))
1666                    (ioa (method-combination-identity-with-one-argument mc-obj)))
1667               (setf emf-form
1668                     (if (and (null (cdr primaries))
1669                              (not (null ioa)))
1670;;                          `(lambda (args)
1671;;                             (funcall ,(%method-function (car primaries)) args nil))
1672                         (generate-emf-lambda (%method-function (car primaries)) nil)
1673                         `(lambda (args)
1674                            (,operator ,@(mapcar
1675                                          (lambda (primary)
1676                                            `(funcall ,(%method-function primary) args nil))
1677                                          primaries)))))))))
1678    (or (ignore-errors (autocompile emf-form))
1679        (coerce-to-function emf-form))))
1680
1681(defun generate-emf-lambda (method-function next-emfun)
1682  #'(lambda (args)
1683      (declare (optimize speed))
1684      (funcall method-function args next-emfun)))
1685
1686;;; compute an effective method function from a list of primary methods:
1687
1688(defun compute-primary-emfun (methods)
1689  (if (null methods)
1690      nil
1691      (let ((next-emfun (compute-primary-emfun (cdr methods))))
1692        #'(lambda (args)
1693           (funcall (%method-function (car methods)) args next-emfun)))))
1694
1695(defvar *call-next-method-p*)
1696(defvar *next-method-p-p*)
1697
1698(defun walk-form (form)
1699  (cond ((atom form)
1700         (cond ((eq form 'call-next-method)
1701                (setf *call-next-method-p* t))
1702               ((eq form 'next-method-p)
1703                (setf *next-method-p-p* t))))
1704        (t
1705         (walk-form (%car form))
1706         (walk-form (%cdr form)))))
1707
1708(defun compute-method-function (lambda-expression)
1709  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
1710        (body (cddr lambda-expression))
1711        (*call-next-method-p* nil)
1712        (*next-method-p-p* nil))
1713    (multiple-value-bind (body declarations) (parse-body body)
1714      (let ((ignorable-vars '()))
1715        (dolist (var lambda-list)
1716          (if (memq var lambda-list-keywords)
1717              (return)
1718              (push var ignorable-vars)))
1719        (push `(declare (ignorable ,@ignorable-vars)) declarations))
1720      (walk-form body)
1721      (cond ((or *call-next-method-p* *next-method-p-p*)
1722             `(lambda (args next-emfun)
1723                (flet ((call-next-method (&rest cnm-args)
1724                         (if (null next-emfun)
1725                             (error "No next method for generic function.")
1726                             (funcall next-emfun (or cnm-args args))))
1727                       (next-method-p ()
1728                         (not (null next-emfun))))
1729                  (declare (ignorable (function call-next-method)
1730                                      (function next-method-p)))
1731                  (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
1732            ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
1733             ;; Required parameters only.
1734             (case (length lambda-list)
1735               (1
1736                `(lambda (args next-emfun)
1737                   (declare (ignore next-emfun))
1738                   (let ((,(%car lambda-list) (%car args)))
1739                     (declare (ignorable ,(%car lambda-list)))
1740                     ,@declarations ,@body)))
1741               (2
1742                `(lambda (args next-emfun)
1743                   (declare (ignore next-emfun))
1744                   (let ((,(%car lambda-list) (%car args))
1745                         (,(%cadr lambda-list) (%cadr args)))
1746                     (declare (ignorable ,(%car lambda-list)
1747                                         ,(%cadr lambda-list)))
1748                     ,@declarations ,@body)))
1749               (3
1750                `(lambda (args next-emfun)
1751                   (declare (ignore next-emfun))
1752                   (let ((,(%car lambda-list) (%car args))
1753                         (,(%cadr lambda-list) (%cadr args))
1754                         (,(%caddr lambda-list) (%caddr args)))
1755                     (declare (ignorable ,(%car lambda-list)
1756                                         ,(%cadr lambda-list)
1757                                         ,(%caddr lambda-list)))
1758                     ,@declarations ,@body)))
1759               (t
1760                `(lambda (args next-emfun)
1761                   (declare (ignore next-emfun))
1762                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
1763            (t
1764             `(lambda (args next-emfun)
1765                (declare (ignore next-emfun))
1766                (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
1767
1768(defun compute-method-fast-function (lambda-expression)
1769  (let ((lambda-list (allow-other-keys (cadr lambda-expression))))
1770    (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))
1771      (return-from compute-method-fast-function nil))
1772    ;; Only required args.
1773    (let ((body (cddr lambda-expression))
1774          (*call-next-method-p* nil)
1775          (*next-method-p-p* nil))
1776      (multiple-value-bind (body declarations) (parse-body body)
1777        (walk-form body)
1778        (when (or *call-next-method-p* *next-method-p-p*)
1779          (return-from compute-method-fast-function nil))
1780        (let ((decls `(declare (ignorable ,@lambda-list))))
1781          (setf lambda-expression
1782                (list* (car lambda-expression)
1783                       (cadr lambda-expression)
1784                       decls
1785                       (cddr lambda-expression))))
1786        (case (length lambda-list)
1787          (1
1788;;            `(lambda (args next-emfun)
1789;;               (let ((,(%car lambda-list) (%car args)))
1790;;                 (declare (ignorable ,(%car lambda-list)))
1791;;                 ,@declarations ,@body)))
1792           lambda-expression)
1793          (2
1794;;            `(lambda (args next-emfun)
1795;;               (let ((,(%car lambda-list) (%car args))
1796;;                     (,(%cadr lambda-list) (%cadr args)))
1797;;                 (declare (ignorable ,(%car lambda-list)
1798;;                                     ,(%cadr lambda-list)))
1799;;                 ,@declarations ,@body)))
1800           lambda-expression)
1801;;           (3
1802;;            `(lambda (args next-emfun)
1803;;               (let ((,(%car lambda-list) (%car args))
1804;;                     (,(%cadr lambda-list) (%cadr args))
1805;;                     (,(%caddr lambda-list) (%caddr args)))
1806;;                 (declare (ignorable ,(%car lambda-list)
1807;;                                     ,(%cadr lambda-list)
1808;;                                     ,(%caddr lambda-list)))
1809;;                 ,@declarations ,@body)))
1810          (t
1811           nil))))))
1812
1813;; From CLHS section 7.6.5:
1814;; "When a generic function or any of its methods mentions &key in a lambda
1815;; list, the specific set of keyword arguments accepted by the generic function
1816;; varies according to the applicable methods. The set of keyword arguments
1817;; accepted by the generic function for a particular call is the union of the
1818;; keyword arguments accepted by all applicable methods and the keyword
1819;; arguments mentioned after &key in the generic function definition, if any."
1820;; Adapted from Sacla.
1821(defun allow-other-keys (lambda-list)
1822  (if (and (member '&key lambda-list)
1823           (not (member '&allow-other-keys lambda-list)))
1824      (let* ((key-end (or (position '&aux lambda-list) (length lambda-list)))
1825             (aux-part (subseq lambda-list key-end)))
1826        `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
1827      lambda-list))
1828
1829(defmacro defmethod (&rest args)
1830  (multiple-value-bind
1831      (function-name qualifiers lambda-list specializers documentation declarations body)
1832      (parse-defmethod args)
1833    (let* ((specializers-form '())
1834           (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
1835           (method-function (compute-method-function lambda-expression))
1836           (fast-function (compute-method-fast-function lambda-expression))
1837           )
1838      (dolist (specializer specializers)
1839        (cond ((and (consp specializer) (eq (car specializer) 'eql))
1840               (push `(list 'eql ,(cadr specializer)) specializers-form))
1841              (t
1842               (push `',specializer specializers-form))))
1843      (setf specializers-form `(list ,@(nreverse specializers-form)))
1844      `(progn
1845         (ensure-method ',function-name
1846                        :lambda-list ',lambda-list
1847                        :qualifiers ',qualifiers
1848                        :specializers ,specializers-form
1849                        ,@(if documentation `(:documentation ,documentation))
1850                        :function (function ,method-function)
1851                        ,@(if fast-function `(:fast-function (function ,fast-function)))
1852                        )))))
1853
1854;;; Reader and writer methods
1855
1856(defun make-instance-standard-reader-method (gf
1857                                             &key
1858                                             lambda-list
1859                                             qualifiers
1860                                             specializers
1861                                             documentation
1862                                             function
1863                                             fast-function
1864                                             slot-name)
1865  (declare (ignore gf))
1866  (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
1867    (setf (method-lambda-list method) lambda-list)
1868    (setf (method-qualifiers method) qualifiers)
1869    (%set-method-specializers method (canonicalize-specializers specializers))
1870    (setf (method-documentation method) documentation)
1871    (%set-method-generic-function method nil)
1872    (%set-method-function method function)
1873    (%set-method-fast-function method fast-function)
1874    (set-reader-method-slot-name method slot-name)
1875    method))
1876
1877(defun add-reader-method (class function-name slot-name)
1878  (let* ((lambda-expression
1879          (if (eq (class-of class) +the-standard-class+)
1880              `(lambda (object) (std-slot-value object ',slot-name))
1881              `(lambda (object) (slot-value object ',slot-name))))
1882         (method-function (compute-method-function lambda-expression))
1883         (fast-function (compute-method-fast-function lambda-expression)))
1884    (let ((method-lambda-list '(object))
1885          (gf (find-generic-function function-name nil)))
1886      (if gf
1887          (check-method-lambda-list method-lambda-list (generic-function-lambda-list gf))
1888          (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list)))
1889      (let ((method
1890             (make-instance-standard-reader-method gf
1891                                                   :lambda-list '(object)
1892                                                   :qualifiers ()
1893                                                   :specializers (list class)
1894                                                   :function (if (autoloadp 'compile)
1895                                                                 method-function
1896                                                                 (autocompile method-function))
1897                                                   :fast-function (if (autoloadp 'compile)
1898                                                                      fast-function
1899                                                                      (autocompile fast-function))
1900                                                   :slot-name slot-name)))
1901        (%add-method gf method)
1902        method))))
1903
1904(defun add-writer-method (class function-name slot-name)
1905  (let* ((lambda-expression
1906          (if (eq (class-of class) +the-standard-class+)
1907              `(lambda (new-value object)
1908                 (setf (std-slot-value object ',slot-name) new-value))
1909              `(lambda (new-value object)
1910                 (setf (slot-value object ',slot-name) new-value))))
1911         (method-function (compute-method-function lambda-expression))
1912         (fast-function (compute-method-fast-function lambda-expression))
1913         )
1914    (ensure-method function-name
1915                   :lambda-list '(new-value object)
1916                   :qualifiers ()
1917                   :specializers (list +the-T-class+ class)
1918;;                    :function `(function ,method-function)
1919                   :function (if (autoloadp 'compile)
1920                                 method-function
1921                                 (autocompile method-function))
1922                   :fast-function (if (autoloadp 'compile)
1923                                      fast-function
1924                                      (autocompile fast-function))
1925                   )))
1926
1927(defmacro redefine-class-forwarder (name slot &optional alternative-name)
1928  (let* (($name (if (consp name) (cadr name) name))
1929         (%name (intern (concatenate 'string
1930                                     "%"
1931                                     (if (consp name)
1932                                         (symbol-name 'set-) "")
1933                                     (symbol-name $name))
1934                        (find-package "SYS"))))
1935    (unless alternative-name
1936      (setf alternative-name name))
1937    (if (consp name)
1938        `(progn ;; setter
1939           (defgeneric ,alternative-name (new-value class))
1940           (defmethod ,alternative-name (new-value (class built-in-class))
1941             (,%name new-value class))
1942           (defmethod ,alternative-name (new-value (class forward-referenced-class))
1943             (,%name new-value class))
1944           (defmethod ,alternative-name (new-value (class structure-class))
1945             (,%name new-value class))
1946           (defmethod ,alternative-name (new-value (class standard-class))
1947             (setf (slot-value class ',slot) new-value))
1948           ,@(unless (eq name alternative-name)
1949                     `((setf (get ',$name 'SETF-FUNCTION)
1950                             (symbol-function ',alternative-name))))
1951           )
1952        `(progn ;; getter
1953           (defgeneric ,alternative-name (class))
1954           (defmethod ,alternative-name ((class built-in-class))
1955             (,%name class))
1956           (defmethod ,alternative-name ((class forward-referenced-class))
1957             (,%name class))
1958           (defmethod ,alternative-name ((class structure-class))
1959             (,%name class))
1960           (defmethod ,alternative-name ((class standard-class))
1961             (slot-value class ',slot))
1962           ,@(unless (eq name alternative-name)
1963                     `((setf (symbol-function ',$name)
1964                             (symbol-function ',alternative-name))))
1965           ) )))
1966
1967(redefine-class-forwarder class-name name)
1968(redefine-class-forwarder (setf class-name) name)
1969(redefine-class-forwarder class-slots slots)
1970(redefine-class-forwarder (setf class-slots) slots)
1971(redefine-class-forwarder class-direct-slots direct-slots)
1972(redefine-class-forwarder (setf class-direct-slots) direct-slots)
1973(redefine-class-forwarder class-layout layout)
1974(redefine-class-forwarder (setf class-layout) layout)
1975(redefine-class-forwarder class-direct-superclasses direct-superclasses)
1976(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
1977(redefine-class-forwarder class-direct-subclasses direct-subclasses)
1978(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
1979(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
1980(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
1981(redefine-class-forwarder class-precedence-list precedence-list)
1982(redefine-class-forwarder (setf class-precedence-list) precedence-list)
1983(redefine-class-forwarder class-finalized-p finalized-p)
1984(redefine-class-forwarder (setf class-finalized-p) finalized-p)
1985(redefine-class-forwarder class-default-initargs default-initargs)
1986(redefine-class-forwarder (setf class-default-initargs) default-initargs)
1987(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
1988(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
1989
1990(defgeneric direct-slot-definition-class (class &rest initargs))
1991
1992(defmethod direct-slot-definition-class ((class class) &rest initargs)
1993  (declare (ignore initargs))
1994  +the-direct-slot-definition-class+)
1995
1996(defgeneric effective-slot-definition-class (class &rest initargs))
1997
1998(defmethod effective-slot-definition-class ((class class) &rest initargs)
1999  (declare (ignore initargs))
2000  +the-effective-slot-definition-class+)
2001
2002(fmakunbound 'documentation)
2003(defgeneric documentation (x doc-type))
2004
2005(defgeneric (setf documentation) (new-value x doc-type))
2006
2007(defmethod documentation ((x symbol) doc-type)
2008  (%documentation x doc-type))
2009
2010(defmethod (setf documentation) (new-value (x symbol) doc-type)
2011  (%set-documentation x doc-type new-value))
2012
2013(defmethod documentation ((x function) doc-type)
2014  (%documentation x doc-type))
2015
2016(defmethod (setf documentation) (new-value (x function) doc-type)
2017  (%set-documentation x doc-type new-value))
2018
2019;; FIXME This should be a weak hashtable!
2020(defvar *list-documentation-hashtable* (make-hash-table :test #'equal))
2021
2022(defmethod documentation ((x list) (doc-type (eql 'function)))
2023  (let ((alist (gethash x *list-documentation-hashtable*)))
2024    (and alist (cdr (assoc doc-type alist)))))
2025
2026(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
2027  (let ((alist (gethash x *list-documentation-hashtable*)))
2028    (and alist (cdr (assoc doc-type alist)))))
2029
2030(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
2031  (let* ((alist (gethash x *list-documentation-hashtable*))
2032         (entry (and alist (assoc doc-type alist))))
2033    (cond (entry
2034           (setf (cdr entry) new-value))
2035          (t
2036           (setf (gethash x *list-documentation-hashtable*)
2037                 (push (cons doc-type new-value) alist)))))
2038  new-value)
2039
2040(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
2041  (let* ((alist (gethash x *list-documentation-hashtable*))
2042         (entry (and alist (assoc doc-type alist))))
2043    (cond (entry
2044           (setf (cdr entry) new-value))
2045          (t
2046           (setf (gethash x *list-documentation-hashtable*)
2047                 (push (cons doc-type new-value) alist)))))
2048  new-value)
2049
2050(defmethod documentation ((x standard-class) (doc-type (eql 't)))
2051  (class-documentation x))
2052
2053(defmethod documentation ((x standard-class) (doc-type (eql 'type)))
2054  (class-documentation x))
2055
2056(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't)))
2057  (%set-class-documentation x new-value))
2058
2059(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type)))
2060  (%set-class-documentation x new-value))
2061
2062(defmethod documentation ((x structure-class) (doc-type (eql 't)))
2063  (%documentation x doc-type))
2064
2065(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
2066  (%documentation x doc-type))
2067
2068(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
2069  (%set-documentation x doc-type new-value))
2070
2071(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
2072  (%set-documentation x doc-type new-value))
2073
2074(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
2075  (generic-function-documentation x))
2076
2077(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
2078  (setf (generic-function-documentation x) new-value))
2079
2080(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
2081  (generic-function-documentation x))
2082
2083(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
2084  (setf (generic-function-documentation x) new-value))
2085
2086(defmethod documentation ((x standard-method) (doc-type (eql 't)))
2087  (method-documentation x))
2088
2089(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
2090  (setf (method-documentation x) new-value))
2091
2092(defmethod documentation ((x package) (doc-type (eql 't)))
2093  (%documentation x doc-type))
2094
2095(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
2096  (%set-documentation x doc-type new-value))
2097
2098;;; Applicable methods
2099
2100(defgeneric compute-applicable-methods (gf args)
2101  (:method ((gf standard-generic-function) args)
2102    (%compute-applicable-methods gf args)))
2103
2104(defgeneric compute-applicable-methods-using-classes (gf classes)
2105  (:method ((gf standard-generic-function) classes)
2106    (let ((methods '()))
2107      (dolist (method (generic-function-methods gf))
2108  (multiple-value-bind (applicable knownp)
2109      (method-applicable-using-classes-p method classes)
2110    (cond (applicable
2111     (push method methods))
2112    ((not knownp)
2113     (return-from compute-applicable-methods-using-classes
2114       (values nil nil))))))
2115      (values (sort-methods methods gf classes)
2116        t))))
2117
2118(export '(compute-applicable-methods
2119    compute-applicable-methods-using-classes))
2120
2121
2122;;; Slot access
2123
2124(defun set-slot-value-using-class (new-value class instance slot-name)
2125  (declare (ignore class)) ; FIXME
2126  (setf (std-slot-value instance slot-name) new-value))
2127
2128(defgeneric slot-value-using-class (class instance slot-name))
2129
2130(defmethod slot-value-using-class ((class standard-class) instance slot-name)
2131  (std-slot-value instance slot-name))
2132
2133(defmethod slot-value-using-class ((class structure-class) instance slot-name)
2134  (std-slot-value instance slot-name))
2135
2136(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
2137
2138(defmethod (setf slot-value-using-class) (new-value
2139                                          (class standard-class)
2140                                          instance
2141                                          slot-name)
2142  (setf (std-slot-value instance slot-name) new-value))
2143
2144(defmethod (setf slot-value-using-class) (new-value
2145                                          (class structure-class)
2146                                          instance
2147                                          slot-name)
2148  (setf (std-slot-value instance slot-name) new-value))
2149
2150(defgeneric slot-exists-p-using-class (class instance slot-name))
2151
2152(defmethod slot-exists-p-using-class (class instance slot-name)
2153  nil)
2154
2155(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
2156  (std-slot-exists-p instance slot-name))
2157
2158(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
2159  (dolist (dsd (class-slots class))
2160    (when (eq (sys::dsd-name dsd) slot-name)
2161      (return-from slot-exists-p-using-class t)))
2162  nil)
2163
2164(defgeneric slot-boundp-using-class (class instance slot-name))
2165(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
2166  (std-slot-boundp instance slot-name))
2167(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
2168  "Structure slots can't be unbound, so this method always returns T."
2169  (declare (ignore class instance slot-name))
2170  t)
2171
2172(defgeneric slot-makunbound-using-class (class instance slot-name))
2173(defmethod slot-makunbound-using-class ((class standard-class)
2174                                        instance
2175                                        slot-name)
2176  (std-slot-makunbound instance slot-name))
2177(defmethod slot-makunbound-using-class ((class structure-class)
2178                                        instance
2179                                        slot-name)
2180  (declare (ignore class instance slot-name))
2181  (error "Structure slots can't be unbound"))
2182
2183(defgeneric slot-missing (class instance slot-name operation &optional new-value))
2184
2185(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
2186  (declare (ignore new-value))
2187  (error "The slot ~S is missing from the class ~S." slot-name class))
2188
2189(defgeneric slot-unbound (class instance slot-name))
2190
2191(defmethod slot-unbound ((class t) instance slot-name)
2192  (error 'unbound-slot :instance instance :name slot-name))
2193
2194;;; Instance creation and initialization
2195
2196(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
2197
2198(defmethod allocate-instance ((class standard-class) &rest initargs)
2199  (declare (ignore initargs))
2200  (std-allocate-instance class))
2201
2202(defmethod allocate-instance ((class structure-class) &rest initargs)
2203  (declare (ignore initargs))
2204  (%make-structure (class-name class)
2205                   (make-list (length (class-slots class))
2206                              :initial-element +slot-unbound+)))
2207
2208;; "The set of valid initialization arguments for a class is the set of valid
2209;; initialization arguments that either fill slots or supply arguments to
2210;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
2211;; 7.1.2
2212
2213(defun check-initargs (instance shared-initialize-param initargs)
2214  (when (oddp (length initargs))
2215    (error 'program-error
2216           :format-control "Odd number of keyword arguments."))
2217  (unless (getf initargs :allow-other-keys)
2218    (let ((methods 
2219     (nconc 
2220      (compute-applicable-methods 
2221       #'shared-initialize
2222       (if initargs
2223     `(,instance ,shared-initialize-param ,@initargs)
2224         (list instance shared-initialize-param)))
2225      (compute-applicable-methods 
2226       #'initialize-instance
2227       (if initargs
2228     `(,instance ,@initargs)
2229         (list instance)))))
2230    (slots (class-slots (class-of instance))))
2231      (do* ((tail initargs (cddr tail))
2232            (initarg (car tail) (car tail)))
2233           ((null tail))
2234        (unless (or (valid-initarg-p initarg slots)
2235        (valid-methodarg-p initarg methods)
2236                    (eq initarg :allow-other-keys))
2237          (error 'program-error
2238                 :format-control "Invalid initarg ~S."
2239                 :format-arguments (list initarg)))))))
2240
2241(defun valid-methodarg-p (initarg methods)
2242  (when (symbolp initarg)
2243    (dolist (method methods nil)
2244      (let ((valid-initargs (method-lambda-list method)))
2245  (when (find (symbol-value initarg) valid-initargs 
2246         :test #'(lambda (a b)
2247             (if (listp b)
2248           (string= a (car b))
2249         (or
2250          (string= a b)
2251          (string= b "&ALLOW-OTHER-KEYS")))))
2252
2253    (return t))))))
2254
2255(defun valid-initarg-p (initarg slots)
2256  (dolist (slot slots nil)
2257    (let ((valid-initargs (slot-definition-initargs slot)))
2258      (when (memq initarg valid-initargs)
2259        (return t)))))
2260
2261(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
2262
2263(defmethod make-instance ((class standard-class) &rest initargs)
2264  (when (oddp (length initargs))
2265    (error 'program-error :format-control "Odd number of keyword arguments."))
2266  (unless (class-finalized-p class)
2267    (std-finalize-inheritance class))
2268  (let ((class-default-initargs (class-default-initargs class)))
2269    (when class-default-initargs
2270      (let ((default-initargs '()))
2271        (do* ((list class-default-initargs (cddr list))
2272              (key (car list) (car list))
2273              (fn (cadr list) (cadr list)))
2274             ((null list))
2275          (when (eq (getf initargs key 'not-found) 'not-found)
2276            (setf default-initargs (append default-initargs (list key (funcall fn))))))
2277        (setf initargs (append initargs default-initargs)))))
2278
2279  (let ((instance (std-allocate-instance class)))
2280    (check-initargs instance t initargs)
2281    (apply #'initialize-instance instance initargs)
2282    instance))
2283
2284(defmethod make-instance ((class symbol) &rest initargs)
2285  (apply #'make-instance (find-class class) initargs))
2286
2287(defgeneric initialize-instance (instance &key))
2288
2289(defmethod initialize-instance ((instance standard-object) &rest initargs)
2290  (apply #'shared-initialize instance t initargs))
2291
2292(defgeneric reinitialize-instance (instance &key))
2293
2294;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the
2295;; validity of initargs and signals an error if an initarg is supplied that is
2296;; not declared as valid. The method then calls the generic function SHARED-
2297;; INITIALIZE with the following arguments: the instance, nil (which means no
2298;; slots should be initialized according to their initforms), and the initargs
2299;; it received."
2300(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2301  (apply #'shared-initialize instance () initargs))
2302
2303(defun std-shared-initialize (instance slot-names all-keys)
2304  (when (oddp (length all-keys))
2305    (error 'program-error :format-control "Odd number of keyword arguments."))
2306  (do* ((tail all-keys (cddr tail))
2307  (initarg (car tail) (car tail)))
2308      ((null tail))
2309    (when (and initarg (not (symbolp initarg)))
2310      (error 'program-error
2311       :format-control "Invalid initarg ~S."
2312       :format-arguments (list initarg))))
2313  (dolist (slot (class-slots (class-of instance)))
2314    (let ((slot-name (slot-definition-name slot)))
2315      (multiple-value-bind (init-key init-value foundp)
2316          (get-properties all-keys (slot-definition-initargs slot))
2317        (if foundp
2318            (setf (std-slot-value instance slot-name) init-value)
2319            (unless (std-slot-boundp instance slot-name)
2320              (let ((initfunction (slot-definition-initfunction slot)))
2321                (when (and initfunction (or (eq slot-names t)
2322                                            (memq slot-name slot-names)))
2323                  (setf (std-slot-value instance slot-name)
2324                        (funcall initfunction)))))))))
2325  instance)
2326
2327(defgeneric shared-initialize (instance slot-names &key))
2328
2329(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
2330  (std-shared-initialize instance slot-names initargs))
2331
2332(defmethod shared-initialize ((slot slot-definition) slot-names
2333            &rest args
2334            &key name initargs initform initfunction
2335            readers writers allocation
2336            &allow-other-keys)
2337  ;;Keyword args are duplicated from init-slot-definition only to have
2338  ;;them checked.
2339  (declare (ignore slot-names)) ;;TODO?
2340  (declare (ignore name initargs initform initfunction readers writers allocation))
2341  ;;For built-in slots
2342  (apply #'init-slot-definition slot args)
2343  ;;For user-defined slots
2344  (call-next-method))
2345
2346;;; change-class
2347
2348(defgeneric change-class (instance new-class &key))
2349
2350(defmethod change-class ((old-instance standard-object) (new-class standard-class)
2351                         &rest initargs)
2352  (let ((old-slots (class-slots (class-of old-instance)))
2353        (new-slots (class-slots new-class))
2354        (new-instance (allocate-instance new-class)))
2355    ;; "The values of local slots specified by both the class CTO and the class
2356    ;; CFROM are retained. If such a local slot was unbound, it remains
2357    ;; unbound."
2358    (dolist (new-slot new-slots)
2359      (when (instance-slot-p new-slot)
2360        (let* ((slot-name (slot-definition-name new-slot))
2361               (old-slot (find slot-name old-slots :key 'slot-definition-name)))
2362          ;; "The values of slots specified as shared in the class CFROM and as
2363          ;; local in the class CTO are retained."
2364          (when (and old-slot (slot-boundp old-instance slot-name))
2365            (setf (slot-value new-instance slot-name)
2366                  (slot-value old-instance slot-name))))))
2367    (swap-slots old-instance new-instance)
2368    (rotatef (std-instance-layout new-instance)
2369             (std-instance-layout old-instance))
2370    (apply #'update-instance-for-different-class
2371           new-instance old-instance initargs)
2372    old-instance))
2373
2374(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
2375  (apply #'change-class instance (find-class new-class) initargs))
2376
2377(defgeneric update-instance-for-different-class (old new &key))
2378
2379(defmethod update-instance-for-different-class
2380  ((old standard-object) (new standard-object) &rest initargs)
2381  (let ((added-slots
2382         (remove-if #'(lambda (slot-name)
2383                       (slot-exists-p old slot-name))
2384                    (mapcar 'slot-definition-name
2385                            (class-slots (class-of new))))))
2386    (check-initargs new added-slots initargs)
2387    (apply #'shared-initialize new added-slots initargs)))
2388
2389;;; make-instances-obsolete
2390
2391(defgeneric make-instances-obsolete (class))
2392
2393(defmethod make-instances-obsolete ((class standard-class))
2394  (%make-instances-obsolete class))
2395
2396(defmethod make-instances-obsolete ((class symbol))
2397  (make-instances-obsolete (find-class class))
2398  class)
2399
2400;;; update-instance-for-redefined-class
2401
2402(defgeneric update-instance-for-redefined-class (instance
2403                                                 added-slots
2404                                                 discarded-slots
2405                                                 property-list
2406                                                 &rest initargs
2407                                                 &key
2408                                                 &allow-other-keys))
2409
2410(defmethod update-instance-for-redefined-class ((instance standard-object)
2411            added-slots
2412            discarded-slots
2413            property-list
2414            &rest initargs)
2415  (check-initargs instance added-slots initargs)
2416  (apply #'shared-initialize instance added-slots initargs))
2417
2418;;;  Methods having to do with class metaobjects.
2419
2420(defmethod initialize-instance :after ((class standard-class) &rest args)
2421  (apply #'std-after-initialization-for-classes class args))
2422
2423;;; Finalize inheritance
2424
2425(defgeneric finalize-inheritance (class))
2426
2427(defmethod finalize-inheritance ((class standard-class))
2428  (std-finalize-inheritance class))
2429
2430;;; Class precedence lists
2431
2432(defgeneric compute-class-precedence-list (class))
2433(defmethod compute-class-precedence-list ((class standard-class))
2434  (std-compute-class-precedence-list class))
2435
2436;;; Slot inheritance
2437
2438(defgeneric compute-slots (class))
2439(defmethod compute-slots ((class standard-class))
2440  (std-compute-slots class))
2441
2442(defgeneric compute-effective-slot-definition (class direct-slots))
2443(defmethod compute-effective-slot-definition
2444  ((class standard-class) direct-slots)
2445  (std-compute-effective-slot-definition class direct-slots))
2446
2447;;; Methods having to do with generic function metaobjects.
2448
2449(defmethod initialize-instance :after ((gf standard-generic-function) &key)
2450  (finalize-generic-function gf))
2451
2452;;; Methods having to do with generic function invocation.
2453
2454(defgeneric compute-discriminating-function (gf))
2455(defmethod compute-discriminating-function ((gf standard-generic-function))
2456  (std-compute-discriminating-function gf))
2457
2458(defgeneric method-more-specific-p (gf method1 method2 required-classes))
2459
2460(defmethod method-more-specific-p ((gf standard-generic-function)
2461                                   method1 method2 required-classes)
2462  (std-method-more-specific-p method1 method2 required-classes
2463                              (generic-function-argument-precedence-order gf)))
2464
2465(defgeneric compute-effective-method-function (gf methods))
2466(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
2467  (std-compute-effective-method-function gf methods))
2468
2469(defgeneric compute-applicable-methods (gf args))
2470(defmethod compute-applicable-methods ((gf standard-generic-function) args)
2471  (%compute-applicable-methods gf args))
2472
2473;;; Slot definition accessors
2474
2475(map nil (lambda (sym)
2476     (fmakunbound sym) ;;we need to redefine them as GFs
2477     (fmakunbound `(setf ,sym))
2478     (export sym))
2479  '(slot-definition-allocation 
2480    slot-definition-initargs
2481    slot-definition-initform
2482    slot-definition-initfunction
2483    slot-definition-name
2484    slot-definition-readers
2485    slot-definition-writers
2486    slot-definition-allocation-class))
2487
2488(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
2489  `(let (($cl (class-of ,slot-definition)))
2490     (case $cl
2491       ((+the-slot-definition-class+
2492   +the-direct-slot-definition-class+
2493   +the-effective-slot-definition-class+)
2494  ,std-form)
2495       (t ,generic-form))))
2496
2497(defgeneric slot-definition-allocation (slot-definition)
2498  (:method ((slot-definition slot-definition))
2499    (slot-definition-dispatch slot-definition
2500      (%slot-definition-allocation slot-definition)
2501      (slot-value slot-definition 'sys::allocation))))
2502
2503(defgeneric (setf slot-definition-allocation) (value slot-definition)
2504  (:method (value (slot-definition slot-definition))
2505    (slot-definition-dispatch slot-definition
2506      (set-slot-definition-allocation slot-definition value)
2507      (setf (slot-value slot-definition 'sys::allocation) value))))
2508
2509(defgeneric slot-definition-initargs (slot-definition)
2510  (:method ((slot-definition slot-definition))
2511    (slot-definition-dispatch slot-definition
2512      (%slot-definition-initargs slot-definition)
2513      (slot-value slot-definition 'sys::initargs))))
2514
2515(defgeneric (setf slot-definition-initargs) (value slot-definition)
2516  (:method (value (slot-definition slot-definition))
2517    (slot-definition-dispatch slot-definition
2518      (set-slot-definition-initargs slot-definition value)
2519      (setf (slot-value slot-definition 'sys::initargs) value))))
2520
2521(defgeneric slot-definition-initform (slot-definition)
2522  (:method ((slot-definition slot-definition))
2523    (slot-definition-dispatch slot-definition
2524      (%slot-definition-initform slot-definition)
2525      (slot-value slot-definition 'sys::initform))))
2526
2527(defgeneric (setf slot-definition-initform) (value slot-definition)
2528  (:method (value (slot-definition slot-definition))
2529    (slot-definition-dispatch slot-definition
2530      (set-slot-definition-initform slot-definition value)
2531      (setf (slot-value slot-definition 'sys::initform) value))))
2532
2533(defgeneric slot-definition-initfunction (slot-definition)
2534  (:method ((slot-definition slot-definition))
2535    (slot-definition-dispatch slot-definition
2536      (%slot-definition-initfunction slot-definition)
2537      (slot-value slot-definition 'sys::initfunction))))
2538
2539(defgeneric (setf slot-definition-initfunction) (value slot-definition)
2540  (:method (value (slot-definition slot-definition))
2541    (slot-definition-dispatch slot-definition
2542      (set-slot-definition-initfunction slot-definition value)
2543      (setf (slot-value slot-definition 'sys::initfunction) value))))
2544
2545(defgeneric slot-definition-name (slot-definition)
2546  (:method ((slot-definition slot-definition))
2547    (slot-definition-dispatch slot-definition
2548      (%slot-definition-name slot-definition)
2549      (slot-value slot-definition 'sys::name))))
2550
2551(defgeneric (setf slot-definition-name) (value slot-definition)
2552  (:method (value (slot-definition slot-definition))
2553    (slot-definition-dispatch slot-definition
2554      (set-slot-definition-name slot-definition value)
2555      (setf (slot-value slot-definition 'sys::name) value))))
2556
2557(defgeneric slot-definition-readers (slot-definition)
2558  (:method ((slot-definition slot-definition))
2559    (slot-definition-dispatch slot-definition
2560      (%slot-definition-readers slot-definition)
2561      (slot-value slot-definition 'sys::readers))))
2562
2563(defgeneric (setf slot-definition-readers) (value slot-definition)
2564  (:method (value (slot-definition slot-definition))
2565    (slot-definition-dispatch slot-definition
2566      (set-slot-definition-readers slot-definition value)
2567      (setf (slot-value slot-definition 'sys::readers) value))))
2568
2569(defgeneric slot-definition-writers (slot-definition)
2570  (:method ((slot-definition slot-definition))
2571    (slot-definition-dispatch slot-definition
2572      (%slot-definition-writers slot-definition)
2573      (slot-value slot-definition 'sys::writers))))
2574
2575(defgeneric (setf slot-definition-writers) (value slot-definition)
2576  (:method (value (slot-definition slot-definition))
2577    (slot-definition-dispatch slot-definition
2578      (set-slot-definition-writers slot-definition value)
2579      (setf (slot-value slot-definition 'sys::writers) value))))
2580
2581(defgeneric slot-definition-allocation-class (slot-definition)
2582  (:method ((slot-definition slot-definition))
2583    (slot-definition-dispatch slot-definition
2584      (%slot-definition-allocation-class slot-definition)
2585      (slot-value slot-definition 'sys::allocation-class))))
2586
2587(defgeneric (setf slot-definition-allocation-class) (value slot-definition)
2588  (:method (value (slot-definition slot-definition))
2589    (slot-definition-dispatch slot-definition
2590      (set-slot-definition-allocation-class slot-definition value)
2591      (setf (slot-value slot-definition 'sys::allocation-class) value))))
2592
2593(defgeneric slot-definition-location (slot-definition)
2594  (:method ((slot-definition slot-definition))
2595    (slot-definition-dispatch slot-definition
2596      (%slot-definition-location slot-definition)
2597      (slot-value slot-definition 'sys::location))))
2598
2599(defgeneric (setf slot-definition-location) (value slot-definition)
2600  (:method (value (slot-definition slot-definition))
2601    (slot-definition-dispatch slot-definition
2602      (set-slot-definition-location slot-definition value)
2603      (setf (slot-value slot-definition 'sys::location) value))))
2604
2605;;; No %slot-definition-type.
2606
2607
2608;;; Conditions.
2609
2610(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
2611  (let ((parent-types (or parent-types '(condition)))
2612        (report nil))
2613    (dolist (option options)
2614      (when (eq (car option) :report)
2615        (setf report (cadr option))
2616  (setf options (delete option options :test #'equal))
2617        (return)))
2618    (typecase report
2619      (null
2620       `(progn
2621          (defclass ,name ,parent-types ,slot-specs ,@options)
2622          ',name))
2623      (string
2624       `(progn
2625          (defclass ,name ,parent-types ,slot-specs ,@options)
2626          (defmethod print-object ((condition ,name) stream)
2627            (if *print-escape*
2628                (call-next-method)
2629                (progn (write-string ,report stream) condition)))
2630          ',name))
2631      (t
2632       `(progn
2633          (defclass ,name ,parent-types ,slot-specs ,@options)
2634          (defmethod print-object ((condition ,name) stream)
2635            (if *print-escape*
2636                (call-next-method)
2637                (funcall #',report condition stream)))
2638          ',name)))))
2639
2640(defun make-condition (type &rest initargs)
2641  (or (%make-condition type initargs)
2642      (let ((class (if (symbolp type) (find-class type) type)))
2643        (apply #'make-instance class initargs))))
2644
2645;; Adapted from SBCL.
2646;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
2647(defun coerce-to-condition (datum arguments default-type fun-name)
2648  (cond ((typep datum 'condition)
2649         (when arguments
2650           (error 'simple-type-error
2651                  :datum arguments
2652                  :expected-type 'null
2653                  :format-control "You may not supply additional arguments when giving ~S to ~S."
2654                  :format-arguments (list datum fun-name)))
2655         datum)
2656        ((symbolp datum)
2657         (apply #'make-condition datum arguments))
2658        ((or (stringp datum) (functionp datum))
2659         (make-condition default-type
2660                         :format-control datum
2661                         :format-arguments arguments))
2662        (t
2663         (error 'simple-type-error
2664                :datum datum
2665                :expected-type '(or symbol string)
2666                :format-control "Bad argument to ~S: ~S."
2667                :format-arguments (list fun-name datum)))))
2668
2669(defgeneric make-load-form (object &optional environment))
2670
2671(defmethod make-load-form ((object t) &optional environment)
2672  (declare (ignore environment))
2673  (apply #'no-applicable-method #'make-load-form (list object)))
2674
2675(defmethod make-load-form ((class class) &optional environment)
2676  (declare (ignore environment))
2677  (let ((name (class-name class)))
2678    (unless (and name (eq (find-class name nil) class))
2679      (error 'simple-type-error
2680             :format-control "Can't use anonymous or undefined class as a constant: ~S."
2681             :format-arguments (list class)))
2682    `(find-class ',name)))
2683
2684(defun invalid-method-error (method format-control &rest args)
2685  (let ((message (apply #'format nil format-control args)))
2686    (error "Invalid method error for ~S:~%    ~A" method message)))
2687
2688(defun method-combination-error (format-control &rest args)
2689  (let ((message (apply #'format nil format-control args)))
2690    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
2691
2692(fmakunbound 'no-applicable-method)
2693(defgeneric no-applicable-method (generic-function &rest args))
2694
2695(defmethod no-applicable-method (generic-function &rest args)
2696  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
2697         generic-function
2698         args))
2699
2700(defgeneric find-method (generic-function
2701                         qualifiers
2702                         specializers
2703                         &optional errorp))
2704
2705(defmethod find-method ((generic-function standard-generic-function)
2706      qualifiers specializers &optional (errorp t))
2707  (%find-method generic-function qualifiers specializers errorp))
2708
2709(defgeneric add-method (generic-function method))
2710
2711(defmethod add-method ((generic-function standard-generic-function) (method method))
2712  (let ((method-lambda-list (method-lambda-list method))
2713        (gf-lambda-list (generic-function-lambda-list generic-function)))
2714    (check-method-lambda-list method-lambda-list gf-lambda-list))
2715  (%add-method generic-function method))
2716
2717(defgeneric remove-method (generic-function method))
2718
2719(defmethod remove-method ((generic-function standard-generic-function) method)
2720  (%remove-method generic-function method))
2721
2722;; See describe.lisp.
2723(defgeneric describe-object (object stream))
2724
2725;; FIXME
2726(defgeneric no-next-method (generic-function method &rest args))
2727
2728;; FIXME
2729(defgeneric function-keywords (method))
2730
2731(setf *clos-booting* nil)
2732
2733(defgeneric class-prototype (class))
2734
2735(defmethod class-prototype :before (class)
2736  (unless (class-finalized-p class)
2737    (error "~@<~S is not finalized.~:@>" class)))
2738
2739(defmethod class-prototype ((class standard-class))
2740  (allocate-instance class))
2741
2742(defmethod class-prototype ((class structure-class))
2743  (allocate-instance class))
2744
2745(provide 'clos)
Note: See TracBrowser for help on using the repository browser.