1 | ;;; clos.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003-2007 Peter Graves |
---|
4 | ;;; Copyright (C) 2010-2013 Mark Evenson |
---|
5 | ;;; $Id: clos.lisp 14529 2013-06-09 17:09:28Z 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 | (export '(%defgeneric canonicalize-direct-superclasses)) |
---|
56 | |
---|
57 | |
---|
58 | ;; |
---|
59 | ;; |
---|
60 | ;; |
---|
61 | ;; In order to bootstrap CLOS, first implement the required API as |
---|
62 | ;; normal functions which only apply to the "root" metaclass |
---|
63 | ;; STANDARD-CLASS. |
---|
64 | ;; |
---|
65 | ;; After putting the normal functions in place, the building blocks |
---|
66 | ;; are in place to gradually swap the normal functions with |
---|
67 | ;; generic functions and methods. |
---|
68 | ;; |
---|
69 | ;; Some functionality implemented in the temporary regular functions |
---|
70 | ;; needs to be available later as a method definition to be dispatched |
---|
71 | ;; to for the standard case, e.g. with arguments of type STANDARD-CLASS |
---|
72 | ;; or STANDARD-GENERIC-FUNCTION. To prevent repeated code, the |
---|
73 | ;; functions are implemented in functions by the same name as the API |
---|
74 | ;; functions, but with the STD- prefix. These functions are sometimes |
---|
75 | ;; used in regular code as well, either in a "fast path" or to break a |
---|
76 | ;; circularity (e.g., within compute-discriminating-function when the |
---|
77 | ;; user adds a method to compute-discriminating-function). |
---|
78 | ;; |
---|
79 | ;; When hacking this file, note that some important parts are implemented |
---|
80 | ;; in the Java world. These Java bits can be found in the files |
---|
81 | ;; |
---|
82 | ;; * LispClass.java |
---|
83 | ;; * SlotClass.java |
---|
84 | ;; * StandardClass.java |
---|
85 | ;; * BuiltInClass.java |
---|
86 | ;; * StandardObject.java |
---|
87 | ;; * StandardObjectFunctions.java |
---|
88 | ;; * FuncallableStandardObject.java |
---|
89 | ;; * Layout.java |
---|
90 | ;; |
---|
91 | ;; In case of function names, those defined on the Java side can be |
---|
92 | ;; recognized by their prefixed percent (%) sign. |
---|
93 | ;; |
---|
94 | ;; The API functions need to be declaimed NOTINLINE explicitly, because |
---|
95 | ;; that prevents inlining in the current FASL (which is allowed by the |
---|
96 | ;; CLHS without the declaration); this is a hard requirement to in order |
---|
97 | ;; to be able to swap the symbol's function slot with a generic function |
---|
98 | ;; later on - with it actually being used. |
---|
99 | ;; |
---|
100 | ;; |
---|
101 | ;; |
---|
102 | ;; ### Note that the "declares all API functions as regular functions" |
---|
103 | ;; isn't true when I write the above, but it's definitely the target. |
---|
104 | ;; |
---|
105 | ;; A note about AMOP: the first chapters (and the sample Closette |
---|
106 | ;; implementation) of the book sometimes deviate from the specification. |
---|
107 | ;; For example, in the examples slot-value-using-class has the slot name |
---|
108 | ;; as third argument where in the specification it is the effective slot |
---|
109 | ;; definition. When in doubt, we aim to follow the specification, the |
---|
110 | ;; MOP test suite at http://common-lisp.net/project/closer/features.html |
---|
111 | ;; and the behavior of other CL implementations in preference to |
---|
112 | ;; chapters 1-4 and appendix D. |
---|
113 | |
---|
114 | (defconstant +the-standard-class+ (find-class 'standard-class)) |
---|
115 | (defconstant +the-funcallable-standard-class+ |
---|
116 | (find-class 'funcallable-standard-class)) |
---|
117 | (defconstant +the-standard-object-class+ (find-class 'standard-object)) |
---|
118 | (defconstant +the-funcallable-standard-object-class+ |
---|
119 | (find-class 'funcallable-standard-object)) |
---|
120 | (defconstant +the-standard-method-class+ (find-class 'standard-method)) |
---|
121 | (defconstant +the-T-class+ (find-class 'T)) |
---|
122 | (defconstant +the-standard-slot-definition-class+ (find-class 'standard-slot-definition)) |
---|
123 | (defconstant +the-standard-direct-slot-definition-class+ (find-class 'standard-direct-slot-definition)) |
---|
124 | (defconstant +the-standard-effective-slot-definition-class+ (find-class 'standard-effective-slot-definition)) |
---|
125 | |
---|
126 | ;; Don't use DEFVAR, because that disallows loading clos.lisp |
---|
127 | ;; after compiling it: the binding won't get assigned to T anymore |
---|
128 | (defparameter *clos-booting* t) |
---|
129 | |
---|
130 | (defmacro define-class->%class-forwarder (name) |
---|
131 | (let* (($name (if (consp name) (cadr name) name)) |
---|
132 | (%name (intern (concatenate 'string |
---|
133 | "%" |
---|
134 | (if (consp name) |
---|
135 | (symbol-name 'set-) "") |
---|
136 | (symbol-name $name)) |
---|
137 | (symbol-package $name)))) |
---|
138 | `(progn |
---|
139 | (declaim (notinline ,name)) |
---|
140 | (defun ,name (&rest args) |
---|
141 | (apply #',%name args))))) |
---|
142 | |
---|
143 | ;; |
---|
144 | ;; DEFINE PLACE HOLDER FUNCTIONS |
---|
145 | ;; |
---|
146 | |
---|
147 | (define-class->%class-forwarder class-name) |
---|
148 | (define-class->%class-forwarder (setf class-name)) |
---|
149 | (define-class->%class-forwarder class-slots) |
---|
150 | (define-class->%class-forwarder (setf class-slots)) |
---|
151 | (define-class->%class-forwarder class-direct-slots) |
---|
152 | (define-class->%class-forwarder (setf class-direct-slots)) |
---|
153 | (define-class->%class-forwarder class-layout) |
---|
154 | (define-class->%class-forwarder (setf class-layout)) |
---|
155 | (define-class->%class-forwarder class-direct-superclasses) |
---|
156 | (define-class->%class-forwarder (setf class-direct-superclasses)) |
---|
157 | (define-class->%class-forwarder class-direct-subclasses) |
---|
158 | (define-class->%class-forwarder (setf class-direct-subclasses)) |
---|
159 | (define-class->%class-forwarder class-direct-methods) |
---|
160 | (define-class->%class-forwarder (setf class-direct-methods)) |
---|
161 | (define-class->%class-forwarder class-precedence-list) |
---|
162 | (define-class->%class-forwarder (setf class-precedence-list)) |
---|
163 | (define-class->%class-forwarder class-finalized-p) |
---|
164 | (define-class->%class-forwarder (setf class-finalized-p)) |
---|
165 | (define-class->%class-forwarder class-default-initargs) |
---|
166 | (define-class->%class-forwarder (setf class-default-initargs)) |
---|
167 | (define-class->%class-forwarder class-direct-default-initargs) |
---|
168 | (define-class->%class-forwarder (setf class-direct-default-initargs)) |
---|
169 | |
---|
170 | (declaim (notinline add-direct-subclass remove-direct-subclass)) |
---|
171 | (defun add-direct-subclass (superclass subclass) |
---|
172 | (setf (class-direct-subclasses superclass) |
---|
173 | (adjoin subclass (class-direct-subclasses superclass)))) |
---|
174 | (defun remove-direct-subclass (superclass subclass) |
---|
175 | (setf (class-direct-subclasses superclass) |
---|
176 | (remove subclass (class-direct-subclasses superclass)))) |
---|
177 | |
---|
178 | (defun fixup-standard-class-hierarchy () |
---|
179 | ;; Make the result of class-direct-subclasses for the pre-built |
---|
180 | ;; classes agree with AMOP Table 5.1 (pg. 141). This could be done in |
---|
181 | ;; StandardClass.java where these classes are defined, but it's less |
---|
182 | ;; painful to do it Lisp-side. |
---|
183 | (flet ((add-subclasses (class subclasses) |
---|
184 | (when (atom subclasses) (setf subclasses (list subclasses))) |
---|
185 | (setf (class-direct-subclasses (find-class class)) |
---|
186 | (union (class-direct-subclasses (find-class class)) |
---|
187 | (mapcar #'find-class subclasses))))) |
---|
188 | (add-subclasses t 'standard-object) |
---|
189 | (add-subclasses 'function 'funcallable-standard-object) |
---|
190 | (add-subclasses 'standard-object '(funcallable-standard-object metaobject)) |
---|
191 | (add-subclasses 'metaobject |
---|
192 | '(method slot-definition specializer)) |
---|
193 | (add-subclasses 'specializer '(class)) |
---|
194 | (add-subclasses 'method 'standard-method) |
---|
195 | (add-subclasses 'slot-definition |
---|
196 | '(direct-slot-definition effective-slot-definition |
---|
197 | standard-slot-definition)) |
---|
198 | (add-subclasses 'standard-slot-definition |
---|
199 | '(standard-direct-slot-definition |
---|
200 | standard-effective-slot-definition)) |
---|
201 | (add-subclasses 'direct-slot-definition 'standard-direct-slot-definition) |
---|
202 | (add-subclasses 'effective-slot-definition |
---|
203 | 'standard-effective-slot-definition) |
---|
204 | (add-subclasses 'class |
---|
205 | '(built-in-class standard-class funcallable-standard-class)))) |
---|
206 | (fixup-standard-class-hierarchy) |
---|
207 | |
---|
208 | (defun std-class-p (class) |
---|
209 | (let ((metaclass (class-of class))) |
---|
210 | (or (eq metaclass +the-standard-class+) |
---|
211 | (eq metaclass +the-funcallable-standard-class+)))) |
---|
212 | |
---|
213 | (defun no-applicable-method (generic-function &rest args) |
---|
214 | (error "There is no applicable method for the generic function ~S when called with arguments ~S." |
---|
215 | generic-function |
---|
216 | args)) |
---|
217 | |
---|
218 | (defun function-keywords (method) |
---|
219 | (std-function-keywords method)) |
---|
220 | |
---|
221 | (declaim (notinline map-dependents)) |
---|
222 | (defun map-dependents (metaobject function) |
---|
223 | ;; stub, will be redefined later |
---|
224 | (declare (ignore metaobject function)) |
---|
225 | nil) |
---|
226 | |
---|
227 | (defmacro push-on-end (value location) |
---|
228 | `(setf ,location (nconc ,location (list ,value)))) |
---|
229 | |
---|
230 | ;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list, |
---|
231 | ;;; which must be non-nil. |
---|
232 | |
---|
233 | (defun (setf getf*) (new-value plist key) |
---|
234 | (block body |
---|
235 | (do ((x plist (cddr x))) |
---|
236 | ((null x)) |
---|
237 | (when (eq (car x) key) |
---|
238 | (setf (car (cdr x)) new-value) |
---|
239 | (return-from body new-value))) |
---|
240 | (push-on-end key plist) |
---|
241 | (push-on-end new-value plist) |
---|
242 | new-value)) |
---|
243 | |
---|
244 | (defun mapappend (fun &rest args) |
---|
245 | (if (some #'null args) |
---|
246 | () |
---|
247 | (append (apply fun (mapcar #'car args)) |
---|
248 | (apply #'mapappend fun (mapcar #'cdr args))))) |
---|
249 | |
---|
250 | (defun mapplist (fun x) |
---|
251 | (if (null x) |
---|
252 | () |
---|
253 | (cons (funcall fun (car x) (cadr x)) |
---|
254 | (mapplist fun (cddr x))))) |
---|
255 | |
---|
256 | (defsetf std-slot-value set-std-slot-value) |
---|
257 | |
---|
258 | (defsetf std-instance-layout %set-std-instance-layout) |
---|
259 | (defsetf standard-instance-access %set-standard-instance-access) |
---|
260 | (defun funcallable-standard-instance-access (instance location) |
---|
261 | (standard-instance-access instance location)) |
---|
262 | (defsetf funcallable-standard-instance-access %set-standard-instance-access) |
---|
263 | |
---|
264 | (defun (setf find-class) (new-value symbol &optional errorp environment) |
---|
265 | (declare (ignore errorp environment)) |
---|
266 | (%set-find-class symbol new-value)) |
---|
267 | |
---|
268 | (defun canonicalize-direct-slots (direct-slots) |
---|
269 | `(list ,@(mapcar #'canonicalize-direct-slot direct-slots))) |
---|
270 | |
---|
271 | (defun canonicalize-direct-slot (spec) |
---|
272 | (if (symbolp spec) |
---|
273 | `(list :name ',spec) |
---|
274 | (let ((name (car spec)) |
---|
275 | (initfunction nil) |
---|
276 | (initform nil) |
---|
277 | (initargs ()) |
---|
278 | (type nil) |
---|
279 | (allocation nil) |
---|
280 | (documentation nil) |
---|
281 | (readers ()) |
---|
282 | (writers ()) |
---|
283 | (other-options ()) |
---|
284 | (non-std-options ())) |
---|
285 | (do ((olist (cdr spec) (cddr olist))) |
---|
286 | ((null olist)) |
---|
287 | (case (car olist) |
---|
288 | (:initform |
---|
289 | (when initform |
---|
290 | (error 'program-error |
---|
291 | "duplicate slot option :INITFORM for slot named ~S" |
---|
292 | name)) |
---|
293 | (setq initfunction t) |
---|
294 | (setq initform (cadr olist))) |
---|
295 | (:initarg |
---|
296 | (push-on-end (cadr olist) initargs)) |
---|
297 | (:allocation |
---|
298 | (when allocation |
---|
299 | (error 'program-error |
---|
300 | "duplicate slot option :ALLOCATION for slot named ~S" |
---|
301 | name)) |
---|
302 | (setf allocation (cadr olist)) |
---|
303 | (push-on-end (car olist) other-options) |
---|
304 | (push-on-end (cadr olist) other-options)) |
---|
305 | (:type |
---|
306 | (when type |
---|
307 | (error 'program-error |
---|
308 | "duplicate slot option :TYPE for slot named ~S" |
---|
309 | name)) |
---|
310 | (setf type (cadr olist))) |
---|
311 | (:documentation |
---|
312 | (when documentation |
---|
313 | (error 'program-error |
---|
314 | "duplicate slot option :DOCUMENTATION for slot named ~S" |
---|
315 | name)) |
---|
316 | (setf documentation (cadr olist))) |
---|
317 | (:reader |
---|
318 | (maybe-note-name-defined (cadr olist)) |
---|
319 | (push-on-end (cadr olist) readers)) |
---|
320 | (:writer |
---|
321 | (maybe-note-name-defined (cadr olist)) |
---|
322 | (push-on-end (cadr olist) writers)) |
---|
323 | (:accessor |
---|
324 | (maybe-note-name-defined (cadr olist)) |
---|
325 | (push-on-end (cadr olist) readers) |
---|
326 | (push-on-end `(setf ,(cadr olist)) writers)) |
---|
327 | (t |
---|
328 | (push-on-end (cadr olist) (getf non-std-options (car olist)))))) |
---|
329 | `(list |
---|
330 | :name ',name |
---|
331 | ,@(when initfunction |
---|
332 | `(:initform ',initform |
---|
333 | :initfunction ,(if (eq allocation :class) |
---|
334 | ;; CLHS specifies the initform for a |
---|
335 | ;; class allocation level slot needs |
---|
336 | ;; to be evaluated in the dynamic |
---|
337 | ;; extent of the DEFCLASS form |
---|
338 | (let ((var (gensym))) |
---|
339 | `(let ((,var ,initform)) |
---|
340 | (lambda () ,var))) |
---|
341 | `(lambda () ,initform)))) |
---|
342 | ,@(when initargs `(:initargs ',initargs)) |
---|
343 | ,@(when readers `(:readers ',readers)) |
---|
344 | ,@(when writers `(:writers ',writers)) |
---|
345 | ,@(when type `(:type ',type)) |
---|
346 | ,@(when documentation `(:documentation ',documentation)) |
---|
347 | ,@other-options |
---|
348 | ,@(mapcar #'(lambda (opt) (if (or (atom opt) (/= 1 (length opt))) |
---|
349 | `',opt |
---|
350 | `',(car opt))) |
---|
351 | non-std-options))))) |
---|
352 | |
---|
353 | (defun maybe-note-name-defined (name) |
---|
354 | (when (fboundp 'note-name-defined) |
---|
355 | (note-name-defined name))) |
---|
356 | |
---|
357 | (defun canonicalize-defclass-options (options) |
---|
358 | (mapappend #'canonicalize-defclass-option options)) |
---|
359 | |
---|
360 | (defun canonicalize-defclass-option (option) |
---|
361 | (case (car option) |
---|
362 | (:metaclass |
---|
363 | (list ':metaclass |
---|
364 | `(find-class ',(cadr option)))) |
---|
365 | (:default-initargs |
---|
366 | (list |
---|
367 | ':direct-default-initargs |
---|
368 | `(list ,@(mapplist |
---|
369 | #'(lambda (key value) |
---|
370 | `(list ',key ',value ,(make-initfunction value))) |
---|
371 | (cdr option))))) |
---|
372 | ((:documentation :report) |
---|
373 | (list (car option) `',(cadr option))) |
---|
374 | (t (list `(quote ,(car option)) `(quote ,(cdr option)))))) |
---|
375 | |
---|
376 | (defun make-initfunction (initform) |
---|
377 | `(function (lambda () ,initform))) |
---|
378 | |
---|
379 | (defun slot-definition-allocation (slot-definition) |
---|
380 | (std-slot-value slot-definition 'sys::allocation)) |
---|
381 | |
---|
382 | (declaim (notinline (setf slot-definition-allocation))) |
---|
383 | (defun (setf slot-definition-allocation) (value slot-definition) |
---|
384 | (setf (std-slot-value slot-definition 'sys::allocation) value)) |
---|
385 | |
---|
386 | (defun slot-definition-initargs (slot-definition) |
---|
387 | (std-slot-value slot-definition 'sys::initargs)) |
---|
388 | |
---|
389 | (declaim (notinline (setf slot-definition-initargs))) |
---|
390 | (defun (setf slot-definition-initargs) (value slot-definition) |
---|
391 | (setf (std-slot-value slot-definition 'sys::initargs) value)) |
---|
392 | |
---|
393 | (defun slot-definition-initform (slot-definition) |
---|
394 | (std-slot-value slot-definition 'sys::initform)) |
---|
395 | |
---|
396 | (declaim (notinline (setf slot-definition-initform))) |
---|
397 | (defun (setf slot-definition-initform) (value slot-definition) |
---|
398 | (setf (std-slot-value slot-definition 'sys::initform) value)) |
---|
399 | |
---|
400 | (defun slot-definition-initfunction (slot-definition) |
---|
401 | (std-slot-value slot-definition 'sys::initfunction)) |
---|
402 | |
---|
403 | (declaim (notinline (setf slot-definition-initfunction))) |
---|
404 | (defun (setf slot-definition-initfunction) (value slot-definition) |
---|
405 | (setf (std-slot-value slot-definition 'sys::initfunction) value)) |
---|
406 | |
---|
407 | (defun slot-definition-name (slot-definition) |
---|
408 | (std-slot-value slot-definition 'sys:name)) |
---|
409 | |
---|
410 | (declaim (notinline (setf slot-definition-name))) |
---|
411 | (defun (setf slot-definition-name) (value slot-definition) |
---|
412 | (setf (std-slot-value slot-definition 'sys:name) value)) |
---|
413 | |
---|
414 | (defun slot-definition-readers (slot-definition) |
---|
415 | (std-slot-value slot-definition 'sys::readers)) |
---|
416 | |
---|
417 | (declaim (notinline (setf slot-definition-readers))) |
---|
418 | (defun (setf slot-definition-readers) (value slot-definition) |
---|
419 | (setf (std-slot-value slot-definition 'sys::readers) value)) |
---|
420 | |
---|
421 | (defun slot-definition-writers (slot-definition) |
---|
422 | (std-slot-value slot-definition 'sys::writers)) |
---|
423 | |
---|
424 | (declaim (notinline (setf slot-definition-writers))) |
---|
425 | (defun (setf slot-definition-writers) (value slot-definition) |
---|
426 | (setf (std-slot-value slot-definition 'sys::writers) value)) |
---|
427 | |
---|
428 | (defun slot-definition-allocation-class (slot-definition) |
---|
429 | (std-slot-value slot-definition 'sys::allocation-class)) |
---|
430 | |
---|
431 | (declaim (notinline (setf slot-definition-allocation-class))) |
---|
432 | (defun (setf slot-definition-allocation-class) (value slot-definition) |
---|
433 | (setf (std-slot-value slot-definition 'sys::allocation-class) value)) |
---|
434 | |
---|
435 | (defun slot-definition-location (slot-definition) |
---|
436 | (std-slot-value slot-definition 'sys::location)) |
---|
437 | |
---|
438 | (declaim (notinline (setf slot-definition-location-class))) |
---|
439 | (defun (setf slot-definition-location) (value slot-definition) |
---|
440 | (setf (std-slot-value slot-definition 'sys::location) value)) |
---|
441 | |
---|
442 | (defun slot-definition-type (slot-definition) |
---|
443 | (std-slot-value slot-definition 'sys::%type)) |
---|
444 | |
---|
445 | (declaim (notinline (setf slot-definition-type))) |
---|
446 | (defun (setf slot-definition-type) (value slot-definition) |
---|
447 | (setf (std-slot-value slot-definition 'sys::%type) value)) |
---|
448 | |
---|
449 | (defun slot-definition-documentation (slot-definition) |
---|
450 | (std-slot-value slot-definition 'sys:%documentation)) |
---|
451 | |
---|
452 | (declaim (notinline (setf slot-definition-documentation))) |
---|
453 | (defun (setf slot-definition-documentation) (value slot-definition) |
---|
454 | (setf (std-slot-value slot-definition 'sys:%documentation) value)) |
---|
455 | |
---|
456 | (defun init-slot-definition (slot &key name |
---|
457 | (initargs ()) |
---|
458 | (initform nil) |
---|
459 | (initfunction nil) |
---|
460 | (readers ()) |
---|
461 | (writers ()) |
---|
462 | (allocation :instance) |
---|
463 | (allocation-class nil) |
---|
464 | (type t) |
---|
465 | (documentation nil)) |
---|
466 | (setf (slot-definition-name slot) name) |
---|
467 | (setf (slot-definition-initargs slot) initargs) |
---|
468 | (setf (slot-definition-initform slot) initform) |
---|
469 | (setf (slot-definition-initfunction slot) initfunction) |
---|
470 | (setf (slot-definition-readers slot) readers) |
---|
471 | (setf (slot-definition-writers slot) writers) |
---|
472 | (setf (slot-definition-allocation slot) allocation) |
---|
473 | (setf (slot-definition-allocation-class slot) allocation-class) |
---|
474 | (setf (slot-definition-type slot) type) |
---|
475 | (setf (slot-definition-documentation slot) documentation) |
---|
476 | slot) |
---|
477 | |
---|
478 | (declaim (notinline direct-slot-definition-class)) |
---|
479 | (defun direct-slot-definition-class (class &rest args) |
---|
480 | (declare (ignore class args)) |
---|
481 | +the-standard-direct-slot-definition-class+) |
---|
482 | |
---|
483 | (defun make-direct-slot-definition (class &rest args) |
---|
484 | (let ((slot-class (apply #'direct-slot-definition-class class args))) |
---|
485 | (if (eq slot-class +the-standard-direct-slot-definition-class+) |
---|
486 | (let ((slot (%make-slot-definition +the-standard-direct-slot-definition-class+))) |
---|
487 | (apply #'init-slot-definition slot :allocation-class class args) |
---|
488 | slot) |
---|
489 | (progn |
---|
490 | (let ((slot (apply #'make-instance slot-class :allocation-class class |
---|
491 | args))) |
---|
492 | slot))))) |
---|
493 | |
---|
494 | (declaim (notinline effective-slot-definition-class)) |
---|
495 | (defun effective-slot-definition-class (class &rest args) |
---|
496 | (declare (ignore class args)) |
---|
497 | +the-standard-effective-slot-definition-class+) |
---|
498 | |
---|
499 | (defun make-effective-slot-definition (class &rest args) |
---|
500 | (let ((slot-class (apply #'effective-slot-definition-class class args))) |
---|
501 | (if (eq slot-class +the-standard-effective-slot-definition-class+) |
---|
502 | (let ((slot (%make-slot-definition +the-standard-effective-slot-definition-class+))) |
---|
503 | (apply #'init-slot-definition slot args) |
---|
504 | slot) |
---|
505 | (progn |
---|
506 | (let ((slot (apply #'make-instance slot-class args))) |
---|
507 | slot))))) |
---|
508 | |
---|
509 | ;;; finalize-inheritance |
---|
510 | |
---|
511 | (declaim (notinline compute-default-initargs)) |
---|
512 | (defun compute-default-initargs (class) |
---|
513 | (std-compute-default-initargs class)) |
---|
514 | |
---|
515 | (defun std-compute-default-initargs (class) |
---|
516 | (delete-duplicates |
---|
517 | (mapcan #'(lambda (c) |
---|
518 | (copy-list |
---|
519 | (class-direct-default-initargs c))) |
---|
520 | (class-precedence-list class)) |
---|
521 | :key #'car :from-end t)) |
---|
522 | |
---|
523 | (defun std-finalize-inheritance (class) |
---|
524 | ;; In case the class is already finalized, return |
---|
525 | ;; immediately, as per AMOP. |
---|
526 | (when (class-finalized-p class) |
---|
527 | (return-from std-finalize-inheritance)) |
---|
528 | (setf (class-precedence-list class) |
---|
529 | (funcall (if (std-class-p class) |
---|
530 | #'std-compute-class-precedence-list |
---|
531 | #'compute-class-precedence-list) |
---|
532 | class)) |
---|
533 | (setf (class-slots class) |
---|
534 | (funcall (if (std-class-p class) |
---|
535 | #'std-compute-slots |
---|
536 | #'compute-slots) class)) |
---|
537 | (let ((old-layout (class-layout class)) |
---|
538 | (length 0) |
---|
539 | (instance-slots '()) |
---|
540 | (shared-slots '())) |
---|
541 | (dolist (slot (class-slots class)) |
---|
542 | (case (slot-definition-allocation slot) |
---|
543 | (:instance |
---|
544 | (setf (slot-definition-location slot) length) |
---|
545 | (incf length) |
---|
546 | (push (slot-definition-name slot) instance-slots)) |
---|
547 | (:class |
---|
548 | (unless (slot-definition-location slot) |
---|
549 | (let ((allocation-class (slot-definition-allocation-class slot))) |
---|
550 | (if (eq allocation-class class) |
---|
551 | ;; We initialize class slots here so they can be |
---|
552 | ;; accessed without creating a dummy instance. |
---|
553 | (let ((initfunction (slot-definition-initfunction slot))) |
---|
554 | (setf (slot-definition-location slot) |
---|
555 | (cons (slot-definition-name slot) |
---|
556 | (if initfunction |
---|
557 | (funcall initfunction) |
---|
558 | +slot-unbound+)))) |
---|
559 | (setf (slot-definition-location slot) |
---|
560 | (slot-location allocation-class (slot-definition-name slot)))))) |
---|
561 | (push (slot-definition-location slot) shared-slots)))) |
---|
562 | (when old-layout |
---|
563 | ;; Redefined class: initialize added shared slots. |
---|
564 | (dolist (location shared-slots) |
---|
565 | (let* ((slot-name (car location)) |
---|
566 | (old-location (layout-slot-location old-layout slot-name))) |
---|
567 | (unless old-location |
---|
568 | (let* ((slot-definition (find slot-name (class-slots class) :key 'slot-definition-name)) |
---|
569 | (initfunction (slot-definition-initfunction slot-definition))) |
---|
570 | (when initfunction |
---|
571 | (setf (cdr location) (funcall initfunction)))))))) |
---|
572 | (setf (class-layout class) |
---|
573 | (make-layout class (nreverse instance-slots) (nreverse shared-slots)))) |
---|
574 | (setf (class-default-initargs class) |
---|
575 | (compute-default-initargs class)) |
---|
576 | (setf (class-finalized-p class) t)) |
---|
577 | |
---|
578 | (declaim (notinline finalize-inheritance)) |
---|
579 | (defun finalize-inheritance (class) |
---|
580 | (std-finalize-inheritance class)) |
---|
581 | |
---|
582 | |
---|
583 | ;;; Class precedence lists |
---|
584 | |
---|
585 | (defun std-compute-class-precedence-list (class) |
---|
586 | (let ((classes-to-order (collect-superclasses* class))) |
---|
587 | (dolist (super classes-to-order) |
---|
588 | (when (typep super 'forward-referenced-class) |
---|
589 | (error "Can't compute class precedence list for class ~A ~ |
---|
590 | which depends on forward referenced class ~A." class super))) |
---|
591 | (topological-sort classes-to-order |
---|
592 | (remove-duplicates |
---|
593 | (mapappend #'local-precedence-ordering |
---|
594 | classes-to-order)) |
---|
595 | #'std-tie-breaker-rule))) |
---|
596 | |
---|
597 | ;;; topological-sort implements the standard algorithm for topologically |
---|
598 | ;;; sorting an arbitrary set of elements while honoring the precedence |
---|
599 | ;;; constraints given by a set of (X,Y) pairs that indicate that element |
---|
600 | ;;; X must precede element Y. The tie-breaker procedure is called when it |
---|
601 | ;;; is necessary to choose from multiple minimal elements; both a list of |
---|
602 | ;;; candidates and the ordering so far are provided as arguments. |
---|
603 | |
---|
604 | (defun topological-sort (elements constraints tie-breaker) |
---|
605 | (let ((remaining-constraints constraints) |
---|
606 | (remaining-elements elements) |
---|
607 | (result ())) |
---|
608 | (loop |
---|
609 | (let ((minimal-elements |
---|
610 | (remove-if |
---|
611 | #'(lambda (class) |
---|
612 | (member class remaining-constraints |
---|
613 | :key #'cadr)) |
---|
614 | remaining-elements))) |
---|
615 | (when (null minimal-elements) |
---|
616 | (if (null remaining-elements) |
---|
617 | (return-from topological-sort result) |
---|
618 | (error "Inconsistent precedence graph."))) |
---|
619 | (let ((choice (if (null (cdr minimal-elements)) |
---|
620 | (car minimal-elements) |
---|
621 | (funcall tie-breaker |
---|
622 | minimal-elements |
---|
623 | result)))) |
---|
624 | (setq result (append result (list choice))) |
---|
625 | (setq remaining-elements |
---|
626 | (remove choice remaining-elements)) |
---|
627 | (setq remaining-constraints |
---|
628 | (remove choice |
---|
629 | remaining-constraints |
---|
630 | :test #'member))))))) |
---|
631 | |
---|
632 | ;;; In the event of a tie while topologically sorting class precedence lists, |
---|
633 | ;;; the CLOS Specification says to "select the one that has a direct subclass |
---|
634 | ;;; rightmost in the class precedence list computed so far." The same result |
---|
635 | ;;; is obtained by inspecting the partially constructed class precedence list |
---|
636 | ;;; from right to left, looking for the first minimal element to show up among |
---|
637 | ;;; the direct superclasses of the class precedence list constituent. |
---|
638 | ;;; (There's a lemma that shows that this rule yields a unique result.) |
---|
639 | |
---|
640 | (defun std-tie-breaker-rule (minimal-elements cpl-so-far) |
---|
641 | (dolist (cpl-constituent (reverse cpl-so-far)) |
---|
642 | (let* ((supers (class-direct-superclasses cpl-constituent)) |
---|
643 | (common (intersection minimal-elements supers))) |
---|
644 | (when (not (null common)) |
---|
645 | (return-from std-tie-breaker-rule (car common)))))) |
---|
646 | |
---|
647 | ;;; This version of collect-superclasses* isn't bothered by cycles in the class |
---|
648 | ;;; hierarchy, which sometimes happen by accident. |
---|
649 | |
---|
650 | (defun collect-superclasses* (class) |
---|
651 | (labels ((all-superclasses-loop (seen superclasses) |
---|
652 | (let ((to-be-processed |
---|
653 | (set-difference superclasses seen))) |
---|
654 | (if (null to-be-processed) |
---|
655 | superclasses |
---|
656 | (let ((class-to-process |
---|
657 | (car to-be-processed))) |
---|
658 | (all-superclasses-loop |
---|
659 | (cons class-to-process seen) |
---|
660 | (union (class-direct-superclasses |
---|
661 | class-to-process) |
---|
662 | superclasses))))))) |
---|
663 | (all-superclasses-loop () (list class)))) |
---|
664 | |
---|
665 | ;;; The local precedence ordering of a class C with direct superclasses C_1, |
---|
666 | ;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)). |
---|
667 | |
---|
668 | (defun local-precedence-ordering (class) |
---|
669 | (mapcar #'list |
---|
670 | (cons class |
---|
671 | (butlast (class-direct-superclasses class))) |
---|
672 | (class-direct-superclasses class))) |
---|
673 | |
---|
674 | ;;; Slot inheritance |
---|
675 | |
---|
676 | (defun std-compute-slots (class) |
---|
677 | (let* ((all-slots (mapappend #'(lambda (c) (class-direct-slots c)) |
---|
678 | ;; Slots of base class must come first |
---|
679 | (reverse (class-precedence-list class)))) |
---|
680 | (all-names (delete-duplicates |
---|
681 | (mapcar 'slot-definition-name all-slots) |
---|
682 | :from-end t))) |
---|
683 | (mapcar #'(lambda (name) |
---|
684 | (funcall |
---|
685 | (if (std-class-p class) |
---|
686 | #'std-compute-effective-slot-definition |
---|
687 | #'compute-effective-slot-definition) |
---|
688 | class |
---|
689 | name |
---|
690 | ;; Slot of inherited class must override initfunction, |
---|
691 | ;; documentation of base class |
---|
692 | (nreverse |
---|
693 | (remove name all-slots |
---|
694 | :key 'slot-definition-name |
---|
695 | :test-not #'eq)))) |
---|
696 | all-names))) |
---|
697 | |
---|
698 | (defun std-compute-effective-slot-definition (class name direct-slots) |
---|
699 | (let ((initer (find-if-not #'null direct-slots |
---|
700 | :key 'slot-definition-initfunction)) |
---|
701 | (documentation-slot (find-if-not #'null direct-slots |
---|
702 | :key 'slot-definition-documentation)) |
---|
703 | (types (delete-duplicates |
---|
704 | (delete t (mapcar #'slot-definition-type direct-slots)) |
---|
705 | :test #'equal))) |
---|
706 | (make-effective-slot-definition |
---|
707 | class |
---|
708 | :name name |
---|
709 | :initform (if initer |
---|
710 | (slot-definition-initform initer) |
---|
711 | nil) |
---|
712 | :initfunction (if initer |
---|
713 | (slot-definition-initfunction initer) |
---|
714 | nil) |
---|
715 | :initargs (remove-duplicates |
---|
716 | (mapappend 'slot-definition-initargs |
---|
717 | direct-slots)) |
---|
718 | :allocation (slot-definition-allocation (car direct-slots)) |
---|
719 | :allocation-class (when (slot-boundp (car direct-slots) |
---|
720 | 'sys::allocation-class) |
---|
721 | ;;for some classes created in Java |
---|
722 | ;;(e.g. SimpleCondition) this slot is unbound |
---|
723 | (slot-definition-allocation-class (car direct-slots))) |
---|
724 | :type (cond ((null types) t) |
---|
725 | ((= 1 (length types)) types) |
---|
726 | (t (list* 'and types))) |
---|
727 | :documentation (if documentation-slot |
---|
728 | (documentation documentation-slot t) |
---|
729 | nil)))) |
---|
730 | |
---|
731 | ;;; Standard instance slot access |
---|
732 | |
---|
733 | ;;; N.B. The location of the effective-slots slots in the class metaobject for |
---|
734 | ;;; standard-class must be determined without making any further slot |
---|
735 | ;;; references. |
---|
736 | |
---|
737 | (defun find-slot-definition (class slot-name) |
---|
738 | (dolist (slot (class-slots class) nil) |
---|
739 | (when (eq slot-name (slot-definition-name slot)) |
---|
740 | (return slot)))) |
---|
741 | |
---|
742 | (defun slot-location (class slot-name) |
---|
743 | (let ((slot (find-slot-definition class slot-name))) |
---|
744 | (if slot |
---|
745 | (slot-definition-location slot) |
---|
746 | nil))) |
---|
747 | |
---|
748 | (defun instance-slot-location (instance slot-name) |
---|
749 | (let ((layout (std-instance-layout instance))) |
---|
750 | (and layout (layout-slot-location layout slot-name)))) |
---|
751 | |
---|
752 | (defun slot-value (object slot-name) |
---|
753 | (let* ((class (class-of object)) |
---|
754 | (metaclass (class-of class))) |
---|
755 | (if (or (eq metaclass +the-standard-class+) |
---|
756 | (eq metaclass +the-structure-class+) |
---|
757 | (eq metaclass +the-funcallable-standard-class+)) |
---|
758 | (std-slot-value object slot-name) |
---|
759 | (slot-value-using-class class object |
---|
760 | (find-slot-definition class slot-name))))) |
---|
761 | |
---|
762 | (defun %set-slot-value (object slot-name new-value) |
---|
763 | (let* ((class (class-of object)) |
---|
764 | (metaclass (class-of class))) |
---|
765 | (if (or (eq metaclass +the-standard-class+) |
---|
766 | (eq metaclass +the-structure-class+) |
---|
767 | (eq metaclass +the-funcallable-standard-class+)) |
---|
768 | (setf (std-slot-value object slot-name) new-value) |
---|
769 | (setf (slot-value-using-class class object |
---|
770 | (find-slot-definition class slot-name)) |
---|
771 | new-value)))) |
---|
772 | |
---|
773 | (defsetf slot-value %set-slot-value) |
---|
774 | |
---|
775 | (defun slot-boundp (object slot-name) |
---|
776 | (let ((class (class-of object))) |
---|
777 | (if (std-class-p class) |
---|
778 | (std-slot-boundp object slot-name) |
---|
779 | (slot-boundp-using-class class object |
---|
780 | (find-slot-definition class slot-name))))) |
---|
781 | |
---|
782 | (defun std-slot-makunbound (instance slot-name) |
---|
783 | (let ((location (instance-slot-location instance slot-name))) |
---|
784 | (cond ((fixnump location) |
---|
785 | (setf (standard-instance-access instance location) +slot-unbound+)) |
---|
786 | ((consp location) |
---|
787 | (setf (cdr location) +slot-unbound+)) |
---|
788 | (t |
---|
789 | (slot-missing (class-of instance) instance slot-name 'slot-makunbound)))) |
---|
790 | instance) |
---|
791 | |
---|
792 | (defun slot-makunbound (object slot-name) |
---|
793 | (let ((class (class-of object))) |
---|
794 | (if (std-class-p class) |
---|
795 | (std-slot-makunbound object slot-name) |
---|
796 | (slot-makunbound-using-class class object |
---|
797 | (find-slot-definition class slot-name))))) |
---|
798 | |
---|
799 | (defun std-slot-exists-p (instance slot-name) |
---|
800 | (not (null (find slot-name (class-slots (class-of instance)) |
---|
801 | :key 'slot-definition-name)))) |
---|
802 | |
---|
803 | (defun slot-exists-p (object slot-name) |
---|
804 | (let ((class (class-of object))) |
---|
805 | (if (std-class-p class) |
---|
806 | (std-slot-exists-p object slot-name) |
---|
807 | (slot-exists-p-using-class class object slot-name)))) |
---|
808 | |
---|
809 | (defun instance-slot-p (slot) |
---|
810 | (eq (slot-definition-allocation slot) :instance)) |
---|
811 | |
---|
812 | (defun std-allocate-instance (class) |
---|
813 | (sys::%std-allocate-instance class)) |
---|
814 | |
---|
815 | (defun allocate-funcallable-instance (class) |
---|
816 | (let ((instance (sys::%allocate-funcallable-instance class))) |
---|
817 | ;; KLUDGE: without this, the build fails with unbound-slot |
---|
818 | (when (or (eq class +the-standard-generic-function-class+) |
---|
819 | (subtypep class +the-standard-generic-function-class+)) |
---|
820 | (setf (std-slot-value instance 'sys::method-class) |
---|
821 | +the-standard-method-class+)) |
---|
822 | (set-funcallable-instance-function |
---|
823 | instance |
---|
824 | #'(lambda (&rest args) |
---|
825 | (declare (ignore args)) |
---|
826 | (error 'program-error "Called a funcallable-instance with unset function."))) |
---|
827 | instance)) |
---|
828 | |
---|
829 | (declaim (notinline class-prototype)) |
---|
830 | (defun class-prototype (class) |
---|
831 | (unless (class-finalized-p class) (error "Class ~A not finalized" (class-name class))) |
---|
832 | (std-allocate-instance class)) |
---|
833 | |
---|
834 | (defun maybe-finalize-class-subtree (class) |
---|
835 | (when (every #'class-finalized-p (class-direct-superclasses class)) |
---|
836 | (finalize-inheritance class) |
---|
837 | (dolist (subclass (class-direct-subclasses class)) |
---|
838 | (maybe-finalize-class-subtree subclass)))) |
---|
839 | |
---|
840 | (defun make-instance-standard-class (metaclass |
---|
841 | &rest initargs |
---|
842 | &key name direct-superclasses direct-slots |
---|
843 | direct-default-initargs |
---|
844 | documentation) |
---|
845 | (declare (ignore metaclass)) |
---|
846 | (let ((class (std-allocate-instance +the-standard-class+))) |
---|
847 | (unless *clos-booting* |
---|
848 | (check-initargs (list #'allocate-instance #'initialize-instance) |
---|
849 | (list* class initargs) |
---|
850 | class t initargs |
---|
851 | *make-instance-initargs-cache* 'make-instance)) |
---|
852 | (%set-class-name name class) |
---|
853 | ;; KLUDGE: necessary in define-primordial-class, otherwise |
---|
854 | ;; StandardClass.getClassLayout() throws an error |
---|
855 | (unless *clos-booting* (%set-class-layout nil class)) |
---|
856 | (%set-class-direct-subclasses () class) |
---|
857 | (%set-class-direct-methods () class) |
---|
858 | (%set-class-documentation class documentation) |
---|
859 | (std-after-initialization-for-classes class |
---|
860 | :direct-superclasses direct-superclasses |
---|
861 | :direct-slots direct-slots |
---|
862 | :direct-default-initargs direct-default-initargs) |
---|
863 | class)) |
---|
864 | |
---|
865 | (defun make-or-find-instance-funcallable-standard-class |
---|
866 | (metaclass &rest initargs &key name direct-superclasses direct-slots |
---|
867 | direct-default-initargs documentation) |
---|
868 | (declare (ignore metaclass initargs)) |
---|
869 | (or (find-class name nil) |
---|
870 | (let ((class (std-allocate-instance +the-funcallable-standard-class+))) |
---|
871 | (%set-class-name name class) |
---|
872 | (unless *clos-booting* (%set-class-layout nil class)) |
---|
873 | (%set-class-direct-subclasses () class) |
---|
874 | (%set-class-direct-methods () class) |
---|
875 | (%set-class-documentation class documentation) |
---|
876 | (std-after-initialization-for-classes class |
---|
877 | :direct-superclasses direct-superclasses |
---|
878 | :direct-slots direct-slots |
---|
879 | :direct-default-initargs direct-default-initargs) |
---|
880 | class))) |
---|
881 | |
---|
882 | ;(defun convert-to-direct-slot-definition (class canonicalized-slot) |
---|
883 | ; (apply #'make-instance |
---|
884 | ; (apply #'direct-slot-definition-class |
---|
885 | ; class canonicalized-slot) |
---|
886 | ; canonicalized-slot)) |
---|
887 | |
---|
888 | (defun canonicalize-direct-superclass-list (class direct-superclasses) |
---|
889 | (cond (direct-superclasses) |
---|
890 | ((subtypep (class-of class) +the-funcallable-standard-class+) |
---|
891 | (list +the-funcallable-standard-object-class+)) |
---|
892 | ((subtypep (class-of class) +the-standard-class+) |
---|
893 | (list +the-standard-object-class+)))) |
---|
894 | |
---|
895 | (defun std-after-initialization-for-classes (class |
---|
896 | &key direct-superclasses direct-slots |
---|
897 | direct-default-initargs |
---|
898 | &allow-other-keys) |
---|
899 | (let ((supers (canonicalize-direct-superclass-list class direct-superclasses))) |
---|
900 | (setf (class-direct-superclasses class) supers) |
---|
901 | (dolist (superclass supers) |
---|
902 | (add-direct-subclass superclass class))) |
---|
903 | (let ((slots (mapcar #'(lambda (slot-properties) |
---|
904 | (apply #'make-direct-slot-definition class slot-properties)) |
---|
905 | direct-slots))) |
---|
906 | (setf (class-direct-slots class) slots) |
---|
907 | (dolist (direct-slot slots) |
---|
908 | (dolist (reader (slot-definition-readers direct-slot)) |
---|
909 | (add-reader-method class reader direct-slot)) |
---|
910 | (dolist (writer (slot-definition-writers direct-slot)) |
---|
911 | (add-writer-method class writer direct-slot)))) |
---|
912 | (setf (class-direct-default-initargs class) direct-default-initargs) |
---|
913 | (maybe-finalize-class-subtree class) |
---|
914 | (values)) |
---|
915 | |
---|
916 | (defmacro define-primordial-class (name superclasses direct-slots) |
---|
917 | "Primitive class definition tool. |
---|
918 | No non-standard metaclasses, accessor methods, duplicate slots, |
---|
919 | non-existent superclasses, default initargs, or other complicated stuff. |
---|
920 | Handle with care." |
---|
921 | (let ((class (gensym))) |
---|
922 | `(let ((,class (make-instance-standard-class |
---|
923 | nil |
---|
924 | :name ',name |
---|
925 | :direct-superclasses ',(mapcar #'find-class superclasses) |
---|
926 | :direct-slots ,(canonicalize-direct-slots direct-slots)))) |
---|
927 | (%set-find-class ',name ,class) |
---|
928 | ,class))) |
---|
929 | |
---|
930 | (defmacro define-funcallable-primordial-class (name superclasses direct-slots) |
---|
931 | "Primitive funcallable class definition tool. |
---|
932 | No non-standard metaclasses, accessor methods, duplicate slots, |
---|
933 | non-existent superclasses, default initargs, or other complicated stuff. |
---|
934 | Handle with care. |
---|
935 | Will not modify existing classes to avoid breaking std-generic-function-p." |
---|
936 | (let ((class (gensym))) |
---|
937 | `(let ((,class (make-or-find-instance-funcallable-standard-class |
---|
938 | nil |
---|
939 | :name ',name |
---|
940 | :direct-superclasses ',(mapcar #'find-class superclasses) |
---|
941 | :direct-slots ,(canonicalize-direct-slots direct-slots)))) |
---|
942 | (%set-find-class ',name ,class) |
---|
943 | ,class))) |
---|
944 | |
---|
945 | (define-primordial-class eql-specializer (specializer) |
---|
946 | ((object :initform nil) |
---|
947 | (direct-methods :initform nil))) |
---|
948 | |
---|
949 | (define-primordial-class method-combination (metaobject) |
---|
950 | ((sys::name :initarg :name :initform nil) |
---|
951 | (sys::%documentation :initarg :documentation :initform nil) |
---|
952 | (options :initarg :options :initform nil))) |
---|
953 | |
---|
954 | (define-primordial-class short-method-combination (method-combination) |
---|
955 | ((operator :initarg :operator) |
---|
956 | (identity-with-one-argument :initarg :identity-with-one-argument))) |
---|
957 | |
---|
958 | (define-primordial-class long-method-combination (method-combination) |
---|
959 | ((sys::lambda-list :initarg :lambda-list) |
---|
960 | (method-group-specs :initarg :method-group-specs) |
---|
961 | (args-lambda-list :initarg :args-lambda-list) |
---|
962 | (generic-function-symbol :initarg :generic-function-symbol) |
---|
963 | (function :initarg :function) |
---|
964 | (arguments :initarg :arguments) |
---|
965 | (declarations :initarg :declarations) |
---|
966 | (forms :initarg :forms))) |
---|
967 | |
---|
968 | (define-primordial-class standard-accessor-method (standard-method) |
---|
969 | ((sys::%slot-definition :initarg :slot-definition :initform nil))) |
---|
970 | |
---|
971 | (define-primordial-class standard-reader-method (standard-accessor-method) |
---|
972 | ()) |
---|
973 | (defconstant +the-standard-reader-method-class+ |
---|
974 | (find-class 'standard-reader-method)) |
---|
975 | |
---|
976 | (define-primordial-class standard-writer-method (standard-accessor-method) |
---|
977 | ()) |
---|
978 | (defconstant +the-standard-writer-method-class+ |
---|
979 | (find-class 'standard-writer-method)) |
---|
980 | |
---|
981 | (define-primordial-class structure-class (class) |
---|
982 | ()) |
---|
983 | (defconstant +the-structure-class+ (find-class 'structure-class)) |
---|
984 | |
---|
985 | (define-primordial-class forward-referenced-class (class) |
---|
986 | ;; The standard-class layout. Not all of these slots are necessary, |
---|
987 | ;; but at least NAME and DIRECT-SUBCLASSES are. |
---|
988 | ((sys::name :initarg :name :initform nil) |
---|
989 | (sys::layout :initform nil) |
---|
990 | (sys::direct-superclasses :initform nil) |
---|
991 | (sys::direct-subclasses :initform nil) |
---|
992 | (sys::precedence-list :initform nil) |
---|
993 | (sys::direct-methods :initform nil) |
---|
994 | (sys::direct-slots :initform nil) |
---|
995 | (sys::slots :initform nil) |
---|
996 | (sys::direct-default-initargs :initform nil) |
---|
997 | (sys::default-initargs :initform nil) |
---|
998 | (sys::finalized-p :initform nil) |
---|
999 | (sys::%documentation :initform nil))) |
---|
1000 | (defconstant +the-forward-referenced-class+ |
---|
1001 | (find-class 'forward-referenced-class)) |
---|
1002 | |
---|
1003 | (define-funcallable-primordial-class generic-function |
---|
1004 | (metaobject funcallable-standard-object) |
---|
1005 | ()) |
---|
1006 | |
---|
1007 | (defvar *extensible-built-in-classes* |
---|
1008 | (list (find-class 'sequence) |
---|
1009 | (find-class 'java:java-object))) |
---|
1010 | |
---|
1011 | (defvar *make-instance-initargs-cache* |
---|
1012 | (make-hash-table :test #'eq) |
---|
1013 | "Cached sets of allowable initargs, keyed on the class they belong to.") |
---|
1014 | (defvar *reinitialize-instance-initargs-cache* |
---|
1015 | (make-hash-table :test #'eq) |
---|
1016 | "Cached sets of allowable initargs, keyed on the class they belong to.") |
---|
1017 | |
---|
1018 | (defun expand-long-defcombin (name args) |
---|
1019 | (destructuring-bind (lambda-list method-groups &rest body) args |
---|
1020 | `(apply #'define-long-form-method-combination |
---|
1021 | ',name |
---|
1022 | ',lambda-list |
---|
1023 | (list ,@(mapcar #'canonicalize-method-group-spec method-groups)) |
---|
1024 | ',body))) |
---|
1025 | |
---|
1026 | ;;; The class method-combination and its subclasses are defined in |
---|
1027 | ;;; StandardClass.java, but we cannot use make-instance and slot-value |
---|
1028 | ;;; yet. |
---|
1029 | |
---|
1030 | (defun %make-long-method-combination (&key name documentation lambda-list |
---|
1031 | method-group-specs args-lambda-list |
---|
1032 | generic-function-symbol function |
---|
1033 | arguments declarations forms) |
---|
1034 | (let ((instance (std-allocate-instance (find-class 'long-method-combination)))) |
---|
1035 | (setf (std-slot-value instance 'sys::name) name) |
---|
1036 | (setf (std-slot-value instance 'sys:%documentation) documentation) |
---|
1037 | (setf (std-slot-value instance 'sys::lambda-list) lambda-list) |
---|
1038 | (setf (std-slot-value instance 'method-group-specs) method-group-specs) |
---|
1039 | (setf (std-slot-value instance 'args-lambda-list) args-lambda-list) |
---|
1040 | (setf (std-slot-value instance 'generic-function-symbol) |
---|
1041 | generic-function-symbol) |
---|
1042 | (setf (std-slot-value instance 'function) function) |
---|
1043 | (setf (std-slot-value instance 'arguments) arguments) |
---|
1044 | (setf (std-slot-value instance 'declarations) declarations) |
---|
1045 | (setf (std-slot-value instance 'forms) forms) |
---|
1046 | (setf (std-slot-value instance 'options) nil) |
---|
1047 | instance)) |
---|
1048 | |
---|
1049 | (defun method-combination-name (method-combination) |
---|
1050 | (check-type method-combination method-combination) |
---|
1051 | (std-slot-value method-combination 'sys::name)) |
---|
1052 | |
---|
1053 | (defun method-combination-documentation (method-combination) |
---|
1054 | (check-type method-combination method-combination) |
---|
1055 | (std-slot-value method-combination 'sys:%documentation)) |
---|
1056 | |
---|
1057 | (defun short-method-combination-operator (method-combination) |
---|
1058 | (check-type method-combination short-method-combination) |
---|
1059 | (std-slot-value method-combination 'operator)) |
---|
1060 | |
---|
1061 | (defun short-method-combination-identity-with-one-argument (method-combination) |
---|
1062 | (check-type method-combination short-method-combination) |
---|
1063 | (std-slot-value method-combination 'identity-with-one-argument)) |
---|
1064 | |
---|
1065 | (defun long-method-combination-lambda-list (method-combination) |
---|
1066 | (check-type method-combination long-method-combination) |
---|
1067 | (std-slot-value method-combination 'sys::lambda-list)) |
---|
1068 | |
---|
1069 | (defun long-method-combination-method-group-specs (method-combination) |
---|
1070 | (check-type method-combination long-method-combination) |
---|
1071 | (std-slot-value method-combination 'method-group-specs)) |
---|
1072 | |
---|
1073 | (defun long-method-combination-args-lambda-list (method-combination) |
---|
1074 | (check-type method-combination long-method-combination) |
---|
1075 | (std-slot-value method-combination 'args-lambda-list)) |
---|
1076 | |
---|
1077 | (defun long-method-combination-generic-function-symbol (method-combination) |
---|
1078 | (check-type method-combination long-method-combination) |
---|
1079 | (std-slot-value method-combination 'generic-function-symbol)) |
---|
1080 | |
---|
1081 | (defun long-method-combination-function (method-combination) |
---|
1082 | (check-type method-combination long-method-combination) |
---|
1083 | (std-slot-value method-combination 'function)) |
---|
1084 | |
---|
1085 | (defun long-method-combination-arguments (method-combination) |
---|
1086 | (check-type method-combination long-method-combination) |
---|
1087 | (std-slot-value method-combination 'arguments)) |
---|
1088 | |
---|
1089 | (defun long-method-combination-declarations (method-combination) |
---|
1090 | (check-type method-combination long-method-combination) |
---|
1091 | (std-slot-value method-combination 'declarations)) |
---|
1092 | |
---|
1093 | (defun long-method-combination-forms (method-combination) |
---|
1094 | (check-type method-combination long-method-combination) |
---|
1095 | (std-slot-value method-combination 'forms)) |
---|
1096 | |
---|
1097 | |
---|
1098 | (defun expand-short-defcombin (whole) |
---|
1099 | (let* ((name (cadr whole)) |
---|
1100 | (documentation |
---|
1101 | (getf (cddr whole) :documentation "")) |
---|
1102 | (identity-with-one-arg |
---|
1103 | (getf (cddr whole) :identity-with-one-argument nil)) |
---|
1104 | (operator |
---|
1105 | (getf (cddr whole) :operator name))) |
---|
1106 | `(progn |
---|
1107 | (let ((instance (std-allocate-instance |
---|
1108 | (find-class 'short-method-combination)))) |
---|
1109 | (setf (std-slot-value instance 'sys::name) ',name) |
---|
1110 | (setf (std-slot-value instance 'sys:%documentation) ',documentation) |
---|
1111 | (setf (std-slot-value instance 'operator) ',operator) |
---|
1112 | (setf (std-slot-value instance 'identity-with-one-argument) |
---|
1113 | ',identity-with-one-arg) |
---|
1114 | (setf (std-slot-value instance 'options) nil) |
---|
1115 | (setf (get ',name 'method-combination-object) instance) |
---|
1116 | ',name)))) |
---|
1117 | |
---|
1118 | (defmacro define-method-combination (&whole form name &rest args) |
---|
1119 | (if (and (cddr form) |
---|
1120 | (listp (caddr form))) |
---|
1121 | (expand-long-defcombin name args) |
---|
1122 | (expand-short-defcombin form))) |
---|
1123 | |
---|
1124 | (define-method-combination + :identity-with-one-argument t) |
---|
1125 | (define-method-combination and :identity-with-one-argument t) |
---|
1126 | (define-method-combination append :identity-with-one-argument nil) |
---|
1127 | (define-method-combination list :identity-with-one-argument nil) |
---|
1128 | (define-method-combination max :identity-with-one-argument t) |
---|
1129 | (define-method-combination min :identity-with-one-argument t) |
---|
1130 | (define-method-combination nconc :identity-with-one-argument t) |
---|
1131 | (define-method-combination or :identity-with-one-argument t) |
---|
1132 | (define-method-combination progn :identity-with-one-argument t) |
---|
1133 | |
---|
1134 | ;;; |
---|
1135 | ;;; long form of define-method-combination (from Sacla and XCL) |
---|
1136 | ;;; |
---|
1137 | (defun method-group-p (selecter qualifiers) |
---|
1138 | ;; selecter::= qualifier-pattern | predicate |
---|
1139 | (etypecase selecter |
---|
1140 | (list (or (equal selecter qualifiers) |
---|
1141 | (let ((last (last selecter))) |
---|
1142 | (when (eq '* (cdr last)) |
---|
1143 | (let* ((prefix `(,@(butlast selecter) ,(car last))) |
---|
1144 | (pos (mismatch prefix qualifiers))) |
---|
1145 | (or (null pos) (= pos (length prefix)))))))) |
---|
1146 | ((eql *) t) |
---|
1147 | (symbol (funcall (symbol-function selecter) qualifiers)))) |
---|
1148 | |
---|
1149 | (defun check-variable-name (name) |
---|
1150 | (flet ((valid-variable-name-p (name) |
---|
1151 | (and (symbolp name) (not (constantp name))))) |
---|
1152 | (assert (valid-variable-name-p name)))) |
---|
1153 | |
---|
1154 | (defun canonicalize-method-group-spec (spec) |
---|
1155 | ;; spec ::= (name {qualifier-pattern+ | predicate} [[long-form-option]]) |
---|
1156 | ;; long-form-option::= :description description | :order order | |
---|
1157 | ;; :required required-p |
---|
1158 | ;; a canonicalized-spec is a simple plist. |
---|
1159 | (let* ((rest spec) |
---|
1160 | (name (prog2 (check-variable-name (car rest)) |
---|
1161 | (car rest) |
---|
1162 | (setq rest (cdr rest)))) |
---|
1163 | (option-names '(:description :order :required)) |
---|
1164 | (selecters (let ((end (or (position-if #'(lambda (it) |
---|
1165 | (member it option-names)) |
---|
1166 | rest) |
---|
1167 | (length rest)))) |
---|
1168 | (prog1 (subseq rest 0 end) |
---|
1169 | (setq rest (subseq rest end))))) |
---|
1170 | (description (getf rest :description "")) |
---|
1171 | (order (getf rest :order :most-specific-first)) |
---|
1172 | (required-p (getf rest :required))) |
---|
1173 | `(list :name ',name |
---|
1174 | :predicate (lambda (qualifiers) |
---|
1175 | (loop for item in ',selecters |
---|
1176 | thereis (method-group-p item qualifiers))) |
---|
1177 | :description ',description |
---|
1178 | :order ',order |
---|
1179 | :required ',required-p |
---|
1180 | :*-selecter ,(equal selecters '(*))))) |
---|
1181 | |
---|
1182 | (defun extract-required-part (lambda-list) |
---|
1183 | (flet ((skip (key lambda-list) |
---|
1184 | (if (eq (first lambda-list) key) |
---|
1185 | (cddr lambda-list) |
---|
1186 | lambda-list))) |
---|
1187 | (let* ((trimmed-lambda-list |
---|
1188 | (skip '&environment (skip '&whole lambda-list))) |
---|
1189 | (after-required-lambda-list |
---|
1190 | (member-if #'(lambda (it) (member it lambda-list-keywords)) |
---|
1191 | trimmed-lambda-list))) |
---|
1192 | (if after-required-lambda-list |
---|
1193 | (ldiff trimmed-lambda-list after-required-lambda-list) |
---|
1194 | trimmed-lambda-list)))) |
---|
1195 | |
---|
1196 | (defun extract-specified-part (key lambda-list) |
---|
1197 | (case key |
---|
1198 | ((&eval &whole) |
---|
1199 | (list (second (member key lambda-list)))) |
---|
1200 | (t |
---|
1201 | (let ((here (cdr (member key lambda-list)))) |
---|
1202 | (ldiff here |
---|
1203 | (member-if #'(lambda (it) (member it lambda-list-keywords)) |
---|
1204 | here)))))) |
---|
1205 | |
---|
1206 | (defun extract-optional-part (lambda-list) |
---|
1207 | (extract-specified-part '&optional lambda-list)) |
---|
1208 | |
---|
1209 | (defun parse-define-method-combination-args-lambda-list (lambda-list) |
---|
1210 | ;; Define-method-combination Arguments Lambda Lists |
---|
1211 | ;; http://www.lispworks.com/reference/HyperSpec/Body/03_dj.htm |
---|
1212 | (let ((required (extract-required-part lambda-list)) |
---|
1213 | (whole (extract-specified-part '&whole lambda-list)) |
---|
1214 | (optional (extract-specified-part '&optional lambda-list)) |
---|
1215 | (rest (extract-specified-part '&rest lambda-list)) |
---|
1216 | (keys (extract-specified-part '&key lambda-list)) |
---|
1217 | (aux (extract-specified-part '&aux lambda-list))) |
---|
1218 | (values (first whole) |
---|
1219 | required |
---|
1220 | (mapcar #'(lambda (spec) |
---|
1221 | (if (consp spec) |
---|
1222 | `(,(first spec) ,(second spec) ,@(cddr spec)) |
---|
1223 | `(,spec nil))) |
---|
1224 | optional) |
---|
1225 | (first rest) |
---|
1226 | (mapcar #'(lambda (spec) |
---|
1227 | (let ((key (if (consp spec) (car spec) spec)) |
---|
1228 | (rest (when (consp spec) (rest spec)))) |
---|
1229 | `(,(if (consp key) key `(,(make-keyword key) ,key)) |
---|
1230 | ,(car rest) |
---|
1231 | ,@(cdr rest)))) |
---|
1232 | keys) |
---|
1233 | (mapcar #'(lambda (spec) |
---|
1234 | (if (consp spec) |
---|
1235 | `(,(first spec) ,(second spec)) |
---|
1236 | `(,spec nil))) |
---|
1237 | aux)))) |
---|
1238 | |
---|
1239 | (defun wrap-with-call-method-macro (gf args-var emf-form) |
---|
1240 | `(macrolet |
---|
1241 | ((call-method (method &optional next-method-list) |
---|
1242 | `(funcall |
---|
1243 | ,(cond |
---|
1244 | ((listp method) |
---|
1245 | (assert (eq (first method) 'make-method)) |
---|
1246 | ;; by generating an inline expansion we prevent allocation |
---|
1247 | ;; of a method instance which will be discarded immediately |
---|
1248 | ;; after reading the METHOD-FUNCTION slot |
---|
1249 | (compute-method-function |
---|
1250 | `(lambda (&rest ,(gensym)) |
---|
1251 | ;; the MAKE-METHOD body form gets evaluated in |
---|
1252 | ;; the null lexical environment augmented |
---|
1253 | ;; with a binding for CALL-METHOD |
---|
1254 | ,(wrap-with-call-method-macro ,gf |
---|
1255 | ',args-var |
---|
1256 | (second method))))) |
---|
1257 | (t (method-function method))) |
---|
1258 | ,',args-var |
---|
1259 | ,(unless (null next-method-list) |
---|
1260 | ;; by not generating an emf when there are no next methods, |
---|
1261 | ;; we ensure next-method-p returns NIL |
---|
1262 | (compute-effective-method |
---|
1263 | ,gf (generic-function-method-combination ,gf) |
---|
1264 | (process-next-method-list next-method-list)))))) |
---|
1265 | ,emf-form)) |
---|
1266 | |
---|
1267 | (defun assert-unambiguous-method-sorting (group-name methods) |
---|
1268 | (let ((specializers (make-hash-table :test 'equal))) |
---|
1269 | (dolist (method methods) |
---|
1270 | (push method (gethash (method-specializers method) specializers))) |
---|
1271 | (loop for specializer-methods being each hash-value of specializers |
---|
1272 | using (hash-key method-specializers) |
---|
1273 | unless (= 1 (length specializer-methods)) |
---|
1274 | do (error "Ambiguous method sorting in method group ~A due to multiple ~ |
---|
1275 | methods with specializers ~S: ~S" |
---|
1276 | group-name method-specializers specializer-methods)))) |
---|
1277 | |
---|
1278 | (defmacro with-method-groups (method-group-specs methods-form &body forms) |
---|
1279 | (flet ((grouping-form (spec methods-var) |
---|
1280 | (let ((predicate (coerce-to-function (getf spec :predicate))) |
---|
1281 | (group (gensym)) |
---|
1282 | (leftovers (gensym)) |
---|
1283 | (method (gensym))) |
---|
1284 | `(let ((,group '()) |
---|
1285 | (,leftovers '())) |
---|
1286 | (dolist (,method ,methods-var) |
---|
1287 | (if (funcall ,predicate (method-qualifiers ,method)) |
---|
1288 | (push ,method ,group) |
---|
1289 | (push ,method ,leftovers))) |
---|
1290 | (ecase ,(getf spec :order) |
---|
1291 | (:most-specific-last ) |
---|
1292 | (:most-specific-first (setq ,group (nreverse ,group)))) |
---|
1293 | ,@(when (getf spec :required) |
---|
1294 | `((when (null ,group) |
---|
1295 | (error "Method group ~S must not be empty." |
---|
1296 | ',(getf spec :name))))) |
---|
1297 | (setq ,methods-var (nreverse ,leftovers)) |
---|
1298 | ,group)))) |
---|
1299 | (let ((rest (gensym)) |
---|
1300 | (method (gensym))) |
---|
1301 | `(let* ((,rest ,methods-form) |
---|
1302 | ,@(mapcar #'(lambda (spec) |
---|
1303 | `(,(getf spec :name) ,(grouping-form spec rest))) |
---|
1304 | method-group-specs)) |
---|
1305 | (dolist (,method ,rest) |
---|
1306 | (invalid-method-error ,method |
---|
1307 | "Method ~S with qualifiers ~S does not belong to any method group." |
---|
1308 | ,method (method-qualifiers ,method))) |
---|
1309 | ,@(unless (and (= 1 (length method-group-specs)) |
---|
1310 | (getf (car method-group-specs) :*-selecter)) |
---|
1311 | (mapcar #'(lambda (spec) |
---|
1312 | `(assert-unambiguous-method-sorting ',(getf spec :name) ,(getf spec :name))) |
---|
1313 | method-group-specs)) |
---|
1314 | ,@forms)))) |
---|
1315 | |
---|
1316 | (defun method-combination-type-lambda-with-args-emf |
---|
1317 | (&key args-lambda-list generic-function-symbol forms &allow-other-keys) |
---|
1318 | (multiple-value-bind |
---|
1319 | (whole required optional rest keys aux) |
---|
1320 | (parse-define-method-combination-args-lambda-list args-lambda-list) |
---|
1321 | (unless rest |
---|
1322 | (when keys |
---|
1323 | (setf rest (gensym)))) |
---|
1324 | (let* ((gf-lambda-list (gensym)) |
---|
1325 | (args-var (gensym)) |
---|
1326 | (args-len-var (gensym)) |
---|
1327 | (binding-forms (gensym)) |
---|
1328 | (needs-args-len-var (gensym)) |
---|
1329 | (emf-form (gensym))) |
---|
1330 | `(let* ((,gf-lambda-list (slot-value ,generic-function-symbol |
---|
1331 | 'sys::lambda-list)) |
---|
1332 | (nreq (length (extract-required-part ,gf-lambda-list))) |
---|
1333 | (nopt (length (extract-optional-part ,gf-lambda-list))) |
---|
1334 | (,binding-forms) |
---|
1335 | (,needs-args-len-var) |
---|
1336 | (,emf-form |
---|
1337 | (let* (,@(when whole |
---|
1338 | `((,whole (progn |
---|
1339 | (push `(,',whole ,',args-var) |
---|
1340 | ,binding-forms) |
---|
1341 | ',args-var)))) |
---|
1342 | ,@(when rest |
---|
1343 | ;; ### TODO: use a fresh symbol for the rest |
---|
1344 | ;; binding being generated and pushed into binding-forms |
---|
1345 | `((,rest (progn |
---|
1346 | (push `(,',rest |
---|
1347 | (subseq ,',args-var |
---|
1348 | ,(+ nreq nopt))) |
---|
1349 | ,binding-forms) |
---|
1350 | ',rest)))) |
---|
1351 | ,@(loop for var in required and i upfrom 0 |
---|
1352 | for var-binding = (gensym) |
---|
1353 | collect `(,var (when (< ,i nreq) |
---|
1354 | (push `(,',var-binding |
---|
1355 | (nth ,,i ,',args-var)) |
---|
1356 | ,binding-forms) |
---|
1357 | ',var-binding))) |
---|
1358 | ,@(loop for (var initform supplied-var) in optional |
---|
1359 | and i upfrom 0 |
---|
1360 | for supplied-binding = (or supplied-var (gensym)) |
---|
1361 | for var-binding = (gensym) |
---|
1362 | ;; check for excess parameters |
---|
1363 | ;; only assign initform if the parameter |
---|
1364 | ;; isn't in excess: the spec says explicitly |
---|
1365 | ;; to bind parameters in excess to forms evaluating |
---|
1366 | ;; to nil. |
---|
1367 | ;; This leaves initforms to be used with |
---|
1368 | ;; parameters not supplied in excess, but |
---|
1369 | ;; not available in the arguments list |
---|
1370 | ;; |
---|
1371 | ;; Also, if specified, bind "supplied-p" |
---|
1372 | collect `(,supplied-binding |
---|
1373 | (when (< ,i nopt) |
---|
1374 | (setq ,needs-args-len-var t) |
---|
1375 | ;; ### TODO: use a fresh symbol for the supplied binding |
---|
1376 | ;; binding being generated and pushed into binding-forms |
---|
1377 | (push `(,',supplied-binding |
---|
1378 | (< ,(+ ,i nreq) ,',args-len-var)) |
---|
1379 | ,binding-forms) |
---|
1380 | ',supplied-binding)) |
---|
1381 | collect `(,var (when (< ,i nopt) |
---|
1382 | (push `(,',var-binding |
---|
1383 | (if ,',supplied-binding |
---|
1384 | (nth ,(+ ,i nreq) |
---|
1385 | ,',args-var) |
---|
1386 | ,',initform)) |
---|
1387 | ,binding-forms) |
---|
1388 | ',var-binding))) |
---|
1389 | ,@(loop for ((key var) initform supplied-var) in keys |
---|
1390 | for supplied-binding = (or supplied-var (gensym)) |
---|
1391 | for var-binding = (gensym) |
---|
1392 | ;; Same as optional parameters: |
---|
1393 | ;; even though keywords can't be supplied in |
---|
1394 | ;; excess, we should bind "supplied-p" in case |
---|
1395 | ;; the key isn't supplied in the arguments list |
---|
1396 | collect `(,supplied-binding |
---|
1397 | (progn |
---|
1398 | ;; ### TODO: use a fresh symbol for the rest |
---|
1399 | ;; binding being generated and pushed into binding-forms |
---|
1400 | (push `(,',supplied-binding |
---|
1401 | (member ,',key ,',rest)) |
---|
1402 | ,binding-forms) |
---|
1403 | ',supplied-binding)) |
---|
1404 | collect `(,var (progn |
---|
1405 | (push `(,',var-binding |
---|
1406 | (if ,',supplied-binding |
---|
1407 | (cadr ,',supplied-binding) |
---|
1408 | ,',initform)) |
---|
1409 | ,binding-forms) |
---|
1410 | ',var-binding))) |
---|
1411 | ,@(loop for (var initform) in aux |
---|
1412 | for var-binding = (gensym) |
---|
1413 | collect `(,var (progn |
---|
1414 | (push '(,var-binding ,initform) |
---|
1415 | ,binding-forms) |
---|
1416 | ',var-binding)))) |
---|
1417 | ,@forms))) |
---|
1418 | `(lambda (,',args-var) |
---|
1419 | ;; set up bindings to ensure the expressions to which the |
---|
1420 | ;; variables of the arguments option have been bound are |
---|
1421 | ;; evaluated exactly once. |
---|
1422 | (let* (,@(when ,needs-args-len-var |
---|
1423 | `((,',args-len-var (length ,',args-var)))) |
---|
1424 | ,@(reverse ,binding-forms)) |
---|
1425 | ;; This is the lambda which *is* the effective method |
---|
1426 | ;; hence gets called on every method invocation |
---|
1427 | ;; be as efficient in this method as we can be |
---|
1428 | ,(wrap-with-call-method-macro ,generic-function-symbol |
---|
1429 | ',args-var ,emf-form))))))) |
---|
1430 | |
---|
1431 | (defun method-combination-type-lambda |
---|
1432 | (&rest all-args |
---|
1433 | &key name lambda-list args-lambda-list generic-function-symbol |
---|
1434 | method-group-specs declarations forms &allow-other-keys) |
---|
1435 | (declare (ignore name)) |
---|
1436 | (let ((methods (gensym)) |
---|
1437 | (args-var (gensym)) |
---|
1438 | (emf-form (gensym))) |
---|
1439 | `(lambda (,generic-function-symbol ,methods ,@lambda-list) |
---|
1440 | ;; This is the lambda which computes the effective method |
---|
1441 | ,@declarations |
---|
1442 | (with-method-groups ,method-group-specs |
---|
1443 | ,methods |
---|
1444 | ,(if (null args-lambda-list) |
---|
1445 | `(let ((,emf-form (progn ,@forms))) |
---|
1446 | `(lambda (,',args-var) |
---|
1447 | ;; This is the lambda which *is* the effective method |
---|
1448 | ;; hence gets called on every method invocation |
---|
1449 | ;; be as efficient in this method as we can be |
---|
1450 | ,(wrap-with-call-method-macro ,generic-function-symbol |
---|
1451 | ',args-var ,emf-form))) |
---|
1452 | (apply #'method-combination-type-lambda-with-args-emf all-args)))))) |
---|
1453 | |
---|
1454 | (defun declarationp (expr) |
---|
1455 | (and (consp expr) (eq (car expr) 'DECLARE))) |
---|
1456 | |
---|
1457 | (defun long-form-method-combination-args (args) |
---|
1458 | ;; define-method-combination name lambda-list (method-group-specifier*) args |
---|
1459 | ;; args ::= [(:arguments . args-lambda-list)] |
---|
1460 | ;; [(:generic-function generic-function-symbol)] |
---|
1461 | ;; [[declaration* | documentation]] form* |
---|
1462 | (let ((rest args)) |
---|
1463 | (labels ((nextp (key) (and (consp (car rest)) (eq key (caar rest)))) |
---|
1464 | (args-lambda-list () |
---|
1465 | (when (nextp :arguments) |
---|
1466 | (prog1 (cdr (car rest)) (setq rest (cdr rest))))) |
---|
1467 | (generic-function-symbol () |
---|
1468 | (if (nextp :generic-function) |
---|
1469 | (prog1 (second (car rest)) (setq rest (cdr rest))) |
---|
1470 | (gensym))) |
---|
1471 | (declaration* () |
---|
1472 | (let ((end (position-if-not #'declarationp rest))) |
---|
1473 | (when end |
---|
1474 | (prog1 (subseq rest 0 end) (setq rest (nthcdr end rest)))))) |
---|
1475 | (documentation? () |
---|
1476 | (when (stringp (car rest)) |
---|
1477 | (prog1 (car rest) (setq rest (cdr rest))))) |
---|
1478 | (form* () rest)) |
---|
1479 | (let ((declarations '())) |
---|
1480 | `(:args-lambda-list ,(args-lambda-list) |
---|
1481 | :generic-function-symbol ,(generic-function-symbol) |
---|
1482 | :documentation ,(prog2 (setq declarations (declaration*)) |
---|
1483 | (documentation?)) |
---|
1484 | :declarations (,@declarations ,@(declaration*)) |
---|
1485 | :forms ,(form*)))))) |
---|
1486 | |
---|
1487 | (defun define-long-form-method-combination (name lambda-list method-group-specs |
---|
1488 | &rest args) |
---|
1489 | (let* ((initargs `(:name ,name |
---|
1490 | :lambda-list ,lambda-list |
---|
1491 | :method-group-specs ,method-group-specs |
---|
1492 | ,@(long-form-method-combination-args args))) |
---|
1493 | (lambda-expression (apply #'method-combination-type-lambda initargs))) |
---|
1494 | (setf (get name 'method-combination-object) |
---|
1495 | (apply '%make-long-method-combination |
---|
1496 | :function (coerce-to-function lambda-expression) initargs)) |
---|
1497 | name)) |
---|
1498 | |
---|
1499 | (defun std-find-method-combination (gf name options) |
---|
1500 | (declare (ignore gf)) |
---|
1501 | (when (and (eql name 'standard) options) |
---|
1502 | ;; CLHS DEFGENERIC |
---|
1503 | (error "The standard method combination does not accept any arguments.")) |
---|
1504 | (let ((mc (get name 'method-combination-object))) |
---|
1505 | (cond |
---|
1506 | ((null mc) (error "Method combination ~S not found" name)) |
---|
1507 | ((null options) mc) |
---|
1508 | ((typep mc 'short-method-combination) |
---|
1509 | (make-instance |
---|
1510 | 'short-method-combination |
---|
1511 | :name name |
---|
1512 | :documentation (method-combination-documentation mc) |
---|
1513 | :operator (short-method-combination-operator mc) |
---|
1514 | :identity-with-one-argument |
---|
1515 | (short-method-combination-identity-with-one-argument mc) |
---|
1516 | :options options)) |
---|
1517 | ((typep mc 'long-method-combination) |
---|
1518 | (make-instance |
---|
1519 | 'long-method-combination |
---|
1520 | :name name |
---|
1521 | :documentation (method-combination-documentation mc) |
---|
1522 | :lambda-list (long-method-combination-lambda-list mc) |
---|
1523 | :method-group-specs (long-method-combination-method-group-specs mc) |
---|
1524 | :args-lambda-list (long-method-combination-args-lambda-list mc) |
---|
1525 | :generic-function-symbol (long-method-combination-generic-function-symbol mc) |
---|
1526 | :function (long-method-combination-function mc) |
---|
1527 | :arguments (long-method-combination-arguments mc) |
---|
1528 | :declarations (long-method-combination-declarations mc) |
---|
1529 | :forms (long-method-combination-forms mc) |
---|
1530 | :options options))))) |
---|
1531 | |
---|
1532 | (declaim (notinline find-method-combination)) |
---|
1533 | (defun find-method-combination (gf name options) |
---|
1534 | (std-find-method-combination gf name options)) |
---|
1535 | |
---|
1536 | (defconstant +the-standard-method-combination+ |
---|
1537 | (let ((instance (std-allocate-instance (find-class 'method-combination)))) |
---|
1538 | (setf (std-slot-value instance 'sys::name) 'standard) |
---|
1539 | (setf (std-slot-value instance 'sys:%documentation) |
---|
1540 | "The standard method combination.") |
---|
1541 | (setf (std-slot-value instance 'options) nil) |
---|
1542 | instance) |
---|
1543 | "The standard method combination. |
---|
1544 | Do not use this object for identity since it changes between |
---|
1545 | compile-time and run-time. To detect the standard method combination, |
---|
1546 | compare the method combination name to the symbol 'standard.") |
---|
1547 | (setf (get 'standard 'method-combination-object) +the-standard-method-combination+) |
---|
1548 | |
---|
1549 | (define-funcallable-primordial-class standard-generic-function (generic-function) |
---|
1550 | ((sys::name :initarg :name :initform nil) |
---|
1551 | (sys::lambda-list :initarg :lambda-list :initform nil) |
---|
1552 | (sys::required-args :initarg :required-args :initform nil) |
---|
1553 | (sys::optional-args :initarg :optional-args :initform nil) |
---|
1554 | (sys::initial-methods :initarg :initial-methods :initform nil) |
---|
1555 | (sys::methods :initarg :methods :initform nil) |
---|
1556 | (sys::method-class :initarg :method-class |
---|
1557 | :initform +the-standard-method-class+) |
---|
1558 | (sys::%method-combination :initarg :method-combination |
---|
1559 | :initform +the-standard-method-combination+) |
---|
1560 | (sys::argument-precedence-order :initarg :argument-precedence-order |
---|
1561 | :initform nil) |
---|
1562 | (sys::declarations :initarg :declarations :initform nil) |
---|
1563 | (sys::%documentation :initarg :documentation :initform nil))) |
---|
1564 | (defconstant +the-standard-generic-function-class+ |
---|
1565 | (find-class 'standard-generic-function)) |
---|
1566 | |
---|
1567 | (defun std-generic-function-p (gf) |
---|
1568 | (eq (class-of gf) +the-standard-generic-function-class+)) |
---|
1569 | |
---|
1570 | (defparameter *eql-specializer-table* (make-hash-table :test 'eql)) |
---|
1571 | |
---|
1572 | (defun intern-eql-specializer (object) |
---|
1573 | (or (gethash object *eql-specializer-table*) |
---|
1574 | (setf (gethash object *eql-specializer-table*) |
---|
1575 | ;; we will be called during generic function invocation |
---|
1576 | ;; setup, so have to rely on plain functions here. |
---|
1577 | (let ((instance (std-allocate-instance (find-class 'eql-specializer)))) |
---|
1578 | (setf (std-slot-value instance 'object) object) |
---|
1579 | (setf (std-slot-value instance 'direct-methods) nil) |
---|
1580 | instance)))) |
---|
1581 | |
---|
1582 | (defun eql-specializer-object (eql-specializer) |
---|
1583 | (check-type eql-specializer eql-specializer) |
---|
1584 | (std-slot-value eql-specializer 'object)) |
---|
1585 | |
---|
1586 | ;;; Initial versions of some method metaobject readers. Defined on |
---|
1587 | ;;; AMOP pg. 218ff, will be redefined when generic functions are set up. |
---|
1588 | |
---|
1589 | (defun std-method-function (method) |
---|
1590 | (std-slot-value method 'sys::%function)) |
---|
1591 | |
---|
1592 | (defun std-method-generic-function (method) |
---|
1593 | (std-slot-value method 'sys::%generic-function)) |
---|
1594 | |
---|
1595 | (defun std-method-specializers (method) |
---|
1596 | (std-slot-value method 'sys::specializers)) |
---|
1597 | |
---|
1598 | (defun std-method-qualifiers (method) |
---|
1599 | (std-slot-value method 'sys::qualifiers)) |
---|
1600 | |
---|
1601 | (defun std-accessor-method-slot-definition (accessor-method) |
---|
1602 | (std-slot-value accessor-method 'sys::%slot-definition)) |
---|
1603 | |
---|
1604 | ;;; Additional method readers |
---|
1605 | (defun std-method-fast-function (method) |
---|
1606 | (std-slot-value method 'sys::fast-function)) |
---|
1607 | |
---|
1608 | (defun std-function-keywords (method) |
---|
1609 | (values (std-slot-value method 'sys::keywords) |
---|
1610 | (std-slot-value method 'sys::other-keywords-p))) |
---|
1611 | |
---|
1612 | ;;; Preliminary accessor definitions, will be redefined as generic |
---|
1613 | ;;; functions later in this file |
---|
1614 | |
---|
1615 | (declaim (notinline method-generic-function)) |
---|
1616 | (defun method-generic-function (method) |
---|
1617 | (std-method-generic-function method)) |
---|
1618 | |
---|
1619 | (declaim (notinline method-function)) |
---|
1620 | (defun method-function (method) |
---|
1621 | (std-method-function method)) |
---|
1622 | |
---|
1623 | (declaim (notinline method-specializers)) |
---|
1624 | (defun method-specializers (method) |
---|
1625 | (std-method-specializers method)) |
---|
1626 | |
---|
1627 | (declaim (notinline method-qualifiers)) |
---|
1628 | (defun method-qualifiers (method) |
---|
1629 | (std-method-qualifiers method)) |
---|
1630 | |
---|
1631 | |
---|
1632 | |
---|
1633 | ;;; MOP (p. 216) specifies the following reader generic functions: |
---|
1634 | ;;; generic-function-argument-precedence-order |
---|
1635 | ;;; generic-function-declarations |
---|
1636 | ;;; generic-function-lambda-list |
---|
1637 | ;;; generic-function-method-class |
---|
1638 | ;;; generic-function-method-combination |
---|
1639 | ;;; generic-function-methods |
---|
1640 | ;;; generic-function-name |
---|
1641 | |
---|
1642 | ;;; Additionally, we define the following reader functions: |
---|
1643 | ;;; generic-function-required-arguments |
---|
1644 | ;;; generic-function-optional-arguments |
---|
1645 | |
---|
1646 | ;;; These are defined as functions here and redefined as generic |
---|
1647 | ;;; functions via atomic-defgeneric once we're all set up. |
---|
1648 | |
---|
1649 | (defun generic-function-name (gf) |
---|
1650 | (std-slot-value gf 'sys::name)) |
---|
1651 | |
---|
1652 | (defun generic-function-lambda-list (gf) |
---|
1653 | (std-slot-value gf 'sys::lambda-list)) |
---|
1654 | |
---|
1655 | (defun generic-function-methods (gf) |
---|
1656 | (std-slot-value gf 'sys::methods)) |
---|
1657 | |
---|
1658 | (defun generic-function-method-class (gf) |
---|
1659 | (std-slot-value gf 'sys::method-class)) |
---|
1660 | |
---|
1661 | (defun generic-function-method-combination (gf) |
---|
1662 | (std-slot-value gf 'sys::%method-combination)) |
---|
1663 | |
---|
1664 | (defun generic-function-argument-precedence-order (gf) |
---|
1665 | (std-slot-value gf 'sys::argument-precedence-order)) |
---|
1666 | |
---|
1667 | (defun generic-function-required-arguments (gf) |
---|
1668 | (std-slot-value gf 'sys::required-args)) |
---|
1669 | |
---|
1670 | (defun generic-function-optional-arguments (gf) |
---|
1671 | (std-slot-value gf 'sys::optional-args)) |
---|
1672 | |
---|
1673 | (defun (setf method-lambda-list) (new-value method) |
---|
1674 | (setf (std-slot-value method 'sys::lambda-list) new-value)) |
---|
1675 | |
---|
1676 | (defun (setf method-qualifiers) (new-value method) |
---|
1677 | (setf (std-slot-value method 'sys::qualifiers) new-value)) |
---|
1678 | |
---|
1679 | (defun method-documentation (method) |
---|
1680 | (std-slot-value method 'sys:%documentation)) |
---|
1681 | |
---|
1682 | (defun (setf method-documentation) (new-value method) |
---|
1683 | (setf (std-slot-value method 'sys:%documentation) new-value)) |
---|
1684 | |
---|
1685 | ;;; defgeneric |
---|
1686 | |
---|
1687 | (defmacro defgeneric (function-name lambda-list |
---|
1688 | &rest options-and-method-descriptions) |
---|
1689 | (let ((options ()) |
---|
1690 | (methods ()) |
---|
1691 | (declarations ()) |
---|
1692 | (documentation nil)) |
---|
1693 | (dolist (item options-and-method-descriptions) |
---|
1694 | (case (car item) |
---|
1695 | (declare |
---|
1696 | (setf declarations (append declarations (cdr item)))) |
---|
1697 | (:documentation |
---|
1698 | (when documentation |
---|
1699 | (error 'program-error |
---|
1700 | :format-control "Documentation option was specified twice for generic function ~S." |
---|
1701 | :format-arguments (list function-name))) |
---|
1702 | (setf documentation t) |
---|
1703 | (push item options)) |
---|
1704 | (:method |
---|
1705 | ;; KLUDGE (rudi 2013-04-02): this only works with subclasses |
---|
1706 | ;; of standard-generic-function, since the initial-methods |
---|
1707 | ;; slot is not mandated by AMOP |
---|
1708 | (push |
---|
1709 | `(push (defmethod ,function-name ,@(cdr item)) |
---|
1710 | (std-slot-value (fdefinition ',function-name) 'sys::initial-methods)) |
---|
1711 | methods)) |
---|
1712 | (t |
---|
1713 | (push item options)))) |
---|
1714 | (when declarations (push (list :declarations declarations) options)) |
---|
1715 | (setf options (nreverse options) |
---|
1716 | methods (nreverse methods)) |
---|
1717 | ;; Since DEFGENERIC currently shares its argument parsing with |
---|
1718 | ;; DEFMETHOD, we perform this check here. |
---|
1719 | (when (find '&aux lambda-list) |
---|
1720 | (error 'program-error |
---|
1721 | :format-control "&AUX is not allowed in a generic function lambda list: ~S" |
---|
1722 | :format-arguments (list lambda-list))) |
---|
1723 | `(prog1 |
---|
1724 | (%defgeneric |
---|
1725 | ',function-name |
---|
1726 | :lambda-list ',lambda-list |
---|
1727 | ,@(canonicalize-defgeneric-options options)) |
---|
1728 | ,@methods))) |
---|
1729 | |
---|
1730 | (defun canonicalize-defgeneric-options (options) |
---|
1731 | (mapappend #'canonicalize-defgeneric-option options)) |
---|
1732 | |
---|
1733 | (defun canonicalize-defgeneric-option (option) |
---|
1734 | (case (car option) |
---|
1735 | (:generic-function-class |
---|
1736 | (list :generic-function-class `(find-class ',(cadr option)))) |
---|
1737 | (:method-class |
---|
1738 | (list :method-class `(find-class ',(cadr option)))) |
---|
1739 | (:method-combination |
---|
1740 | (list :method-combination `',(cdr option))) |
---|
1741 | (:argument-precedence-order |
---|
1742 | (list :argument-precedence-order `',(cdr option))) |
---|
1743 | (t |
---|
1744 | (list `',(car option) `',(cadr option))))) |
---|
1745 | |
---|
1746 | ;; From OpenMCL (called canonicalize-argument-precedence-order there, |
---|
1747 | ;; but AMOP specifies argument-precedence-order to return a permutation |
---|
1748 | ;; of the required arguments, not a list of indices, so we calculate |
---|
1749 | ;; them on demand). |
---|
1750 | (defun argument-precedence-order-indices (apo req) |
---|
1751 | (cond ((equal apo req) nil) |
---|
1752 | ((not (eql (length apo) (length req))) |
---|
1753 | (error 'program-error |
---|
1754 | :format-control "Specified argument precedence order ~S does not match lambda list." |
---|
1755 | :format-arguments (list apo))) |
---|
1756 | (t (let ((res nil)) |
---|
1757 | (dolist (arg apo (nreverse res)) |
---|
1758 | (let ((index (position arg req))) |
---|
1759 | (if (or (null index) (memq index res)) |
---|
1760 | (error 'program-error |
---|
1761 | :format-control "Specified argument precedence order ~S does not match lambda list." |
---|
1762 | :format-arguments (list apo))) |
---|
1763 | (push index res))))))) |
---|
1764 | |
---|
1765 | (defun find-generic-function (name &optional (errorp t)) |
---|
1766 | (let ((function (and (fboundp name) (fdefinition name)))) |
---|
1767 | (when function |
---|
1768 | (when (typep function 'generic-function) |
---|
1769 | (return-from find-generic-function function)) |
---|
1770 | (when (and *traced-names* (find name *traced-names* :test #'equal)) |
---|
1771 | (setf function (untraced-function name)) |
---|
1772 | (when (typep function 'generic-function) |
---|
1773 | (return-from find-generic-function function))))) |
---|
1774 | (if errorp |
---|
1775 | (error "There is no generic function named ~S." name) |
---|
1776 | nil)) |
---|
1777 | |
---|
1778 | (defun lambda-lists-congruent-p (lambda-list1 lambda-list2) |
---|
1779 | (let* ((plist1 (analyze-lambda-list lambda-list1)) |
---|
1780 | (args1 (getf plist1 :required-args)) |
---|
1781 | (plist2 (analyze-lambda-list lambda-list2)) |
---|
1782 | (args2 (getf plist2 :required-args))) |
---|
1783 | (= (length args1) (length args2)))) |
---|
1784 | |
---|
1785 | (defun %defgeneric (function-name &rest all-keys) |
---|
1786 | (when (fboundp function-name) |
---|
1787 | (let ((gf (fdefinition function-name))) |
---|
1788 | (when (typep gf 'standard-generic-function) |
---|
1789 | ;; Remove methods defined by previous DEFGENERIC forms, as |
---|
1790 | ;; specified by CLHS, 7.7 (Macro DEFGENERIC). KLUDGE: only |
---|
1791 | ;; works for subclasses of standard-generic-function. Since |
---|
1792 | ;; AMOP doesn't specify a reader for initial methods, we have to |
---|
1793 | ;; skip this step otherwise. |
---|
1794 | (dolist (method (std-slot-value gf 'sys::initial-methods)) |
---|
1795 | (std-remove-method gf method) |
---|
1796 | (map-dependents gf |
---|
1797 | #'(lambda (dep) |
---|
1798 | (update-dependent gf dep |
---|
1799 | 'remove-method method)))) |
---|
1800 | (setf (std-slot-value gf 'sys::initial-methods) '())))) |
---|
1801 | (apply 'ensure-generic-function function-name all-keys)) |
---|
1802 | |
---|
1803 | ;;; Bootstrap version of ensure-generic-function, handling only |
---|
1804 | ;;; standard-generic-function. This function is replaced later. |
---|
1805 | (declaim (notinline ensure-generic-function)) |
---|
1806 | (defun ensure-generic-function (function-name |
---|
1807 | &rest all-keys |
---|
1808 | &key |
---|
1809 | (lambda-list nil lambda-list-supplied-p) |
---|
1810 | (generic-function-class +the-standard-generic-function-class+) |
---|
1811 | (method-class +the-standard-method-class+) |
---|
1812 | (method-combination +the-standard-method-combination+ mc-p) |
---|
1813 | argument-precedence-order |
---|
1814 | (documentation nil documentation-supplied-p) |
---|
1815 | &allow-other-keys) |
---|
1816 | (setf all-keys (copy-list all-keys)) ; since we modify it |
---|
1817 | (remf all-keys :generic-function-class) |
---|
1818 | (let ((gf (find-generic-function function-name nil))) |
---|
1819 | (if gf |
---|
1820 | (progn |
---|
1821 | (when lambda-list-supplied-p |
---|
1822 | (unless (or (null (generic-function-methods gf)) |
---|
1823 | (lambda-lists-congruent-p lambda-list |
---|
1824 | (generic-function-lambda-list gf))) |
---|
1825 | (error 'simple-error |
---|
1826 | :format-control "The lambda list ~S is incompatible with the existing methods of ~S." |
---|
1827 | :format-arguments (list lambda-list gf))) |
---|
1828 | (setf (std-slot-value gf 'sys::lambda-list) lambda-list) |
---|
1829 | (let* ((plist (analyze-lambda-list lambda-list)) |
---|
1830 | (required-args (getf plist ':required-args))) |
---|
1831 | (setf (std-slot-value gf 'sys::required-args) required-args) |
---|
1832 | (setf (std-slot-value gf 'sys::optional-args) |
---|
1833 | (getf plist :optional-args)))) |
---|
1834 | (setf (std-slot-value gf 'sys::argument-precedence-order) |
---|
1835 | (or argument-precedence-order (generic-function-required-arguments gf))) |
---|
1836 | (when documentation-supplied-p |
---|
1837 | (setf (std-slot-value gf 'sys::%documentation) documentation)) |
---|
1838 | (finalize-standard-generic-function gf) |
---|
1839 | gf) |
---|
1840 | (progn |
---|
1841 | (when (and (null *clos-booting*) |
---|
1842 | (and (fboundp function-name) |
---|
1843 | ;; since we're overwriting an autoloader, |
---|
1844 | ;; we're probably meant to redefine it, |
---|
1845 | ;; so throwing an error here might be a bad idea. |
---|
1846 | ;; also, resolving the symbol isn't |
---|
1847 | ;; a good option either: we've seen that lead to |
---|
1848 | ;; recursive loading of the same file |
---|
1849 | (and (not (autoloadp function-name)) |
---|
1850 | (and (consp function-name) |
---|
1851 | (eq 'setf (first function-name)) |
---|
1852 | (not (autoload-ref-p (second function-name))))))) |
---|
1853 | (error 'program-error |
---|
1854 | :format-control "~A already names an ordinary function, macro, or special operator." |
---|
1855 | :format-arguments (list function-name))) |
---|
1856 | (when mc-p |
---|
1857 | (error "Preliminary ensure-method does not support :method-combination argument.")) |
---|
1858 | (apply #'make-instance-standard-generic-function |
---|
1859 | generic-function-class |
---|
1860 | :name function-name |
---|
1861 | :method-class method-class |
---|
1862 | :method-combination method-combination |
---|
1863 | all-keys))))) |
---|
1864 | |
---|
1865 | (defun collect-eql-specializer-objects (generic-function) |
---|
1866 | (let ((result nil)) |
---|
1867 | (dolist (method (generic-function-methods generic-function)) |
---|
1868 | (dolist (specializer (method-specializers method)) |
---|
1869 | (when (typep specializer 'eql-specializer) |
---|
1870 | (pushnew (eql-specializer-object specializer) |
---|
1871 | result |
---|
1872 | :test 'eql)))) |
---|
1873 | result)) |
---|
1874 | |
---|
1875 | (defun finalize-standard-generic-function (gf) |
---|
1876 | (%reinit-emf-cache gf (collect-eql-specializer-objects gf)) |
---|
1877 | (set-funcallable-instance-function |
---|
1878 | gf |
---|
1879 | (if (std-generic-function-p gf) |
---|
1880 | (std-compute-discriminating-function gf) |
---|
1881 | (compute-discriminating-function gf))) |
---|
1882 | ;; FIXME Do we need to warn on redefinition somewhere else? |
---|
1883 | (let ((*warn-on-redefinition* nil)) |
---|
1884 | (setf (fdefinition (generic-function-name gf)) gf)) |
---|
1885 | (values)) |
---|
1886 | |
---|
1887 | (defun make-instance-standard-generic-function (generic-function-class |
---|
1888 | &key name lambda-list |
---|
1889 | (method-class +the-standard-method-class+) |
---|
1890 | (method-combination +the-standard-method-combination+) |
---|
1891 | argument-precedence-order |
---|
1892 | declarations |
---|
1893 | documentation) |
---|
1894 | ;; to avoid circularities, we do not call generic functions in here. |
---|
1895 | (declare (ignore generic-function-class)) |
---|
1896 | (check-argument-precedence-order lambda-list argument-precedence-order) |
---|
1897 | (let ((gf (allocate-funcallable-instance +the-standard-generic-function-class+))) |
---|
1898 | (unless (classp method-class) (setf method-class (find-class method-class))) |
---|
1899 | (unless (typep method-combination 'method-combination) |
---|
1900 | (setf method-combination |
---|
1901 | (find-method-combination |
---|
1902 | gf (car method-combination) (cdr method-combination)))) |
---|
1903 | (setf (std-slot-value gf 'sys::name) name) |
---|
1904 | (setf (std-slot-value gf 'sys::lambda-list) lambda-list) |
---|
1905 | (setf (std-slot-value gf 'sys::initial-methods) ()) |
---|
1906 | (setf (std-slot-value gf 'sys::methods) ()) |
---|
1907 | (setf (std-slot-value gf 'sys::method-class) method-class) |
---|
1908 | (setf (std-slot-value gf 'sys::%method-combination) method-combination) |
---|
1909 | (setf (std-slot-value gf 'sys::declarations) declarations) |
---|
1910 | (setf (std-slot-value gf 'sys::%documentation) documentation) |
---|
1911 | (let* ((plist (analyze-lambda-list (generic-function-lambda-list gf))) |
---|
1912 | (required-args (getf plist ':required-args))) |
---|
1913 | (setf (std-slot-value gf 'sys::required-args) required-args) |
---|
1914 | (setf (std-slot-value gf 'sys::optional-args) (getf plist :optional-args)) |
---|
1915 | (setf (std-slot-value gf 'sys::argument-precedence-order) |
---|
1916 | (or argument-precedence-order required-args))) |
---|
1917 | (finalize-standard-generic-function gf) |
---|
1918 | gf)) |
---|
1919 | |
---|
1920 | (defun canonicalize-specializers (specializers) |
---|
1921 | (mapcar #'canonicalize-specializer specializers)) |
---|
1922 | |
---|
1923 | (defun canonicalize-specializer (specializer) |
---|
1924 | (cond ((classp specializer) |
---|
1925 | specializer) |
---|
1926 | ((typep specializer 'eql-specializer) |
---|
1927 | specializer) |
---|
1928 | ((symbolp specializer) |
---|
1929 | (find-class specializer)) |
---|
1930 | ((and (consp specializer) |
---|
1931 | (eq (car specializer) 'eql)) |
---|
1932 | (let ((object (cadr specializer))) |
---|
1933 | (when (and (consp object) |
---|
1934 | (eq (car object) 'quote)) |
---|
1935 | (setf object (cadr object))) |
---|
1936 | (intern-eql-specializer object))) |
---|
1937 | ((and (consp specializer) |
---|
1938 | (eq (car specializer) 'java:jclass)) |
---|
1939 | (let ((jclass (eval specializer))) |
---|
1940 | (java::ensure-java-class jclass))) |
---|
1941 | (t |
---|
1942 | (error "Unknown specializer: ~S" specializer)))) |
---|
1943 | |
---|
1944 | (defun parse-defmethod (args) |
---|
1945 | (let ((function-name (car args)) |
---|
1946 | (qualifiers ()) |
---|
1947 | (specialized-lambda-list ()) |
---|
1948 | (body ()) |
---|
1949 | (parse-state :qualifiers)) |
---|
1950 | (dolist (arg (cdr args)) |
---|
1951 | (ecase parse-state |
---|
1952 | (:qualifiers |
---|
1953 | (if (and (atom arg) (not (null arg))) |
---|
1954 | (push arg qualifiers) |
---|
1955 | (progn |
---|
1956 | (setf specialized-lambda-list arg) |
---|
1957 | (setf parse-state :body)))) |
---|
1958 | (:body (push arg body)))) |
---|
1959 | (setf qualifiers (nreverse qualifiers) |
---|
1960 | body (nreverse body)) |
---|
1961 | (multiple-value-bind (real-body declarations documentation) |
---|
1962 | (parse-body body) |
---|
1963 | (values function-name |
---|
1964 | qualifiers |
---|
1965 | (extract-lambda-list specialized-lambda-list) |
---|
1966 | (extract-specializer-names specialized-lambda-list) |
---|
1967 | documentation |
---|
1968 | declarations |
---|
1969 | (list* 'block |
---|
1970 | (fdefinition-block-name function-name) |
---|
1971 | real-body))))) |
---|
1972 | |
---|
1973 | (defun required-portion (gf args) |
---|
1974 | (let ((number-required (length (generic-function-required-arguments gf)))) |
---|
1975 | (when (< (length args) number-required) |
---|
1976 | (error 'program-error |
---|
1977 | :format-control "Not enough arguments for generic function ~S." |
---|
1978 | :format-arguments (list (generic-function-name gf)))) |
---|
1979 | (subseq args 0 number-required))) |
---|
1980 | |
---|
1981 | (defun extract-lambda-list (specialized-lambda-list) |
---|
1982 | (let* ((plist (analyze-lambda-list specialized-lambda-list)) |
---|
1983 | (requireds (getf plist :required-names)) |
---|
1984 | (rv (getf plist :rest-var)) |
---|
1985 | (ks (getf plist :key-args)) |
---|
1986 | (keysp (getf plist :keysp)) |
---|
1987 | (aok (getf plist :allow-other-keys)) |
---|
1988 | (opts (getf plist :optional-args)) |
---|
1989 | (auxs (getf plist :auxiliary-args))) |
---|
1990 | `(,@requireds |
---|
1991 | ,@(if opts `(&optional ,@opts) ()) |
---|
1992 | ,@(if rv `(&rest ,rv) ()) |
---|
1993 | ,@(if (or ks keysp aok) `(&key ,@ks) ()) |
---|
1994 | ,@(if aok '(&allow-other-keys) ()) |
---|
1995 | ,@(if auxs `(&aux ,@auxs) ())))) |
---|
1996 | |
---|
1997 | (defun extract-specializer-names (specialized-lambda-list) |
---|
1998 | (let ((plist (analyze-lambda-list specialized-lambda-list))) |
---|
1999 | (getf plist ':specializers))) |
---|
2000 | |
---|
2001 | (defun get-keyword-from-arg (arg) |
---|
2002 | (if (listp arg) |
---|
2003 | (if (listp (car arg)) |
---|
2004 | (caar arg) |
---|
2005 | (make-keyword (car arg))) |
---|
2006 | (make-keyword arg))) |
---|
2007 | |
---|
2008 | (defun analyze-lambda-list (lambda-list) |
---|
2009 | (let ((keys ()) ; Just the keywords |
---|
2010 | (key-args ()) ; Keywords argument specs |
---|
2011 | (keysp nil) ; |
---|
2012 | (required-names ()) ; Just the variable names |
---|
2013 | (required-args ()) ; Variable names & specializers |
---|
2014 | (specializers ()) ; Just the specializers |
---|
2015 | (rest-var nil) |
---|
2016 | (optionals ()) |
---|
2017 | (auxs ()) |
---|
2018 | (allow-other-keys nil) |
---|
2019 | (state :required)) |
---|
2020 | (dolist (arg lambda-list) |
---|
2021 | (if (member arg lambda-list-keywords) |
---|
2022 | (ecase arg |
---|
2023 | (&optional |
---|
2024 | (unless (eq state :required) |
---|
2025 | (error 'program-error |
---|
2026 | :format-control "~A followed by &OPTIONAL not allowed ~ |
---|
2027 | in lambda list ~S" |
---|
2028 | :format-arguments (list state lambda-list))) |
---|
2029 | (setq state '&optional)) |
---|
2030 | (&rest |
---|
2031 | (unless (or (eq state :required) |
---|
2032 | (eq state '&optional)) |
---|
2033 | (error 'program-error |
---|
2034 | :format-control "~A followed by &REST not allowed ~ |
---|
2035 | in lambda list ~S" |
---|
2036 | :format-arguments (list state lambda-list))) |
---|
2037 | (setq state '&rest)) |
---|
2038 | (&key |
---|
2039 | (unless (or (eq state :required) |
---|
2040 | (eq state '&optional) |
---|
2041 | (eq state '&rest)) |
---|
2042 | (error 'program-error |
---|
2043 | :format-control "~A followed by &KEY not allowed |
---|
2044 | in lambda list ~S" |
---|
2045 | :format-arguments (list state lambda-list))) |
---|
2046 | (setq keysp t) |
---|
2047 | (setq state '&key)) |
---|
2048 | (&allow-other-keys |
---|
2049 | (unless (eq state '&key) |
---|
2050 | (error 'program-error |
---|
2051 | :format-control "&ALLOW-OTHER-KEYS not allowed while |
---|
2052 | parsing ~A in lambda list ~S" |
---|
2053 | :format-arguments (list state lambda-list))) |
---|
2054 | (setq allow-other-keys 't)) |
---|
2055 | (&aux |
---|
2056 | ;; &aux comes last; any other previous state is fine |
---|
2057 | (setq state '&aux))) |
---|
2058 | (case state |
---|
2059 | (:required |
---|
2060 | (push-on-end arg required-args) |
---|
2061 | (if (listp arg) |
---|
2062 | (progn (push-on-end (car arg) required-names) |
---|
2063 | (push-on-end (cadr arg) specializers)) |
---|
2064 | (progn (push-on-end arg required-names) |
---|
2065 | (push-on-end 't specializers)))) |
---|
2066 | (&optional (push-on-end arg optionals)) |
---|
2067 | (&rest (setq rest-var arg)) |
---|
2068 | (&key |
---|
2069 | (push-on-end (get-keyword-from-arg arg) keys) |
---|
2070 | (push-on-end arg key-args)) |
---|
2071 | (&aux (push-on-end arg auxs))))) |
---|
2072 | (list :required-names required-names |
---|
2073 | :required-args required-args |
---|
2074 | :specializers specializers |
---|
2075 | :rest-var rest-var |
---|
2076 | :keywords keys |
---|
2077 | :key-args key-args |
---|
2078 | :keysp keysp |
---|
2079 | :auxiliary-args auxs |
---|
2080 | :optional-args optionals |
---|
2081 | :allow-other-keys allow-other-keys))) |
---|
2082 | |
---|
2083 | #+nil |
---|
2084 | (defun check-method-arg-info (gf arg-info method) |
---|
2085 | (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) |
---|
2086 | (analyze-lambda-list (if (consp method) |
---|
2087 | (early-method-lambda-list method) |
---|
2088 | (method-lambda-list method))) |
---|
2089 | (flet ((lose (string &rest args) |
---|
2090 | (error 'simple-program-error |
---|
2091 | :format-control "~@<attempt to add the method~2I~_~S~I~_~ |
---|
2092 | to the generic function~2I~_~S;~I~_~ |
---|
2093 | but ~?~:>" |
---|
2094 | :format-arguments (list method gf string args))) |
---|
2095 | (comparison-description (x y) |
---|
2096 | (if (> x y) "more" "fewer"))) |
---|
2097 | (let ((gf-nreq (arg-info-number-required arg-info)) |
---|
2098 | (gf-nopt (arg-info-number-optional arg-info)) |
---|
2099 | (gf-key/rest-p (arg-info-key/rest-p arg-info)) |
---|
2100 | (gf-keywords (arg-info-keys arg-info))) |
---|
2101 | (unless (= nreq gf-nreq) |
---|
2102 | (lose |
---|
2103 | "the method has ~A required arguments than the generic function." |
---|
2104 | (comparison-description nreq gf-nreq))) |
---|
2105 | (unless (= nopt gf-nopt) |
---|
2106 | (lose |
---|
2107 | "the method has ~A optional arguments than the generic function." |
---|
2108 | (comparison-description nopt gf-nopt))) |
---|
2109 | (unless (eq (or keysp restp) gf-key/rest-p) |
---|
2110 | (lose |
---|
2111 | "the method and generic function differ in whether they accept~_~ |
---|
2112 | &REST or &KEY arguments.")) |
---|
2113 | (when (consp gf-keywords) |
---|
2114 | (unless (or (and restp (not keysp)) |
---|
2115 | allow-other-keys-p |
---|
2116 | (every (lambda (k) (memq k keywords)) gf-keywords)) |
---|
2117 | (lose "the method does not accept each of the &KEY arguments~2I~_~ |
---|
2118 | ~S." |
---|
2119 | gf-keywords))))))) |
---|
2120 | |
---|
2121 | (defun check-method-lambda-list (name method-lambda-list gf-lambda-list) |
---|
2122 | (let* ((gf-restp (not (null (memq '&rest gf-lambda-list)))) |
---|
2123 | (gf-plist (analyze-lambda-list gf-lambda-list)) |
---|
2124 | (gf-keysp (getf gf-plist :keysp)) |
---|
2125 | (gf-keywords (getf gf-plist :keywords)) |
---|
2126 | (method-plist (analyze-lambda-list method-lambda-list)) |
---|
2127 | (method-restp (not (null (memq '&rest method-lambda-list)))) |
---|
2128 | (method-keysp (getf method-plist :keysp)) |
---|
2129 | (method-keywords (getf method-plist :keywords)) |
---|
2130 | (method-allow-other-keys-p (getf method-plist :allow-other-keys))) |
---|
2131 | (unless (= (length (getf gf-plist :required-args)) |
---|
2132 | (length (getf method-plist :required-args))) |
---|
2133 | (error "The method-lambda-list ~S ~ |
---|
2134 | has the wrong number of required arguments ~ |
---|
2135 | for the generic function ~S." method-lambda-list name)) |
---|
2136 | (unless (= (length (getf gf-plist :optional-args)) |
---|
2137 | (length (getf method-plist :optional-args))) |
---|
2138 | (error "The method-lambda-list ~S ~ |
---|
2139 | has the wrong number of optional arguments ~ |
---|
2140 | for the generic function ~S." method-lambda-list name)) |
---|
2141 | (unless (eq (or gf-restp gf-keysp) (or method-restp method-keysp)) |
---|
2142 | (error "The method-lambda-list ~S ~ |
---|
2143 | and the generic function ~S ~ |
---|
2144 | differ in whether they accept &REST or &KEY arguments." |
---|
2145 | method-lambda-list name)) |
---|
2146 | (when (consp gf-keywords) |
---|
2147 | (unless (or (and method-restp (not method-keysp)) |
---|
2148 | method-allow-other-keys-p |
---|
2149 | (every (lambda (k) (memq k method-keywords)) gf-keywords)) |
---|
2150 | (error "The method-lambda-list ~S does not accept ~ |
---|
2151 | all of the keyword arguments defined for the ~ |
---|
2152 | generic function." method-lambda-list name))))) |
---|
2153 | |
---|
2154 | (defun check-argument-precedence-order (lambda-list argument-precedence-order) |
---|
2155 | (when argument-precedence-order |
---|
2156 | (if lambda-list |
---|
2157 | ;; raising the required program-errors is a side-effect of |
---|
2158 | ;; calculating the given permutation of apo vs req |
---|
2159 | (argument-precedence-order-indices |
---|
2160 | argument-precedence-order |
---|
2161 | (getf (analyze-lambda-list lambda-list) :required-args)) |
---|
2162 | ;; AMOP pg. 198 |
---|
2163 | (error 'program-error "argument precedence order specified without lambda list")))) |
---|
2164 | |
---|
2165 | (defvar *gf-initialize-instance* nil |
---|
2166 | "Cached value of the INITIALIZE-INSTANCE generic function. |
---|
2167 | Initialized with the true value near the end of the file.") |
---|
2168 | (defvar *gf-allocate-instance* nil |
---|
2169 | "Cached value of the ALLOCATE-INSTANCE generic function. |
---|
2170 | Initialized with the true value near the end of the file.") |
---|
2171 | (defvar *gf-shared-initialize* nil |
---|
2172 | "Cached value of the SHARED-INITIALIZE generic function. |
---|
2173 | Initialized with the true value near the end of the file.") |
---|
2174 | (defvar *gf-reinitialize-instance* nil |
---|
2175 | "Cached value of the REINITIALIZE-INSTANCE generic function. |
---|
2176 | Initialized with the true value near the end of the file.") |
---|
2177 | |
---|
2178 | (declaim (ftype (function * method) ensure-method)) |
---|
2179 | (defun ensure-method (name &rest all-keys) |
---|
2180 | (let ((method-lambda-list (getf all-keys :lambda-list)) |
---|
2181 | (gf (find-generic-function name nil))) |
---|
2182 | (when (or (eq gf *gf-initialize-instance*) |
---|
2183 | (eq gf *gf-allocate-instance*) |
---|
2184 | (eq gf *gf-shared-initialize*) |
---|
2185 | (eq gf *gf-reinitialize-instance*)) |
---|
2186 | ;; ### Clearly, this can be targeted much more exact |
---|
2187 | ;; as we only need to remove the specializing class and all |
---|
2188 | ;; its subclasses from the hash. |
---|
2189 | (clrhash *make-instance-initargs-cache*) |
---|
2190 | (clrhash *reinitialize-instance-initargs-cache*)) |
---|
2191 | (if gf |
---|
2192 | (check-method-lambda-list name method-lambda-list |
---|
2193 | (generic-function-lambda-list gf)) |
---|
2194 | (setf gf (ensure-generic-function name :lambda-list method-lambda-list))) |
---|
2195 | (let ((method |
---|
2196 | (if (eq (generic-function-method-class gf) +the-standard-method-class+) |
---|
2197 | (apply #'make-instance-standard-method gf all-keys) |
---|
2198 | (apply #'make-instance (generic-function-method-class gf) all-keys)))) |
---|
2199 | (if (and |
---|
2200 | (eq (generic-function-method-class gf) +the-standard-method-class+) |
---|
2201 | (std-generic-function-p gf)) |
---|
2202 | (progn |
---|
2203 | (std-add-method gf method) |
---|
2204 | (map-dependents gf |
---|
2205 | #'(lambda (dep) |
---|
2206 | (update-dependent gf dep 'add-method method)))) |
---|
2207 | (add-method gf method)) |
---|
2208 | method))) |
---|
2209 | |
---|
2210 | (defun make-instance-standard-method (gf |
---|
2211 | &key |
---|
2212 | lambda-list |
---|
2213 | qualifiers |
---|
2214 | specializers |
---|
2215 | documentation |
---|
2216 | function |
---|
2217 | fast-function) |
---|
2218 | (declare (ignore gf)) |
---|
2219 | (let ((method (std-allocate-instance +the-standard-method-class+)) |
---|
2220 | (analyzed-args (analyze-lambda-list lambda-list))) |
---|
2221 | (setf (method-lambda-list method) lambda-list) |
---|
2222 | (setf (method-qualifiers method) qualifiers) |
---|
2223 | (setf (std-slot-value method 'sys::specializers) |
---|
2224 | (canonicalize-specializers specializers)) |
---|
2225 | (setf (method-documentation method) documentation) |
---|
2226 | (setf (std-slot-value method 'sys::%generic-function) nil) ; set by add-method |
---|
2227 | (setf (std-slot-value method 'sys::%function) function) |
---|
2228 | (setf (std-slot-value method 'sys::fast-function) fast-function) |
---|
2229 | (setf (std-slot-value method 'sys::keywords) (getf analyzed-args :keywords)) |
---|
2230 | (setf (std-slot-value method 'sys::other-keywords-p) |
---|
2231 | (getf analyzed-args :allow-other-keys)) |
---|
2232 | method)) |
---|
2233 | |
---|
2234 | ;;; To be redefined as generic functions later |
---|
2235 | (declaim (notinline add-direct-method)) |
---|
2236 | (defun add-direct-method (specializer method) |
---|
2237 | (if (typep specializer 'eql-specializer) |
---|
2238 | (pushnew method (std-slot-value specializer 'direct-methods)) |
---|
2239 | (pushnew method (class-direct-methods specializer)))) |
---|
2240 | |
---|
2241 | (declaim (notinline remove-direct-method)) |
---|
2242 | (defun remove-direct-method (specializer method) |
---|
2243 | (if (typep specializer 'eql-specializer) |
---|
2244 | (setf (std-slot-value specializer 'direct-methods) |
---|
2245 | (remove method (std-slot-value specializer 'direct-methods))) |
---|
2246 | (setf (class-direct-methods specializer) |
---|
2247 | (remove method (class-direct-methods specializer))))) |
---|
2248 | |
---|
2249 | (defun std-add-method (gf method) |
---|
2250 | ;; calls sites need to make sure that method is either a method of the |
---|
2251 | ;; given gf or does not have a gf. |
---|
2252 | (let ((old-method (%find-method gf (std-method-qualifiers method) |
---|
2253 | (method-specializers method) nil))) |
---|
2254 | (when old-method |
---|
2255 | (if (and (std-generic-function-p gf) |
---|
2256 | (eq (class-of old-method) +the-standard-method-class+)) |
---|
2257 | (std-remove-method gf old-method) |
---|
2258 | (remove-method gf old-method)))) |
---|
2259 | (setf (std-slot-value method 'sys::%generic-function) gf) |
---|
2260 | (push method (std-slot-value gf 'sys::methods)) |
---|
2261 | (dolist (specializer (method-specializers method)) |
---|
2262 | (add-direct-method specializer method)) |
---|
2263 | (finalize-standard-generic-function gf) |
---|
2264 | gf) |
---|
2265 | |
---|
2266 | (defun std-remove-method (gf method) |
---|
2267 | (setf (std-slot-value gf 'sys::methods) |
---|
2268 | (remove method (generic-function-methods gf))) |
---|
2269 | (setf (std-slot-value method 'sys::%generic-function) nil) |
---|
2270 | (dolist (specializer (method-specializers method)) |
---|
2271 | (remove-direct-method specializer method)) |
---|
2272 | (finalize-standard-generic-function gf) |
---|
2273 | gf) |
---|
2274 | |
---|
2275 | (defun %find-method (gf qualifiers specializers &optional (errorp t)) |
---|
2276 | ;; "If the specializers argument does not correspond in length to the number |
---|
2277 | ;; of required arguments of the generic-function, an an error of type ERROR |
---|
2278 | ;; is signaled." |
---|
2279 | (unless (= (length specializers) (length (generic-function-required-arguments gf))) |
---|
2280 | (error "The specializers argument has length ~S, but ~S has ~S required parameters." |
---|
2281 | (length specializers) |
---|
2282 | gf |
---|
2283 | (length (generic-function-required-arguments gf)))) |
---|
2284 | (let* ((canonical-specializers (canonicalize-specializers specializers)) |
---|
2285 | (method |
---|
2286 | (find-if #'(lambda (method) |
---|
2287 | (and (equal qualifiers |
---|
2288 | (method-qualifiers method)) |
---|
2289 | (equal canonical-specializers |
---|
2290 | (method-specializers method)))) |
---|
2291 | (generic-function-methods gf)))) |
---|
2292 | (if (and (null method) errorp) |
---|
2293 | (error "No such method for ~S." (generic-function-name gf)) |
---|
2294 | method))) |
---|
2295 | |
---|
2296 | (defun fast-callable-p (gf) |
---|
2297 | (and (eq (method-combination-name (generic-function-method-combination gf)) |
---|
2298 | 'standard) |
---|
2299 | (null (intersection (generic-function-lambda-list gf) |
---|
2300 | '(&rest &optional &key &allow-other-keys &aux))))) |
---|
2301 | |
---|
2302 | (defun std-compute-discriminating-function (gf) |
---|
2303 | ;; In this function, we know that gf is of class |
---|
2304 | ;; standard-generic-function, so we can access the instance's slots |
---|
2305 | ;; via std-slot-value. This breaks circularities when redefining |
---|
2306 | ;; generic function accessors. |
---|
2307 | (let ((methods (std-slot-value gf 'sys::methods))) |
---|
2308 | (cond |
---|
2309 | ((and (= (length methods) 1) |
---|
2310 | (eq (type-of (car methods)) 'standard-reader-method) |
---|
2311 | (eq (type-of (car (std-method-specializers (car methods)))) |
---|
2312 | 'standard-class)) |
---|
2313 | (let* ((method (first methods)) |
---|
2314 | (slot-definition (std-slot-value method 'sys::%slot-definition)) |
---|
2315 | (slot-name (std-slot-value slot-definition 'sys:name)) |
---|
2316 | (class (car (std-method-specializers method)))) |
---|
2317 | #'(lambda (instance) |
---|
2318 | ;; TODO: elide this test for low values of SAFETY |
---|
2319 | (unless (typep instance class) |
---|
2320 | (no-applicable-method gf (list instance))) |
---|
2321 | ;; hash table lookup for slot position in Layout object via |
---|
2322 | ;; StandardObject.SLOT_VALUE, so should be reasonably fast |
---|
2323 | (std-slot-value instance slot-name)))) |
---|
2324 | ((and (= (length methods) 1) |
---|
2325 | (eq (type-of (car methods)) 'standard-writer-method) |
---|
2326 | (eq (type-of (second (std-method-specializers (car methods)))) |
---|
2327 | 'standard-class)) |
---|
2328 | (let* ((method (first methods)) |
---|
2329 | (slot-definition (std-slot-value method 'sys::%slot-definition)) |
---|
2330 | (slot-name (std-slot-value slot-definition 'sys:name)) |
---|
2331 | (class (car (std-method-specializers method)))) |
---|
2332 | #'(lambda (new-value instance) |
---|
2333 | ;; TODO: elide this test for low values of SAFETY |
---|
2334 | (unless (typep instance class) |
---|
2335 | (no-applicable-method gf (list new-value instance))) |
---|
2336 | ;; hash table lookup for slot position in Layout object via |
---|
2337 | ;; StandardObject.SET_SLOT_VALUE, so should be reasonably fast |
---|
2338 | (setf (std-slot-value instance slot-name) new-value)))) |
---|
2339 | (t |
---|
2340 | (let* ((number-required (length (generic-function-required-arguments gf))) |
---|
2341 | (lambda-list (generic-function-lambda-list gf)) |
---|
2342 | (exact (null (intersection lambda-list |
---|
2343 | '(&rest &optional &key |
---|
2344 | &allow-other-keys)))) |
---|
2345 | (no-aux (null (some |
---|
2346 | (lambda (method) |
---|
2347 | (find '&aux (std-slot-value method 'sys::lambda-list))) |
---|
2348 | methods)))) |
---|
2349 | (if (and exact |
---|
2350 | no-aux) |
---|
2351 | (cond |
---|
2352 | ((= number-required 1) |
---|
2353 | (cond |
---|
2354 | ((and (eq (method-combination-name |
---|
2355 | (std-slot-value gf 'sys::%method-combination)) |
---|
2356 | 'standard) |
---|
2357 | (= (length methods) 1) |
---|
2358 | (std-method-fast-function (%car methods))) |
---|
2359 | (let* ((method (%car methods)) |
---|
2360 | (specializer (car (std-method-specializers method))) |
---|
2361 | (function (std-method-fast-function method))) |
---|
2362 | (if (typep specializer 'eql-specializer) |
---|
2363 | (let ((specializer-object (eql-specializer-object specializer))) |
---|
2364 | #'(lambda (arg) |
---|
2365 | (declare (optimize speed)) |
---|
2366 | (if (eql arg specializer-object) |
---|
2367 | (funcall function arg) |
---|
2368 | (no-applicable-method gf (list arg))))) |
---|
2369 | #'(lambda (arg) |
---|
2370 | (declare (optimize speed)) |
---|
2371 | (unless (simple-typep arg specializer) |
---|
2372 | ;; FIXME no applicable method |
---|
2373 | (error 'simple-type-error |
---|
2374 | :datum arg |
---|
2375 | :expected-type specializer)) |
---|
2376 | (funcall function arg))))) |
---|
2377 | (t |
---|
2378 | #'(lambda (arg) |
---|
2379 | (declare (optimize speed)) |
---|
2380 | (let* ((args (list arg)) |
---|
2381 | (emfun (get-cached-emf gf args))) |
---|
2382 | (if emfun |
---|
2383 | (funcall emfun args) |
---|
2384 | (slow-method-lookup gf args))))))) |
---|
2385 | ((= number-required 2) |
---|
2386 | #'(lambda (arg1 arg2) |
---|
2387 | (declare (optimize speed)) |
---|
2388 | (let* ((args (list arg1 arg2)) |
---|
2389 | (emfun (get-cached-emf gf args))) |
---|
2390 | (if emfun |
---|
2391 | (funcall emfun args) |
---|
2392 | (slow-method-lookup gf args))))) |
---|
2393 | ((= number-required 3) |
---|
2394 | #'(lambda (arg1 arg2 arg3) |
---|
2395 | (declare (optimize speed)) |
---|
2396 | (let* ((args (list arg1 arg2 arg3)) |
---|
2397 | (emfun (get-cached-emf gf args))) |
---|
2398 | (if emfun |
---|
2399 | (funcall emfun args) |
---|
2400 | (slow-method-lookup gf args))))) |
---|
2401 | (t |
---|
2402 | #'(lambda (&rest args) |
---|
2403 | (declare (optimize speed)) |
---|
2404 | (let ((len (length args))) |
---|
2405 | (unless (= len number-required) |
---|
2406 | (error 'program-error |
---|
2407 | :format-control "Not enough arguments for generic function ~S." |
---|
2408 | :format-arguments (list (generic-function-name gf))))) |
---|
2409 | (let ((emfun (get-cached-emf gf args))) |
---|
2410 | (if emfun |
---|
2411 | (funcall emfun args) |
---|
2412 | (slow-method-lookup gf args)))))) |
---|
2413 | #'(lambda (&rest args) |
---|
2414 | (declare (optimize speed)) |
---|
2415 | (let ((len (length args))) |
---|
2416 | (unless (>= len number-required) |
---|
2417 | (error 'program-error |
---|
2418 | :format-control "Not enough arguments for generic function ~S." |
---|
2419 | :format-arguments (list (generic-function-name gf))))) |
---|
2420 | (let ((emfun (get-cached-emf gf args))) |
---|
2421 | (if emfun |
---|
2422 | (funcall emfun args) |
---|
2423 | (slow-method-lookup gf args)))))))))) |
---|
2424 | |
---|
2425 | (defun sort-methods (methods gf required-classes) |
---|
2426 | (if (or (null methods) (null (%cdr methods))) |
---|
2427 | methods |
---|
2428 | (sort methods |
---|
2429 | (if (std-generic-function-p gf) |
---|
2430 | (let ((method-indices |
---|
2431 | (argument-precedence-order-indices |
---|
2432 | (generic-function-argument-precedence-order gf) |
---|
2433 | (getf (analyze-lambda-list (generic-function-lambda-list gf)) |
---|
2434 | ':required-args)))) |
---|
2435 | #'(lambda (m1 m2) |
---|
2436 | (std-method-more-specific-p |
---|
2437 | m1 m2 required-classes method-indices))) |
---|
2438 | #'(lambda (m1 m2) |
---|
2439 | (method-more-specific-p gf m1 m2 required-classes)))))) |
---|
2440 | |
---|
2441 | (defun method-applicable-p (method args) |
---|
2442 | (do* ((specializers (method-specializers method) (cdr specializers)) |
---|
2443 | (args args (cdr args))) |
---|
2444 | ((null specializers) t) |
---|
2445 | (let ((specializer (car specializers))) |
---|
2446 | (if (typep specializer 'eql-specializer) |
---|
2447 | (unless (eql (car args) (eql-specializer-object specializer)) |
---|
2448 | (return nil)) |
---|
2449 | (unless (subclassp (class-of (car args)) specializer) |
---|
2450 | (return nil)))))) |
---|
2451 | |
---|
2452 | (defun std-compute-applicable-methods (gf args) |
---|
2453 | (let ((required-classes (mapcar #'class-of (required-portion gf args))) |
---|
2454 | (methods '())) |
---|
2455 | (dolist (method (generic-function-methods gf)) |
---|
2456 | (when (method-applicable-p method args) |
---|
2457 | (push method methods))) |
---|
2458 | (sort-methods methods gf required-classes))) |
---|
2459 | |
---|
2460 | (declaim (notinline compute-applicable-methods)) |
---|
2461 | (defun compute-applicable-methods (gf args) |
---|
2462 | (std-compute-applicable-methods gf args)) |
---|
2463 | |
---|
2464 | ;;; METHOD-APPLICABLE-USING-CLASSES-P |
---|
2465 | ;;; |
---|
2466 | ;;; If the first return value is T, METHOD is definitely applicable to |
---|
2467 | ;;; arguments that are instances of CLASSES. If the first value is |
---|
2468 | ;;; NIL and the second value is T, METHOD is definitely not applicable |
---|
2469 | ;;; to arguments that are instances of CLASSES; if the second value is |
---|
2470 | ;;; NIL the applicability of METHOD cannot be determined by inspecting |
---|
2471 | ;;; the classes of its arguments only. |
---|
2472 | ;;; |
---|
2473 | (defun method-applicable-using-classes-p (method classes) |
---|
2474 | (do* ((specializers (method-specializers method) (cdr specializers)) |
---|
2475 | (classes classes (cdr classes)) |
---|
2476 | (knownp t)) |
---|
2477 | ((null specializers) |
---|
2478 | (if knownp (values t t) (values nil nil))) |
---|
2479 | (let ((specializer (car specializers))) |
---|
2480 | (if (typep specializer 'eql-specializer) |
---|
2481 | (if (eql (class-of (eql-specializer-object specializer)) |
---|
2482 | (car classes)) |
---|
2483 | (setf knownp nil) |
---|
2484 | (return (values nil t))) |
---|
2485 | (unless (subclassp (car classes) specializer) |
---|
2486 | (return (values nil t))))))) |
---|
2487 | |
---|
2488 | (defun check-applicable-method-keyword-args (gf args |
---|
2489 | keyword-args |
---|
2490 | applicable-keywords) |
---|
2491 | (when (oddp (length keyword-args)) |
---|
2492 | (error 'program-error |
---|
2493 | :format-control "Odd number of keyword arguments in call to ~S ~ |
---|
2494 | with arguments list ~S" |
---|
2495 | :format-arguments (list gf args))) |
---|
2496 | (unless (getf keyword-args :allow-other-keys) |
---|
2497 | (loop for key in keyword-args by #'cddr |
---|
2498 | unless (or (member key applicable-keywords) |
---|
2499 | (eq key :allow-other-keys)) |
---|
2500 | do (error 'program-error |
---|
2501 | :format-control "Invalid keyword argument ~S in call ~ |
---|
2502 | to ~S with argument list ~S." |
---|
2503 | :format-arguments (list key gf args))))) |
---|
2504 | |
---|
2505 | (defun compute-applicable-keywords (gf applicable-methods) |
---|
2506 | (let ((applicable-keywords |
---|
2507 | (getf (analyze-lambda-list (generic-function-lambda-list gf)) |
---|
2508 | :keywords))) |
---|
2509 | (loop for method in applicable-methods |
---|
2510 | do (multiple-value-bind |
---|
2511 | (keywords allow-other-keys) |
---|
2512 | (function-keywords method) |
---|
2513 | (when allow-other-keys |
---|
2514 | (setf applicable-keywords :any) |
---|
2515 | (return)) |
---|
2516 | (setf applicable-keywords |
---|
2517 | (union applicable-keywords keywords)))) |
---|
2518 | applicable-keywords)) |
---|
2519 | |
---|
2520 | (defun wrap-emfun-for-keyword-args-check (gf emfun non-keyword-args |
---|
2521 | applicable-keywords) |
---|
2522 | #'(lambda (args) |
---|
2523 | (check-applicable-method-keyword-args |
---|
2524 | gf args |
---|
2525 | (nthcdr non-keyword-args args) applicable-keywords) |
---|
2526 | (funcall emfun args))) |
---|
2527 | |
---|
2528 | (defun slow-method-lookup (gf args) |
---|
2529 | (let ((applicable-methods |
---|
2530 | (if (std-generic-function-p gf) |
---|
2531 | (std-compute-applicable-methods gf args) |
---|
2532 | (or (compute-applicable-methods-using-classes gf (mapcar #'class-of args)) |
---|
2533 | (compute-applicable-methods gf args))))) |
---|
2534 | (if applicable-methods |
---|
2535 | (let* ((emfun (funcall (if (std-generic-function-p gf) |
---|
2536 | #'std-compute-effective-method |
---|
2537 | #'compute-effective-method) |
---|
2538 | gf (generic-function-method-combination gf) |
---|
2539 | applicable-methods)) |
---|
2540 | (non-keyword-args (+ (length (generic-function-required-arguments gf)) |
---|
2541 | (length (generic-function-optional-arguments gf)))) |
---|
2542 | (gf-lambda-list (generic-function-lambda-list gf)) |
---|
2543 | (checks-required (and (member '&key gf-lambda-list) |
---|
2544 | (not (member '&allow-other-keys |
---|
2545 | gf-lambda-list)))) |
---|
2546 | (applicable-keywords |
---|
2547 | (when checks-required |
---|
2548 | ;; Don't do applicable keyword checks when this is |
---|
2549 | ;; one of the 'exceptional four' or when the gf allows |
---|
2550 | ;; other keywords. |
---|
2551 | (compute-applicable-keywords gf applicable-methods)))) |
---|
2552 | (when (and checks-required |
---|
2553 | (not (eq applicable-keywords :any))) |
---|
2554 | (setf emfun |
---|
2555 | (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args |
---|
2556 | applicable-keywords))) |
---|
2557 | (cache-emf gf args emfun) |
---|
2558 | (funcall emfun args)) |
---|
2559 | (apply #'no-applicable-method gf args)))) |
---|
2560 | |
---|
2561 | (defun sub-specializer-p (c1 c2 c-arg) |
---|
2562 | (find c2 (cdr (memq c1 (%class-precedence-list c-arg))))) |
---|
2563 | |
---|
2564 | (defun std-method-more-specific-p (method1 method2 required-classes argument-precedence-order) |
---|
2565 | (if argument-precedence-order |
---|
2566 | (let ((specializers-1 (std-method-specializers method1)) |
---|
2567 | (specializers-2 (std-method-specializers method2))) |
---|
2568 | (dolist (index argument-precedence-order) |
---|
2569 | (let ((spec1 (nth index specializers-1)) |
---|
2570 | (spec2 (nth index specializers-2))) |
---|
2571 | (unless (eq spec1 spec2) |
---|
2572 | (cond ((typep spec1 'eql-specializer) |
---|
2573 | (return t)) |
---|
2574 | ((typep spec2 'eql-specializer) |
---|
2575 | (return nil)) |
---|
2576 | (t |
---|
2577 | (return (sub-specializer-p spec1 spec2 |
---|
2578 | (nth index required-classes))))))))) |
---|
2579 | (do ((specializers-1 (std-method-specializers method1) (cdr specializers-1)) |
---|
2580 | (specializers-2 (std-method-specializers method2) (cdr specializers-2)) |
---|
2581 | (classes required-classes (cdr classes))) |
---|
2582 | ((null specializers-1) nil) |
---|
2583 | (let ((spec1 (car specializers-1)) |
---|
2584 | (spec2 (car specializers-2))) |
---|
2585 | (unless (eq spec1 spec2) |
---|
2586 | (cond ((typep spec1 'eql-specializer) |
---|
2587 | (return t)) |
---|
2588 | ((typep spec2 'eql-specializer) |
---|
2589 | (return nil)) |
---|
2590 | (t |
---|
2591 | (return (sub-specializer-p spec1 spec2 (car classes)))))))))) |
---|
2592 | |
---|
2593 | (defun primary-method-p (method) |
---|
2594 | (null (intersection '(:before :after :around) (method-qualifiers method)))) |
---|
2595 | |
---|
2596 | (defun before-method-p (method) |
---|
2597 | (equal '(:before) (method-qualifiers method))) |
---|
2598 | |
---|
2599 | (defun after-method-p (method) |
---|
2600 | (equal '(:after) (method-qualifiers method))) |
---|
2601 | |
---|
2602 | (defun around-method-p (method) |
---|
2603 | (equal '(:around) (method-qualifiers method))) |
---|
2604 | |
---|
2605 | (defun process-next-method-list (next-method-list) |
---|
2606 | (mapcar #'(lambda (next-method-form) |
---|
2607 | (cond |
---|
2608 | ((listp next-method-form) |
---|
2609 | (assert (eq (first next-method-form) 'make-method)) |
---|
2610 | (let* ((rest-sym (gensym))) |
---|
2611 | (make-instance-standard-method |
---|
2612 | nil ;; ignored |
---|
2613 | :lambda-list (list '&rest rest-sym) |
---|
2614 | :function (compute-method-function `(lambda (&rest ,rest-sym) |
---|
2615 | ,(second next-method-form)))))) |
---|
2616 | (t |
---|
2617 | (assert (typep next-method-form 'method)) |
---|
2618 | next-method-form))) |
---|
2619 | next-method-list)) |
---|
2620 | |
---|
2621 | (defun std-compute-effective-method (gf method-combination methods) |
---|
2622 | (assert (typep method-combination 'method-combination)) |
---|
2623 | (let* ((mc-name (method-combination-name method-combination)) |
---|
2624 | (options (slot-value method-combination 'options)) |
---|
2625 | (order (car options)) |
---|
2626 | (primaries '()) |
---|
2627 | (arounds '()) |
---|
2628 | around |
---|
2629 | emf-form |
---|
2630 | (long-method-combination-p |
---|
2631 | (typep method-combination 'long-method-combination))) |
---|
2632 | (unless long-method-combination-p |
---|
2633 | (dolist (m methods) |
---|
2634 | (let ((qualifiers (method-qualifiers m))) |
---|
2635 | (cond ((null qualifiers) |
---|
2636 | (if (eq mc-name 'standard) |
---|
2637 | (push m primaries) |
---|
2638 | (error "Method combination type mismatch: missing qualifier for method combination ~S." method-combination))) |
---|
2639 | ((cdr qualifiers) |
---|
2640 | (error "Invalid method qualifiers.")) |
---|
2641 | ((eq (car qualifiers) :around) |
---|
2642 | (push m arounds)) |
---|
2643 | ((eq (car qualifiers) mc-name) |
---|
2644 | (push m primaries)) |
---|
2645 | ((memq (car qualifiers) '(:before :after))) |
---|
2646 | (t |
---|
2647 | (error "Invalid method qualifiers.")))))) |
---|
2648 | (unless (eq order :most-specific-last) |
---|
2649 | (setf primaries (nreverse primaries))) |
---|
2650 | (setf arounds (nreverse arounds)) |
---|
2651 | (setf around (car arounds)) |
---|
2652 | (when (and (null primaries) (not long-method-combination-p)) |
---|
2653 | (error "No primary methods for the generic function ~S." gf)) |
---|
2654 | (cond |
---|
2655 | (around |
---|
2656 | (let ((next-emfun |
---|
2657 | (funcall |
---|
2658 | (if (std-generic-function-p gf) |
---|
2659 | #'std-compute-effective-method |
---|
2660 | #'compute-effective-method) |
---|
2661 | gf method-combination (remove around methods)))) |
---|
2662 | (setf emf-form |
---|
2663 | (generate-emf-lambda (method-function around) next-emfun)))) |
---|
2664 | ((eq mc-name 'standard) |
---|
2665 | (let* ((next-emfun (compute-primary-emfun (cdr primaries))) |
---|
2666 | (befores (remove-if-not #'before-method-p methods)) |
---|
2667 | (reverse-afters |
---|
2668 | (reverse (remove-if-not #'after-method-p methods)))) |
---|
2669 | (setf emf-form |
---|
2670 | (cond |
---|
2671 | ((and (null befores) (null reverse-afters)) |
---|
2672 | (let ((fast-function (std-method-fast-function (car primaries)))) |
---|
2673 | (if fast-function |
---|
2674 | (ecase (length (generic-function-required-arguments gf)) |
---|
2675 | (1 |
---|
2676 | #'(lambda (args) |
---|
2677 | (declare (optimize speed)) |
---|
2678 | (funcall fast-function (car args)))) |
---|
2679 | (2 |
---|
2680 | #'(lambda (args) |
---|
2681 | (declare (optimize speed)) |
---|
2682 | (funcall fast-function (car args) (cadr args))))) |
---|
2683 | (generate-emf-lambda (std-method-function (car primaries)) |
---|
2684 | next-emfun)))) |
---|
2685 | (t |
---|
2686 | (let ((method-function (method-function (car primaries)))) |
---|
2687 | #'(lambda (args) |
---|
2688 | (declare (optimize speed)) |
---|
2689 | (dolist (before befores) |
---|
2690 | (funcall (method-function before) args nil)) |
---|
2691 | (multiple-value-prog1 |
---|
2692 | (funcall method-function args next-emfun) |
---|
2693 | (dolist (after reverse-afters) |
---|
2694 | (funcall (method-function after) args nil)))))))))) |
---|
2695 | (long-method-combination-p |
---|
2696 | (let ((function (long-method-combination-function method-combination)) |
---|
2697 | (arguments (slot-value method-combination 'options))) |
---|
2698 | (assert function) |
---|
2699 | (setf emf-form |
---|
2700 | (if arguments |
---|
2701 | (apply function gf methods arguments) |
---|
2702 | (funcall function gf methods))))) |
---|
2703 | (t |
---|
2704 | (unless (typep method-combination 'short-method-combination) |
---|
2705 | (error "Unsupported method combination type ~A." mc-name)) |
---|
2706 | (let ((operator (short-method-combination-operator method-combination)) |
---|
2707 | (ioa (short-method-combination-identity-with-one-argument method-combination))) |
---|
2708 | (setf emf-form |
---|
2709 | (if (and ioa (null (cdr primaries))) |
---|
2710 | (generate-emf-lambda (method-function (car primaries)) nil) |
---|
2711 | `(lambda (args) |
---|
2712 | (,operator ,@(mapcar |
---|
2713 | (lambda (primary) |
---|
2714 | `(funcall ,(method-function primary) args nil)) |
---|
2715 | primaries)))))))) |
---|
2716 | (assert (not (null emf-form))) |
---|
2717 | (or #+nil (ignore-errors (autocompile emf-form)) |
---|
2718 | (coerce-to-function emf-form)))) |
---|
2719 | |
---|
2720 | (defun generate-emf-lambda (method-function next-emfun) |
---|
2721 | #'(lambda (args) |
---|
2722 | (declare (optimize speed)) |
---|
2723 | (funcall method-function args next-emfun))) |
---|
2724 | |
---|
2725 | ;;; compute an effective method function from a list of primary methods: |
---|
2726 | |
---|
2727 | (defun compute-primary-emfun (methods) |
---|
2728 | (if (null methods) |
---|
2729 | nil |
---|
2730 | (let ((next-emfun (compute-primary-emfun (cdr methods)))) |
---|
2731 | #'(lambda (args) |
---|
2732 | (funcall (std-method-function (car methods)) args next-emfun))))) |
---|
2733 | |
---|
2734 | (defvar *call-next-method-p*) |
---|
2735 | (defvar *next-method-p-p*) |
---|
2736 | |
---|
2737 | (defun walk-form (form) |
---|
2738 | (cond ((atom form) |
---|
2739 | (cond ((eq form 'call-next-method) |
---|
2740 | (setf *call-next-method-p* t)) |
---|
2741 | ((eq form 'next-method-p) |
---|
2742 | (setf *next-method-p-p* t)))) |
---|
2743 | (t |
---|
2744 | (walk-form (%car form)) |
---|
2745 | (walk-form (%cdr form))))) |
---|
2746 | |
---|
2747 | (defun compute-method-function (lambda-expression) |
---|
2748 | (let ((lambda-list (allow-other-keys (cadr lambda-expression))) |
---|
2749 | (body (cddr lambda-expression)) |
---|
2750 | (*call-next-method-p* nil) |
---|
2751 | (*next-method-p-p* nil)) |
---|
2752 | (multiple-value-bind (body declarations) (parse-body body) |
---|
2753 | (let ((ignorable-vars '())) |
---|
2754 | (dolist (var lambda-list) |
---|
2755 | (if (memq var lambda-list-keywords) |
---|
2756 | (return) |
---|
2757 | (push var ignorable-vars))) |
---|
2758 | (push `(declare (ignorable ,@ignorable-vars)) declarations)) |
---|
2759 | (walk-form body) |
---|
2760 | (cond ((or *call-next-method-p* *next-method-p-p*) |
---|
2761 | `(lambda (args next-emfun) |
---|
2762 | (flet ((call-next-method (&rest cnm-args) |
---|
2763 | (if (null next-emfun) |
---|
2764 | (error "No next method for generic function.") |
---|
2765 | (funcall next-emfun (or cnm-args args)))) |
---|
2766 | (next-method-p () |
---|
2767 | (not (null next-emfun)))) |
---|
2768 | (declare (ignorable (function call-next-method) |
---|
2769 | (function next-method-p))) |
---|
2770 | (apply #'(lambda ,lambda-list ,@declarations ,@body) args)))) |
---|
2771 | ((null (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux))) |
---|
2772 | ;; Required parameters only. |
---|
2773 | (case (length lambda-list) |
---|
2774 | (1 |
---|
2775 | `(lambda (args next-emfun) |
---|
2776 | (declare (ignore next-emfun)) |
---|
2777 | (let ((,(%car lambda-list) (%car args))) |
---|
2778 | (declare (ignorable ,(%car lambda-list))) |
---|
2779 | ,@declarations ,@body))) |
---|
2780 | (2 |
---|
2781 | `(lambda (args next-emfun) |
---|
2782 | (declare (ignore next-emfun)) |
---|
2783 | (let ((,(%car lambda-list) (%car args)) |
---|
2784 | (,(%cadr lambda-list) (%cadr args))) |
---|
2785 | (declare (ignorable ,(%car lambda-list) |
---|
2786 | ,(%cadr lambda-list))) |
---|
2787 | ,@declarations ,@body))) |
---|
2788 | (3 |
---|
2789 | `(lambda (args next-emfun) |
---|
2790 | (declare (ignore next-emfun)) |
---|
2791 | (let ((,(%car lambda-list) (%car args)) |
---|
2792 | (,(%cadr lambda-list) (%cadr args)) |
---|
2793 | (,(%caddr lambda-list) (%caddr args))) |
---|
2794 | (declare (ignorable ,(%car lambda-list) |
---|
2795 | ,(%cadr lambda-list) |
---|
2796 | ,(%caddr lambda-list))) |
---|
2797 | ,@declarations ,@body))) |
---|
2798 | (t |
---|
2799 | `(lambda (args next-emfun) |
---|
2800 | (declare (ignore next-emfun)) |
---|
2801 | (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))) |
---|
2802 | (t |
---|
2803 | `(lambda (args next-emfun) |
---|
2804 | (declare (ignore next-emfun)) |
---|
2805 | (apply #'(lambda ,lambda-list ,@declarations ,@body) args))))))) |
---|
2806 | |
---|
2807 | (defun compute-method-fast-function (lambda-expression) |
---|
2808 | (let ((lambda-list (allow-other-keys (cadr lambda-expression)))) |
---|
2809 | (when (intersection lambda-list '(&rest &optional &key &allow-other-keys &aux)) |
---|
2810 | (return-from compute-method-fast-function nil)) |
---|
2811 | ;; Only required args. |
---|
2812 | (let ((body (cddr lambda-expression)) |
---|
2813 | (*call-next-method-p* nil) |
---|
2814 | (*next-method-p-p* nil)) |
---|
2815 | (multiple-value-bind (body declarations) (parse-body body) |
---|
2816 | (walk-form body) |
---|
2817 | (when (or *call-next-method-p* *next-method-p-p*) |
---|
2818 | (return-from compute-method-fast-function nil)) |
---|
2819 | (let ((decls `(declare (ignorable ,@lambda-list)))) |
---|
2820 | (setf lambda-expression |
---|
2821 | (list* (car lambda-expression) |
---|
2822 | (cadr lambda-expression) |
---|
2823 | decls |
---|
2824 | (cddr lambda-expression)))) |
---|
2825 | (case (length lambda-list) |
---|
2826 | (1 |
---|
2827 | ;; `(lambda (args next-emfun) |
---|
2828 | ;; (let ((,(%car lambda-list) (%car args))) |
---|
2829 | ;; (declare (ignorable ,(%car lambda-list))) |
---|
2830 | ;; ,@declarations ,@body))) |
---|
2831 | lambda-expression) |
---|
2832 | (2 |
---|
2833 | ;; `(lambda (args next-emfun) |
---|
2834 | ;; (let ((,(%car lambda-list) (%car args)) |
---|
2835 | ;; (,(%cadr lambda-list) (%cadr args))) |
---|
2836 | ;; (declare (ignorable ,(%car lambda-list) |
---|
2837 | ;; ,(%cadr lambda-list))) |
---|
2838 | ;; ,@declarations ,@body))) |
---|
2839 | lambda-expression) |
---|
2840 | ;; (3 |
---|
2841 | ;; `(lambda (args next-emfun) |
---|
2842 | ;; (let ((,(%car lambda-list) (%car args)) |
---|
2843 | ;; (,(%cadr lambda-list) (%cadr args)) |
---|
2844 | ;; (,(%caddr lambda-list) (%caddr args))) |
---|
2845 | ;; (declare (ignorable ,(%car lambda-list) |
---|
2846 | ;; ,(%cadr lambda-list) |
---|
2847 | ;; ,(%caddr lambda-list))) |
---|
2848 | ;; ,@declarations ,@body))) |
---|
2849 | (t |
---|
2850 | nil)))))) |
---|
2851 | |
---|
2852 | (declaim (notinline make-method-lambda)) |
---|
2853 | (defun make-method-lambda (generic-function method lambda-expression env) |
---|
2854 | (declare (ignore generic-function method env)) |
---|
2855 | (values (compute-method-function lambda-expression) nil)) |
---|
2856 | |
---|
2857 | |
---|
2858 | ;; From CLHS section 7.6.5: |
---|
2859 | ;; "When a generic function or any of its methods mentions &key in a lambda |
---|
2860 | ;; list, the specific set of keyword arguments accepted by the generic function |
---|
2861 | ;; varies according to the applicable methods. The set of keyword arguments |
---|
2862 | ;; accepted by the generic function for a particular call is the union of the |
---|
2863 | ;; keyword arguments accepted by all applicable methods and the keyword |
---|
2864 | ;; arguments mentioned after &key in the generic function definition, if any." |
---|
2865 | ;; Adapted from Sacla. |
---|
2866 | (defun allow-other-keys (lambda-list) |
---|
2867 | (if (and (member '&key lambda-list) |
---|
2868 | (not (member '&allow-other-keys lambda-list))) |
---|
2869 | (let* ((key-end (or (position '&aux lambda-list) (length lambda-list))) |
---|
2870 | (aux-part (subseq lambda-list key-end))) |
---|
2871 | `(,@(subseq lambda-list 0 key-end) &allow-other-keys ,@aux-part)) |
---|
2872 | lambda-list)) |
---|
2873 | |
---|
2874 | (defmacro defmethod (&rest args &environment env) |
---|
2875 | (multiple-value-bind |
---|
2876 | (function-name qualifiers lambda-list specializers documentation declarations body) |
---|
2877 | (parse-defmethod args) |
---|
2878 | (let* ((specializers-form '()) |
---|
2879 | (lambda-expression `(lambda ,lambda-list ,@declarations ,body)) |
---|
2880 | (gf (or (find-generic-function function-name nil) |
---|
2881 | (class-prototype (find-class 'standard-generic-function)))) |
---|
2882 | (method-function |
---|
2883 | (make-method-lambda gf (class-prototype (generic-function-method-class gf)) |
---|
2884 | lambda-expression env)) |
---|
2885 | (fast-function (compute-method-fast-function lambda-expression)) |
---|
2886 | ) |
---|
2887 | (dolist (specializer specializers) |
---|
2888 | (cond ((and (consp specializer) (eq (car specializer) 'eql)) |
---|
2889 | (push `(list 'eql ,(cadr specializer)) specializers-form)) |
---|
2890 | (t |
---|
2891 | (push `',specializer specializers-form)))) |
---|
2892 | (setf specializers-form `(list ,@(nreverse specializers-form))) |
---|
2893 | `(progn |
---|
2894 | (ensure-method ',function-name |
---|
2895 | :lambda-list ',lambda-list |
---|
2896 | :qualifiers ',qualifiers |
---|
2897 | :specializers (canonicalize-specializers ,specializers-form) |
---|
2898 | ,@(if documentation `(:documentation ,documentation)) |
---|
2899 | :function (function ,method-function) |
---|
2900 | ,@(if fast-function `(:fast-function (function ,fast-function))) |
---|
2901 | ))))) |
---|
2902 | |
---|
2903 | ;;; Reader and writer methods |
---|
2904 | |
---|
2905 | (defun make-instance-standard-accessor-method (method-class |
---|
2906 | &key |
---|
2907 | lambda-list |
---|
2908 | qualifiers |
---|
2909 | specializers |
---|
2910 | documentation |
---|
2911 | function |
---|
2912 | fast-function |
---|
2913 | slot-definition) |
---|
2914 | (let ((method (std-allocate-instance method-class))) |
---|
2915 | (setf (method-lambda-list method) lambda-list) |
---|
2916 | (setf (method-qualifiers method) qualifiers) |
---|
2917 | (setf (std-slot-value method 'sys::specializers) |
---|
2918 | (canonicalize-specializers specializers)) |
---|
2919 | (setf (method-documentation method) documentation) |
---|
2920 | (setf (std-slot-value method 'sys::%generic-function) nil) |
---|
2921 | (setf (std-slot-value method 'sys::%function) function) |
---|
2922 | (setf (std-slot-value method 'sys::fast-function) fast-function) |
---|
2923 | (setf (std-slot-value method 'sys::%slot-definition) slot-definition) |
---|
2924 | (setf (std-slot-value method 'sys::keywords) nil) |
---|
2925 | (setf (std-slot-value method 'sys::other-keywords-p) nil) |
---|
2926 | method)) |
---|
2927 | |
---|
2928 | (defun add-reader-method (class function-name slot-definition) |
---|
2929 | (let* ((slot-name (slot-definition-name slot-definition)) |
---|
2930 | (lambda-expression |
---|
2931 | (if (std-class-p class) |
---|
2932 | `(lambda (object) (std-slot-value object ',slot-name)) |
---|
2933 | `(lambda (object) (slot-value object ',slot-name)))) |
---|
2934 | (method-function (compute-method-function lambda-expression)) |
---|
2935 | (fast-function (compute-method-fast-function lambda-expression)) |
---|
2936 | (method-lambda-list '(object)) |
---|
2937 | (gf (find-generic-function function-name nil)) |
---|
2938 | (initargs `(:lambda-list ,method-lambda-list |
---|
2939 | :qualifiers () |
---|
2940 | :specializers (,class) |
---|
2941 | :function ,(if (autoloadp 'compile) |
---|
2942 | method-function |
---|
2943 | (autocompile method-function)) |
---|
2944 | :fast-function ,(if (autoloadp 'compile) |
---|
2945 | fast-function |
---|
2946 | (autocompile fast-function)) |
---|
2947 | :slot-definition ,slot-definition)) |
---|
2948 | (method-class (if (std-class-p class) |
---|
2949 | +the-standard-reader-method-class+ |
---|
2950 | (apply #'reader-method-class class slot-definition |
---|
2951 | initargs)))) |
---|
2952 | ;; required by AMOP pg. 225 |
---|
2953 | (assert (subtypep method-class +the-standard-reader-method-class+)) |
---|
2954 | (if gf |
---|
2955 | (check-method-lambda-list function-name |
---|
2956 | method-lambda-list |
---|
2957 | (generic-function-lambda-list gf)) |
---|
2958 | (setf gf (ensure-generic-function function-name |
---|
2959 | :lambda-list method-lambda-list))) |
---|
2960 | (let ((method |
---|
2961 | (if (eq method-class +the-standard-reader-method-class+) |
---|
2962 | (apply #'make-instance-standard-accessor-method method-class |
---|
2963 | initargs) |
---|
2964 | (apply #'make-instance method-class |
---|
2965 | :generic-function nil ; handled by add-method |
---|
2966 | initargs)))) |
---|
2967 | (if (std-generic-function-p gf) |
---|
2968 | (progn |
---|
2969 | (std-add-method gf method) |
---|
2970 | (map-dependents gf |
---|
2971 | #'(lambda (dep) |
---|
2972 | (update-dependent gf dep 'add-method method)))) |
---|
2973 | (add-method gf method)) |
---|
2974 | method))) |
---|
2975 | |
---|
2976 | (defun add-writer-method (class function-name slot-definition) |
---|
2977 | (let* ((slot-name (slot-definition-name slot-definition)) |
---|
2978 | (lambda-expression |
---|
2979 | (if (std-class-p class) |
---|
2980 | `(lambda (new-value object) |
---|
2981 | (setf (std-slot-value object ',slot-name) new-value)) |
---|
2982 | `(lambda (new-value object) |
---|
2983 | (setf (slot-value object ',slot-name) new-value)))) |
---|
2984 | (method-function (compute-method-function lambda-expression)) |
---|
2985 | (fast-function (compute-method-fast-function lambda-expression)) |
---|
2986 | (method-lambda-list '(new-value object)) |
---|
2987 | (gf (find-generic-function function-name nil)) |
---|
2988 | (initargs `(:lambda-list ,method-lambda-list |
---|
2989 | :qualifiers () |
---|
2990 | :specializers (,+the-T-class+ ,class) |
---|
2991 | :function ,(if (autoloadp 'compile) |
---|
2992 | method-function |
---|
2993 | (autocompile method-function)) |
---|
2994 | :fast-function ,(if (autoloadp 'compile) |
---|
2995 | fast-function |
---|
2996 | (autocompile fast-function)) |
---|
2997 | :slot-definition ,slot-definition)) |
---|
2998 | (method-class (if (std-class-p class) |
---|
2999 | +the-standard-writer-method-class+ |
---|
3000 | (apply #'writer-method-class class slot-definition |
---|
3001 | initargs)))) |
---|
3002 | ;; required by AMOP pg. 242 |
---|
3003 | (assert (subtypep method-class +the-standard-writer-method-class+)) |
---|
3004 | (if gf |
---|
3005 | (check-method-lambda-list function-name |
---|
3006 | method-lambda-list |
---|
3007 | (generic-function-lambda-list gf)) |
---|
3008 | (setf gf (ensure-generic-function function-name |
---|
3009 | :lambda-list method-lambda-list))) |
---|
3010 | (let ((method |
---|
3011 | (if (eq method-class +the-standard-writer-method-class+) |
---|
3012 | (apply #'make-instance-standard-accessor-method method-class |
---|
3013 | initargs) |
---|
3014 | (apply #'make-instance method-class |
---|
3015 | :generic-function nil ; handled by add-method |
---|
3016 | initargs)))) |
---|
3017 | (if (std-generic-function-p gf) |
---|
3018 | (progn |
---|
3019 | (std-add-method gf method) |
---|
3020 | (map-dependents gf |
---|
3021 | #'(lambda (dep) |
---|
3022 | (update-dependent gf dep 'add-method method)))) |
---|
3023 | (add-method gf method)) |
---|
3024 | method))) |
---|
3025 | |
---|
3026 | (defmacro atomic-defgeneric (function-name &rest rest) |
---|
3027 | "Macro to define a generic function and 'swap it into place' after |
---|
3028 | it's been fully defined with all its methods. |
---|
3029 | |
---|
3030 | Note: the user should really use the (:method ..) method description |
---|
3031 | way of defining methods; there's not much use in atomically defining |
---|
3032 | generic functions without providing sensible behaviour." |
---|
3033 | (let ((temp-sym (gensym))) |
---|
3034 | `(progn |
---|
3035 | (defgeneric ,temp-sym ,@rest) |
---|
3036 | (let ((gf (symbol-function ',temp-sym))) |
---|
3037 | ;; FIXME (rudi 2012-07-08): fset gets the source location info |
---|
3038 | ;; to charpos 23 always (but (setf fdefinition) leaves the |
---|
3039 | ;; outdated source position in place, which is even worse). |
---|
3040 | (fset ',function-name gf) |
---|
3041 | (setf (std-slot-value gf 'sys::name) ',function-name) |
---|
3042 | (fmakunbound ',temp-sym) |
---|
3043 | gf)))) |
---|
3044 | |
---|
3045 | (defmacro redefine-class-forwarder (name slot &optional body-alist) |
---|
3046 | "Define a generic function on a temporary symbol as an accessor |
---|
3047 | for the slot `slot'. Then, when definition is complete (including |
---|
3048 | allocation of methods), swap the definition in place. |
---|
3049 | |
---|
3050 | `body-alist' can be used to override the default method bodies for given |
---|
3051 | metaclasses. In substitute method bodies, `class' names the class |
---|
3052 | instance and, for setters, `new-value' the new value." |
---|
3053 | (let* ((setterp (consp name)) |
---|
3054 | (%name |
---|
3055 | (intern (concatenate 'string |
---|
3056 | "%" |
---|
3057 | (if setterp (symbol-name 'set-) "") |
---|
3058 | (symbol-name (if setterp (cadr name) name))) |
---|
3059 | (find-package "SYS"))) |
---|
3060 | (bodies |
---|
3061 | (append body-alist |
---|
3062 | (if setterp |
---|
3063 | `((built-in-class . (,%name new-value class)) |
---|
3064 | (forward-referenced-class . (,%name new-value class)) |
---|
3065 | (structure-class . (,%name new-value class)) |
---|
3066 | (standard-class . (setf (slot-value class ',slot) |
---|
3067 | new-value)) |
---|
3068 | (funcallable-standard-class . (setf (slot-value class ',slot) |
---|
3069 | new-value))) |
---|
3070 | `((built-in-class . (,%name class)) |
---|
3071 | (forward-referenced-class . (,%name class)) |
---|
3072 | (structure-class . (,%name class)) |
---|
3073 | (standard-class . (slot-value class ',slot)) |
---|
3074 | (funcallable-standard-class . (slot-value class ',slot))))))) |
---|
3075 | `(atomic-defgeneric ,name (,@(when setterp (list 'new-value)) class) |
---|
3076 | ,@(mapcar #'(lambda (class-name) |
---|
3077 | `(:method (,@(when setterp (list 'new-value)) |
---|
3078 | (class ,class-name)) |
---|
3079 | ,(cdr (assoc class-name bodies)))) |
---|
3080 | '(built-in-class forward-referenced-class structure-class |
---|
3081 | standard-class funcallable-standard-class))))) |
---|
3082 | |
---|
3083 | ;;; The slot names here must agree with the ones defined in |
---|
3084 | ;;; StandardClass.java:layoutStandardClass. |
---|
3085 | (redefine-class-forwarder class-name sys:name) |
---|
3086 | ;;; AMOP pg. 230 |
---|
3087 | (redefine-class-forwarder (setf class-name) sys:name |
---|
3088 | ((standard-class . (progn (reinitialize-instance class :name new-value) new-value)) |
---|
3089 | (funcallable-standard-class . (progn (reinitialize-instance class :name new-value) new-value)))) |
---|
3090 | (redefine-class-forwarder class-slots sys:slots) |
---|
3091 | (redefine-class-forwarder (setf class-slots) sys:slots) |
---|
3092 | (redefine-class-forwarder class-direct-slots sys:direct-slots) |
---|
3093 | (redefine-class-forwarder (setf class-direct-slots) sys:direct-slots) |
---|
3094 | (redefine-class-forwarder class-layout sys:layout) |
---|
3095 | (redefine-class-forwarder (setf class-layout) sys:layout) |
---|
3096 | (redefine-class-forwarder class-direct-superclasses sys:direct-superclasses) |
---|
3097 | (redefine-class-forwarder (setf class-direct-superclasses) sys:direct-superclasses) |
---|
3098 | (redefine-class-forwarder class-direct-subclasses sys:direct-subclasses) |
---|
3099 | (redefine-class-forwarder (setf class-direct-subclasses) sys:direct-subclasses) |
---|
3100 | (redefine-class-forwarder class-direct-methods sys:direct-methods) |
---|
3101 | (redefine-class-forwarder (setf class-direct-methods) sys:direct-methods) |
---|
3102 | (redefine-class-forwarder class-precedence-list sys:precedence-list) |
---|
3103 | (redefine-class-forwarder (setf class-precedence-list) sys:precedence-list) |
---|
3104 | (redefine-class-forwarder class-finalized-p sys:finalized-p) |
---|
3105 | (redefine-class-forwarder (setf class-finalized-p) sys:finalized-p) |
---|
3106 | (redefine-class-forwarder class-default-initargs sys:default-initargs) |
---|
3107 | (redefine-class-forwarder (setf class-default-initargs) sys:default-initargs) |
---|
3108 | (redefine-class-forwarder class-direct-default-initargs sys:direct-default-initargs) |
---|
3109 | (redefine-class-forwarder (setf class-direct-default-initargs) sys:direct-default-initargs) |
---|
3110 | |
---|
3111 | ;;; Class definition |
---|
3112 | |
---|
3113 | (defun check-duplicate-slots (slots) |
---|
3114 | (flet ((canonical-slot-name (canonical-slot) |
---|
3115 | (getf canonical-slot :name))) |
---|
3116 | (dolist (s1 slots) |
---|
3117 | (let ((name1 (canonical-slot-name s1))) |
---|
3118 | (dolist (s2 (cdr (memq s1 slots))) |
---|
3119 | (when (eq name1 (canonical-slot-name s2)) |
---|
3120 | (error 'program-error "Duplicate slot ~S" name1))))))) |
---|
3121 | |
---|
3122 | (defun check-duplicate-default-initargs (initargs) |
---|
3123 | (let ((names ())) |
---|
3124 | (dolist (initarg initargs) |
---|
3125 | (push (car initarg) names)) |
---|
3126 | (do* ((names names (cdr names)) |
---|
3127 | (name (car names) (car names))) |
---|
3128 | ((null names)) |
---|
3129 | (when (memq name (cdr names)) |
---|
3130 | (error 'program-error |
---|
3131 | :format-control "Duplicate initialization argument name ~S in :DEFAULT-INITARGS." |
---|
3132 | :format-arguments (list name)))))) |
---|
3133 | |
---|
3134 | (defun canonicalize-direct-superclasses (direct-superclasses) |
---|
3135 | (let ((classes '())) |
---|
3136 | (dolist (class-specifier direct-superclasses) |
---|
3137 | (let ((class (if (classp class-specifier) |
---|
3138 | class-specifier |
---|
3139 | (find-class class-specifier nil)))) |
---|
3140 | (unless class |
---|
3141 | (setf class (make-instance +the-forward-referenced-class+ |
---|
3142 | :name class-specifier)) |
---|
3143 | (setf (find-class class-specifier) class)) |
---|
3144 | (when (and (typep class 'built-in-class) |
---|
3145 | (not (member class *extensible-built-in-classes*))) |
---|
3146 | (error "Attempt to define a subclass of built-in-class ~S." |
---|
3147 | class-specifier)) |
---|
3148 | (push class classes))) |
---|
3149 | (nreverse classes))) |
---|
3150 | |
---|
3151 | (atomic-defgeneric add-direct-subclass (superclass subclass) |
---|
3152 | (:method ((superclass class) (subclass class)) |
---|
3153 | (setf (class-direct-subclasses superclass) |
---|
3154 | (adjoin subclass (class-direct-subclasses superclass))))) |
---|
3155 | |
---|
3156 | (atomic-defgeneric remove-direct-subclass (superclass subclass) |
---|
3157 | (:method ((superclass class) (subclass class)) |
---|
3158 | (setf (class-direct-subclasses superclass) |
---|
3159 | (remove subclass (class-direct-subclasses superclass))))) |
---|
3160 | |
---|
3161 | ;;; AMOP pg. 182 |
---|
3162 | (defun ensure-class (name &rest all-keys &key &allow-other-keys) |
---|
3163 | (let ((class (find-class name nil))) |
---|
3164 | ;; CLHS DEFCLASS: "If a class with the same proper name already |
---|
3165 | ;; exists [...] the existing class is redefined." Ansi-tests |
---|
3166 | ;; CLASS-0309 and CLASS-0310.1 demand this behavior. |
---|
3167 | (if (and class (eql (class-name class) name)) |
---|
3168 | (apply #'ensure-class-using-class class name all-keys) |
---|
3169 | (apply #'ensure-class-using-class nil name all-keys)))) |
---|
3170 | |
---|
3171 | ;;; AMOP pg. 183ff. |
---|
3172 | (defgeneric ensure-class-using-class (class name &key direct-default-initargs |
---|
3173 | direct-slots direct-superclasses |
---|
3174 | metaclass &allow-other-keys)) |
---|
3175 | |
---|
3176 | (defmethod ensure-class-using-class :before (class name &key direct-slots |
---|
3177 | direct-default-initargs |
---|
3178 | &allow-other-keys) |
---|
3179 | (check-duplicate-slots direct-slots) |
---|
3180 | (check-duplicate-default-initargs direct-default-initargs)) |
---|
3181 | |
---|
3182 | (defmethod ensure-class-using-class ((class null) name &rest all-keys |
---|
3183 | &key (metaclass +the-standard-class+) |
---|
3184 | direct-superclasses |
---|
3185 | &allow-other-keys) |
---|
3186 | (setf all-keys (copy-list all-keys)) ; since we modify it |
---|
3187 | (remf all-keys :metaclass) |
---|
3188 | (unless (classp metaclass) (setf metaclass (find-class metaclass))) |
---|
3189 | (let ((class (apply (if (eq metaclass +the-standard-class+) |
---|
3190 | #'make-instance-standard-class |
---|
3191 | #'make-instance) |
---|
3192 | metaclass :name name |
---|
3193 | :direct-superclasses (canonicalize-direct-superclasses |
---|
3194 | direct-superclasses) |
---|
3195 | all-keys))) |
---|
3196 | (%set-find-class name class) |
---|
3197 | class)) |
---|
3198 | |
---|
3199 | (defmethod ensure-class-using-class ((class built-in-class) name &rest all-keys |
---|
3200 | &key &allow-other-keys) |
---|
3201 | (declare (ignore all-keys)) |
---|
3202 | (error "The symbol ~S names a built-in class." name)) |
---|
3203 | |
---|
3204 | (defmethod ensure-class-using-class ((class forward-referenced-class) name |
---|
3205 | &rest all-keys |
---|
3206 | &key (metaclass +the-standard-class+) |
---|
3207 | direct-superclasses &allow-other-keys) |
---|
3208 | (setf all-keys (copy-list all-keys)) ; since we modify it |
---|
3209 | (remf all-keys :metaclass) |
---|
3210 | (unless (classp metaclass) (setf metaclass (find-class metaclass))) |
---|
3211 | (apply #'change-class class metaclass all-keys) |
---|
3212 | (apply #'reinitialize-instance class |
---|
3213 | :name name |
---|
3214 | :direct-superclasses (canonicalize-direct-superclasses |
---|
3215 | direct-superclasses) |
---|
3216 | all-keys) |
---|
3217 | class) |
---|
3218 | |
---|
3219 | (defmethod ensure-class-using-class ((class class) name |
---|
3220 | &rest all-keys |
---|
3221 | &key (metaclass +the-standard-class+ metaclassp) |
---|
3222 | direct-superclasses |
---|
3223 | &allow-other-keys) |
---|
3224 | (declare (ignore name)) |
---|
3225 | (setf all-keys (copy-list all-keys)) ; since we modify it |
---|
3226 | (remf all-keys :metaclass) |
---|
3227 | (unless (classp metaclass) (setf metaclass (find-class metaclass))) |
---|
3228 | (when (and metaclassp (not (eq (class-of class) metaclass))) |
---|
3229 | (error 'program-error |
---|
3230 | "Trying to redefine class ~S with different metaclass." |
---|
3231 | (class-name class))) |
---|
3232 | (apply #'reinitialize-instance class |
---|
3233 | :direct-superclasses (canonicalize-direct-superclasses direct-superclasses) |
---|
3234 | all-keys) |
---|
3235 | class) |
---|
3236 | |
---|
3237 | (defmacro defclass (&whole form name direct-superclasses direct-slots &rest options) |
---|
3238 | (unless (>= (length form) 3) |
---|
3239 | (error 'program-error "Wrong number of arguments for DEFCLASS.")) |
---|
3240 | (check-declaration-type name) |
---|
3241 | `(ensure-class ',name |
---|
3242 | :direct-superclasses |
---|
3243 | (canonicalize-direct-superclasses ',direct-superclasses) |
---|
3244 | :direct-slots |
---|
3245 | ,(canonicalize-direct-slots direct-slots) |
---|
3246 | ,@(canonicalize-defclass-options options))) |
---|
3247 | |
---|
3248 | |
---|
3249 | ;;; AMOP pg. 180 |
---|
3250 | (defgeneric direct-slot-definition-class (class &rest initargs)) |
---|
3251 | |
---|
3252 | (defmethod direct-slot-definition-class ((class class) &rest initargs) |
---|
3253 | (declare (ignore initargs)) |
---|
3254 | +the-standard-direct-slot-definition-class+) |
---|
3255 | |
---|
3256 | ;;; AMOP pg. 181 |
---|
3257 | (defgeneric effective-slot-definition-class (class &rest initargs)) |
---|
3258 | |
---|
3259 | (defmethod effective-slot-definition-class ((class class) &rest initargs) |
---|
3260 | (declare (ignore initargs)) |
---|
3261 | +the-standard-effective-slot-definition-class+) |
---|
3262 | |
---|
3263 | ;;; AMOP pg. 224 |
---|
3264 | (defgeneric reader-method-class (class direct-slot &rest initargs)) |
---|
3265 | |
---|
3266 | (defmethod reader-method-class ((class standard-class) |
---|
3267 | (direct-slot standard-direct-slot-definition) |
---|
3268 | &rest initargs) |
---|
3269 | (declare (ignore initargs)) |
---|
3270 | +the-standard-reader-method-class+) |
---|
3271 | |
---|
3272 | (defmethod reader-method-class ((class funcallable-standard-class) |
---|
3273 | (direct-slot standard-direct-slot-definition) |
---|
3274 | &rest initargs) |
---|
3275 | (declare (ignore initargs)) |
---|
3276 | +the-standard-reader-method-class+) |
---|
3277 | |
---|
3278 | ;;; AMOP pg. 242 |
---|
3279 | (defgeneric writer-method-class (class direct-slot &rest initargs)) |
---|
3280 | |
---|
3281 | (defmethod writer-method-class ((class standard-class) |
---|
3282 | (direct-slot standard-direct-slot-definition) |
---|
3283 | &rest initargs) |
---|
3284 | (declare (ignore initargs)) |
---|
3285 | +the-standard-writer-method-class+) |
---|
3286 | |
---|
3287 | (defmethod writer-method-class ((class funcallable-standard-class) |
---|
3288 | (direct-slot standard-direct-slot-definition) |
---|
3289 | &rest initargs) |
---|
3290 | (declare (ignore initargs)) |
---|
3291 | +the-standard-writer-method-class+) |
---|
3292 | |
---|
3293 | ;;; Applicable methods |
---|
3294 | |
---|
3295 | (atomic-defgeneric compute-applicable-methods (gf args) |
---|
3296 | (:method ((gf standard-generic-function) args) |
---|
3297 | (std-compute-applicable-methods gf args))) |
---|
3298 | |
---|
3299 | (defgeneric compute-applicable-methods-using-classes (gf classes) |
---|
3300 | (:method ((gf standard-generic-function) classes) |
---|
3301 | (let ((methods '())) |
---|
3302 | (dolist (method (generic-function-methods gf)) |
---|
3303 | (multiple-value-bind (applicable knownp) |
---|
3304 | (method-applicable-using-classes-p method classes) |
---|
3305 | (cond (applicable |
---|
3306 | (push method methods)) |
---|
3307 | ((not knownp) |
---|
3308 | (return-from compute-applicable-methods-using-classes |
---|
3309 | (values nil nil)))))) |
---|
3310 | (values (sort-methods methods gf classes) |
---|
3311 | t)))) |
---|
3312 | |
---|
3313 | |
---|
3314 | ;;; Slot access |
---|
3315 | ;;; |
---|
3316 | ;;; See AMOP pg. 156ff. for an overview. |
---|
3317 | ;;; |
---|
3318 | ;;; AMOP specifies these generic functions to dispatch on slot objects |
---|
3319 | ;;; (with the exception of slot-exists-p-using-class), although its |
---|
3320 | ;;; sample implementation Closette dispatches on slot names. We let |
---|
3321 | ;;; slot-value and friends call their gf counterparts with the effective |
---|
3322 | ;;; slot definition, but leave the definitions dispatching on slot name |
---|
3323 | ;;; in place for user convenience. |
---|
3324 | |
---|
3325 | ;;; AMOP pg. 235 |
---|
3326 | (defgeneric slot-value-using-class (class instance slot)) |
---|
3327 | |
---|
3328 | (defmethod slot-value-using-class ((class standard-class) instance (slot symbol)) |
---|
3329 | (std-slot-value instance slot)) |
---|
3330 | (defmethod slot-value-using-class ((class standard-class) instance |
---|
3331 | (slot standard-effective-slot-definition)) |
---|
3332 | (let* ((location (slot-definition-location slot)) |
---|
3333 | (value (if (consp location) |
---|
3334 | (cdr location) ; :allocation :class |
---|
3335 | (standard-instance-access instance location)))) |
---|
3336 | (if (eq value +slot-unbound+) |
---|
3337 | ;; fix SLOT-UNBOUND.5 from ansi test suite |
---|
3338 | (nth-value 0 (slot-unbound class instance (slot-definition-name slot))) |
---|
3339 | value))) |
---|
3340 | |
---|
3341 | (defmethod slot-value-using-class ((class funcallable-standard-class) |
---|
3342 | instance (slot symbol)) |
---|
3343 | (std-slot-value instance slot)) |
---|
3344 | (defmethod slot-value-using-class ((class funcallable-standard-class) instance |
---|
3345 | (slot standard-effective-slot-definition)) |
---|
3346 | (let* ((location (slot-definition-location slot)) |
---|
3347 | (value (if (consp location) |
---|
3348 | (cdr location) ; :allocation :class |
---|
3349 | (funcallable-standard-instance-access instance location)))) |
---|
3350 | (if (eq value +slot-unbound+) |
---|
3351 | ;; fix SLOT-UNBOUND.5 from ansi test suite |
---|
3352 | (nth-value 0 (slot-unbound class instance (slot-definition-name slot))) |
---|
3353 | value))) |
---|
3354 | |
---|
3355 | (defmethod slot-value-using-class ((class structure-class) instance |
---|
3356 | (slot symbol)) |
---|
3357 | (std-slot-value instance slot)) |
---|
3358 | (defmethod slot-value-using-class ((class structure-class) instance |
---|
3359 | (slot standard-effective-slot-definition)) |
---|
3360 | (std-slot-value instance (slot-definition-name slot))) |
---|
3361 | |
---|
3362 | ;;; AMOP pg. 231 |
---|
3363 | (defgeneric (setf slot-value-using-class) (new-value class instance slot)) |
---|
3364 | |
---|
3365 | (defmethod (setf slot-value-using-class) (new-value |
---|
3366 | (class standard-class) |
---|
3367 | instance |
---|
3368 | (slot symbol)) |
---|
3369 | (setf (std-slot-value instance slot) new-value)) |
---|
3370 | (defmethod (setf slot-value-using-class) (new-value |
---|
3371 | (class standard-class) |
---|
3372 | instance |
---|
3373 | (slot standard-effective-slot-definition)) |
---|
3374 | (let ((location (slot-definition-location slot))) |
---|
3375 | (if (consp location) ; :allocation :class |
---|
3376 | (setf (cdr location) new-value) |
---|
3377 | (setf (standard-instance-access instance location) new-value)))) |
---|
3378 | |
---|
3379 | (defmethod (setf slot-value-using-class) (new-value |
---|
3380 | (class funcallable-standard-class) |
---|
3381 | instance |
---|
3382 | (slot symbol)) |
---|
3383 | (setf (std-slot-value instance slot) new-value)) |
---|
3384 | (defmethod (setf slot-value-using-class) (new-value |
---|
3385 | (class funcallable-standard-class) |
---|
3386 | instance |
---|
3387 | (slot standard-effective-slot-definition)) |
---|
3388 | (let ((location (slot-definition-location slot))) |
---|
3389 | (if (consp location) ; :allocation :class |
---|
3390 | (setf (cdr location) new-value) |
---|
3391 | (setf (funcallable-standard-instance-access instance location) |
---|
3392 | new-value)))) |
---|
3393 | |
---|
3394 | (defmethod (setf slot-value-using-class) (new-value |
---|
3395 | (class structure-class) |
---|
3396 | instance |
---|
3397 | (slot symbol)) |
---|
3398 | (setf (std-slot-value instance slot) new-value)) |
---|
3399 | (defmethod (setf slot-value-using-class) (new-value |
---|
3400 | (class structure-class) |
---|
3401 | instance |
---|
3402 | (slot standard-effective-slot-definition)) |
---|
3403 | (setf (std-slot-value instance (slot-definition-name slot)) new-value)) |
---|
3404 | |
---|
3405 | ;;; slot-exists-p-using-class is not specified by AMOP, and obviously |
---|
3406 | ;;; cannot be specialized on the slot type. Hence, its implementation |
---|
3407 | ;;; differs from slot-(boundp|makunbound|value)-using-class |
---|
3408 | (defgeneric slot-exists-p-using-class (class instance slot-name)) |
---|
3409 | |
---|
3410 | (defmethod slot-exists-p-using-class (class instance slot-name) |
---|
3411 | nil) |
---|
3412 | |
---|
3413 | (defmethod slot-exists-p-using-class ((class standard-class) instance slot-name) |
---|
3414 | (std-slot-exists-p instance slot-name)) |
---|
3415 | (defmethod slot-exists-p-using-class ((class funcallable-standard-class) instance slot-name) |
---|
3416 | (std-slot-exists-p instance slot-name)) |
---|
3417 | |
---|
3418 | (defmethod slot-exists-p-using-class ((class structure-class) instance slot-name) |
---|
3419 | (dolist (dsd (class-slots class)) |
---|
3420 | (when (eq (sys::dsd-name dsd) slot-name) |
---|
3421 | (return-from slot-exists-p-using-class t))) |
---|
3422 | nil) |
---|
3423 | |
---|
3424 | |
---|
3425 | (defgeneric slot-boundp-using-class (class instance slot)) |
---|
3426 | (defmethod slot-boundp-using-class ((class standard-class) instance (slot symbol)) |
---|
3427 | (std-slot-boundp instance slot)) |
---|
3428 | (defmethod slot-boundp-using-class ((class standard-class) instance |
---|
3429 | (slot standard-effective-slot-definition)) |
---|
3430 | (let ((location (slot-definition-location slot))) |
---|
3431 | (if (consp location) |
---|
3432 | (not (eq (cdr location) +slot-unbound+)) ; :allocation :class |
---|
3433 | (not (eq (standard-instance-access instance location) +slot-unbound+))))) |
---|
3434 | |
---|
3435 | (defmethod slot-boundp-using-class ((class funcallable-standard-class) instance |
---|
3436 | (slot symbol)) |
---|
3437 | (std-slot-boundp instance slot)) |
---|
3438 | (defmethod slot-boundp-using-class ((class funcallable-standard-class) instance |
---|
3439 | (slot standard-effective-slot-definition)) |
---|
3440 | (let ((location (slot-definition-location slot))) |
---|
3441 | (if (consp location) |
---|
3442 | (not (eq (cdr location) +slot-unbound+)) ; :allocation :class |
---|
3443 | (not (eq (funcallable-standard-instance-access instance location) |
---|
3444 | +slot-unbound+))))) |
---|
3445 | |
---|
3446 | (defmethod slot-boundp-using-class ((class structure-class) instance slot) |
---|
3447 | "Structure slots can't be unbound, so this method always returns T." |
---|
3448 | (declare (ignore class instance slot)) |
---|
3449 | t) |
---|
3450 | |
---|
3451 | (defgeneric slot-makunbound-using-class (class instance slot)) |
---|
3452 | (defmethod slot-makunbound-using-class ((class standard-class) |
---|
3453 | instance |
---|
3454 | (slot symbol)) |
---|
3455 | (std-slot-makunbound instance slot)) |
---|
3456 | (defmethod slot-makunbound-using-class ((class standard-class) |
---|
3457 | instance |
---|
3458 | (slot standard-effective-slot-definition)) |
---|
3459 | (let ((location (slot-definition-location slot))) |
---|
3460 | (if (consp location) |
---|
3461 | (setf (cdr location) +slot-unbound+) |
---|
3462 | (setf (standard-instance-access instance location) +slot-unbound+)))) |
---|
3463 | |
---|
3464 | (defmethod slot-makunbound-using-class ((class funcallable-standard-class) |
---|
3465 | instance |
---|
3466 | (slot symbol)) |
---|
3467 | (std-slot-makunbound instance slot)) |
---|
3468 | (defmethod slot-makunbound-using-class ((class funcallable-standard-class) |
---|
3469 | instance |
---|
3470 | (slot symbol)) |
---|
3471 | (let ((location (slot-definition-location slot))) |
---|
3472 | (if (consp location) |
---|
3473 | (setf (cdr location) +slot-unbound+) |
---|
3474 | (setf (funcallable-standard-instance-access instance location) |
---|
3475 | +slot-unbound+)))) |
---|
3476 | |
---|
3477 | (defmethod slot-makunbound-using-class ((class structure-class) |
---|
3478 | instance |
---|
3479 | slot) |
---|
3480 | (declare (ignore class instance slot)) |
---|
3481 | (error "Structure slots can't be unbound")) |
---|
3482 | |
---|
3483 | (defgeneric slot-missing (class instance slot-name operation &optional new-value)) |
---|
3484 | |
---|
3485 | (defmethod slot-missing ((class t) instance slot-name operation &optional new-value) |
---|
3486 | (declare (ignore new-value)) |
---|
3487 | (error "The slot ~S is missing from the class ~S." slot-name class)) |
---|
3488 | |
---|
3489 | (defgeneric slot-unbound (class instance slot-name)) |
---|
3490 | |
---|
3491 | (defmethod slot-unbound ((class t) instance slot-name) |
---|
3492 | (error 'unbound-slot :instance instance :name slot-name)) |
---|
3493 | |
---|
3494 | ;;; Instance creation and initialization |
---|
3495 | |
---|
3496 | ;;; AMOP pg. 168ff. |
---|
3497 | (defgeneric allocate-instance (class &rest initargs &key &allow-other-keys)) |
---|
3498 | |
---|
3499 | (defmethod allocate-instance ((class standard-class) &rest initargs) |
---|
3500 | (declare (ignore initargs)) |
---|
3501 | (std-allocate-instance class)) |
---|
3502 | |
---|
3503 | (defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) |
---|
3504 | (declare (ignore initargs)) |
---|
3505 | (allocate-funcallable-instance class)) |
---|
3506 | |
---|
3507 | (defmethod allocate-instance ((class structure-class) &rest initargs) |
---|
3508 | (declare (ignore initargs)) |
---|
3509 | (%make-structure (class-name class) |
---|
3510 | (make-list (length (class-slots class)) |
---|
3511 | :initial-element +slot-unbound+))) |
---|
3512 | |
---|
3513 | (defmethod allocate-instance ((class built-in-class) &rest initargs) |
---|
3514 | (declare (ignore initargs)) |
---|
3515 | (error "Cannot allocate instances of a built-in class: ~S" class)) |
---|
3516 | |
---|
3517 | (defmethod allocate-instance :before ((class class) &rest initargs) |
---|
3518 | (declare (ignore initargs)) |
---|
3519 | (unless (class-finalized-p class) |
---|
3520 | (finalize-inheritance class))) |
---|
3521 | |
---|
3522 | ;; "The set of valid initialization arguments for a class is the set of valid |
---|
3523 | ;; initialization arguments that either fill slots or supply arguments to |
---|
3524 | ;; methods, along with the predefined initialization argument :ALLOW-OTHER-KEYS." |
---|
3525 | ;; 7.1.2 |
---|
3526 | |
---|
3527 | (defun calculate-allowable-initargs (gf-list args instance |
---|
3528 | shared-initialize-param |
---|
3529 | initargs) |
---|
3530 | (let* ((methods |
---|
3531 | (nconc |
---|
3532 | (std-compute-applicable-methods #'shared-initialize |
---|
3533 | (list* instance |
---|
3534 | shared-initialize-param |
---|
3535 | initargs)) |
---|
3536 | (mapcan #'(lambda (gf) |
---|
3537 | (if (std-generic-function-p gf) |
---|
3538 | (std-compute-applicable-methods gf args) |
---|
3539 | (compute-applicable-methods gf args))) |
---|
3540 | gf-list))) |
---|
3541 | (method-keyword-args |
---|
3542 | (reduce #'merge-initargs-sets |
---|
3543 | (mapcar #'method-lambda-list methods) |
---|
3544 | :key #'extract-lambda-list-keywords |
---|
3545 | :initial-value nil)) |
---|
3546 | (slots-initargs |
---|
3547 | (mapappend #'slot-definition-initargs |
---|
3548 | (class-slots (class-of instance))))) |
---|
3549 | (merge-initargs-sets |
---|
3550 | (merge-initargs-sets slots-initargs method-keyword-args) |
---|
3551 | '(:allow-other-keys)))) ;; allow-other-keys is always allowed |
---|
3552 | |
---|
3553 | (defun check-initargs (gf-list args instance |
---|
3554 | shared-initialize-param initargs |
---|
3555 | cache call-site) |
---|
3556 | "Checks the validity of `initargs' for the generic functions in `gf-list' |
---|
3557 | when called with `args' by calculating the applicable methods for each gf. |
---|
3558 | The applicable methods for SHARED-INITIALIZE based on `instance', |
---|
3559 | `shared-initialize-param' and `initargs' are added to the list of |
---|
3560 | applicable methods." |
---|
3561 | (when (oddp (length initargs)) |
---|
3562 | (error 'program-error |
---|
3563 | :format-control "Odd number of keyword arguments.")) |
---|
3564 | (unless (getf initargs :allow-other-keys) |
---|
3565 | (multiple-value-bind (allowable-initargs present-p) |
---|
3566 | (when cache |
---|
3567 | (gethash (class-of instance) cache)) |
---|
3568 | (unless present-p |
---|
3569 | (setf allowable-initargs |
---|
3570 | (calculate-allowable-initargs gf-list args instance |
---|
3571 | shared-initialize-param initargs)) |
---|
3572 | (when cache |
---|
3573 | (setf (gethash (class-of instance) cache) |
---|
3574 | allowable-initargs))) |
---|
3575 | (unless (eq t allowable-initargs) |
---|
3576 | (do* ((tail initargs (cddr tail)) |
---|
3577 | (initarg (car tail) (car tail))) |
---|
3578 | ((null tail)) |
---|
3579 | (unless (memq initarg allowable-initargs) |
---|
3580 | (error 'program-error |
---|
3581 | :format-control "Invalid initarg ~S in call to ~S with arglist ~S." |
---|
3582 | :format-arguments (list initarg call-site args)))))))) |
---|
3583 | |
---|
3584 | (defun merge-initargs-sets (list1 list2) |
---|
3585 | (cond |
---|
3586 | ((eq list1 t) t) |
---|
3587 | ((eq list2 t) t) |
---|
3588 | (t (union list1 list2)))) |
---|
3589 | |
---|
3590 | (defun extract-lambda-list-keywords (lambda-list) |
---|
3591 | "Returns a list of keywords acceptable as keyword arguments, |
---|
3592 | or T when any keyword is acceptable due to presence of |
---|
3593 | &allow-other-keys." |
---|
3594 | (when (member '&allow-other-keys lambda-list) |
---|
3595 | (return-from extract-lambda-list-keywords t)) |
---|
3596 | (loop with keyword-args = (cdr (memq '&key lambda-list)) |
---|
3597 | for key in keyword-args |
---|
3598 | when (eq key '&aux) do (loop-finish) |
---|
3599 | when (eq key '&allow-other-keys) do (return t) |
---|
3600 | when (listp key) do (setq key (car key)) |
---|
3601 | collect (if (symbolp key) |
---|
3602 | (make-keyword key) |
---|
3603 | (car key)))) |
---|
3604 | |
---|
3605 | |
---|
3606 | (defgeneric make-instance (class &rest initargs &key &allow-other-keys)) |
---|
3607 | |
---|
3608 | (defmethod make-instance :before ((class class) &rest initargs) |
---|
3609 | (when (oddp (length initargs)) |
---|
3610 | (error 'program-error :format-control "Odd number of keyword arguments.")) |
---|
3611 | (unless (class-finalized-p class) |
---|
3612 | (finalize-inheritance class))) |
---|
3613 | |
---|
3614 | (defun augment-initargs-with-defaults (class initargs) |
---|
3615 | (let ((default-initargs '())) |
---|
3616 | (dolist (initarg (class-default-initargs class)) |
---|
3617 | (let ((key (first initarg)) |
---|
3618 | (fn (third initarg))) |
---|
3619 | (when (eq (getf initargs key +slot-unbound+) +slot-unbound+) |
---|
3620 | (push key default-initargs) |
---|
3621 | (push (funcall fn) default-initargs)))) |
---|
3622 | (append initargs (nreverse default-initargs)))) |
---|
3623 | |
---|
3624 | (defmethod make-instance ((class standard-class) &rest initargs) |
---|
3625 | (setf initargs (augment-initargs-with-defaults class initargs)) |
---|
3626 | (let ((instance (std-allocate-instance class))) |
---|
3627 | (check-initargs (list #'allocate-instance #'initialize-instance) |
---|
3628 | (list* instance initargs) |
---|
3629 | instance t initargs |
---|
3630 | *make-instance-initargs-cache* 'make-instance) |
---|
3631 | (apply #'initialize-instance instance initargs) |
---|
3632 | instance)) |
---|
3633 | |
---|
3634 | (defmethod make-instance ((class funcallable-standard-class) &rest initargs) |
---|
3635 | (setf initargs (augment-initargs-with-defaults class initargs)) |
---|
3636 | (let ((instance (allocate-funcallable-instance class))) |
---|
3637 | (check-initargs (list #'allocate-instance #'initialize-instance) |
---|
3638 | (list* instance initargs) |
---|
3639 | instance t initargs |
---|
3640 | *make-instance-initargs-cache* 'make-instance) |
---|
3641 | (apply #'initialize-instance instance initargs) |
---|
3642 | instance)) |
---|
3643 | |
---|
3644 | (defmethod make-instance ((class symbol) &rest initargs) |
---|
3645 | (apply #'make-instance (find-class class) initargs)) |
---|
3646 | |
---|
3647 | (defgeneric initialize-instance (instance &rest initargs |
---|
3648 | &key &allow-other-keys)) |
---|
3649 | |
---|
3650 | (defmethod initialize-instance ((instance standard-object) &rest initargs) |
---|
3651 | (apply #'shared-initialize instance t initargs)) |
---|
3652 | |
---|
3653 | (defgeneric reinitialize-instance (instance &rest initargs |
---|
3654 | &key &allow-other-keys)) |
---|
3655 | |
---|
3656 | ;; "The system-supplied primary method for REINITIALIZE-INSTANCE checks the |
---|
3657 | ;; validity of initargs and signals an error if an initarg is supplied that is |
---|
3658 | ;; not declared as valid. The method then calls the generic function SHARED- |
---|
3659 | ;; INITIALIZE with the following arguments: the instance, nil (which means no |
---|
3660 | ;; slots should be initialized according to their initforms), and the initargs |
---|
3661 | ;; it received." |
---|
3662 | (defmethod reinitialize-instance ((instance standard-object) &rest initargs) |
---|
3663 | (check-initargs (list #'reinitialize-instance) (list* instance initargs) |
---|
3664 | instance () initargs |
---|
3665 | *reinitialize-instance-initargs-cache* 'reinitialize-instance) |
---|
3666 | (apply #'shared-initialize instance () initargs)) |
---|
3667 | |
---|
3668 | (defun std-shared-initialize (instance slot-names all-keys) |
---|
3669 | (when (oddp (length all-keys)) |
---|
3670 | (error 'program-error :format-control "Odd number of keyword arguments.")) |
---|
3671 | ;; do a quick scan of the arguments list to see if it's a real |
---|
3672 | ;; 'initialization argument list' (which is not the same as |
---|
3673 | ;; checking initarg validity |
---|
3674 | (do* ((tail all-keys (cddr tail)) |
---|
3675 | (initarg (car tail) (car tail))) |
---|
3676 | ((null tail)) |
---|
3677 | (unless (symbolp initarg) |
---|
3678 | (error 'program-error |
---|
3679 | :format-control "Initarg ~S not a symbol." |
---|
3680 | :format-arguments (list initarg)))) |
---|
3681 | (dolist (slot (class-slots (class-of instance))) |
---|
3682 | (let ((slot-name (slot-definition-name slot))) |
---|
3683 | (multiple-value-bind (init-key init-value foundp) |
---|
3684 | (get-properties all-keys (slot-definition-initargs slot)) |
---|
3685 | (if foundp |
---|
3686 | (setf (std-slot-value instance slot-name) init-value) |
---|
3687 | (unless (std-slot-boundp instance slot-name) |
---|
3688 | (let ((initfunction (slot-definition-initfunction slot))) |
---|
3689 | (when (and initfunction (or (eq slot-names t) |
---|
3690 | (memq slot-name slot-names))) |
---|
3691 | (setf (std-slot-value instance slot-name) |
---|
3692 | (funcall initfunction))))))))) |
---|
3693 | instance) |
---|
3694 | |
---|
3695 | (defgeneric shared-initialize (instance slot-names |
---|
3696 | &rest initargs |
---|
3697 | &key &allow-other-keys)) |
---|
3698 | |
---|
3699 | (defmethod shared-initialize ((instance standard-object) slot-names |
---|
3700 | &rest initargs) |
---|
3701 | (std-shared-initialize instance slot-names initargs)) |
---|
3702 | |
---|
3703 | (defmethod shared-initialize ((slot slot-definition) slot-names |
---|
3704 | &rest args |
---|
3705 | &key name initargs initform initfunction |
---|
3706 | readers writers allocation |
---|
3707 | &allow-other-keys) |
---|
3708 | ;;Keyword args are duplicated from init-slot-definition only to have |
---|
3709 | ;;them checked. |
---|
3710 | (declare (ignore slot-names)) ;;TODO? |
---|
3711 | (declare (ignore name initargs initform initfunction readers writers allocation)) |
---|
3712 | ;;For built-in slots |
---|
3713 | (apply #'init-slot-definition slot :allow-other-keys t args) |
---|
3714 | ;;For user-defined slots |
---|
3715 | (call-next-method)) |
---|
3716 | |
---|
3717 | ;;; change-class |
---|
3718 | |
---|
3719 | (defgeneric change-class (instance new-class &key &allow-other-keys)) |
---|
3720 | |
---|
3721 | (defmethod change-class ((old-instance standard-object) (new-class standard-class) |
---|
3722 | &rest initargs) |
---|
3723 | (let ((old-slots (class-slots (class-of old-instance))) |
---|
3724 | (new-slots (class-slots new-class)) |
---|
3725 | (new-instance (allocate-instance new-class))) |
---|
3726 | ;; "The values of local slots specified by both the class CTO and the class |
---|
3727 | ;; CFROM are retained. If such a local slot was unbound, it remains |
---|
3728 | ;; unbound." |
---|
3729 | (dolist (new-slot new-slots) |
---|
3730 | (when (instance-slot-p new-slot) |
---|
3731 | (let* ((slot-name (slot-definition-name new-slot)) |
---|
3732 | (old-slot (find slot-name old-slots :key 'slot-definition-name))) |
---|
3733 | ;; "The values of slots specified as shared in the class CFROM and as |
---|
3734 | ;; local in the class CTO are retained." |
---|
3735 | (when (and old-slot (slot-boundp old-instance slot-name)) |
---|
3736 | (setf (slot-value new-instance slot-name) |
---|
3737 | (slot-value old-instance slot-name)))))) |
---|
3738 | (swap-slots old-instance new-instance) |
---|
3739 | (rotatef (std-instance-layout new-instance) |
---|
3740 | (std-instance-layout old-instance)) |
---|
3741 | (apply #'update-instance-for-different-class |
---|
3742 | new-instance old-instance initargs) |
---|
3743 | old-instance)) |
---|
3744 | |
---|
3745 | (defmethod change-class ((instance standard-object) (new-class symbol) &rest initargs) |
---|
3746 | (apply #'change-class instance (find-class new-class) initargs)) |
---|
3747 | |
---|
3748 | (defgeneric update-instance-for-different-class (old new |
---|
3749 | &rest initargs |
---|
3750 | &key &allow-other-keys)) |
---|
3751 | |
---|
3752 | (defmethod update-instance-for-different-class |
---|
3753 | ((old standard-object) (new standard-object) &rest initargs) |
---|
3754 | (let ((added-slots |
---|
3755 | (remove-if #'(lambda (slot-name) |
---|
3756 | (slot-exists-p old slot-name)) |
---|
3757 | (mapcar 'slot-definition-name |
---|
3758 | (class-slots (class-of new)))))) |
---|
3759 | (check-initargs (list #'update-instance-for-different-class) |
---|
3760 | (list old new initargs) |
---|
3761 | new added-slots initargs |
---|
3762 | nil 'update-instance-for-different-class) |
---|
3763 | (apply #'shared-initialize new added-slots initargs))) |
---|
3764 | |
---|
3765 | ;;; make-instances-obsolete |
---|
3766 | |
---|
3767 | (defgeneric make-instances-obsolete (class)) |
---|
3768 | |
---|
3769 | (defmethod make-instances-obsolete ((class standard-class)) |
---|
3770 | (%make-instances-obsolete class)) |
---|
3771 | (defmethod make-instances-obsolete ((class funcallable-standard-class)) |
---|
3772 | (%make-instances-obsolete class)) |
---|
3773 | (defmethod make-instances-obsolete ((class symbol)) |
---|
3774 | (make-instances-obsolete (find-class class)) |
---|
3775 | class) |
---|
3776 | |
---|
3777 | ;;; update-instance-for-redefined-class |
---|
3778 | |
---|
3779 | (defgeneric update-instance-for-redefined-class (instance |
---|
3780 | added-slots |
---|
3781 | discarded-slots |
---|
3782 | property-list |
---|
3783 | &rest initargs |
---|
3784 | &key |
---|
3785 | &allow-other-keys)) |
---|
3786 | |
---|
3787 | (defmethod update-instance-for-redefined-class ((instance standard-object) |
---|
3788 | added-slots |
---|
3789 | discarded-slots |
---|
3790 | property-list |
---|
3791 | &rest initargs) |
---|
3792 | (check-initargs (list #'update-instance-for-redefined-class) |
---|
3793 | (list* instance added-slots discarded-slots |
---|
3794 | property-list initargs) |
---|
3795 | instance added-slots initargs |
---|
3796 | nil 'update-instance-for-redefined-class) |
---|
3797 | (apply #'shared-initialize instance added-slots initargs)) |
---|
3798 | |
---|
3799 | ;;; Methods having to do with class metaobjects. |
---|
3800 | |
---|
3801 | (defmethod initialize-instance :after ((class standard-class) &rest args) |
---|
3802 | (apply #'std-after-initialization-for-classes class args)) |
---|
3803 | |
---|
3804 | (defmethod initialize-instance :after ((class funcallable-standard-class) |
---|
3805 | &rest args) |
---|
3806 | (apply #'std-after-initialization-for-classes class args)) |
---|
3807 | |
---|
3808 | (defmethod reinitialize-instance :before ((class standard-class) |
---|
3809 | &rest all-keys |
---|
3810 | &key direct-superclasses) |
---|
3811 | (check-initargs (list #'allocate-instance |
---|
3812 | #'initialize-instance) |
---|
3813 | (list* class all-keys) |
---|
3814 | class t all-keys |
---|
3815 | nil 'reinitialize-instance) |
---|
3816 | (dolist (superclass (set-difference (class-direct-superclasses class) |
---|
3817 | direct-superclasses)) |
---|
3818 | (remove-direct-subclass superclass class)) |
---|
3819 | (dolist (superclass (set-difference direct-superclasses |
---|
3820 | (class-direct-superclasses class))) |
---|
3821 | (add-direct-subclass superclass class))) |
---|
3822 | |
---|
3823 | (defmethod reinitialize-instance :before ((class funcallable-standard-class) |
---|
3824 | &rest all-keys |
---|
3825 | &key direct-superclasses) |
---|
3826 | (check-initargs (list #'allocate-instance |
---|
3827 | #'initialize-instance) |
---|
3828 | (list* class all-keys) |
---|
3829 | class t all-keys |
---|
3830 | nil 'reinitialize-instance) |
---|
3831 | (dolist (superclass (set-difference (class-direct-superclasses class) |
---|
3832 | direct-superclasses)) |
---|
3833 | (remove-direct-subclass superclass class)) |
---|
3834 | (dolist (superclass (set-difference direct-superclasses |
---|
3835 | (class-direct-superclasses class))) |
---|
3836 | (add-direct-subclass superclass class))) |
---|
3837 | |
---|
3838 | (defun std-after-reinitialization-for-classes (class |
---|
3839 | &rest all-keys |
---|
3840 | &key (direct-superclasses nil direct-superclasses-p) |
---|
3841 | (direct-slots nil direct-slots-p) |
---|
3842 | (direct-default-initargs nil direct-default-initargs-p) |
---|
3843 | &allow-other-keys) |
---|
3844 | (remhash class *make-instance-initargs-cache*) |
---|
3845 | (remhash class *reinitialize-instance-initargs-cache*) |
---|
3846 | (%make-instances-obsolete class) |
---|
3847 | (setf (class-finalized-p class) nil) |
---|
3848 | (when direct-superclasses-p |
---|
3849 | (let* ((old-supers (class-direct-superclasses class)) |
---|
3850 | (new-supers (canonicalize-direct-superclass-list |
---|
3851 | class direct-superclasses))) |
---|
3852 | (setf (class-direct-superclasses class) new-supers) |
---|
3853 | (dolist (old-superclass (set-difference old-supers new-supers)) |
---|
3854 | (remove-direct-subclass old-superclass class)) |
---|
3855 | (dolist (new-superclass (set-difference new-supers old-supers)) |
---|
3856 | (add-direct-subclass new-superclass class)))) |
---|
3857 | (when direct-slots-p |
---|
3858 | ;; FIXME: maybe remove old reader and writer methods? |
---|
3859 | (let ((slots (mapcar #'(lambda (slot-properties) |
---|
3860 | (apply #'make-direct-slot-definition class slot-properties)) |
---|
3861 | direct-slots))) |
---|
3862 | (setf (class-direct-slots class) slots) |
---|
3863 | (dolist (direct-slot slots) |
---|
3864 | (dolist (reader (slot-definition-readers direct-slot)) |
---|
3865 | (add-reader-method class reader direct-slot)) |
---|
3866 | (dolist (writer (slot-definition-writers direct-slot)) |
---|
3867 | (add-writer-method class writer direct-slot))))) |
---|
3868 | (when direct-default-initargs-p |
---|
3869 | (setf (class-direct-default-initargs class) direct-default-initargs)) |
---|
3870 | (maybe-finalize-class-subtree class) |
---|
3871 | (map-dependents class #'(lambda (dep) (update-dependent class dep all-keys)))) |
---|
3872 | |
---|
3873 | (defmethod reinitialize-instance :after ((class standard-class) |
---|
3874 | &rest all-keys) |
---|
3875 | (apply #'std-after-reinitialization-for-classes class all-keys)) |
---|
3876 | |
---|
3877 | (defmethod reinitialize-instance :after ((class funcallable-standard-class) |
---|
3878 | &rest all-keys) |
---|
3879 | (apply #'std-after-reinitialization-for-classes class all-keys)) |
---|
3880 | |
---|
3881 | (defmethod reinitialize-instance :before ((gf standard-generic-function) |
---|
3882 | &key |
---|
3883 | (lambda-list nil lambda-list-supplied-p) |
---|
3884 | &allow-other-keys) |
---|
3885 | (when lambda-list-supplied-p |
---|
3886 | (unless (or (null (generic-function-methods gf)) |
---|
3887 | (lambda-lists-congruent-p lambda-list |
---|
3888 | (generic-function-lambda-list gf))) |
---|
3889 | (error "The lambda list ~S is incompatible with the existing methods of ~S." |
---|
3890 | lambda-list gf)))) |
---|
3891 | |
---|
3892 | (defmethod reinitialize-instance :after ((gf standard-generic-function) |
---|
3893 | &rest all-keys) |
---|
3894 | (map-dependents gf #'(lambda (dep) (update-dependent gf dep all-keys)))) |
---|
3895 | |
---|
3896 | ;;; Finalize inheritance |
---|
3897 | |
---|
3898 | (atomic-defgeneric finalize-inheritance (class) |
---|
3899 | (:method ((class standard-class)) |
---|
3900 | (std-finalize-inheritance class)) |
---|
3901 | (:method ((class funcallable-standard-class)) |
---|
3902 | (std-finalize-inheritance class))) |
---|
3903 | |
---|
3904 | ;;; Default initargs |
---|
3905 | |
---|
3906 | ;;; AMOP pg. 174 |
---|
3907 | (atomic-defgeneric compute-default-initargs (class) |
---|
3908 | (:method ((class standard-class)) |
---|
3909 | (std-compute-default-initargs class)) |
---|
3910 | (:method ((class funcallable-standard-class)) |
---|
3911 | (std-compute-default-initargs class))) |
---|
3912 | |
---|
3913 | ;;; Class precedence lists |
---|
3914 | |
---|
3915 | (defgeneric compute-class-precedence-list (class)) |
---|
3916 | (defmethod compute-class-precedence-list ((class standard-class)) |
---|
3917 | (std-compute-class-precedence-list class)) |
---|
3918 | (defmethod compute-class-precedence-list ((class funcallable-standard-class)) |
---|
3919 | (std-compute-class-precedence-list class)) |
---|
3920 | |
---|
3921 | ;;; Slot inheritance |
---|
3922 | |
---|
3923 | (defgeneric compute-slots (class)) |
---|
3924 | (defmethod compute-slots ((class standard-class)) |
---|
3925 | (std-compute-slots class)) |
---|
3926 | (defmethod compute-slots ((class funcallable-standard-class)) |
---|
3927 | (std-compute-slots class)) |
---|
3928 | |
---|
3929 | (defgeneric compute-effective-slot-definition (class name direct-slots)) |
---|
3930 | (defmethod compute-effective-slot-definition |
---|
3931 | ((class standard-class) name direct-slots) |
---|
3932 | (std-compute-effective-slot-definition class name direct-slots)) |
---|
3933 | (defmethod compute-effective-slot-definition |
---|
3934 | ((class funcallable-standard-class) name direct-slots) |
---|
3935 | (std-compute-effective-slot-definition class name direct-slots)) |
---|
3936 | |
---|
3937 | ;;; Methods having to do with generic function invocation. |
---|
3938 | |
---|
3939 | (defgeneric compute-discriminating-function (gf)) |
---|
3940 | (defmethod compute-discriminating-function ((gf standard-generic-function)) |
---|
3941 | (std-compute-discriminating-function gf)) |
---|
3942 | |
---|
3943 | (defgeneric method-more-specific-p (gf method1 method2 required-classes)) |
---|
3944 | |
---|
3945 | (defmethod method-more-specific-p ((gf standard-generic-function) |
---|
3946 | method1 method2 required-classes) |
---|
3947 | (let ((method-indices |
---|
3948 | (argument-precedence-order-indices |
---|
3949 | (generic-function-argument-precedence-order gf) |
---|
3950 | (getf (analyze-lambda-list (generic-function-lambda-list gf)) |
---|
3951 | ':required-args)))) |
---|
3952 | (std-method-more-specific-p method1 method2 required-classes method-indices))) |
---|
3953 | |
---|
3954 | ;;; AMOP pg. 176 |
---|
3955 | (defgeneric compute-effective-method (gf method-combination methods)) |
---|
3956 | (defmethod compute-effective-method ((gf standard-generic-function) method-combination methods) |
---|
3957 | (std-compute-effective-method gf method-combination methods)) |
---|
3958 | |
---|
3959 | (defgeneric compute-applicable-methods (gf args)) |
---|
3960 | (defmethod compute-applicable-methods ((gf standard-generic-function) args) |
---|
3961 | (std-compute-applicable-methods gf args)) |
---|
3962 | |
---|
3963 | ;;; AMOP pg. 207 |
---|
3964 | (atomic-defgeneric make-method-lambda (generic-function method lambda-expression environment) |
---|
3965 | (:method ((generic-function standard-generic-function) |
---|
3966 | (method standard-method) |
---|
3967 | lambda-expression environment) |
---|
3968 | (declare (ignore environment)) |
---|
3969 | (values (compute-method-function lambda-expression) nil))) |
---|
3970 | |
---|
3971 | |
---|
3972 | ;;; Slot definition accessors |
---|
3973 | |
---|
3974 | (defmacro slot-definition-dispatch (slot-definition std-form generic-form) |
---|
3975 | `(let (($cl (class-of ,slot-definition))) |
---|
3976 | (case $cl |
---|
3977 | ((+the-standard-slot-definition-class+ |
---|
3978 | +the-standard-direct-slot-definition-class+ |
---|
3979 | +the-standard-effective-slot-definition-class+) |
---|
3980 | ,std-form) |
---|
3981 | (t ,generic-form)))) |
---|
3982 | |
---|
3983 | (atomic-defgeneric slot-definition-allocation (slot-definition) |
---|
3984 | (:method ((slot-definition slot-definition)) |
---|
3985 | (slot-definition-dispatch slot-definition |
---|
3986 | (std-slot-value slot-definition 'sys::allocation) |
---|
3987 | (slot-value slot-definition 'sys::allocation)))) |
---|
3988 | |
---|
3989 | (atomic-defgeneric (setf slot-definition-allocation) (value slot-definition) |
---|
3990 | (:method (value (slot-definition slot-definition)) |
---|
3991 | (slot-definition-dispatch slot-definition |
---|
3992 | (setf (std-slot-value slot-definition 'sys::allocation) value) |
---|
3993 | (setf (slot-value slot-definition 'sys::allocation) value)))) |
---|
3994 | |
---|
3995 | (atomic-defgeneric slot-definition-initargs (slot-definition) |
---|
3996 | (:method ((slot-definition slot-definition)) |
---|
3997 | (slot-definition-dispatch slot-definition |
---|
3998 | (std-slot-value slot-definition 'sys::initargs) |
---|
3999 | (slot-value slot-definition 'sys::initargs)))) |
---|
4000 | |
---|
4001 | (atomic-defgeneric (setf slot-definition-initargs) (value slot-definition) |
---|
4002 | (:method (value (slot-definition slot-definition)) |
---|
4003 | (slot-definition-dispatch slot-definition |
---|
4004 | (setf (std-slot-value slot-definition 'sys::initargs) value) |
---|
4005 | (setf (slot-value slot-definition 'sys::initargs) value)))) |
---|
4006 | |
---|
4007 | (atomic-defgeneric slot-definition-initform (slot-definition) |
---|
4008 | (:method ((slot-definition slot-definition)) |
---|
4009 | (slot-definition-dispatch slot-definition |
---|
4010 | (std-slot-value slot-definition 'sys::initform) |
---|
4011 | (slot-value slot-definition 'sys::initform)))) |
---|
4012 | |
---|
4013 | (atomic-defgeneric (setf slot-definition-initform) (value slot-definition) |
---|
4014 | (:method (value (slot-definition slot-definition)) |
---|
4015 | (slot-definition-dispatch slot-definition |
---|
4016 | (setf (std-slot-value slot-definition 'sys::initform) value) |
---|
4017 | (setf (slot-value slot-definition 'sys::initform) value)))) |
---|
4018 | |
---|
4019 | (atomic-defgeneric slot-definition-initfunction (slot-definition) |
---|
4020 | (:method ((slot-definition slot-definition)) |
---|
4021 | (slot-definition-dispatch slot-definition |
---|
4022 | (std-slot-value slot-definition 'sys::initfunction) |
---|
4023 | (slot-value slot-definition 'sys::initfunction)))) |
---|
4024 | |
---|
4025 | (atomic-defgeneric (setf slot-definition-initfunction) (value slot-definition) |
---|
4026 | (:method (value (slot-definition slot-definition)) |
---|
4027 | (slot-definition-dispatch slot-definition |
---|
4028 | (setf (std-slot-value slot-definition 'sys::initfunction) value) |
---|
4029 | (setf (slot-value slot-definition 'sys::initfunction) value)))) |
---|
4030 | |
---|
4031 | (atomic-defgeneric slot-definition-name (slot-definition) |
---|
4032 | (:method ((slot-definition slot-definition)) |
---|
4033 | (slot-definition-dispatch slot-definition |
---|
4034 | (std-slot-value slot-definition 'sys:name) |
---|
4035 | (slot-value slot-definition 'sys:name)))) |
---|
4036 | |
---|
4037 | (atomic-defgeneric (setf slot-definition-name) (value slot-definition) |
---|
4038 | (:method (value (slot-definition slot-definition)) |
---|
4039 | (slot-definition-dispatch slot-definition |
---|
4040 | (setf (std-slot-value slot-definition 'sys:name) value) |
---|
4041 | (setf (slot-value slot-definition 'sys:name) value)))) |
---|
4042 | |
---|
4043 | (atomic-defgeneric slot-definition-readers (slot-definition) |
---|
4044 | (:method ((slot-definition slot-definition)) |
---|
4045 | (slot-definition-dispatch slot-definition |
---|
4046 | (std-slot-value slot-definition 'sys::readers) |
---|
4047 | (slot-value slot-definition 'sys::readers)))) |
---|
4048 | |
---|
4049 | (atomic-defgeneric (setf slot-definition-readers) (value slot-definition) |
---|
4050 | (:method (value (slot-definition slot-definition)) |
---|
4051 | (slot-definition-dispatch slot-definition |
---|
4052 | (setf (std-slot-value slot-definition 'sys::readers) value) |
---|
4053 | (setf (slot-value slot-definition 'sys::readers) value)))) |
---|
4054 | |
---|
4055 | (atomic-defgeneric slot-definition-writers (slot-definition) |
---|
4056 | (:method ((slot-definition slot-definition)) |
---|
4057 | (slot-definition-dispatch slot-definition |
---|
4058 | (std-slot-value slot-definition 'sys::writers) |
---|
4059 | (slot-value slot-definition 'sys::writers)))) |
---|
4060 | |
---|
4061 | (atomic-defgeneric (setf slot-definition-writers) (value slot-definition) |
---|
4062 | (:method (value (slot-definition slot-definition)) |
---|
4063 | (slot-definition-dispatch slot-definition |
---|
4064 | (setf (std-slot-value slot-definition 'sys::writers) value) |
---|
4065 | (setf (slot-value slot-definition 'sys::writers) value)))) |
---|
4066 | |
---|
4067 | (atomic-defgeneric slot-definition-allocation-class (slot-definition) |
---|
4068 | (:method ((slot-definition slot-definition)) |
---|
4069 | (slot-definition-dispatch slot-definition |
---|
4070 | (std-slot-value slot-definition 'sys::allocation-class) |
---|
4071 | (slot-value slot-definition 'sys::allocation-class)))) |
---|
4072 | |
---|
4073 | (atomic-defgeneric (setf slot-definition-allocation-class) |
---|
4074 | (value slot-definition) |
---|
4075 | (:method (value (slot-definition slot-definition)) |
---|
4076 | (slot-definition-dispatch slot-definition |
---|
4077 | (setf (std-slot-value slot-definition 'sys::allocation-class) value) |
---|
4078 | (setf (slot-value slot-definition 'sys::allocation-class) value)))) |
---|
4079 | |
---|
4080 | (atomic-defgeneric slot-definition-location (slot-definition) |
---|
4081 | (:method ((slot-definition slot-definition)) |
---|
4082 | (slot-definition-dispatch slot-definition |
---|
4083 | (std-slot-value slot-definition 'sys::location) |
---|
4084 | (slot-value slot-definition 'sys::location)))) |
---|
4085 | |
---|
4086 | (atomic-defgeneric (setf slot-definition-location) (value slot-definition) |
---|
4087 | (:method (value (slot-definition slot-definition)) |
---|
4088 | (slot-definition-dispatch slot-definition |
---|
4089 | (setf (std-slot-value slot-definition 'sys::location) value) |
---|
4090 | (setf (slot-value slot-definition 'sys::location) value)))) |
---|
4091 | |
---|
4092 | (atomic-defgeneric slot-definition-type (slot-definition) |
---|
4093 | (:method ((slot-definition slot-definition)) |
---|
4094 | (slot-definition-dispatch slot-definition |
---|
4095 | (std-slot-value slot-definition 'sys::%type) |
---|
4096 | (slot-value slot-definition 'sys::%type)))) |
---|
4097 | |
---|
4098 | (atomic-defgeneric (setf slot-definition-type) (value slot-definition) |
---|
4099 | (:method (value (slot-definition slot-definition)) |
---|
4100 | (slot-definition-dispatch slot-definition |
---|
4101 | (setf (std-slot-value slot-definition 'sys::%type) value) |
---|
4102 | (setf (slot-value slot-definition 'sys::%type) value)))) |
---|
4103 | |
---|
4104 | (atomic-defgeneric slot-definition-documentation (slot-definition) |
---|
4105 | (:method ((slot-definition slot-definition)) |
---|
4106 | (slot-definition-dispatch slot-definition |
---|
4107 | (std-slot-value slot-definition 'sys:%documentation) |
---|
4108 | (slot-value slot-definition 'sys:%documentation)))) |
---|
4109 | |
---|
4110 | (atomic-defgeneric (setf slot-definition-documentation) (value slot-definition) |
---|
4111 | (:method (value (slot-definition slot-definition)) |
---|
4112 | (slot-definition-dispatch slot-definition |
---|
4113 | (setf (std-slot-value slot-definition 'sys:%documentation) value) |
---|
4114 | (setf (slot-value slot-definition 'sys:%documentation) value)))) |
---|
4115 | |
---|
4116 | |
---|
4117 | ;;; Conditions. |
---|
4118 | |
---|
4119 | (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) &body options) |
---|
4120 | (let ((parent-types (or parent-types '(condition))) |
---|
4121 | (report nil)) |
---|
4122 | (dolist (option options) |
---|
4123 | (when (eq (car option) :report) |
---|
4124 | (setf report (cadr option)) |
---|
4125 | (setf options (delete option options :test #'equal)) |
---|
4126 | (return))) |
---|
4127 | (typecase report |
---|
4128 | (null |
---|
4129 | `(progn |
---|
4130 | (defclass ,name ,parent-types ,slot-specs ,@options) |
---|
4131 | ',name)) |
---|
4132 | (string |
---|
4133 | `(progn |
---|
4134 | (defclass ,name ,parent-types ,slot-specs ,@options) |
---|
4135 | (defmethod print-object ((condition ,name) stream) |
---|
4136 | (if *print-escape* |
---|
4137 | (call-next-method) |
---|
4138 | (progn (write-string ,report stream) condition))) |
---|
4139 | ',name)) |
---|
4140 | (t |
---|
4141 | `(progn |
---|
4142 | (defclass ,name ,parent-types ,slot-specs ,@options) |
---|
4143 | (defmethod print-object ((condition ,name) stream) |
---|
4144 | (if *print-escape* |
---|
4145 | (call-next-method) |
---|
4146 | (funcall #',report condition stream))) |
---|
4147 | ',name))))) |
---|
4148 | |
---|
4149 | (defun make-condition (type &rest initargs) |
---|
4150 | (or (%make-condition type initargs) |
---|
4151 | (let ((class (if (symbolp type) (find-class type) type))) |
---|
4152 | (apply #'make-instance class initargs)))) |
---|
4153 | |
---|
4154 | ;; Adapted from SBCL. |
---|
4155 | ;; Originally defined in signal.lisp. Redefined here now that we have MAKE-CONDITION. |
---|
4156 | (defun coerce-to-condition (datum arguments default-type fun-name) |
---|
4157 | (cond ((typep datum 'condition) |
---|
4158 | (when arguments |
---|
4159 | (error 'simple-type-error |
---|
4160 | :datum arguments |
---|
4161 | :expected-type 'null |
---|
4162 | :format-control "You may not supply additional arguments when giving ~S to ~S." |
---|
4163 | :format-arguments (list datum fun-name))) |
---|
4164 | datum) |
---|
4165 | ((symbolp datum) |
---|
4166 | (apply #'make-condition datum arguments)) |
---|
4167 | ((or (stringp datum) (functionp datum)) |
---|
4168 | (make-condition default-type |
---|
4169 | :format-control datum |
---|
4170 | :format-arguments arguments)) |
---|
4171 | (t |
---|
4172 | (error 'simple-type-error |
---|
4173 | :datum datum |
---|
4174 | :expected-type '(or symbol string) |
---|
4175 | :format-control "Bad argument to ~S: ~S." |
---|
4176 | :format-arguments (list fun-name datum))))) |
---|
4177 | |
---|
4178 | (defgeneric make-load-form (object &optional environment)) |
---|
4179 | |
---|
4180 | (defmethod make-load-form ((object t) &optional environment) |
---|
4181 | (declare (ignore environment)) |
---|
4182 | (apply #'no-applicable-method #'make-load-form (list object))) |
---|
4183 | |
---|
4184 | (defmethod make-load-form ((class class) &optional environment) |
---|
4185 | (declare (ignore environment)) |
---|
4186 | (let ((name (class-name class))) |
---|
4187 | (unless (and name (eq (find-class name nil) class)) |
---|
4188 | (error 'simple-type-error |
---|
4189 | :format-control "Can't use anonymous or undefined class as a constant: ~S." |
---|
4190 | :format-arguments (list class))) |
---|
4191 | `(find-class ',name))) |
---|
4192 | |
---|
4193 | (defun invalid-method-error (method format-control &rest args) |
---|
4194 | (let ((message (apply #'format nil format-control args))) |
---|
4195 | (error "Invalid method error for ~S:~% ~A" method message))) |
---|
4196 | |
---|
4197 | (defun method-combination-error (format-control &rest args) |
---|
4198 | (let ((message (apply #'format nil format-control args))) |
---|
4199 | (error "Method combination error in CLOS dispatch:~% ~A" message))) |
---|
4200 | |
---|
4201 | |
---|
4202 | (atomic-defgeneric no-applicable-method (generic-function &rest args) |
---|
4203 | (:method (generic-function &rest args) |
---|
4204 | (error "There is no applicable method for the generic function ~S ~ |
---|
4205 | when called with arguments ~S." |
---|
4206 | generic-function |
---|
4207 | args))) |
---|
4208 | |
---|
4209 | |
---|
4210 | ;;; FIXME (rudi 2012-01-28): this can be a function, it only needs to |
---|
4211 | ;;; use standard accessor functions |
---|
4212 | (defgeneric find-method (generic-function |
---|
4213 | qualifiers |
---|
4214 | specializers |
---|
4215 | &optional errorp)) |
---|
4216 | |
---|
4217 | (defmethod find-method ((generic-function standard-generic-function) |
---|
4218 | qualifiers specializers &optional (errorp t)) |
---|
4219 | (%find-method generic-function qualifiers specializers errorp)) |
---|
4220 | |
---|
4221 | (defgeneric find-method ((generic-function symbol) |
---|
4222 | qualifiers specializers &optional (errorp t)) |
---|
4223 | (find-method (find-generic-function generic-function errorp) |
---|
4224 | qualifiers specializers errorp)) |
---|
4225 | |
---|
4226 | ;;; AMOP pg. 167 |
---|
4227 | (defgeneric add-method (generic-function method)) |
---|
4228 | |
---|
4229 | (defmethod add-method :before ((generic-function generic-function) |
---|
4230 | (method method)) |
---|
4231 | (when (and (method-generic-function method) |
---|
4232 | (not (eql generic-function (method-generic-function method)))) |
---|
4233 | (error 'simple-error |
---|
4234 | :format-control "~S is already a method of ~S, cannot add to ~S." |
---|
4235 | :format-arguments (list method (method-generic-function method) |
---|
4236 | generic-function))) |
---|
4237 | (check-method-lambda-list (generic-function-name generic-function) |
---|
4238 | (method-lambda-list method) |
---|
4239 | (generic-function-lambda-list generic-function))) |
---|
4240 | |
---|
4241 | (defmethod add-method ((generic-function standard-generic-function) |
---|
4242 | (method standard-method)) |
---|
4243 | (std-add-method generic-function method)) |
---|
4244 | |
---|
4245 | (defmethod add-method :after ((generic-function generic-function) |
---|
4246 | (method method)) |
---|
4247 | (map-dependents generic-function |
---|
4248 | #'(lambda (dep) (update-dependent generic-function dep |
---|
4249 | 'add-method method)))) |
---|
4250 | |
---|
4251 | (defgeneric remove-method (generic-function method)) |
---|
4252 | |
---|
4253 | (defmethod remove-method ((generic-function standard-generic-function) |
---|
4254 | (method standard-method)) |
---|
4255 | (std-remove-method generic-function method)) |
---|
4256 | |
---|
4257 | (defmethod remove-method :after ((generic-function generic-function) |
---|
4258 | (method method)) |
---|
4259 | (map-dependents generic-function |
---|
4260 | #'(lambda (dep) (update-dependent generic-function dep |
---|
4261 | 'remove-method method)))) |
---|
4262 | |
---|
4263 | ;; See describe.lisp. |
---|
4264 | (defgeneric describe-object (object stream)) |
---|
4265 | |
---|
4266 | ;; FIXME |
---|
4267 | (defgeneric no-next-method (generic-function method &rest args)) |
---|
4268 | |
---|
4269 | (atomic-defgeneric function-keywords (method) |
---|
4270 | (:method ((method standard-method)) |
---|
4271 | (std-function-keywords method))) |
---|
4272 | |
---|
4273 | (setf *gf-initialize-instance* (symbol-function 'initialize-instance)) |
---|
4274 | (setf *gf-allocate-instance* (symbol-function 'allocate-instance)) |
---|
4275 | (setf *gf-shared-initialize* (symbol-function 'shared-initialize)) |
---|
4276 | (setf *gf-reinitialize-instance* (symbol-function 'reinitialize-instance)) |
---|
4277 | (setf *clos-booting* nil) |
---|
4278 | |
---|
4279 | (atomic-defgeneric class-prototype (class) |
---|
4280 | (:method ((class standard-class)) |
---|
4281 | (allocate-instance class)) |
---|
4282 | (:method ((class funcallable-standard-class)) |
---|
4283 | (allocate-instance class)) |
---|
4284 | (:method ((class structure-class)) |
---|
4285 | (allocate-instance class)) |
---|
4286 | (:method :before (class) |
---|
4287 | (unless (class-finalized-p class) |
---|
4288 | (error "~@<~S is not finalized.~:@>" class)))) |
---|
4289 | |
---|
4290 | |
---|
4291 | |
---|
4292 | |
---|
4293 | |
---|
4294 | (defmethod shared-initialize :before ((instance generic-function) |
---|
4295 | slot-names |
---|
4296 | &key lambda-list argument-precedence-order |
---|
4297 | &allow-other-keys) |
---|
4298 | (check-argument-precedence-order lambda-list argument-precedence-order)) |
---|
4299 | |
---|
4300 | (defmethod shared-initialize :after ((instance standard-generic-function) |
---|
4301 | slot-names |
---|
4302 | &key lambda-list argument-precedence-order |
---|
4303 | (method-combination '(standard)) |
---|
4304 | &allow-other-keys) |
---|
4305 | (let* ((plist (analyze-lambda-list lambda-list)) |
---|
4306 | (required-args (getf plist ':required-args))) |
---|
4307 | (setf (std-slot-value instance 'sys::required-args) required-args) |
---|
4308 | (setf (std-slot-value instance 'sys::optional-args) |
---|
4309 | (getf plist :optional-args)) |
---|
4310 | (setf (std-slot-value instance 'sys::argument-precedence-order) |
---|
4311 | (or argument-precedence-order required-args))) |
---|
4312 | (unless (typep (generic-function-method-combination instance) |
---|
4313 | 'method-combination) |
---|
4314 | ;; this fixes (make-instance 'standard-generic-function) -- the |
---|
4315 | ;; constructor of StandardGenericFunction sets this slot to '(standard) |
---|
4316 | (setf (std-slot-value instance 'sys::%method-combination) |
---|
4317 | (find-method-combination |
---|
4318 | instance (car method-combination) (cdr method-combination)))) |
---|
4319 | (finalize-standard-generic-function instance)) |
---|
4320 | |
---|
4321 | ;;; Readers for generic function metaobjects |
---|
4322 | ;;; AMOP pg. 216ff. |
---|
4323 | (atomic-defgeneric generic-function-argument-precedence-order (generic-function) |
---|
4324 | (:method ((generic-function standard-generic-function)) |
---|
4325 | (std-slot-value generic-function 'sys::argument-precedence-order))) |
---|
4326 | |
---|
4327 | (atomic-defgeneric generic-function-declarations (generic-function) |
---|
4328 | (:method ((generic-function standard-generic-function)) |
---|
4329 | (std-slot-value generic-function 'sys::declarations))) |
---|
4330 | |
---|
4331 | (atomic-defgeneric generic-function-lambda-list (generic-function) |
---|
4332 | (:method ((generic-function standard-generic-function)) |
---|
4333 | (std-slot-value generic-function 'sys::lambda-list))) |
---|
4334 | |
---|
4335 | (atomic-defgeneric generic-function-method-class (generic-function) |
---|
4336 | (:method ((generic-function standard-generic-function)) |
---|
4337 | (std-slot-value generic-function 'sys::method-class))) |
---|
4338 | |
---|
4339 | (atomic-defgeneric generic-function-method-combination (generic-function) |
---|
4340 | (:method ((generic-function standard-generic-function)) |
---|
4341 | (std-slot-value generic-function 'sys::%method-combination))) |
---|
4342 | |
---|
4343 | (atomic-defgeneric generic-function-methods (generic-function) |
---|
4344 | (:method ((generic-function standard-generic-function)) |
---|
4345 | (std-slot-value generic-function 'sys::methods))) |
---|
4346 | |
---|
4347 | (atomic-defgeneric generic-function-name (generic-function) |
---|
4348 | (:method ((generic-function standard-generic-function)) |
---|
4349 | (slot-value generic-function 'sys::name))) |
---|
4350 | |
---|
4351 | (atomic-defgeneric generic-function-required-arguments (generic-function) |
---|
4352 | (:method ((generic-function standard-generic-function)) |
---|
4353 | (std-slot-value generic-function 'sys::required-args))) |
---|
4354 | |
---|
4355 | (atomic-defgeneric generic-function-optional-arguments (generic-function) |
---|
4356 | (:method ((generic-function standard-generic-function)) |
---|
4357 | (std-slot-value generic-function 'sys::optional-args))) |
---|
4358 | |
---|
4359 | ;;; AMOP pg. 231 |
---|
4360 | (defgeneric (setf generic-function-name) (new-value gf) |
---|
4361 | (:method (new-value (gf generic-function)) |
---|
4362 | (reinitialize-instance gf :name new-value))) |
---|
4363 | |
---|
4364 | ;;; Readers for Method Metaobjects |
---|
4365 | ;;; AMOP pg. 218ff. |
---|
4366 | |
---|
4367 | (atomic-defgeneric method-function (method) |
---|
4368 | (:method ((method standard-method)) |
---|
4369 | (std-method-function method))) |
---|
4370 | |
---|
4371 | (atomic-defgeneric method-generic-function (method) |
---|
4372 | (:method ((method standard-method)) |
---|
4373 | (std-method-generic-function method))) |
---|
4374 | |
---|
4375 | (atomic-defgeneric method-lambda-list (method) |
---|
4376 | (:method ((method standard-method)) |
---|
4377 | (std-slot-value method 'sys::lambda-list))) |
---|
4378 | |
---|
4379 | (atomic-defgeneric method-specializers (method) |
---|
4380 | (:method ((method standard-method)) |
---|
4381 | (std-method-specializers method))) |
---|
4382 | |
---|
4383 | (atomic-defgeneric method-qualifiers (method) |
---|
4384 | (:method ((method standard-method)) |
---|
4385 | (std-method-qualifiers method))) |
---|
4386 | |
---|
4387 | (atomic-defgeneric accessor-method-slot-definition (method) |
---|
4388 | (:method ((method standard-accessor-method)) |
---|
4389 | (std-accessor-method-slot-definition method))) |
---|
4390 | |
---|
4391 | |
---|
4392 | ;;; find-method-combination |
---|
4393 | |
---|
4394 | ;;; AMOP pg. 191 |
---|
4395 | (atomic-defgeneric find-method-combination (gf name options) |
---|
4396 | (:method (gf (name symbol) options) |
---|
4397 | (std-find-method-combination gf name options))) |
---|
4398 | |
---|
4399 | ;;; specializer-direct-method and friends. |
---|
4400 | |
---|
4401 | ;;; AMOP pg. 237 |
---|
4402 | (defgeneric specializer-direct-generic-functions (specializer)) |
---|
4403 | |
---|
4404 | (defmethod specializer-direct-generic-functions ((specializer class)) |
---|
4405 | (delete-duplicates (mapcar #'method-generic-function |
---|
4406 | (class-direct-methods specializer)))) |
---|
4407 | |
---|
4408 | (defmethod specializer-direct-generic-functions ((specializer eql-specializer)) |
---|
4409 | (delete-duplicates (mapcar #'method-generic-function |
---|
4410 | (slot-value specializer 'direct-methods)))) |
---|
4411 | |
---|
4412 | ;;; AMOP pg. 238 |
---|
4413 | (defgeneric specializer-direct-methods (specializer)) |
---|
4414 | |
---|
4415 | (defmethod specializer-direct-methods ((specializer class)) |
---|
4416 | (class-direct-methods specializer)) |
---|
4417 | |
---|
4418 | (defmethod specializer-direct-methods ((specializer eql-specializer)) |
---|
4419 | (slot-value specializer 'direct-methods)) |
---|
4420 | |
---|
4421 | ;;; AMOP pg. 165 |
---|
4422 | (atomic-defgeneric add-direct-method (specializer method) |
---|
4423 | (:method ((specializer class) (method method)) |
---|
4424 | (pushnew method (class-direct-methods specializer))) |
---|
4425 | (:method ((specializer eql-specializer) (method method)) |
---|
4426 | (pushnew method (slot-value specializer 'direct-methods)))) |
---|
4427 | |
---|
4428 | |
---|
4429 | ;;; AMOP pg. 227 |
---|
4430 | (atomic-defgeneric remove-direct-method (specializer method) |
---|
4431 | (:method ((specializer class) (method method)) |
---|
4432 | (setf (class-direct-methods specializer) |
---|
4433 | (remove method (class-direct-methods specializer)))) |
---|
4434 | (:method ((specializer eql-specializer) (method method)) |
---|
4435 | (setf (slot-value specializer 'direct-methods) |
---|
4436 | (remove method (slot-value specializer 'direct-methods))))) |
---|
4437 | |
---|
4438 | ;;; The Dependent Maintenance Protocol (AMOP pg. 160ff.) |
---|
4439 | |
---|
4440 | (defvar *dependents* (make-hash-table :test 'eq :weakness :key)) |
---|
4441 | |
---|
4442 | ;;; AMOP pg. 164 |
---|
4443 | (defgeneric add-dependent (metaobject dependent)) |
---|
4444 | (defmethod add-dependent ((metaobject standard-class) dependent) |
---|
4445 | (pushnew dependent (gethash metaobject *dependents* nil))) |
---|
4446 | (defmethod add-dependent ((metaobject funcallable-standard-class) dependent) |
---|
4447 | (pushnew dependent (gethash metaobject *dependents* nil))) |
---|
4448 | (defmethod add-dependent ((metaobject standard-generic-function) dependent) |
---|
4449 | (pushnew dependent (gethash metaobject *dependents* nil))) |
---|
4450 | |
---|
4451 | ;;; AMOP pg. 225 |
---|
4452 | (defgeneric remove-dependent (metaobject dependent)) |
---|
4453 | (defmethod remove-dependent ((metaobject standard-class) dependent) |
---|
4454 | (setf (gethash metaobject *dependents*) |
---|
4455 | (delete dependent (gethash metaobject *dependents* nil) :test #'eq))) |
---|
4456 | (defmethod remove-dependent ((metaobject funcallable-standard-class) dependent) |
---|
4457 | (setf (gethash metaobject *dependents*) |
---|
4458 | (delete dependent (gethash metaobject *dependents* nil) :test #'eq))) |
---|
4459 | (defmethod remove-dependent ((metaobject standard-generic-function) dependent) |
---|
4460 | (setf (gethash metaobject *dependents*) |
---|
4461 | (delete dependent (gethash metaobject *dependents* nil) :test #'eq))) |
---|
4462 | |
---|
4463 | ;;; AMOP pg. 210 |
---|
4464 | (atomic-defgeneric map-dependents (metaobject function) |
---|
4465 | (:method ((metaobject standard-class) function) |
---|
4466 | (dolist (dependent (gethash metaobject *dependents* nil)) |
---|
4467 | (funcall function dependent))) |
---|
4468 | (:method ((metaobject funcallable-standard-class) function) |
---|
4469 | (dolist (dependent (gethash metaobject *dependents* nil)) |
---|
4470 | (funcall function dependent))) |
---|
4471 | (:method ((metaobject standard-generic-function) function) |
---|
4472 | (dolist (dependent (gethash metaobject *dependents* nil)) |
---|
4473 | (funcall function dependent)))) |
---|
4474 | |
---|
4475 | ;;; AMOP pg. 239 |
---|
4476 | (defgeneric update-dependent (metaobject dependent &rest initargs)) |
---|
4477 | |
---|
4478 | |
---|
4479 | ;;; ensure-generic-function(-using-class), AMOP pg. 185ff. |
---|
4480 | (defgeneric ensure-generic-function-using-class (generic-function function-name |
---|
4481 | &key |
---|
4482 | argument-precedence-order |
---|
4483 | declarations documentation |
---|
4484 | generic-function-class |
---|
4485 | lambda-list method-class |
---|
4486 | method-combination |
---|
4487 | name |
---|
4488 | &allow-other-keys)) |
---|
4489 | |
---|
4490 | (defmethod ensure-generic-function-using-class |
---|
4491 | ((generic-function generic-function) |
---|
4492 | function-name |
---|
4493 | &rest all-keys |
---|
4494 | &key (generic-function-class (class-of generic-function)) |
---|
4495 | (method-class (generic-function-method-class generic-function)) |
---|
4496 | (method-combination (generic-function-method-combination generic-function)) |
---|
4497 | &allow-other-keys) |
---|
4498 | (setf all-keys (copy-list all-keys)) ; since we modify it |
---|
4499 | (remf all-keys :generic-function-class) |
---|
4500 | (unless (classp generic-function-class) |
---|
4501 | (setf generic-function-class (find-class generic-function-class))) |
---|
4502 | (unless (classp method-class) (setf method-class (find-class method-class))) |
---|
4503 | (unless (eq generic-function-class (class-of generic-function)) |
---|
4504 | (error "The class ~S is incompatible with the existing class (~S) of ~S." |
---|
4505 | generic-function-class (class-of generic-function) generic-function)) |
---|
4506 | ;; We used to check for changes in method class here, but CLHS says: |
---|
4507 | ;; "If function-name specifies a generic function that has a different |
---|
4508 | ;; value for the :method-class argument, the value is changed, but any |
---|
4509 | ;; existing methods are not changed." |
---|
4510 | (unless (typep method-combination 'method-combination) |
---|
4511 | (setf method-combination |
---|
4512 | (find-method-combination generic-function |
---|
4513 | (car method-combination) |
---|
4514 | (cdr method-combination)))) |
---|
4515 | (apply #'reinitialize-instance generic-function |
---|
4516 | :method-combination method-combination |
---|
4517 | :method-class method-class |
---|
4518 | all-keys) |
---|
4519 | generic-function) |
---|
4520 | |
---|
4521 | (defmethod ensure-generic-function-using-class ((generic-function null) |
---|
4522 | function-name |
---|
4523 | &rest all-keys |
---|
4524 | &key (generic-function-class +the-standard-generic-function-class+) |
---|
4525 | &allow-other-keys) |
---|
4526 | (setf all-keys (copy-list all-keys)) ; since we modify it |
---|
4527 | (remf all-keys :generic-function-class) |
---|
4528 | (unless (classp generic-function-class) |
---|
4529 | (setf generic-function-class (find-class generic-function-class))) |
---|
4530 | (when (and (null *clos-booting*) (fboundp function-name)) |
---|
4531 | (if (or (autoloadp function-name) |
---|
4532 | (and (consp function-name) |
---|
4533 | (eq 'setf (first function-name)) |
---|
4534 | (autoload-ref-p (second function-name)))) |
---|
4535 | (fmakunbound function-name) |
---|
4536 | (error 'program-error |
---|
4537 | :format-control "~A already names an ordinary function, macro, or special operator." |
---|
4538 | :format-arguments (list function-name)))) |
---|
4539 | (apply (if (eq generic-function-class +the-standard-generic-function-class+) |
---|
4540 | #'make-instance-standard-generic-function |
---|
4541 | #'make-instance) |
---|
4542 | generic-function-class :name function-name all-keys)) |
---|
4543 | |
---|
4544 | (defun ensure-generic-function (function-name &rest all-keys |
---|
4545 | &key |
---|
4546 | lambda-list generic-function-class |
---|
4547 | method-class |
---|
4548 | method-combination |
---|
4549 | argument-precedence-order |
---|
4550 | declarations |
---|
4551 | documentation |
---|
4552 | &allow-other-keys) |
---|
4553 | (declare (ignore lambda-list generic-function-class method-class |
---|
4554 | method-combination argument-precedence-order declarations |
---|
4555 | documentation)) |
---|
4556 | (apply #'ensure-generic-function-using-class |
---|
4557 | (find-generic-function function-name nil) |
---|
4558 | function-name all-keys)) |
---|
4559 | |
---|
4560 | ;;; SLIME compatibility functions. |
---|
4561 | |
---|
4562 | (defun %method-generic-function (method) |
---|
4563 | (method-generic-function method)) |
---|
4564 | |
---|
4565 | (defun %method-function (method) |
---|
4566 | (method-function method)) |
---|
4567 | |
---|
4568 | (eval-when (:compile-toplevel :load-toplevel :execute) |
---|
4569 | (require "MOP")) |
---|
4570 | |
---|
4571 | (provide "CLOS") |
---|
4572 | |
---|