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

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

Selected built-in classes can now be subclassed. Only SEQUENCE is allowed as of this revision.
This makes sequences user-extensible again.

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