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

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

Fixed regression: correctly set slot-allocation-class for effective slot definitions.

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