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

Last change on this file since 12067 was 12067, checked in by vvoutilainen, 14 years ago

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