source: branches/0.22.x/abcl/src/org/armedbear/lisp/clos.lisp

Last change on this file was 12805, checked in by astalla, 15 years ago

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