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

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

Merged the scripting branch, providing JSR-223 support and other new
features. JSR-233 is only built if the necessary javax.script.* classes
are found in the CLASSPATH.

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