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

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

Progress towards support for custom slot definitions: use of generic (setf slot-definition-*), bugfixes

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