source: trunk/j/src/org/armedbear/lisp/clos.lisp @ 9266

Last change on this file since 9266 was 9236, checked in by piso, 16 years ago

Work in progress (tested).

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