Context Navigation

clos.lisp @ 13762

Visit:

Last change on this file since 13762 was 13762, checked in by rschlatte, 11 years ago

Fix short-method-combination object creation

... fixes a number of failing ANSI tests.

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

File size: 142.2 KB

Line
1	;;; clos.lisp
2	;;;
3	;;; Copyright (C) 2003-2007 Peter Graves
4	;;; Copyright (C) 2010 Mark Evenson
5	;;; $Id: clos.lisp 13762 2012-01-11 21:07:07Z 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 make-instance-standard-class (metaclass
690	&rest initargs
691	&key name direct-superclasses direct-slots
692	direct-default-initargs
693	documentation)
694	(declare (ignore metaclass))
695	(let ((class (std-allocate-instance +the-standard-class+)))
696	(check-initargs (list #'allocate-instance #'initialize-instance)
697	(list* class initargs)
698	class t initargs
699	make-instance-initargs-cache 'make-instance)
700	(%set-class-name name class)
701	(%set-class-layout nil class)
702	(%set-class-direct-subclasses () class)
703	(%set-class-direct-methods () class)
704	(%set-class-documentation class documentation)
705	(std-after-initialization-for-classes class
706	:direct-superclasses direct-superclasses
707	:direct-slots direct-slots
708	:direct-default-initargs direct-default-initargs)
709	class))
710
711	;(defun convert-to-direct-slot-definition (class canonicalized-slot)
712	; (apply #'make-instance
713	; (apply #'direct-slot-definition-class
714	; class canonicalized-slot)
715	; canonicalized-slot))
716
717	(defun std-after-initialization-for-classes (class
718	&key direct-superclasses direct-slots
719	direct-default-initargs
720	&allow-other-keys)
721	(let ((supers (or direct-superclasses
722	(list +the-standard-object-class+))))
723	(setf (class-direct-superclasses class) supers)
724	(dolist (superclass supers)
725	(pushnew class (class-direct-subclasses superclass))))
726	(let ((slots (mapcar #'(lambda (slot-properties)
727	(apply #'make-direct-slot-definition class slot-properties))
728	direct-slots)))
729	(setf (class-direct-slots class) slots)
730	(dolist (direct-slot slots)
731	(dolist (reader (slot-definition-readers direct-slot))
732	(add-reader-method class reader (slot-definition-name direct-slot)))
733	(dolist (writer (slot-definition-writers direct-slot))
734	(add-writer-method class writer (slot-definition-name direct-slot)))))
735	(setf (class-direct-default-initargs class) direct-default-initargs)
736	(maybe-finalize-class-subtree class)
737	(values))
738
739	(defun canonical-slot-name (canonical-slot)
740	(getf canonical-slot :name))
741
742	(defvar extensible-built-in-classes
743	(list (find-class 'sequence)
744	(find-class 'java:java-object)))
745
746	(defvar make-instance-initargs-cache
747	(make-hash-table :test #'eq)
748	"Cached sets of allowable initargs, keyed on the class they belong to.")
749	(defvar reinitialize-instance-initargs-cache
750	(make-hash-table :test #'eq)
751	"Cached sets of allowable initargs, keyed on the class they belong to.")
752
753	(defun ensure-class (name &rest all-keys &key metaclass &allow-other-keys)
754	;; Check for duplicate slots.
755	(remf all-keys :metaclass)
756	(let ((slots (getf all-keys :direct-slots)))
757	(dolist (s1 slots)
758	(let ((name1 (canonical-slot-name s1)))
759	(dolist (s2 (cdr (memq s1 slots)))
760	(when (eq name1 (canonical-slot-name s2))
761	(error 'program-error "Duplicate slot ~S" name1))))))
762	;; Check for duplicate argument names in :DEFAULT-INITARGS.
763	(let ((names ()))
764	(do* ((initargs (getf all-keys :direct-default-initargs) (cddr initargs))
765	(name (car initargs) (car initargs)))
766	((null initargs))
767	(push name names))
768	(do* ((names names (cdr names))
769	(name (car names) (car names)))
770	((null names))
771	(when (memq name (cdr names))
772	(error 'program-error
773	:format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS."
774	:format-arguments (list name)))))
775	(let ((direct-superclasses (getf all-keys :direct-superclasses)))
776	(dolist (class direct-superclasses)
777	(when (and (typep class 'built-in-class)
778	(not (member class extensible-built-in-classes)))
779	(error "Attempt to define a subclass of a built-in-class: ~S" class))))
780	(let ((old-class (find-class name nil)))
781	(cond ((and old-class (eq name (class-name old-class)))
782	(cond ((typep old-class 'built-in-class)
783	(error "The symbol ~S names a built-in class." name))
784	((typep old-class 'forward-referenced-class)
785	(let ((new-class (apply #'make-instance-standard-class
786	+the-standard-class+
787	:name name all-keys)))
788	(%set-find-class name new-class)
789	(setf (class-direct-subclasses new-class)
790	(class-direct-subclasses old-class))
791	(dolist (subclass (class-direct-subclasses old-class))
792	(setf (class-direct-superclasses subclass)
793	(substitute new-class old-class
794	(class-direct-superclasses subclass))))
795	(maybe-finalize-class-subtree new-class)
796	new-class))
797	(t
798	;; We're redefining the class.
799	(apply #'reinitialize-instance old-class all-keys)
800	old-class)))
801	(t
802	(let ((class (apply (if metaclass
803	#'make-instance
804	#'make-instance-standard-class)
805	(or metaclass
806	+the-standard-class+)
807	:name name all-keys)))
808	(%set-find-class name class)
809	class)))))
810
811
812	(defun maybe-finalize-class-subtree (class)
813	(when (every #'class-finalized-p (class-direct-superclasses class))
814	(finalize-inheritance class)
815	(dolist (subclass (class-direct-subclasses class))
816	(maybe-finalize-class-subtree subclass))))
817
818	(defmacro defclass (&whole form name direct-superclasses direct-slots &rest options)
819	(unless (>= (length form) 3)
820	(error 'program-error "Wrong number of arguments for DEFCLASS."))
821	(check-declaration-type name)
822	`(ensure-class ',name
823	:direct-superclasses
824	(canonicalize-direct-superclasses ',direct-superclasses)
825	:direct-slots
826	,(canonicalize-direct-slots direct-slots)
827	,@(canonicalize-defclass-options options)))
828
829	(defun expand-long-defcombin (name args)
830	(destructuring-bind (lambda-list method-groups &rest body) args
831	`(apply #'define-long-form-method-combination
832	',name
833	',lambda-list
834	(list ,@(mapcar #'canonicalize-method-group-spec method-groups))
835	',body)))
836
837	;;; The class method-combination and its subclasses are defined in
838	;;; StandardClass.java, but we cannot use make-instance and slot-value
839	;;; yet.
840
841	(defun make-long-method-combination (&key name documentation lambda-list
842	method-group-specs args-lambda-list
843	generic-function-symbol function
844	arguments declarations forms)
845	(let ((instance (std-allocate-instance (find-class 'long-method-combination))))
846	(when name (setf (std-slot-value instance 'sys::name) name))
847	(when documentation
848	(setf (std-slot-value instance 'documentation) documentation))
849	(when lambda-list
850	(setf (std-slot-value instance 'sys::lambda-list) lambda-list))
851	(when method-group-specs
852	(setf (std-slot-value instance 'method-group-specs) method-group-specs))
853	(when args-lambda-list
854	(setf (std-slot-value instance 'args-lambda-list) args-lambda-list))
855	(when generic-function-symbol
856	(setf (std-slot-value instance 'generic-function-symbol)
857	generic-function-symbol))
858	(when function
859	(setf (std-slot-value instance 'function) function))
860	(when arguments
861	(setf (std-slot-value instance 'arguments) arguments))
862	(when declarations
863	(setf (std-slot-value instance 'declarations) declarations))
864	(when forms
865	(setf (std-slot-value instance 'forms) forms))
866	instance))
867
868	(defun method-combination-name (method-combination)
869	(check-type method-combination method-combination)
870	(std-slot-value method-combination 'sys::name))
871
872	(defun method-combination-documentation (method-combination)
873	(check-type method-combination method-combination)
874	(std-slot-value method-combination 'documentation))
875
876	(defun short-method-combination-operator (method-combination)
877	(check-type method-combination short-method-combination)
878	(std-slot-value method-combination 'operator))
879
880	(defun short-method-combination-identity-with-one-argument (method-combination)
881	(check-type method-combination short-method-combination)
882	(std-slot-value method-combination 'identity-with-one-argument))
883
884	(defun long-method-combination-lambda-list (method-combination)
885	(check-type method-combination long-method-combination)
886	(std-slot-value method-combination 'sys::lambda-list))
887
888	(defun long-method-combination-method-group-specs (method-combination)
889	(check-type method-combination long-method-combination)
890	(std-slot-value method-combination 'method-group-specs))
891
892	(defun long-method-combination-args-lambda-list (method-combination)
893	(check-type method-combination long-method-combination)
894	(std-slot-value method-combination 'args-lambda-list))
895
896	(defun long-method-combination-generic-function-symbol (method-combination)
897	(check-type method-combination long-method-combination)
898	(std-slot-value method-combination 'generic-function-symbol))
899
900	(defun long-method-combination-function (method-combination)
901	(check-type method-combination long-method-combination)
902	(std-slot-value method-combination 'function))
903
904	(defun long-method-combination-arguments (method-combination)
905	(check-type method-combination long-method-combination)
906	(std-slot-value method-combination 'arguments))
907
908	(defun long-method-combination-declarations (method-combination)
909	(check-type method-combination long-method-combination)
910	(std-slot-value method-combination 'declarations))
911
912	(defun long-method-combination-forms (method-combination)
913	(check-type method-combination long-method-combination)
914	(std-slot-value method-combination 'forms))
915
916
917	(defun expand-short-defcombin (whole)
918	(let* ((name (cadr whole))
919	(documentation
920	(getf (cddr whole) :documentation ""))
921	(identity-with-one-arg
922	(getf (cddr whole) :identity-with-one-argument nil))
923	(operator
924	(getf (cddr whole) :operator name)))
925	`(progn
926	;; Class short-method-combination is defined in StandardClass.java.
927	(let ((instance (std-allocate-instance
928	(find-class 'short-method-combination))))
929	(setf (std-slot-value instance 'sys::name) ',name)
930	(setf (std-slot-value instance 'documentation) ',documentation)
931	(setf (std-slot-value instance 'operator) ',operator)
932	(setf (std-slot-value instance 'identity-with-one-argument)
933	',identity-with-one-arg)
934	(setf (get ',name 'method-combination-object) instance)
935	',name))))
936
937	(defmacro define-method-combination (&whole form name &rest args)
938	(if (and (cddr form)
939	(listp (caddr form)))
940	(expand-long-defcombin name args)
941	(expand-short-defcombin form)))
942
943	(define-method-combination + :identity-with-one-argument t)
944	(define-method-combination and :identity-with-one-argument t)
945	(define-method-combination append :identity-with-one-argument nil)
946	(define-method-combination list :identity-with-one-argument nil)
947	(define-method-combination max :identity-with-one-argument t)
948	(define-method-combination min :identity-with-one-argument t)
949	(define-method-combination nconc :identity-with-one-argument t)
950	(define-method-combination or :identity-with-one-argument t)
951	(define-method-combination progn :identity-with-one-argument t)
952
953	;;;
954	;;; long form of define-method-combination (from Sacla and XCL)
955	;;;
956	(defun define-method-combination-type (name &rest initargs)
957	(setf (get name 'method-combination-object)
958	(apply 'make-long-method-combination initargs)))
959
960	(defun method-group-p (selecter qualifiers)
961	;; selecter::= qualifier-pattern \| predicate
962	(etypecase selecter
963	(list (or (equal selecter qualifiers)
964	(let ((last (last selecter)))
965	(when (eq '* (cdr last))
966	(let* ((prefix `(,@(butlast selecter) ,(car last)))
967	(pos (mismatch prefix qualifiers)))
968	(or (null pos) (= pos (length prefix))))))))
969	((eql *) t)
970	(symbol (funcall (symbol-function selecter) qualifiers))))
971
972	(defun check-variable-name (name)
973	(flet ((valid-variable-name-p (name)
974	(and (symbolp name) (not (constantp name)))))
975	(assert (valid-variable-name-p name))))
976
977	(defun canonicalize-method-group-spec (spec)
978	;; spec ::= (name {qualifier-pattern+ \| predicate} [[long-form-option]])
979	;; long-form-option::= :description description \| :order order \|
980	;; :required required-p
981	;; a canonicalized-spec is a simple plist.
982	(let* ((rest spec)
983	(name (prog2 (check-variable-name (car rest))
984	(car rest)
985	(setq rest (cdr rest))))
986	(option-names '(:description :order :required))
987	(selecters (let ((end (or (position-if #'(lambda (it)
988	(member it option-names))
989	rest)
990	(length rest))))
991	(prog1 (subseq rest 0 end)
992	(setq rest (subseq rest end)))))
993	(description (getf rest :description ""))
994	(order (getf rest :order :most-specific-first))
995	(required-p (getf rest :required)))
996	`(list :name ',name
997	:predicate (lambda (qualifiers)
998	(loop for item in ',selecters
999	thereis (method-group-p item qualifiers)))
1000	:description ',description
1001	:order ',order
1002	:required ',required-p
1003	:-selecter ,(equal selecters '()))))
1004
1005	(defun extract-required-part (lambda-list)
1006	(flet ((skip (key lambda-list)
1007	(if (eq (first lambda-list) key)
1008	(cddr lambda-list)
1009	lambda-list)))
1010	(ldiff (skip '&environment (skip '&whole lambda-list))
1011	(member-if #'(lambda (it) (member it lambda-list-keywords))
1012	lambda-list))))
1013
1014	(defun extract-specified-part (key lambda-list)
1015	(case key
1016	((&eval &whole)
1017	(list (second (member key lambda-list))))
1018	(t
1019	(let ((here (cdr (member key lambda-list))))
1020	(ldiff here
1021	(member-if #'(lambda (it) (member it lambda-list-keywords))
1022	here))))))
1023
1024	(defun extract-optional-part (lambda-list)
1025	(extract-specified-part '&optional lambda-list))
1026
1027	(defun parse-define-method-combination-arguments-lambda-list (lambda-list)
1028	;; Define-method-combination Arguments Lambda Lists
1029	;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm
1030	(let ((required (extract-required-part lambda-list))
1031	(whole (extract-specified-part '&whole lambda-list))
1032	(optional (extract-specified-part '&optional lambda-list))
1033	(rest (extract-specified-part '&rest lambda-list))
1034	(keys (extract-specified-part '&key lambda-list))
1035	(aux (extract-specified-part '&aux lambda-list)))
1036	(values (first whole)
1037	required
1038	(mapcar #'(lambda (spec)
1039	(if (consp spec)
1040	`(,(first spec) ,(second spec) ,@(cddr spec))
1041	`(,spec nil)))
1042	optional)
1043	(first rest)
1044	(mapcar #'(lambda (spec)
1045	(let ((key (if (consp spec) (car spec) spec))
1046	(rest (when (consp spec) (rest spec))))
1047	`(,(if (consp key) key `(,(make-keyword key) ,key))
1048	,(car rest)
1049	,@(cdr rest))))
1050	keys)
1051	(mapcar #'(lambda (spec)
1052	(if (consp spec)
1053	`(,(first spec) ,(second spec))
1054	`(,spec nil)))
1055	aux))))
1056
1057	(defmacro getk (plist key init-form)
1058	"Similar to getf except eval and return INIT-FORM if KEY has no value in PLIST."
1059	(let ((not-exist (gensym))
1060	(value (gensym)))
1061	`(let ((,value (getf ,plist ,key ,not-exist)))
1062	(if (eq ,not-exist ,value) ,init-form ,value))))
1063
1064	(defun wrap-with-call-method-macro (gf args-var forms)
1065	`(macrolet
1066	((call-method (method &optional next-method-list)
1067	`(funcall
1068	,(cond
1069	((listp method)
1070	(assert (eq (first method) 'make-method))
1071	;; by generating an inline expansion we prevent allocation
1072	;; of a method instance which will be discarded immediately
1073	;; after reading the METHOD-FUNCTION slot
1074	(compute-method-function
1075	`(lambda (&rest ,(gensym))
1076	;; the MAKE-METHOD body form gets evaluated in
1077	;; the null lexical environment augmented
1078	;; with a binding for CALL-METHOD
1079	,(wrap-with-call-method-macro ,gf
1080	',args-var
1081	(second method)))))
1082	(t (%method-function method)))
1083	,',args-var
1084	,(unless (null next-method-list)
1085	;; by not generating an emf when there are no next methods,
1086	;; we ensure next-method-p returns NIL
1087	(compute-effective-method-function
1088	,gf (process-next-method-list next-method-list))))))
1089	,@forms))
1090
1091	(defmacro with-args-lambda-list (args-lambda-list
1092	generic-function-symbol
1093	gf-args-symbol
1094	&body forms)
1095	(let ((gf-lambda-list (gensym))
1096	(nrequired (gensym))
1097	(noptional (gensym))
1098	(rest-args (gensym)))
1099	(multiple-value-bind (whole required optional rest keys aux)
1100	(parse-define-method-combination-arguments-lambda-list args-lambda-list)
1101	`(let* ((,gf-lambda-list (slot-value ,generic-function-symbol 'sys::lambda-list))
1102	(,nrequired (length (extract-required-part ,gf-lambda-list)))
1103	(,noptional (length (extract-optional-part ,gf-lambda-list)))
1104	(,rest-args (subseq ,gf-args-symbol (+ ,nrequired ,noptional)))
1105	,@(when whole `((,whole ,gf-args-symbol)))
1106	,@(loop for var in required and i upfrom 0
1107	collect `(,var (when (< ,i ,nrequired)
1108	(nth ,i ,gf-args-symbol))))
1109	,@(loop for (var init-form) in optional and i upfrom 0
1110	collect
1111	`(,var (if (< ,i ,noptional)
1112	(nth (+ ,nrequired ,i) ,gf-args-symbol)
1113	,init-form)))
1114	,@(when rest `((,rest ,rest-args)))
1115	,@(loop for ((key var) init-form) in keys and i upfrom 0
1116	collect `(,var (getk ,rest-args ',key ,init-form)))
1117	,@(loop for (var init-form) in aux and i upfrom 0
1118	collect `(,var ,init-form)))
1119	,@forms))))
1120
1121	(defun assert-unambiguous-method-sorting (group-name methods)
1122	(let ((specializers (make-hash-table :test 'equal)))
1123	(dolist (method methods)
1124	(push method (gethash (method-specializers method) specializers)))
1125	(loop for specializer-methods being each hash-value of specializers
1126	using (hash-key method-specializers)
1127	unless (= 1 (length specializer-methods))
1128	do (error "Ambiguous method sorting in method group ~A due to multiple ~
1129	methods with specializers ~S: ~S"
1130	group-name method-specializers specializer-methods))))
1131
1132	(defmacro with-method-groups (method-group-specs methods-form &body forms)
1133	(flet ((grouping-form (spec methods-var)
1134	(let ((predicate (coerce-to-function (getf spec :predicate)))
1135	(group (gensym))
1136	(leftovers (gensym))
1137	(method (gensym)))
1138	`(let ((,group '())
1139	(,leftovers '()))
1140	(dolist (,method ,methods-var)
1141	(if (funcall ,predicate (method-qualifiers ,method))
1142	(push ,method ,group)
1143	(push ,method ,leftovers)))
1144	(ecase ,(getf spec :order)
1145	(:most-specific-last )
1146	(:most-specific-first (setq ,group (nreverse ,group))))
1147	,@(when (getf spec :required)
1148	`((when (null ,group)
1149	(error "Method group ~S must not be empty."
1150	',(getf spec :name)))))
1151	(setq ,methods-var (nreverse ,leftovers))
1152	,group))))
1153	(let ((rest (gensym))
1154	(method (gensym)))
1155	`(let* ((,rest ,methods-form)
1156	,@(mapcar #'(lambda (spec)
1157	`(,(getf spec :name) ,(grouping-form spec rest)))
1158	method-group-specs))
1159	(dolist (,method ,rest)
1160	(invalid-method-error ,method
1161	"Method ~S with qualifiers ~S does not belong to any method group."
1162	,method (method-qualifiers ,method)))
1163	,@(unless (and (= 1 (length method-group-specs))
1164	(getf (car method-group-specs) :*-selecter))
1165	(mapcar #'(lambda (spec)
1166	`(assert-unambiguous-method-sorting ',(getf spec :name) ,(getf spec :name)))
1167	method-group-specs))
1168	,@forms))))
1169
1170	(defun method-combination-type-lambda
1171	(&key name lambda-list args-lambda-list generic-function-symbol
1172	method-group-specs declarations forms &allow-other-keys)
1173	(declare (ignore name))
1174	(let ((methods (gensym))
1175	(args-var (gensym)))
1176	`(lambda (,generic-function-symbol ,methods ,@lambda-list)
1177	,@declarations
1178	(with-method-groups ,method-group-specs
1179	,methods
1180	,(if (null args-lambda-list)
1181	`(let ((result (progn ,@forms)))
1182	`(lambda (,',args-var)
1183	,(wrap-with-call-method-macro ,generic-function-symbol
1184	',args-var (list result))))
1185	`(lambda (,args-var)
1186	(let* ((result
1187	(with-args-lambda-list ,args-lambda-list
1188	,generic-function-symbol ,args-var
1189	,@forms))
1190	(function
1191	`(lambda (,',args-var) ;; ugly: we're reusing it
1192	;; to prevent calling gensym on every EMF invocation
1193	,(wrap-with-call-method-macro ,generic-function-symbol
1194	',args-var
1195	(list result)))))
1196	(funcall function ,args-var))))))))
1197
1198	(defun declarationp (expr)
1199	(and (consp expr) (eq (car expr) 'DECLARE)))
1200
1201	(defun long-form-method-combination-args (args)
1202	;; define-method-combination name lambda-list (method-group-specifier*) args
1203	;; args ::= [(:arguments . args-lambda-list)]
1204	;; [(:generic-function generic-function-symbol)]
1205	;; [[declaration* \| documentation]] form*
1206	(let ((rest args))
1207	(labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest))))
1208	(args-lambda-list ()
1209	(when (nextp :arguments)
1210	(prog1 (cdr (car rest)) (setq rest (cdr rest)))))
1211	(generic-function-symbol ()
1212	(if (nextp :generic-function)
1213	(prog1 (second (car rest)) (setq rest (cdr rest)))
1214	(gensym)))
1215	(declaration* ()
1216	(let ((end (position-if-not #'declarationp rest)))
1217	(when end
1218	(prog1 (subseq rest 0 end) (setq rest (nthcdr end rest))))))
1219	(documentation? ()
1220	(when (stringp (car rest))
1221	(prog1 (car rest) (setq rest (cdr rest)))))
1222	(form* () rest))
1223	(let ((declarations '()))
1224	`(:args-lambda-list ,(args-lambda-list)
1225	:generic-function-symbol ,(generic-function-symbol)
1226	:documentation ,(prog2 (setq declarations (declaration*))
1227	(documentation?))
1228	:declarations (,@declarations ,@(declaration*))
1229	:forms ,(form*))))))
1230
1231	(defun define-long-form-method-combination (name lambda-list method-group-specs
1232	&rest args)
1233	(let* ((initargs `(:name ,name
1234	:lambda-list ,lambda-list
1235	:method-group-specs ,method-group-specs
1236	,@(long-form-method-combination-args args)))
1237	(lambda-expression (apply #'method-combination-type-lambda initargs)))
1238	(apply #'define-method-combination-type name
1239	`(,@initargs
1240	;; :function ,(compile nil lambda-expression)
1241	:function ,(coerce-to-function lambda-expression)))
1242	name))
1243
1244	(defparameter eql-specializer-table (make-hash-table :test 'eql))
1245
1246	(defun intern-eql-specializer (object)
1247	(or (gethash object eql-specializer-table)
1248	(setf (gethash object eql-specializer-table)
1249	;; we will be called during generic function invocation
1250	;; setup, so have to rely on plain functions here.
1251	(let ((instance (std-allocate-instance (find-class 'eql-specializer))))
1252	(setf (std-slot-value instance 'sys::object) object)
1253	instance))))
1254
1255	(defun eql-specializer-object (eql-specializer)
1256	(check-type eql-specializer eql-specializer)
1257	(std-slot-value eql-specializer 'sys::object))
1258
1259	;; MOP (p. 216) specifies the following reader generic functions:
1260	;; generic-function-argument-precedence-order
1261	;; generic-function-declarations
1262	;; generic-function-lambda-list
1263	;; generic-function-method-class
1264	;; generic-function-method-combination
1265	;; generic-function-methods
1266	;; generic-function-name
1267
1268	(defun generic-function-lambda-list (gf)
1269	(%generic-function-lambda-list gf))
1270	(defsetf generic-function-lambda-list %set-generic-function-lambda-list)
1271
1272	(defun (setf generic-function-documentation) (new-value gf)
1273	(set-generic-function-documentation gf new-value))
1274
1275	(defun (setf generic-function-initial-methods) (new-value gf)
1276	(set-generic-function-initial-methods gf new-value))
1277
1278	(defun (setf generic-function-methods) (new-value gf)
1279	(set-generic-function-methods gf new-value))
1280
1281	(defun (setf generic-function-method-class) (new-value gf)
1282	(set-generic-function-method-class gf new-value))
1283
1284	(defun (setf generic-function-method-combination) (new-value gf)
1285	(set-generic-function-method-combination gf new-value))
1286
1287	(defun (setf generic-function-argument-precedence-order) (new-value gf)
1288	(set-generic-function-argument-precedence-order gf new-value))
1289
1290	(declaim (ftype (function * t) classes-to-emf-table))
1291	(defun classes-to-emf-table (gf)
1292	(generic-function-classes-to-emf-table gf))
1293
1294	(defun (setf classes-to-emf-table) (new-value gf)
1295	(set-generic-function-classes-to-emf-table gf new-value))
1296
1297	(defun (setf method-lambda-list) (new-value method)
1298	(set-method-lambda-list method new-value))
1299
1300	(defun (setf method-qualifiers) (new-value method)
1301	(set-method-qualifiers method new-value))
1302
1303	(defun (setf method-documentation) (new-value method)
1304	(set-method-documentation method new-value))
1305
1306	;;; defgeneric
1307
1308	(defmacro defgeneric (function-name lambda-list
1309	&rest options-and-method-descriptions)
1310	(let ((options ())
1311	(methods ())
1312	(documentation nil))
1313	(dolist (item options-and-method-descriptions)
1314	(case (car item)
1315	(declare) ; FIXME
1316	(:documentation
1317	(when documentation
1318	(error 'program-error
1319	:format-control "Documentation option was specified twice for generic function ~S."
1320	:format-arguments (list function-name)))
1321	(setf documentation t)
1322	(push item options))
1323	(:method
1324	(push
1325	`(push (defmethod ,function-name ,@(cdr item))
1326	(generic-function-initial-methods (fdefinition ',function-name)))
1327	methods))
1328	(t
1329	(push item options))))
1330	(setf options (nreverse options)
1331	methods (nreverse methods))
1332	`(prog1
1333	(%defgeneric
1334	',function-name
1335	:lambda-list ',lambda-list
1336	,@(canonicalize-defgeneric-options options))
1337	,@methods)))
1338
1339	(defun canonicalize-defgeneric-options (options)
1340	(mapappend #'canonicalize-defgeneric-option options))
1341
1342	(defun canonicalize-defgeneric-option (option)
1343	(case (car option)
1344	(:generic-function-class
1345	(list :generic-function-class `(find-class ',(cadr option))))
1346	(:method-class
1347	(list :method-class `(find-class ',(cadr option))))
1348	(:method-combination
1349	(list :method-combination `',(cdr option)))
1350	(:argument-precedence-order
1351	(list :argument-precedence-order `',(cdr option)))
1352	(t
1353	(list `',(car option) `',(cadr option)))))
1354
1355	;; From OpenMCL.
1356	(defun canonicalize-argument-precedence-order (apo req)
1357	(cond ((equal apo req) nil)
1358	((not (eql (length apo) (length req)))
1359	(error 'program-error
1360	:format-control "Specified argument precedence order ~S does not match lambda list."
1361	:format-arguments (list apo)))
1362	(t (let ((res nil))
1363	(dolist (arg apo (nreverse res))
1364	(let ((index (position arg req)))
1365	(if (or (null index) (memq index res))
1366	(error 'program-error
1367	:format-control "Specified argument precedence order ~S does not match lambda list."
1368	:format-arguments (list apo)))
1369	(push index res)))))))
1370
1371	(defun find-generic-function (name &optional (errorp t))
1372	(let ((function (and (fboundp name) (fdefinition name))))
1373	(when function
1374	(when (typep function 'generic-function)
1375	(return-from find-generic-function function))
1376	(when (and traced-names (find name traced-names :test #'equal))
1377	(setf function (untraced-function name))
1378	(when (typep function 'generic-function)
1379	(return-from find-generic-function function)))))
1380	(if errorp
1381	(error "There is no generic function named ~S." name)
1382	nil))
1383
1384	(defun lambda-lists-congruent-p (lambda-list1 lambda-list2)
1385	(let* ((plist1 (analyze-lambda-list lambda-list1))
1386	(args1 (getf plist1 :required-args))
1387	(plist2 (analyze-lambda-list lambda-list2))
1388	(args2 (getf plist2 :required-args)))
1389	(= (length args1) (length args2))))
1390
1391	(defun %defgeneric (function-name &rest all-keys)
1392	(when (fboundp function-name)
1393	(let ((gf (fdefinition function-name)))
1394	(when (typep gf 'generic-function)
1395	;; Remove methods defined by previous DEFGENERIC forms.
1396	(dolist (method (generic-function-initial-methods gf))
1397	(%remove-method gf method))
1398	(setf (generic-function-initial-methods gf) '()))))
1399	(apply 'ensure-generic-function function-name all-keys))
1400
1401	(defun ensure-generic-function (function-name
1402	&rest all-keys
1403	&key
1404	lambda-list
1405	(generic-function-class +the-standard-generic-function-class+)
1406	(method-class +the-standard-method-class+)
1407	(method-combination 'standard)
1408	(argument-precedence-order nil apo-p)
1409	documentation
1410	&allow-other-keys)
1411	(when (autoloadp function-name)
1412	(resolve function-name))
1413	(let ((gf (find-generic-function function-name nil)))
1414	(if gf
1415	(progn
1416	(unless (or (null (generic-function-methods gf))
1417	(lambda-lists-congruent-p lambda-list (generic-function-lambda-list gf)))
1418	(error 'simple-error
1419	:format-control "The lambda list ~S is incompatible with the existing methods of ~S."
1420	:format-arguments (list lambda-list gf)))
1421	(setf (generic-function-lambda-list gf) lambda-list)
1422	(setf (generic-function-documentation gf) documentation)
1423	(let* ((plist (analyze-lambda-list lambda-list))
1424	(required-args (getf plist ':required-args)))
1425	(%set-gf-required-args gf required-args)
1426	(when apo-p
1427	(setf (generic-function-argument-precedence-order gf)
1428	(if argument-precedence-order
1429	(canonicalize-argument-precedence-order argument-precedence-order
1430	required-args)
1431	nil)))
1432	(finalize-generic-function gf))
1433	gf)
1434	(progn
1435	(when (and (null clos-booting)
1436	(fboundp function-name))
1437	(error 'program-error
1438	:format-control "~A already names an ordinary function, macro, or special operator."
1439	:format-arguments (list function-name)))
1440	(setf gf (apply (if (eq generic-function-class +the-standard-generic-function-class+)
1441	#'make-instance-standard-generic-function
1442	#'make-instance)
1443	generic-function-class
1444	:name function-name
1445	:method-class method-class
1446	:method-combination method-combination
1447	all-keys))
1448	gf))))
1449
1450	(defun initial-discriminating-function (gf args)
1451	(set-funcallable-instance-function
1452	gf
1453	(funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
1454	#'std-compute-discriminating-function
1455	#'compute-discriminating-function)
1456	gf))
1457	(apply gf args))
1458
1459	(defun collect-eql-specializer-objects (generic-function)
1460	(let ((result nil))
1461	(dolist (method (generic-function-methods generic-function))
1462	(dolist (specializer (%method-specializers method))
1463	(when (typep specializer 'eql-specializer)
1464	(pushnew (eql-specializer-object specializer)
1465	result
1466	:test 'eql))))
1467	result))
1468
1469	(defun finalize-generic-function (gf)
1470	(%finalize-generic-function gf)
1471	(setf (classes-to-emf-table gf) (make-hash-table :test #'equal))
1472	(%init-eql-specializations gf (collect-eql-specializer-objects gf))
1473	(set-funcallable-instance-function
1474	gf #'(lambda (&rest args)
1475	(initial-discriminating-function gf args)))
1476	;; FIXME Do we need to warn on redefinition somewhere else?
1477	(let ((warn-on-redefinition nil))
1478	(setf (fdefinition (%generic-function-name gf)) gf))
1479	(values))
1480
1481	(defun make-instance-standard-generic-function (generic-function-class
1482	&key name lambda-list
1483	method-class
1484	method-combination
1485	argument-precedence-order
1486	documentation)
1487	(declare (ignore generic-function-class))
1488	(let ((gf (std-allocate-instance +the-standard-generic-function-class+)))
1489	(%set-generic-function-name gf name)
1490	(setf (generic-function-lambda-list gf) lambda-list)
1491	(setf (generic-function-initial-methods gf) ())
1492	(setf (generic-function-methods gf) ())
1493	(setf (generic-function-method-class gf) method-class)
1494	(setf (generic-function-method-combination gf) method-combination)
1495	(setf (generic-function-documentation gf) documentation)
1496	(setf (classes-to-emf-table gf) nil)
1497	(let* ((plist (analyze-lambda-list (generic-function-lambda-list gf)))
1498	(required-args (getf plist ':required-args)))
1499	(%set-gf-required-args gf required-args)
1500	(setf (generic-function-argument-precedence-order gf)
1501	(if argument-precedence-order
1502	(canonicalize-argument-precedence-order argument-precedence-order
1503	required-args)
1504	nil)))
1505	(finalize-generic-function gf)
1506	gf))
1507
1508	(defun canonicalize-specializers (specializers)
1509	(mapcar #'canonicalize-specializer specializers))
1510
1511	(defun canonicalize-specializer (specializer)
1512	(cond ((classp specializer)
1513	specializer)
1514	((typep specializer 'eql-specializer)
1515	specializer)
1516	((symbolp specializer)
1517	(find-class specializer))
1518	((and (consp specializer)
1519	(eq (car specializer) 'eql))
1520	(let ((object (cadr specializer)))
1521	(when (and (consp object)
1522	(eq (car object) 'quote))
1523	(setf object (cadr object)))
1524	(intern-eql-specializer object)))
1525	((and (consp specializer)
1526	(eq (car specializer) 'java:jclass))
1527	(let ((jclass (eval specializer)))
1528	(java::ensure-java-class jclass)))
1529	(t
1530	(error "Unknown specializer: ~S" specializer))))
1531
1532	(defun parse-defmethod (args)
1533	(let ((function-name (car args))
1534	(qualifiers ())
1535	(specialized-lambda-list ())
1536	(body ())
1537	(parse-state :qualifiers))
1538	(dolist (arg (cdr args))
1539	(ecase parse-state
1540	(:qualifiers
1541	(if (and (atom arg) (not (null arg)))
1542	(push arg qualifiers)
1543	(progn
1544	(setf specialized-lambda-list arg)
1545	(setf parse-state :body))))
1546	(:body (push arg body))))
1547	(setf qualifiers (nreverse qualifiers)
1548	body (nreverse body))
1549	(multiple-value-bind (real-body declarations documentation)
1550	(parse-body body)
1551	(values function-name
1552	qualifiers
1553	(extract-lambda-list specialized-lambda-list)
1554	(extract-specializer-names specialized-lambda-list)
1555	documentation
1556	declarations
1557	(list* 'block
1558	(fdefinition-block-name function-name)
1559	real-body)))))
1560
1561	(defun required-portion (gf args)
1562	(let ((number-required (length (gf-required-args gf))))
1563	(when (< (length args) number-required)
1564	(error 'program-error
1565	:format-control "Not enough arguments for generic function ~S."
1566	:format-arguments (list (%generic-function-name gf))))
1567	(subseq args 0 number-required)))
1568
1569	(defun extract-lambda-list (specialized-lambda-list)
1570	(let* ((plist (analyze-lambda-list specialized-lambda-list))
1571	(requireds (getf plist :required-names))
1572	(rv (getf plist :rest-var))
1573	(ks (getf plist :key-args))
1574	(keysp (getf plist :keysp))
1575	(aok (getf plist :allow-other-keys))
1576	(opts (getf plist :optional-args))
1577	(auxs (getf plist :auxiliary-args)))
1578	`(,@requireds
1579	,@(if rv `(&rest ,rv) ())
1580	,@(if (or ks keysp aok) `(&key ,@ks) ())
1581	,@(if aok '(&allow-other-keys) ())
1582	,@(if opts `(&optional ,@opts) ())
1583	,@(if auxs `(&aux ,@auxs) ()))))
1584
1585	(defun extract-specializer-names (specialized-lambda-list)
1586	(let ((plist (analyze-lambda-list specialized-lambda-list)))
1587	(getf plist ':specializers)))
1588
1589	(defun get-keyword-from-arg (arg)
1590	(if (listp arg)
1591	(if (listp (car arg))
1592	(caar arg)
1593	(make-keyword (car arg)))
1594	(make-keyword arg)))
1595
1596	(defun analyze-lambda-list (lambda-list)
1597	(let ((keys ()) ; Just the keywords
1598	(key-args ()) ; Keywords argument specs
1599	(keysp nil) ;
1600	(required-names ()) ; Just the variable names
1601	(required-args ()) ; Variable names & specializers
1602	(specializers ()) ; Just the specializers
1603	(rest-var nil)
1604	(optionals ())
1605	(auxs ())
1606	(allow-other-keys nil)
1607	(state :parsing-required))
1608	(dolist (arg lambda-list)
1609	(if (member arg lambda-list-keywords)
1610	(ecase arg
1611	(&optional
1612	(setq state :parsing-optional))
1613	(&rest
1614	(setq state :parsing-rest))
1615	(&key
1616	(setq keysp t)
1617	(setq state :parsing-key))
1618	(&allow-other-keys
1619	(setq allow-other-keys 't))
1620	(&aux
1621	(setq state :parsing-aux)))
1622	(case state
1623	(:parsing-required
1624	(push-on-end arg required-args)
1625	(if (listp arg)
1626	(progn (push-on-end (car arg) required-names)
1627	(push-on-end (cadr arg) specializers))
1628	(progn (push-on-end arg required-names)
1629	(push-on-end 't specializers))))
1630	(:parsing-optional (push-on-end arg optionals))
1631	(:parsing-rest (setq rest-var arg))
1632	(:parsing-key
1633	(push-on-end (get-keyword-from-arg arg) keys)
1634	(push-on-end arg key-args))
1635	(:parsing-aux (push-on-end arg auxs)))))
1636	(list :required-names required-names
1637	:required-args required-args
1638	:specializers specializers
1639	:rest-var rest-var
1640	:keywords keys
1641	:key-args key-args
1642	:keysp keysp
1643	:auxiliary-args auxs
1644	:optional-args optionals
1645	:allow-other-keys allow-other-keys)))
1646
1647	#+nil
1648	(defun check-method-arg-info (gf arg-info method)
1649	(multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
1650	(analyze-lambda-list (if (consp method)
1651	(early-method-lambda-list method)
1652	(method-lambda-list method)))
1653	(flet ((lose (string &rest args)
1654	(error 'simple-program-error
1655	:format-control "~@<attempt to add the method~2I~_~S~I~_~
1656	to the generic function~2I~_~S;~I~_~
1657	but ~?~:>"
1658	:format-arguments (list method gf string args)))
1659	(comparison-description (x y)
1660	(if (> x y) "more" "fewer")))
1661	(let ((gf-nreq (arg-info-number-required arg-info))
1662	(gf-nopt (arg-info-number-optional arg-info))
1663	(gf-key/rest-p (arg-info-key/rest-p arg-info))
1664	(gf-keywords (arg-info-keys arg-info)))
1665	(unless (= nreq gf-nreq)
1666	(lose
1667	"the method has ~A required arguments than the generic function."
1668	(comparison-description nreq gf-nreq)))
1669	(unless (= nopt gf-nopt)
1670	(lose
1671	"the method has ~A optional arguments than the generic function."
1672	(comparison-description nopt gf-nopt)))
1673	(unless (eq (or keysp restp) gf-key/rest-p)
1674	(lose
1675	"the method and generic function differ in whether they accept~_~
1676	&REST or &KEY arguments."))
1677	(when (consp gf-keywords)
1678	(unless (or (and restp (not keysp))
1679	allow-other-keys-p
1680	(every (lambda (k) (memq k keywords)) gf-keywords))
1681	(lose "the method does not accept each of the &KEY arguments~2I~_~
1682	~S."
1683	gf-keywords)))))))
1684
1685	(defun check-method-lambda-list (name method-lambda-list gf-lambda-list)
1686	(let* ((gf-restp (not (null (memq '&rest gf-lambda-list))))
1687	(gf-plist (analyze-lambda-list gf-lambda-list))
1688	(gf-keysp (getf gf-plist :keysp))
1689	(gf-keywords (getf gf-plist :keywords))
1690	(method-plist (analyze-lambda-list method-lambda-list))
1691	(method-restp (not (null (memq '&rest method-lambda-list))))
1692	(method-keysp (getf method-plist :keysp))
1693	(method-keywords (getf method-plist :keywords))
1694	(method-allow-other-keys-p (getf method-plist :allow-other-keys)))
1695	(unless (= (length (getf gf-plist :required-args))
1696	(length (getf method-plist :required-args)))
1697	(error "The method-lambda-list ~S ~
1698	has the wrong number of required arguments ~
1699	for the generic function ~S." method-lambda-list name))
1700	(unless (= (length (getf gf-plist :optional-args))
1701	(length (getf method-plist :optional-args)))
1702	(error "The method-lambda-list ~S ~
1703	has the wrong number of optional arguments ~
1704	for the generic function ~S." method-lambda-list name))
1705	(unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp))
1706	(error "The method-lambda-list ~S ~
1707	and the generic function ~S ~
1708	differ in whether they accept &REST or &KEY arguments."
1709	method-lambda-list name))
1710	(when (consp gf-keywords)
1711	(unless (or (and method-restp (not method-keysp))
1712	method-allow-other-keys-p
1713	(every (lambda (k) (memq k method-keywords)) gf-keywords))
1714	(error "The method-lambda-list ~S does not accept ~
1715	all of the keyword arguments defined for the ~
1716	generic function." method-lambda-list name)))))
1717
1718	(defvar gf-initialize-instance nil
1719	"Cached value of the INITIALIZE-INSTANCE generic function.
1720	Initialized with the true value near the end of the file.")
1721	(defvar gf-allocate-instance nil
1722	"Cached value of the ALLOCATE-INSTANCE generic function.
1723	Initialized with the true value near the end of the file.")
1724	(defvar gf-shared-initialize nil
1725	"Cached value of the SHARED-INITIALIZE generic function.
1726	Initialized with the true value near the end of the file.")
1727	(defvar gf-reinitialize-instance nil
1728	"Cached value of the REINITIALIZE-INSTANCE generic function.
1729	Initialized with the true value near the end of the file.")
1730
1731	(declaim (ftype (function * method) ensure-method))
1732	(defun ensure-method (name &rest all-keys)
1733	(let ((method-lambda-list (getf all-keys :lambda-list))
1734	(gf (find-generic-function name nil)))
1735	(when (or (eq gf gf-initialize-instance)
1736	(eq gf gf-allocate-instance)
1737	(eq gf gf-shared-initialize)
1738	(eq gf gf-reinitialize-instance))
1739	;; ### Clearly, this can be targeted much more exact
1740	;; as we only need to remove the specializing class and all
1741	;; its subclasses from the hash.
1742	(clrhash make-instance-initargs-cache)
1743	(clrhash reinitialize-instance-initargs-cache))
1744	(if gf
1745	(check-method-lambda-list name method-lambda-list
1746	(generic-function-lambda-list gf))
1747	(setf gf (ensure-generic-function name :lambda-list method-lambda-list)))
1748	(let ((method
1749	(if (eq (generic-function-method-class gf) +the-standard-method-class+)
1750	(apply #'make-instance-standard-method gf all-keys)
1751	(apply #'make-instance (generic-function-method-class gf) all-keys))))
1752	(%add-method gf method)
1753	method)))
1754
1755	(defun make-instance-standard-method (gf
1756	&key
1757	lambda-list
1758	qualifiers
1759	specializers
1760	documentation
1761	function
1762	fast-function)
1763	(declare (ignore gf))
1764	(let ((method (std-allocate-instance +the-standard-method-class+)))
1765	(setf (method-lambda-list method) lambda-list)
1766	(setf (method-qualifiers method) qualifiers)
1767	(%set-method-specializers method (canonicalize-specializers specializers))
1768	(setf (method-documentation method) documentation)
1769	(%set-method-generic-function method nil)
1770	(%set-method-function method function)
1771	(%set-method-fast-function method fast-function)
1772	method))
1773
1774	(defun %add-method (gf method)
1775	(when (%method-generic-function method)
1776	(error 'simple-error
1777	:format-control "ADD-METHOD: ~S is a method of ~S."
1778	:format-arguments (list method (%method-generic-function method))))
1779	;; Remove existing method with same qualifiers and specializers (if any).
1780	(let ((old-method (%find-method gf (method-qualifiers method)
1781	(%method-specializers method) nil)))
1782	(when old-method
1783	(%remove-method gf old-method)))
1784	(%set-method-generic-function method gf)
1785	(push method (generic-function-methods gf))
1786	(dolist (specializer (%method-specializers method))
1787	(when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1788	(pushnew method (class-direct-methods specializer))))
1789	(finalize-generic-function gf)
1790	gf)
1791
1792	(defun %remove-method (gf method)
1793	(setf (generic-function-methods gf)
1794	(remove method (generic-function-methods gf)))
1795	(%set-method-generic-function method nil)
1796	(dolist (specializer (%method-specializers method))
1797	(when (typep specializer 'class) ;; FIXME What about EQL specializer objects?
1798	(setf (class-direct-methods specializer)
1799	(remove method (class-direct-methods specializer)))))
1800	(finalize-generic-function gf)
1801	gf)
1802
1803	(defun %find-method (gf qualifiers specializers &optional (errorp t))
1804	;; "If the specializers argument does not correspond in length to the number
1805	;; of required arguments of the generic-function, an an error of type ERROR
1806	;; is signaled."
1807	(unless (= (length specializers) (length (gf-required-args gf)))
1808	(error "The specializers argument has length ~S, but ~S has ~S required parameters."
1809	(length specializers)
1810	gf
1811	(length (gf-required-args gf))))
1812	(let* ((canonical-specializers (canonicalize-specializers specializers))
1813	(method
1814	(find-if #'(lambda (method)
1815	(and (equal qualifiers
1816	(method-qualifiers method))
1817	(equal canonical-specializers
1818	(%method-specializers method))))
1819	(generic-function-methods gf))))
1820	(if (and (null method) errorp)
1821	(error "No such method for ~S." (%generic-function-name gf))
1822	method)))
1823
1824	(defun fast-callable-p (gf)
1825	(and (eq (generic-function-method-combination gf) 'standard)
1826	(null (intersection (%generic-function-lambda-list gf)
1827	'(&rest &optional &key &allow-other-keys &aux)))))
1828
1829	(declaim (ftype (function * t) slow-method-lookup-1))
1830
1831	(declaim (ftype (function (t t t) t) slow-reader-lookup))
1832	(defun slow-reader-lookup (gf layout slot-name)
1833	(let ((location (layout-slot-location layout slot-name)))
1834	(cache-slot-location gf layout location)
1835	location))
1836
1837	(defun std-compute-discriminating-function (gf)
1838	(let ((code
1839	(cond
1840	((and (= (length (generic-function-methods gf)) 1)
1841	(typep (car (generic-function-methods gf)) 'standard-reader-method))
1842	;; (sys::%format t "standard reader function ~S~%" (generic-function-name gf))
1843
1844	(let* ((method (%car (generic-function-methods gf)))
1845	(class (car (%method-specializers method)))
1846	(slot-name (reader-method-slot-name method)))
1847	#'(lambda (arg)
1848	(declare (optimize speed))
1849	(let* ((layout (std-instance-layout arg))
1850	(location (get-cached-slot-location gf layout)))
1851	(unless location
1852	(unless (simple-typep arg class)
1853	;; FIXME no applicable method
1854	(error 'simple-type-error
1855	:datum arg
1856	:expected-type class))
1857	(setf location (slow-reader-lookup gf layout slot-name)))
1858	(if (consp location)
1859	;; Shared slot.
1860	(cdr location)
1861	(standard-instance-access arg location))))))
1862
1863	(t
1864	(let* ((emf-table (classes-to-emf-table gf))
1865	(number-required (length (gf-required-args gf)))
1866	(lambda-list (%generic-function-lambda-list gf))
1867	(exact (null (intersection lambda-list
1868	'(&rest &optional &key
1869	&allow-other-keys &aux)))))
1870	(if exact
1871	(cond
1872	((= number-required 1)
1873	(cond
1874	((and (eq (generic-function-method-combination gf) 'standard)
1875	(= (length (generic-function-methods gf)) 1))
1876	(let* ((method (%car (generic-function-methods gf)))
1877	(specializer (car (%method-specializers method)))
1878	(function (or (%method-fast-function method)
1879	(%method-function method))))
1880	(if (typep specializer 'eql-specializer)
1881	(let ((specializer-object (eql-specializer-object specializer)))
1882	#'(lambda (arg)
1883	(declare (optimize speed))
1884	(if (eql arg specializer-object)
1885	(funcall function arg)
1886	(no-applicable-method gf (list arg)))))
1887	#'(lambda (arg)
1888	(declare (optimize speed))
1889	(unless (simple-typep arg specializer)
1890	;; FIXME no applicable method
1891	(error 'simple-type-error
1892	:datum arg
1893	:expected-type specializer))
1894	(funcall function arg)))))
1895	(t
1896	#'(lambda (arg)
1897	(declare (optimize speed))
1898	(let* ((specialization
1899	(%get-arg-specialization gf arg))
1900	(emfun (or (gethash1 specialization
1901	emf-table)
1902	(slow-method-lookup-1
1903	gf arg specialization))))
1904	(if emfun
1905	(funcall emfun (list arg))
1906	(apply #'no-applicable-method gf (list arg))))))))
1907	((= number-required 2)
1908	#'(lambda (arg1 arg2)
1909	(declare (optimize speed))
1910	(let* ((args (list arg1 arg2))
1911	(emfun (get-cached-emf gf args)))
1912	(if emfun
1913	(funcall emfun args)
1914	(slow-method-lookup gf args)))))
1915	((= number-required 3)
1916	#'(lambda (arg1 arg2 arg3)
1917	(declare (optimize speed))
1918	(let* ((args (list arg1 arg2 arg3))
1919	(emfun (get-cached-emf gf args)))
1920	(if emfun
1921	(funcall emfun args)
1922	(slow-method-lookup gf args)))))
1923	(t
1924	#'(lambda (&rest args)
1925	(declare (optimize speed))
1926	(let ((len (length args)))
1927	(unless (= len number-required)
1928	(error 'program-error
1929	:format-control "Not enough arguments for generic function ~S."
1930	:format-arguments (list (%generic-function-name gf)))))
1931	(let ((emfun (get-cached-emf gf args)))
1932	(if emfun
1933	(funcall emfun args)
1934	(slow-method-lookup gf args))))))
1935	#'(lambda (&rest args)
1936	(declare (optimize speed))
1937	(let ((len (length args)))
1938	(unless (>= len number-required)
1939	(error 'program-error
1940	:format-control "Not enough arguments for generic function ~S."
1941	:format-arguments (list (%generic-function-name gf)))))
1942	(let ((emfun (get-cached-emf gf args)))
1943	(if emfun
1944	(funcall emfun args)
1945	(slow-method-lookup gf args))))))))))
1946
1947	code))
1948
1949	(defun sort-methods (methods gf required-classes)
1950	(if (or (null methods) (null (%cdr methods)))
1951	methods
1952	(sort methods
1953	(if (eq (class-of gf) +the-standard-generic-function-class+)
1954	#'(lambda (m1 m2)
1955	(std-method-more-specific-p m1 m2 required-classes
1956	(generic-function-argument-precedence-order gf)))
1957	#'(lambda (m1 m2)
1958	(method-more-specific-p gf m1 m2 required-classes))))))
1959
1960	(defun method-applicable-p (method args)
1961	(do* ((specializers (%method-specializers method) (cdr specializers))
1962	(args args (cdr args)))
1963	((null specializers) t)
1964	(let ((specializer (car specializers)))
1965	(if (typep specializer 'eql-specializer)
1966	(unless (eql (car args) (eql-specializer-object specializer))
1967	(return nil))
1968	(unless (subclassp (class-of (car args)) specializer)
1969	(return nil))))))
1970
1971	(defun %compute-applicable-methods (gf args)
1972	(let ((required-classes (mapcar #'class-of (required-portion gf args)))
1973	(methods '()))
1974	(dolist (method (generic-function-methods gf))
1975	(when (method-applicable-p method args)
1976	(push method methods)))
1977	(sort-methods methods gf required-classes)))
1978
1979	;;; METHOD-APPLICABLE-USING-CLASSES-P
1980	;;;
1981	;;; If the first return value is T, METHOD is definitely applicable to
1982	;;; arguments that are instances of CLASSES. If the first value is
1983	;;; NIL and the second value is T, METHOD is definitely not applicable
1984	;;; to arguments that are instances of CLASSES; if the second value is
1985	;;; NIL the applicability of METHOD cannot be determined by inspecting
1986	;;; the classes of its arguments only.
1987	;;;
1988	(defun method-applicable-using-classes-p (method classes)
1989	(do* ((specializers (%method-specializers method) (cdr specializers))
1990	(classes classes (cdr classes))
1991	(knownp t))
1992	((null specializers)
1993	(if knownp (values t t) (values nil nil)))
1994	(let ((specializer (car specializers)))
1995	(if (typep specializer 'eql-specializer)
1996	(if (eql (class-of (eql-specializer-object specializer))
1997	(car classes))
1998	(setf knownp nil)
1999	(return (values nil t)))
2000	(unless (subclassp (car classes) specializer)
2001	(return (values nil t)))))))
2002
2003	(defun slow-method-lookup (gf args)
2004	(let ((applicable-methods (%compute-applicable-methods gf args)))
2005	(if applicable-methods
2006	(let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
2007	#'std-compute-effective-method-function
2008	#'compute-effective-method-function)
2009	gf applicable-methods)))
2010	(cache-emf gf args emfun)
2011	(funcall emfun args))
2012	(apply #'no-applicable-method gf args))))
2013
2014	(defun slow-method-lookup-1 (gf arg arg-specialization)
2015	(let ((applicable-methods (%compute-applicable-methods gf (list arg))))
2016	(if applicable-methods
2017	(let ((emfun (funcall (if (eq (class-of gf) +the-standard-generic-function-class+)
2018	#'std-compute-effective-method-function
2019	#'compute-effective-method-function)
2020	gf applicable-methods)))
2021	(when emfun
2022	(setf (gethash arg-specialization (classes-to-emf-table gf)) emfun))
2023	emfun))))
2024
2025	(defun sub-specializer-p (c1 c2 c-arg)
2026	(find c2 (cdr (memq c1 (%class-precedence-list c-arg)))))
2027
2028	(defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order)
2029	(if argument-precedence-order
2030	(let ((specializers-1 (%method-specializers method1))
2031	(specializers-2 (%method-specializers method2)))
2032	(dolist (index argument-precedence-order)
2033	(let ((spec1 (nth index specializers-1))
2034	(spec2 (nth index specializers-2)))
2035	(unless (eq spec1 spec2)
2036	(cond ((typep spec1 'eql-specializer)
2037	(return t))
2038	((typep spec2 'eql-specializer)
2039	(return nil))
2040	(t
2041	(return (sub-specializer-p spec1 spec2
2042	(nth index required-classes)))))))))
2043	(do ((specializers-1 (%method-specializers method1) (cdr specializers-1))
2044	(specializers-2 (%method-specializers method2) (cdr specializers-2))
2045	(classes required-classes (cdr classes)))
2046	((null specializers-1) nil)
2047	(let ((spec1 (car specializers-1))
2048	(spec2 (car specializers-2)))
2049	(unless (eq spec1 spec2)
2050	(cond ((typep spec1 'eql-specializer)
2051	(return t))
2052	((typep spec2 'eql-specializer)
2053	(return nil))
2054	(t
2055	(return (sub-specializer-p spec1 spec2 (car classes))))))))))
2056
2057	(defun primary-method-p (method)
2058	(null (intersection '(:before :after :around) (method-qualifiers method))))
2059
2060	(defun before-method-p (method)
2061	(equal '(:before) (method-qualifiers method)))
2062
2063	(defun after-method-p (method)
2064	(equal '(:after) (method-qualifiers method)))
2065
2066	(defun around-method-p (method)
2067	(equal '(:around) (method-qualifiers method)))
2068
2069	(defun process-next-method-list (next-method-list)
2070	(mapcar #'(lambda (next-method-form)
2071	(cond
2072	((listp next-method-form)
2073	(assert (eq (first next-method-form) 'make-method))
2074	(let* ((rest-sym (gensym)))
2075	(make-instance-standard-method
2076	nil ;; ignored
2077	:lambda-list (list '&rest rest-sym)
2078	:function (compute-method-function `(lambda (&rest ,rest-sym)
2079	,(second next-method-form))))))
2080	(t
2081	(assert (typep next-method-form 'method))
2082	next-method-form)))
2083	next-method-list))
2084
2085	(defun std-compute-effective-method-function (gf methods)
2086	(let* ((mc (generic-function-method-combination gf))
2087	(mc-name (if (atom mc) mc (%car mc)))
2088	(options (if (atom mc) '() (%cdr mc)))
2089	(order (car options))
2090	(primaries '())
2091	(arounds '())
2092	around
2093	emf-form
2094	(long-method-combination-p
2095	(typep (get mc-name 'method-combination-object) 'long-method-combination)))
2096	(unless long-method-combination-p
2097	(dolist (m methods)
2098	(let ((qualifiers (method-qualifiers m)))
2099	(cond ((null qualifiers)
2100	(if (eq mc-name 'standard)
2101	(push m primaries)
2102	(error "Method combination type mismatch.")))
2103	((cdr qualifiers)
2104	(error "Invalid method qualifiers."))
2105	((eq (car qualifiers) :around)
2106	(push m arounds))
2107	((eq (car qualifiers) mc-name)
2108	(push m primaries))
2109	((memq (car qualifiers) '(:before :after)))
2110	(t
2111	(error "Invalid method qualifiers."))))))
2112	(unless (eq order :most-specific-last)
2113	(setf primaries (nreverse primaries)))
2114	(setf arounds (nreverse arounds))
2115	(setf around (car arounds))
2116	(when (and (null primaries) (not long-method-combination-p))
2117	(error "No primary methods for the generic function ~S." gf))
2118	(cond
2119	(around
2120	(let ((next-emfun
2121	(funcall
2122	(if (eq (class-of gf) +the-standard-generic-function-class+)
2123	#'std-compute-effective-method-function
2124	#'compute-effective-method-function)
2125	gf (remove around methods))))
2126	(setf emf-form
2127	(generate-emf-lambda (%method-function around) next-emfun))))
2128	((eq mc-name 'standard)
2129	(let* ((next-emfun (compute-primary-emfun (cdr primaries)))
2130	(befores (remove-if-not #'before-method-p methods))
2131	(reverse-afters
2132	(reverse (remove-if-not #'after-method-p methods))))
2133	(setf emf-form
2134	(cond
2135	((and (null befores) (null reverse-afters))
2136	(let ((fast-function (%method-fast-function (car primaries))))
2137	(if fast-function
2138	(ecase (length (gf-required-args gf))
2139	(1
2140	#'(lambda (args)
2141	(declare (optimize speed))
2142	(funcall fast-function (car args))))
2143	(2
2144	#'(lambda (args)
2145	(declare (optimize speed))
2146	(funcall fast-function (car args) (cadr args)))))
2147	(generate-emf-lambda (%method-function (car primaries))
2148	next-emfun))))
2149	(t
2150	(let ((method-function (%method-function (car primaries))))
2151	#'(lambda (args)
2152	(declare (optimize speed))
2153	(dolist (before befores)
2154	(funcall (%method-function before) args nil))
2155	(multiple-value-prog1
2156	(funcall method-function args next-emfun)
2157	(dolist (after reverse-afters)
2158	(funcall (%method-function after) args nil))))))))))
2159	(long-method-combination-p
2160	(let* ((mc-obj (get mc-name 'method-combination-object))
2161	(function (long-method-combination-function mc-obj))
2162	(arguments (rest (slot-value gf 'method-combination))))
2163	(assert (typep mc-obj 'long-method-combination))
2164	(assert function)
2165	(setf emf-form
2166	(if arguments
2167	(apply function gf methods arguments)
2168	(funcall function gf methods)))))
2169	(t
2170	(let ((mc-obj (get mc-name 'method-combination-object)))
2171	(unless (typep mc-obj 'short-method-combination)
2172	(error "Unsupported method combination type ~A."
2173	mc-name))
2174	(let* ((operator (short-method-combination-operator mc-obj))
2175	(ioa (short-method-combination-identity-with-one-argument mc-obj)))
2176	(setf emf-form
2177	(if (and (null (cdr primaries))
2178	(not (null ioa)))
2179	(generate-emf-lambda (%method-function (car primaries)) nil)
2180	`(lambda (args)
2181	(,operator ,@(mapcar
2182	(lambda (primary)
2183	`(funcall ,(%method-function primary) args nil))
2184	primaries)))))))))
2185	(assert (not (null emf-form)))
2186	(or #+nil (ignore-errors (autocompile emf-form))
2187	(coerce-to-function emf-form))))
2188
2189	(defun generate-emf-lambda (method-function next-emfun)
2190	#'(lambda (args)
2191	(declare (optimize speed))
2192	(funcall method-function args next-emfun)))
2193
2194	;;; compute an effective method function from a list of primary methods:
2195
2196	(defun compute-primary-emfun (methods)
2197	(if (null methods)
2198	nil
2199	(let ((next-emfun (compute-primary-emfun (cdr methods))))
2200	#'(lambda (args)
2201	(funcall (%method-function (car methods)) args next-emfun)))))
2202
2203	(defvar call-next-method-p)
2204	(defvar next-method-p-p)
2205
2206	(defun walk-form (form)
2207	(cond ((atom form)
2208	(cond ((eq form 'call-next-method)
2209	(setf call-next-method-p t))
2210	((eq form 'next-method-p)
2211	(setf next-method-p-p t))))
2212	(t
2213	(walk-form (%car form))
2214	(walk-form (%cdr form)))))
2215
2216	(defun compute-method-function (lambda-expression)
2217	(let ((lambda-list (allow-other-keys (cadr lambda-expression)))
2218	(body (cddr lambda-expression))
2219	(call-next-method-p nil)
2220	(next-method-p-p nil))
2221	(multiple-value-bind (body declarations) (parse-body body)
2222	(let ((ignorable-vars '()))
2223	(dolist (var lambda-list)
2224	(if (memq var lambda-list-keywords)
2225	(return)
2226	(push var ignorable-vars)))
2227	(push `(declare (ignorable ,@ignorable-vars)) declarations))
2228	(walk-form body)
2229	(cond ((or call-next-method-p next-method-p-p)
2230	`(lambda (args next-emfun)
2231	(flet ((call-next-method (&rest cnm-args)
2232	(if (null next-emfun)
2233	(error "No next method for generic function.")
2234	(funcall next-emfun (or cnm-args args))))
2235	(next-method-p ()
2236	(not (null next-emfun))))
2237	(declare (ignorable (function call-next-method)
2238	(function next-method-p)))
2239	(apply #'(lambda ,lambda-list ,@declarations ,@body) args))))
2240	((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)))
2241	;; Required parameters only.
2242	(case (length lambda-list)
2243	(1
2244	`(lambda (args next-emfun)
2245	(declare (ignore next-emfun))
2246	(let ((,(%car lambda-list) (%car args)))
2247	(declare (ignorable ,(%car lambda-list)))
2248	,@declarations ,@body)))
2249	(2
2250	`(lambda (args next-emfun)
2251	(declare (ignore next-emfun))
2252	(let ((,(%car lambda-list) (%car args))
2253	(,(%cadr lambda-list) (%cadr args)))
2254	(declare (ignorable ,(%car lambda-list)
2255	,(%cadr lambda-list)))
2256	,@declarations ,@body)))
2257	(3
2258	`(lambda (args next-emfun)
2259	(declare (ignore next-emfun))
2260	(let ((,(%car lambda-list) (%car args))
2261	(,(%cadr lambda-list) (%cadr args))
2262	(,(%caddr lambda-list) (%caddr args)))
2263	(declare (ignorable ,(%car lambda-list)
2264	,(%cadr lambda-list)
2265	,(%caddr lambda-list)))
2266	,@declarations ,@body)))
2267	(t
2268	`(lambda (args next-emfun)
2269	(declare (ignore next-emfun))
2270	(apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))
2271	(t
2272	`(lambda (args next-emfun)
2273	(declare (ignore next-emfun))
2274	(apply #'(lambda ,lambda-list ,@declarations ,@body) args)))))))
2275
2276	(defun compute-method-fast-function (lambda-expression)
2277	(let ((lambda-list (allow-other-keys (cadr lambda-expression))))
2278	(when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))
2279	(return-from compute-method-fast-function nil))
2280	;; Only required args.
2281	(let ((body (cddr lambda-expression))
2282	(call-next-method-p nil)
2283	(next-method-p-p nil))
2284	(multiple-value-bind (body declarations) (parse-body body)
2285	(walk-form body)
2286	(when (or call-next-method-p next-method-p-p)
2287	(return-from compute-method-fast-function nil))
2288	(let ((decls `(declare (ignorable ,@lambda-list))))
2289	(setf lambda-expression
2290	(list* (car lambda-expression)
2291	(cadr lambda-expression)
2292	decls
2293	(cddr lambda-expression))))
2294	(case (length lambda-list)
2295	(1
2296	;; `(lambda (args next-emfun)
2297	;; (let ((,(%car lambda-list) (%car args)))
2298	;; (declare (ignorable ,(%car lambda-list)))
2299	;; ,@declarations ,@body)))
2300	lambda-expression)
2301	(2
2302	;; `(lambda (args next-emfun)
2303	;; (let ((,(%car lambda-list) (%car args))
2304	;; (,(%cadr lambda-list) (%cadr args)))
2305	;; (declare (ignorable ,(%car lambda-list)
2306	;; ,(%cadr lambda-list)))
2307	;; ,@declarations ,@body)))
2308	lambda-expression)
2309	;; (3
2310	;; `(lambda (args next-emfun)
2311	;; (let ((,(%car lambda-list) (%car args))
2312	;; (,(%cadr lambda-list) (%cadr args))
2313	;; (,(%caddr lambda-list) (%caddr args)))
2314	;; (declare (ignorable ,(%car lambda-list)
2315	;; ,(%cadr lambda-list)
2316	;; ,(%caddr lambda-list)))
2317	;; ,@declarations ,@body)))
2318	(t
2319	nil))))))
2320
2321	;; From CLHS section 7.6.5:
2322	;; "When a generic function or any of its methods mentions &key in a lambda
2323	;; list, the specific set of keyword arguments accepted by the generic function
2324	;; varies according to the applicable methods. The set of keyword arguments
2325	;; accepted by the generic function for a particular call is the union of the
2326	;; keyword arguments accepted by all applicable methods and the keyword
2327	;; arguments mentioned after &key in the generic function definition, if any."
2328	;; Adapted from Sacla.
2329	(defun allow-other-keys (lambda-list)
2330	(if (and (member '&key lambda-list)
2331	(not (member '&allow-other-keys lambda-list)))
2332	(let* ((key-end (or (position '&aux lambda-list) (length lambda-list)))
2333	(aux-part (subseq lambda-list key-end)))
2334	`(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part))
2335	lambda-list))
2336
2337	(defmacro defmethod (&rest args)
2338	(multiple-value-bind
2339	(function-name qualifiers lambda-list specializers documentation declarations body)
2340	(parse-defmethod args)
2341	(let* ((specializers-form '())
2342	(lambda-expression `(lambda ,lambda-list ,@declarations ,body))
2343	(method-function (compute-method-function lambda-expression))
2344	(fast-function (compute-method-fast-function lambda-expression))
2345	)
2346	(dolist (specializer specializers)
2347	(cond ((and (consp specializer) (eq (car specializer) 'eql))
2348	(push `(list 'eql ,(cadr specializer)) specializers-form))
2349	(t
2350	(push `',specializer specializers-form))))
2351	(setf specializers-form `(list ,@(nreverse specializers-form)))
2352	`(progn
2353	(ensure-method ',function-name
2354	:lambda-list ',lambda-list
2355	:qualifiers ',qualifiers
2356	:specializers ,specializers-form
2357	,@(if documentation `(:documentation ,documentation))
2358	:function (function ,method-function)
2359	,@(if fast-function `(:fast-function (function ,fast-function)))
2360	)))))
2361
2362	;;; Reader and writer methods
2363
2364	(defun make-instance-standard-reader-method (gf
2365	&key
2366	lambda-list
2367	qualifiers
2368	specializers
2369	documentation
2370	function
2371	fast-function
2372	slot-name)
2373	(declare (ignore gf))
2374	(let ((method (std-allocate-instance +the-standard-reader-method-class+)))
2375	(setf (method-lambda-list method) lambda-list)
2376	(setf (method-qualifiers method) qualifiers)
2377	(%set-method-specializers method (canonicalize-specializers specializers))
2378	(setf (method-documentation method) documentation)
2379	(%set-method-generic-function method nil)
2380	(%set-method-function method function)
2381	(%set-method-fast-function method fast-function)
2382	(set-reader-method-slot-name method slot-name)
2383	method))
2384
2385	(defun add-reader-method (class function-name slot-name)
2386	(let* ((lambda-expression
2387	(if (eq (class-of class) +the-standard-class+)
2388	`(lambda (object) (std-slot-value object ',slot-name))
2389	`(lambda (object) (slot-value object ',slot-name))))
2390	(method-function (compute-method-function lambda-expression))
2391	(fast-function (compute-method-fast-function lambda-expression)))
2392	(let ((method-lambda-list '(object))
2393	(gf (find-generic-function function-name nil)))
2394	(if gf
2395	(check-method-lambda-list function-name
2396	method-lambda-list
2397	(generic-function-lambda-list gf))
2398	(setf gf (ensure-generic-function function-name :lambda-list method-lambda-list)))
2399	(let ((method
2400	(make-instance-standard-reader-method gf
2401	:lambda-list '(object)
2402	:qualifiers ()
2403	:specializers (list class)
2404	:function (if (autoloadp 'compile)
2405	method-function
2406	(autocompile method-function))
2407	:fast-function (if (autoloadp 'compile)
2408	fast-function
2409	(autocompile fast-function))
2410	:slot-name slot-name)))
2411	(%add-method gf method)
2412	method))))
2413
2414	(defun add-writer-method (class function-name slot-name)
2415	(let* ((lambda-expression
2416	(if (eq (class-of class) +the-standard-class+)
2417	`(lambda (new-value object)
2418	(setf (std-slot-value object ',slot-name) new-value))
2419	`(lambda (new-value object)
2420	(setf (slot-value object ',slot-name) new-value))))
2421	(method-function (compute-method-function lambda-expression))
2422	(fast-function (compute-method-fast-function lambda-expression))
2423	)
2424	(ensure-method function-name
2425	:lambda-list '(new-value object)
2426	:qualifiers ()
2427	:specializers (list +the-T-class+ class)
2428	;; :function `(function ,method-function)
2429	:function (if (autoloadp 'compile)
2430	method-function
2431	(autocompile method-function))
2432	:fast-function (if (autoloadp 'compile)
2433	fast-function
2434	(autocompile fast-function))
2435	)))
2436
2437	(defmacro atomic-defgeneric (function-name &rest rest)
2438	"Macro to define a generic function and 'swap it into place' after
2439	it's been fully defined with all its methods.
2440
2441	Note: the user should really use the (:method ..) method description
2442	way of defining methods; there's not much use in atomically defining
2443	generic functions without providing sensible behaviour..."
2444	(let ((temp-sym (gensym)))
2445	`(progn
2446	(defgeneric ,temp-sym ,@rest)
2447	(let ((gf (symbol-function ',temp-sym)))
2448	(setf ,(if (and (consp function-name)
2449	(eq (car function-name) 'setf))
2450	`(get ',(second function-name) 'setf-function)
2451	`(symbol-function ',function-name)) gf)
2452	(%set-generic-function-name gf ',function-name)
2453	gf))))
2454
2455	(defmacro redefine-class-forwarder (name slot)
2456	"Define a generic function on a temporary symbol as an accessor
2457	for the slot `slot'. Then, when definition is complete (including
2458	allocation of methods), swap the definition in place.
2459
2460	Without this approach, we can't depend the old forwarders to be
2461	in place, while we still need them to "
2462	(let* (($name (if (consp name) (cadr name) name))
2463	(%name (intern (concatenate 'string
2464	"%"
2465	(if (consp name)
2466	(symbol-name 'set-) "")
2467	(symbol-name $name))
2468	(find-package "SYS"))))
2469	`(atomic-defgeneric ,name (;; splice a new-value parameter for setters
2470	,@(when (consp name) (list 'new-value))
2471	class)
2472	,@(mapcar (if (consp name)
2473	#'(lambda (class-name)
2474	`(:method (new-value (class ,class-name))
2475	(,%name new-value class)))
2476	#'(lambda (class-name)
2477	`(:method ((class ,class-name))
2478	(,%name class))))
2479	'(built-in-class
2480	forward-referenced-class
2481	structure-class))
2482	(:method (,@(when (consp name) (list 'new-value))
2483	(class standard-class))
2484	,(if (consp name)
2485	`(setf (slot-value class ',slot) new-value)
2486	`(slot-value class ',slot))))))
2487
2488
2489	(redefine-class-forwarder class-name name)
2490	(redefine-class-forwarder (setf class-name) name)
2491	(redefine-class-forwarder class-slots slots)
2492	(redefine-class-forwarder (setf class-slots) slots)
2493	(redefine-class-forwarder class-direct-slots direct-slots)
2494	(redefine-class-forwarder (setf class-direct-slots) direct-slots)
2495	(redefine-class-forwarder class-layout layout)
2496	(redefine-class-forwarder (setf class-layout) layout)
2497	(redefine-class-forwarder class-direct-superclasses direct-superclasses)
2498	(redefine-class-forwarder (setf class-direct-superclasses) direct-superclasses)
2499	(redefine-class-forwarder class-direct-subclasses direct-subclasses)
2500	(redefine-class-forwarder (setf class-direct-subclasses) direct-subclasses)
2501	(redefine-class-forwarder class-direct-methods direct-methods)
2502	(redefine-class-forwarder (setf class-direct-methods) direct-methods)
2503	(redefine-class-forwarder class-precedence-list precedence-list)
2504	(redefine-class-forwarder (setf class-precedence-list) precedence-list)
2505	(redefine-class-forwarder class-finalized-p finalized-p)
2506	(redefine-class-forwarder (setf class-finalized-p) finalized-p)
2507	(redefine-class-forwarder class-default-initargs default-initargs)
2508	(redefine-class-forwarder (setf class-default-initargs) default-initargs)
2509	(redefine-class-forwarder class-direct-default-initargs direct-default-initargs)
2510	(redefine-class-forwarder (setf class-direct-default-initargs) direct-default-initargs)
2511
2512	(defgeneric direct-slot-definition-class (class &rest initargs))
2513
2514	(defmethod direct-slot-definition-class ((class class) &rest initargs)
2515	(declare (ignore initargs))
2516	+the-standard-direct-slot-definition-class+)
2517
2518	(defgeneric effective-slot-definition-class (class &rest initargs))
2519
2520	(defmethod effective-slot-definition-class ((class class) &rest initargs)
2521	(declare (ignore initargs))
2522	+the-standard-effective-slot-definition-class+)
2523
2524	(atomic-defgeneric documentation (x doc-type)
2525	(:method ((x symbol) doc-type)
2526	(%documentation x doc-type))
2527	(:method ((x function) doc-type)
2528	(%documentation x doc-type)))
2529
2530	(atomic-defgeneric (setf documentation) (new-value x doc-type)
2531	(:method (new-value (x symbol) doc-type)
2532	(%set-documentation x doc-type new-value))
2533	(:method (new-value (x function) doc-type)
2534	(%set-documentation x doc-type new-value)))
2535
2536
2537	;; FIXME This should be a weak hashtable!
2538	(defvar list-documentation-hashtable (make-hash-table :test #'equal))
2539
2540	(defmethod documentation ((x list) (doc-type (eql 'function)))
2541	(let ((alist (gethash x list-documentation-hashtable)))
2542	(and alist (cdr (assoc doc-type alist)))))
2543
2544	(defmethod documentation ((x list) (doc-type (eql 'compiler-macro)))
2545	(let ((alist (gethash x list-documentation-hashtable)))
2546	(and alist (cdr (assoc doc-type alist)))))
2547
2548	(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
2549	(let* ((alist (gethash x list-documentation-hashtable))
2550	(entry (and alist (assoc doc-type alist))))
2551	(cond (entry
2552	(setf (cdr entry) new-value))
2553	(t
2554	(setf (gethash x list-documentation-hashtable)
2555	(push (cons doc-type new-value) alist)))))
2556	new-value)
2557
2558	(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'compiler-macro)))
2559	(let* ((alist (gethash x list-documentation-hashtable))
2560	(entry (and alist (assoc doc-type alist))))
2561	(cond (entry
2562	(setf (cdr entry) new-value))
2563	(t
2564	(setf (gethash x list-documentation-hashtable)
2565	(push (cons doc-type new-value) alist)))))
2566	new-value)
2567
2568	(defmethod documentation ((x standard-class) (doc-type (eql 't)))
2569	(class-documentation x))
2570
2571	(defmethod documentation ((x standard-class) (doc-type (eql 'type)))
2572	(class-documentation x))
2573
2574	(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 't)))
2575	(%set-class-documentation x new-value))
2576
2577	(defmethod (setf documentation) (new-value (x standard-class) (doc-type (eql 'type)))
2578	(%set-class-documentation x new-value))
2579
2580	(defmethod documentation ((x structure-class) (doc-type (eql 't)))
2581	(%documentation x doc-type))
2582
2583	(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
2584	(%documentation x doc-type))
2585
2586	(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 't)))
2587	(%set-documentation x doc-type new-value))
2588
2589	(defmethod (setf documentation) (new-value (x structure-class) (doc-type (eql 'type)))
2590	(%set-documentation x doc-type new-value))
2591
2592	(defmethod documentation ((x standard-generic-function) (doc-type (eql 't)))
2593	(generic-function-documentation x))
2594
2595	(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 't)))
2596	(setf (generic-function-documentation x) new-value))
2597
2598	(defmethod documentation ((x standard-generic-function) (doc-type (eql 'function)))
2599	(generic-function-documentation x))
2600
2601	(defmethod (setf documentation) (new-value (x standard-generic-function) (doc-type (eql 'function)))
2602	(setf (generic-function-documentation x) new-value))
2603
2604	(defmethod documentation ((x standard-method) (doc-type (eql 't)))
2605	(method-documentation x))
2606
2607	(defmethod (setf documentation) (new-value (x standard-method) (doc-type (eql 't)))
2608	(setf (method-documentation x) new-value))
2609
2610	(defmethod documentation ((x package) (doc-type (eql 't)))
2611	(%documentation x doc-type))
2612
2613	(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
2614	(%set-documentation x doc-type new-value))
2615
2616	(defmethod documentation ((x symbol) (doc-type (eql 'function)))
2617	(%documentation x doc-type))
2618
2619	;;; Applicable methods
2620
2621	(defgeneric compute-applicable-methods (gf args)
2622	(:method ((gf standard-generic-function) args)
2623	(%compute-applicable-methods gf args)))
2624
2625	(defgeneric compute-applicable-methods-using-classes (gf classes)
2626	(:method ((gf standard-generic-function) classes)
2627	(let ((methods '()))
2628	(dolist (method (generic-function-methods gf))
2629	(multiple-value-bind (applicable knownp)
2630	(method-applicable-using-classes-p method classes)
2631	(cond (applicable
2632	(push method methods))
2633	((not knownp)
2634	(return-from compute-applicable-methods-using-classes
2635	(values nil nil))))))
2636	(values (sort-methods methods gf classes)
2637	t))))
2638
2639	(export '(compute-applicable-methods
2640	compute-applicable-methods-using-classes))
2641
2642
2643	;;; Slot access
2644
2645	(defun set-slot-value-using-class (new-value class instance slot-name)
2646	(declare (ignore class)) ; FIXME
2647	(setf (std-slot-value instance slot-name) new-value))
2648
2649	(defgeneric slot-value-using-class (class instance slot-name))
2650
2651	(defmethod slot-value-using-class ((class standard-class) instance slot-name)
2652	(std-slot-value instance slot-name))
2653
2654	(defmethod slot-value-using-class ((class structure-class) instance slot-name)
2655	(std-slot-value instance slot-name))
2656
2657	(defgeneric (setf slot-value-using-class) (new-value class instance slot-name))
2658
2659	(defmethod (setf slot-value-using-class) (new-value
2660	(class standard-class)
2661	instance
2662	slot-name)
2663	(setf (std-slot-value instance slot-name) new-value))
2664
2665	(defmethod (setf slot-value-using-class) (new-value
2666	(class structure-class)
2667	instance
2668	slot-name)
2669	(setf (std-slot-value instance slot-name) new-value))
2670
2671	(defgeneric slot-exists-p-using-class (class instance slot-name))
2672
2673	(defmethod slot-exists-p-using-class (class instance slot-name)
2674	nil)
2675
2676	(defmethod slot-exists-p-using-class ((class standard-class) instance slot-name)
2677	(std-slot-exists-p instance slot-name))
2678
2679	(defmethod slot-exists-p-using-class ((class structure-class) instance slot-name)
2680	(dolist (dsd (class-slots class))
2681	(when (eq (sys::dsd-name dsd) slot-name)
2682	(return-from slot-exists-p-using-class t)))
2683	nil)
2684
2685	(defgeneric slot-boundp-using-class (class instance slot-name))
2686	(defmethod slot-boundp-using-class ((class standard-class) instance slot-name)
2687	(std-slot-boundp instance slot-name))
2688	(defmethod slot-boundp-using-class ((class structure-class) instance slot-name)
2689	"Structure slots can't be unbound, so this method always returns T."
2690	(declare (ignore class instance slot-name))
2691	t)
2692
2693	(defgeneric slot-makunbound-using-class (class instance slot-name))
2694	(defmethod slot-makunbound-using-class ((class standard-class)
2695	instance
2696	slot-name)
2697	(std-slot-makunbound instance slot-name))
2698	(defmethod slot-makunbound-using-class ((class structure-class)
2699	instance
2700	slot-name)
2701	(declare (ignore class instance slot-name))
2702	(error "Structure slots can't be unbound"))
2703
2704	(defgeneric slot-missing (class instance slot-name operation &optional new-value))
2705
2706	(defmethod slot-missing ((class t) instance slot-name operation &optional new-value)
2707	(declare (ignore new-value))
2708	(error "The slot ~S is missing from the class ~S." slot-name class))
2709
2710	(defgeneric slot-unbound (class instance slot-name))
2711
2712	(defmethod slot-unbound ((class t) instance slot-name)
2713	(error 'unbound-slot :instance instance :name slot-name))
2714
2715	;;; Instance creation and initialization
2716
2717	(defgeneric allocate-instance (class &rest initargs &key &allow-other-keys))
2718
2719	(defmethod allocate-instance ((class standard-class) &rest initargs)
2720	(declare (ignore initargs))
2721	(std-allocate-instance class))
2722
2723	(defmethod allocate-instance ((class structure-class) &rest initargs)
2724	(declare (ignore initargs))
2725	(%make-structure (class-name class)
2726	(make-list (length (class-slots class))
2727	:initial-element +slot-unbound+)))
2728
2729	;; "The set of valid initialization arguments for a class is the set of valid
2730	;; initialization arguments that either fill slots or supply arguments to
2731	;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS."
2732	;; 7.1.2
2733
2734	(defun calculate-allowable-initargs (gf-list args instance
2735	shared-initialize-param
2736	initargs)
2737	(let* ((methods
2738	(nconc
2739	(compute-applicable-methods #'shared-initialize
2740	(list* instance
2741	shared-initialize-param
2742	initargs))
2743	(mapcan #'(lambda (gf)
2744	(compute-applicable-methods gf args))
2745	gf-list)))
2746	(method-keyword-args
2747	(reduce #'merge-initargs-sets
2748	(mapcar #'method-lambda-list methods)
2749	:key #'extract-lambda-list-keywords
2750	:initial-value nil))
2751	(slots-initargs
2752	(mapappend #'slot-definition-initargs
2753	(class-slots (class-of instance)))))
2754	(merge-initargs-sets
2755	(merge-initargs-sets slots-initargs method-keyword-args)
2756	'(:allow-other-keys)))) ;; allow-other-keys is always allowed
2757
2758	(defun check-initargs (gf-list args instance
2759	shared-initialize-param initargs
2760	cache call-site)
2761	"Checks the validity of `initargs' for the generic functions in `gf-list'
2762	when called with `args' by calculating the applicable methods for each gf.
2763	The applicable methods for SHARED-INITIALIZE based on `instance',
2764	`shared-initialize-param' and `initargs' are added to the list of
2765	applicable methods."
2766	(when (oddp (length initargs))
2767	(error 'program-error
2768	:format-control "Odd number of keyword arguments."))
2769	(unless (getf initargs :allow-other-keys)
2770	(multiple-value-bind (allowable-initargs present-p)
2771	(when cache
2772	(gethash (class-of instance) cache))
2773	(unless present-p
2774	(setf allowable-initargs
2775	(calculate-allowable-initargs gf-list args instance
2776	shared-initialize-param initargs))
2777	(when cache
2778	(setf (gethash (class-of instance) cache)
2779	allowable-initargs)))
2780	(unless (eq t allowable-initargs)
2781	(do* ((tail initargs (cddr tail))
2782	(initarg (car tail) (car tail)))
2783	((null tail))
2784	(unless (memq initarg allowable-initargs)
2785	(error 'program-error
2786	:format-control "Invalid initarg ~S in call to ~S ~
2787	with arglist ~S."
2788	:format-arguments (list initarg call-site args))))))))
2789
2790	(defun merge-initargs-sets (list1 list2)
2791	(cond
2792	((eq list1 t) t)
2793	((eq list2 t) t)
2794	(t (union list1 list2))))
2795
2796	(defun extract-lambda-list-keywords (lambda-list)
2797	"Returns a list of keywords acceptable as keyword arguments,
2798	or T when any keyword is acceptable due to presence of
2799	&allow-other-keys."
2800	(when (member '&allow-other-keys lambda-list)
2801	(return-from extract-lambda-list-keywords t))
2802	(loop with keyword-args = (cdr (memq '&key lambda-list))
2803	for key in keyword-args
2804	when (eq key '&aux) do (loop-finish)
2805	when (eq key '&allow-other-keys) do (return t)
2806	when (listp key) do (setq key (car key))
2807	collect (if (symbolp key)
2808	(make-keyword key)
2809	(car key))))
2810
2811
2812	(defgeneric make-instance (class &rest initargs &key &allow-other-keys))
2813
2814	(defmethod make-instance ((class standard-class) &rest initargs)
2815	(when (oddp (length initargs))
2816	(error 'program-error :format-control "Odd number of keyword arguments."))
2817	(unless (class-finalized-p class)
2818	(std-finalize-inheritance class))
2819	(let ((class-default-initargs (class-default-initargs class)))
2820	(when class-default-initargs
2821	(let ((default-initargs '()))
2822	(do* ((list class-default-initargs (cddr list))
2823	(key (car list) (car list))
2824	(fn (cadr list) (cadr list)))
2825	((null list))
2826	(when (eq (getf initargs key 'not-found) 'not-found)
2827	(setf default-initargs (append default-initargs (list key (funcall fn))))))
2828	(setf initargs (append initargs default-initargs)))))
2829
2830	(let ((instance (std-allocate-instance class)))
2831	(check-initargs (list #'allocate-instance #'initialize-instance)
2832	(list* instance initargs)
2833	instance t initargs
2834	make-instance-initargs-cache 'make-instance)
2835	(apply #'initialize-instance instance initargs)
2836	instance))
2837
2838	(defmethod make-instance ((class symbol) &rest initargs)
2839	(apply #'make-instance (find-class class) initargs))
2840
2841	(defgeneric initialize-instance (instance &key))
2842
2843	(defmethod initialize-instance ((instance standard-object) &rest initargs)
2844	(apply #'shared-initialize instance t initargs))
2845
2846	(defgeneric reinitialize-instance (instance &key))
2847
2848	;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the
2849	;; validity of initargs and signals an error if an initarg is supplied that is
2850	;; not declared as valid. The method then calls the generic function SHARED-
2851	;; INITIALIZE with the following arguments: the instance, nil (which means no
2852	;; slots should be initialized according to their initforms), and the initargs
2853	;; it received."
2854	(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
2855	(check-initargs (list #'reinitialize-instance) (list* instance initargs)
2856	instance () initargs
2857	reinitialize-instance-initargs-cache 'reinitialize-instance)
2858	(apply #'shared-initialize instance () initargs))
2859
2860	(defun std-shared-initialize (instance slot-names all-keys)
2861	(when (oddp (length all-keys))
2862	(error 'program-error :format-control "Odd number of keyword arguments."))
2863	;; do a quick scan of the arguments list to see if it's a real
2864	;; 'initialization argument list' (which is not the same as
2865	;; checking initarg validity
2866	(do* ((tail all-keys (cddr tail))
2867	(initarg (car tail) (car tail)))
2868	((null tail))
2869	(unless (symbolp initarg)
2870	(error 'program-error
2871	:format-control "Initarg ~S not a symbol."
2872	:format-arguments (list initarg))))
2873	(dolist (slot (class-slots (class-of instance)))
2874	(let ((slot-name (slot-definition-name slot)))
2875	(multiple-value-bind (init-key init-value foundp)
2876	(get-properties all-keys (slot-definition-initargs slot))
2877	(if foundp
2878	(setf (std-slot-value instance slot-name) init-value)
2879	(unless (std-slot-boundp instance slot-name)
2880	(let ((initfunction (slot-definition-initfunction slot)))
2881	(when (and initfunction (or (eq slot-names t)
2882	(memq slot-name slot-names)))
2883	(setf (std-slot-value instance slot-name)
2884	(funcall initfunction)))))))))
2885	instance)
2886
2887	(defgeneric shared-initialize (instance slot-names &key))
2888
2889	(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs)
2890	(std-shared-initialize instance slot-names initargs))
2891
2892	(defmethod shared-initialize ((slot slot-definition) slot-names
2893	&rest args
2894	&key name initargs initform initfunction
2895	readers writers allocation
2896	&allow-other-keys)
2897	;;Keyword args are duplicated from init-slot-definition only to have
2898	;;them checked.
2899	(declare (ignore slot-names)) ;;TODO?
2900	(declare (ignore name initargs initform initfunction readers writers allocation))
2901	;;For built-in slots
2902	(apply #'init-slot-definition slot :allow-other-keys t args)
2903	;;For user-defined slots
2904	(call-next-method))
2905
2906	;;; change-class
2907
2908	(defgeneric change-class (instance new-class &key))
2909
2910	(defmethod change-class ((old-instance standard-object) (new-class standard-class)
2911	&rest initargs)
2912	(let ((old-slots (class-slots (class-of old-instance)))
2913	(new-slots (class-slots new-class))
2914	(new-instance (allocate-instance new-class)))
2915	;; "The values of local slots specified by both the class CTO and the class
2916	;; CFROM are retained. If such a local slot was unbound, it remains
2917	;; unbound."
2918	(dolist (new-slot new-slots)
2919	(when (instance-slot-p new-slot)
2920	(let* ((slot-name (slot-definition-name new-slot))
2921	(old-slot (find slot-name old-slots :key 'slot-definition-name)))
2922	;; "The values of slots specified as shared in the class CFROM and as
2923	;; local in the class CTO are retained."
2924	(when (and old-slot (slot-boundp old-instance slot-name))
2925	(setf (slot-value new-instance slot-name)
2926	(slot-value old-instance slot-name))))))
2927	(swap-slots old-instance new-instance)
2928	(rotatef (std-instance-layout new-instance)
2929	(std-instance-layout old-instance))
2930	(apply #'update-instance-for-different-class
2931	new-instance old-instance initargs)
2932	old-instance))
2933
2934	(defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs)
2935	(apply #'change-class instance (find-class new-class) initargs))
2936
2937	(defgeneric update-instance-for-different-class (old new &key))
2938
2939	(defmethod update-instance-for-different-class
2940	((old standard-object) (new standard-object) &rest initargs)
2941	(let ((added-slots
2942	(remove-if #'(lambda (slot-name)
2943	(slot-exists-p old slot-name))
2944	(mapcar 'slot-definition-name
2945	(class-slots (class-of new))))))
2946	(check-initargs (list #'update-instance-for-different-class)
2947	(list old new initargs)
2948	new added-slots initargs
2949	nil 'update-instance-for-different-class)
2950	(apply #'shared-initialize new added-slots initargs)))
2951
2952	;;; make-instances-obsolete
2953
2954	(defgeneric make-instances-obsolete (class))
2955
2956	(defmethod make-instances-obsolete ((class standard-class))
2957	(%make-instances-obsolete class))
2958
2959	(defmethod make-instances-obsolete ((class symbol))
2960	(make-instances-obsolete (find-class class))
2961	class)
2962
2963	;;; update-instance-for-redefined-class
2964
2965	(defgeneric update-instance-for-redefined-class (instance
2966	added-slots
2967	discarded-slots
2968	property-list
2969	&rest initargs
2970	&key
2971	&allow-other-keys))
2972
2973	(defmethod update-instance-for-redefined-class ((instance standard-object)
2974	added-slots
2975	discarded-slots
2976	property-list
2977	&rest initargs)
2978	(check-initargs (list #'update-instance-for-redefined-class)
2979	(list* instance added-slots discarded-slots
2980	property-list initargs)
2981	instance added-slots initargs
2982	nil 'update-instance-for-redefined-class)
2983	(apply #'shared-initialize instance added-slots initargs))
2984
2985	;;; Methods having to do with class metaobjects.
2986
2987	(defmethod initialize-instance :after ((class standard-class) &rest args)
2988	(apply #'std-after-initialization-for-classes class args))
2989
2990	(defmethod reinitialize-instance :after ((class standard-class) &rest all-keys)
2991	(remhash class make-instance-initargs-cache)
2992	(remhash class reinitialize-instance-initargs-cache)
2993	(%make-instances-obsolete class)
2994	(setf (class-finalized-p class) nil)
2995	(check-initargs (list #'allocate-instance
2996	#'initialize-instance)
2997	(list* class all-keys)
2998	class t all-keys
2999	nil 'reinitialize-instance)
3000	(apply #'std-after-initialization-for-classes class all-keys))
3001
3002	;;; Finalize inheritance
3003
3004	(atomic-defgeneric finalize-inheritance (class)
3005	(:method ((class standard-class))
3006	(std-finalize-inheritance class)))
3007
3008	;;; Class precedence lists
3009
3010	(defgeneric compute-class-precedence-list (class))
3011	(defmethod compute-class-precedence-list ((class standard-class))
3012	(std-compute-class-precedence-list class))
3013
3014	;;; Slot inheritance
3015
3016	(defgeneric compute-slots (class))
3017	(defmethod compute-slots ((class standard-class))
3018	(std-compute-slots class))
3019
3020	(defgeneric compute-effective-slot-definition (class name direct-slots))
3021	(defmethod compute-effective-slot-definition
3022	((class standard-class) name direct-slots)
3023	(std-compute-effective-slot-definition class name direct-slots))
3024
3025	;;; Methods having to do with generic function metaobjects.
3026
3027	(defmethod initialize-instance :after ((gf standard-generic-function) &key)
3028	(finalize-generic-function gf))
3029
3030	;;; Methods having to do with generic function invocation.
3031
3032	(defgeneric compute-discriminating-function (gf))
3033	(defmethod compute-discriminating-function ((gf standard-generic-function))
3034	(std-compute-discriminating-function gf))
3035
3036	(defgeneric method-more-specific-p (gf method1 method2 required-classes))
3037
3038	(defmethod method-more-specific-p ((gf standard-generic-function)
3039	method1 method2 required-classes)
3040	(std-method-more-specific-p method1 method2 required-classes
3041	(generic-function-argument-precedence-order gf)))
3042
3043	;;; XXX AMOP has COMPUTE-EFFECTIVE-METHOD
3044	(defgeneric compute-effective-method-function (gf methods))
3045	(defmethod compute-effective-method-function ((gf standard-generic-function) methods)
3046	(std-compute-effective-method-function gf methods))
3047
3048	(defgeneric compute-applicable-methods (gf args))
3049	(defmethod compute-applicable-methods ((gf standard-generic-function) args)
3050	(%compute-applicable-methods gf args))
3051
3052	;;; Slot definition accessors
3053
3054	(defmacro slot-definition-dispatch (slot-definition std-form generic-form)
3055	`(let (($cl (class-of ,slot-definition)))
3056	(case $cl
3057	((+the-standard-slot-definition-class+
3058	+the-standard-direct-slot-definition-class+
3059	+the-standard-effective-slot-definition-class+)
3060	,std-form)
3061	(t ,generic-form))))
3062
3063	(atomic-defgeneric slot-definition-allocation (slot-definition)
3064	(:method ((slot-definition slot-definition))
3065	(slot-definition-dispatch slot-definition
3066	(%slot-definition-allocation slot-definition)
3067	(slot-value slot-definition 'sys::allocation))))
3068
3069	(atomic-defgeneric (setf slot-definition-allocation) (value slot-definition)
3070	(:method (value (slot-definition slot-definition))
3071	(slot-definition-dispatch slot-definition
3072	(set-slot-definition-allocation slot-definition value)
3073	(setf (slot-value slot-definition 'sys::allocation) value))))
3074
3075	(atomic-defgeneric slot-definition-initargs (slot-definition)
3076	(:method ((slot-definition slot-definition))
3077	(slot-definition-dispatch slot-definition
3078	(%slot-definition-initargs slot-definition)
3079	(slot-value slot-definition 'sys::initargs))))
3080
3081	(atomic-defgeneric slot-definition-initform (slot-definition)
3082	(:method ((slot-definition slot-definition))
3083	(slot-definition-dispatch slot-definition
3084	(%slot-definition-initform slot-definition)
3085	(slot-value slot-definition 'sys::initform))))
3086
3087	(atomic-defgeneric (setf slot-definition-initform) (value slot-definition)
3088	(:method (value (slot-definition slot-definition))
3089	(slot-definition-dispatch slot-definition
3090	(set-slot-definition-initform slot-definition value)
3091	(setf (slot-value slot-definition 'sys::initform) value))))
3092
3093	(atomic-defgeneric slot-definition-initfunction (slot-definition)
3094	(:method ((slot-definition slot-definition))
3095	(slot-definition-dispatch slot-definition
3096	(%slot-definition-initfunction slot-definition)
3097	(slot-value slot-definition 'sys::initfunction))))
3098
3099	(atomic-defgeneric (setf slot-definition-initfunction) (value slot-definition)
3100	(:method (value (slot-definition slot-definition))
3101	(slot-definition-dispatch slot-definition
3102	(set-slot-definition-initfunction slot-definition value)
3103	(setf (slot-value slot-definition 'sys::initfunction) value))))
3104
3105	(atomic-defgeneric slot-definition-name (slot-definition)
3106	(:method ((slot-definition slot-definition))
3107	(slot-definition-dispatch slot-definition
3108	(%slot-definition-name slot-definition)
3109	(slot-value slot-definition 'sys::name))))
3110
3111	(atomic-defgeneric (setf slot-definition-name) (value slot-definition)
3112	(:method (value (slot-definition slot-definition))
3113	(slot-definition-dispatch slot-definition
3114	(set-slot-definition-name slot-definition value)
3115	(setf (slot-value slot-definition 'sys::name) value))))
3116
3117	(atomic-defgeneric slot-definition-readers (slot-definition)
3118	(:method ((slot-definition slot-definition))
3119	(slot-definition-dispatch slot-definition
3120	(%slot-definition-readers slot-definition)
3121	(slot-value slot-definition 'sys::readers))))
3122
3123	(atomic-defgeneric (setf slot-definition-readers) (value slot-definition)
3124	(:method (value (slot-definition slot-definition))
3125	(slot-definition-dispatch slot-definition
3126	(set-slot-definition-readers slot-definition value)
3127	(setf (slot-value slot-definition 'sys::readers) value))))
3128
3129	(atomic-defgeneric slot-definition-writers (slot-definition)
3130	(:method ((slot-definition slot-definition))
3131	(slot-definition-dispatch slot-definition
3132	(%slot-definition-writers slot-definition)
3133	(slot-value slot-definition 'sys::writers))))
3134
3135	(atomic-defgeneric (setf slot-definition-writers) (value slot-definition)
3136	(:method (value (slot-definition slot-definition))
3137	(slot-definition-dispatch slot-definition
3138	(set-slot-definition-writers slot-definition value)
3139	(setf (slot-value slot-definition 'sys::writers) value))))
3140
3141	(atomic-defgeneric slot-definition-allocation-class (slot-definition)
3142	(:method ((slot-definition slot-definition))
3143	(slot-definition-dispatch slot-definition
3144	(%slot-definition-allocation-class slot-definition)
3145	(slot-value slot-definition 'sys::allocation-class))))
3146
3147	(atomic-defgeneric (setf slot-definition-allocation-class)
3148	(value slot-definition)
3149	(:method (value (slot-definition slot-definition))
3150	(slot-definition-dispatch slot-definition
3151	(set-slot-definition-allocation-class slot-definition value)
3152	(setf (slot-value slot-definition 'sys::allocation-class) value))))
3153
3154	(atomic-defgeneric slot-definition-location (slot-definition)
3155	(:method ((slot-definition slot-definition))
3156	(slot-definition-dispatch slot-definition
3157	(%slot-definition-location slot-definition)
3158	(slot-value slot-definition 'sys::location))))
3159
3160	(atomic-defgeneric (setf slot-definition-location) (value slot-definition)
3161	(:method (value (slot-definition slot-definition))
3162	(slot-definition-dispatch slot-definition
3163	(set-slot-definition-location slot-definition value)
3164	(setf (slot-value slot-definition 'sys::location) value))))
3165
3166	;;; No %slot-definition-type.
3167
3168
3169	;;; Conditions.
3170
3171	(defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options)
3172	(let ((parent-types (or parent-types '(condition)))
3173	(report nil))
3174	(dolist (option options)
3175	(when (eq (car option) :report)
3176	(setf report (cadr option))
3177	(setf options (delete option options :test #'equal))
3178	(return)))
3179	(typecase report
3180	(null
3181	`(progn
3182	(defclass ,name ,parent-types ,slot-specs ,@options)
3183	',name))
3184	(string
3185	`(progn
3186	(defclass ,name ,parent-types ,slot-specs ,@options)
3187	(defmethod print-object ((condition ,name) stream)
3188	(if print-escape
3189	(call-next-method)
3190	(progn (write-string ,report stream) condition)))
3191	',name))
3192	(t
3193	`(progn
3194	(defclass ,name ,parent-types ,slot-specs ,@options)
3195	(defmethod print-object ((condition ,name) stream)
3196	(if print-escape
3197	(call-next-method)
3198	(funcall #',report condition stream)))
3199	',name)))))
3200
3201	(defun make-condition (type &rest initargs)
3202	(or (%make-condition type initargs)
3203	(let ((class (if (symbolp type) (find-class type) type)))
3204	(apply #'make-instance class initargs))))
3205
3206	;; Adapted from SBCL.
3207	;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION.
3208	(defun coerce-to-condition (datum arguments default-type fun-name)
3209	(cond ((typep datum 'condition)
3210	(when arguments
3211	(error 'simple-type-error
3212	:datum arguments
3213	:expected-type 'null
3214	:format-control "You may not supply additional arguments when giving ~S to ~S."
3215	:format-arguments (list datum fun-name)))
3216	datum)
3217	((symbolp datum)
3218	(apply #'make-condition datum arguments))
3219	((or (stringp datum) (functionp datum))
3220	(make-condition default-type
3221	:format-control datum
3222	:format-arguments arguments))
3223	(t
3224	(error 'simple-type-error
3225	:datum datum
3226	:expected-type '(or symbol string)
3227	:format-control "Bad argument to ~S: ~S."
3228	:format-arguments (list fun-name datum)))))
3229
3230	(defgeneric make-load-form (object &optional environment))
3231
3232	(defmethod make-load-form ((object t) &optional environment)
3233	(declare (ignore environment))
3234	(apply #'no-applicable-method #'make-load-form (list object)))
3235
3236	(defmethod make-load-form ((class class) &optional environment)
3237	(declare (ignore environment))
3238	(let ((name (class-name class)))
3239	(unless (and name (eq (find-class name nil) class))
3240	(error 'simple-type-error
3241	:format-control "Can't use anonymous or undefined class as a constant: ~S."
3242	:format-arguments (list class)))
3243	`(find-class ',name)))
3244
3245	(defun invalid-method-error (method format-control &rest args)
3246	(let ((message (apply #'format nil format-control args)))
3247	(error "Invalid method error for ~S:~% ~A" method message)))
3248
3249	(defun method-combination-error (format-control &rest args)
3250	(let ((message (apply #'format nil format-control args)))
3251	(error "Method combination error in CLOS dispatch:~% ~A" message)))
3252
3253
3254	(atomic-defgeneric no-applicable-method (generic-function &rest args)
3255	(:method (generic-function &rest args)
3256	(error "There is no applicable method for the generic function ~S ~
3257	when called with arguments ~S."
3258	generic-function
3259	args)))
3260
3261
3262
3263	(defgeneric find-method (generic-function
3264	qualifiers
3265	specializers
3266	&optional errorp))
3267
3268	(defmethod find-method ((generic-function standard-generic-function)
3269	qualifiers specializers &optional (errorp t))
3270	(%find-method generic-function qualifiers specializers errorp))
3271
3272	(defgeneric add-method (generic-function method))
3273
3274	(defmethod add-method ((generic-function standard-generic-function)
3275	(method method))
3276	(let ((method-lambda-list (method-lambda-list method))
3277	(gf-lambda-list (generic-function-lambda-list generic-function)))
3278	(check-method-lambda-list (%generic-function-name generic-function)
3279	method-lambda-list gf-lambda-list))
3280	(%add-method generic-function method))
3281
3282	(defgeneric remove-method (generic-function method))
3283
3284	(defmethod remove-method ((generic-function standard-generic-function) method)
3285	(%remove-method generic-function method))
3286
3287	;; See describe.lisp.
3288	(defgeneric describe-object (object stream))
3289
3290	;; FIXME
3291	(defgeneric no-next-method (generic-function method &rest args))
3292
3293	;; FIXME
3294	(defgeneric function-keywords (method))
3295
3296
3297	(setf gf-initialize-instance (symbol-function 'initialize-instance))
3298	(setf gf-allocate-instance (symbol-function 'allocate-instance))
3299	(setf gf-shared-initialize (symbol-function 'shared-initialize))
3300	(setf gf-reinitialize-instance (symbol-function 'reinitialize-instance))
3301	(setf clos-booting nil)
3302
3303	(defgeneric class-prototype (class))
3304
3305	(defmethod class-prototype :before (class)
3306	(unless (class-finalized-p class)
3307	(error "~@<~S is not finalized.~:@>" class)))
3308
3309	(defmethod class-prototype ((class standard-class))
3310	(allocate-instance class))
3311
3312	(defmethod class-prototype ((class structure-class))
3313	(allocate-instance class))
3314
3315	(eval-when (:compile-toplevel :load-toplevel :execute)
3316	(require "MOP"))
3317
3318	(provide 'clos)
3319

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

Context Navigation

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

Download in other formats: