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
29 ;;; Methods themselves are simple inanimate objects. Most properties of
30 ;;; methods are immutable, methods cannot be reinitialized. The following
31 ;;; properties of methods can be changed:
32 ;;; METHOD-GENERIC-FUNCTION
33 ;;; METHOD-FUNCTION ??
35 (defmethod method-function ((method standard-method
))
36 (or (slot-value method
'function
)
37 (let ((fmf (slot-value method
'fast-function
)))
38 (unless fmf
; The :BEFORE SHARED-INITIALIZE method prevents this.
39 (error "~S doesn't seem to have a METHOD-FUNCTION." method
))
40 (setf (slot-value method
'function
)
41 (method-function-from-fast-function fmf
)))))
43 (defmethod accessor-method-class ((method standard-accessor-method
))
44 (car (slot-value method
'specializers
)))
46 (defmethod accessor-method-class ((method standard-writer-method
))
47 (cadr (slot-value method
'specializers
)))
51 ;;; Error checking is done in before methods. Because of the simplicity of
52 ;;; standard method objects the standard primary method can fill the slots.
54 ;;; Methods are not reinitializable.
56 (defmethod reinitialize-instance ((method standard-method
) &rest initargs
)
57 (declare (ignore initargs
))
58 (error "An attempt was made to reinitialize the method ~S.~%~
59 Method objects cannot be reinitialized."
62 (defmethod legal-documentation-p ((object standard-method
) x
)
63 (if (or (null x
) (stringp x
))
67 (defmethod legal-lambda-list-p ((object standard-method
) x
)
71 (defmethod legal-method-function-p ((object standard-method
) x
)
76 (defmethod legal-qualifiers-p ((object standard-method
) x
)
77 (flet ((improper-list ()
78 (return-from legal-qualifiers-p
"Is not a proper list.")))
79 (dolist-carefully (q x improper-list
)
80 (let ((ok (legal-qualifier-p object q
)))
82 (return-from legal-qualifiers-p
83 (format nil
"Contains ~S which ~A" q ok
)))))
86 (defmethod legal-qualifier-p ((object standard-method
) x
)
89 "is not a non-null atom"))
91 (defmethod legal-slot-name-p ((object standard-method
) x
)
92 (cond ((not (symbolp x
)) "is not a symbol")
95 (defmethod legal-specializers-p ((object standard-method
) x
)
96 (flet ((improper-list ()
97 (return-from legal-specializers-p
"Is not a proper list.")))
98 (dolist-carefully (s x improper-list
)
99 (let ((ok (legal-specializer-p object s
)))
101 (return-from legal-specializers-p
102 (format nil
"Contains ~S which ~A" s ok
)))))
105 (defvar *allow-experimental-specializers-p
* nil
)
107 (defmethod legal-specializer-p ((object standard-method
) x
)
108 (if (if *allow-experimental-specializers-p
*
111 (eql-specializer-p x
)))
113 "is neither a class object nor an EQL specializer"))
115 (defmethod shared-initialize :before
((method standard-method
)
123 (declare (ignore slot-names
))
124 (flet ((lose (initarg value string
)
125 (error "when initializing the method ~S:~%~
126 The ~S initialization argument was: ~S.~%~
128 method initarg value string
)))
129 (let ((check-qualifiers (legal-qualifiers-p method qualifiers
))
130 (check-lambda-list (legal-lambda-list-p method lambda-list
))
131 (check-specializers (legal-specializers-p method specializers
))
132 (check-fun (legal-method-function-p method
135 (check-documentation (legal-documentation-p method documentation
)))
136 (unless (eq check-qualifiers t
)
137 (lose :qualifiers qualifiers check-qualifiers
))
138 (unless (eq check-lambda-list t
)
139 (lose :lambda-list lambda-list check-lambda-list
))
140 (unless (eq check-specializers t
)
141 (lose :specializers specializers check-specializers
))
142 (unless (eq check-fun t
)
143 (lose :function function check-fun
))
144 (unless (eq check-documentation t
)
145 (lose :documentation documentation check-documentation
)))))
147 (defmethod shared-initialize :before
((method standard-accessor-method
)
149 &key slot-name slot-definition
)
150 (declare (ignore slot-names
))
151 (unless slot-definition
152 (let ((legalp (legal-slot-name-p method slot-name
)))
153 ;; FIXME: nasty convention; should be renamed to ILLEGAL-SLOT-NAME-P and
154 ;; ILLEGALP, and the convention redone to be less twisty
155 (unless (eq legalp t
)
156 (error "The value of the :SLOT-NAME initarg ~A." legalp
)))))
158 (defmethod shared-initialize :after
((method standard-method
) slot-names
160 &key qualifiers method-spec plist
)
161 (declare (ignore slot-names method-spec plist
))
162 (initialize-method-function initargs nil method
)
163 (setf (plist-value method
'qualifiers
) qualifiers
)
165 (setf (slot-value method
'closure-generator
)
166 (method-function-closure-generator (slot-value method
'function
))))
168 (defmethod shared-initialize :after
((method standard-accessor-method
)
171 (declare (ignore slot-names
))
172 (with-slots (slot-name slot-definition
)
174 (unless slot-definition
175 (let ((class (accessor-method-class method
)))
176 (when (slot-class-p class
)
177 (setq slot-definition
(find slot-name
(class-direct-slots class
)
178 :key
#'slot-definition-name
)))))
179 (when (and slot-definition
(null slot-name
))
180 (setq slot-name
(slot-definition-name slot-definition
)))))
182 (defmethod method-qualifiers ((method standard-method
))
183 (plist-value method
'qualifiers
))
185 (defvar *the-class-generic-function
*
186 (find-class 'generic-function
))
187 (defvar *the-class-standard-generic-function
*
188 (find-class 'standard-generic-function
))
190 (defmethod shared-initialize :before
191 ((generic-function standard-generic-function
)
193 &key
(name nil namep
)
194 (lambda-list () lambda-list-p
)
195 argument-precedence-order
198 (method-class nil method-class-supplied-p
)
199 (method-combination nil method-combination-supplied-p
))
200 (declare (ignore slot-names
201 declarations argument-precedence-order documentation
202 lambda-list lambda-list-p
))
205 (set-fun-name generic-function name
))
207 (flet ((initarg-error (initarg value string
)
208 (error "when initializing the generic function ~S:~%~
209 The ~S initialization argument was: ~A.~%~
211 generic-function initarg value string
)))
212 (cond (method-class-supplied-p
213 (when (symbolp method-class
)
214 (setq method-class
(find-class method-class
)))
215 (unless (and (classp method-class
)
216 (*subtypep
(class-eq-specializer method-class
)
218 (initarg-error :method-class
220 "a subclass of the class METHOD"))
221 (setf (slot-value generic-function
'method-class
) method-class
))
222 ((slot-boundp generic-function
'method-class
))
224 (initarg-error :method-class
226 "a subclass of the class METHOD")))
227 (cond (method-combination-supplied-p
228 (unless (method-combination-p method-combination
)
229 (initarg-error :method-combination
231 "a method combination object")))
232 ((slot-boundp generic-function
'method-combination
))
234 (initarg-error :method-combination
236 "a method combination object")))))
239 (defmethod reinitialize-instance ((generic-function standard-generic-function
)
243 argument-precedence-order
248 (declare (ignore documentation declarations argument-precedence-order
249 lambda-list name method-class method-combination
))
250 (macrolet ((add-initarg (check name slot-name
)
252 (push (slot-value generic-function
,slot-name
) initargs
)
253 (push ,name initargs
))))
254 ; (add-initarg name :name 'name)
255 ; (add-initarg lambda-list :lambda-list 'lambda-list)
256 ; (add-initarg argument-precedence-order
257 ; :argument-precedence-order
258 ; 'argument-precedence-order)
259 ; (add-initarg declarations :declarations 'declarations)
260 ; (add-initarg documentation :documentation 'documentation)
261 ; (add-initarg method-class :method-class 'method-class)
262 ; (add-initarg method-combination :method-combination 'method-combination)
263 (apply #'call-next-method generic-function initargs
)))
266 ;;; These two are scheduled for demolition.
267 (defun real-add-named-method (generic-function-name
271 &rest other-initargs
)
272 (unless (and (fboundp generic-function-name
)
273 (typep (fdefinition generic-function-name
) 'generic-function
))
274 (style-warn "implicitly creating new generic function ~S"
275 generic-function-name
))
276 ;; XXX What about changing the class of the generic function if
277 ;; there is one? Whose job is that, anyway? Do we need something
278 ;; kind of like CLASS-FOR-REDEFINITION?
279 (let* ((generic-function
280 (ensure-generic-function generic-function-name
))
281 (specs (parse-specializers specializers
))
282 (proto (method-prototype-for-gf generic-function-name
))
283 (new (apply #'make-instance
(class-of proto
)
284 :qualifiers qualifiers
286 :lambda-list lambda-list
288 (add-method generic-function new
)
291 (defun real-get-method (generic-function qualifiers specializers
292 &optional
(errorp t
))
293 (let* ((lspec (length specializers
))
295 (dolist (method (generic-function-methods generic-function
))
296 (let ((mspecializers (method-specializers method
)))
297 (aver (= lspec
(length mspecializers
)))
298 (when (and (equal qualifiers
(method-qualifiers method
))
299 (every #'same-specializer-p specializers
300 (method-specializers method
)))
305 (error "~@<There is no method on ~S with ~
306 ~:[no qualifiers~;~:*qualifiers ~S~] ~
307 and specializers ~S.~@:>"
308 generic-function qualifiers specializers
)))))
310 (defmethod find-method ((generic-function standard-generic-function
)
311 qualifiers specializers
&optional
(errorp t
))
312 (let ((nreq (length (arg-info-metatypes (gf-arg-info generic-function
)))))
313 ;; ANSI: "The specializers argument contains the parameter
314 ;; specializers for the method. It must correspond in length to
315 ;; the number of required arguments of the generic function, or an
316 ;; error is signaled."
317 (when (/= (length specializers
) nreq
)
318 (error "~@<The generic function ~S takes ~D required argument~:P; ~
319 was asked to find a method with specializers ~S~@:>"
320 generic-function nreq specializers
))
321 (real-get-method generic-function qualifiers
322 (parse-specializers specializers
) errorp
)))
324 ;;; Compute various information about a generic-function's arglist by looking
325 ;;; at the argument lists of the methods. The hair for trying not to use
326 ;;; &REST arguments lives here.
327 ;;; The values returned are:
328 ;;; number-of-required-arguments
329 ;;; the number of required arguments to this generic-function's
330 ;;; discriminating function
332 ;;; whether or not this generic-function's discriminating
333 ;;; function takes an &rest argument.
334 ;;; specialized-argument-positions
335 ;;; a list of the positions of the arguments this generic-function
336 ;;; specializes (e.g. for a classical generic-function this is the
338 (defmethod compute-discriminating-function-arglist-info
339 ((generic-function standard-generic-function
))
340 ;;(declare (values number-of-required-arguments &rest-argument-p
341 ;; specialized-argument-postions))
342 (let ((number-required nil
)
344 (specialized-positions ())
345 (methods (generic-function-methods generic-function
)))
346 (dolist (method methods
)
347 (multiple-value-setq (number-required restp specialized-positions
)
348 (compute-discriminating-function-arglist-info-internal
349 generic-function method number-required restp specialized-positions
)))
350 (values number-required restp
(sort specialized-positions
#'<))))
352 (defun compute-discriminating-function-arglist-info-internal
353 (generic-function method number-of-requireds restp
354 specialized-argument-positions
)
355 (declare (ignore generic-function
)
356 (type (or null fixnum
) number-of-requireds
))
358 (declare (fixnum requireds
))
359 ;; Go through this methods arguments seeing how many are required,
360 ;; and whether there is an &rest argument.
361 (dolist (arg (method-lambda-list method
))
362 (cond ((eq arg
'&aux
) (return))
363 ((memq arg
'(&optional
&rest
&key
))
364 (return (setq restp t
)))
365 ((memq arg lambda-list-keywords
))
366 (t (incf requireds
))))
367 ;; Now go through this method's type specifiers to see which
368 ;; argument positions are type specified. Treat T specially
369 ;; in the usual sort of way. For efficiency don't bother to
370 ;; keep specialized-argument-positions sorted, rather depend
371 ;; on our caller to do that.
373 (dolist (type-spec (method-specializers method
))
374 (unless (eq type-spec
*the-class-t
*)
375 (pushnew pos specialized-argument-positions
))
377 ;; Finally merge the values for this method into the values
378 ;; for the exisiting methods and return them. Note that if
379 ;; num-of-requireds is NIL it means this is the first method
380 ;; and we depend on that.
381 (values (min (or number-of-requireds requireds
) requireds
)
383 (and number-of-requireds
(/= number-of-requireds requireds
)))
384 specialized-argument-positions
)))
386 (defun make-discriminating-function-arglist (number-required-arguments restp
)
387 (nconc (let ((args nil
))
388 (dotimes (i number-required-arguments
)
389 (push (intern (format nil
"Discriminating Function Arg ~D" i
))
393 `(&rest
,(intern "Discriminating Function &rest Arg")))))
395 (defmethod generic-function-argument-precedence-order
396 ((gf standard-generic-function
))
397 (aver (eq *boot-state
* 'complete
))
398 (loop with arg-info
= (gf-arg-info gf
)
399 with lambda-list
= (arg-info-lambda-list arg-info
)
400 for argument-position in
(arg-info-precedence arg-info
)
401 collect
(nth argument-position lambda-list
)))
403 (defmethod generic-function-lambda-list ((gf generic-function
))
406 (defmethod gf-fast-method-function-p ((gf standard-generic-function
))
407 (gf-info-fast-mf-p (slot-value gf
'arg-info
)))
409 (defmethod initialize-instance :after
((gf standard-generic-function
)
410 &key
(lambda-list nil lambda-list-p
)
411 argument-precedence-order
)
412 (with-slots (arg-info) gf
415 :lambda-list lambda-list
416 :argument-precedence-order argument-precedence-order
)
418 (when (arg-info-valid-p arg-info
)
421 (defmethod reinitialize-instance :around
422 ((gf standard-generic-function
) &rest args
&key
423 (lambda-list nil lambda-list-p
) (argument-precedence-order nil apo-p
))
424 (let ((old-mc (generic-function-method-combination gf
)))
425 (prog1 (call-next-method)
426 ;; KLUDGE: EQ is too strong a test.
427 (unless (eq old-mc
(generic-function-method-combination gf
))
428 (flush-effective-method-cache gf
))
430 ((and lambda-list-p apo-p
)
432 :lambda-list lambda-list
433 :argument-precedence-order argument-precedence-order
))
434 (lambda-list-p (set-arg-info gf
:lambda-list lambda-list
))
435 (t (set-arg-info gf
)))
436 (when (and (arg-info-valid-p (gf-arg-info gf
))
438 (or lambda-list-p
(cddr args
)))
441 (declaim (special *lazy-dfun-compute-p
*))
443 (defun set-methods (gf methods
)
444 (setf (generic-function-methods gf
) nil
)
445 (loop (when (null methods
) (return gf
))
446 (real-add-method gf
(pop methods
) methods
)))
448 (defun real-add-method (generic-function method
&optional skip-dfun-update-p
)
449 (when (method-generic-function method
)
450 (error "~@<The method ~S is already part of the generic ~
451 function ~S; it can't be added to another generic ~
452 function until it is removed from the first one.~@:>"
453 method
(method-generic-function method
)))
454 (flet ((similar-lambda-lists-p (method-a method-b
)
455 (multiple-value-bind (a-nreq a-nopt a-keyp a-restp
)
456 (analyze-lambda-list (method-lambda-list method-a
))
457 (multiple-value-bind (b-nreq b-nopt b-keyp b-restp
)
458 (analyze-lambda-list (method-lambda-list method-b
))
459 (and (= a-nreq b-nreq
)
461 (eq (or a-keyp a-restp
)
462 (or b-keyp b-restp
)))))))
463 (let* ((name (generic-function-name generic-function
))
464 (qualifiers (method-qualifiers method
))
465 (specializers (method-specializers method
))
466 (existing (get-method generic-function
471 ;; If there is already a method like this one then we must get
472 ;; rid of it before proceeding. Note that we call the generic
473 ;; function REMOVE-METHOD to remove it rather than doing it in
474 ;; some internal way.
475 (when (and existing
(similar-lambda-lists-p existing method
))
476 (remove-method generic-function existing
))
478 (setf (method-generic-function method
) generic-function
)
479 (pushnew method
(generic-function-methods generic-function
))
480 (dolist (specializer specializers
)
481 (add-direct-method specializer method
))
483 ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
484 ;; detecting attempts to add methods with incongruent lambda
485 ;; lists. However, according to Gerd Moellmann on cmucl-imp,
486 ;; it also depends on the new method already having been added
487 ;; to the generic function. Therefore, we need to remove it
489 (let ((remove-again-p t
))
492 (set-arg-info generic-function
:new-method method
)
493 (setq remove-again-p nil
))
495 (remove-method generic-function method
))))
497 ;; KLUDGE II: ANSI saith that it is not an error to add a
498 ;; method with invalid qualifiers to a generic function of the
499 ;; wrong kind; it's only an error at generic function
500 ;; invocation time; I dunno what the rationale was, and it
501 ;; sucks. Nevertheless, it's probably a programmer error, so
502 ;; let's warn anyway. -- CSR, 2003-08-20
503 (let ((mc (generic-function-method-combination generic-functioN
)))
505 ((eq mc
*standard-method-combination
*)
506 (when (and qualifiers
508 (not (memq (car qualifiers
)
509 '(:around
:before
:after
)))))
510 (warn "~@<Invalid qualifiers for standard method combination ~
511 in method ~S:~2I~_~S.~@:>"
513 ((short-method-combination-p mc
)
514 (let ((mc-name (method-combination-type mc
)))
515 (when (or (null qualifiers
)
517 (and (neq (car qualifiers
) :around
)
518 (neq (car qualifiers
) mc-name
)))
519 (warn "~@<Invalid qualifiers for ~S method combination ~
520 in method ~S:~2I~_~S.~@:>"
521 mc-name method qualifiers
))))))
523 (unless skip-dfun-update-p
524 (update-ctors 'add-method
525 :generic-function generic-function
527 (update-dfun generic-function
))
530 (defun real-remove-method (generic-function method
)
531 (when (eq generic-function
(method-generic-function method
))
532 (let* ((name (generic-function-name generic-function
))
533 (specializers (method-specializers method
))
534 (methods (generic-function-methods generic-function
))
535 (new-methods (remove method methods
)))
536 (setf (method-generic-function method
) nil
)
537 (setf (generic-function-methods generic-function
) new-methods
)
538 (dolist (specializer (method-specializers method
))
539 (remove-direct-method specializer method
))
540 (set-arg-info generic-function
)
541 (update-ctors 'remove-method
542 :generic-function generic-function
544 (update-dfun generic-function
)))
547 (defun compute-applicable-methods-function (generic-function arguments
)
548 (values (compute-applicable-methods-using-types
550 (types-from-args generic-function arguments
'eql
))))
552 (defmethod compute-applicable-methods
553 ((generic-function generic-function
) arguments
)
554 (values (compute-applicable-methods-using-types
556 (types-from-args generic-function arguments
'eql
))))
558 (defmethod compute-applicable-methods-using-classes
559 ((generic-function generic-function
) classes
)
560 (compute-applicable-methods-using-types
562 (types-from-args generic-function classes
'class-eq
)))
564 (defun proclaim-incompatible-superclasses (classes)
565 (setq classes
(mapcar (lambda (class)
570 (dolist (class classes
)
571 (dolist (other-class classes
)
572 (unless (eq class other-class
)
573 (pushnew other-class
(class-incompatible-superclass-list class
))))))
575 (defun superclasses-compatible-p (class1 class2
)
576 (let ((cpl1 (cpl-or-nil class1
))
577 (cpl2 (cpl-or-nil class2
)))
579 (dolist (ic (class-incompatible-superclass-list sc1
))
581 (return-from superclasses-compatible-p nil
))))))
584 #'proclaim-incompatible-superclasses
585 '(;; superclass class
586 (built-in-class std-class structure-class
) ; direct subclasses of pcl-class
587 (standard-class funcallable-standard-class
)
588 ;; superclass metaobject
589 (class eql-specializer class-eq-specializer method method-combination
590 generic-function slot-definition
)
591 ;; metaclass built-in-class
592 (number sequence character
; direct subclasses of t, but not array
593 standard-object structure-object
) ; or symbol
594 (number array character symbol
; direct subclasses of t, but not
595 standard-object structure-object
) ; sequence
596 (complex float rational
) ; direct subclasses of number
597 (integer ratio
) ; direct subclasses of rational
598 (list vector
) ; direct subclasses of sequence
599 (cons null
) ; direct subclasses of list
600 (string bit-vector
) ; direct subclasses of vector
603 (defmethod same-specializer-p ((specl1 specializer
) (specl2 specializer
))
606 (defmethod same-specializer-p ((specl1 class
) (specl2 class
))
609 (defmethod specializer-class ((specializer class
))
612 (defmethod same-specializer-p ((specl1 class-eq-specializer
)
613 (specl2 class-eq-specializer
))
614 (eq (specializer-class specl1
) (specializer-class specl2
)))
616 (defmethod same-specializer-p ((specl1 eql-specializer
)
617 (specl2 eql-specializer
))
618 (eq (specializer-object specl1
) (specializer-object specl2
)))
620 (defmethod specializer-class ((specializer eql-specializer
))
621 (class-of (slot-value specializer
'object
)))
623 (defvar *in-gf-arg-info-p
* nil
)
624 (setf (gdefinition 'arg-info-reader
)
625 (let ((mf (initialize-method-function
626 (make-internal-reader-method-function
627 'standard-generic-function
'arg-info
)
629 (lambda (&rest args
) (funcall mf args nil
))))
632 (defun error-need-at-least-n-args (function n
)
633 (error "~@<The function ~2I~_~S ~I~_requires at least ~W argument~:P.~:>"
637 (defun types-from-args (generic-function arguments
&optional type-modifier
)
638 (multiple-value-bind (nreq applyp metatypes nkeys arg-info
)
639 (get-generic-fun-info generic-function
)
640 (declare (ignore applyp metatypes nkeys
))
641 (let ((types-rev nil
))
642 (dotimes-fixnum (i nreq
)
645 (error-need-at-least-n-args (generic-function-name generic-function
)
647 (let ((arg (pop arguments
)))
648 (push (if type-modifier
`(,type-modifier
,arg
) arg
) types-rev
)))
649 (values (nreverse types-rev
) arg-info
))))
651 (defun get-wrappers-from-classes (nkeys wrappers classes metatypes
)
652 (let* ((w wrappers
) (w-tail w
) (mt-tail metatypes
))
653 (dolist (class (if (listp classes
) classes
(list classes
)))
654 (unless (eq t
(car mt-tail
))
655 (let ((c-w (class-wrapper class
)))
656 (unless c-w
(return-from get-wrappers-from-classes nil
))
659 (setf (car w-tail
) c-w
660 w-tail
(cdr w-tail
)))))
661 (setq mt-tail
(cdr mt-tail
)))
664 (defun sdfun-for-caching (gf classes
)
665 (let ((types (mapcar #'class-eq-type classes
)))
666 (multiple-value-bind (methods all-applicable-and-sorted-p
)
667 (compute-applicable-methods-using-types gf types
)
668 (let ((generator (get-secondary-dispatch-function1
669 gf methods types nil t all-applicable-and-sorted-p
)))
670 (make-callable gf methods generator
671 nil
(mapcar #'class-wrapper classes
))))))
673 (defun value-for-caching (gf classes
)
674 (let ((methods (compute-applicable-methods-using-types
675 gf
(mapcar #'class-eq-type classes
))))
676 (method-function-get (or (method-fast-function (car methods
))
677 (method-function (car methods
)))
680 (defun default-secondary-dispatch-function (generic-function)
682 (let ((methods (compute-applicable-methods generic-function args
)))
684 (let ((emf (get-effective-method-function generic-function
686 (invoke-emf emf args
))
687 (apply #'no-applicable-method generic-function args
)))))
690 (loop (when (atom x
) (return (eq x y
)))
691 (when (atom y
) (return nil
))
692 (unless (eq (car x
) (car y
)) (return nil
))
693 (setq x
(cdr x
) y
(cdr y
))))
695 (defvar *std-cam-methods
* nil
)
697 (defun compute-applicable-methods-emf (generic-function)
698 (if (eq *boot-state
* 'complete
)
699 (let* ((cam (gdefinition 'compute-applicable-methods
))
700 (cam-methods (compute-applicable-methods-using-types
701 cam
(list `(eql ,generic-function
) t
))))
702 (values (get-effective-method-function cam cam-methods
)
704 (or *std-cam-methods
*
705 (setq *std-cam-methods
*
706 (compute-applicable-methods-using-types
707 cam
(list `(eql ,cam
) t
)))))))
708 (values #'compute-applicable-methods-function t
)))
710 (defun compute-applicable-methods-emf-std-p (gf)
711 (gf-info-c-a-m-emf-std-p (gf-arg-info gf
)))
713 (defvar *old-c-a-m-gf-methods
* nil
)
715 (defun update-all-c-a-m-gf-info (c-a-m-gf)
716 (let ((methods (generic-function-methods c-a-m-gf
)))
717 (if (and *old-c-a-m-gf-methods
*
718 (every (lambda (old-method)
719 (member old-method methods
))
720 *old-c-a-m-gf-methods
*))
721 (let ((gfs-to-do nil
)
722 (gf-classes-to-do nil
))
723 (dolist (method methods
)
724 (unless (member method
*old-c-a-m-gf-methods
*)
725 (let ((specl (car (method-specializers method
))))
726 (if (eql-specializer-p specl
)
727 (pushnew (specializer-object specl
) gfs-to-do
)
728 (pushnew (specializer-class specl
) gf-classes-to-do
)))))
729 (map-all-generic-functions
731 (when (or (member gf gfs-to-do
)
732 (dolist (class gf-classes-to-do nil
)
734 (class-precedence-list (class-of gf
)))))
735 (update-c-a-m-gf-info gf
)))))
736 (map-all-generic-functions #'update-c-a-m-gf-info
))
737 (setq *old-c-a-m-gf-methods
* methods
)))
739 (defun update-gf-info (gf)
740 (update-c-a-m-gf-info gf
)
741 (update-gf-simple-accessor-type gf
))
743 (defun update-c-a-m-gf-info (gf)
744 (unless (early-gf-p gf
)
745 (multiple-value-bind (c-a-m-emf std-p
)
746 (compute-applicable-methods-emf gf
)
747 (let ((arg-info (gf-arg-info gf
)))
748 (setf (gf-info-static-c-a-m-emf arg-info
) c-a-m-emf
)
749 (setf (gf-info-c-a-m-emf-std-p arg-info
) std-p
)))))
751 (defun update-gf-simple-accessor-type (gf)
752 (let ((arg-info (gf-arg-info gf
)))
753 (setf (gf-info-simple-accessor-type arg-info
)
754 (let* ((methods (generic-function-methods gf
))
755 (class (and methods
(class-of (car methods
))))
758 *the-class-standard-reader-method
*)
761 *the-class-standard-writer-method
*)
764 *the-class-standard-boundp-method
*)
766 (when (and (gf-info-c-a-m-emf-std-p arg-info
)
768 (dolist (method (cdr methods
) t
)
769 (unless (eq class
(class-of method
)) (return nil
)))
770 (eq (generic-function-method-combination gf
)
771 *standard-method-combination
*))
775 ;;; CMUCL (Gerd's PCL, 2002-04-25) comment:
777 ;;; Return two values. First value is a function to be stored in
778 ;;; effective slot definition SLOTD for reading it with
779 ;;; SLOT-VALUE-USING-CLASS, setting it with (SETF
780 ;;; SLOT-VALUE-USING-CLASS) or testing it with
781 ;;; SLOT-BOUNDP-USING-CLASS. GF is one of these generic functions,
782 ;;; TYPE is one of the symbols READER, WRITER, BOUNDP. CLASS is
785 ;;; Second value is true if the function returned is one of the
786 ;;; optimized standard functions for the purpose, which are used
787 ;;; when only standard methods are applicable.
789 ;;; FIXME: Change all these wacky function names to something sane.
790 (defun get-accessor-method-function (gf type class slotd
)
791 (let* ((std-method (standard-svuc-method type
))
792 (str-method (structure-svuc-method type
))
793 (types1 `((eql ,class
) (class-eq ,class
) (eql ,slotd
)))
794 (types (if (eq type
'writer
) `(t ,@types1
) types1
))
795 (methods (compute-applicable-methods-using-types gf types
))
796 (std-p (null (cdr methods
))))
799 (get-optimized-std-accessor-method-function class slotd type
)
800 (let* ((optimized-std-fun
801 (get-optimized-std-slot-value-using-class-method-function
804 `((,(car (or (member std-method methods
)
805 (member str-method methods
)
807 'get-accessor-method-function
)))
808 ,optimized-std-fun
)))
810 (let ((wrappers (list (wrapper-of class
)
811 (class-wrapper class
)
812 (wrapper-of slotd
))))
813 (if (eq type
'writer
)
814 (cons (class-wrapper *the-class-t
*) wrappers
)
816 (sdfun (get-secondary-dispatch-function
817 gf methods types method-alist wrappers
)))
818 (get-accessor-from-svuc-method-function class slotd sdfun type
)))
821 ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp)
822 (defun update-slot-value-gf-info (gf type
)
824 (update-std-or-str-methods gf type
))
825 (when (and (standard-svuc-method type
) (structure-svuc-method type
))
826 (flet ((update-class (class)
827 (when (class-finalized-p class
)
828 (dolist (slotd (class-slots class
))
829 (compute-slot-accessor-info slotd type gf
)))))
831 (update-class *new-class
*)
832 (map-all-classes #'update-class
'slot-object
)))))
834 (defvar *standard-slot-value-using-class-method
* nil
)
835 (defvar *standard-setf-slot-value-using-class-method
* nil
)
836 (defvar *standard-slot-boundp-using-class-method
* nil
)
837 (defvar *condition-slot-value-using-class-method
* nil
)
838 (defvar *condition-setf-slot-value-using-class-method
* nil
)
839 (defvar *condition-slot-boundp-using-class-method
* nil
)
840 (defvar *structure-slot-value-using-class-method
* nil
)
841 (defvar *structure-setf-slot-value-using-class-method
* nil
)
842 (defvar *structure-slot-boundp-using-class-method
* nil
)
844 (defun standard-svuc-method (type)
846 (reader *standard-slot-value-using-class-method
*)
847 (writer *standard-setf-slot-value-using-class-method
*)
848 (boundp *standard-slot-boundp-using-class-method
*)))
850 (defun set-standard-svuc-method (type method
)
852 (reader (setq *standard-slot-value-using-class-method
* method
))
853 (writer (setq *standard-setf-slot-value-using-class-method
* method
))
854 (boundp (setq *standard-slot-boundp-using-class-method
* method
))))
856 (defun condition-svuc-method (type)
858 (reader *condition-slot-value-using-class-method
*)
859 (writer *condition-setf-slot-value-using-class-method
*)
860 (boundp *condition-slot-boundp-using-class-method
*)))
862 (defun set-condition-svuc-method (type method
)
864 (reader (setq *condition-slot-value-using-class-method
* method
))
865 (writer (setq *condition-setf-slot-value-using-class-method
* method
))
866 (boundp (setq *condition-slot-boundp-using-class-method
* method
))))
868 (defun structure-svuc-method (type)
870 (reader *structure-slot-value-using-class-method
*)
871 (writer *structure-setf-slot-value-using-class-method
*)
872 (boundp *structure-slot-boundp-using-class-method
*)))
874 (defun set-structure-svuc-method (type method
)
876 (reader (setq *structure-slot-value-using-class-method
* method
))
877 (writer (setq *structure-setf-slot-value-using-class-method
* method
))
878 (boundp (setq *structure-slot-boundp-using-class-method
* method
))))
880 (defun update-std-or-str-methods (gf type
)
881 (dolist (method (generic-function-methods gf
))
882 (let ((specls (method-specializers method
)))
883 (when (and (or (not (eq type
'writer
))
884 (eq (pop specls
) *the-class-t
*))
885 (every #'classp specls
))
886 (cond ((and (eq (class-name (car specls
)) 'std-class
)
887 (eq (class-name (cadr specls
)) 'std-object
)
888 (eq (class-name (caddr specls
))
889 'standard-effective-slot-definition
))
890 (set-standard-svuc-method type method
))
891 ((and (eq (class-name (car specls
)) 'condition-class
)
892 (eq (class-name (cadr specls
)) 'condition
)
893 (eq (class-name (caddr specls
))
894 'condition-effective-slot-definition
))
895 (set-condition-svuc-method type method
))
896 ((and (eq (class-name (car specls
)) 'structure-class
)
897 (eq (class-name (cadr specls
)) 'structure-object
)
898 (eq (class-name (caddr specls
))
899 'structure-effective-slot-definition
))
900 (set-structure-svuc-method type method
)))))))
902 (defun mec-all-classes-internal (spec precompute-p
)
903 (cons (specializer-class spec
)
906 (not (or (eq spec
*the-class-t
*)
907 (eq spec
*the-class-slot-object
*)
908 (eq spec
*the-class-std-object
*)
909 (eq spec
*the-class-standard-object
*)
910 (eq spec
*the-class-structure-object
*)))
911 (let ((sc (class-direct-subclasses spec
)))
913 (mapcan (lambda (class)
914 (mec-all-classes-internal class precompute-p
))
917 (defun mec-all-classes (spec precompute-p
)
918 (let ((classes (mec-all-classes-internal spec precompute-p
)))
919 (if (null (cdr classes
))
921 (let* ((a-classes (cons nil classes
))
923 (loop (when (null (cdr tail
))
924 (return (cdr a-classes
)))
925 (let ((class (cadr tail
))
927 (if (dolist (c ttail nil
)
928 (when (eq class c
) (return t
)))
929 (setf (cdr tail
) (cddr tail
))
930 (setf tail
(cdr tail
)))))))))
932 (defun mec-all-class-lists (spec-list precompute-p
)
935 (let* ((car-all-classes (mec-all-classes (car spec-list
)
937 (all-class-lists (mec-all-class-lists (cdr spec-list
)
939 (mapcan (lambda (list)
940 (mapcar (lambda (c) (cons c list
)) car-all-classes
))
943 (defun make-emf-cache (generic-function valuep cache classes-list new-class
)
944 (let* ((arg-info (gf-arg-info generic-function
))
945 (nkeys (arg-info-nkeys arg-info
))
946 (metatypes (arg-info-metatypes arg-info
))
947 (wrappers (unless (eq nkeys
1) (make-list nkeys
)))
948 (precompute-p (gf-precompute-dfun-and-emf-p arg-info
))
949 (default '(default)))
950 (flet ((add-class-list (classes)
951 (when (or (null new-class
) (memq new-class classes
))
952 (let ((wrappers (get-wrappers-from-classes
953 nkeys wrappers classes metatypes
)))
955 (eq default
(probe-cache cache wrappers default
)))
956 (let ((value (cond ((eq valuep t
)
957 (sdfun-for-caching generic-function
959 ((eq valuep
:constant-value
)
960 (value-for-caching generic-function
962 (setq cache
(fill-cache cache wrappers value
))))))))
964 (mapc #'add-class-list classes-list
)
965 (dolist (method (generic-function-methods generic-function
))
966 (mapc #'add-class-list
967 (mec-all-class-lists (method-specializers method
)
971 (defmacro class-test
(arg class
)
972 (cond ((eq class
*the-class-t
*)
974 ((eq class
*the-class-slot-object
*)
975 `(not (typep (classoid-of ,arg
)
976 'built-in-classoid
)))
977 ((eq class
*the-class-std-object
*)
978 `(or (std-instance-p ,arg
) (fsc-instance-p ,arg
)))
979 ((eq class
*the-class-standard-object
*)
980 `(std-instance-p ,arg
))
981 ((eq class
*the-class-funcallable-standard-object
*)
982 `(fsc-instance-p ,arg
))
984 `(typep ,arg
',(class-name class
)))))
986 (defmacro class-eq-test
(arg class
)
987 `(eq (class-of ,arg
) ',class
))
989 (defmacro eql-test
(arg object
)
990 `(eql ,arg
',object
))
992 (defun dnet-methods-p (form)
994 (or (eq (car form
) 'methods
)
995 (eq (car form
) 'unordered-methods
))))
997 ;;; This is CASE, but without gensyms.
998 (defmacro scase
(arg &rest clauses
)
999 `(let ((.case-arg.
,arg
))
1000 (cond ,@(mapcar (lambda (clause)
1001 (list* (cond ((null (car clause
))
1003 ((consp (car clause
))
1004 (if (null (cdar clause
))
1009 ((member (car clause
) '(t otherwise
))
1012 `(eql .case-arg.
',(car clause
))))
1017 (defmacro mcase
(arg &rest clauses
) `(scase ,arg
,@clauses
))
1019 (defun generate-discrimination-net (generic-function methods types sorted-p
)
1020 (let* ((arg-info (gf-arg-info generic-function
))
1021 (precedence (arg-info-precedence arg-info
)))
1022 (generate-discrimination-net-internal
1023 generic-function methods types
1024 (lambda (methods known-types
)
1027 (let ((sorted-methods nil
))
1029 (copy-list methods
) precedence
1031 (when sorted-methods
(return-from one-order-p nil
))
1032 (setq sorted-methods methods
)))
1033 (setq methods sorted-methods
))
1035 `(methods ,methods
,known-types
)
1036 `(unordered-methods ,methods
,known-types
)))
1037 (lambda (position type true-value false-value
)
1038 (let ((arg (dfun-arg-symbol position
)))
1039 (if (eq (car type
) 'eql
)
1040 (let* ((false-case-p (and (consp false-value
)
1041 (or (eq (car false-value
) 'scase
)
1042 (eq (car false-value
) 'mcase
))
1043 (eq arg
(cadr false-value
))))
1044 (false-clauses (if false-case-p
1046 `((t ,false-value
))))
1047 (case-sym (if (and (dnet-methods-p true-value
)
1049 (eq (car false-value
) 'mcase
)
1050 (dnet-methods-p false-value
)))
1053 (type-sym `(,(cadr type
))))
1055 (,type-sym
,true-value
)
1057 `(if ,(let ((arg (dfun-arg-symbol position
)))
1059 (class `(class-test ,arg
,(cadr type
)))
1060 (class-eq `(class-eq-test ,arg
,(cadr type
)))))
1065 (defun class-from-type (type)
1066 (if (or (atom type
) (eq (car type
) t
))
1069 (and (dolist (type (cdr type
) *the-class-t
*)
1070 (when (and (consp type
) (not (eq (car type
) 'not
)))
1071 (return (class-from-type type
)))))
1073 (eql (class-of (cadr type
)))
1074 (class-eq (cadr type
))
1075 (class (cadr type
)))))
1077 (defun precompute-effective-methods (gf caching-p
&optional classes-list-p
)
1078 (let* ((arg-info (gf-arg-info gf
))
1079 (methods (generic-function-methods gf
))
1080 (precedence (arg-info-precedence arg-info
))
1081 (*in-precompute-effective-methods-p
* t
)
1083 (generate-discrimination-net-internal
1085 (lambda (methods known-types
)
1087 (when classes-list-p
1088 (push (mapcar #'class-from-type known-types
) classes-list
))
1089 (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
1094 (get-secondary-dispatch-function1
1095 gf methods known-types
1096 nil caching-p no-eql-specls-p
))))))
1097 (lambda (position type true-value false-value
)
1098 (declare (ignore position type true-value false-value
))
1101 (if (and (consp type
) (eq (car type
) 'eql
))
1102 `(class-eq ,(class-of (cadr type
)))
1106 ;;; We know that known-type implies neither new-type nor `(not ,new-type).
1107 (defun augment-type (new-type known-type
)
1108 (if (or (eq known-type t
)
1109 (eq (car new-type
) 'eql
))
1111 (let ((so-far (if (and (consp known-type
) (eq (car known-type
) 'and
))
1113 (list known-type
))))
1114 (unless (eq (car new-type
) 'not
)
1116 (mapcan (lambda (type)
1117 (unless (*subtypep new-type type
)
1122 `(and ,new-type
,@so-far
)))))
1124 (defun generate-discrimination-net-internal
1125 (gf methods types methods-function test-fun type-function
)
1126 (let* ((arg-info (gf-arg-info gf
))
1127 (precedence (arg-info-precedence arg-info
))
1128 (nreq (arg-info-number-required arg-info
))
1129 (metatypes (arg-info-metatypes arg-info
)))
1130 (labels ((do-column (p-tail contenders known-types
)
1132 (let* ((position (car p-tail
))
1133 (known-type (or (nth position types
) t
)))
1134 (if (eq (nth position metatypes
) t
)
1135 (do-column (cdr p-tail
) contenders
1136 (cons (cons position known-type
)
1138 (do-methods p-tail contenders
1139 known-type
() known-types
)))
1140 (funcall methods-function contenders
1141 (let ((k-t (make-list nreq
)))
1142 (dolist (index+type known-types
)
1143 (setf (nth (car index
+type
) k-t
)
1146 (do-methods (p-tail contenders known-type winners known-types
)
1148 ;; is a (sorted) list of methods that must be discriminated.
1150 ;; is the type of this argument, constructed from tests
1153 ;; is a (sorted) list of methods that are potentially
1154 ;; applicable after the discrimination has been made.
1155 (if (null contenders
)
1156 (do-column (cdr p-tail
)
1158 (cons (cons (car p-tail
) known-type
)
1160 (let* ((position (car p-tail
))
1161 (method (car contenders
))
1162 (specl (nth position
(method-specializers method
)))
1163 (type (funcall type-function
1164 (type-from-specializer specl
))))
1165 (multiple-value-bind (app-p maybe-app-p
)
1166 (specializer-applicable-using-type-p type known-type
)
1167 (flet ((determined-to-be (truth-value)
1168 (if truth-value app-p
(not maybe-app-p
)))
1169 (do-if (truth &optional implied
)
1170 (let ((ntype (if truth type
`(not ,type
))))
1175 (augment-type ntype known-type
))
1177 (append winners
`(,method
))
1180 (cond ((determined-to-be nil
) (do-if nil t
))
1181 ((determined-to-be t
) (do-if t t
))
1182 (t (funcall test-fun position type
1183 (do-if t
) (do-if nil
))))))))))
1184 (do-column precedence methods
()))))
1186 (defun compute-secondary-dispatch-function (generic-function net
&optional
1187 method-alist wrappers
)
1188 (function-funcall (compute-secondary-dispatch-function1 generic-function net
)
1189 method-alist wrappers
))
1191 (defvar *eq-case-table-limit
* 15)
1192 (defvar *case-table-limit
* 10)
1194 (defun compute-mcase-parameters (case-list)
1195 (unless (eq t
(caar (last case-list
)))
1196 (error "The key for the last case arg to mcase was not T"))
1197 (let* ((eq-p (dolist (case case-list t
)
1198 (unless (or (eq (car case
) t
)
1199 (symbolp (caar case
)))
1201 (len (1- (length case-list
)))
1202 (type (cond ((= len
1)
1206 *eq-case-table-limit
*
1207 *case-table-limit
*))
1213 (defmacro mlookup
(key info default
&optional eq-p type
)
1214 (unless (or (eq eq-p t
) (null eq-p
))
1215 (bug "Invalid eq-p argument: ~S" eq-p
))
1219 (declare (optimize (inhibit-warnings 3)))
1220 (,(if eq-p
'eq
'eql
) ,key
(car ,info
)))
1224 `(dolist (e ,info
,default
)
1226 (declare (optimize (inhibit-warnings 3)))
1227 (,(if eq-p
'eq
'eql
) (car e
) ,key
))
1230 `(gethash ,key
,info
,default
))))
1232 (defun net-test-converter (form)
1234 (default-test-converter form
)
1236 ((invoke-effective-method-function invoke-fast-method-call
)
1243 `(mlookup ,(cadr form
)
1246 ,@(compute-mcase-parameters (cddr form
))))
1247 (t (default-test-converter form
)))))
1249 (defun net-code-converter (form)
1251 (default-code-converter form
)
1253 ((methods unordered-methods
)
1254 (let ((gensym (gensym)))
1258 (let ((mp (compute-mcase-parameters (cddr form
)))
1259 (gensym (gensym)) (default (gensym)))
1260 (values `(mlookup ,(cadr form
) ,gensym
,default
,@mp
)
1261 (list gensym default
))))
1263 (default-code-converter form
)))))
1265 (defun net-constant-converter (form generic-function
)
1266 (or (let ((c (methods-converter form generic-function
)))
1269 (default-constant-converter form
)
1272 (let* ((mp (compute-mcase-parameters (cddr form
)))
1273 (list (mapcar (lambda (clause)
1274 (let ((key (car clause
))
1275 (meth (cadr clause
)))
1276 (cons (if (consp key
) (car key
) key
)
1278 meth generic-function
))))
1280 (default (car (last list
))))
1281 (list (list* :mcase mp
(nbutlast list
))
1284 (default-constant-converter form
))))))
1286 (defun methods-converter (form generic-function
)
1287 (cond ((and (consp form
) (eq (car form
) 'methods
))
1289 (get-effective-method-function1 generic-function
(cadr form
))))
1290 ((and (consp form
) (eq (car form
) 'unordered-methods
))
1291 (default-secondary-dispatch-function generic-function
))))
1293 (defun convert-methods (constant method-alist wrappers
)
1294 (if (and (consp constant
)
1295 (eq (car constant
) '.methods.
))
1296 (funcall (cdr constant
) method-alist wrappers
)
1299 (defun convert-table (constant method-alist wrappers
)
1300 (cond ((and (consp constant
)
1301 (eq (car constant
) :mcase
))
1302 (let ((alist (mapcar (lambda (k+m
)
1304 (convert-methods (cdr k
+m
)
1308 (mp (cadr constant
)))
1315 (let ((table (make-hash-table :test
(if (car mp
) 'eq
'eql
))))
1317 (setf (gethash (car k
+m
) table
) (cdr k
+m
)))
1320 (defun compute-secondary-dispatch-function1 (generic-function net
1321 &optional function-p
)
1323 ((and (eq (car net
) 'methods
) (not function-p
))
1324 (get-effective-method-function1 generic-function
(cadr net
)))
1326 (let* ((name (generic-function-name generic-function
))
1327 (arg-info (gf-arg-info generic-function
))
1328 (metatypes (arg-info-metatypes arg-info
))
1329 (applyp (arg-info-applyp arg-info
))
1330 (fmc-arg-info (cons (length metatypes
) applyp
))
1331 (arglist (if function-p
1332 (make-dfun-lambda-list metatypes applyp
)
1333 (make-fast-method-call-lambda-list metatypes applyp
))))
1334 (multiple-value-bind (cfunction constants
)
1335 (get-fun1 `(,(if function-p
1339 ,@(unless function-p
1340 `((declare (ignore .pv-cell.
1341 .next-method-call.
))))
1342 (locally (declare #.
*optimize-speed
*)
1344 ,(make-emf-call metatypes applyp
'emf
))))
1345 #'net-test-converter
1346 #'net-code-converter
1348 (net-constant-converter form generic-function
)))
1349 (lambda (method-alist wrappers
)
1350 (let* ((alist (list nil
))
1352 (dolist (constant constants
)
1353 (let* ((a (or (dolist (a alist nil
)
1354 (when (eq (car a
) constant
)
1358 constant method-alist wrappers
)
1360 constant method-alist wrappers
)))))
1362 (setf (cdr alist-tail
) new
)
1363 (setf alist-tail new
)))
1364 (let ((function (apply cfunction
(mapcar #'cdr
(cdr alist
)))))
1367 (make-fast-method-call
1368 :function
(set-fun-name function
`(sdfun-method ,name
))
1369 :arg-info fmc-arg-info
))))))))))
1371 (defvar *show-make-unordered-methods-emf-calls
* nil
)
1373 (defun make-unordered-methods-emf (generic-function methods
)
1374 (when *show-make-unordered-methods-emf-calls
*
1375 (format t
"~&make-unordered-methods-emf ~S~%"
1376 (generic-function-name generic-function
)))
1377 (lambda (&rest args
)
1378 (let* ((types (types-from-args generic-function args
'eql
))
1379 (smethods (sort-applicable-methods generic-function
1382 (emf (get-effective-method-function generic-function smethods
)))
1383 (invoke-emf emf args
))))
1385 ;;; The value returned by compute-discriminating-function is a function
1386 ;;; object. It is called a discriminating function because it is called
1387 ;;; when the generic function is called and its role is to discriminate
1388 ;;; on the arguments to the generic function and then call appropriate
1389 ;;; method functions.
1391 ;;; A discriminating function can only be called when it is installed as
1392 ;;; the funcallable instance function of the generic function for which
1393 ;;; it was computed.
1395 ;;; More precisely, if compute-discriminating-function is called with
1396 ;;; an argument <gf1>, and returns a result <df1>, that result must
1397 ;;; not be passed to apply or funcall directly. Rather, <df1> must be
1398 ;;; stored as the funcallable instance function of the same generic
1399 ;;; function <gf1> (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the
1400 ;;; generic function can be passed to funcall or apply.
1402 ;;; An important exception is that methods on this generic function are
1403 ;;; permitted to return a function which itself ends up calling the value
1404 ;;; returned by a more specific method. This kind of `encapsulation' of
1405 ;;; discriminating function is critical to many uses of the MOP.
1407 ;;; As an example, the following canonical case is legal:
1409 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1410 ;;; (let ((std (call-next-method)))
1412 ;;; (print (list 'call-to-gf gf arg))
1413 ;;; (funcall std arg))))
1415 ;;; Because many discriminating functions would like to use a dynamic
1416 ;;; strategy in which the precise discriminating function changes with
1417 ;;; time it is important to specify how a discriminating function is
1418 ;;; permitted itself to change the funcallable instance function of the
1419 ;;; generic function.
1421 ;;; Discriminating functions may set the funcallable instance function
1422 ;;; of the generic function, but the new value must be generated by making
1423 ;;; a call to COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any
1424 ;;; more specific methods which may have encapsulated the discriminating
1425 ;;; function will get a chance to encapsulate the new, inner discriminating
1428 ;;; This implies that if a discriminating function wants to modify itself
1429 ;;; it should first store some information in the generic function proper,
1430 ;;; and then call compute-discriminating-function. The appropriate method
1431 ;;; on compute-discriminating-function will see the information stored in
1432 ;;; the generic function and generate a discriminating function accordingly.
1434 ;;; The following is an example of a discriminating function which modifies
1435 ;;; itself in accordance with this protocol:
1437 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1439 ;;; (cond (<some condition>
1440 ;;; <store some info in the generic function>
1441 ;;; (set-funcallable-instance-function
1443 ;;; (compute-discriminating-function gf))
1444 ;;; (funcall gf arg))
1446 ;;; <call-a-method-of-gf>))))
1448 ;;; Whereas this code would not be legal:
1450 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1452 ;;; (cond (<some condition>
1453 ;;; (set-funcallable-instance-function
1455 ;;; (lambda (a) ..))
1456 ;;; (funcall gf arg))
1458 ;;; <call-a-method-of-gf>))))
1460 ;;; NOTE: All the examples above assume that all instances of the class
1461 ;;; my-generic-function accept only one argument.
1463 (defun slot-value-using-class-dfun (class object slotd
)
1464 (declare (ignore class
))
1465 (function-funcall (slot-definition-reader-function slotd
) object
))
1467 (defun setf-slot-value-using-class-dfun (new-value class object slotd
)
1468 (declare (ignore class
))
1469 (function-funcall (slot-definition-writer-function slotd
) new-value object
))
1471 (defun slot-boundp-using-class-dfun (class object slotd
)
1472 (declare (ignore class
))
1473 (function-funcall (slot-definition-boundp-function slotd
) object
))
1475 (defmethod compute-discriminating-function ((gf standard-generic-function
))
1476 (with-slots (dfun-state arg-info
) gf
1477 (typecase dfun-state
1478 (null (let ((name (generic-function-name gf
)))
1479 (when (eq name
'compute-applicable-methods
)
1480 (update-all-c-a-m-gf-info gf
))
1481 (cond ((eq name
'slot-value-using-class
)
1482 (update-slot-value-gf-info gf
'reader
)
1483 #'slot-value-using-class-dfun
)
1484 ((equal name
'(setf slot-value-using-class
))
1485 (update-slot-value-gf-info gf
'writer
)
1486 #'setf-slot-value-using-class-dfun
)
1487 ((eq name
'slot-boundp-using-class
)
1488 (update-slot-value-gf-info gf
'boundp
)
1489 #'slot-boundp-using-class-dfun
)
1490 ((gf-precompute-dfun-and-emf-p arg-info
)
1491 (make-final-dfun gf
))
1493 (make-initial-dfun gf
)))))
1494 (function dfun-state
)
1495 (cons (car dfun-state
)))))
1497 (defmethod update-gf-dfun ((class std-class
) gf
)
1498 (let ((*new-class
* class
)
1499 #||
(name (generic-function-name gf
)) ||
#
1500 (arg-info (gf-arg-info gf
)))
1502 ((eq name
'slot-value-using-class
)
1503 (update-slot-value-gf-info gf
'reader
))
1504 ((equal name
'(setf slot-value-using-class
))
1505 (update-slot-value-gf-info gf
'writer
))
1506 ((eq name
'slot-boundp-using-class
)
1507 (update-slot-value-gf-info gf
'boundp
))
1509 ((gf-precompute-dfun-and-emf-p arg-info
)
1510 (multiple-value-bind (dfun cache info
)
1511 (make-final-dfun-internal gf
)
1512 (set-dfun gf dfun cache info
) ; lest the cache be freed twice
1513 (update-dfun gf dfun cache info
))))))
1515 (defmethod (setf class-name
) :before
(new-value (class class
))
1516 (let ((classoid (find-classoid (class-name class
))))
1517 (setf (classoid-name classoid
) new-value
)))
1519 (defmethod function-keywords ((method standard-method
))
1520 (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords
)
1521 (analyze-lambda-list (if (consp method
)
1522 (early-method-lambda-list method
)
1523 (method-lambda-list method
)))
1524 (declare (ignore nreq nopt keysp restp
))
1525 (values keywords allow-other-keys-p
)))
1527 (defun method-ll->generic-function-ll
(ll)
1528 (multiple-value-bind
1529 (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters
)
1530 (analyze-lambda-list ll
)
1531 (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords
))
1532 (remove-if (lambda (s)
1533 (or (memq s keyword-parameters
)
1534 (eq s
'&allow-other-keys
)))
1537 ;;; This is based on the rules of method lambda list congruency defined in
1538 ;;; the spec. The lambda list it constructs is the pretty union of the
1539 ;;; lambda lists of all the methods. It doesn't take method applicability
1540 ;;; into account at all yet.
1541 (defmethod generic-function-pretty-arglist
1542 ((generic-function standard-generic-function
))
1543 (let ((methods (generic-function-methods generic-function
)))
1546 ;; arglist is constructed from the GF's methods - maybe with
1547 ;; keys and rest stuff added
1548 (multiple-value-bind (required optional rest key allow-other-keys
)
1549 (method-pretty-arglist (car methods
))
1550 (dolist (m (cdr methods
))
1551 (multiple-value-bind (method-key-keywords
1552 method-allow-other-keys
1554 (function-keywords m
)
1555 ;; we've modified function-keywords to return what we want as
1556 ;; the third value, no other change here.
1557 (declare (ignore method-key-keywords
))
1558 (setq key
(union key method-key
))
1559 (setq allow-other-keys
(or allow-other-keys
1560 method-allow-other-keys
))))
1561 (when allow-other-keys
1562 (setq arglist
'(&allow-other-keys
)))
1564 (setq arglist
(nconc (list '&key
) key arglist
)))
1566 (setq arglist
(nconc (list '&rest rest
) arglist
)))
1568 (setq arglist
(nconc (list '&optional
) optional arglist
)))
1569 (nconc required arglist
)))
1570 ;; otherwise we take the lambda-list from the GF directly, with no
1571 ;; other 'keys' added ...
1572 (let ((lambda-list (generic-function-lambda-list generic-function
)))
1575 (defmethod method-pretty-arglist ((method standard-method
))
1580 (allow-other-keys nil
)
1582 (arglist (method-lambda-list method
)))
1583 (dolist (arg arglist
)
1584 (cond ((eq arg
'&optional
) (setq state
'optional
))
1585 ((eq arg
'&rest
) (setq state
'rest
))
1586 ((eq arg
'&key
) (setq state
'key
))
1587 ((eq arg
'&allow-other-keys
) (setq allow-other-keys t
))
1588 ((memq arg lambda-list-keywords
))
1591 (required (push arg required
))
1592 (optional (push arg optional
))
1593 (key (push arg key
))
1594 (rest (setq rest arg
))))))
1595 (values (nreverse required
)