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

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

Support for user-extensible sequences, adapted from SBCL.

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