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

Last change on this file since 8430 was 8430, checked in by piso, 17 years ago

FINALIZE-GENERIC-FUNCTION: bind *WARN-ON-REDEFINITION* to NIL.

File size: 79.2 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: clos.lisp,v 1.135 2005-01-31 17:27:18 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from Closette.
21
22;;; Closette Version 1.0 (February 10, 1991)
23;;;
24;;; Copyright (c) 1990, 1991 Xerox Corporation.
25;;; All rights reserved.
26;;;
27;;; Use and copying of this software and preparation of derivative works
28;;; based upon this software are permitted.  Any distribution of this
29;;; software or derivative works must comply with all applicable United
30;;; States export control laws.
31;;;
32;;; This software is made available AS IS, and Xerox Corporation makes no
33;;; warranty about the software, its performance or its conformity to any
34;;; specification.
35;;;
36;;; Closette is an implementation of a subset of CLOS with a metaobject
37;;; protocol as described in "The Art of The Metaobject Protocol",
38;;; MIT Press, 1991.
39
40(in-package #: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  ;; FIXME Do we need to warn on redefinition somewhere else?
906  (let ((*warn-on-redefinition* nil))
907    (setf (fdefinition (generic-function-name gf)) gf))
908  (clrhash (classes-to-emf-table gf))
909  (values))
910
911(defun make-instance-standard-generic-function (generic-function-class
912                                                &key name lambda-list
913                                                method-class
914                                                method-combination
915                                                argument-precedence-order
916                                                documentation)
917  (declare (ignore generic-function-class))
918  (let ((gf (std-allocate-instance the-class-standard-gf)))
919    (setf (generic-function-name gf) name)
920    (setf (generic-function-lambda-list gf) lambda-list)
921    (setf (generic-function-initial-methods gf) ())
922    (setf (generic-function-methods gf) ())
923    (setf (generic-function-method-class gf) method-class)
924    (setf (generic-function-method-combination gf) method-combination)
925    (setf (generic-function-documentation gf) documentation)
926    (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
927    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
928           (required-args (getf plist ':required-args)))
929      (%set-gf-required-args gf required-args)
930      (setf (slot-value gf 'argument-precedence-order)
931            (if argument-precedence-order
932                (canonicalize-argument-precedence-order argument-precedence-order
933                                                        required-args)
934                nil)))
935    (finalize-generic-function gf)
936    gf))
937
938(defmacro defmethod (&rest args &environment env)
939  (when (and env (empty-environment-p env))
940    (setf env nil))
941  (multiple-value-bind
942    (function-name qualifiers lambda-list specializers documentation declarations body)
943    (parse-defmethod args)
944    (let ((specializers-form ()))
945      (dolist (specializer specializers)
946        (cond ((and (consp specializer) (eq (car specializer) 'eql))
947               (push `(list 'eql ,(cadr specializer)) specializers-form))
948              (t
949               (push `',specializer specializers-form))))
950      (setf specializers-form `(list ,@(nreverse specializers-form)))
951      `(progn
952         (unless (find-generic-function ',function-name nil)
953           (ensure-generic-function
954            ',function-name
955            :lambda-list ',lambda-list))
956         (ensure-method (find-generic-function ',function-name)
957                        :lambda-list ',lambda-list
958                        :qualifiers ',qualifiers
959                        :specializers ,specializers-form
960                        :documentation ,documentation
961                        :declarations ',declarations
962                        :body ',body
963                        :environment ,env)))))
964
965(defun canonicalize-specializers (specializers)
966  (mapcar #'canonicalize-specializer specializers))
967
968(defun canonicalize-specializer (specializer)
969  (cond ((classp specializer)
970         specializer)
971        ((eql-specializer-p specializer)
972         specializer)
973        ((symbolp specializer)
974         (find-class specializer))
975        ((and (consp specializer)
976              (eq (car specializer) 'eql))
977         (let ((object (cadr specializer)))
978           (when (and (consp object)
979                      (eq (car object) 'quote))
980             (setf object (cadr object)))
981           (intern-eql-specializer object)))
982        (t
983         (error "Unknown specializer: ~S" specializer))))
984
985(defun parse-defmethod (args)
986  (let ((function-name (car args))
987        (qualifiers ())
988        (specialized-lambda-list ())
989        (body ())
990        (parse-state :qualifiers))
991    (dolist (arg (cdr args))
992      (ecase parse-state
993        (:qualifiers
994         (if (and (atom arg) (not (null arg)))
995             (push-on-end arg qualifiers)
996             (progn
997               (setf specialized-lambda-list arg)
998               (setf parse-state :body))))
999        (:body (push-on-end arg body))))
1000    (multiple-value-bind (real-body declarations documentation)
1001      (parse-body body)
1002        (values function-name
1003                qualifiers
1004                (extract-lambda-list specialized-lambda-list)
1005                (extract-specializers specialized-lambda-list)
1006                documentation
1007                declarations
1008                (list* 'block
1009                         (if (consp function-name)
1010                             (cadr function-name)
1011                             function-name)
1012                         real-body)))))
1013
1014(defun required-portion (gf args)
1015  (let ((number-required (length (gf-required-args gf))))
1016    (when (< (length args) number-required)
1017      (error 'program-error
1018             :format-control "Not enough arguments for generic function ~S."
1019             :format-arguments (list (generic-function-name gf))))
1020    (subseq args 0 number-required)))
1021
1022(defun extract-lambda-list (specialized-lambda-list)
1023  (let* ((plist (analyze-lambda-list specialized-lambda-list))
1024         (requireds (getf plist :required-names))
1025         (rv (getf plist :rest-var))
1026         (ks (getf plist :key-args))
1027         (keysp (getf plist :keysp))
1028         (aok (getf plist :allow-other-keys))
1029         (opts (getf plist :optional-args))
1030         (auxs (getf plist :auxiliary-args)))
1031    `(,@requireds
1032      ,@(if rv `(&rest ,rv) ())
1033      ,@(if (or ks keysp aok) `(&key ,@ks) ())
1034      ,@(if aok '(&allow-other-keys) ())
1035      ,@(if opts `(&optional ,@opts) ())
1036      ,@(if auxs `(&aux ,@auxs) ()))))
1037
1038(defun extract-specializers (specialized-lambda-list)
1039  (let ((plist (analyze-lambda-list specialized-lambda-list)))
1040    (getf plist ':specializers)))
1041
1042(defun get-keyword-from-arg (arg)
1043  (if (listp arg)
1044      (if (listp (car arg))
1045          (caar arg)
1046          (make-keyword (car arg)))
1047      (make-keyword arg)))
1048
1049(defun analyze-lambda-list (lambda-list)
1050  (let ((keys ())           ; Just the keywords
1051        (key-args ())       ; Keywords argument specs
1052        (keysp nil)         ;
1053        (required-names ()) ; Just the variable names
1054        (required-args ())  ; Variable names & specializers
1055        (specializers ())   ; Just the specializers
1056        (rest-var nil)
1057        (optionals ())
1058        (auxs ())
1059        (allow-other-keys nil)
1060        (state :parsing-required))
1061    (dolist (arg lambda-list)
1062      (if (member arg lambda-list-keywords)
1063          (ecase arg
1064            (&optional
1065             (setq state :parsing-optional))
1066            (&rest
1067             (setq state :parsing-rest))
1068            (&key
1069             (setq keysp t)
1070             (setq state :parsing-key))
1071            (&allow-other-keys
1072             (setq allow-other-keys 't))
1073            (&aux
1074             (setq state :parsing-aux)))
1075          (case state
1076            (:parsing-required
1077             (push-on-end arg required-args)
1078             (if (listp arg)
1079                 (progn (push-on-end (car arg) required-names)
1080                   (push-on-end (cadr arg) specializers))
1081                 (progn (push-on-end arg required-names)
1082                   (push-on-end 't specializers))))
1083            (:parsing-optional (push-on-end arg optionals))
1084            (:parsing-rest (setq rest-var arg))
1085            (:parsing-key
1086             (push-on-end (get-keyword-from-arg arg) keys)
1087             (push-on-end arg key-args))
1088            (:parsing-aux (push-on-end arg auxs)))))
1089    (list  :required-names required-names
1090           :required-args required-args
1091           :specializers specializers
1092           :rest-var rest-var
1093           :keywords keys
1094           :key-args key-args
1095           :keysp keysp
1096           :auxiliary-args auxs
1097           :optional-args optionals
1098           :allow-other-keys allow-other-keys)))
1099
1100#+nil
1101(defun check-method-arg-info (gf arg-info method)
1102  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1103    (analyze-lambda-list (if (consp method)
1104                             (early-method-lambda-list method)
1105                             (method-lambda-list method)))
1106    (flet ((lose (string &rest args)
1107                 (error 'simple-program-error
1108                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
1109                        to the generic function~2I~_~S;~I~_~
1110                        but ~?~:>"
1111                        :format-arguments (list method gf string args)))
1112           (comparison-description (x y)
1113                                   (if (> x y) "more" "fewer")))
1114      (let ((gf-nreq (arg-info-number-required arg-info))
1115            (gf-nopt (arg-info-number-optional arg-info))
1116            (gf-key/rest-p (arg-info-key/rest-p arg-info))
1117            (gf-keywords (arg-info-keys arg-info)))
1118        (unless (= nreq gf-nreq)
1119          (lose
1120           "the method has ~A required arguments than the generic function."
1121           (comparison-description nreq gf-nreq)))
1122        (unless (= nopt gf-nopt)
1123          (lose
1124           "the method has ~A optional arguments than the generic function."
1125           (comparison-description nopt gf-nopt)))
1126        (unless (eq (or keysp restp) gf-key/rest-p)
1127          (lose
1128           "the method and generic function differ in whether they accept~_~
1129            &REST or &KEY arguments."))
1130        (when (consp gf-keywords)
1131          (unless (or (and restp (not keysp))
1132                      allow-other-keys-p
1133                      (every (lambda (k) (memq k keywords)) gf-keywords))
1134            (lose "the method does not accept each of the &KEY arguments~2I~_~
1135            ~S."
1136                  gf-keywords)))))))
1137
1138(defun check-method-lambda-list (method-lambda-list gf-lambda-list)
1139  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
1140         (gf-plist (analyze-lambda-list gf-lambda-list))
1141         (gf-keysp (getf gf-plist :keysp))
1142         (gf-keywords (getf gf-plist :keywords))
1143         (method-plist (analyze-lambda-list method-lambda-list))
1144         (method-restp (not (null (memq '&rest method-lambda-list))))
1145         (method-keysp (getf method-plist :keysp))
1146         (method-keywords (getf method-plist :keywords))
1147         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1148    (unless (= (length (getf gf-plist :required-args))
1149               (length (getf method-plist :required-args)))
1150      (error "The method has the wrong number of required arguments for the generic function."))
1151    (unless (= (length (getf gf-plist :optional-args))
1152               (length (getf method-plist :optional-args)))
1153      (error "The method has the wrong number of optional arguments for the generic function."))
1154    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1155      (error "The method and the generic function differ in whether they accept &REST or &KEY arguments."))
1156    (when (consp gf-keywords)
1157      (unless (or (and method-restp (not method-keysp))
1158                  method-allow-other-keys-p
1159                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
1160        (error "The method does not accept all of the keyword arguments defined for the generic function.")))))
1161
1162(defun ensure-method (gf &rest all-keys)
1163  (let ((method-lambda-list (getf all-keys :lambda-list))
1164        (gf-lambda-list (generic-function-lambda-list gf)))
1165    (check-method-lambda-list method-lambda-list gf-lambda-list))
1166  (let ((method
1167         (if (eq (generic-function-method-class gf) the-class-standard-method)
1168             (apply #'make-instance-standard-method gf all-keys)
1169             (apply #'make-instance (generic-function-method-class gf) all-keys))))
1170    (%add-method gf method)
1171    method))
1172
1173(defun make-instance-standard-method (gf
1174                                      &key
1175                                      lambda-list qualifiers specializers
1176                                      documentation declarations body
1177                                      environment)
1178  (let ((method (std-allocate-instance the-class-standard-method)))
1179    (setf (method-lambda-list method) lambda-list)
1180    (setf (method-qualifiers method) qualifiers)
1181    (setf (method-specializers method) (canonicalize-specializers specializers))
1182    (setf (method-documentation method) documentation)
1183    (setf (method-declarations method) declarations)
1184    (setf (method-body method) (precompile-form body nil))
1185    (setf (method-environment method) environment)
1186    (setf (method-generic-function method) nil)
1187    (setf (method-function method) (std-compute-method-function method gf))
1188    method))
1189
1190(defun add-method (gf method)
1191  (let ((method-lambda-list (method-lambda-list method))
1192        (gf-lambda-list (generic-function-lambda-list gf)))
1193    (check-method-lambda-list method-lambda-list gf-lambda-list))
1194  (%add-method gf method))
1195
1196(defun %add-method (gf method)
1197  (when (method-generic-function method)
1198    (error 'simple-error
1199           :format-control "ADD-METHOD: ~S is a method of ~S."
1200           :format-arguments (list method (method-generic-function method))))
1201  ;; Remove existing method with same qualifiers and specializers (if any).
1202  (let ((old-method (find-method gf (method-qualifiers method)
1203                                 (method-specializers method) nil)))
1204    (when old-method
1205      (remove-method gf old-method)))
1206  (setf (method-generic-function method) gf)
1207  (push method (generic-function-methods gf))
1208  (dolist (specializer (method-specializers method))
1209    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1210      (pushnew method (class-direct-methods specializer))))
1211  (finalize-generic-function gf)
1212  gf)
1213
1214(defun remove-method (gf method)
1215  (setf (generic-function-methods gf)
1216        (remove method (generic-function-methods gf)))
1217  (setf (method-generic-function method) nil)
1218  (dolist (specializer (method-specializers method))
1219    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1220      (setf (class-direct-methods specializer)
1221            (remove method (class-direct-methods specializer)))))
1222  (finalize-generic-function gf)
1223  gf)
1224
1225(defun find-method (gf qualifiers specializers &optional (errorp t))
1226  ;; "If the specializers argument does not correspond in length to the number
1227  ;; of required arguments of the generic-function, an an error of type ERROR
1228  ;; is signaled."
1229  (unless (= (length specializers) (length (gf-required-args gf)))
1230    (error "FIND-METHOD: the specializers argument has length ~S, but ~S has ~S required parameters."
1231           (length specializers)
1232           gf
1233           (length (gf-required-args gf))))
1234  (let* ((canonical-specializers (canonicalize-specializers specializers))
1235         (method
1236          (find-if #'(lambda (method)
1237                      (and (equal qualifiers
1238                                  (method-qualifiers method))
1239                           (equal canonical-specializers
1240                                  (method-specializers method))))
1241                   (generic-function-methods gf))))
1242    (if (and (null method) errorp)
1243        (error "No such method for ~S." (generic-function-name gf))
1244        method)))
1245
1246;;; Reader and writer methods
1247
1248(defun add-reader-method (class fn-name slot-name)
1249  (ensure-method
1250   (ensure-generic-function fn-name :lambda-list '(object))
1251   :lambda-list '(object)
1252   :qualifiers ()
1253   :specializers (list class)
1254   :body `(slot-value object ',slot-name)
1255   :environment nil)
1256  (values))
1257
1258(defun add-writer-method (class fn-name slot-name)
1259  (ensure-method
1260   (ensure-generic-function
1261    fn-name :lambda-list '(new-value object))
1262   :lambda-list '(new-value object)
1263   :qualifiers ()
1264   :specializers (list (find-class 't) class)
1265   :body `(setf (slot-value object ',slot-name)
1266                new-value)
1267   :environment nil)
1268  (values))
1269
1270(defun subclassp (c1 c2)
1271  (not (null (find c2 (class-precedence-list c1)))))
1272
1273(defun methods-contain-eql-specializer-p (methods)
1274  (dolist (method methods nil)
1275    (when (dolist (spec (method-specializers method) nil)
1276            (when (eql-specializer-p spec) (return t)))
1277      (return t))))
1278
1279(defun std-compute-discriminating-function (gf)
1280  (let ((code
1281         (if (methods-contain-eql-specializer-p (generic-function-methods gf))
1282             (make-closure `(lambda (&rest args)
1283                              (slow-method-lookup ,gf args nil))
1284                           nil)
1285             (let ((emf-table (classes-to-emf-table gf))
1286                   (number-required (length (gf-required-args gf))))
1287               (make-closure
1288                (cond ((= number-required 1)
1289                       `(lambda (&rest args)
1290                          (when (null args)
1291                            (error 'program-error
1292                                   :format-control "Not enough arguments for generic function ~S."
1293                                   :format-arguments (list (generic-function-name ,gf))))
1294                          (let* ((classes (list (class-of (car args))))
1295                                 (emfun (gethash classes ,emf-table)))
1296                            (if emfun
1297                                (funcall emfun args)
1298                                (slow-method-lookup ,gf args classes)))))
1299                      (t
1300                       `(lambda (&rest args)
1301                          (when (< (length args) ,number-required)
1302                            (error 'program-error
1303                                   :format-control "Not enough arguments for generic function ~S."
1304                                   :format-arguments (list (generic-function-name ,gf))))
1305                          (let ((classes ())
1306                                (i 0)
1307                                emfun)
1308                            (dolist (arg args)
1309                              (push (class-of arg) classes)
1310                              (when (= (incf i) ,number-required)
1311                                (return)))
1312                            (setf classes (nreverse classes))
1313                            (setf emfun (gethash classes ,emf-table))
1314                            (if emfun
1315                                (funcall emfun args)
1316                                (slow-method-lookup ,gf args classes))))))
1317                nil)))))
1318
1319    (when (and (fboundp 'compile)
1320               (not (autoloadp 'compile)))
1321      (setf code (or (compile nil code) code)))
1322
1323    code))
1324
1325(defun method-applicable-p (method args)
1326  (do* ((specializers (method-specializers method) (cdr specializers))
1327        (args args (cdr args)))
1328       ((null specializers) t)
1329    (let ((specializer (car specializers)))
1330      (if (typep specializer 'eql-specializer)
1331          (unless (eql (car args) (eql-specializer-object specializer))
1332            (return nil))
1333          (unless (subclassp (class-of (car args)) specializer)
1334            (return nil))))))
1335
1336(defun %compute-applicable-methods (gf args)
1337  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
1338        (methods ()))
1339    (dolist (method (generic-function-methods gf))
1340      (when (method-applicable-p method args)
1341        (push method methods)))
1342    (sort methods
1343          (if (eq (class-of gf) the-class-standard-gf)
1344              #'(lambda (m1 m2)
1345                 (std-method-more-specific-p m1 m2 required-classes
1346                                             (generic-function-argument-precedence-order gf)))
1347              #'(lambda (m1 m2)
1348                 (method-more-specific-p gf m1 m2 required-classes))))))
1349
1350(defun slow-method-lookup (gf args classes)
1351  (let ((applicable-methods (%compute-applicable-methods gf args)))
1352    (if applicable-methods
1353        (let ((emfun (funcall (if (eq (class-of gf) the-class-standard-gf)
1354                                  #'std-compute-effective-method-function
1355                                  #'compute-effective-method-function)
1356                              gf applicable-methods)))
1357          (when classes
1358            (setf (gethash classes (classes-to-emf-table gf)) emfun))
1359          (funcall emfun args))
1360        (apply #'no-applicable-method gf args))))
1361
1362(defun sub-specializer-p (c1 c2 c-arg)
1363  (find c2 (cdr (memq c1 (class-precedence-list c-arg)))))
1364
1365(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
1366  (if argument-precedence-order
1367      (let ((specializers-1 (method-specializers method1))
1368            (specializers-2 (method-specializers method2)))
1369        (dolist (index argument-precedence-order)
1370          (let ((spec1 (nth index specializers-1))
1371                (spec2 (nth index specializers-2)))
1372            (unless (eq spec1 spec2)
1373              (cond ((eql-specializer-p spec1)
1374                     (return t))
1375                    ((eql-specializer-p spec2)
1376                     (return nil))
1377                    (t
1378                     (return (sub-specializer-p spec1 spec2
1379                                                (nth index required-classes)))))))))
1380      (do ((specializers-1 (method-specializers method1) (cdr specializers-1))
1381           (specializers-2 (method-specializers method2) (cdr specializers-2))
1382           (classes required-classes (cdr classes)))
1383          ((null specializers-1) nil)
1384        (let ((spec1 (car specializers-1))
1385              (spec2 (car specializers-2)))
1386          (unless (eq spec1 spec2)
1387            (cond ((eql-specializer-p spec1)
1388                   (return t))
1389                  ((eql-specializer-p spec2)
1390                   (return nil))
1391                  (t
1392                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))
1393
1394(defun primary-method-p (method)
1395  (null (intersection '(:before :after :around) (method-qualifiers method))))
1396
1397(defun before-method-p (method)
1398  (equal '(:before) (method-qualifiers method)))
1399
1400(defun after-method-p (method)
1401  (equal '(:after) (method-qualifiers method)))
1402
1403(defun around-method-p (method)
1404  (equal '(:around) (method-qualifiers method)))
1405
1406(defun std-compute-effective-method-function (gf methods)
1407  (let* ((mc (generic-function-method-combination gf))
1408         (mc-name (if (atom mc) mc (car mc)))
1409         (options (if (atom mc) '() (cdr mc)))
1410         (order (car options))
1411         (primaries '())
1412         (arounds '())
1413         around)
1414    (dolist (m methods)
1415      (let ((qualifiers (method-qualifiers m)))
1416        (cond ((null qualifiers)
1417               (if (eq mc-name 'standard)
1418                   (push m primaries)
1419                   (error "Method combination type mismatch.")))
1420              ((cdr qualifiers)
1421               (error "Invalid method qualifiers."))
1422              ((eq (car qualifiers) :around)
1423               (push m arounds))
1424              ((eq (car qualifiers) mc-name)
1425               (push m primaries))
1426              ((memq (car qualifiers) '(:before :after)))
1427              (t
1428               (error "Invalid method qualifiers.")))))
1429    (unless (eq order :most-specific-last)
1430      (setf primaries (nreverse primaries)))
1431    (setf arounds (nreverse arounds))
1432    (setf around (car arounds))
1433    (when (null primaries)
1434      (error "No primary methods for the generic function ~S." gf))
1435    (cond (around
1436           (let ((next-emfun
1437                  (funcall
1438                   (if (eq (class-of gf) the-class-standard-gf)
1439                       #'std-compute-effective-method-function
1440                       #'compute-effective-method-function)
1441                   gf (remove around methods))))
1442             #'(lambda (args)
1443                (funcall (method-function around) args next-emfun))))
1444          ((eq mc-name 'standard)
1445           (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
1446                  (befores (remove-if-not #'before-method-p methods))
1447                  (reverse-afters
1448                   (reverse (remove-if-not #'after-method-p methods)))
1449                  (code
1450                   (make-closure
1451                    (if (and (null befores) (null reverse-afters))
1452                        `(lambda (args)
1453                           (funcall ,(method-function (car primaries)) args ,next-emfun))
1454                        `(lambda (args)
1455                           (dolist (before ',befores)
1456                             (funcall (method-function before) args nil))
1457                           (multiple-value-prog1
1458                            (funcall (method-function ,(car primaries)) args ,next-emfun)
1459                            (dolist (after ',reverse-afters)
1460                              (funcall (method-function after) args nil)))))
1461                    nil)))
1462             (setf code (or (compile nil code) code))
1463             code))
1464          (t
1465           (let ((mc-obj (get mc-name 'method-combination-object)))
1466             (unless mc-obj
1467               (error "Unsupported method combination type ~A." mc-name))
1468             (let* ((operator (method-combination-operator mc-obj))
1469                    (ioa (method-combination-identity-with-one-argument mc-obj))
1470                    (form
1471                     (if (and (null (cdr primaries))
1472                              (not (null ioa)))
1473                         `(lambda (args)
1474                            (funcall ,(method-function (car primaries)) args nil))
1475                         `(lambda (args)
1476                            (,operator ,@(mapcar
1477                                          (lambda (primary)
1478                                            `(funcall ,(method-function primary) args nil))
1479                                          primaries))))))
1480               (coerce-to-function form)))))))
1481
1482;;; compute an effective method function from a list of primary methods:
1483
1484(defun compute-primary-emfun (methods)
1485  (if (null methods)
1486      nil
1487      (let ((next-emfun (compute-primary-emfun (cdr methods))))
1488        #'(lambda (args)
1489           (funcall (method-function (car methods)) args next-emfun)))))
1490
1491(defvar *call-next-method-p*)
1492(defvar *next-method-p-p*)
1493
1494(defun walk-form (form)
1495  (cond ((atom form)
1496         (cond ((eq form 'call-next-method)
1497                (setf *call-next-method-p* t))
1498               ((eq form 'next-method-p)
1499                (setf *next-method-p-p* t))))
1500        (t
1501         (walk-form (car form))
1502         (walk-form (cdr form)))))
1503
1504(defvar *compile-method-functions* nil)
1505
1506(defun std-compute-method-function (method gf)
1507  (let ((body (method-body method))
1508        (declarations (method-declarations method))
1509        (lambda-list (kludge-arglist (method-lambda-list method)))
1510        (*call-next-method-p* nil)
1511        (*next-method-p-p* nil))
1512    (walk-form body)
1513    (if (or *call-next-method-p* *next-method-p-p*)
1514        (make-closure
1515         `(lambda (args next-emfun)
1516            (flet ((call-next-method (&rest cnm-args)
1517                     (if (null next-emfun)
1518                         (error "No next method for generic function ~S."
1519                                (method-generic-function ',method))
1520                         (funcall next-emfun (or cnm-args args))))
1521                   (next-method-p ()
1522                     (not (null next-emfun))))
1523              (apply #'(lambda ,lambda-list ,@declarations ,body) args)))
1524         (method-environment method))
1525        (let ((code (make-closure `(lambda ,lambda-list ,@declarations ,body)
1526                                  (method-environment method))))
1527
1528          (when *compile-method-functions*
1529            (fresh-line)
1530            (sys:simple-format t "STD-COMPUTE-METHOD-FUNCTION ~S ~S "
1531                               (if gf (generic-function-name gf) nil)
1532                               (method-specializers method))
1533            (cond ((or (not (fboundp 'compile))
1534                       (autoloadp 'compile))
1535                   (sys:simple-format t "compiler not available~%"))
1536                  ((or (null (method-environment method))
1537                       (sys::empty-environment-p (method-environment method)))
1538                   (setf code (or (compile nil code) code))
1539                   (sys:simple-format t "compiled-function-p is ~S~%"
1540                                      (compiled-function-p code)))
1541                  (t
1542                   (sys:simple-format t "environment is not empty~%"))))
1543
1544          (make-closure `(lambda (args next-emfun) (apply ,code args)) nil)))))
1545
1546;;; N.B. The function kludge-arglist is used to pave over the differences
1547;;; between argument keyword compatibility for regular functions versus
1548;;; generic functions.
1549
1550;; FIXME
1551;; From CLHS section 7.6.5:
1552;; "When a generic function or any of its methods mentions &key in a lambda
1553;; list, the specific set of keyword arguments accepted by the generic function
1554;; varies according to the applicable methods. The set of keyword arguments
1555;; accepted by the generic function for a particular call is the union of the
1556;; keyword arguments accepted by all applicable methods and the keyword
1557;; arguments mentioned after &key in the generic function definition, if any."
1558
1559(defun kludge-arglist (lambda-list)
1560  (if (and (member '&key lambda-list)
1561           (not (member '&allow-other-keys lambda-list)))
1562      (append lambda-list '(&allow-other-keys))
1563      (if (and (not (member '&rest lambda-list))
1564               (not (member '&key lambda-list)))
1565          (append lambda-list '(&key &allow-other-keys))
1566          lambda-list)))
1567
1568(fmakunbound 'class-name)
1569
1570(defgeneric class-name (class))
1571
1572(defmethod class-name ((class class))
1573  (%class-name class))
1574
1575(defgeneric (setf class-name) (new-value class))
1576
1577(defmethod (setf class-name) (new-value (class class))
1578  (%set-class-name class new-value))
1579
1580(fmakunbound 'documentation)
1581(remf (symbol-plist 'documentation) 'setf-inverse)
1582
1583(defgeneric documentation (x doc-type))
1584
1585(defgeneric (setf documentation) (new-value x doc-type))
1586
1587(defmethod documentation ((x symbol) doc-type)
1588  (case doc-type
1589    (FUNCTION
1590     (get x '%function-documentation))
1591    (VARIABLE
1592     (get x '%variable-documentation))
1593    (STRUCTURE
1594     (get x '%structure-documentation))))
1595
1596(defmethod (setf documentation) (new-value (x symbol) doc-type)
1597  (case doc-type
1598    (FUNCTION
1599     (setf (get x '%function-documentation) new-value))
1600    (VARIABLE
1601     (setf (get x '%variable-documentation) new-value))
1602    (STRUCTURE
1603     (setf (get x '%structure-documentation) new-value))))
1604
1605(defmethod documentation ((x standard-class) (doc-type (eql 't)))
1606  (class-documentation x))
1607
1608(defmethod documentation ((x standard-class) (doc-type (eql 'type)))
1609  (class-documentation x))
1610
1611(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't)))
1612  (%set-class-documentation x new-value))
1613
1614(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type)))
1615  (%set-class-documentation x new-value))
1616
1617(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
1618  (generic-function-documentation x))
1619
1620(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
1621  (setf (generic-function-documentation x) new-value))
1622
1623(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
1624  (generic-function-documentation x))
1625
1626(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
1627  (setf (generic-function-documentation x) new-value))
1628
1629(defmethod documentation ((x standard-method) (doc-type (eql 't)))
1630  (method-documentation x))
1631
1632(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
1633  (setf (method-documentation x) new-value))
1634
1635;; FIXME
1636(defmethod documentation ((x package) (doc-type (eql 't)))
1637  nil)
1638
1639;; FIXME
1640(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
1641  new-value)
1642
1643;;; Slot access
1644
1645(defun setf-slot-value-using-class (new-value class instance slot-name)
1646  (setf (std-slot-value instance slot-name) new-value))
1647
1648(defgeneric slot-value-using-class (class instance slot-name))
1649
1650(defmethod slot-value-using-class ((class standard-class) instance slot-name)
1651  (std-slot-value instance slot-name))
1652
1653(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
1654(defmethod (setf slot-value-using-class)
1655  (new-value (class standard-class) instance slot-name)
1656  (setf (std-slot-value instance slot-name) new-value))
1657
1658(defgeneric slot-exists-p-using-class (class instance slot-name))
1659
1660(defmethod slot-exists-p-using-class (class instance slot-name)
1661  nil)
1662
1663(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
1664  (std-slot-exists-p instance slot-name))
1665
1666(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
1667  (dolist (dsd (class-slots class))
1668    (when (eq (dsd-name dsd) slot-name)
1669      (return-from slot-exists-p-using-class t)))
1670  nil)
1671
1672(defgeneric slot-boundp-using-class (class instance slot-name))
1673(defmethod slot-boundp-using-class
1674  ((class standard-class) instance slot-name)
1675  (std-slot-boundp instance slot-name))
1676
1677(defgeneric slot-makunbound-using-class (class instance slot-name))
1678(defmethod slot-makunbound-using-class
1679  ((class standard-class) instance slot-name)
1680  (std-slot-makunbound instance slot-name))
1681
1682(defgeneric slot-missing (class instance slot-name operation &optional new-value))
1683
1684(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
1685  (error "The slot ~S is missing from the class ~S." slot-name class))
1686
1687(defgeneric slot-unbound (class instance slot-name))
1688
1689(defmethod slot-unbound ((class t) instance slot-name)
1690  (error 'unbound-slot :instance instance :name slot-name))
1691
1692;;; Instance creation and initialization
1693
1694(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
1695
1696(defmethod allocate-instance ((class standard-class) &rest initargs)
1697  (std-allocate-instance class))
1698
1699(defmethod allocate-instance ((class structure-class) &rest initargs)
1700  (%make-structure (%class-name class)
1701                   (make-list (length (class-slots class))
1702                              :initial-element +slot-unbound+)))
1703
1704(defgeneric make-instance (class &key))
1705
1706(defmethod make-instance ((class standard-class) &rest initargs)
1707  (when (oddp (length initargs))
1708    (error 'program-error
1709           :format-control "Odd number of keyword arguments."))
1710  (unless (class-finalized-p class)
1711    (std-finalize-inheritance class))
1712  (let ((class-default-initargs (class-default-initargs class)))
1713    (when class-default-initargs
1714      (let ((default-initargs ()))
1715        (do* ((list class-default-initargs (cddr list))
1716              (key (car list) (car list))
1717              (fn (cadr list) (cadr list)))
1718             ((null list))
1719          (when (eq (getf initargs key 'not-found) 'not-found)
1720            (setf default-initargs (append default-initargs (list key (funcall fn))))))
1721        (setf initargs (append initargs default-initargs)))))
1722  (let ((instance (std-allocate-instance class)))
1723    (apply #'initialize-instance instance initargs)
1724    instance))
1725
1726(defmethod make-instance ((class symbol) &rest initargs)
1727  (apply #'make-instance (find-class class) initargs))
1728
1729(defgeneric initialize-instance (instance &key))
1730
1731(defmethod initialize-instance ((instance standard-object) &rest initargs)
1732  (apply #'shared-initialize instance t initargs))
1733
1734(defgeneric reinitialize-instance (instance &key))
1735
1736(defmethod reinitialize-instance
1737  ((instance standard-object) &rest initargs)
1738  (apply #'shared-initialize instance () initargs))
1739
1740(defun std-shared-initialize (instance slot-names all-keys)
1741  (when (oddp (length all-keys))
1742    (error 'program-error :format-control "Odd number of keyword arguments."))
1743  (dolist (slot (class-slots (class-of instance)))
1744    (let ((slot-name (slot-definition-name slot)))
1745      (multiple-value-bind (init-key init-value foundp)
1746        (get-properties all-keys (slot-definition-initargs slot))
1747        (if foundp
1748            (setf (std-slot-value instance slot-name) init-value)
1749            (when (and (not (std-slot-boundp instance slot-name))
1750                       (slot-definition-initfunction slot)
1751                       (or (eq slot-names t)
1752                           (member slot-name slot-names)))
1753              (setf (std-slot-value instance slot-name)
1754                    (funcall (slot-definition-initfunction slot))))))))
1755  instance)
1756
1757(defgeneric shared-initialize (instance slot-names &key))
1758
1759(defmethod shared-initialize ((instance standard-object)
1760                              slot-names &rest all-keys)
1761  (std-shared-initialize instance slot-names all-keys))
1762
1763;;; change-class
1764
1765(defgeneric change-class (instance new-class &key))
1766
1767(defmethod change-class ((old-instance standard-object) (new-class standard-class)
1768                         &rest initargs)
1769  (let ((new-instance (allocate-instance new-class)))
1770    (dolist (slot-name (mapcar #'slot-definition-name
1771                               (class-slots new-class)))
1772      (when (and (slot-exists-p old-instance slot-name)
1773                 (slot-boundp old-instance slot-name))
1774        (setf (slot-value new-instance slot-name)
1775              (slot-value old-instance slot-name))))
1776    (rotatef (std-instance-slots new-instance)
1777             (std-instance-slots old-instance))
1778    (rotatef (std-instance-layout new-instance)
1779             (std-instance-layout old-instance))
1780    (apply #'update-instance-for-different-class
1781           new-instance old-instance initargs)
1782    old-instance))
1783
1784(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
1785  (apply #'change-class instance (find-class new-class) initargs))
1786
1787(defgeneric update-instance-for-different-class (old new &key))
1788
1789(defmethod update-instance-for-different-class
1790  ((old standard-object) (new standard-object) &rest initargs)
1791  (let ((added-slots
1792         (remove-if #'(lambda (slot-name)
1793                       (slot-exists-p old slot-name))
1794                    (mapcar #'slot-definition-name
1795                            (class-slots (class-of new))))))
1796    (apply #'shared-initialize new added-slots initargs)))
1797
1798;;;  Methods having to do with class metaobjects.
1799
1800(defmethod initialize-instance :after ((class standard-class) &rest args)
1801  (apply #'std-after-initialization-for-classes class args))
1802
1803;;; Finalize inheritance
1804
1805(defgeneric finalize-inheritance (class))
1806
1807(defmethod finalize-inheritance ((class standard-class))
1808  (std-finalize-inheritance class))
1809
1810;;; Class precedence lists
1811
1812(defgeneric compute-class-precedence-list (class))
1813(defmethod compute-class-precedence-list ((class standard-class))
1814  (std-compute-class-precedence-list class))
1815
1816;;; Slot inheritance
1817
1818(defgeneric compute-slots (class))
1819(defmethod compute-slots ((class standard-class))
1820  (std-compute-slots class))
1821
1822(defgeneric compute-effective-slot-definition (class direct-slots))
1823(defmethod compute-effective-slot-definition
1824  ((class standard-class) direct-slots)
1825  (std-compute-effective-slot-definition class direct-slots))
1826
1827;;; Methods having to do with generic function metaobjects.
1828
1829(defmethod initialize-instance :after ((gf standard-generic-function) &key)
1830  (finalize-generic-function gf))
1831
1832;;; Methods having to do with generic function invocation.
1833
1834(defgeneric compute-discriminating-function (gf))
1835(defmethod compute-discriminating-function ((gf standard-generic-function))
1836  (std-compute-discriminating-function gf))
1837
1838(defgeneric method-more-specific-p (gf method1 method2 required-classes))
1839
1840(defmethod method-more-specific-p ((gf standard-generic-function)
1841                                   method1 method2 required-classes)
1842  (std-method-more-specific-p method1 method2 required-classes
1843                              (generic-function-argument-precedence-order gf)))
1844
1845(defgeneric compute-effective-method-function (gf methods))
1846(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
1847  (std-compute-effective-method-function gf methods))
1848
1849(defgeneric compute-applicable-methods (gf args))
1850(defmethod compute-applicable-methods ((gf standard-generic-function) args)
1851  (%compute-applicable-methods gf args))
1852
1853;;; Conditions.
1854
1855(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
1856                                 &body options)
1857  (let ((parent-types (or parent-types '(condition)))
1858        (report nil))
1859    (dolist (option options)
1860      (when (eq (car option) :report)
1861        (let ((arg (cadr option)))
1862          (setf report
1863                (if (stringp arg)
1864                    `#'(lambda (condition stream)
1865                        (declare (ignore condition))
1866                        (write-string ,arg stream))
1867                    `#'(lambda (condition stream)
1868                        (funcall #',arg condition stream)))))))
1869    (if report
1870        `(progn
1871           (defclass ,name ,parent-types ,slot-specs ,@options)
1872           (defmethod print-object ((condition ,name) stream)
1873             (if *print-escape*
1874                 (call-next-method)
1875                 (funcall ,report condition stream)))
1876           (setf (get ',name 'sys::condition-report-function) ,report)
1877           ',name)
1878        `(progn
1879           (defclass ,name ,parent-types ,slot-specs ,@options)
1880           ',name))))
1881
1882(defun make-condition (type &rest initargs)
1883  (or (%make-condition type initargs)
1884      (apply #'make-instance (find-class type) initargs)))
1885
1886;; Adapted from SBCL.
1887;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
1888(defun coerce-to-condition (datum arguments default-type fun-name)
1889  (cond ((typep datum 'condition)
1890         (when arguments
1891           (error 'simple-type-error
1892                  :datum arguments
1893                  :expected-type 'null
1894                  :format-control "You may not supply additional arguments when giving ~S to ~S."
1895                  :format-arguments (list datum fun-name)))
1896         datum)
1897        ((symbolp datum)
1898         (apply #'make-condition datum arguments))
1899        ((or (stringp datum) (functionp datum))
1900         (make-condition default-type
1901                         :format-control datum
1902                         :format-arguments arguments))
1903        (t
1904         (error 'simple-type-error
1905                :datum datum
1906                :expected-type '(or symbol string)
1907                :format-control "Bad argument to ~S: ~S."
1908                :format-arguments (list fun-name datum)))))
1909
1910;; Originally defined in Primitives.java. Redefined here to support arbitrary
1911;; conditions.
1912(defun error (datum &rest arguments)
1913  (let ((condition (coerce-to-condition datum arguments 'simple-error 'error)))
1914    (signal condition)
1915    (invoke-debugger condition)))
1916
1917(defgeneric make-load-form (object &optional environment))
1918
1919(defmethod make-load-form ((object t) &optional environment)
1920  (apply #'no-applicable-method #'make-load-form (list object)))
1921
1922(defmethod make-load-form ((class class) &optional environment)
1923  (let ((name (%class-name class)))
1924    (unless (and name (eq (find-class name nil) class))
1925      (error 'simple-type-error
1926             :format-control "Can't use anonymous or undefined class as a constant: ~S."
1927             :format-arguments (list class)))
1928    `(find-class ',name)))
1929
1930(defun invalid-method-error (method format-control &rest args)
1931  (let ((message (apply #'format nil format-control args)))
1932    (error "Invalid method error for ~S:~%    ~A" method message)))
1933
1934(defun method-combination-error (format-control &rest args)
1935  (let ((message (apply #'format nil format-control args)))
1936    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
1937
1938(defgeneric no-applicable-method (generic-function &rest args))
1939
1940(defmethod no-applicable-method (generic-function &rest args)
1941  (error "No applicable method for the generic function ~S when called with arguments ~S."
1942         generic-function
1943         args))
1944
1945(provide 'clos)
Note: See TracBrowser for help on using the repository browser.