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

Last change on this file since 8391 was 8391, checked in by asimon, 17 years ago

Hack for printing conditions.

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