Context Navigation

clos.lisp @ 13782

Visit:

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

Implement readers for generic-function objects as generic functions (AMOP pg. 216)

... rename predefined low-level accessors (e.g. generic-function-name ->

sys:%generic-function-name)

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

File size: 146.5 KB

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

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

Context Navigation

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

Download in other formats: