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

Last change on this file since 11306 was 11306, checked in by ehuelsmann, 14 years ago

Revert c11291 which breaks certain uses of ASDF.

Found by: Mark Evenson (evenson at panix.com)

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