Context Navigation

clos.lisp @ 13219

Visit:

Last change on this file since 13219 was 13219, checked in by ehuelsmann, 13 years ago

Add caching to CHECK-INITARGS: cache sets of allowable initargs
per class.

Note: This change *only* implements caching for "case 1" out of the 4
cases that check-initargs now supports. (Case 1 being instance creation.)

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

File size: 134.5 KB

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

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

Context Navigation

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

Download in other formats: