Context Navigation

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

Visit:

Last change on this file since 13206 was 13206, checked in by ehuelsmann, 13 years ago
Simplify argument passing in CHECK-INITARGS.
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 130.0 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: