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

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

CANONICALIZE-DIRECT-SLOT: call MAYBE-NOTE-NAME-DEFINED for readers, writers and accessors.

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