Context Navigation

clos.lisp

Visit:

Last change on this file was 13376, checked in by Mark Evenson, 14 years ago

Implement MOP:VALIDATE-SUPERCLASS.

Start breaking out MOP defintions into separate 'mop.lisp' file.

Property svn:eol-style set to native
Property svn:keywords set to Id

File size: 135.0 KB

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

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

Context Navigation

source: branches/0.27.x/abcl/src/org/armedbear/lisp/clos.lisp

Download in other formats: