1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
10 ;;;; copyright information from original PCL sources:
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
28 ;;; Methods themselves are simple inanimate objects. Most properties of
29 ;;; methods are immutable, methods cannot be reinitialized. The following
30 ;;; properties of methods can be changed:
31 ;;; METHOD-GENERIC-FUNCTION
35 ;;; Error checking is done in before methods. Because of the simplicity of
36 ;;; standard method objects the standard primary method can fill the slots.
38 ;;; Methods are not reinitializable.
40 (define-condition metaobject-initialization-violation
41 (reference-condition simple-error
)
44 (macrolet ((def (name args control
)
45 `(defmethod ,name
,args
46 (declare (ignore initargs
))
47 (error 'metaobject-initialization-violation
48 :format-control
,(format nil
"~@<~A~@:>" control
)
49 :format-arguments
(list ',name
)
50 :references
(list '(:amop
:initialization method
))))))
51 (def reinitialize-instance
((method method
) &rest initargs
)
52 "Method objects cannot be redefined by ~S.")
53 (def change-class
((method method
) new
&rest initargs
)
54 "Method objects cannot be redefined by ~S.")
55 ;; NEW being a subclass of method is dealt with in the general
56 ;; method of CHANGE-CLASS
57 (def update-instance-for-redefined-class
((method method
) added discarded
59 "No behaviour specified for ~S on method objects.")
60 (def update-instance-for-different-class
(old (new method
) &rest initargs
)
61 "No behaviour specified for ~S on method objects.")
62 (def update-instance-for-different-class
((old method
) new
&rest initargs
)
63 "No behaviour specified for ~S on method objects."))
65 (define-condition invalid-method-initarg
(simple-program-error)
66 ((method :initarg
:method
:reader invalid-method-initarg-method
))
69 (format s
"~@<In initialization of ~S:~2I~_~?~@:>"
70 (invalid-method-initarg-method c
)
71 (simple-condition-format-control c
)
72 (simple-condition-format-arguments c
)))))
74 (defun invalid-method-initarg (method format-control
&rest args
)
75 (error 'invalid-method-initarg
:method method
76 :format-control format-control
:format-arguments args
))
78 (defun check-documentation (method doc
)
79 (unless (or (null doc
) (stringp doc
))
80 (invalid-method-initarg method
"~@<~S of ~S is neither ~S nor a ~S.~@:>"
81 :documentation doc
'null
'string
)))
82 (defun check-lambda-list (method ll
)
85 (defun check-method-function (method fun
)
86 (unless (functionp fun
)
87 (invalid-method-initarg method
"~@<~S of ~S is not a ~S.~@:>"
88 :function fun
'function
)))
90 (defun check-qualifiers (method qualifiers
)
91 (flet ((improper-list ()
92 (invalid-method-initarg method
93 "~@<~S of ~S is an improper list.~@:>"
94 :qualifiers qualifiers
)))
95 (dolist-carefully (q qualifiers improper-list
)
96 (unless (and q
(atom q
))
97 (invalid-method-initarg method
98 "~@<~S, in ~S ~S, is not a non-~S atom.~@:>"
99 q
:qualifiers qualifiers
'null
)))))
101 (defun check-slot-name (method name
)
102 (unless (symbolp name
)
103 (invalid-method-initarg "~@<~S of ~S is not a ~S.~@:>"
104 :slot-name name
'symbol
)))
106 (defun check-specializers (method specializers
)
107 (flet ((improper-list ()
108 (invalid-method-initarg method
109 "~@<~S of ~S is an improper list.~@:>"
110 :specializers specializers
)))
111 (dolist-carefully (s specializers improper-list
)
112 (unless (specializerp s
)
113 (invalid-method-initarg method
114 "~@<~S, in ~S ~S, is not a ~S.~@:>"
115 s
:specializers specializers
'specializer
)))
116 ;; KLUDGE: ANSI says that it's not valid to have methods
117 ;; specializing on classes which are "not defined", leaving
118 ;; unclear what the definedness of a class is; AMOP suggests that
119 ;; forward-referenced-classes, since they have proper names and
120 ;; all, are at least worthy of some level of definition. We allow
121 ;; methods specialized on forward-referenced-classes, but it's
122 ;; non-portable and potentially dubious, so
123 (let ((frcs (remove-if-not #'forward-referenced-class-p specializers
)))
125 (style-warn "~@<Defining a method using ~
126 ~V[~;~1{~S~}~;~1{~S and ~S~}~:;~{~#[~;and ~]~S~^, ~}~] ~
127 as ~2:*~V[~;a specializer~:;specializers~].~@:>"
128 (length frcs
) frcs
)))))
130 (defmethod shared-initialize :before
131 ((method standard-method
) slot-names
&key
132 qualifiers lambda-list specializers function documentation
)
133 (declare (ignore slot-names
))
134 ;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get
135 ;; this extra paranoia and nothing else does; either everything
136 ;; should be aggressively checking initargs, or nothing much should.
137 ;; In either case, it would probably be better to have :type
138 ;; declarations in slots, which would then give a suitable type
139 ;; error (if we implement type-checking for slots...) rather than
140 ;; this hand-crafted thing.
141 (check-qualifiers method qualifiers
)
142 (check-lambda-list method lambda-list
)
143 (check-specializers method specializers
)
144 (check-method-function method function
)
145 (check-documentation method documentation
))
147 (defmethod shared-initialize :before
148 ((method standard-accessor-method
) slot-names
&key
149 slot-name slot-definition
)
150 (declare (ignore slot-names
))
151 (unless slot-definition
152 (check-slot-name method slot-name
)))
154 (defmethod shared-initialize :after
((method standard-method
) slot-names
156 (declare (ignore slot-names
))
157 (initialize-method-function initargs method
))
160 (defvar *the-class-generic-function
*
161 (find-class 'generic-function
))
162 (defvar *the-class-standard-generic-function
*
163 (find-class 'standard-generic-function
))
165 (defmethod shared-initialize :before
166 ((generic-function standard-generic-function
)
168 &key
(name nil namep
)
169 (lambda-list () lambda-list-p
)
170 argument-precedence-order
173 (method-class nil method-class-supplied-p
)
174 (method-combination nil method-combination-supplied-p
))
175 (declare (ignore slot-names
176 declarations argument-precedence-order documentation
177 lambda-list lambda-list-p
))
180 (set-fun-name generic-function name
))
182 (flet ((initarg-error (initarg value string
)
183 (error "when initializing the generic function ~S:~%~
184 The ~S initialization argument was: ~A.~%~
186 generic-function initarg value string
)))
187 (cond (method-class-supplied-p
188 (when (symbolp method-class
)
189 (setq method-class
(find-class method-class
)))
190 (unless (and (classp method-class
)
191 (*subtypep
(class-eq-specializer method-class
)
193 (initarg-error :method-class
195 "a subclass of the class METHOD"))
196 (setf (slot-value generic-function
'method-class
) method-class
))
197 ((slot-boundp generic-function
'method-class
))
199 (initarg-error :method-class
201 "a subclass of the class METHOD")))
202 (cond (method-combination-supplied-p
203 (unless (method-combination-p method-combination
)
204 (initarg-error :method-combination
206 "a method combination object")))
207 ((slot-boundp generic-function
'%method-combination
))
209 (initarg-error :method-combination
211 "a method combination object")))))
213 (defun find-generic-function (name &optional
(errorp t
))
214 (let ((fun (and (fboundp name
) (fdefinition name
))))
216 ((and fun
(typep fun
'generic-function
)) fun
)
217 (errorp (error "No generic function named ~S." name
))
220 (defun real-add-named-method (generic-function-name
224 &rest other-initargs
)
225 (unless (and (fboundp generic-function-name
)
226 (typep (fdefinition generic-function-name
) 'generic-function
))
227 (style-warn "implicitly creating new generic function ~S"
228 generic-function-name
))
229 (let* ((existing-gf (find-generic-function generic-function-name nil
))
232 (ensure-generic-function
233 generic-function-name
234 :generic-function-class
(class-of existing-gf
))
235 (ensure-generic-function generic-function-name
)))
236 (specs (parse-specializers specializers
))
237 (proto (method-prototype-for-gf generic-function-name
))
238 (new (apply #'make-instance
(class-of proto
)
239 :qualifiers qualifiers
241 :lambda-list lambda-list
243 (add-method generic-function new
)
246 (define-condition find-method-length-mismatch
247 (reference-condition simple-error
)
249 (:default-initargs
:references
(list '(:ansi-cl
:function find-method
))))
251 (defun real-get-method (generic-function qualifiers specializers
253 always-check-specializers
)
254 (let ((lspec (length specializers
))
255 (methods (generic-function-methods generic-function
)))
256 (when (or methods always-check-specializers
)
257 (let ((nreq (length (arg-info-metatypes (gf-arg-info
258 generic-function
)))))
259 ;; Since we internally bypass FIND-METHOD by using GET-METHOD
260 ;; instead we need to to this here or users may get hit by a
261 ;; failed AVER instead of a sensible error message.
262 (when (/= lspec nreq
)
264 'find-method-length-mismatch
266 "~@<The generic function ~S takes ~D required argument~:P; ~
267 was asked to find a method with specializers ~S~@:>"
268 :format-arguments
(list generic-function nreq specializers
)))))
270 (dolist (method methods
)
271 (let ((mspecializers (method-specializers method
)))
272 (aver (= lspec
(length mspecializers
)))
273 (when (and (equal qualifiers
(method-qualifiers method
))
274 (every #'same-specializer-p specializers
275 (method-specializers method
)))
280 (error "~@<There is no method on ~S with ~
281 ~:[no qualifiers~;~:*qualifiers ~S~] ~
282 and specializers ~S.~@:>"
283 generic-function qualifiers specializers
))))))
285 (defmethod find-method ((generic-function standard-generic-function
)
286 qualifiers specializers
&optional
(errorp t
))
287 ;; ANSI about FIND-METHOD: "The specializers argument contains the
288 ;; parameter specializers for the method. It must correspond in
289 ;; length to the number of required arguments of the generic
290 ;; function, or an error is signaled."
292 ;; This error checking is done by REAL-GET-METHOD.
293 (real-get-method generic-function
295 (parse-specializers specializers
)
299 ;;; Compute various information about a generic-function's arglist by looking
300 ;;; at the argument lists of the methods. The hair for trying not to use
301 ;;; &REST arguments lives here.
302 ;;; The values returned are:
303 ;;; number-of-required-arguments
304 ;;; the number of required arguments to this generic-function's
305 ;;; discriminating function
307 ;;; whether or not this generic-function's discriminating
308 ;;; function takes an &rest argument.
309 ;;; specialized-argument-positions
310 ;;; a list of the positions of the arguments this generic-function
311 ;;; specializes (e.g. for a classical generic-function this is the
313 (defmethod compute-discriminating-function-arglist-info
314 ((generic-function standard-generic-function
))
315 ;;(declare (values number-of-required-arguments &rest-argument-p
316 ;; specialized-argument-postions))
317 (let ((number-required nil
)
319 (specialized-positions ())
320 (methods (generic-function-methods generic-function
)))
321 (dolist (method methods
)
322 (multiple-value-setq (number-required restp specialized-positions
)
323 (compute-discriminating-function-arglist-info-internal
324 generic-function method number-required restp specialized-positions
)))
325 (values number-required restp
(sort specialized-positions
#'<))))
327 (defun compute-discriminating-function-arglist-info-internal
328 (generic-function method number-of-requireds restp
329 specialized-argument-positions
)
330 (declare (ignore generic-function
)
331 (type (or null fixnum
) number-of-requireds
))
333 (declare (fixnum requireds
))
334 ;; Go through this methods arguments seeing how many are required,
335 ;; and whether there is an &rest argument.
336 (dolist (arg (method-lambda-list method
))
337 (cond ((eq arg
'&aux
) (return))
338 ((memq arg
'(&optional
&rest
&key
))
339 (return (setq restp t
)))
340 ((memq arg lambda-list-keywords
))
341 (t (incf requireds
))))
342 ;; Now go through this method's type specifiers to see which
343 ;; argument positions are type specified. Treat T specially
344 ;; in the usual sort of way. For efficiency don't bother to
345 ;; keep specialized-argument-positions sorted, rather depend
346 ;; on our caller to do that.
348 (dolist (type-spec (method-specializers method
))
349 (unless (eq type-spec
*the-class-t
*)
350 (pushnew pos specialized-argument-positions
))
352 ;; Finally merge the values for this method into the values
353 ;; for the exisiting methods and return them. Note that if
354 ;; num-of-requireds is NIL it means this is the first method
355 ;; and we depend on that.
356 (values (min (or number-of-requireds requireds
) requireds
)
358 (and number-of-requireds
(/= number-of-requireds requireds
)))
359 specialized-argument-positions
)))
361 (defun make-discriminating-function-arglist (number-required-arguments restp
)
362 (nconc (let ((args nil
))
363 (dotimes (i number-required-arguments
)
364 (push (format-symbol *package
* ;; ! is this right?
365 "Discriminating Function Arg ~D"
370 `(&rest
,(format-symbol *package
*
371 "Discriminating Function &rest Arg")))))
373 (defmethod generic-function-argument-precedence-order
374 ((gf standard-generic-function
))
375 (aver (eq *boot-state
* 'complete
))
376 (loop with arg-info
= (gf-arg-info gf
)
377 with lambda-list
= (arg-info-lambda-list arg-info
)
378 for argument-position in
(arg-info-precedence arg-info
)
379 collect
(nth argument-position lambda-list
)))
381 (defmethod generic-function-lambda-list ((gf generic-function
))
384 (defmethod gf-fast-method-function-p ((gf standard-generic-function
))
385 (gf-info-fast-mf-p (slot-value gf
'arg-info
)))
387 (defmethod initialize-instance :after
((gf standard-generic-function
)
388 &key
(lambda-list nil lambda-list-p
)
389 argument-precedence-order
)
390 (with-slots (arg-info) gf
393 :lambda-list lambda-list
394 :argument-precedence-order argument-precedence-order
)
396 (when (arg-info-valid-p arg-info
)
399 (defmethod reinitialize-instance :around
400 ((gf standard-generic-function
) &rest args
&key
401 (lambda-list nil lambda-list-p
) (argument-precedence-order nil apo-p
))
402 (let ((old-mc (generic-function-method-combination gf
)))
403 (prog1 (call-next-method)
404 ;; KLUDGE: EQ is too strong a test.
405 (unless (eq old-mc
(generic-function-method-combination gf
))
406 (flush-effective-method-cache gf
))
408 ((and lambda-list-p apo-p
)
410 :lambda-list lambda-list
411 :argument-precedence-order argument-precedence-order
))
412 (lambda-list-p (set-arg-info gf
:lambda-list lambda-list
))
413 (t (set-arg-info gf
)))
414 (when (arg-info-valid-p (gf-arg-info gf
))
416 (map-dependents gf
(lambda (dependent)
417 (apply #'update-dependent gf dependent args
))))))
419 (declaim (special *lazy-dfun-compute-p
*))
421 (defun set-methods (gf methods
)
422 (setf (generic-function-methods gf
) nil
)
423 (loop (when (null methods
) (return gf
))
424 (real-add-method gf
(pop methods
) methods
)))
426 (define-condition new-value-specialization
(reference-condition error
)
427 ((%method
:initarg
:method
:reader new-value-specialization-method
))
430 (format s
"~@<Cannot add method ~S to ~S, as it specializes the ~
431 new-value argument.~@:>"
432 (new-value-specialization-method c
)
433 #'(setf slot-value-using-class
))))
434 (:default-initargs
:references
435 (list '(:sbcl
:node
"Metaobject Protocol")
436 '(:amop
:generic-function
(setf slot-value-using-class
)))))
438 (defun real-add-method (generic-function method
&optional skip-dfun-update-p
)
439 (when (method-generic-function method
)
440 (error "~@<The method ~S is already part of the generic ~
441 function ~S; it can't be added to another generic ~
442 function until it is removed from the first one.~@:>"
443 method
(method-generic-function method
)))
444 (flet ((similar-lambda-lists-p (method-a method-b
)
445 (multiple-value-bind (a-nreq a-nopt a-keyp a-restp
)
446 (analyze-lambda-list (method-lambda-list method-a
))
447 (multiple-value-bind (b-nreq b-nopt b-keyp b-restp
)
448 (analyze-lambda-list (method-lambda-list method-b
))
449 (and (= a-nreq b-nreq
)
451 (eq (or a-keyp a-restp
)
452 (or b-keyp b-restp
)))))))
453 (let* ((name (generic-function-name generic-function
))
454 (qualifiers (method-qualifiers method
))
455 (specializers (method-specializers method
))
456 (existing (get-method generic-function
461 ;; If there is already a method like this one then we must get
462 ;; rid of it before proceeding. Note that we call the generic
463 ;; function REMOVE-METHOD to remove it rather than doing it in
464 ;; some internal way.
465 (when (and existing
(similar-lambda-lists-p existing method
))
466 (remove-method generic-function existing
))
468 ;; KLUDGE: We have a special case here, as we disallow
469 ;; specializations of the NEW-VALUE argument to (SETF
470 ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is
471 ;; the optimizing function here: it precomputes the effective
472 ;; method, assuming that there is no dispatch to be done on
473 ;; the new-value argument.
474 (when (and (eq generic-function
#'(setf slot-value-using-class
))
475 (not (eq *the-class-t
* (first specializers
))))
476 (error 'new-value-specialization
479 (setf (method-generic-function method
) generic-function
)
480 (pushnew method
(generic-function-methods generic-function
))
481 (dolist (specializer specializers
)
482 (add-direct-method specializer method
))
484 ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
485 ;; detecting attempts to add methods with incongruent lambda
486 ;; lists. However, according to Gerd Moellmann on cmucl-imp,
487 ;; it also depends on the new method already having been added
488 ;; to the generic function. Therefore, we need to remove it
490 (let ((remove-again-p t
))
493 (set-arg-info generic-function
:new-method method
)
494 (setq remove-again-p nil
))
496 (remove-method generic-function method
))))
498 ;; KLUDGE II: ANSI saith that it is not an error to add a
499 ;; method with invalid qualifiers to a generic function of the
500 ;; wrong kind; it's only an error at generic function
501 ;; invocation time; I dunno what the rationale was, and it
502 ;; sucks. Nevertheless, it's probably a programmer error, so
503 ;; let's warn anyway. -- CSR, 2003-08-20
504 (let ((mc (generic-function-method-combination generic-functioN
)))
506 ((eq mc
*standard-method-combination
*)
507 (when (and qualifiers
509 (not (memq (car qualifiers
)
510 '(:around
:before
:after
)))))
511 (warn "~@<Invalid qualifiers for standard method combination ~
512 in method ~S:~2I~_~S.~@:>"
514 ((short-method-combination-p mc
)
515 (let ((mc-name (method-combination-type-name mc
)))
516 (when (or (null qualifiers
)
518 (and (neq (car qualifiers
) :around
)
519 (neq (car qualifiers
) mc-name
)))
520 (warn "~@<Invalid qualifiers for ~S method combination ~
521 in method ~S:~2I~_~S.~@:>"
522 mc-name method qualifiers
))))))
524 (unless skip-dfun-update-p
525 (update-ctors 'add-method
526 :generic-function generic-function
528 (update-dfun generic-function
))
529 (map-dependents generic-function
531 (update-dependent generic-function
532 dep
'add-method method
)))
535 (defun real-remove-method (generic-function method
)
536 (when (eq generic-function
(method-generic-function method
))
537 (let* ((name (generic-function-name generic-function
))
538 (specializers (method-specializers method
))
539 (methods (generic-function-methods generic-function
))
540 (new-methods (remove method methods
)))
541 (setf (method-generic-function method
) nil
)
542 (setf (generic-function-methods generic-function
) new-methods
)
543 (dolist (specializer (method-specializers method
))
544 (remove-direct-method specializer method
))
545 (set-arg-info generic-function
)
546 (update-ctors 'remove-method
547 :generic-function generic-function
549 (update-dfun generic-function
)
550 (map-dependents generic-function
552 (update-dependent generic-function
553 dep
'remove-method method
)))))
556 (defun compute-applicable-methods-function (generic-function arguments
)
557 (values (compute-applicable-methods-using-types
559 (types-from-args generic-function arguments
'eql
))))
561 (defmethod compute-applicable-methods
562 ((generic-function generic-function
) arguments
)
563 (values (compute-applicable-methods-using-types
565 (types-from-args generic-function arguments
'eql
))))
567 (defmethod compute-applicable-methods-using-classes
568 ((generic-function generic-function
) classes
)
569 (compute-applicable-methods-using-types
571 (types-from-args generic-function classes
'class-eq
)))
573 (defun proclaim-incompatible-superclasses (classes)
574 (setq classes
(mapcar (lambda (class)
579 (dolist (class classes
)
580 (dolist (other-class classes
)
581 (unless (eq class other-class
)
582 (pushnew other-class
(class-incompatible-superclass-list class
))))))
584 (defun superclasses-compatible-p (class1 class2
)
585 (let ((cpl1 (cpl-or-nil class1
))
586 (cpl2 (cpl-or-nil class2
)))
588 (dolist (ic (class-incompatible-superclass-list sc1
))
590 (return-from superclasses-compatible-p nil
))))))
593 #'proclaim-incompatible-superclasses
594 '(;; superclass class
595 (built-in-class std-class structure-class
) ; direct subclasses of pcl-class
596 (standard-class funcallable-standard-class
)
597 ;; superclass metaobject
598 (class eql-specializer class-eq-specializer method method-combination
599 generic-function slot-definition
)
600 ;; metaclass built-in-class
601 (number sequence character
; direct subclasses of t, but not array
602 standard-object structure-object
) ; or symbol
603 (number array character symbol
; direct subclasses of t, but not
604 standard-object structure-object
) ; sequence
605 (complex float rational
) ; direct subclasses of number
606 (integer ratio
) ; direct subclasses of rational
607 (list vector
) ; direct subclasses of sequence
608 (cons null
) ; direct subclasses of list
609 (string bit-vector
) ; direct subclasses of vector
612 (defmethod same-specializer-p ((specl1 specializer
) (specl2 specializer
))
615 (defmethod same-specializer-p ((specl1 class
) (specl2 class
))
618 (defmethod specializer-class ((specializer class
))
621 (defmethod same-specializer-p ((specl1 class-eq-specializer
)
622 (specl2 class-eq-specializer
))
623 (eq (specializer-class specl1
) (specializer-class specl2
)))
625 (defmethod same-specializer-p ((specl1 eql-specializer
)
626 (specl2 eql-specializer
))
627 (eq (specializer-object specl1
) (specializer-object specl2
)))
629 (defmethod specializer-class ((specializer eql-specializer
))
630 (class-of (slot-value specializer
'object
)))
632 ;;; KLUDGE: this is needed to allow for user-defined specializers in
633 ;;; RAISE-METATYPE; however, the list of methods is maintained by
634 ;;; hand, which is error-prone. We can't just add a method to
635 ;;; SPECIALIZER-CLASS, or at least not with confidence, as that
636 ;;; function is used elsewhere in PCL. `STANDARD' here is used in the
637 ;;; sense of `comes with PCL' rather than `blessed by the
638 ;;; authorities'. -- CSR, 2007-05-10
639 (defmethod standard-specializer-p ((specializer class
)) t
)
640 (defmethod standard-specializer-p ((specializer eql-specializer
)) t
)
641 (defmethod standard-specializer-p ((specializer class-eq-specializer
)) t
)
642 (defmethod standard-specializer-p ((specializer class-prototype-specializer
))
644 (defmethod standard-specializer-p ((specializer specializer
)) nil
)
646 (defun specializer-class-or-nil (specializer)
647 (and (standard-specializer-p specializer
)
648 (specializer-class specializer
)))
650 (defun error-need-at-least-n-args (function n
)
651 (error 'simple-program-error
652 :format-control
"~@<The function ~2I~_~S ~I~_requires ~
653 at least ~W argument~:P.~:>"
654 :format-arguments
(list function n
)))
656 (defun types-from-args (generic-function arguments
&optional type-modifier
)
657 (multiple-value-bind (nreq applyp metatypes nkeys arg-info
)
658 (get-generic-fun-info generic-function
)
659 (declare (ignore applyp metatypes nkeys
))
660 (let ((types-rev nil
))
661 (dotimes-fixnum (i nreq
)
664 (error-need-at-least-n-args (generic-function-name generic-function
)
666 (let ((arg (pop arguments
)))
667 (push (if type-modifier
`(,type-modifier
,arg
) arg
) types-rev
)))
668 (values (nreverse types-rev
) arg-info
))))
670 (defun get-wrappers-from-classes (nkeys wrappers classes metatypes
)
671 (let* ((w wrappers
) (w-tail w
) (mt-tail metatypes
))
672 (dolist (class (if (listp classes
) classes
(list classes
)))
673 (unless (eq t
(car mt-tail
))
674 (let ((c-w (class-wrapper class
)))
675 (unless c-w
(return-from get-wrappers-from-classes nil
))
678 (setf (car w-tail
) c-w
679 w-tail
(cdr w-tail
)))))
680 (setq mt-tail
(cdr mt-tail
)))
683 (defun sdfun-for-caching (gf classes
)
684 (let ((types (mapcar #'class-eq-type classes
)))
685 (multiple-value-bind (methods all-applicable-and-sorted-p
)
686 (compute-applicable-methods-using-types gf types
)
687 (let ((generator (get-secondary-dispatch-function1
688 gf methods types nil t all-applicable-and-sorted-p
)))
689 (make-callable gf methods generator
690 nil
(mapcar #'class-wrapper classes
))))))
692 (defun value-for-caching (gf classes
)
693 (let ((methods (compute-applicable-methods-using-types
694 gf
(mapcar #'class-eq-type classes
))))
695 (method-plist-value (car methods
) :constant-value
)))
697 (defun default-secondary-dispatch-function (generic-function)
699 (let ((methods (compute-applicable-methods generic-function args
)))
701 (let ((emf (get-effective-method-function generic-function
703 (invoke-emf emf args
))
704 (apply #'no-applicable-method generic-function args
)))))
707 (loop (when (atom x
) (return (eq x y
)))
708 (when (atom y
) (return nil
))
709 (unless (eq (car x
) (car y
)) (return nil
))
713 (defvar *std-cam-methods
* nil
)
715 (defun compute-applicable-methods-emf (generic-function)
716 (if (eq *boot-state
* 'complete
)
717 (let* ((cam (gdefinition 'compute-applicable-methods
))
718 (cam-methods (compute-applicable-methods-using-types
719 cam
(list `(eql ,generic-function
) t
))))
720 (values (get-effective-method-function cam cam-methods
)
722 (or *std-cam-methods
*
723 (setq *std-cam-methods
*
724 (compute-applicable-methods-using-types
725 cam
(list `(eql ,cam
) t
)))))))
726 (values #'compute-applicable-methods-function t
)))
728 (defun compute-applicable-methods-emf-std-p (gf)
729 (gf-info-c-a-m-emf-std-p (gf-arg-info gf
)))
731 (defvar *old-c-a-m-gf-methods
* nil
)
733 (defun update-all-c-a-m-gf-info (c-a-m-gf)
734 (let ((methods (generic-function-methods c-a-m-gf
)))
735 (if (and *old-c-a-m-gf-methods
*
736 (every (lambda (old-method)
737 (member old-method methods
))
738 *old-c-a-m-gf-methods
*))
739 (let ((gfs-to-do nil
)
740 (gf-classes-to-do nil
))
741 (dolist (method methods
)
742 (unless (member method
*old-c-a-m-gf-methods
*)
743 (let ((specl (car (method-specializers method
))))
744 (if (eql-specializer-p specl
)
745 (pushnew (specializer-object specl
) gfs-to-do
)
746 (pushnew (specializer-class specl
) gf-classes-to-do
)))))
747 (map-all-generic-functions
749 (when (or (member gf gfs-to-do
)
750 (dolist (class gf-classes-to-do nil
)
752 (class-precedence-list (class-of gf
)))))
753 (update-c-a-m-gf-info gf
)))))
754 (map-all-generic-functions #'update-c-a-m-gf-info
))
755 (setq *old-c-a-m-gf-methods
* methods
)))
757 (defun update-gf-info (gf)
758 (update-c-a-m-gf-info gf
)
759 (update-gf-simple-accessor-type gf
))
761 (defun update-c-a-m-gf-info (gf)
762 (unless (early-gf-p gf
)
763 (multiple-value-bind (c-a-m-emf std-p
)
764 (compute-applicable-methods-emf gf
)
765 (let ((arg-info (gf-arg-info gf
)))
766 (setf (gf-info-static-c-a-m-emf arg-info
) c-a-m-emf
)
767 (setf (gf-info-c-a-m-emf-std-p arg-info
) std-p
)))))
769 (defun update-gf-simple-accessor-type (gf)
770 (let ((arg-info (gf-arg-info gf
)))
771 (setf (gf-info-simple-accessor-type arg-info
)
772 (let* ((methods (generic-function-methods gf
))
773 (class (and methods
(class-of (car methods
))))
776 (cond ((or (eq class
*the-class-standard-reader-method
*)
777 (eq class
*the-class-global-reader-method
*))
779 ((or (eq class
*the-class-standard-writer-method
*)
780 (eq class
*the-class-global-writer-method
*))
782 ((or (eq class
*the-class-standard-boundp-method
*)
783 (eq class
*the-class-global-boundp-method
*))
785 (when (and (gf-info-c-a-m-emf-std-p arg-info
)
787 (dolist (method (cdr methods
) t
)
788 (unless (eq class
(class-of method
)) (return nil
)))
789 (eq (generic-function-method-combination gf
)
790 *standard-method-combination
*))
794 ;;; CMUCL (Gerd's PCL, 2002-04-25) comment:
796 ;;; Return two values. First value is a function to be stored in
797 ;;; effective slot definition SLOTD for reading it with
798 ;;; SLOT-VALUE-USING-CLASS, setting it with (SETF
799 ;;; SLOT-VALUE-USING-CLASS) or testing it with
800 ;;; SLOT-BOUNDP-USING-CLASS. GF is one of these generic functions,
801 ;;; TYPE is one of the symbols READER, WRITER, BOUNDP. CLASS is
804 ;;; Second value is true if the function returned is one of the
805 ;;; optimized standard functions for the purpose, which are used
806 ;;; when only standard methods are applicable.
808 ;;; FIXME: Change all these wacky function names to something sane.
809 (defun get-accessor-method-function (gf type class slotd
)
810 (let* ((std-method (standard-svuc-method type
))
811 (str-method (structure-svuc-method type
))
812 (types1 `((eql ,class
) (class-eq ,class
) (eql ,slotd
)))
813 (types (if (eq type
'writer
) `(t ,@types1
) types1
))
814 (methods (compute-applicable-methods-using-types gf types
))
815 (std-p (null (cdr methods
))))
818 (get-optimized-std-accessor-method-function class slotd type
)
819 (let* ((optimized-std-fun
820 (get-optimized-std-slot-value-using-class-method-function
823 `((,(car (or (member std-method methods
)
824 (member str-method methods
)
826 'get-accessor-method-function
)))
827 ,optimized-std-fun
)))
829 (let ((wrappers (list (wrapper-of class
)
830 (class-wrapper class
)
831 (wrapper-of slotd
))))
832 (if (eq type
'writer
)
833 (cons (class-wrapper *the-class-t
*) wrappers
)
835 (sdfun (get-secondary-dispatch-function
836 gf methods types method-alist wrappers
)))
837 (get-accessor-from-svuc-method-function class slotd sdfun type
)))
840 ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp)
841 (defun update-slot-value-gf-info (gf type
)
843 (update-std-or-str-methods gf type
))
844 (when (and (standard-svuc-method type
) (structure-svuc-method type
))
845 (flet ((update-accessor-info (class)
846 (when (class-finalized-p class
)
847 (dolist (slotd (class-slots class
))
848 (compute-slot-accessor-info slotd type gf
)))))
850 (update-accessor-info *new-class
*)
851 (map-all-classes #'update-accessor-info
'slot-object
)))))
853 (defvar *standard-slot-value-using-class-method
* nil
)
854 (defvar *standard-setf-slot-value-using-class-method
* nil
)
855 (defvar *standard-slot-boundp-using-class-method
* nil
)
856 (defvar *condition-slot-value-using-class-method
* nil
)
857 (defvar *condition-setf-slot-value-using-class-method
* nil
)
858 (defvar *condition-slot-boundp-using-class-method
* nil
)
859 (defvar *structure-slot-value-using-class-method
* nil
)
860 (defvar *structure-setf-slot-value-using-class-method
* nil
)
861 (defvar *structure-slot-boundp-using-class-method
* nil
)
863 (defun standard-svuc-method (type)
865 (reader *standard-slot-value-using-class-method
*)
866 (writer *standard-setf-slot-value-using-class-method
*)
867 (boundp *standard-slot-boundp-using-class-method
*)))
869 (defun set-standard-svuc-method (type method
)
871 (reader (setq *standard-slot-value-using-class-method
* method
))
872 (writer (setq *standard-setf-slot-value-using-class-method
* method
))
873 (boundp (setq *standard-slot-boundp-using-class-method
* method
))))
875 (defun condition-svuc-method (type)
877 (reader *condition-slot-value-using-class-method
*)
878 (writer *condition-setf-slot-value-using-class-method
*)
879 (boundp *condition-slot-boundp-using-class-method
*)))
881 (defun set-condition-svuc-method (type method
)
883 (reader (setq *condition-slot-value-using-class-method
* method
))
884 (writer (setq *condition-setf-slot-value-using-class-method
* method
))
885 (boundp (setq *condition-slot-boundp-using-class-method
* method
))))
887 (defun structure-svuc-method (type)
889 (reader *structure-slot-value-using-class-method
*)
890 (writer *structure-setf-slot-value-using-class-method
*)
891 (boundp *structure-slot-boundp-using-class-method
*)))
893 (defun set-structure-svuc-method (type method
)
895 (reader (setq *structure-slot-value-using-class-method
* method
))
896 (writer (setq *structure-setf-slot-value-using-class-method
* method
))
897 (boundp (setq *structure-slot-boundp-using-class-method
* method
))))
899 (defun update-std-or-str-methods (gf type
)
900 (dolist (method (generic-function-methods gf
))
901 (let ((specls (method-specializers method
)))
902 (when (and (or (not (eq type
'writer
))
903 (eq (pop specls
) *the-class-t
*))
904 (every #'classp specls
))
905 (cond ((and (eq (class-name (car specls
)) 'std-class
)
906 (eq (class-name (cadr specls
)) 'standard-object
)
907 (eq (class-name (caddr specls
))
908 'standard-effective-slot-definition
))
909 (set-standard-svuc-method type method
))
910 ((and (eq (class-name (car specls
)) 'condition-class
)
911 (eq (class-name (cadr specls
)) 'condition
)
912 (eq (class-name (caddr specls
))
913 'condition-effective-slot-definition
))
914 (set-condition-svuc-method type method
))
915 ((and (eq (class-name (car specls
)) 'structure-class
)
916 (eq (class-name (cadr specls
)) 'structure-object
)
917 (eq (class-name (caddr specls
))
918 'structure-effective-slot-definition
))
919 (set-structure-svuc-method type method
)))))))
921 (defun mec-all-classes-internal (spec precompute-p
)
922 (let ((wrapper (class-wrapper (specializer-class spec
))))
923 (unless (or (not wrapper
) (invalid-wrapper-p wrapper
))
924 (cons (specializer-class spec
)
927 (not (or (eq spec
*the-class-t
*)
928 (eq spec
*the-class-slot-object
*)
929 (eq spec
*the-class-standard-object
*)
930 (eq spec
*the-class-structure-object
*)))
931 (let ((sc (class-direct-subclasses spec
)))
933 (mapcan (lambda (class)
934 (mec-all-classes-internal class precompute-p
))
937 (defun mec-all-classes (spec precompute-p
)
938 (let ((classes (mec-all-classes-internal spec precompute-p
)))
939 (if (null (cdr classes
))
941 (let* ((a-classes (cons nil classes
))
943 (loop (when (null (cdr tail
))
944 (return (cdr a-classes
)))
945 (let ((class (cadr tail
))
947 (if (dolist (c ttail nil
)
948 (when (eq class c
) (return t
)))
949 (setf (cdr tail
) (cddr tail
))
950 (setf tail
(cdr tail
)))))))))
952 (defun mec-all-class-lists (spec-list precompute-p
)
955 (let* ((car-all-classes (mec-all-classes (car spec-list
)
957 (all-class-lists (mec-all-class-lists (cdr spec-list
)
959 (mapcan (lambda (list)
960 (mapcar (lambda (c) (cons c list
)) car-all-classes
))
963 (defun make-emf-cache (generic-function valuep cache classes-list new-class
)
964 (let* ((arg-info (gf-arg-info generic-function
))
965 (nkeys (arg-info-nkeys arg-info
))
966 (metatypes (arg-info-metatypes arg-info
))
967 (wrappers (unless (eq nkeys
1) (make-list nkeys
)))
968 (precompute-p (gf-precompute-dfun-and-emf-p arg-info
)))
969 (flet ((add-class-list (classes)
970 (when (or (null new-class
) (memq new-class classes
))
971 (let ((%wrappers
(get-wrappers-from-classes
972 nkeys wrappers classes metatypes
)))
973 (when (and %wrappers
(not (probe-cache cache %wrappers
)))
974 (let ((value (cond ((eq valuep t
)
975 (sdfun-for-caching generic-function
977 ((eq valuep
:constant-value
)
978 (value-for-caching generic-function
980 ;; need to get them again, as finalization might
981 ;; have happened in between, which would
982 ;; invalidate wrappers.
983 (let ((wrappers (get-wrappers-from-classes
984 nkeys wrappers classes metatypes
)))
985 (when (if (atom wrappers
)
986 (not (invalid-wrapper-p wrappers
))
987 (every (complement #'invalid-wrapper-p
)
989 (setq cache
(fill-cache cache wrappers value
))))))))))
991 (mapc #'add-class-list classes-list
)
992 (dolist (method (generic-function-methods generic-function
))
993 (mapc #'add-class-list
994 (mec-all-class-lists (method-specializers method
)
998 (defmacro class-test
(arg class
)
1000 ((eq class
*the-class-t
*) t
)
1001 ((eq class
*the-class-slot-object
*)
1002 `(not (typep (classoid-of ,arg
) 'built-in-classoid
)))
1003 ((eq class
*the-class-standard-object
*)
1004 `(or (std-instance-p ,arg
) (fsc-instance-p ,arg
)))
1005 ((eq class
*the-class-funcallable-standard-object
*)
1006 `(fsc-instance-p ,arg
))
1008 `(typep ,arg
',(class-name class
)))))
1010 (defmacro class-eq-test
(arg class
)
1011 `(eq (class-of ,arg
) ',class
))
1013 (defmacro eql-test
(arg object
)
1014 `(eql ,arg
',object
))
1016 (defun dnet-methods-p (form)
1018 (or (eq (car form
) 'methods
)
1019 (eq (car form
) 'unordered-methods
))))
1021 ;;; This is CASE, but without gensyms.
1022 (defmacro scase
(arg &rest clauses
)
1023 `(let ((.case-arg.
,arg
))
1024 (cond ,@(mapcar (lambda (clause)
1025 (list* (cond ((null (car clause
))
1027 ((consp (car clause
))
1028 (if (null (cdar clause
))
1033 ((member (car clause
) '(t otherwise
))
1036 `(eql .case-arg.
',(car clause
))))
1041 (defmacro mcase
(arg &rest clauses
) `(scase ,arg
,@clauses
))
1043 (defun generate-discrimination-net (generic-function methods types sorted-p
)
1044 (let* ((arg-info (gf-arg-info generic-function
))
1045 (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info
))
1046 (precedence (arg-info-precedence arg-info
)))
1047 (generate-discrimination-net-internal
1048 generic-function methods types
1049 (lambda (methods known-types
)
1051 (and c-a-m-emf-std-p
1053 (let ((sorted-methods nil
))
1055 (copy-list methods
) precedence
1057 (when sorted-methods
(return-from one-order-p nil
))
1058 (setq sorted-methods methods
)))
1059 (setq methods sorted-methods
))
1061 `(methods ,methods
,known-types
)
1062 `(unordered-methods ,methods
,known-types
)))
1063 (lambda (position type true-value false-value
)
1064 (let ((arg (dfun-arg-symbol position
)))
1065 (if (eq (car type
) 'eql
)
1066 (let* ((false-case-p (and (consp false-value
)
1067 (or (eq (car false-value
) 'scase
)
1068 (eq (car false-value
) 'mcase
))
1069 (eq arg
(cadr false-value
))))
1070 (false-clauses (if false-case-p
1072 `((t ,false-value
))))
1073 (case-sym (if (and (dnet-methods-p true-value
)
1075 (eq (car false-value
) 'mcase
)
1076 (dnet-methods-p false-value
)))
1079 (type-sym `(,(cadr type
))))
1081 (,type-sym
,true-value
)
1083 `(if ,(let ((arg (dfun-arg-symbol position
)))
1085 (class `(class-test ,arg
,(cadr type
)))
1086 (class-eq `(class-eq-test ,arg
,(cadr type
)))))
1091 (defun class-from-type (type)
1092 (if (or (atom type
) (eq (car type
) t
))
1095 (and (dolist (type (cdr type
) *the-class-t
*)
1096 (when (and (consp type
) (not (eq (car type
) 'not
)))
1097 (return (class-from-type type
)))))
1099 (eql (class-of (cadr type
)))
1100 (class-eq (cadr type
))
1101 (class (cadr type
)))))
1103 (defun precompute-effective-methods (gf caching-p
&optional classes-list-p
)
1104 (let* ((arg-info (gf-arg-info gf
))
1105 (methods (generic-function-methods gf
))
1106 (precedence (arg-info-precedence arg-info
))
1107 (*in-precompute-effective-methods-p
* t
)
1109 (generate-discrimination-net-internal
1111 (lambda (methods known-types
)
1113 (when classes-list-p
1114 (push (mapcar #'class-from-type known-types
) classes-list
))
1115 (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
1120 (get-secondary-dispatch-function1
1121 gf methods known-types
1122 nil caching-p no-eql-specls-p
))))))
1123 (lambda (position type true-value false-value
)
1124 (declare (ignore position type true-value false-value
))
1127 (if (and (consp type
) (eq (car type
) 'eql
))
1128 `(class-eq ,(class-of (cadr type
)))
1132 ;;; We know that known-type implies neither new-type nor `(not ,new-type).
1133 (defun augment-type (new-type known-type
)
1134 (if (or (eq known-type t
)
1135 (eq (car new-type
) 'eql
))
1137 (let ((so-far (if (and (consp known-type
) (eq (car known-type
) 'and
))
1139 (list known-type
))))
1140 (unless (eq (car new-type
) 'not
)
1142 (mapcan (lambda (type)
1143 (unless (*subtypep new-type type
)
1148 `(and ,new-type
,@so-far
)))))
1150 (defun generate-discrimination-net-internal
1151 (gf methods types methods-function test-fun type-function
)
1152 (let* ((arg-info (gf-arg-info gf
))
1153 (precedence (arg-info-precedence arg-info
))
1154 (nreq (arg-info-number-required arg-info
))
1155 (metatypes (arg-info-metatypes arg-info
)))
1156 (labels ((do-column (p-tail contenders known-types
)
1158 (let* ((position (car p-tail
))
1159 (known-type (or (nth position types
) t
)))
1160 (if (eq (nth position metatypes
) t
)
1161 (do-column (cdr p-tail
) contenders
1162 (cons (cons position known-type
)
1164 (do-methods p-tail contenders
1165 known-type
() known-types
)))
1166 (funcall methods-function contenders
1167 (let ((k-t (make-list nreq
)))
1168 (dolist (index+type known-types
)
1169 (setf (nth (car index
+type
) k-t
)
1172 (do-methods (p-tail contenders known-type winners known-types
)
1174 ;; is a (sorted) list of methods that must be discriminated.
1176 ;; is the type of this argument, constructed from tests
1179 ;; is a (sorted) list of methods that are potentially
1180 ;; applicable after the discrimination has been made.
1181 (if (null contenders
)
1182 (do-column (cdr p-tail
)
1184 (cons (cons (car p-tail
) known-type
)
1186 (let* ((position (car p-tail
))
1187 (method (car contenders
))
1188 (specl (nth position
(method-specializers method
)))
1189 (type (funcall type-function
1190 (type-from-specializer specl
))))
1191 (multiple-value-bind (app-p maybe-app-p
)
1192 (specializer-applicable-using-type-p type known-type
)
1193 (flet ((determined-to-be (truth-value)
1194 (if truth-value app-p
(not maybe-app-p
)))
1195 (do-if (truth &optional implied
)
1196 (let ((ntype (if truth type
`(not ,type
))))
1201 (augment-type ntype known-type
))
1203 (append winners
`(,method
))
1206 (cond ((determined-to-be nil
) (do-if nil t
))
1207 ((determined-to-be t
) (do-if t t
))
1208 (t (funcall test-fun position type
1209 (do-if t
) (do-if nil
))))))))))
1210 (do-column precedence methods
()))))
1212 (defun compute-secondary-dispatch-function (generic-function net
&optional
1213 method-alist wrappers
)
1214 (function-funcall (compute-secondary-dispatch-function1 generic-function net
)
1215 method-alist wrappers
))
1217 (defvar *eq-case-table-limit
* 15)
1218 (defvar *case-table-limit
* 10)
1220 (defun compute-mcase-parameters (case-list)
1221 (unless (eq t
(caar (last case-list
)))
1222 (error "The key for the last case arg to mcase was not T"))
1223 (let* ((eq-p (dolist (case case-list t
)
1224 (unless (or (eq (car case
) t
)
1225 (symbolp (caar case
)))
1227 (len (1- (length case-list
)))
1228 (type (cond ((= len
1)
1232 *eq-case-table-limit
*
1233 *case-table-limit
*))
1239 (defmacro mlookup
(key info default
&optional eq-p type
)
1240 (unless (or (eq eq-p t
) (null eq-p
))
1241 (bug "Invalid eq-p argument: ~S" eq-p
))
1245 (declare (optimize (inhibit-warnings 3)))
1246 (,(if eq-p
'eq
'eql
) ,key
(car ,info
)))
1250 `(dolist (e ,info
,default
)
1252 (declare (optimize (inhibit-warnings 3)))
1253 (,(if eq-p
'eq
'eql
) (car e
) ,key
))
1256 `(gethash ,key
,info
,default
))))
1258 (defun net-test-converter (form)
1260 (default-test-converter form
)
1262 ((invoke-effective-method-function invoke-fast-method-call
1263 invoke-effective-narrow-method-function
)
1270 `(mlookup ,(cadr form
)
1273 ,@(compute-mcase-parameters (cddr form
))))
1274 (t (default-test-converter form
)))))
1276 (defun net-code-converter (form)
1278 (default-code-converter form
)
1280 ((methods unordered-methods
)
1281 (let ((gensym (gensym)))
1285 (let ((mp (compute-mcase-parameters (cddr form
)))
1286 (gensym (gensym)) (default (gensym)))
1287 (values `(mlookup ,(cadr form
) ,gensym
,default
,@mp
)
1288 (list gensym default
))))
1290 (default-code-converter form
)))))
1292 (defun net-constant-converter (form generic-function
)
1293 (or (let ((c (methods-converter form generic-function
)))
1296 (default-constant-converter form
)
1299 (let* ((mp (compute-mcase-parameters (cddr form
)))
1300 (list (mapcar (lambda (clause)
1301 (let ((key (car clause
))
1302 (meth (cadr clause
)))
1303 (cons (if (consp key
) (car key
) key
)
1305 meth generic-function
))))
1307 (default (car (last list
))))
1308 (list (list* :mcase mp
(nbutlast list
))
1311 (default-constant-converter form
))))))
1313 (defun methods-converter (form generic-function
)
1314 (cond ((and (consp form
) (eq (car form
) 'methods
))
1316 (get-effective-method-function1 generic-function
(cadr form
))))
1317 ((and (consp form
) (eq (car form
) 'unordered-methods
))
1318 (default-secondary-dispatch-function generic-function
))))
1320 (defun convert-methods (constant method-alist wrappers
)
1321 (if (and (consp constant
)
1322 (eq (car constant
) '.methods.
))
1323 (funcall (cdr constant
) method-alist wrappers
)
1326 (defun convert-table (constant method-alist wrappers
)
1327 (cond ((and (consp constant
)
1328 (eq (car constant
) :mcase
))
1329 (let ((alist (mapcar (lambda (k+m
)
1331 (convert-methods (cdr k
+m
)
1335 (mp (cadr constant
)))
1342 (let ((table (make-hash-table :test
(if (car mp
) 'eq
'eql
))))
1344 (setf (gethash (car k
+m
) table
) (cdr k
+m
)))
1347 (defun compute-secondary-dispatch-function1 (generic-function net
1348 &optional function-p
)
1350 ((and (eq (car net
) 'methods
) (not function-p
))
1351 (get-effective-method-function1 generic-function
(cadr net
)))
1353 (let* ((name (generic-function-name generic-function
))
1354 (arg-info (gf-arg-info generic-function
))
1355 (metatypes (arg-info-metatypes arg-info
))
1356 (nargs (length metatypes
))
1357 (applyp (arg-info-applyp arg-info
))
1358 (fmc-arg-info (cons nargs applyp
))
1359 (arglist (if function-p
1360 (make-dfun-lambda-list nargs applyp
)
1361 (make-fast-method-call-lambda-list nargs applyp
))))
1362 (multiple-value-bind (cfunction constants
)
1365 ,@(unless function-p
1366 `((declare (ignore .pv-cell. .next-method-call.
))))
1367 (locally (declare #.
*optimize-speed
*)
1369 ,(make-emf-call nargs applyp
'emf
))))
1370 #'net-test-converter
1371 #'net-code-converter
1373 (net-constant-converter form generic-function
)))
1374 (lambda (method-alist wrappers
)
1375 (let* ((alist (list nil
))
1377 (dolist (constant constants
)
1378 (let* ((a (or (dolist (a alist nil
)
1379 (when (eq (car a
) constant
)
1383 constant method-alist wrappers
)
1385 constant method-alist wrappers
)))))
1387 (setf (cdr alist-tail
) new
)
1388 (setf alist-tail new
)))
1389 (let ((function (apply cfunction
(mapcar #'cdr
(cdr alist
)))))
1392 (make-fast-method-call
1393 :function
(set-fun-name function
`(sdfun-method ,name
))
1394 :arg-info fmc-arg-info
))))))))))
1396 (defvar *show-make-unordered-methods-emf-calls
* nil
)
1398 (defun make-unordered-methods-emf (generic-function methods
)
1399 (when *show-make-unordered-methods-emf-calls
*
1400 (format t
"~&make-unordered-methods-emf ~S~%"
1401 (generic-function-name generic-function
)))
1402 (lambda (&rest args
)
1403 (let* ((types (types-from-args generic-function args
'eql
))
1404 (smethods (sort-applicable-methods generic-function
1407 (emf (get-effective-method-function generic-function smethods
)))
1408 (invoke-emf emf args
))))
1410 ;;; The value returned by compute-discriminating-function is a function
1411 ;;; object. It is called a discriminating function because it is called
1412 ;;; when the generic function is called and its role is to discriminate
1413 ;;; on the arguments to the generic function and then call appropriate
1414 ;;; method functions.
1416 ;;; A discriminating function can only be called when it is installed as
1417 ;;; the funcallable instance function of the generic function for which
1418 ;;; it was computed.
1420 ;;; More precisely, if compute-discriminating-function is called with
1421 ;;; an argument <gf1>, and returns a result <df1>, that result must
1422 ;;; not be passed to apply or funcall directly. Rather, <df1> must be
1423 ;;; stored as the funcallable instance function of the same generic
1424 ;;; function <gf1> (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the
1425 ;;; generic function can be passed to funcall or apply.
1427 ;;; An important exception is that methods on this generic function are
1428 ;;; permitted to return a function which itself ends up calling the value
1429 ;;; returned by a more specific method. This kind of `encapsulation' of
1430 ;;; discriminating function is critical to many uses of the MOP.
1432 ;;; As an example, the following canonical case is legal:
1434 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1435 ;;; (let ((std (call-next-method)))
1437 ;;; (print (list 'call-to-gf gf arg))
1438 ;;; (funcall std arg))))
1440 ;;; Because many discriminating functions would like to use a dynamic
1441 ;;; strategy in which the precise discriminating function changes with
1442 ;;; time it is important to specify how a discriminating function is
1443 ;;; permitted itself to change the funcallable instance function of the
1444 ;;; generic function.
1446 ;;; Discriminating functions may set the funcallable instance function
1447 ;;; of the generic function, but the new value must be generated by making
1448 ;;; a call to COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any
1449 ;;; more specific methods which may have encapsulated the discriminating
1450 ;;; function will get a chance to encapsulate the new, inner discriminating
1453 ;;; This implies that if a discriminating function wants to modify itself
1454 ;;; it should first store some information in the generic function proper,
1455 ;;; and then call compute-discriminating-function. The appropriate method
1456 ;;; on compute-discriminating-function will see the information stored in
1457 ;;; the generic function and generate a discriminating function accordingly.
1459 ;;; The following is an example of a discriminating function which modifies
1460 ;;; itself in accordance with this protocol:
1462 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1464 ;;; (cond (<some condition>
1465 ;;; <store some info in the generic function>
1466 ;;; (set-funcallable-instance-function
1468 ;;; (compute-discriminating-function gf))
1469 ;;; (funcall gf arg))
1471 ;;; <call-a-method-of-gf>))))
1473 ;;; Whereas this code would not be legal:
1475 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1477 ;;; (cond (<some condition>
1478 ;;; (set-funcallable-instance-function
1480 ;;; (lambda (a) ..))
1481 ;;; (funcall gf arg))
1483 ;;; <call-a-method-of-gf>))))
1485 ;;; NOTE: All the examples above assume that all instances of the class
1486 ;;; my-generic-function accept only one argument.
1488 (defun slot-value-using-class-dfun (class object slotd
)
1489 (declare (ignore class
))
1490 (function-funcall (slot-definition-reader-function slotd
) object
))
1492 (defun setf-slot-value-using-class-dfun (new-value class object slotd
)
1493 (declare (ignore class
))
1494 (function-funcall (slot-definition-writer-function slotd
) new-value object
))
1496 (defun slot-boundp-using-class-dfun (class object slotd
)
1497 (declare (ignore class
))
1498 (function-funcall (slot-definition-boundp-function slotd
) object
))
1500 (defun special-case-for-compute-discriminating-function-p (gf)
1501 (or (eq gf
#'slot-value-using-class
)
1502 (eq gf
#'(setf slot-value-using-class
))
1503 (eq gf
#'slot-boundp-using-class
)))
1505 (defmethod compute-discriminating-function ((gf standard-generic-function
))
1506 (with-slots (dfun-state arg-info
) gf
1507 (when (special-case-for-compute-discriminating-function-p gf
)
1508 ;; if we have a special case for
1509 ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
1510 ;; special cases implemented as of 2006-05-09) any information
1511 ;; in the cache is misplaced.
1512 (aver (null dfun-state
)))
1513 (typecase dfun-state
1515 (when (eq gf
#'compute-applicable-methods
)
1516 (update-all-c-a-m-gf-info gf
))
1518 ((eq gf
#'slot-value-using-class
)
1519 (update-slot-value-gf-info gf
'reader
)
1520 #'slot-value-using-class-dfun
)
1521 ((eq gf
#'(setf slot-value-using-class
))
1522 (update-slot-value-gf-info gf
'writer
)
1523 #'setf-slot-value-using-class-dfun
)
1524 ((eq gf
#'slot-boundp-using-class
)
1525 (update-slot-value-gf-info gf
'boundp
)
1526 #'slot-boundp-using-class-dfun
)
1527 ((gf-precompute-dfun-and-emf-p arg-info
)
1528 (make-final-dfun gf
))
1530 (make-initial-dfun gf
))))
1531 (function dfun-state
)
1532 (cons (car dfun-state
)))))
1534 (defmethod update-gf-dfun ((class std-class
) gf
)
1535 (let ((*new-class
* class
)
1536 (arg-info (gf-arg-info gf
)))
1538 ((special-case-for-compute-discriminating-function-p gf
))
1539 ((gf-precompute-dfun-and-emf-p arg-info
)
1540 (multiple-value-bind (dfun cache info
)
1541 (make-final-dfun-internal gf
)
1542 ;; FIXME: What does the next comment mean? Presumably it
1543 ;; refers to the age-old implementation where cache vectors
1544 ;; where cached resources? Also, the first thing UPDATE-DFUN
1545 ;; does it SET-DFUN, so do we really need it here?
1546 (set-dfun gf dfun cache info
) ; lest the cache be freed twice
1547 (update-dfun gf dfun cache info
))))))
1549 (defmethod (setf class-name
) (new-value class
)
1550 (let ((classoid (wrapper-classoid (class-wrapper class
))))
1551 (if (and new-value
(symbolp new-value
))
1552 (setf (classoid-name classoid
) new-value
)
1553 (setf (classoid-name classoid
) nil
)))
1554 (reinitialize-instance class
:name new-value
)
1557 (defmethod (setf generic-function-name
) (new-value generic-function
)
1558 (reinitialize-instance generic-function
:name new-value
)
1561 (defmethod function-keywords ((method standard-method
))
1562 (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords
)
1563 (analyze-lambda-list (if (consp method
)
1564 (early-method-lambda-list method
)
1565 (method-lambda-list method
)))
1566 (declare (ignore nreq nopt keysp restp
))
1567 (values keywords allow-other-keys-p
)))
1569 (defun method-ll->generic-function-ll
(ll)
1570 (multiple-value-bind
1571 (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters
)
1572 (analyze-lambda-list ll
)
1573 (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords
))
1574 (remove-if (lambda (s)
1575 (or (memq s keyword-parameters
)
1576 (eq s
'&allow-other-keys
)))
1579 ;;; This is based on the rules of method lambda list congruency defined in
1580 ;;; the spec. The lambda list it constructs is the pretty union of the
1581 ;;; lambda lists of all the methods. It doesn't take method applicability
1582 ;;; into account at all yet.
1583 (defmethod generic-function-pretty-arglist
1584 ((generic-function standard-generic-function
))
1585 (let ((methods (generic-function-methods generic-function
)))
1588 ;; arglist is constructed from the GF's methods - maybe with
1589 ;; keys and rest stuff added
1590 (multiple-value-bind (required optional rest key allow-other-keys
)
1591 (method-pretty-arglist (car methods
))
1592 (dolist (m (cdr methods
))
1593 (multiple-value-bind (method-key-keywords
1594 method-allow-other-keys
1596 (function-keywords m
)
1597 ;; we've modified function-keywords to return what we want as
1598 ;; the third value, no other change here.
1599 (declare (ignore method-key-keywords
))
1600 (setq key
(union key method-key
))
1601 (setq allow-other-keys
(or allow-other-keys
1602 method-allow-other-keys
))))
1603 (when allow-other-keys
1604 (setq arglist
'(&allow-other-keys
)))
1606 (setq arglist
(nconc (list '&key
) key arglist
)))
1608 (setq arglist
(nconc (list '&rest rest
) arglist
)))
1610 (setq arglist
(nconc (list '&optional
) optional arglist
)))
1611 (nconc required arglist
)))
1612 ;; otherwise we take the lambda-list from the GF directly, with no
1613 ;; other 'keys' added ...
1614 (let ((lambda-list (generic-function-lambda-list generic-function
)))
1617 (defmethod method-pretty-arglist ((method standard-method
))
1622 (allow-other-keys nil
)
1624 (arglist (method-lambda-list method
)))
1625 (dolist (arg arglist
)
1626 (cond ((eq arg
'&optional
) (setq state
'optional
))
1627 ((eq arg
'&rest
) (setq state
'rest
))
1628 ((eq arg
'&key
) (setq state
'key
))
1629 ((eq arg
'&allow-other-keys
) (setq allow-other-keys t
))
1630 ((memq arg lambda-list-keywords
))
1633 (required (push arg required
))
1634 (optional (push arg optional
))
1635 (key (push arg key
))
1636 (rest (setq rest arg
))))))
1637 (values (nreverse required
)