source: trunk/abcl/src/org/armedbear/lisp/clos.lisp @ 13184

Last change on this file since 13184 was 13184, checked in by ehuelsmann, 11 years ago

Enhance error messages for improved user friendlyness, as requested by Blake.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 127.1 KB
Line 
1;;; clos.lisp
2;;;
3;;; Copyright (C) 2003-2007 Peter Graves
4;;; Copyright (C) 2010 Mark Evenson
5;;; $Id: clos.lisp 13184 2011-01-25 21:56:33Z ehuelsmann $
6;;;
7;;; This program is free software; you can redistribute it and/or
8;;; modify it under the terms of the GNU General Public License
9;;; as published by the Free Software Foundation; either version 2
10;;; of the License, or (at your option) any later version.
11;;;
12;;; This program is distributed in the hope that it will be useful,
13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with this program; if not, write to the Free Software
19;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
20;;;
21;;; As a special exception, the copyright holders of this library give you
22;;; permission to link this library with independent modules to produce an
23;;; executable, regardless of the license terms of these independent
24;;; modules, and to copy and distribute the resulting executable under
25;;; terms of your choice, provided that you also meet, for each linked
26;;; independent module, the terms and conditions of the license of that
27;;; module.  An independent module is a module which is not derived from
28;;; or based on this library.  If you modify this library, you may extend
29;;; this exception to your version of the library, but you are not
30;;; obligated to do so.  If you do not wish to do so, delete this
31;;; exception statement from your version.
32
33;;; Originally based on Closette.
34     
35;;; Closette Version 1.0 (February 10, 1991)
36;;;
37;;; Copyright (c) 1990, 1991 Xerox Corporation.
38;;; All rights reserved.
39;;;
40;;; Use and copying of this software and preparation of derivative works
41;;; based upon this software are permitted.  Any distribution of this
42;;; software or derivative works must comply with all applicable United
43;;; States export control laws.
44;;;
45;;; This software is made available AS IS, and Xerox Corporation makes no
46;;; warranty about the software, its performance or its conformity to any
47;;; specification.
48;;;
49;;; Closette is an implementation of a subset of CLOS with a metaobject
50;;; protocol as described in "The Art of The Metaobject Protocol",
51;;; MIT Press, 1991.
52
53(in-package #:mop)
54
55(export '(class-precedence-list class-slots))
56(defconstant +the-standard-class+ (find-class 'standard-class))
57(defconstant +the-structure-class+ (find-class 'structure-class))
58(defconstant +the-standard-object-class+ (find-class 'standard-object))
59(defconstant +the-standard-method-class+ (find-class 'standard-method))
60(defconstant +the-standard-reader-method-class+
61  (find-class 'standard-reader-method))
62(defconstant +the-standard-generic-function-class+
63  (find-class 'standard-generic-function))
64(defconstant +the-T-class+ (find-class 'T))
65(defconstant +the-slot-definition-class+ (find-class 'slot-definition))
66(defconstant +the-direct-slot-definition-class+ (find-class 'direct-slot-definition))
67(defconstant +the-effective-slot-definition-class+ (find-class 'effective-slot-definition))
68
69;; Don't use DEFVAR, because that disallows loading clos.lisp
70;; after compiling it: the binding won't get assigned to T anymore
71(defparameter *clos-booting* t)
72
73(defmacro define-class->%class-forwarder (name)
74  (let* (($name (if (consp name) (cadr name) name))
75         (%name (intern (concatenate 'string
76                                     "%"
77                                     (if (consp name)
78                                         (symbol-name 'set-) "")
79                                     (symbol-name $name))
80                        (symbol-package $name))))
81    `(progn
82       (declaim (notinline ,name))
83       (defun ,name (&rest args)
84         (apply #',%name args)))))
85
86(define-class->%class-forwarder class-name)
87(define-class->%class-forwarder (setf class-name))
88(define-class->%class-forwarder class-slots)
89(define-class->%class-forwarder (setf class-slots))
90(define-class->%class-forwarder class-direct-slots)
91(define-class->%class-forwarder (setf class-direct-slots))
92(define-class->%class-forwarder class-layout)
93(define-class->%class-forwarder (setf class-layout))
94(define-class->%class-forwarder class-direct-superclasses)
95(define-class->%class-forwarder (setf class-direct-superclasses))
96(define-class->%class-forwarder class-direct-subclasses)
97(define-class->%class-forwarder (setf class-direct-subclasses))
98(define-class->%class-forwarder class-direct-methods)
99(define-class->%class-forwarder (setf class-direct-methods))
100(define-class->%class-forwarder class-precedence-list)
101(define-class->%class-forwarder (setf class-precedence-list))
102(define-class->%class-forwarder class-finalized-p)
103(define-class->%class-forwarder (setf class-finalized-p))
104(define-class->%class-forwarder class-default-initargs)
105(define-class->%class-forwarder (setf class-default-initargs))
106(define-class->%class-forwarder class-direct-default-initargs)
107(define-class->%class-forwarder (setf class-direct-default-initargs))
108
109(defun no-applicable-method (generic-function &rest args)
110  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
111         generic-function
112         args))
113
114
115
116(defmacro push-on-end (value location)
117  `(setf ,location (nconc ,location (list ,value))))
118
119;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list,
120;;; which must be non-nil.
121
122(defun (setf getf*) (new-value plist key)
123  (block body
124    (do ((x plist (cddr x)))
125        ((null x))
126      (when (eq (car x) key)
127        (setf (car (cdr x)) new-value)
128        (return-from body new-value)))
129    (push-on-end key plist)
130    (push-on-end new-value plist)
131    new-value))
132
133(defun mapappend (fun &rest args)
134  (if (some #'null args)
135      ()
136      (append (apply fun (mapcar #'car args))
137              (apply #'mapappend fun (mapcar #'cdr args)))))
138
139(defun mapplist (fun x)
140  (if (null x)
141      ()
142      (cons (funcall fun (car x) (cadr x))
143            (mapplist fun (cddr x)))))
144
145(defsetf std-instance-layout %set-std-instance-layout)
146(defsetf standard-instance-access %set-standard-instance-access)
147
148(defun (setf find-class) (new-value symbol &optional errorp environment)
149  (declare (ignore errorp environment))
150  (%set-find-class symbol new-value))
151
152(defun canonicalize-direct-slots (direct-slots)
153  `(list ,@(mapcar #'canonicalize-direct-slot direct-slots)))
154
155(defun canonicalize-direct-slot (spec)
156  (if (symbolp spec)
157      `(list :name ',spec)
158      (let ((name (car spec))
159            (initfunction nil)
160            (initform nil)
161            (initargs ())
162            (type nil)
163            (allocation nil)
164            (documentation nil)
165            (readers ())
166            (writers ())
167            (other-options ())
168      (non-std-options ()))
169        (do ((olist (cdr spec) (cddr olist)))
170            ((null olist))
171          (case (car olist)
172            (:initform
173             (when initform
174               (error 'program-error
175                      "duplicate slot option :INITFORM for slot named ~S"
176                      name))
177             (setq initfunction
178                   `(function (lambda () ,(cadr olist))))
179             (setq initform `',(cadr olist)))
180            (:initarg
181             (push-on-end (cadr olist) initargs))
182            (:allocation
183             (when allocation
184               (error 'program-error
185                      "duplicate slot option :ALLOCATION for slot named ~S"
186                      name))
187             (setf allocation (cadr olist))
188             (push-on-end (car olist) other-options)
189             (push-on-end (cadr olist) other-options))
190            (:type
191             (when type
192               (error 'program-error
193                      "duplicate slot option :TYPE for slot named ~S"
194                      name))
195             (setf type (cadr olist))) ;; FIXME type is ignored
196            (:documentation
197             (when documentation
198               (error 'program-error
199                      "duplicate slot option :DOCUMENTATION for slot named ~S"
200                      name))
201             (setf documentation (cadr olist))) ;; FIXME documentation is ignored
202            (:reader
203             (maybe-note-name-defined (cadr olist))
204             (push-on-end (cadr olist) readers))
205            (:writer
206             (maybe-note-name-defined (cadr olist))
207             (push-on-end (cadr olist) writers))
208            (:accessor
209             (maybe-note-name-defined (cadr olist))
210             (push-on-end (cadr olist) readers)
211             (push-on-end `(setf ,(cadr olist)) writers))
212            (t
213       (push-on-end `(quote ,(car olist)) non-std-options)
214             (push-on-end (cadr olist) non-std-options))))
215        `(list
216          :name ',name
217          ,@(when initfunction
218              `(:initform ,initform
219                          :initfunction ,initfunction))
220          ,@(when initargs `(:initargs ',initargs))
221          ,@(when readers `(:readers ',readers))
222          ,@(when writers `(:writers ',writers))
223          ,@other-options
224    ,@non-std-options))))
225
226(defun maybe-note-name-defined (name)
227  (when (fboundp 'note-name-defined)
228    (note-name-defined name)))
229
230(defun canonicalize-direct-superclasses (direct-superclasses)
231  (let ((classes '()))
232    (dolist (class-specifier direct-superclasses)
233      (if (classp class-specifier)
234          (push class-specifier classes)
235          (let ((class (find-class class-specifier nil)))
236            (unless class
237              (setf class (make-forward-referenced-class class-specifier)))
238            (push class classes))))
239    (nreverse classes)))
240
241(defun canonicalize-defclass-options (options)
242  (mapappend #'canonicalize-defclass-option options))
243
244(defun canonicalize-defclass-option (option)
245  (case (car option)
246    (:metaclass
247     (list ':metaclass
248           `(find-class ',(cadr option))))
249    (:default-initargs
250     (list
251      ':direct-default-initargs
252      `(list ,@(mapappend
253                #'(lambda (x) x)
254                (mapplist
255                 #'(lambda (key value)
256                    `(',key ,(make-initfunction value)))
257                 (cdr option))))))
258    ((:documentation :report)
259     (list (car option) `',(cadr option)))
260    (t (list `(quote ,(car option)) `(quote ,(cdr option))))))
261
262(defun make-initfunction (initform)
263  `(function (lambda () ,initform)))
264
265(defun slot-definition-allocation (slot-definition)
266  (%slot-definition-allocation slot-definition))
267
268(declaim (notinline (setf slot-definition-allocation)))
269(defun (setf slot-definition-allocation) (value slot-definition)
270  (set-slot-definition-allocation slot-definition value))
271
272(defun slot-definition-initargs (slot-definition)
273  (%slot-definition-initargs slot-definition))
274
275(declaim (notinline (setf slot-definition-initargs)))
276(defun (setf slot-definition-initargs) (value slot-definition)
277  (set-slot-definition-initargs slot-definition value))
278
279(defun slot-definition-initform (slot-definition)
280  (%slot-definition-initform slot-definition))
281
282(declaim (notinline (setf slot-definition-initform)))
283(defun (setf slot-definition-initform) (value slot-definition)
284  (set-slot-definition-initform slot-definition value))
285
286(defun slot-definition-initfunction (slot-definition)
287  (%slot-definition-initfunction slot-definition))
288
289(declaim (notinline (setf slot-definition-initfunction)))
290(defun (setf slot-definition-initfunction) (value slot-definition)
291  (set-slot-definition-initfunction slot-definition value))
292
293(defun slot-definition-name (slot-definition)
294  (%slot-definition-name slot-definition))
295
296(declaim (notinline (setf slot-definition-name)))
297(defun (setf slot-definition-name) (value slot-definition)
298  (set-slot-definition-name slot-definition value))
299
300(defun slot-definition-readers (slot-definition)
301  (%slot-definition-readers slot-definition))
302
303(declaim (notinline (setf slot-definition-readers)))
304(defun (setf slot-definition-readers) (value slot-definition)
305  (set-slot-definition-readers slot-definition value))
306
307(defun slot-definition-writers (slot-definition)
308  (%slot-definition-writers slot-definition))
309
310(declaim (notinline (setf slot-definition-writers)))
311(defun (setf slot-definition-writers) (value slot-definition)
312  (set-slot-definition-writers slot-definition value))
313
314(defun slot-definition-allocation-class (slot-definition)
315  (%slot-definition-allocation-class slot-definition))
316
317(declaim (notinline (setf slot-definition-allocation-class)))
318(defun (setf slot-definition-allocation-class) (value slot-definition)
319  (set-slot-definition-allocation-class slot-definition value))
320
321(defun slot-definition-location (slot-definition)
322  (%slot-definition-location slot-definition))
323
324(declaim (notinline (setf slot-definition-location-class)))
325(defun (setf slot-definition-location) (value slot-definition)
326  (set-slot-definition-location slot-definition value))
327
328(defun init-slot-definition (slot &key name
329           (initargs ())
330           (initform nil)
331           (initfunction nil)
332           (readers ())
333           (writers ())
334           (allocation :instance)
335           (allocation-class nil))
336  (setf (slot-definition-name slot) name)
337  (setf (slot-definition-initargs slot) initargs)
338  (setf (slot-definition-initform slot) initform)
339  (setf (slot-definition-initfunction slot) initfunction)
340  (setf (slot-definition-readers slot) readers)
341  (setf (slot-definition-writers slot) writers)
342  (setf (slot-definition-allocation slot) allocation)
343  (setf (slot-definition-allocation-class slot) allocation-class)
344  slot)
345
346(defun make-direct-slot-definition (class &rest args)
347  (let ((slot-class (direct-slot-definition-class class)))
348    (if (eq slot-class +the-direct-slot-definition-class+)
349  (let ((slot (make-slot-definition +the-direct-slot-definition-class+)))
350    (apply #'init-slot-definition slot :allocation-class class args)
351    slot)
352  (progn
353    (let ((slot (apply #'make-instance slot-class :allocation-class class
354           args)))
355      slot)))))
356
357(defun make-effective-slot-definition (class &rest args)
358  (let ((slot-class (effective-slot-definition-class class)))
359    (if (eq slot-class +the-effective-slot-definition-class+)
360  (let ((slot (make-slot-definition +the-effective-slot-definition-class+)))
361    (apply #'init-slot-definition slot args)
362    slot)
363  (progn
364    (let ((slot (apply #'make-instance slot-class args)))
365      slot)))))
366
367;;; finalize-inheritance
368
369(defun std-compute-class-default-initargs (class)
370  (mapcan #'(lambda (c)
371              (copy-list
372               (class-direct-default-initargs c)))
373          (class-precedence-list class)))
374
375(defun std-finalize-inheritance (class)
376  (setf (class-precedence-list class)
377   (funcall (if (eq (class-of class) +the-standard-class+)
378                #'std-compute-class-precedence-list
379                #'compute-class-precedence-list)
380            class))
381  (dolist (class (class-precedence-list class))
382    (when (typep class 'forward-referenced-class)
383      (return-from std-finalize-inheritance)))
384  (setf (class-slots class)
385                   (funcall (if (eq (class-of class) +the-standard-class+)
386                                #'std-compute-slots
387                     #'compute-slots) class))
388  (let ((old-layout (class-layout class))
389        (length 0)
390        (instance-slots '())
391        (shared-slots '()))
392    (dolist (slot (class-slots class))
393      (case (slot-definition-allocation slot)
394        (:instance
395         (setf (slot-definition-location slot) length)
396         (incf length)
397         (push (slot-definition-name slot) instance-slots))
398        (:class
399         (unless (slot-definition-location slot)
400           (let ((allocation-class (slot-definition-allocation-class slot)))
401             (setf (slot-definition-location slot)
402       (if (eq allocation-class class)
403           (cons (slot-definition-name slot) +slot-unbound+)
404           (slot-location allocation-class (slot-definition-name slot))))))
405         (push (slot-definition-location slot) shared-slots))))
406    (when old-layout
407      ;; Redefined class: initialize added shared slots.
408      (dolist (location shared-slots)
409        (let* ((slot-name (car location))
410               (old-location (layout-slot-location old-layout slot-name)))
411          (unless old-location
412            (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name))
413                   (initfunction (slot-definition-initfunction slot-definition)))
414              (when initfunction
415                (setf (cdr location) (funcall initfunction))))))))
416    (setf (class-layout class)
417          (make-layout class (nreverse instance-slots) (nreverse shared-slots))))
418  (setf (class-default-initargs class)
419        (std-compute-class-default-initargs class))
420  (setf (class-finalized-p class) t))
421
422;;; Class precedence lists
423
424(defun std-compute-class-precedence-list (class)
425  (let ((classes-to-order (collect-superclasses* class)))
426    (topological-sort classes-to-order
427                      (remove-duplicates
428                       (mapappend #'local-precedence-ordering
429                                  classes-to-order))
430                      #'std-tie-breaker-rule)))
431
432;;; topological-sort implements the standard algorithm for topologically
433;;; sorting an arbitrary set of elements while honoring the precedence
434;;; constraints given by a set of (X,Y) pairs that indicate that element
435;;; X must precede element Y.  The tie-breaker procedure is called when it
436;;; is necessary to choose from multiple minimal elements; both a list of
437;;; candidates and the ordering so far are provided as arguments.
438
439(defun topological-sort (elements constraints tie-breaker)
440  (let ((remaining-constraints constraints)
441        (remaining-elements elements)
442        (result ()))
443    (loop
444      (let ((minimal-elements
445             (remove-if
446              #'(lambda (class)
447                 (member class remaining-constraints
448                         :key #'cadr))
449              remaining-elements)))
450        (when (null minimal-elements)
451          (if (null remaining-elements)
452              (return-from topological-sort result)
453              (error "Inconsistent precedence graph.")))
454        (let ((choice (if (null (cdr minimal-elements))
455                          (car minimal-elements)
456                          (funcall tie-breaker
457                                   minimal-elements
458                                   result))))
459          (setq result (append result (list choice)))
460          (setq remaining-elements
461                (remove choice remaining-elements))
462          (setq remaining-constraints
463                (remove choice
464                        remaining-constraints
465                        :test #'member)))))))
466
467;;; In the event of a tie while topologically sorting class precedence lists,
468;;; the CLOS Specification says to "select the one that has a direct subclass
469;;; rightmost in the class precedence list computed so far."  The same result
470;;; is obtained by inspecting the partially constructed class precedence list
471;;; from right to left, looking for the first minimal element to show up among
472;;; the direct superclasses of the class precedence list constituent.
473;;; (There's a lemma that shows that this rule yields a unique result.)
474
475(defun std-tie-breaker-rule (minimal-elements cpl-so-far)
476  (dolist (cpl-constituent (reverse cpl-so-far))
477    (let* ((supers (class-direct-superclasses cpl-constituent))
478           (common (intersection minimal-elements supers)))
479      (when (not (null common))
480        (return-from std-tie-breaker-rule (car common))))))
481
482;;; This version of collect-superclasses* isn't bothered by cycles in the class
483;;; hierarchy, which sometimes happen by accident.
484
485(defun collect-superclasses* (class)
486  (labels ((all-superclasses-loop (seen superclasses)
487                                  (let ((to-be-processed
488                                         (set-difference superclasses seen)))
489                                    (if (null to-be-processed)
490                                        superclasses
491                                        (let ((class-to-process
492                                               (car to-be-processed)))
493                                          (all-superclasses-loop
494                                           (cons class-to-process seen)
495                                           (union (class-direct-superclasses
496                                                   class-to-process)
497                                                  superclasses)))))))
498          (all-superclasses-loop () (list class))))
499
500;;; The local precedence ordering of a class C with direct superclasses C_1,
501;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)).
502
503(defun local-precedence-ordering (class)
504  (mapcar #'list
505          (cons class
506                (butlast (class-direct-superclasses class)))
507          (class-direct-superclasses class)))
508
509;;; Slot inheritance
510
511(defun std-compute-slots (class)
512  (let* ((all-slots (mapappend #'class-direct-slots
513                               (class-precedence-list class)))
514         (all-names (remove-duplicates
515                     (mapcar 'slot-definition-name all-slots))))
516    (mapcar #'(lambda (name)
517               (funcall
518                (if (eq (class-of class) +the-standard-class+)
519                    #'std-compute-effective-slot-definition
520                    #'compute-effective-slot-definition)
521                class
522                (remove name all-slots
523                        :key 'slot-definition-name
524                        :test-not #'eq)))
525            all-names)))
526
527(defun std-compute-effective-slot-definition (class direct-slots)
528  (let ((initer (find-if-not #'null direct-slots
529                             :key 'slot-definition-initfunction)))
530    (make-effective-slot-definition
531     class
532     :name (slot-definition-name (car direct-slots))
533     :initform (if initer
534                   (slot-definition-initform initer)
535                   nil)
536     :initfunction (if initer
537                       (slot-definition-initfunction initer)
538                       nil)
539     :initargs (remove-duplicates
540                (mapappend 'slot-definition-initargs
541                           direct-slots))
542     :allocation (slot-definition-allocation (car direct-slots))
543     :allocation-class (when (slot-boundp (car direct-slots)
544            'sys::allocation-class)
545       ;;for some classes created in Java
546       ;;(e.g. SimpleCondition) this slot is unbound
547       (slot-definition-allocation-class (car direct-slots))))))
548
549;;; Standard instance slot access
550
551;;; N.B. The location of the effective-slots slots in the class metaobject for
552;;; standard-class must be determined without making any further slot
553;;; references.
554
555(defun find-slot-definition (class slot-name)
556  (dolist (slot (class-slots class) nil)
557    (when (eq slot-name (slot-definition-name slot))
558      (return slot))))
559
560(defun slot-location (class slot-name)
561  (let ((slot (find-slot-definition class slot-name)))
562    (if slot
563        (slot-definition-location slot)
564        nil)))
565
566(defun instance-slot-location (instance slot-name)
567  (let ((layout (std-instance-layout instance)))
568    (and layout (layout-slot-location layout slot-name))))
569
570(defun slot-value (object slot-name)
571  (if (or (eq (class-of (class-of object)) +the-standard-class+)
572    (eq (class-of (class-of object)) +the-structure-class+))
573      (std-slot-value object slot-name)
574      (slot-value-using-class (class-of object) object slot-name)))
575
576(defsetf std-slot-value set-std-slot-value)
577
578(defun %set-slot-value (object slot-name new-value)
579  (if (or (eq (class-of (class-of object)) +the-standard-class+)
580    (eq (class-of (class-of object)) +the-structure-class+))
581      (setf (std-slot-value object slot-name) new-value)
582      (set-slot-value-using-class new-value (class-of object)
583                                  object slot-name)))
584
585(defsetf slot-value %set-slot-value)
586
587(defun slot-boundp (object slot-name)
588  (if (eq (class-of (class-of object)) +the-standard-class+)
589      (std-slot-boundp object slot-name)
590      (slot-boundp-using-class (class-of object) object slot-name)))
591
592(defun std-slot-makunbound (instance slot-name)
593  (let ((location (instance-slot-location instance slot-name)))
594    (cond ((fixnump location)
595           (setf (standard-instance-access instance location) +slot-unbound+))
596          ((consp location)
597           (setf (cdr location) +slot-unbound+))
598          (t
599           (slot-missing (class-of instance) instance slot-name 'slot-makunbound))))
600  instance)
601
602(defun slot-makunbound (object slot-name)
603  (if (eq (class-of (class-of object)) +the-standard-class+)
604      (std-slot-makunbound object slot-name)
605      (slot-makunbound-using-class (class-of object) object slot-name)))
606
607(defun std-slot-exists-p (instance slot-name)
608  (not (null (find slot-name (class-slots (class-of instance))
609                   :key 'slot-definition-name))))
610
611(defun slot-exists-p (object slot-name)
612  (if (eq (class-of (class-of object)) +the-standard-class+)
613      (std-slot-exists-p object slot-name)
614      (slot-exists-p-using-class (class-of object) object slot-name)))
615
616(defun instance-slot-p (slot)
617  (eq (slot-definition-allocation slot) :instance))
618
619(defun make-instance-standard-class (metaclass
620             &rest initargs
621                                     &key name direct-superclasses direct-slots
622                                     direct-default-initargs
623                                     documentation)
624  (declare (ignore metaclass))
625  (let ((class (std-allocate-instance +the-standard-class+)))
626    (check-initargs class t initargs)
627    (%set-class-name name class)
628    (%set-class-layout nil class)
629    (%set-class-direct-subclasses ()  class)
630    (%set-class-direct-methods ()  class)
631    (%set-class-documentation class documentation)
632    (std-after-initialization-for-classes class
633                                          :direct-superclasses direct-superclasses
634                                          :direct-slots direct-slots
635                                          :direct-default-initargs direct-default-initargs)
636    class))
637
638;(defun convert-to-direct-slot-definition (class canonicalized-slot)
639;  (apply #'make-instance
640;         (apply #'direct-slot-definition-class
641;                class canonicalized-slot)
642;         canonicalized-slot))
643
644(defun std-after-initialization-for-classes (class
645                                             &key direct-superclasses direct-slots
646                                             direct-default-initargs
647                                             &allow-other-keys)
648  (let ((supers (or direct-superclasses
649                    (list +the-standard-object-class+))))
650    (setf (class-direct-superclasses class) supers)
651    (dolist (superclass supers)
652      (pushnew class (class-direct-subclasses superclass))))
653  (let ((slots (mapcar #'(lambda (slot-properties)
654                          (apply #'make-direct-slot-definition class slot-properties))
655                       direct-slots)))
656    (setf (class-direct-slots class) slots)
657    (dolist (direct-slot slots)
658      (dolist (reader (slot-definition-readers direct-slot))
659        (add-reader-method class reader (slot-definition-name direct-slot)))
660      (dolist (writer (slot-definition-writers direct-slot))
661        (add-writer-method class writer (slot-definition-name direct-slot)))))
662  (setf (class-direct-default-initargs class) direct-default-initargs)
663  (funcall (if (eq (class-of class) +the-standard-class+)
664               #'std-finalize-inheritance
665               #'finalize-inheritance)
666           class)
667  (values))
668
669(defun canonical-slot-name (canonical-slot)
670  (getf canonical-slot :name))
671
672(defvar *extensible-built-in-classes*
673  (list (find-class 'sequence)
674        (find-class 'java:java-object)))
675
676(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
677  ;; Check for duplicate slots.
678  (remf all-keys :metaclass)
679  (let ((slots (getf all-keys :direct-slots)))
680    (dolist (s1 slots)
681      (let ((name1 (canonical-slot-name s1)))
682        (dolist (s2 (cdr (memq s1 slots)))
683          (when (eq name1 (canonical-slot-name s2))
684            (error 'program-error "Duplicate slot ~S" name1))))))
685  ;; Check for duplicate argument names in :DEFAULT-INITARGS.
686  (let ((names ()))
687    (do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
688          (name (car initargs) (car initargs)))
689         ((null initargs))
690      (push name names))
691    (do* ((names names (cdr names))
692          (name (car names) (car names)))
693         ((null names))
694      (when (memq name (cdr names))
695        (error 'program-error
696               :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
697               :format-arguments (list name)))))
698  (let ((direct-superclasses (getf all-keys :direct-superclasses)))
699    (dolist (class direct-superclasses)
700      (when (and (typep class 'built-in-class)
701     (not (member class *extensible-built-in-classes*)))
702        (error "Attempt to define a subclass of a built-in-class: ~S" class))))
703  (let ((old-class (find-class name nil)))
704    (cond ((and old-class (eq name (class-name old-class)))
705           (cond ((typep old-class 'built-in-class)
706                  (error "The symbol ~S names a built-in class." name))
707                 ((typep old-class 'forward-referenced-class)
708                  (let ((new-class (apply #'make-instance-standard-class
709                                          +the-standard-class+
710                                          :name name all-keys)))
711                    (%set-find-class name new-class)
712                    (dolist (subclass (class-direct-subclasses old-class))
713                      (setf (class-direct-superclasses subclass)
714                            (substitute new-class old-class
715                                        (class-direct-superclasses subclass))))
716                    new-class))
717                 (t
718                  ;; We're redefining the class.
719                  (%make-instances-obsolete old-class)
720      (check-initargs old-class t all-keys)
721                  (apply #'std-after-initialization-for-classes old-class all-keys)
722                  old-class)))
723          (t
724           (let ((class (apply (if metaclass
725                                   #'make-instance
726                                   #'make-instance-standard-class)
727                               (or metaclass
728                                   +the-standard-class+)
729                               :name name all-keys)))
730             (%set-find-class name class)
731             class)))))
732
733(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
734  (unless (>= (length form) 3)
735    (error 'program-error "Wrong number of arguments for DEFCLASS."))
736  (check-declaration-type name)
737  `(ensure-class ',name
738                 :direct-superclasses
739                 (canonicalize-direct-superclasses ',direct-superclasses)
740                 :direct-slots
741                 ,(canonicalize-direct-slots direct-slots)
742                 ,@(canonicalize-defclass-options options)))
743
744(defstruct method-combination
745  name
746  documentation)
747
748(defstruct (short-method-combination 
749             (:include method-combination))
750  operator
751  identity-with-one-argument)
752
753(defstruct (long-method-combination
754             (:include method-combination))
755  lambda-list
756  method-group-specs
757  args-lambda-list
758  generic-function-symbol
759  function
760  arguments
761  declarations
762  forms)
763
764(defun expand-long-defcombin (name args)
765  (destructuring-bind (lambda-list method-groups &rest body) args
766    `(apply #'define-long-form-method-combination
767            ',name
768            ',lambda-list
769            (list ,@(mapcar #'canonicalize-method-group-spec method-groups))
770            ',body)))
771
772(defun expand-short-defcombin (whole)
773  (let* ((name (cadr whole))
774         (documentation
775          (getf (cddr whole) :documentation ""))
776         (identity-with-one-arg
777          (getf (cddr whole) :identity-with-one-argument nil))
778         (operator
779          (getf (cddr whole) :operator name)))
780    `(progn
781       (setf (get ',name 'method-combination-object)
782             (make-short-method-combination
783              :name ',name
784              :operator ',operator
785              :identity-with-one-argument ',identity-with-one-arg
786              :documentation ',documentation))
787       ',name)))
788
789(defmacro define-method-combination (&whole form name &rest args)
790  (if (and (cddr form)
791           (listp (caddr form)))
792      (expand-long-defcombin name args)
793      (expand-short-defcombin form)))
794
795(define-method-combination +      :identity-with-one-argument t)
796(define-method-combination and    :identity-with-one-argument t)
797(define-method-combination append :identity-with-one-argument nil)
798(define-method-combination list   :identity-with-one-argument nil)
799(define-method-combination max    :identity-with-one-argument t)
800(define-method-combination min    :identity-with-one-argument t)
801(define-method-combination nconc  :identity-with-one-argument t)
802(define-method-combination or     :identity-with-one-argument t)
803(define-method-combination progn  :identity-with-one-argument t)
804
805;;;
806;;; long form of define-method-combination (from Sacla and XCL)
807;;;
808(defun define-method-combination-type (name &rest initargs)
809    (setf (get name 'method-combination-object)
810          (apply 'make-long-method-combination initargs)))
811
812(defun method-group-p (selecter qualifiers)
813  ;; selecter::= qualifier-pattern | predicate
814  (etypecase selecter
815    (list (or (equal selecter qualifiers)
816              (let ((last (last selecter)))
817                (when (eq '* (cdr last))
818                  (let* ((prefix `(,@(butlast selecter) ,(car last)))
819                         (pos (mismatch prefix qualifiers)))
820                    (or (null pos) (= pos (length prefix))))))))
821    ((eql *) t)
822    (symbol (funcall (symbol-function selecter) qualifiers))))
823
824(defun check-variable-name (name)
825  (flet ((valid-variable-name-p (name)
826                                (and (symbolp name) (not (constantp name)))))
827    (assert (valid-variable-name-p name))))
828
829(defun canonicalize-method-group-spec (spec)
830  ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]])
831  ;; long-form-option::= :description description | :order order |
832  ;;                     :required required-p
833  ;; a canonicalized-spec is a simple plist.
834  (let* ((rest spec)
835         (name (prog2 (check-variable-name (car rest))
836                 (car rest)
837                 (setq rest (cdr rest))))
838         (option-names '(:description :order :required))
839         (selecters (let ((end (or (position-if #'(lambda (it)
840                                                   (member it option-names))
841                                                rest)
842                                   (length rest))))
843                      (prog1 (subseq rest 0 end)
844                        (setq rest (subseq rest end)))))
845         (description (getf rest :description ""))
846         (order (getf rest :order :most-specific-first))
847         (required-p (getf rest :required)))
848    `(list :name ',name
849           :predicate (lambda (qualifiers)
850                        (loop for item in ',selecters
851                          thereis (method-group-p item qualifiers)))
852           :description ',description
853           :order ',order
854           :required ',required-p)))
855
856(defun extract-required-part (lambda-list)
857  (flet ((skip (key lambda-list)
858               (if (eq (first lambda-list) key)
859                   (cddr lambda-list)
860                   lambda-list)))
861    (ldiff (skip '&environment (skip '&whole lambda-list))
862           (member-if #'(lambda (it) (member it lambda-list-keywords))
863                      lambda-list))))
864
865(defun extract-specified-part (key lambda-list)
866  (case key
867    ((&eval &whole)
868     (list (second (member key lambda-list))))
869    (t
870     (let ((here (cdr (member key lambda-list))))
871       (ldiff here
872              (member-if #'(lambda (it) (member it lambda-list-keywords))
873                         here))))))
874
875(defun extract-optional-part (lambda-list)
876  (extract-specified-part '&optional lambda-list))
877
878(defun parse-define-method-combination-arguments-lambda-list (lambda-list)
879  ;; Define-method-combination Arguments Lambda Lists
880  ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm
881  (let ((required (extract-required-part lambda-list))
882        (whole    (extract-specified-part '&whole    lambda-list))
883        (optional (extract-specified-part '&optional lambda-list))
884        (rest     (extract-specified-part '&rest     lambda-list))
885        (keys     (extract-specified-part '&key      lambda-list))
886        (aux      (extract-specified-part '&aux      lambda-list)))
887    (values (first whole)
888            required
889            (mapcar #'(lambda (spec)
890                       (if (consp spec)
891                           `(,(first spec) ,(second spec) ,@(cddr spec))
892                           `(,spec nil)))
893                    optional)
894            (first rest)
895            (mapcar #'(lambda (spec)
896                       (let ((key (if (consp spec) (car spec) spec))
897                             (rest (when (consp spec) (rest spec))))
898                         `(,(if (consp key) key `(,(make-keyword key) ,key))
899                           ,(car rest)
900                           ,@(cdr rest))))
901                    keys)
902            (mapcar #'(lambda (spec)
903                       (if (consp spec)
904                           `(,(first spec) ,(second spec))
905                           `(,spec nil)))
906                    aux))))
907
908(defmacro getk (plist key init-form)
909  "Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST."
910  (let ((not-exist (gensym))
911        (value (gensym)))
912    `(let ((,value (getf ,plist ,key ,not-exist)))
913       (if (eq ,not-exist ,value) ,init-form ,value))))
914
915(defconstant +gf-args-var+ (make-symbol "GF-ARGS-VAR"))
916
917(defmacro with-args-lambda-list (args-lambda-list generic-function-symbol
918                                                  &body forms)
919  (let ((gf-lambda-list (gensym))
920        (nrequired (gensym))
921        (noptional (gensym))
922        (rest-args (gensym)))
923    (multiple-value-bind (whole required optional rest keys aux)
924        (parse-define-method-combination-arguments-lambda-list args-lambda-list)
925      `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'lambda-list))
926              (,nrequired (length (extract-required-part ,gf-lambda-list)))
927              (,noptional (length (extract-optional-part ,gf-lambda-list)))
928              (,rest-args (subseq ,+gf-args-var+ (+ ,nrequired ,noptional)))
929              ,@(when whole `((,whole ,+gf-args-var+)))
930              ,@(loop for var in required and i upfrom 0
931                  collect `(,var (when (< ,i ,nrequired)
932                                   (nth ,i ,+gf-args-var+))))
933              ,@(loop for (var init-form) in optional and i upfrom 0
934                  collect
935                  `(,var (if (< ,i ,noptional)
936                             (nth (+ ,nrequired ,i) ,+gf-args-var+)
937                             ,init-form)))
938              ,@(when rest `((,rest ,rest-args)))
939              ,@(loop for ((key var) init-form) in keys and i upfrom 0
940                  collect `(,var (getk ,rest-args ',key ,init-form)))
941              ,@(loop for (var init-form) in aux and i upfrom 0
942                  collect `(,var ,init-form)))
943         ,@forms))))
944
945(defmacro with-method-groups (method-group-specs methods-form &body forms)
946  (flet ((grouping-form (spec methods-var)
947                        (let ((predicate (coerce-to-function (getf spec :predicate)))
948                              (group (gensym))
949                              (leftovers (gensym))
950                              (method (gensym)))
951                          `(let ((,group '())
952                                 (,leftovers '()))
953                             (dolist (,method ,methods-var)
954                               (if (funcall ,predicate (method-qualifiers ,method))
955                                   (push ,method ,group)
956                                   (push ,method ,leftovers)))
957                             (ecase ,(getf spec :order)
958                               (:most-specific-last )
959                               (:most-specific-first (setq ,group (nreverse ,group))))
960                             ,@(when (getf spec :required)
961                                 `((when (null ,group)
962                                     (error "Method group ~S must not be empty."
963                                            ',(getf spec :name)))))
964                             (setq ,methods-var (nreverse ,leftovers))
965                             ,group))))
966    (let ((rest (gensym))
967          (method (gensym)))
968      `(let* ((,rest ,methods-form)
969              ,@(mapcar #'(lambda (spec)
970                           `(,(getf spec :name) ,(grouping-form spec rest)))
971                        method-group-specs))
972         (dolist (,method ,rest)
973           (invalid-method-error ,method
974                                 "Method ~S with qualifiers ~S does not belong to any method group."
975                                 ,method (method-qualifiers ,method)))
976         ,@forms))))
977
978(defun method-combination-type-lambda
979  (&key name lambda-list args-lambda-list generic-function-symbol
980        method-group-specs declarations forms &allow-other-keys)
981  (let ((methods (gensym)))
982    `(lambda (,generic-function-symbol ,methods ,@lambda-list)
983       ,@declarations
984       (let ((*message-prefix* ,(format nil "METHOD COMBINATION TYPE ~S: " name)))
985         (with-method-groups ,method-group-specs
986           ,methods
987           ,@(if (null args-lambda-list)
988                 forms
989                 `((with-args-lambda-list ,args-lambda-list
990                     ,generic-function-symbol
991                     ,@forms))))))))
992
993(defun declarationp (expr)
994  (and (consp expr) (eq (car expr) 'DECLARE)))
995
996(defun long-form-method-combination-args (args)
997  ;; define-method-combination name lambda-list (method-group-specifier*) args
998  ;; args ::= [(:arguments . args-lambda-list)]
999  ;;          [(:generic-function generic-function-symbol)]
1000  ;;          [[declaration* | documentation]] form*
1001  (let ((rest args))
1002    (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest))))
1003             (args-lambda-list ()
1004               (when (nextp :arguments)
1005                 (prog1 (cdr (car rest)) (setq rest (cdr rest)))))
1006             (generic-function-symbol ()
1007                (if (nextp :generic-function)
1008                    (prog1 (second (car rest)) (setq rest (cdr rest)))
1009                    (gensym)))
1010             (declaration* ()
1011               (let ((end (position-if-not #'declarationp rest)))
1012                 (when end
1013                   (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
1014             (documentation? ()
1015               (when (stringp (car rest))
1016                 (prog1 (car rest) (setq rest (cdr rest)))))
1017             (form* () rest))
1018      (let ((declarations '()))
1019        `(:args-lambda-list ,(args-lambda-list)
1020                            :generic-function-symbol ,(generic-function-symbol)
1021                            :documentation ,(prog2 (setq declarations (declaration*))
1022                                              (documentation?))
1023                            :declarations (,@declarations ,@(declaration*))
1024                            :forms ,(form*))))))
1025
1026(defun define-long-form-method-combination (name lambda-list method-group-specs
1027                                                 &rest args)
1028  (let* ((initargs `(:name ,name
1029                     :lambda-list ,lambda-list
1030                     :method-group-specs ,method-group-specs
1031                     ,@(long-form-method-combination-args args)))
1032         (lambda-expression (apply #'method-combination-type-lambda initargs)))
1033    (apply #'define-method-combination-type name
1034           `(,@initargs
1035;;              :function ,(compile nil lambda-expression)
1036             :function ,(coerce-to-function lambda-expression)))
1037    name))
1038
1039(defstruct eql-specializer
1040  object)
1041
1042(defparameter *eql-specializer-table* (make-hash-table :test 'eql))
1043
1044(defun intern-eql-specializer (object)
1045  (or (gethash object *eql-specializer-table*)
1046      (setf (gethash object *eql-specializer-table*)
1047            (make-eql-specializer :object object))))
1048
1049;; MOP (p. 216) specifies the following reader generic functions:
1050;;   generic-function-argument-precedence-order
1051;;   generic-function-declarations
1052;;   generic-function-lambda-list
1053;;   generic-function-method-class
1054;;   generic-function-method-combination
1055;;   generic-function-methods
1056;;   generic-function-name
1057
1058(defun generic-function-lambda-list (gf)
1059  (%generic-function-lambda-list gf))
1060(defsetf generic-function-lambda-list %set-generic-function-lambda-list)
1061
1062(defun (setf generic-function-documentation) (new-value gf)
1063  (set-generic-function-documentation gf new-value))
1064
1065(defun (setf generic-function-initial-methods) (new-value gf)
1066  (set-generic-function-initial-methods gf new-value))
1067
1068(defun (setf generic-function-methods) (new-value gf)
1069  (set-generic-function-methods gf new-value))
1070
1071(defun (setf generic-function-method-class) (new-value gf)
1072  (set-generic-function-method-class gf new-value))
1073
1074(defun (setf generic-function-method-combination) (new-value gf)
1075  (set-generic-function-method-combination gf new-value))
1076
1077(defun (setf generic-function-argument-precedence-order) (new-value gf)
1078  (set-generic-function-argument-precedence-order gf new-value))
1079
1080(declaim (ftype (function * t) classes-to-emf-table))
1081(defun classes-to-emf-table (gf)
1082  (generic-function-classes-to-emf-table gf))
1083
1084(defun (setf classes-to-emf-table) (new-value gf)
1085  (set-generic-function-classes-to-emf-table gf new-value))
1086
1087(defun (setf method-lambda-list) (new-value method)
1088  (set-method-lambda-list method new-value))
1089
1090(defun (setf method-qualifiers) (new-value method)
1091  (set-method-qualifiers method new-value))
1092
1093(defun (setf method-documentation) (new-value method)
1094  (set-method-documentation method new-value))
1095
1096;;; defgeneric
1097
1098(defmacro defgeneric (function-name lambda-list
1099                                    &rest options-and-method-descriptions)
1100  (let ((options ())
1101        (methods ())
1102        (documentation nil))
1103    (dolist (item options-and-method-descriptions)
1104      (case (car item)
1105        (declare) ; FIXME
1106        (:documentation
1107         (when documentation
1108           (error 'program-error
1109                  :format-control "Documentation option was specified twice for generic function ~S."
1110                  :format-arguments (list function-name)))
1111         (setf documentation t)
1112         (push item options))
1113        (:method
1114         (push
1115          `(push (defmethod ,function-name ,@(cdr item))
1116                 (generic-function-initial-methods (fdefinition ',function-name)))
1117          methods))
1118        (t
1119         (push item options))))
1120    (setf options (nreverse options)
1121          methods (nreverse methods))
1122    `(prog1
1123       (%defgeneric
1124        ',function-name
1125        :lambda-list ',lambda-list
1126        ,@(canonicalize-defgeneric-options options))
1127       ,@methods)))
1128
1129(defun canonicalize-defgeneric-options (options)
1130  (mapappend #'canonicalize-defgeneric-option options))
1131
1132(defun canonicalize-defgeneric-option (option)
1133  (case (car option)
1134    (:generic-function-class
1135     (list :generic-function-class `(find-class ',(cadr option))))
1136    (:method-class
1137     (list :method-class `(find-class ',(cadr option))))
1138    (:method-combination
1139     (list :method-combination `',(cdr option)))
1140    (:argument-precedence-order
1141     (list :argument-precedence-order `',(cdr option)))
1142    (t
1143     (list `',(car option) `',(cadr option)))))
1144
1145;; From OpenMCL.
1146(defun canonicalize-argument-precedence-order (apo req)
1147  (cond ((equal apo req) nil)
1148        ((not (eql (length apo) (length req)))
1149         (error 'program-error
1150                :format-control "Specified argument precedence order ~S does not match lambda list."
1151                :format-arguments (list apo)))
1152        (t (let ((res nil))
1153             (dolist (arg apo (nreverse res))
1154               (let ((index (position arg req)))
1155                 (if (or (null index) (memq index res))
1156                     (error 'program-error
1157                            :format-control "Specified argument precedence order ~S does not match lambda list."
1158                            :format-arguments (list apo)))
1159                 (push index res)))))))
1160
1161(defun find-generic-function (name &optional (errorp t))
1162  (let ((function (and (fboundp name) (fdefinition name))))
1163    (when function
1164      (when (typep function 'generic-function)
1165        (return-from find-generic-function function))
1166      (when (and *traced-names* (find name *traced-names* :test #'equal))
1167        (setf function (untraced-function name))
1168        (when (typep function 'generic-function)
1169          (return-from find-generic-function function)))))
1170  (if errorp
1171      (error "There is no generic function named ~S." name)
1172      nil))
1173
1174(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
1175  (let* ((plist1 (analyze-lambda-list lambda-list1))
1176         (args1 (getf plist1 :required-args))
1177         (plist2 (analyze-lambda-list lambda-list2))
1178         (args2 (getf plist2 :required-args)))
1179    (= (length args1) (length args2))))
1180
1181(defun %defgeneric (function-name &rest all-keys)
1182  (when (fboundp function-name)
1183    (let ((gf (fdefinition function-name)))
1184      (when (typep gf 'generic-function)
1185        ;; Remove methods defined by previous DEFGENERIC forms.
1186        (dolist (method (generic-function-initial-methods gf))
1187          (%remove-method gf method))
1188        (setf (generic-function-initial-methods gf) '()))))
1189  (apply 'ensure-generic-function function-name all-keys))
1190
1191(defun ensure-generic-function (function-name
1192                                &rest all-keys
1193                                &key
1194                                lambda-list
1195                                (generic-function-class +the-standard-generic-function-class+)
1196                                (method-class +the-standard-method-class+)
1197                                (method-combination 'standard)
1198                                (argument-precedence-order nil apo-p)
1199                                documentation
1200                                &allow-other-keys)
1201  (when (autoloadp function-name)
1202    (resolve function-name))
1203  (let ((gf (find-generic-function function-name nil)))
1204    (if gf
1205        (progn
1206          (unless (or (null (generic-function-methods gf))
1207                      (lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf)))
1208            (error 'simple-error
1209                   :format-control "The lambda list ~S is incompatible with the existing methods of ~S."
1210                   :format-arguments (list lambda-list gf)))
1211          (setf (generic-function-lambda-list gf) lambda-list)
1212          (setf (generic-function-documentation gf) documentation)
1213          (let* ((plist (analyze-lambda-list lambda-list))
1214                 (required-args (getf plist ':required-args)))
1215            (%set-gf-required-args gf required-args)
1216            (when apo-p
1217              (setf (generic-function-argument-precedence-order gf)
1218                    (if argument-precedence-order
1219                        (canonicalize-argument-precedence-order argument-precedence-order
1220                                                                required-args)
1221                        nil)))
1222            (finalize-generic-function gf))
1223          gf)
1224        (progn
1225          (when (and (null *clos-booting*)
1226                     (fboundp function-name))
1227            (error 'program-error
1228                   :format-control "~A already names an ordinary function, macro, or special operator."
1229                   :format-arguments (list function-name)))
1230          (setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
1231                              #'make-instance-standard-generic-function
1232                              #'make-instance)
1233                          generic-function-class
1234                          :name function-name
1235                          :method-class method-class
1236                          :method-combination method-combination
1237                          all-keys))
1238          gf))))
1239
1240(defun initial-discriminating-function (gf args)
1241  (set-funcallable-instance-function
1242   gf
1243   (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1244                #'std-compute-discriminating-function
1245                #'compute-discriminating-function)
1246            gf))
1247  (apply gf args))
1248
1249(defun collect-eql-specializer-objects (generic-function)
1250  (let ((result nil))
1251    (dolist (method (generic-function-methods generic-function))
1252      (dolist (specializer (%method-specializers method))
1253        (when (typep specializer 'eql-specializer)
1254          (pushnew (eql-specializer-object specializer)
1255                   result
1256                   :test 'eql))))
1257    result))
1258
1259(defun finalize-generic-function (gf)
1260  (%finalize-generic-function gf)
1261  (setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
1262  (%init-eql-specializations gf (collect-eql-specializer-objects gf))
1263  (set-funcallable-instance-function
1264   gf #'(lambda (&rest args)
1265          (initial-discriminating-function gf args)))
1266  ;; FIXME Do we need to warn on redefinition somewhere else?
1267  (let ((*warn-on-redefinition* nil))
1268    (setf (fdefinition (%generic-function-name gf)) gf))
1269  (values))
1270
1271(defun make-instance-standard-generic-function (generic-function-class
1272                                                &key name lambda-list
1273                                                method-class
1274                                                method-combination
1275                                                argument-precedence-order
1276                                                documentation)
1277  (declare (ignore generic-function-class))
1278  (let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
1279    (%set-generic-function-name gf name)
1280    (setf (generic-function-lambda-list gf) lambda-list)
1281    (setf (generic-function-initial-methods gf) ())
1282    (setf (generic-function-methods gf) ())
1283    (setf (generic-function-method-class gf) method-class)
1284    (setf (generic-function-method-combination gf) method-combination)
1285    (setf (generic-function-documentation gf) documentation)
1286    (setf (classes-to-emf-table gf) nil)
1287    (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
1288           (required-args (getf plist ':required-args)))
1289      (%set-gf-required-args gf required-args)
1290      (setf (generic-function-argument-precedence-order gf)
1291            (if argument-precedence-order
1292                (canonicalize-argument-precedence-order argument-precedence-order
1293                                                        required-args)
1294                nil)))
1295    (finalize-generic-function gf)
1296    gf))
1297
1298(defun canonicalize-specializers (specializers)
1299  (mapcar #'canonicalize-specializer specializers))
1300
1301(defun canonicalize-specializer (specializer)
1302  (cond ((classp specializer)
1303         specializer)
1304        ((eql-specializer-p specializer)
1305         specializer)
1306        ((symbolp specializer)
1307         (find-class specializer))
1308        ((and (consp specializer)
1309              (eq (car specializer) 'eql))
1310         (let ((object (cadr specializer)))
1311           (when (and (consp object)
1312                      (eq (car object) 'quote))
1313             (setf object (cadr object)))
1314           (intern-eql-specializer object)))
1315  ((and (consp specializer)
1316              (eq (car specializer) 'java:jclass))
1317         (let ((jclass (eval specializer)))
1318     (java::ensure-java-class jclass)))
1319        (t
1320         (error "Unknown specializer: ~S" specializer))))
1321
1322(defun parse-defmethod (args)
1323  (let ((function-name (car args))
1324        (qualifiers ())
1325        (specialized-lambda-list ())
1326        (body ())
1327        (parse-state :qualifiers))
1328    (dolist (arg (cdr args))
1329      (ecase parse-state
1330        (:qualifiers
1331         (if (and (atom arg) (not (null arg)))
1332             (push arg qualifiers)
1333             (progn
1334               (setf specialized-lambda-list arg)
1335               (setf parse-state :body))))
1336        (:body (push arg body))))
1337    (setf qualifiers (nreverse qualifiers)
1338          body (nreverse body))
1339    (multiple-value-bind (real-body declarations documentation)
1340        (parse-body body)
1341      (values function-name
1342              qualifiers
1343              (extract-lambda-list specialized-lambda-list)
1344              (extract-specializers specialized-lambda-list)
1345              documentation
1346              declarations
1347              (list* 'block
1348                     (fdefinition-block-name function-name)
1349                     real-body)))))
1350
1351(defun required-portion (gf args)
1352  (let ((number-required (length (gf-required-args gf))))
1353    (when (< (length args) number-required)
1354      (error 'program-error
1355             :format-control "Not enough arguments for generic function ~S."
1356             :format-arguments (list (%generic-function-name gf))))
1357    (subseq args 0 number-required)))
1358
1359(defun extract-lambda-list (specialized-lambda-list)
1360  (let* ((plist (analyze-lambda-list specialized-lambda-list))
1361         (requireds (getf plist :required-names))
1362         (rv (getf plist :rest-var))
1363         (ks (getf plist :key-args))
1364         (keysp (getf plist :keysp))
1365         (aok (getf plist :allow-other-keys))
1366         (opts (getf plist :optional-args))
1367         (auxs (getf plist :auxiliary-args)))
1368    `(,@requireds
1369      ,@(if rv `(&rest ,rv) ())
1370      ,@(if (or ks keysp aok) `(&key ,@ks) ())
1371      ,@(if aok '(&allow-other-keys) ())
1372      ,@(if opts `(&optional ,@opts) ())
1373      ,@(if auxs `(&aux ,@auxs) ()))))
1374
1375(defun extract-specializers (specialized-lambda-list)
1376  (let ((plist (analyze-lambda-list specialized-lambda-list)))
1377    (getf plist ':specializers)))
1378
1379(defun get-keyword-from-arg (arg)
1380  (if (listp arg)
1381      (if (listp (car arg))
1382          (caar arg)
1383          (make-keyword (car arg)))
1384      (make-keyword arg)))
1385
1386(defun analyze-lambda-list (lambda-list)
1387  (let ((keys ())           ; Just the keywords
1388        (key-args ())       ; Keywords argument specs
1389        (keysp nil)         ;
1390        (required-names ()) ; Just the variable names
1391        (required-args ())  ; Variable names & specializers
1392        (specializers ())   ; Just the specializers
1393        (rest-var nil)
1394        (optionals ())
1395        (auxs ())
1396        (allow-other-keys nil)
1397        (state :parsing-required))
1398    (dolist (arg lambda-list)
1399      (if (member arg lambda-list-keywords)
1400          (ecase arg
1401            (&optional
1402             (setq state :parsing-optional))
1403            (&rest
1404             (setq state :parsing-rest))
1405            (&key
1406             (setq keysp t)
1407             (setq state :parsing-key))
1408            (&allow-other-keys
1409             (setq allow-other-keys 't))
1410            (&aux
1411             (setq state :parsing-aux)))
1412          (case state
1413            (:parsing-required
1414             (push-on-end arg required-args)
1415             (if (listp arg)
1416                 (progn (push-on-end (car arg) required-names)
1417                   (push-on-end (cadr arg) specializers))
1418                 (progn (push-on-end arg required-names)
1419                   (push-on-end 't specializers))))
1420            (:parsing-optional (push-on-end arg optionals))
1421            (:parsing-rest (setq rest-var arg))
1422            (:parsing-key
1423             (push-on-end (get-keyword-from-arg arg) keys)
1424             (push-on-end arg key-args))
1425            (:parsing-aux (push-on-end arg auxs)))))
1426    (list  :required-names required-names
1427           :required-args required-args
1428           :specializers specializers
1429           :rest-var rest-var
1430           :keywords keys
1431           :key-args key-args
1432           :keysp keysp
1433           :auxiliary-args auxs
1434           :optional-args optionals
1435           :allow-other-keys allow-other-keys)))
1436
1437#+nil
1438(defun check-method-arg-info (gf arg-info method)
1439  (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1440      (analyze-lambda-list (if (consp method)
1441                               (early-method-lambda-list method)
1442                               (method-lambda-list method)))
1443    (flet ((lose (string &rest args)
1444                 (error 'simple-program-error
1445                        :format-control "~@<attempt to add the method~2I~_~S~I~_~
1446                        to the generic function~2I~_~S;~I~_~
1447                        but ~?~:>"
1448                        :format-arguments (list method gf string args)))
1449           (comparison-description (x y)
1450                                   (if (> x y) "more" "fewer")))
1451      (let ((gf-nreq (arg-info-number-required arg-info))
1452            (gf-nopt (arg-info-number-optional arg-info))
1453            (gf-key/rest-p (arg-info-key/rest-p arg-info))
1454            (gf-keywords (arg-info-keys arg-info)))
1455        (unless (= nreq gf-nreq)
1456          (lose
1457           "the method has ~A required arguments than the generic function."
1458           (comparison-description nreq gf-nreq)))
1459        (unless (= nopt gf-nopt)
1460          (lose
1461           "the method has ~A optional arguments than the generic function."
1462           (comparison-description nopt gf-nopt)))
1463        (unless (eq (or keysp restp) gf-key/rest-p)
1464          (lose
1465           "the method and generic function differ in whether they accept~_~
1466            &REST or &KEY arguments."))
1467        (when (consp gf-keywords)
1468          (unless (or (and restp (not keysp))
1469                      allow-other-keys-p
1470                      (every (lambda (k) (memq k keywords)) gf-keywords))
1471            (lose "the method does not accept each of the &KEY arguments~2I~_~
1472            ~S."
1473                  gf-keywords)))))))
1474
1475(defun check-method-lambda-list (name method-lambda-list gf-lambda-list)
1476  (let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
1477         (gf-plist (analyze-lambda-list gf-lambda-list))
1478         (gf-keysp (getf gf-plist :keysp))
1479         (gf-keywords (getf gf-plist :keywords))
1480         (method-plist (analyze-lambda-list method-lambda-list))
1481         (method-restp (not (null (memq '&rest method-lambda-list))))
1482         (method-keysp (getf method-plist :keysp))
1483         (method-keywords (getf method-plist :keywords))
1484         (method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1485    (unless (= (length (getf gf-plist :required-args))
1486               (length (getf method-plist :required-args)))
1487      (error "The method-lambda-list ~S ~
1488              has the wrong number of required arguments ~
1489              for the generic function ~S." method-lambda-list name))
1490    (unless (= (length (getf gf-plist :optional-args))
1491               (length (getf method-plist :optional-args)))
1492      (error "The method-lambda-list ~S ~
1493              has the wrong number of optional arguments ~
1494              for the generic function ~S." method-lambda-list name))
1495    (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1496      (error "The method-lambda-list ~S ~
1497              and the generic function ~S ~
1498              differ in whether they accept &REST or &KEY arguments."
1499             method-lambda-list name))
1500    (when (consp gf-keywords)
1501      (unless (or (and method-restp (not method-keysp))
1502                  method-allow-other-keys-p
1503                  (every (lambda (k) (memq k method-keywords)) gf-keywords))
1504        (error "The method-lambda-list ~S does not accept ~
1505                all of the keyword arguments defined for the ~
1506                generic function." method-lambda-list name)))))
1507
1508(declaim (ftype (function * method) ensure-method))
1509(defun ensure-method (name &rest all-keys)
1510  (let ((method-lambda-list (getf all-keys :lambda-list))
1511        (gf (find-generic-function name nil)))
1512    (if gf
1513        (check-method-lambda-list name method-lambda-list
1514                                  (generic-function-lambda-list gf))
1515        (setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
1516    (let ((method
1517           (if (eq (generic-function-method-class gf) +the-standard-method-class+)
1518               (apply #'make-instance-standard-method gf all-keys)
1519               (apply #'make-instance (generic-function-method-class gf) all-keys))))
1520      (%add-method gf method)
1521      method)))
1522
1523(defun make-instance-standard-method (gf
1524                                      &key
1525                                      lambda-list
1526                                      qualifiers
1527                                      specializers
1528                                      documentation
1529                                      function
1530                                      fast-function)
1531  (declare (ignore gf))
1532  (let ((method (std-allocate-instance +the-standard-method-class+)))
1533    (setf (method-lambda-list method) lambda-list)
1534    (setf (method-qualifiers method) qualifiers)
1535    (%set-method-specializers method (canonicalize-specializers specializers))
1536    (setf (method-documentation method) documentation)
1537    (%set-method-generic-function method nil)
1538    (%set-method-function method function)
1539    (%set-method-fast-function method fast-function)
1540    method))
1541
1542(defun %add-method (gf method)
1543  (when (%method-generic-function method)
1544    (error 'simple-error
1545           :format-control "ADD-METHOD: ~S is a method of ~S."
1546           :format-arguments (list method (%method-generic-function method))))
1547  ;; Remove existing method with same qualifiers and specializers (if any).
1548  (let ((old-method (%find-method gf (method-qualifiers method)
1549                                 (%method-specializers method) nil)))
1550    (when old-method
1551      (%remove-method gf old-method)))
1552  (%set-method-generic-function method gf)
1553  (push method (generic-function-methods gf))
1554  (dolist (specializer (%method-specializers method))
1555    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1556      (pushnew method (class-direct-methods specializer))))
1557  (finalize-generic-function gf)
1558  gf)
1559
1560(defun %remove-method (gf method)
1561  (setf (generic-function-methods gf)
1562        (remove method (generic-function-methods gf)))
1563  (%set-method-generic-function method nil)
1564  (dolist (specializer (%method-specializers method))
1565    (when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1566      (setf (class-direct-methods specializer)
1567            (remove method (class-direct-methods specializer)))))
1568  (finalize-generic-function gf)
1569  gf)
1570
1571(defun %find-method (gf qualifiers specializers &optional (errorp t))
1572  ;; "If the specializers argument does not correspond in length to the number
1573  ;; of required arguments of the generic-function, an an error of type ERROR
1574  ;; is signaled."
1575  (unless (= (length specializers) (length (gf-required-args gf)))
1576    (error "The specializers argument has length ~S, but ~S has ~S required parameters."
1577           (length specializers)
1578           gf
1579           (length (gf-required-args gf))))
1580  (let* ((canonical-specializers (canonicalize-specializers specializers))
1581         (method
1582          (find-if #'(lambda (method)
1583                      (and (equal qualifiers
1584                                  (method-qualifiers method))
1585                           (equal canonical-specializers
1586                                  (%method-specializers method))))
1587                   (generic-function-methods gf))))
1588    (if (and (null method) errorp)
1589        (error "No such method for ~S." (%generic-function-name gf))
1590        method)))
1591
1592(defun fast-callable-p (gf)
1593  (and (eq (generic-function-method-combination gf) 'standard)
1594       (null (intersection (%generic-function-lambda-list gf)
1595                           '(&rest &optional &key &allow-other-keys &aux)))))
1596
1597(declaim (ftype (function * t) slow-method-lookup-1))
1598
1599(declaim (ftype (function (t t t) t) slow-reader-lookup))
1600(defun slow-reader-lookup (gf layout slot-name)
1601  (let ((location (layout-slot-location layout slot-name)))
1602    (cache-slot-location gf layout location)
1603    location))
1604
1605(defun std-compute-discriminating-function (gf)
1606  (let ((code
1607         (cond
1608           ((and (= (length (generic-function-methods gf)) 1)
1609                 (typep (car (generic-function-methods gf)) 'standard-reader-method))
1610            ;;                 (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
1611
1612            (let* ((method (%car (generic-function-methods gf)))
1613                   (class (car (%method-specializers method)))
1614                   (slot-name (reader-method-slot-name method)))
1615              #'(lambda (arg)
1616                  (declare (optimize speed))
1617                  (let* ((layout (std-instance-layout arg))
1618                         (location (get-cached-slot-location gf layout)))
1619                    (unless location
1620                      (unless (simple-typep arg class)
1621                        ;; FIXME no applicable method
1622                        (error 'simple-type-error
1623                               :datum arg
1624                               :expected-type class))
1625                      (setf location (slow-reader-lookup gf layout slot-name)))
1626                    (if (consp location)
1627                        ;; Shared slot.
1628                        (cdr location)
1629                        (standard-instance-access arg location))))))
1630
1631           (t
1632            (let* ((emf-table (classes-to-emf-table gf))
1633                   (number-required (length (gf-required-args gf)))
1634                   (lambda-list (%generic-function-lambda-list gf))
1635                   (exact (null (intersection lambda-list
1636                                              '(&rest &optional &key
1637                                                &allow-other-keys &aux)))))
1638              (if exact
1639                  (cond
1640                    ((= number-required 1)
1641                     (cond
1642                       ((and (eq (generic-function-method-combination gf) 'standard)
1643                             (= (length (generic-function-methods gf)) 1))
1644                        (let* ((method (%car (generic-function-methods gf)))
1645                               (specializer (car (%method-specializers method)))
1646                               (function (or (%method-fast-function method)
1647                                             (%method-function method))))
1648                          (if (eql-specializer-p specializer)
1649                              (let ((specializer-object (eql-specializer-object specializer)))
1650                                #'(lambda (arg)
1651                                    (declare (optimize speed))
1652                                    (if (eql arg specializer-object)
1653                                        (funcall function arg)
1654                                        (no-applicable-method gf (list arg)))))
1655                              #'(lambda (arg)
1656                                  (declare (optimize speed))
1657                                  (unless (simple-typep arg specializer)
1658                                    ;; FIXME no applicable method
1659                                    (error 'simple-type-error
1660                                           :datum arg
1661                                           :expected-type specializer))
1662                                  (funcall function arg)))))
1663                       (t
1664                        #'(lambda (arg)
1665                            (declare (optimize speed))
1666                            (let* ((specialization
1667                                    (%get-arg-specialization gf arg))
1668                                   (emfun (or (gethash1 specialization
1669                                                        emf-table)
1670                                              (slow-method-lookup-1
1671                                               gf arg specialization))))
1672                              (if emfun
1673                                  (funcall emfun (list arg))
1674                                  (apply #'no-applicable-method gf (list arg))))))))
1675                    ((= number-required 2)
1676                     #'(lambda (arg1 arg2)
1677                         (declare (optimize speed))
1678                         (let* ((args (list arg1 arg2))
1679                                (emfun (get-cached-emf gf args)))
1680                           (if emfun
1681                               (funcall emfun args)
1682                               (slow-method-lookup gf args)))))
1683                    ((= number-required 3)
1684                     #'(lambda (arg1 arg2 arg3)
1685                         (declare (optimize speed))
1686                         (let* ((args (list arg1 arg2 arg3))
1687                                (emfun (get-cached-emf gf args)))
1688                           (if emfun
1689                               (funcall emfun args)
1690                               (slow-method-lookup gf args)))))
1691                    (t
1692                     #'(lambda (&rest args)
1693                         (declare (optimize speed))
1694                         (let ((len (length args)))
1695                           (unless (= len number-required)
1696                             (error 'program-error
1697                                    :format-control "Not enough arguments for generic function ~S."
1698                                    :format-arguments (list (%generic-function-name gf)))))
1699                         (let ((emfun (get-cached-emf gf args)))
1700                           (if emfun
1701                               (funcall emfun args)
1702                               (slow-method-lookup gf args))))))
1703                  #'(lambda (&rest args)
1704                      (declare (optimize speed))
1705                      (let ((len (length args)))
1706                        (unless (>= len number-required)
1707                          (error 'program-error
1708                                 :format-control "Not enough arguments for generic function ~S."
1709                                 :format-arguments (list (%generic-function-name gf)))))
1710                      (let ((emfun (get-cached-emf gf args)))
1711                        (if emfun
1712                            (funcall emfun args)
1713                            (slow-method-lookup gf args))))))))))
1714
1715    code))
1716
1717(defun sort-methods (methods gf required-classes)
1718  (if (or (null methods) (null (%cdr methods)))
1719      methods
1720      (sort methods
1721      (if (eq (class-of gf) +the-standard-generic-function-class+)
1722    #'(lambda (m1 m2)
1723        (std-method-more-specific-p m1 m2 required-classes
1724            (generic-function-argument-precedence-order gf)))
1725    #'(lambda (m1 m2)
1726        (method-more-specific-p gf m1 m2 required-classes))))))
1727
1728(defun method-applicable-p (method args)
1729  (do* ((specializers (%method-specializers method) (cdr specializers))
1730        (args args (cdr args)))
1731       ((null specializers) t)
1732    (let ((specializer (car specializers)))
1733      (if (typep specializer 'eql-specializer)
1734          (unless (eql (car args) (eql-specializer-object specializer))
1735            (return nil))
1736          (unless (subclassp (class-of (car args)) specializer)
1737            (return nil))))))
1738
1739(defun %compute-applicable-methods (gf args)
1740  (let ((required-classes (mapcar #'class-of (required-portion gf args)))
1741        (methods '()))
1742    (dolist (method (generic-function-methods gf))
1743      (when (method-applicable-p method args)
1744        (push method methods)))
1745    (sort-methods methods gf required-classes)))
1746
1747;;; METHOD-APPLICABLE-USING-CLASSES-P
1748;;;
1749;;; If the first return value is T, METHOD is definitely applicable to
1750;;; arguments that are instances of CLASSES.  If the first value is
1751;;; NIL and the second value is T, METHOD is definitely not applicable
1752;;; to arguments that are instances of CLASSES; if the second value is
1753;;; NIL the applicability of METHOD cannot be determined by inspecting
1754;;; the classes of its arguments only.
1755;;;
1756(defun method-applicable-using-classes-p (method classes)
1757  (do* ((specializers (%method-specializers method) (cdr specializers))
1758  (classes classes (cdr classes))
1759  (knownp t))
1760       ((null specializers)
1761  (if knownp (values t t) (values nil nil)))
1762    (let ((specializer (car specializers)))
1763      (if (typep specializer 'eql-specializer)
1764    (if (eql (class-of (eql-specializer-object specializer)) 
1765       (car classes))
1766        (setf knownp nil)
1767        (return (values nil t)))
1768    (unless (subclassp (car classes) specializer)
1769      (return (values nil t)))))))
1770
1771(defun slow-method-lookup (gf args)
1772  (let ((applicable-methods (%compute-applicable-methods gf args)))
1773    (if applicable-methods
1774        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1775                                  #'std-compute-effective-method-function
1776                                  #'compute-effective-method-function)
1777                              gf applicable-methods)))
1778          (cache-emf gf args emfun)
1779          (funcall emfun args))
1780        (apply #'no-applicable-method gf args))))
1781
1782(defun slow-method-lookup-1 (gf arg arg-specialization)
1783  (let ((applicable-methods (%compute-applicable-methods gf (list arg))))
1784    (if applicable-methods
1785        (let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1786                                  #'std-compute-effective-method-function
1787                                  #'compute-effective-method-function)
1788                              gf applicable-methods)))
1789          (when emfun
1790            (setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
1791          emfun))))
1792
1793(defun sub-specializer-p (c1 c2 c-arg)
1794  (find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
1795
1796(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
1797  (if argument-precedence-order
1798      (let ((specializers-1 (%method-specializers method1))
1799            (specializers-2 (%method-specializers method2)))
1800        (dolist (index argument-precedence-order)
1801          (let ((spec1 (nth index specializers-1))
1802                (spec2 (nth index specializers-2)))
1803            (unless (eq spec1 spec2)
1804              (cond ((eql-specializer-p spec1)
1805                     (return t))
1806                    ((eql-specializer-p spec2)
1807                     (return nil))
1808                    (t
1809                     (return (sub-specializer-p spec1 spec2
1810                                                (nth index required-classes)))))))))
1811      (do ((specializers-1 (%method-specializers method1) (cdr specializers-1))
1812           (specializers-2 (%method-specializers method2) (cdr specializers-2))
1813           (classes required-classes (cdr classes)))
1814          ((null specializers-1) nil)
1815        (let ((spec1 (car specializers-1))
1816              (spec2 (car specializers-2)))
1817          (unless (eq spec1 spec2)
1818            (cond ((eql-specializer-p spec1)
1819                   (return t))
1820                  ((eql-specializer-p spec2)
1821                   (return nil))
1822                  (t
1823                   (return (sub-specializer-p spec1 spec2 (car classes))))))))))
1824
1825(defun primary-method-p (method)
1826  (null (intersection '(:before :after :around) (method-qualifiers method))))
1827
1828(defun before-method-p (method)
1829  (equal '(:before) (method-qualifiers method)))
1830
1831(defun after-method-p (method)
1832  (equal '(:after) (method-qualifiers method)))
1833
1834(defun around-method-p (method)
1835  (equal '(:around) (method-qualifiers method)))
1836
1837(defun std-compute-effective-method-function (gf methods)
1838  (let* ((mc (generic-function-method-combination gf))
1839         (mc-name (if (atom mc) mc (%car mc)))
1840         (options (if (atom mc) '() (%cdr mc)))
1841         (order (car options))
1842         (primaries '())
1843         (arounds '())
1844         around
1845         emf-form
1846         (long-method-combination-p 
1847          (typep (get mc-name 'method-combination-object) 'long-method-combination)))
1848    (unless long-method-combination-p
1849      (dolist (m methods)
1850        (let ((qualifiers (method-qualifiers m)))
1851          (cond ((null qualifiers)
1852                 (if (eq mc-name 'standard)
1853                     (push m primaries)
1854                     (error "Method combination type mismatch.")))
1855                ((cdr qualifiers)
1856                 (error "Invalid method qualifiers."))
1857                ((eq (car qualifiers) :around)
1858                 (push m arounds))
1859                ((eq (car qualifiers) mc-name)
1860                 (push m primaries))
1861                ((memq (car qualifiers) '(:before :after)))
1862                (t
1863                 (error "Invalid method qualifiers."))))))
1864    (unless (eq order :most-specific-last)
1865      (setf primaries (nreverse primaries)))
1866    (setf arounds (nreverse arounds))
1867    (setf around (car arounds))
1868    (when (and (null primaries) (not long-method-combination-p))
1869      (error "No primary methods for the generic function ~S." gf))
1870    (cond
1871      (around
1872       (let ((next-emfun
1873              (funcall
1874               (if (eq (class-of gf) +the-standard-generic-function-class+)
1875                   #'std-compute-effective-method-function
1876                   #'compute-effective-method-function)
1877               gf (remove around methods))))
1878         (setf emf-form
1879               (generate-emf-lambda (%method-function around) next-emfun))))
1880      ((eq mc-name 'standard)
1881       (let* ((next-emfun (compute-primary-emfun (cdr primaries)))
1882              (befores (remove-if-not #'before-method-p methods))
1883              (reverse-afters
1884               (reverse (remove-if-not #'after-method-p methods))))
1885         (setf emf-form
1886               (cond
1887                 ((and (null befores) (null reverse-afters))
1888                  (let ((fast-function (%method-fast-function (car primaries))))
1889                    (if fast-function
1890                        (ecase (length (gf-required-args gf))
1891                          (1
1892                           #'(lambda (args)
1893                               (declare (optimize speed))
1894                               (funcall fast-function (car args))))
1895                          (2
1896                           #'(lambda (args)
1897                               (declare (optimize speed))
1898                               (funcall fast-function (car args) (cadr args)))))
1899                        (generate-emf-lambda (%method-function (car primaries))
1900                                             next-emfun))))
1901                 (t
1902                  (let ((method-function (%method-function (car primaries))))
1903                    #'(lambda (args)
1904                        (declare (optimize speed))
1905                        (dolist (before befores)
1906                          (funcall (%method-function before) args nil))
1907                        (multiple-value-prog1
1908                            (funcall method-function args next-emfun)
1909                          (dolist (after reverse-afters)
1910                            (funcall (%method-function after) args nil))))))))))
1911      (long-method-combination-p
1912       (let* ((mc-obj (get mc-name 'method-combination-object))
1913              (function (long-method-combination-function mc-obj))
1914              (arguments (rest (slot-value gf 'method-combination))))
1915         (assert (typep mc-obj 'long-method-combination))
1916         (assert function)
1917         (setf emf-form 
1918               (let ((result (if arguments
1919                                 (apply function gf methods arguments)
1920                                 (funcall function gf methods))))
1921                 `(lambda (args)
1922                    (let ((gf-args-var args))
1923                      (macrolet ((call-method (method &optional next-method-list)
1924                                   `(funcall ,(%method-function method) args nil)))
1925                        ,result)))))))
1926      (t
1927       (let ((mc-obj (get mc-name 'method-combination-object)))
1928         (unless (typep mc-obj 'short-method-combination)
1929           (error "Unsupported method combination type ~A."
1930                  mc-name))
1931         (let* ((operator (short-method-combination-operator mc-obj))
1932                (ioa (short-method-combination-identity-with-one-argument mc-obj)))
1933           (setf emf-form
1934                 (if (and (null (cdr primaries))
1935                          (not (null ioa)))
1936                     (generate-emf-lambda (%method-function (car primaries)) nil)
1937                     `(lambda (args)
1938                        (,operator ,@(mapcar
1939                                      (lambda (primary)
1940                                        `(funcall ,(%method-function primary) args nil))
1941                                      primaries)))))))))
1942    (assert (not (null emf-form)))
1943    (or #+nil (ignore-errors (autocompile emf-form))
1944        (coerce-to-function emf-form))))
1945
1946(defun generate-emf-lambda (method-function next-emfun)
1947  #'(lambda (args)
1948      (declare (optimize speed))
1949      (funcall method-function args next-emfun)))
1950
1951;;; compute an effective method function from a list of primary methods:
1952
1953(defun compute-primary-emfun (methods)
1954  (if (null methods)
1955      nil
1956      (let ((next-emfun (compute-primary-emfun (cdr methods))))
1957        #'(lambda (args)
1958           (funcall (%method-function (car methods)) args next-emfun)))))
1959
1960(defvar *call-next-method-p*)
1961(defvar *next-method-p-p*)
1962
1963(defun walk-form (form)
1964  (cond ((atom form)
1965         (cond ((eq form 'call-next-method)
1966                (setf *call-next-method-p* t))
1967               ((eq form 'next-method-p)
1968                (setf *next-method-p-p* t))))
1969        (t
1970         (walk-form (%car form))
1971         (walk-form (%cdr form)))))
1972
1973(defun compute-method-function (lambda-expression)
1974  (let ((lambda-list (allow-other-keys (cadr lambda-expression)))
1975        (body (cddr lambda-expression))
1976        (*call-next-method-p* nil)
1977        (*next-method-p-p* nil))
1978    (multiple-value-bind (body declarations) (parse-body body)
1979      (let ((ignorable-vars '()))
1980        (dolist (var lambda-list)
1981          (if (memq var lambda-list-keywords)
1982              (return)
1983              (push var ignorable-vars)))
1984        (push `(declare (ignorable ,@ignorable-vars)) declarations))
1985      (walk-form body)
1986      (cond ((or *call-next-method-p* *next-method-p-p*)
1987             `(lambda (args next-emfun)
1988                (flet ((call-next-method (&rest cnm-args)
1989                         (if (null next-emfun)
1990                             (error "No next method for generic function.")
1991                             (funcall next-emfun (or cnm-args args))))
1992                       (next-method-p ()
1993                         (not (null next-emfun))))
1994                  (declare (ignorable (function call-next-method)
1995                                      (function next-method-p)))
1996                  (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
1997            ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
1998             ;; Required parameters only.
1999             (case (length lambda-list)
2000               (1
2001                `(lambda (args next-emfun)
2002                   (declare (ignore next-emfun))
2003                   (let ((,(%car lambda-list) (%car args)))
2004                     (declare (ignorable ,(%car lambda-list)))
2005                     ,@declarations ,@body)))
2006               (2
2007                `(lambda (args next-emfun)
2008                   (declare (ignore next-emfun))
2009                   (let ((,(%car lambda-list) (%car args))
2010                         (,(%cadr lambda-list) (%cadr args)))
2011                     (declare (ignorable ,(%car lambda-list)
2012                                         ,(%cadr lambda-list)))
2013                     ,@declarations ,@body)))
2014               (3
2015                `(lambda (args next-emfun)
2016                   (declare (ignore next-emfun))
2017                   (let ((,(%car lambda-list) (%car args))
2018                         (,(%cadr lambda-list) (%cadr args))
2019                         (,(%caddr lambda-list) (%caddr args)))
2020                     (declare (ignorable ,(%car lambda-list)
2021                                         ,(%cadr lambda-list)
2022                                         ,(%caddr lambda-list)))
2023                     ,@declarations ,@body)))
2024               (t
2025                `(lambda (args next-emfun)
2026                   (declare (ignore next-emfun))
2027                   (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
2028            (t
2029             `(lambda (args next-emfun)
2030                (declare (ignore next-emfun))
2031                (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
2032
2033(defun compute-method-fast-function (lambda-expression)
2034  (let ((lambda-list (allow-other-keys (cadr lambda-expression))))
2035    (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))
2036      (return-from compute-method-fast-function nil))
2037    ;; Only required args.
2038    (let ((body (cddr lambda-expression))
2039          (*call-next-method-p* nil)
2040          (*next-method-p-p* nil))
2041      (multiple-value-bind (body declarations) (parse-body body)
2042        (walk-form body)
2043        (when (or *call-next-method-p* *next-method-p-p*)
2044          (return-from compute-method-fast-function nil))
2045        (let ((decls `(declare (ignorable ,@lambda-list))))
2046          (setf lambda-expression
2047                (list* (car lambda-expression)
2048                       (cadr lambda-expression)
2049                       decls
2050                       (cddr lambda-expression))))
2051        (case (length lambda-list)
2052          (1
2053;;            `(lambda (args next-emfun)
2054;;               (let ((,(%car lambda-list) (%car args)))
2055;;                 (declare (ignorable ,(%car lambda-list)))
2056;;                 ,@declarations ,@body)))
2057           lambda-expression)
2058          (2
2059;;            `(lambda (args next-emfun)
2060;;               (let ((,(%car lambda-list) (%car args))
2061;;                     (,(%cadr lambda-list) (%cadr args)))
2062;;                 (declare (ignorable ,(%car lambda-list)
2063;;                                     ,(%cadr lambda-list)))
2064;;                 ,@declarations ,@body)))
2065           lambda-expression)
2066;;           (3
2067;;            `(lambda (args next-emfun)
2068;;               (let ((,(%car lambda-list) (%car args))
2069;;                     (,(%cadr lambda-list) (%cadr args))
2070;;                     (,(%caddr lambda-list) (%caddr args)))
2071;;                 (declare (ignorable ,(%car lambda-list)
2072;;                                     ,(%cadr lambda-list)
2073;;                                     ,(%caddr lambda-list)))
2074;;                 ,@declarations ,@body)))
2075          (t
2076           nil))))))
2077
2078;; From CLHS section 7.6.5:
2079;; "When a generic function or any of its methods mentions &key in a lambda
2080;; list, the specific set of keyword arguments accepted by the generic function
2081;; varies according to the applicable methods. The set of keyword arguments
2082;; accepted by the generic function for a particular call is the union of the
2083;; keyword arguments accepted by all applicable methods and the keyword
2084;; arguments mentioned after &key in the generic function definition, if any."
2085;; Adapted from Sacla.
2086(defun allow-other-keys (lambda-list)
2087  (if (and (member '&key lambda-list)
2088           (not (member '&allow-other-keys lambda-list)))
2089      (let* ((key-end (or (position '&aux lambda-list) (length lambda-list)))
2090             (aux-part (subseq lambda-list key-end)))
2091        `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
2092      lambda-list))
2093
2094(defmacro defmethod (&rest args)
2095  (multiple-value-bind
2096      (function-name qualifiers lambda-list specializers documentation declarations body)
2097      (parse-defmethod args)
2098    (let* ((specializers-form '())
2099           (lambda-expression `(lambda ,lambda-list ,@declarations ,body))
2100           (method-function (compute-method-function lambda-expression))
2101           (fast-function (compute-method-fast-function lambda-expression))
2102           )
2103      (dolist (specializer specializers)
2104        (cond ((and (consp specializer) (eq (car specializer) 'eql))
2105               (push `(list 'eql ,(cadr specializer)) specializers-form))
2106              (t
2107               (push `',specializer specializers-form))))
2108      (setf specializers-form `(list ,@(nreverse specializers-form)))
2109      `(progn
2110         (ensure-method ',function-name
2111                        :lambda-list ',lambda-list
2112                        :qualifiers ',qualifiers
2113                        :specializers ,specializers-form
2114                        ,@(if documentation `(:documentation ,documentation))
2115                        :function (function ,method-function)
2116                        ,@(if fast-function `(:fast-function (function ,fast-function)))
2117                        )))))
2118
2119;;; Reader and writer methods
2120
2121(defun make-instance-standard-reader-method (gf
2122                                             &key
2123                                             lambda-list
2124                                             qualifiers
2125                                             specializers
2126                                             documentation
2127                                             function
2128                                             fast-function
2129                                             slot-name)
2130  (declare (ignore gf))
2131  (let ((method (std-allocate-instance +the-standard-reader-method-class+)))
2132    (setf (method-lambda-list method) lambda-list)
2133    (setf (method-qualifiers method) qualifiers)
2134    (%set-method-specializers method (canonicalize-specializers specializers))
2135    (setf (method-documentation method) documentation)
2136    (%set-method-generic-function method nil)
2137    (%set-method-function method function)
2138    (%set-method-fast-function method fast-function)
2139    (set-reader-method-slot-name method slot-name)
2140    method))
2141
2142(defun add-reader-method (class function-name slot-name)
2143  (let* ((lambda-expression
2144          (if (eq (class-of class) +the-standard-class+)
2145              `(lambda (object) (std-slot-value object ',slot-name))
2146              `(lambda (object) (slot-value object ',slot-name))))
2147         (method-function (compute-method-function lambda-expression))
2148         (fast-function (compute-method-fast-function lambda-expression)))
2149    (let ((method-lambda-list '(object))
2150          (gf (find-generic-function function-name nil)))
2151      (if gf
2152          (check-method-lambda-list function-name
2153                                    method-lambda-list
2154                                    (generic-function-lambda-list gf))
2155        (setf gf (ensure-generic-function function-name :lambda-list method-lambda-list)))
2156      (let ((method
2157             (make-instance-standard-reader-method gf
2158                                                   :lambda-list '(object)
2159                                                   :qualifiers ()
2160                                                   :specializers (list class)
2161                                                   :function (if (autoloadp 'compile)
2162                                                                 method-function
2163                                                                 (autocompile method-function))
2164                                                   :fast-function (if (autoloadp 'compile)
2165                                                                      fast-function
2166                                                                      (autocompile fast-function))
2167                                                   :slot-name slot-name)))
2168        (%add-method gf method)
2169        method))))
2170
2171(defun add-writer-method (class function-name slot-name)
2172  (let* ((lambda-expression
2173          (if (eq (class-of class) +the-standard-class+)
2174              `(lambda (new-value object)
2175                 (setf (std-slot-value object ',slot-name) new-value))
2176              `(lambda (new-value object)
2177                 (setf (slot-value object ',slot-name) new-value))))
2178         (method-function (compute-method-function lambda-expression))
2179         (fast-function (compute-method-fast-function lambda-expression))
2180         )
2181    (ensure-method function-name
2182                   :lambda-list '(new-value object)
2183                   :qualifiers ()
2184                   :specializers (list +the-T-class+ class)
2185;;                    :function `(function ,method-function)
2186                   :function (if (autoloadp 'compile)
2187                                 method-function
2188                                 (autocompile method-function))
2189                   :fast-function (if (autoloadp 'compile)
2190                                      fast-function
2191                                      (autocompile fast-function))
2192                   )))
2193
2194(defmacro redefine-class-forwarder (name slot &optional alternative-name)
2195  (let* (($name (if (consp name) (cadr name) name))
2196         (%name (intern (concatenate 'string
2197                                     "%"
2198                                     (if (consp name)
2199                                         (symbol-name 'set-) "")
2200                                     (symbol-name $name))
2201                        (find-package "SYS"))))
2202    (unless alternative-name
2203      (setf alternative-name name))
2204    (if (consp name)
2205        `(progn ;; setter
2206           (defgeneric ,alternative-name (new-value class))
2207           (defmethod ,alternative-name (new-value (class built-in-class))
2208             (,%name new-value class))
2209           (defmethod ,alternative-name (new-value (class forward-referenced-class))
2210             (,%name new-value class))
2211           (defmethod ,alternative-name (new-value (class structure-class))
2212             (,%name new-value class))
2213           (defmethod ,alternative-name (new-value (class standard-class))
2214             (setf (slot-value class ',slot) new-value))
2215           ,@(unless (eq name alternative-name)
2216                     `((setf (get ',$name 'SETF-FUNCTION)
2217                             (symbol-function ',alternative-name))))
2218           )
2219        `(progn ;; getter
2220           (defgeneric ,alternative-name (class))
2221           (defmethod ,alternative-name ((class built-in-class))
2222             (,%name class))
2223           (defmethod ,alternative-name ((class forward-referenced-class))
2224             (,%name class))
2225           (defmethod ,alternative-name ((class structure-class))
2226             (,%name class))
2227           (defmethod ,alternative-name ((class standard-class))
2228             (slot-value class ',slot))
2229           ,@(unless (eq name alternative-name)
2230                     `((setf (symbol-function ',$name)
2231                             (symbol-function ',alternative-name))))
2232           ) )))
2233
2234(redefine-class-forwarder class-name name)
2235(redefine-class-forwarder (setf class-name) name)
2236(redefine-class-forwarder class-slots slots)
2237(redefine-class-forwarder (setf class-slots) slots)
2238(redefine-class-forwarder class-direct-slots direct-slots)
2239(redefine-class-forwarder (setf class-direct-slots) direct-slots)
2240(redefine-class-forwarder class-layout layout)
2241(redefine-class-forwarder (setf class-layout) layout)
2242(redefine-class-forwarder class-direct-superclasses direct-superclasses)
2243(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
2244(redefine-class-forwarder class-direct-subclasses direct-subclasses)
2245(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
2246(redefine-class-forwarder class-direct-methods direct-methods !class-direct-methods)
2247(redefine-class-forwarder (setf class-direct-methods) direct-methods !!class-direct-methods)
2248(redefine-class-forwarder class-precedence-list precedence-list)
2249(redefine-class-forwarder (setf class-precedence-list) precedence-list)
2250(redefine-class-forwarder class-finalized-p finalized-p)
2251(redefine-class-forwarder (setf class-finalized-p) finalized-p)
2252(redefine-class-forwarder class-default-initargs default-initargs)
2253(redefine-class-forwarder (setf class-default-initargs) default-initargs)
2254(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
2255(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
2256
2257(defgeneric direct-slot-definition-class (class &rest initargs))
2258
2259(defmethod direct-slot-definition-class ((class class) &rest initargs)
2260  (declare (ignore initargs))
2261  +the-direct-slot-definition-class+)
2262
2263(defgeneric effective-slot-definition-class (class &rest initargs))
2264
2265(defmethod effective-slot-definition-class ((class class) &rest initargs)
2266  (declare (ignore initargs))
2267  +the-effective-slot-definition-class+)
2268
2269(fmakunbound 'documentation)
2270(defgeneric documentation (x doc-type))
2271
2272(defgeneric (setf documentation) (new-value x doc-type))
2273
2274(defmethod documentation ((x symbol) doc-type)
2275  (%documentation x doc-type))
2276
2277(defmethod (setf documentation) (new-value (x symbol) doc-type)
2278  (%set-documentation x doc-type new-value))
2279
2280(defmethod documentation ((x function) doc-type)
2281  (%documentation x doc-type))
2282
2283(defmethod (setf documentation) (new-value (x function) doc-type)
2284  (%set-documentation x doc-type new-value))
2285
2286;; FIXME This should be a weak hashtable!
2287(defvar *list-documentation-hashtable* (make-hash-table :test #'equal))
2288
2289(defmethod documentation ((x list) (doc-type (eql 'function)))
2290  (let ((alist (gethash x *list-documentation-hashtable*)))
2291    (and alist (cdr (assoc doc-type alist)))))
2292
2293(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
2294  (let ((alist (gethash x *list-documentation-hashtable*)))
2295    (and alist (cdr (assoc doc-type alist)))))
2296
2297(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
2298  (let* ((alist (gethash x *list-documentation-hashtable*))
2299         (entry (and alist (assoc doc-type alist))))
2300    (cond (entry
2301           (setf (cdr entry) new-value))
2302          (t
2303           (setf (gethash x *list-documentation-hashtable*)
2304                 (push (cons doc-type new-value) alist)))))
2305  new-value)
2306
2307(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
2308  (let* ((alist (gethash x *list-documentation-hashtable*))
2309         (entry (and alist (assoc doc-type alist))))
2310    (cond (entry
2311           (setf (cdr entry) new-value))
2312          (t
2313           (setf (gethash x *list-documentation-hashtable*)
2314                 (push (cons doc-type new-value) alist)))))
2315  new-value)
2316
2317(defmethod documentation ((x standard-class) (doc-type (eql 't)))
2318  (class-documentation x))
2319
2320(defmethod documentation ((x standard-class) (doc-type (eql 'type)))
2321  (class-documentation x))
2322
2323(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't)))
2324  (%set-class-documentation x new-value))
2325
2326(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type)))
2327  (%set-class-documentation x new-value))
2328
2329(defmethod documentation ((x structure-class) (doc-type (eql 't)))
2330  (%documentation x doc-type))
2331
2332(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
2333  (%documentation x doc-type))
2334
2335(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
2336  (%set-documentation x doc-type new-value))
2337
2338(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
2339  (%set-documentation x doc-type new-value))
2340
2341(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
2342  (generic-function-documentation x))
2343
2344(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
2345  (setf (generic-function-documentation x) new-value))
2346
2347(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
2348  (generic-function-documentation x))
2349
2350(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
2351  (setf (generic-function-documentation x) new-value))
2352
2353(defmethod documentation ((x standard-method) (doc-type (eql 't)))
2354  (method-documentation x))
2355
2356(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
2357  (setf (method-documentation x) new-value))
2358
2359(defmethod documentation ((x package) (doc-type (eql 't)))
2360  (%documentation x doc-type))
2361
2362(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
2363  (%set-documentation x doc-type new-value))
2364
2365;;; Applicable methods
2366
2367(defgeneric compute-applicable-methods (gf args)
2368  (:method ((gf standard-generic-function) args)
2369    (%compute-applicable-methods gf args)))
2370
2371(defgeneric compute-applicable-methods-using-classes (gf classes)
2372  (:method ((gf standard-generic-function) classes)
2373    (let ((methods '()))
2374      (dolist (method (generic-function-methods gf))
2375  (multiple-value-bind (applicable knownp)
2376      (method-applicable-using-classes-p method classes)
2377    (cond (applicable
2378     (push method methods))
2379    ((not knownp)
2380     (return-from compute-applicable-methods-using-classes
2381       (values nil nil))))))
2382      (values (sort-methods methods gf classes)
2383        t))))
2384
2385(export '(compute-applicable-methods
2386    compute-applicable-methods-using-classes))
2387
2388
2389;;; Slot access
2390
2391(defun set-slot-value-using-class (new-value class instance slot-name)
2392  (declare (ignore class)) ; FIXME
2393  (setf (std-slot-value instance slot-name) new-value))
2394
2395(defgeneric slot-value-using-class (class instance slot-name))
2396
2397(defmethod slot-value-using-class ((class standard-class) instance slot-name)
2398  (std-slot-value instance slot-name))
2399
2400(defmethod slot-value-using-class ((class structure-class) instance slot-name)
2401  (std-slot-value instance slot-name))
2402
2403(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
2404
2405(defmethod (setf slot-value-using-class) (new-value
2406                                          (class standard-class)
2407                                          instance
2408                                          slot-name)
2409  (setf (std-slot-value instance slot-name) new-value))
2410
2411(defmethod (setf slot-value-using-class) (new-value
2412                                          (class structure-class)
2413                                          instance
2414                                          slot-name)
2415  (setf (std-slot-value instance slot-name) new-value))
2416
2417(defgeneric slot-exists-p-using-class (class instance slot-name))
2418
2419(defmethod slot-exists-p-using-class (class instance slot-name)
2420  nil)
2421
2422(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
2423  (std-slot-exists-p instance slot-name))
2424
2425(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
2426  (dolist (dsd (class-slots class))
2427    (when (eq (sys::dsd-name dsd) slot-name)
2428      (return-from slot-exists-p-using-class t)))
2429  nil)
2430
2431(defgeneric slot-boundp-using-class (class instance slot-name))
2432(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
2433  (std-slot-boundp instance slot-name))
2434(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
2435  "Structure slots can't be unbound, so this method always returns T."
2436  (declare (ignore class instance slot-name))
2437  t)
2438
2439(defgeneric slot-makunbound-using-class (class instance slot-name))
2440(defmethod slot-makunbound-using-class ((class standard-class)
2441                                        instance
2442                                        slot-name)
2443  (std-slot-makunbound instance slot-name))
2444(defmethod slot-makunbound-using-class ((class structure-class)
2445                                        instance
2446                                        slot-name)
2447  (declare (ignore class instance slot-name))
2448  (error "Structure slots can't be unbound"))
2449
2450(defgeneric slot-missing (class instance slot-name operation &optional new-value))
2451
2452(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
2453  (declare (ignore new-value))
2454  (error "The slot ~S is missing from the class ~S." slot-name class))
2455
2456(defgeneric slot-unbound (class instance slot-name))
2457
2458(defmethod slot-unbound ((class t) instance slot-name)
2459  (error 'unbound-slot :instance instance :name slot-name))
2460
2461;;; Instance creation and initialization
2462
2463(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
2464
2465(defmethod allocate-instance ((class standard-class) &rest initargs)
2466  (declare (ignore initargs))
2467  (std-allocate-instance class))
2468
2469(defmethod allocate-instance ((class structure-class) &rest initargs)
2470  (declare (ignore initargs))
2471  (%make-structure (class-name class)
2472                   (make-list (length (class-slots class))
2473                              :initial-element +slot-unbound+)))
2474
2475;; "The set of valid initialization arguments for a class is the set of valid
2476;; initialization arguments that either fill slots or supply arguments to
2477;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
2478;; 7.1.2
2479
2480(defun check-initargs (instance shared-initialize-param initargs)
2481  (when (oddp (length initargs))
2482    (error 'program-error
2483           :format-control "Odd number of keyword arguments."))
2484  (unless (getf initargs :allow-other-keys)
2485    (let ((methods 
2486     (nconc 
2487      (compute-applicable-methods 
2488       #'shared-initialize
2489       (if initargs
2490     `(,instance ,shared-initialize-param ,@initargs)
2491         (list instance shared-initialize-param)))
2492      (compute-applicable-methods 
2493       #'initialize-instance
2494       (if initargs
2495     `(,instance ,@initargs)
2496         (list instance)))))
2497    (slots (class-slots (class-of instance))))
2498      (do* ((tail initargs (cddr tail))
2499            (initarg (car tail) (car tail)))
2500           ((null tail))
2501        (unless (or (valid-initarg-p initarg slots)
2502        (valid-methodarg-p initarg methods)
2503                    (eq initarg :allow-other-keys))
2504          (error 'program-error
2505                 :format-control "Invalid initarg ~S."
2506                 :format-arguments (list initarg)))))))
2507
2508(defun valid-methodarg-p (initarg methods)
2509  (when (symbolp initarg)
2510    (dolist (method methods nil)
2511      (let ((valid-initargs (method-lambda-list method)))
2512  (when (find (symbol-value initarg) valid-initargs 
2513         :test #'(lambda (a b)
2514             (if (listp b)
2515           (string= a (car b))
2516         (or
2517          (string= a b)
2518          (string= b "&ALLOW-OTHER-KEYS")))))
2519
2520    (return t))))))
2521
2522(defun valid-initarg-p (initarg slots)
2523  (dolist (slot slots nil)
2524    (let ((valid-initargs (slot-definition-initargs slot)))
2525      (when (memq initarg valid-initargs)
2526        (return t)))))
2527
2528(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
2529
2530(defmethod make-instance ((class standard-class) &rest initargs)
2531  (when (oddp (length initargs))
2532    (error 'program-error :format-control "Odd number of keyword arguments."))
2533  (unless (class-finalized-p class)
2534    (std-finalize-inheritance class))
2535  (let ((class-default-initargs (class-default-initargs class)))
2536    (when class-default-initargs
2537      (let ((default-initargs '()))
2538        (do* ((list class-default-initargs (cddr list))
2539              (key (car list) (car list))
2540              (fn (cadr list) (cadr list)))
2541             ((null list))
2542          (when (eq (getf initargs key 'not-found) 'not-found)
2543            (setf default-initargs (append default-initargs (list key (funcall fn))))))
2544        (setf initargs (append initargs default-initargs)))))
2545
2546  (let ((instance (std-allocate-instance class)))
2547    (check-initargs instance t initargs)
2548    (apply #'initialize-instance instance initargs)
2549    instance))
2550
2551(defmethod make-instance ((class symbol) &rest initargs)
2552  (apply #'make-instance (find-class class) initargs))
2553
2554(defgeneric initialize-instance (instance &key))
2555
2556(defmethod initialize-instance ((instance standard-object) &rest initargs)
2557  (apply #'shared-initialize instance t initargs))
2558
2559(defgeneric reinitialize-instance (instance &key))
2560
2561;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the
2562;; validity of initargs and signals an error if an initarg is supplied that is
2563;; not declared as valid. The method then calls the generic function SHARED-
2564;; INITIALIZE with the following arguments: the instance, nil (which means no
2565;; slots should be initialized according to their initforms), and the initargs
2566;; it received."
2567(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2568  (apply #'shared-initialize instance () initargs))
2569
2570(defun std-shared-initialize (instance slot-names all-keys)
2571  (when (oddp (length all-keys))
2572    (error 'program-error :format-control "Odd number of keyword arguments."))
2573  (do* ((tail all-keys (cddr tail))
2574  (initarg (car tail) (car tail)))
2575      ((null tail))
2576    (when (and initarg (not (symbolp initarg)))
2577      (error 'program-error
2578       :format-control "Invalid initarg ~S."
2579       :format-arguments (list initarg))))
2580  (dolist (slot (class-slots (class-of instance)))
2581    (let ((slot-name (slot-definition-name slot)))
2582      (multiple-value-bind (init-key init-value foundp)
2583          (get-properties all-keys (slot-definition-initargs slot))
2584        (if foundp
2585            (setf (std-slot-value instance slot-name) init-value)
2586            (unless (std-slot-boundp instance slot-name)
2587              (let ((initfunction (slot-definition-initfunction slot)))
2588                (when (and initfunction (or (eq slot-names t)
2589                                            (memq slot-name slot-names)))
2590                  (setf (std-slot-value instance slot-name)
2591                        (funcall initfunction)))))))))
2592  instance)
2593
2594(defgeneric shared-initialize (instance slot-names &key))
2595
2596(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
2597  (std-shared-initialize instance slot-names initargs))
2598
2599(defmethod shared-initialize ((slot slot-definition) slot-names
2600            &rest args
2601            &key name initargs initform initfunction
2602            readers writers allocation
2603            &allow-other-keys)
2604  ;;Keyword args are duplicated from init-slot-definition only to have
2605  ;;them checked.
2606  (declare (ignore slot-names)) ;;TODO?
2607  (declare (ignore name initargs initform initfunction readers writers allocation))
2608  ;;For built-in slots
2609  (apply #'init-slot-definition slot :allow-other-keys t args)
2610  ;;For user-defined slots
2611  (call-next-method))
2612
2613;;; change-class
2614
2615(defgeneric change-class (instance new-class &key))
2616
2617(defmethod change-class ((old-instance standard-object) (new-class standard-class)
2618                         &rest initargs)
2619  (let ((old-slots (class-slots (class-of old-instance)))
2620        (new-slots (class-slots new-class))
2621        (new-instance (allocate-instance new-class)))
2622    ;; "The values of local slots specified by both the class CTO and the class
2623    ;; CFROM are retained. If such a local slot was unbound, it remains
2624    ;; unbound."
2625    (dolist (new-slot new-slots)
2626      (when (instance-slot-p new-slot)
2627        (let* ((slot-name (slot-definition-name new-slot))
2628               (old-slot (find slot-name old-slots :key 'slot-definition-name)))
2629          ;; "The values of slots specified as shared in the class CFROM and as
2630          ;; local in the class CTO are retained."
2631          (when (and old-slot (slot-boundp old-instance slot-name))
2632            (setf (slot-value new-instance slot-name)
2633                  (slot-value old-instance slot-name))))))
2634    (swap-slots old-instance new-instance)
2635    (rotatef (std-instance-layout new-instance)
2636             (std-instance-layout old-instance))
2637    (apply #'update-instance-for-different-class
2638           new-instance old-instance initargs)
2639    old-instance))
2640
2641(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
2642  (apply #'change-class instance (find-class new-class) initargs))
2643
2644(defgeneric update-instance-for-different-class (old new &key))
2645
2646(defmethod update-instance-for-different-class
2647  ((old standard-object) (new standard-object) &rest initargs)
2648  (let ((added-slots
2649         (remove-if #'(lambda (slot-name)
2650                       (slot-exists-p old slot-name))
2651                    (mapcar 'slot-definition-name
2652                            (class-slots (class-of new))))))
2653    (check-initargs new added-slots initargs)
2654    (apply #'shared-initialize new added-slots initargs)))
2655
2656;;; make-instances-obsolete
2657
2658(defgeneric make-instances-obsolete (class))
2659
2660(defmethod make-instances-obsolete ((class standard-class))
2661  (%make-instances-obsolete class))
2662
2663(defmethod make-instances-obsolete ((class symbol))
2664  (make-instances-obsolete (find-class class))
2665  class)
2666
2667;;; update-instance-for-redefined-class
2668
2669(defgeneric update-instance-for-redefined-class (instance
2670                                                 added-slots
2671                                                 discarded-slots
2672                                                 property-list
2673                                                 &rest initargs
2674                                                 &key
2675                                                 &allow-other-keys))
2676
2677(defmethod update-instance-for-redefined-class ((instance standard-object)
2678            added-slots
2679            discarded-slots
2680            property-list
2681            &rest initargs)
2682  (check-initargs instance added-slots initargs)
2683  (apply #'shared-initialize instance added-slots initargs))
2684
2685;;;  Methods having to do with class metaobjects.
2686
2687(defmethod initialize-instance :after ((class standard-class) &rest args)
2688  (apply #'std-after-initialization-for-classes class args))
2689
2690;;; Finalize inheritance
2691
2692(defgeneric finalize-inheritance (class))
2693
2694(defmethod finalize-inheritance ((class standard-class))
2695  (std-finalize-inheritance class))
2696
2697;;; Class precedence lists
2698
2699(defgeneric compute-class-precedence-list (class))
2700(defmethod compute-class-precedence-list ((class standard-class))
2701  (std-compute-class-precedence-list class))
2702
2703;;; Slot inheritance
2704
2705(defgeneric compute-slots (class))
2706(defmethod compute-slots ((class standard-class))
2707  (std-compute-slots class))
2708
2709(defgeneric compute-effective-slot-definition (class direct-slots))
2710(defmethod compute-effective-slot-definition
2711  ((class standard-class) direct-slots)
2712  (std-compute-effective-slot-definition class direct-slots))
2713
2714;;; Methods having to do with generic function metaobjects.
2715
2716(defmethod initialize-instance :after ((gf standard-generic-function) &key)
2717  (finalize-generic-function gf))
2718
2719;;; Methods having to do with generic function invocation.
2720
2721(defgeneric compute-discriminating-function (gf))
2722(defmethod compute-discriminating-function ((gf standard-generic-function))
2723  (std-compute-discriminating-function gf))
2724
2725(defgeneric method-more-specific-p (gf method1 method2 required-classes))
2726
2727(defmethod method-more-specific-p ((gf standard-generic-function)
2728                                   method1 method2 required-classes)
2729  (std-method-more-specific-p method1 method2 required-classes
2730                              (generic-function-argument-precedence-order gf)))
2731
2732;;; XXX AMOP has COMPUTE-EFFECTIVE-METHOD
2733(defgeneric compute-effective-method-function (gf methods))
2734(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
2735  (std-compute-effective-method-function gf methods))
2736
2737(defgeneric compute-applicable-methods (gf args))
2738(defmethod compute-applicable-methods ((gf standard-generic-function) args)
2739  (%compute-applicable-methods gf args))
2740
2741;;; Slot definition accessors
2742
2743(map nil (lambda (sym)
2744     (fmakunbound sym) ;;we need to redefine them as GFs
2745     (fmakunbound `(setf ,sym))
2746     (export sym))
2747  '(slot-definition-allocation 
2748    slot-definition-initargs
2749    slot-definition-initform
2750    slot-definition-initfunction
2751    slot-definition-name
2752    slot-definition-readers
2753    slot-definition-writers
2754    slot-definition-allocation-class))
2755
2756(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
2757  `(let (($cl (class-of ,slot-definition)))
2758     (case $cl
2759       ((+the-slot-definition-class+
2760   +the-direct-slot-definition-class+
2761   +the-effective-slot-definition-class+)
2762  ,std-form)
2763       (t ,generic-form))))
2764
2765(defgeneric slot-definition-allocation (slot-definition)
2766  (:method ((slot-definition slot-definition))
2767    (slot-definition-dispatch slot-definition
2768      (%slot-definition-allocation slot-definition)
2769      (slot-value slot-definition 'sys::allocation))))
2770
2771(defgeneric (setf slot-definition-allocation) (value slot-definition)
2772  (:method (value (slot-definition slot-definition))
2773    (slot-definition-dispatch slot-definition
2774      (set-slot-definition-allocation slot-definition value)
2775      (setf (slot-value slot-definition 'sys::allocation) value))))
2776
2777(defgeneric slot-definition-initargs (slot-definition)
2778  (:method ((slot-definition slot-definition))
2779    (slot-definition-dispatch slot-definition
2780      (%slot-definition-initargs slot-definition)
2781      (slot-value slot-definition 'sys::initargs))))
2782
2783(defgeneric (setf slot-definition-initargs) (value slot-definition)
2784  (:method (value (slot-definition slot-definition))
2785    (slot-definition-dispatch slot-definition
2786      (set-slot-definition-initargs slot-definition value)
2787      (setf (slot-value slot-definition 'sys::initargs) value))))
2788
2789(defgeneric slot-definition-initform (slot-definition)
2790  (:method ((slot-definition slot-definition))
2791    (slot-definition-dispatch slot-definition
2792      (%slot-definition-initform slot-definition)
2793      (slot-value slot-definition 'sys::initform))))
2794
2795(defgeneric (setf slot-definition-initform) (value slot-definition)
2796  (:method (value (slot-definition slot-definition))
2797    (slot-definition-dispatch slot-definition
2798      (set-slot-definition-initform slot-definition value)
2799      (setf (slot-value slot-definition 'sys::initform) value))))
2800
2801(defgeneric slot-definition-initfunction (slot-definition)
2802  (:method ((slot-definition slot-definition))
2803    (slot-definition-dispatch slot-definition
2804      (%slot-definition-initfunction slot-definition)
2805      (slot-value slot-definition 'sys::initfunction))))
2806
2807(defgeneric (setf slot-definition-initfunction) (value slot-definition)
2808  (:method (value (slot-definition slot-definition))
2809    (slot-definition-dispatch slot-definition
2810      (set-slot-definition-initfunction slot-definition value)
2811      (setf (slot-value slot-definition 'sys::initfunction) value))))
2812
2813(defgeneric slot-definition-name (slot-definition)
2814  (:method ((slot-definition slot-definition))
2815    (slot-definition-dispatch slot-definition
2816      (%slot-definition-name slot-definition)
2817      (slot-value slot-definition 'sys::name))))
2818
2819(defgeneric (setf slot-definition-name) (value slot-definition)
2820  (:method (value (slot-definition slot-definition))
2821    (slot-definition-dispatch slot-definition
2822      (set-slot-definition-name slot-definition value)
2823      (setf (slot-value slot-definition 'sys::name) value))))
2824
2825(defgeneric slot-definition-readers (slot-definition)
2826  (:method ((slot-definition slot-definition))
2827    (slot-definition-dispatch slot-definition
2828      (%slot-definition-readers slot-definition)
2829      (slot-value slot-definition 'sys::readers))))
2830
2831(defgeneric (setf slot-definition-readers) (value slot-definition)
2832  (:method (value (slot-definition slot-definition))
2833    (slot-definition-dispatch slot-definition
2834      (set-slot-definition-readers slot-definition value)
2835      (setf (slot-value slot-definition 'sys::readers) value))))
2836
2837(defgeneric slot-definition-writers (slot-definition)
2838  (:method ((slot-definition slot-definition))
2839    (slot-definition-dispatch slot-definition
2840      (%slot-definition-writers slot-definition)
2841      (slot-value slot-definition 'sys::writers))))
2842
2843(defgeneric (setf slot-definition-writers) (value slot-definition)
2844  (:method (value (slot-definition slot-definition))
2845    (slot-definition-dispatch slot-definition
2846      (set-slot-definition-writers slot-definition value)
2847      (setf (slot-value slot-definition 'sys::writers) value))))
2848
2849(defgeneric slot-definition-allocation-class (slot-definition)
2850  (:method ((slot-definition slot-definition))
2851    (slot-definition-dispatch slot-definition
2852      (%slot-definition-allocation-class slot-definition)
2853      (slot-value slot-definition 'sys::allocation-class))))
2854
2855(defgeneric (setf slot-definition-allocation-class) (value slot-definition)
2856  (:method (value (slot-definition slot-definition))
2857    (slot-definition-dispatch slot-definition
2858      (set-slot-definition-allocation-class slot-definition value)
2859      (setf (slot-value slot-definition 'sys::allocation-class) value))))
2860
2861(defgeneric slot-definition-location (slot-definition)
2862  (:method ((slot-definition slot-definition))
2863    (slot-definition-dispatch slot-definition
2864      (%slot-definition-location slot-definition)
2865      (slot-value slot-definition 'sys::location))))
2866
2867(defgeneric (setf slot-definition-location) (value slot-definition)
2868  (:method (value (slot-definition slot-definition))
2869    (slot-definition-dispatch slot-definition
2870      (set-slot-definition-location slot-definition value)
2871      (setf (slot-value slot-definition 'sys::location) value))))
2872
2873;;; No %slot-definition-type.
2874
2875
2876;;; Conditions.
2877
2878(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
2879  (let ((parent-types (or parent-types '(condition)))
2880        (report nil))
2881    (dolist (option options)
2882      (when (eq (car option) :report)
2883        (setf report (cadr option))
2884  (setf options (delete option options :test #'equal))
2885        (return)))
2886    (typecase report
2887      (null
2888       `(progn
2889          (defclass ,name ,parent-types ,slot-specs ,@options)
2890          ',name))
2891      (string
2892       `(progn
2893          (defclass ,name ,parent-types ,slot-specs ,@options)
2894          (defmethod print-object ((condition ,name) stream)
2895            (if *print-escape*
2896                (call-next-method)
2897                (progn (write-string ,report stream) condition)))
2898          ',name))
2899      (t
2900       `(progn
2901          (defclass ,name ,parent-types ,slot-specs ,@options)
2902          (defmethod print-object ((condition ,name) stream)
2903            (if *print-escape*
2904                (call-next-method)
2905                (funcall #',report condition stream)))
2906          ',name)))))
2907
2908(defun make-condition (type &rest initargs)
2909  (or (%make-condition type initargs)
2910      (let ((class (if (symbolp type) (find-class type) type)))
2911        (apply #'make-instance class initargs))))
2912
2913;; Adapted from SBCL.
2914;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
2915(defun coerce-to-condition (datum arguments default-type fun-name)
2916  (cond ((typep datum 'condition)
2917         (when arguments
2918           (error 'simple-type-error
2919                  :datum arguments
2920                  :expected-type 'null
2921                  :format-control "You may not supply additional arguments when giving ~S to ~S."
2922                  :format-arguments (list datum fun-name)))
2923         datum)
2924        ((symbolp datum)
2925         (apply #'make-condition datum arguments))
2926        ((or (stringp datum) (functionp datum))
2927         (make-condition default-type
2928                         :format-control datum
2929                         :format-arguments arguments))
2930        (t
2931         (error 'simple-type-error
2932                :datum datum
2933                :expected-type '(or symbol string)
2934                :format-control "Bad argument to ~S: ~S."
2935                :format-arguments (list fun-name datum)))))
2936
2937(defgeneric make-load-form (object &optional environment))
2938
2939(defmethod make-load-form ((object t) &optional environment)
2940  (declare (ignore environment))
2941  (apply #'no-applicable-method #'make-load-form (list object)))
2942
2943(defmethod make-load-form ((class class) &optional environment)
2944  (declare (ignore environment))
2945  (let ((name (class-name class)))
2946    (unless (and name (eq (find-class name nil) class))
2947      (error 'simple-type-error
2948             :format-control "Can't use anonymous or undefined class as a constant: ~S."
2949             :format-arguments (list class)))
2950    `(find-class ',name)))
2951
2952(defun invalid-method-error (method format-control &rest args)
2953  (let ((message (apply #'format nil format-control args)))
2954    (error "Invalid method error for ~S:~%    ~A" method message)))
2955
2956(defun method-combination-error (format-control &rest args)
2957  (let ((message (apply #'format nil format-control args)))
2958    (error "Method combination error in CLOS dispatch:~%    ~A" message)))
2959
2960(fmakunbound 'no-applicable-method)
2961(defgeneric no-applicable-method (generic-function &rest args))
2962
2963(defmethod no-applicable-method (generic-function &rest args)
2964  (error "There is no applicable method for the generic function ~S when called with arguments ~S."
2965         generic-function
2966         args))
2967
2968(defgeneric find-method (generic-function
2969                         qualifiers
2970                         specializers
2971                         &optional errorp))
2972
2973(defmethod find-method ((generic-function standard-generic-function)
2974                        qualifiers specializers &optional (errorp t))
2975  (%find-method generic-function qualifiers specializers errorp))
2976
2977(defgeneric add-method (generic-function method))
2978
2979(defmethod add-method ((generic-function standard-generic-function)
2980                       (method method))
2981  (let ((method-lambda-list (method-lambda-list method))
2982        (gf-lambda-list (generic-function-lambda-list generic-function)))
2983    (check-method-lambda-list (%generic-function-name generic-function)
2984                              method-lambda-list gf-lambda-list))
2985  (%add-method generic-function method))
2986
2987(defgeneric remove-method (generic-function method))
2988
2989(defmethod remove-method ((generic-function standard-generic-function) method)
2990  (%remove-method generic-function method))
2991
2992;; See describe.lisp.
2993(defgeneric describe-object (object stream))
2994
2995;; FIXME
2996(defgeneric no-next-method (generic-function method &rest args))
2997
2998;; FIXME
2999(defgeneric function-keywords (method))
3000
3001(setf *clos-booting* nil)
3002
3003(defgeneric class-prototype (class))
3004
3005(defmethod class-prototype :before (class)
3006  (unless (class-finalized-p class)
3007    (error "~@<~S is not finalized.~:@>" class)))
3008
3009(defmethod class-prototype ((class standard-class))
3010  (allocate-instance class))
3011
3012(defmethod class-prototype ((class structure-class))
3013  (allocate-instance class))
3014
3015(provide 'clos)
Note: See TracBrowser for help on using the repository browser.