Context Navigation

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

Visit:

Last change on this file since 13779 was 13779, checked in by rschlatte, 12 years ago
slightly less dodgy long-form-method-combination initialization.
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 143.9 KB

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

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

Download in other formats: