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

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

Progress towards custom slot definition support: use of generic slot-definition-*

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