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 (defun change-class-to-metaobject-violation (to-name
45 &optional from-name references
)
46 (error 'metaobject-initialization-violation
47 :format-control
"~@<Cannot ~S~@[ ~S~] objects into ~S metaobjects.~@:>"
48 :format-arguments
(list 'change-class from-name to-name
)
49 :references references
))
51 (macrolet ((def (name args control
)
52 `(defmethod ,name
,args
53 (declare (ignore initargs
))
54 (error 'metaobject-initialization-violation
55 :format-control
,(format nil
"~~@<~A~~@:>" control
)
56 :format-arguments
(list ',name
)
57 :references
'((:amop
:initialization method
))))))
58 (def reinitialize-instance
((method method
) &rest initargs
)
59 "Method objects cannot be redefined by ~S.")
60 (def change-class
((method method
) new
&rest initargs
)
61 "Method objects cannot be redefined by ~S.")
62 ;; NEW being a subclass of method is dealt with in the general
63 ;; method of CHANGE-CLASS
64 (def update-instance-for-redefined-class
((method method
) added discarded
66 "No behaviour specified for ~S on method objects.")
67 (def update-instance-for-different-class
(old (new method
) &rest initargs
)
68 "No behaviour specified for ~S on method objects.")
69 (def update-instance-for-different-class
((old method
) new
&rest initargs
)
70 "No behaviour specified for ~S on method objects."))
72 (define-condition invalid-method-initarg
(simple-program-error)
73 ((method :initarg
:method
:reader invalid-method-initarg-method
))
76 (format s
"~@<In initialization of ~S:~2I~_~?~@:>"
77 (invalid-method-initarg-method c
)
78 (simple-condition-format-control c
)
79 (simple-condition-format-arguments c
)))))
81 (defun invalid-method-initarg (method format-control
&rest args
)
82 (error 'invalid-method-initarg
:method method
83 :format-control format-control
:format-arguments args
))
85 (defun check-documentation (method doc
)
86 (unless (or (null doc
) (stringp doc
))
87 (invalid-method-initarg method
"~@<~S of ~S is neither ~S nor a ~S.~@:>"
88 :documentation doc
'null
'string
)))
89 (defun check-lambda-list (method ll
)
90 (declare (ignore method ll
))
93 (defun check-method-function (method fun
)
94 (unless (functionp fun
)
95 (invalid-method-initarg method
"~@<~S of ~S is not a ~S.~@:>"
96 :function fun
'function
)))
98 (macrolet ((dolist-carefully ((var list improper-list-handler
) &body body
)
100 (.dolist-carefully.
,list
))
101 (loop (when (null .dolist-carefully.
) (return nil
))
102 (if (consp .dolist-carefully.
)
104 (setq ,var
(pop .dolist-carefully.
))
106 (,improper-list-handler
))))))
108 (defun check-qualifiers (method qualifiers
)
109 (flet ((improper-list ()
110 (invalid-method-initarg method
111 "~@<~S of ~S is an improper list.~@:>"
112 :qualifiers qualifiers
)))
113 (dolist-carefully (q qualifiers improper-list
)
114 (unless (and q
(atom q
))
115 (invalid-method-initarg method
116 "~@<~S, in ~S ~S, is not a non-~S atom.~@:>"
117 q
:qualifiers qualifiers
'null
)))))
119 (defun check-slot-name (method name
)
120 (declare (ignore method
))
121 (unless (symbolp name
)
122 (invalid-method-initarg "~@<~S of ~S is not a ~S.~@:>"
123 :slot-name name
'symbol
)))
125 (defun check-specializers (method specializers
)
126 (flet ((improper-list ()
127 (invalid-method-initarg method
128 "~@<~S of ~S is an improper list.~@:>"
129 :specializers specializers
)))
130 (dolist-carefully (s specializers improper-list
)
131 (unless (specializerp s
)
132 (invalid-method-initarg method
133 "~@<~S, in ~S ~S, is not a ~S.~@:>"
134 s
:specializers specializers
'specializer
)))
135 ;; KLUDGE: ANSI says that it's not valid to have methods
136 ;; specializing on classes which are "not defined", leaving
137 ;; unclear what the definedness of a class is; AMOP suggests that
138 ;; forward-referenced-classes, since they have proper names and
139 ;; all, are at least worthy of some level of definition. We allow
140 ;; methods specialized on forward-referenced-classes, but it's
141 ;; non-portable and potentially dubious, so
142 (let ((frcs (remove-if-not #'forward-referenced-class-p specializers
)))
144 (style-warn "~@<Defining a method using ~
145 ~V[~;~1{~S~}~;~1{~S and ~S~}~:;~{~#[~;and ~]~S~^, ~}~] ~
146 as ~2:*~V[~;a specializer~:;specializers~].~@:>"
147 (length frcs
) frcs
)))))
150 (defmethod shared-initialize :before
151 ((method standard-method
) slot-names
&key
152 qualifiers lambda-list specializers function documentation
)
153 (declare (ignore slot-names
))
154 ;; FIXME: it's not clear to me (CSR, 2006-08-09) why methods get
155 ;; this extra paranoia and nothing else does; either everything
156 ;; should be aggressively checking initargs, or nothing much should.
157 ;; In either case, it would probably be better to have :type
158 ;; declarations in slots, which would then give a suitable type
159 ;; error (if we implement type-checking for slots...) rather than
160 ;; this hand-crafted thing.
161 (check-qualifiers method qualifiers
)
162 (check-lambda-list method lambda-list
)
163 (check-specializers method specializers
)
164 (check-method-function method function
)
165 (check-documentation method documentation
))
167 (defmethod shared-initialize :before
168 ((method standard-accessor-method
) slot-names
&key
169 slot-name slot-definition
)
170 (declare (ignore slot-names
))
171 (unless slot-definition
172 (check-slot-name method slot-name
)))
174 (defmethod shared-initialize :after
((method standard-method
) slot-names
175 &rest initargs
&key
((method-cell method-cell
)))
176 (declare (ignore slot-names method-cell
))
177 (initialize-method-function initargs method
))
179 (define-load-time-global *the-class-standard-generic-function
*
180 (find-class 'standard-generic-function
))
182 (defmethod shared-initialize :before
183 ((generic-function standard-generic-function
)
185 &key
(lambda-list () lambda-list-p
)
186 argument-precedence-order
189 (method-class nil method-class-supplied-p
)
190 (method-combination nil method-combination-supplied-p
))
191 (declare (ignore slot-names
192 declarations argument-precedence-order documentation
193 lambda-list lambda-list-p
))
195 (flet ((initarg-error (initarg value string
)
196 (error "when initializing the generic function ~S:~%~
197 The ~S initialization argument was: ~A.~%~
199 generic-function initarg value string
)))
200 (cond (method-class-supplied-p
201 (when (symbolp method-class
)
202 (setq method-class
(find-class method-class
)))
203 (unless (and (classp method-class
)
204 (*subtypep
(class-eq-specializer method-class
)
206 (initarg-error :method-class
208 "a subclass of the class METHOD"))
209 (setf (slot-value generic-function
'method-class
) method-class
))
210 ((slot-boundp generic-function
'method-class
))
212 (initarg-error :method-class
214 "a subclass of the class METHOD")))
215 (cond (method-combination-supplied-p
216 (unless (method-combination-p method-combination
)
217 (initarg-error :method-combination
219 "a method combination object")))
220 ((slot-boundp generic-function
'%method-combination
))
222 (initarg-error :method-combination
224 "a method combination object")))))
226 (defun find-generic-function (name &optional
(errorp t
))
227 (let ((fun (and (fboundp name
) (fdefinition name
))))
229 ((and fun
(typep fun
'generic-function
)) fun
)
230 (errorp (error "No generic function named ~S." name
))
233 (defun real-add-named-method (generic-function-name qualifiers
234 specializers lambda-list
&rest other-initargs
)
235 (let* ((existing-gf (find-generic-function generic-function-name nil
))
238 (ensure-generic-function
239 generic-function-name
240 :generic-function-class
(class-of existing-gf
))
241 (ensure-generic-function generic-function-name
)))
242 (proto (method-prototype-for-gf generic-function-name
)))
243 ;; FIXME: Destructive modification of &REST list.
244 (setf (getf (getf other-initargs
'plist
) :name
)
245 (make-method-spec generic-function qualifiers specializers
))
246 (let ((new (apply #'make-instance
(class-of proto
)
247 :qualifiers qualifiers
:specializers specializers
248 :lambda-list lambda-list other-initargs
)))
249 (add-method generic-function new
)
252 (defun real-get-method (generic-function qualifiers specializers
254 always-check-specializers
)
255 (sb-thread::with-recursive-system-lock
((gf-lock generic-function
))
256 (let ((specializer-count (length specializers
))
257 (methods (generic-function-methods generic-function
)))
258 (when (or methods always-check-specializers
)
259 (let ((required-parameter-count
260 (length (arg-info-metatypes (gf-arg-info generic-function
)))))
261 ;; Since we internally bypass FIND-METHOD by using GET-METHOD
262 ;; instead we need to do this here or users may get hit by a
263 ;; failed AVER instead of a sensible error message.
264 (unless (= specializer-count required-parameter-count
)
266 'find-method-length-mismatch
267 :format-control
"~@<The generic function ~S takes ~D ~
268 required argument~:P; was asked to ~
269 find a method with specializers ~:S~@:>"
270 :format-arguments
(list generic-function required-parameter-count
271 (unparse-specializers generic-function specializers
))))))
272 (flet ((congruentp (other-method)
273 (let ((other-specializers (method-specializers other-method
)))
274 (aver (= specializer-count
(length other-specializers
)))
275 (and (equal qualifiers
(safe-method-qualifiers other-method
))
276 (every #'same-specializer-p specializers other-specializers
)))))
277 (declare (dynamic-extent #'congruentp
))
278 (cond ((find-if #'congruentp methods
))
281 (error "~@<There is no method on ~S with ~:[no ~
282 qualifiers~;~:*qualifiers ~:S~] and specializers ~
284 generic-function qualifiers specializers
)))))))
286 (defmethod find-method ((generic-function standard-generic-function
)
287 qualifiers specializers
&optional
(errorp t
))
288 ;; ANSI about FIND-METHOD: "The specializers argument contains the
289 ;; parameter specializers for the method. It must correspond in
290 ;; length to the number of required arguments of the generic
291 ;; function, or an error is signaled."
293 ;; This error checking is done by REAL-GET-METHOD.
295 generic-function qualifiers
296 ;; ANSI for FIND-METHOD seems to imply that in fact specializers
297 ;; should always be passed in parsed form instead of being parsed
298 ;; at this point. Since there's no ANSI-blessed way of getting an
299 ;; EQL specializer, that seems unnecessarily painful, so we are
300 ;; nice to our users. -- CSR, 2007-06-01
301 ;; Note that INTERN-EQL-SPECIALIZER is exported from SB-MOP, but MOP isn't
302 ;; part of the ANSI standard. Parsing introduces a tiny semantic problem in
303 ;; the edge case of an EQL specializer whose object is literally (EQL :X).
304 ;; That one must be supplied as a pre-parsed #<EQL-SPECIALIZER> because if
305 ;; not, we'd parse it into a specializer whose object is :X.
306 (parse-specializers generic-function specializers
) errorp t
))
308 ;;; Compute various information about a generic-function's arglist by looking
309 ;;; at the argument lists of the methods. The hair for trying not to use
310 ;;; &REST arguments lives here.
311 ;;; The values returned are:
312 ;;; number-of-required-arguments
313 ;;; the number of required arguments to this generic-function's
314 ;;; discriminating function
316 ;;; whether or not this generic-function's discriminating
317 ;;; function takes an &rest argument.
318 ;;; specialized-argument-positions
319 ;;; a list of the positions of the arguments this generic-function
320 ;;; specializes (e.g. for a classical generic-function this is the
322 (defmethod compute-discriminating-function-arglist-info
323 ((generic-function standard-generic-function
))
324 ;;(declare (values number-of-required-arguments &rest-argument-p
325 ;; specialized-argument-postions))
326 (let ((number-required nil
)
328 (specialized-positions ())
329 (methods (generic-function-methods generic-function
)))
330 (dolist (method methods
)
331 (multiple-value-setq (number-required restp specialized-positions
)
332 (compute-discriminating-function-arglist-info-internal
333 generic-function method number-required restp specialized-positions
)))
334 (values number-required restp
(sort specialized-positions
#'<))))
336 (defun compute-discriminating-function-arglist-info-internal
337 (generic-function method number-of-requireds restp
338 specialized-argument-positions
)
339 (declare (ignore generic-function
)
340 (type (or null fixnum
) number-of-requireds
))
342 (declare (fixnum requireds
))
343 ;; Go through this methods arguments seeing how many are required,
344 ;; and whether there is an &rest argument.
345 (dolist (arg (method-lambda-list method
))
346 (cond ((eq arg
'&aux
) (return))
347 ((memq arg
'(&optional
&rest
&key
))
348 (return (setq restp t
)))
349 ((memq arg lambda-list-keywords
))
350 (t (incf requireds
))))
351 ;; Now go through this method's type specifiers to see which
352 ;; argument positions are type specified. Treat T specially
353 ;; in the usual sort of way. For efficiency don't bother to
354 ;; keep specialized-argument-positions sorted, rather depend
355 ;; on our caller to do that.
357 (dolist (type-spec (method-specializers method
))
358 (unless (eq type-spec
*the-class-t
*)
359 (pushnew pos specialized-argument-positions
:test
#'eq
))
361 ;; Finally merge the values for this method into the values
362 ;; for the exisiting methods and return them. Note that if
363 ;; num-of-requireds is NIL it means this is the first method
364 ;; and we depend on that.
365 (values (min (or number-of-requireds requireds
) requireds
)
367 (and number-of-requireds
(/= number-of-requireds requireds
)))
368 specialized-argument-positions
)))
370 (defmethod generic-function-argument-precedence-order
371 ((gf standard-generic-function
))
372 (aver (eq **boot-state
** 'complete
))
373 (loop with arg-info
= (gf-arg-info gf
)
374 with lambda-list
= (arg-info-lambda-list arg-info
)
375 for argument-position in
(arg-info-precedence arg-info
)
376 collect
(nth argument-position lambda-list
)))
378 (defmethod generic-function-lambda-list ((gf generic-function
))
381 (defmethod gf-fast-method-function-p ((gf standard-generic-function
))
382 (gf-info-fast-mf-p (slot-value gf
'arg-info
)))
384 (defun add-to-weak-hashset (key set
)
385 (with-system-mutex ((hashset-mutex set
))
386 (hashset-insert set key
)))
387 (defun remove-from-weak-hashset (key set
)
388 (with-system-mutex ((hashset-mutex set
))
389 (hashset-remove set key
)))
390 (defun weak-hashset-memberp (key set
)
391 (with-system-mutex ((hashset-mutex set
))
392 (hashset-find set key
)))
394 (defmethod initialize-instance :after
((gf standard-generic-function
)
395 &key
(lambda-list nil lambda-list-p
)
396 argument-precedence-order
)
397 ;; FIXME: Because ARG-INFO is a STRUCTURE-OBJECT, it does not get
398 ;; a permutation vector, and therefore the code that SLOT-VALUE transforms
399 ;; to winds up punting to #'(SLOT-ACCESSOR :GLOBAL ARG-INFO READER).
400 ;; Using SLOT-VALUE the "slow" way sidesteps some bootstrap issues.
401 (declare (notinline slot-value
))
402 (progn ; WAS: with-slots (arg-info) gf
405 :lambda-list lambda-list
406 :argument-precedence-order argument-precedence-order
)
408 (let ((mc (generic-function-method-combination gf
)))
409 (add-to-weak-hashset gf
(method-combination-%generic-functions mc
)))
410 (when (arg-info-valid-p (slot-value gf
'arg-info
))
413 (defmethod reinitialize-instance :around
414 ((gf standard-generic-function
) &rest args
&key
415 (lambda-list nil lambda-list-p
) (argument-precedence-order nil apo-p
))
416 (let* ((old-mc (generic-function-method-combination gf
))
417 (mc (getf args
:method-combination old-mc
)))
418 (unless (eq mc old-mc
)
419 (aver (weak-hashset-memberp gf
(method-combination-%generic-functions old-mc
)))
420 (aver (not (weak-hashset-memberp gf
(method-combination-%generic-functions mc
)))))
421 (prog1 (call-next-method)
422 (unless (eq mc old-mc
)
423 (remove-from-weak-hashset gf
(method-combination-%generic-functions old-mc
))
424 (add-to-weak-hashset gf
(method-combination-%generic-functions mc
))
425 (flush-effective-method-cache gf
))
426 (sb-thread::with-recursive-system-lock
((gf-lock gf
))
428 ((and lambda-list-p apo-p
)
430 :lambda-list lambda-list
431 :argument-precedence-order argument-precedence-order
))
432 (lambda-list-p (set-arg-info gf
:lambda-list lambda-list
))
433 (t (set-arg-info gf
)))
434 (when (arg-info-valid-p (gf-arg-info gf
))
436 (map-dependents gf
(lambda (dependent)
437 (apply #'update-dependent gf dependent args
)))))))
439 (defun set-methods (gf methods
)
440 (setf (generic-function-methods gf
) nil
)
441 (loop (when (null methods
) (return gf
))
442 (real-add-method gf
(pop methods
) methods
)))
444 (define-condition new-value-specialization
(reference-condition error
)
445 ((%method
:initarg
:method
:reader new-value-specialization-method
))
448 (format s
"~@<Cannot add method ~S to ~S, as it specializes the ~
449 new-value argument.~@:>"
450 (new-value-specialization-method c
)
451 #'(setf slot-value-using-class
))))
452 (:default-initargs
:references
453 (list '(:sbcl
:node
"Metaobject Protocol")
454 '(:amop
:generic-function
(setf slot-value-using-class
)))))
456 (defgeneric values-for-add-method
(gf method
)
457 (:method
((gf standard-generic-function
) (method standard-method
))
458 ;; KLUDGE: Just a single generic dispatch, and everything else
459 ;; comes from permutation vectors. Would be nicer to define
460 ;; REAL-ADD-METHOD with a proper method so that we could efficiently
461 ;; use SLOT-VALUE there.
463 ;; Optimization note: REAL-ADD-METHOD has a lot of O(N) stuff in it (as
464 ;; does PCL as a whole). It should not be too hard to internally store
465 ;; many of the things we now keep in lists as either purely functional
466 ;; O(log N) sets, or --if we don't mind the memory cost-- using
467 ;; specialized hash-tables: most things are used to answer questions about
468 ;; set-membership, not ordering.
469 (values (slot-value gf
'%lock
)
470 (slot-value method
'qualifiers
)
471 (slot-value method
'specializers
)
472 (slot-value method
'lambda-list
)
473 (slot-value method
'%generic-function
)
474 (slot-value gf
'name
))))
476 (define-condition print-object-stream-specializer
(reference-condition simple-warning
)
479 :references
'((:ansi-cl
:function print-object
))
480 :format-control
"~@<Specializing on the second argument to ~S has ~
481 unportable effects, and also interferes with ~
482 precomputation of print functions for exceptional ~
484 :format-arguments
(list 'print-object
)))
486 (defun defer-ftype-computation (gf)
487 ;; Is there any reason not to do this as soon as possible?
488 ;; While doing it with every ADD/REMOVE-METHOD call could result in
489 ;; wasted work, it seems like unnecessary complexity.
490 ;; I think it's just to get through bootstrap, probably,
491 ;; but if it's a semantics thing, it deserves some explanation.
492 (let ((name (generic-function-name gf
)))
493 (when (legal-fun-name-p name
) ; tautological ?
494 (unless (eq (info :function
:where-from name
) :declared
)
495 (when (and (fboundp name
) (eq (fdefinition name
) gf
))
496 (setf (info :function
:type name
) :generic-function
))))))
498 (defun compute-gf-ftype (name)
499 (let ((gf (and (fboundp name
) (fdefinition name
)))
500 (methods-in-compilation-unit (and (boundp 'sb-c
::*methods-in-compilation-unit
*)
501 sb-c
::*methods-in-compilation-unit
*
502 (gethash name sb-c
::*methods-in-compilation-unit
*))))
503 (cond ((generic-function-p gf
)
504 (let* ((ll (generic-function-lambda-list gf
))
505 ;; If the GF has &REST without &KEY then we don't augment
506 ;; the FTYPE with keywords, so as not to complain about keywords
507 ;; which seem not to be accepted.
508 (type (sb-c::ftype-from-lambda-list
509 (if (and (member '&rest ll
) (not (member '&key ll
)))
511 (generic-function-pretty-arglist gf methods-in-compilation-unit
)))))
513 ;; It would be nice if globaldb were transactional,
514 ;; so that either both updates or neither occur.
515 (setf (info :function
:where-from name
) :defined-method
516 (info :function
:type name
) type
)))
517 (methods-in-compilation-unit
518 (setf (info :function
:where-from name
) :defined-method
519 (info :function
:type name
)
520 (sb-c::ftype-from-lambda-list
521 (gf-merge-arglists methods-in-compilation-unit
))))
523 ;; The defaulting expression for (:FUNCTION :TYPE) does not store
524 ;; the default. For :GENERIC-FUNCTION that is not FBOUNDP we also
525 ;; don't, however this branch should never be reached because the
526 ;; info only stores :GENERIC-FUNCTION when methods are loaded.
527 ;; Maybe AVER that it does not happen?
528 (sb-c::ftype-from-definition name
)))))
530 (defun real-add-method (generic-function method
&optional skip-dfun-update-p
)
531 (flet ((similar-lambda-lists-p (old-method new-lambda-list
)
532 (binding* (((a-llks a-nreq a-nopt
)
533 (analyze-lambda-list (method-lambda-list old-method
)))
534 ((b-llks b-nreq b-nopt
)
535 (analyze-lambda-list new-lambda-list
)))
536 (and (= a-nreq b-nreq
)
538 (eq (ll-keyp-or-restp a-llks
)
539 (ll-keyp-or-restp b-llks
))))))
540 (multiple-value-bind (lock qualifiers specializers new-lambda-list
542 (values-for-add-method generic-function method
)
544 (error "~@<The method ~S is already part of the generic ~
545 function ~S; it can't be added to another generic ~
546 function until it is removed from the first one.~@:>"
548 (when (and (eq name
'print-object
) (not (eq (second specializers
) *the-class-t
*)))
549 (warn 'print-object-stream-specializer
))
551 ;; System lock because interrupts need to be disabled as
552 ;; well: it would be bad to unwind and leave the gf in an
553 ;; inconsistent state.
554 (sb-thread::with-recursive-system-lock
(lock)
555 (let ((existing (get-method generic-function
560 ;; If there is already a method like this one then we must get
561 ;; rid of it before proceeding. Note that we call the generic
562 ;; function REMOVE-METHOD to remove it rather than doing it in
563 ;; some internal way.
564 (when (and existing
(similar-lambda-lists-p existing new-lambda-list
))
565 (remove-method generic-function existing
))
567 ;; KLUDGE: We have a special case here, as we disallow
568 ;; specializations of the NEW-VALUE argument to (SETF
569 ;; SLOT-VALUE-USING-CLASS). GET-ACCESSOR-METHOD-FUNCTION is
570 ;; the optimizing function here: it precomputes the effective
571 ;; method, assuming that there is no dispatch to be done on
572 ;; the new-value argument.
573 (when (and (eq generic-function
#'(setf slot-value-using-class
))
574 (not (eq *the-class-t
* (first specializers
))))
575 (error 'new-value-specialization
:method method
))
577 (setf (method-generic-function method
) generic-function
)
578 (pushnew method
(generic-function-methods generic-function
) :test
#'eq
)
579 (dolist (specializer specializers
)
580 (add-direct-method specializer method
))
582 ;; KLUDGE: SET-ARG-INFO contains the error-detecting logic for
583 ;; detecting attempts to add methods with incongruent lambda
584 ;; lists. However, according to Gerd Moellmann on cmucl-imp,
585 ;; it also depends on the new method already having been added
586 ;; to the generic function. Therefore, we need to remove it
588 (let ((remove-again-p t
))
591 (set-arg-info generic-function
:new-method method
)
592 (setq remove-again-p nil
))
594 (remove-method generic-function method
))))
596 ;; KLUDGE II: ANSI saith that it is not an error to add a
597 ;; method with invalid qualifiers to a generic function of the
598 ;; wrong kind; it's only an error at generic function
599 ;; invocation time; I dunno what the rationale was, and it
600 ;; sucks. Nevertheless, it's probably a programmer error, so
601 ;; let's warn anyway. -- CSR, 2003-08-20
602 (let* ((mc (generic-function-method-combination generic-function
))
603 (type-name (method-combination-type-name mc
)))
605 (warn "~@<Invalid qualifiers for ~S method ~
606 combination in method ~S:~2I~_~S.~@:>"
607 type-name method qualifiers
)))
609 ((and (eq mc
*standard-method-combination
*)
612 (not (standard-method-combination-qualifier-p
615 ((and (short-method-combination-p mc
)
616 (or (null qualifiers
)
618 (not (short-method-combination-qualifier-p
619 type-name
(car qualifiers
)))))
621 (unless skip-dfun-update-p
622 (update-ctors 'add-method
623 :generic-function generic-function
625 (update-dfun generic-function
))
626 (defer-ftype-computation generic-function
)
627 (map-dependents generic-function
629 (update-dependent generic-function
630 dep
'add-method method
)))))
631 (serious-condition (c)
635 (defun real-remove-method (generic-function method
)
636 (when (eq generic-function
(method-generic-function method
))
637 (flush-effective-method-cache generic-function
)
638 (let ((lock (gf-lock generic-function
)))
639 ;; System lock because interrupts need to be disabled as well:
640 ;; it would be bad to unwind and leave the gf in an inconsistent
642 (sb-thread::with-recursive-system-lock
(lock)
643 (let* ((specializers (method-specializers method
))
644 (methods (generic-function-methods generic-function
))
645 (new-methods (remove method methods
)))
646 (setf (method-generic-function method
) nil
647 (generic-function-methods generic-function
) new-methods
)
648 (dolist (specializer specializers
)
649 (remove-direct-method specializer method
))
650 (set-arg-info generic-function
)
651 (update-ctors 'remove-method
652 :generic-function generic-function
654 (update-dfun generic-function
)
655 (defer-ftype-computation generic-function
)
656 (map-dependents generic-function
658 (update-dependent generic-function
659 dep
'remove-method method
)))))))
662 (defun compute-applicable-methods-function (generic-function arguments
)
663 (values (compute-applicable-methods-using-types
665 (types-from-args generic-function arguments
'eql
))))
667 (defmethod compute-applicable-methods
668 ((generic-function generic-function
) arguments
)
669 (values (compute-applicable-methods-using-types
671 (types-from-args generic-function arguments
'eql
))))
673 (defmethod compute-applicable-methods-using-classes
674 ((generic-function generic-function
) classes
)
675 (compute-applicable-methods-using-types
677 (types-from-args generic-function classes
'class-eq
)))
679 (defun !proclaim-incompatible-superclasses
(classes)
680 (setq classes
(mapcar (lambda (class)
685 (dolist (class classes
)
686 (dolist (other-class classes
)
687 (unless (eq class other-class
)
688 (pushnew other-class
(class-incompatible-superclass-list class
) :test
#'eq
)))))
690 (defun superclasses-compatible-p (class1 class2
)
691 (let ((cpl1 (cpl-or-nil class1
))
692 (cpl2 (cpl-or-nil class2
)))
694 (dolist (ic (class-incompatible-superclass-list sc1
))
696 (return-from superclasses-compatible-p nil
))))))
699 #'!proclaim-incompatible-superclasses
700 '(;; superclass class
701 (system-class std-class structure-class
) ; direct subclasses of pcl-class
702 (standard-class funcallable-standard-class
)
703 ;; superclass metaobject
704 (class eql-specializer class-eq-specializer method method-combination
705 generic-function slot-definition
)
706 ;; metaclass built-in-class
707 (number sequence character
; direct subclasses of t, but not array
708 standard-object structure-object
) ; or symbol
709 (number array character symbol
; direct subclasses of t, but not
710 standard-object structure-object
) ; sequence
711 (complex float rational
) ; direct subclasses of number
712 (integer ratio
) ; direct subclasses of rational
713 (list vector
) ; direct subclasses of sequence
714 (cons null
) ; direct subclasses of list
715 (string bit-vector
) ; direct subclasses of vector
718 (defmethod same-specializer-p ((specl1 specializer
) (specl2 specializer
))
721 (defmethod same-specializer-p ((specl1 class
) (specl2 class
))
724 (defmethod specializer-class ((specializer class
))
727 (defmethod same-specializer-p ((specl1 class-eq-specializer
)
728 (specl2 class-eq-specializer
))
729 (eq (specializer-class specl1
) (specializer-class specl2
)))
731 ;; FIXME: This method is wacky, and indicative of a coding style in which
732 ;; metaphorically the left hand does not know what the right is doing.
733 ;; If you want this to be the abstract comparator, and you "don't know"
734 ;; that EQL-specializers are interned, then the comparator should be EQL.
735 ;; But if you *do* know that they're interned, then why does this method
736 ;; exist at all? The method on SPECIALIZER works fine.
737 (defmethod same-specializer-p ((specl1 eql-specializer
)
738 (specl2 eql-specializer
))
739 ;; A bit of deception to confuse the enemy?
740 (eq (specializer-object specl1
) (specializer-object specl2
)))
742 (defmethod specializer-class ((specializer eql-specializer
))
743 (class-of (slot-value specializer
'object
)))
745 (defun specializer-class-or-nil (specializer)
746 (and (standard-specializer-p specializer
)
747 (specializer-class specializer
)))
749 (defun error-need-at-least-n-args (function n
)
750 (%program-error
"~@<The function ~2I~_~S ~I~_requires at least ~W ~
754 (defun types-from-args (generic-function arguments
&optional type-modifier
)
755 (multiple-value-bind (nreq applyp metatypes nkeys arg-info
)
756 (get-generic-fun-info generic-function
)
757 (declare (ignore applyp metatypes nkeys
))
758 (let ((types-rev nil
))
759 (dotimes-fixnum (i nreq
)
761 (error-need-at-least-n-args (generic-function-name generic-function
)
763 (let ((arg (pop arguments
)))
764 (push (if type-modifier
`(,type-modifier
,arg
) arg
) types-rev
)))
765 (values (nreverse types-rev
) arg-info
))))
767 (defun get-wrappers-from-classes (nkeys wrappers classes metatypes
)
768 (let* ((w wrappers
) (w-tail w
) (mt-tail metatypes
))
769 (dolist (class (ensure-list classes
))
770 (unless (eq t
(car mt-tail
))
771 (let ((c-w (class-wrapper class
)))
772 (unless c-w
(return-from get-wrappers-from-classes nil
))
775 (setf (car w-tail
) c-w
776 w-tail
(cdr w-tail
)))))
777 (setq mt-tail
(cdr mt-tail
)))
780 (defun sdfun-for-caching (gf classes
)
781 (let ((types (mapcar #'class-eq-type classes
)))
782 (multiple-value-bind (methods all-applicable-and-sorted-p
)
783 (compute-applicable-methods-using-types gf types
)
784 (let ((generator (get-secondary-dispatch-function1
785 gf methods types nil t all-applicable-and-sorted-p
)))
786 (make-callable generator
787 nil
(mapcar #'class-wrapper classes
))))))
789 (defun value-for-caching (gf classes
)
790 (let ((methods (compute-applicable-methods-using-types
791 gf
(mapcar #'class-eq-type classes
))))
792 (method-plist-value (car methods
) :constant-value
)))
794 (defun default-secondary-dispatch-function (generic-function)
796 (let ((methods (compute-applicable-methods generic-function args
)))
798 (let ((emf (get-effective-method-function generic-function
800 (invoke-emf emf args
))
801 (call-no-applicable-method generic-function args
)))))
803 (define-load-time-global *std-cam-methods
* nil
)
805 (defun compute-applicable-methods-emf (generic-function)
806 (if (eq **boot-state
** 'complete
)
807 (let* ((cam (gdefinition 'compute-applicable-methods
))
808 (cam-methods (compute-applicable-methods-using-types
809 cam
(list `(eql ,generic-function
) t
))))
810 (values (get-effective-method-function cam cam-methods
)
811 (list-elts-eq cam-methods
812 (or *std-cam-methods
*
813 (setq *std-cam-methods
*
814 (compute-applicable-methods-using-types
815 cam
(list `(eql ,cam
) t
)))))))
816 (values #'compute-applicable-methods-function t
)))
818 (defun compute-applicable-methods-emf-std-p (gf)
819 (gf-info-c-a-m-emf-std-p (gf-arg-info gf
)))
821 (defvar *old-c-a-m-gf-methods
* nil
)
823 (defun update-all-c-a-m-gf-info (c-a-m-gf)
824 (let ((methods (generic-function-methods c-a-m-gf
)))
825 (if (and *old-c-a-m-gf-methods
*
826 (every (lambda (old-method)
827 (member old-method methods
:test
#'eq
))
828 *old-c-a-m-gf-methods
*))
829 (let ((gfs-to-do nil
)
830 (gf-classes-to-do nil
))
831 (dolist (method methods
)
832 (unless (member method
*old-c-a-m-gf-methods
* :test
#'eq
)
833 (let ((specl (car (method-specializers method
))))
834 (if (eql-specializer-p specl
)
835 (pushnew (specializer-object specl
) gfs-to-do
:test
#'eq
)
836 (pushnew (specializer-class specl
) gf-classes-to-do
:test
#'eq
)))))
837 (map-all-generic-functions
839 (when (or (member gf gfs-to-do
:test
#'eq
)
840 (dolist (class gf-classes-to-do nil
)
842 (class-precedence-list (class-of gf
))
844 (update-c-a-m-gf-info gf
)))))
845 (map-all-generic-functions #'update-c-a-m-gf-info
))
846 (setq *old-c-a-m-gf-methods
* methods
)))
848 (defun update-gf-info (gf)
849 (update-c-a-m-gf-info gf
)
850 (update-gf-simple-accessor-type gf
))
852 (defun update-c-a-m-gf-info (gf)
853 (unless (early-gf-p gf
)
854 (multiple-value-bind (c-a-m-emf std-p
)
855 (compute-applicable-methods-emf gf
)
856 (let ((arg-info (gf-arg-info gf
)))
857 (setf (gf-info-static-c-a-m-emf arg-info
) c-a-m-emf
)
858 (setf (gf-info-c-a-m-emf-std-p arg-info
) std-p
)))))
860 (defun update-gf-simple-accessor-type (gf)
861 (let ((arg-info (gf-arg-info gf
)))
862 (setf (gf-info-simple-accessor-type arg-info
)
863 (let* ((methods (generic-function-methods gf
))
864 (class (and methods
(class-of (car methods
))))
867 (cond ((or (eq class
*the-class-standard-reader-method
*)
868 (eq class
*the-class-global-reader-method
*))
870 ((or (eq class
*the-class-standard-writer-method
*)
871 (eq class
*the-class-global-writer-method
*))
873 ((eq class
*the-class-global-boundp-method
*)
875 ((eq class
*the-class-global-makunbound-method
*)
877 (when (and (gf-info-c-a-m-emf-std-p arg-info
)
879 (dolist (method (cdr methods
) t
)
880 (unless (eq class
(class-of method
)) (return nil
)))
881 (eq (generic-function-method-combination gf
)
882 *standard-method-combination
*))
886 ;;; CMUCL (Gerd's PCL, 2002-04-25) comment:
888 ;;; Return two values. First value is a function to be stored in
889 ;;; effective slot definition SLOTD for reading it with
890 ;;; SLOT-VALUE-USING-CLASS, setting it with (SETF
891 ;;; SLOT-VALUE-USING-CLASS), testing it with SLOT-BOUNDP-USING-CLASS,
892 ;;; or making it unbound with SLOT-MAKUNBOUND-USING-CLASS. GF is one
893 ;;; of these generic functions, TYPE is one of the symbols READER,
894 ;;; WRITER, BOUNDP, MAKUNBOUND. CLASS is SLOTD's class.
896 ;;; Second value is true if the function returned is one of the
897 ;;; optimized standard functions for the purpose, which are used
898 ;;; when only standard methods are applicable.
900 ;;; FIXME: Change all these wacky function names to something sane.
901 (defun get-accessor-method-function (gf type class slotd
)
902 (let* ((std-method (standard-svuc-method type
))
903 (str-method (structure-svuc-method type
))
904 (types1 `((eql ,class
) (class-eq ,class
) (eql ,slotd
)))
905 (types (if (eq type
'writer
) `(t ,@types1
) types1
))
906 (methods (compute-applicable-methods-using-types gf types
))
907 (std-p (null (cdr methods
))))
910 (get-optimized-std-accessor-method-function class slotd type
)
911 (let* ((optimized-std-fun
912 (get-optimized-std-slot-value-using-class-method-function
915 `((,(car (or (member std-method methods
:test
#'eq
)
916 (member str-method methods
:test
#'eq
)
918 'get-accessor-method-function
)))
919 ,optimized-std-fun
)))
921 (let ((wrappers (list (layout-of class
)
922 (class-wrapper class
)
924 (if (eq type
'writer
)
925 (cons (class-wrapper *the-class-t
*) wrappers
)
927 (sdfun (get-secondary-dispatch-function
928 gf methods types method-alist wrappers
)))
929 (get-accessor-from-svuc-method-function class slotd sdfun type
)))
932 ;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp)
933 (defun update-slot-value-gf-info (gf type
)
935 (update-std-or-str-methods gf type
))
936 (when (and (standard-svuc-method type
) (structure-svuc-method type
))
937 (flet ((update-accessor-info (class)
938 (when (class-finalized-p class
)
939 (dolist (slotd (class-slots class
))
940 (compute-slot-accessor-info slotd type gf
)))))
942 (update-accessor-info *new-class
*)
943 (map-all-classes #'update-accessor-info
'slot-object
)))))
945 (define-load-time-global *standard-slot-value-using-class-method
* nil
)
946 (define-load-time-global *standard-setf-slot-value-using-class-method
* nil
)
947 (define-load-time-global *standard-slot-boundp-using-class-method
* nil
)
948 (define-load-time-global *standard-slot-makunbound-using-class-method
* nil
)
949 (define-load-time-global *condition-slot-value-using-class-method
* nil
)
950 (define-load-time-global *condition-setf-slot-value-using-class-method
* nil
)
951 (define-load-time-global *condition-slot-boundp-using-class-method
* nil
)
952 (define-load-time-global *condition-slot-makunbound-using-class-method
* nil
)
953 (define-load-time-global *structure-slot-value-using-class-method
* nil
)
954 (define-load-time-global *structure-setf-slot-value-using-class-method
* nil
)
955 (define-load-time-global *structure-slot-boundp-using-class-method
* nil
)
956 (define-load-time-global *structure-slot-makunbound-using-class-method
* nil
)
958 (defun standard-svuc-method (type)
960 (reader *standard-slot-value-using-class-method
*)
961 (writer *standard-setf-slot-value-using-class-method
*)
962 (boundp *standard-slot-boundp-using-class-method
*)
963 (makunbound *standard-slot-makunbound-using-class-method
*)))
965 (defun set-standard-svuc-method (type method
)
967 (reader (setq *standard-slot-value-using-class-method
* method
))
968 (writer (setq *standard-setf-slot-value-using-class-method
* method
))
969 (boundp (setq *standard-slot-boundp-using-class-method
* method
))
970 (makunbound (setq *standard-slot-makunbound-using-class-method
* method
))))
972 (defun condition-svuc-method (type)
974 (reader *condition-slot-value-using-class-method
*)
975 (writer *condition-setf-slot-value-using-class-method
*)
976 (boundp *condition-slot-boundp-using-class-method
*)
977 (makunbound *condition-slot-makunbound-using-class-method
*)))
979 (defun set-condition-svuc-method (type method
)
981 (reader (setq *condition-slot-value-using-class-method
* method
))
982 (writer (setq *condition-setf-slot-value-using-class-method
* method
))
983 (boundp (setq *condition-slot-boundp-using-class-method
* method
))
984 (makunbound (setq *condition-slot-makunbound-using-class-method
* method
))))
986 (defun structure-svuc-method (type)
988 (reader *structure-slot-value-using-class-method
*)
989 (writer *structure-setf-slot-value-using-class-method
*)
990 (boundp *structure-slot-boundp-using-class-method
*)
991 (makunbound *standard-slot-makunbound-using-class-method
*)))
993 (defun set-structure-svuc-method (type method
)
995 (reader (setq *structure-slot-value-using-class-method
* method
))
996 (writer (setq *structure-setf-slot-value-using-class-method
* method
))
997 (boundp (setq *structure-slot-boundp-using-class-method
* method
))
998 (makunbound (setq *structure-slot-makunbound-using-class-method
* method
))))
1000 (defun update-std-or-str-methods (gf type
)
1001 (dolist (method (generic-function-methods gf
))
1002 (let ((specls (method-specializers method
)))
1003 (when (and (or (not (eq type
'writer
))
1004 (eq (pop specls
) *the-class-t
*))
1005 (every #'classp specls
))
1006 (cond ((and (eq (class-name (car specls
)) 'std-class
)
1007 (eq (class-name (cadr specls
)) 'standard-object
)
1008 (eq (class-name (caddr specls
))
1009 'standard-effective-slot-definition
))
1010 (set-standard-svuc-method type method
))
1011 ((and (eq (class-name (car specls
)) 'condition-class
)
1012 (eq (class-name (cadr specls
)) 'condition
)
1013 (eq (class-name (caddr specls
))
1014 'condition-effective-slot-definition
))
1015 (set-condition-svuc-method type method
))
1016 ((and (eq (class-name (car specls
)) 'structure-class
)
1017 (eq (class-name (cadr specls
)) 'structure-object
)
1018 (eq (class-name (caddr specls
))
1019 'structure-effective-slot-definition
))
1020 (set-structure-svuc-method type method
)))))))
1022 (defun mec-all-classes-internal (spec precompute-p
)
1023 (let ((wrapper (class-wrapper (specializer-class spec
))))
1024 (unless (or (not wrapper
) (invalid-wrapper-p wrapper
))
1025 (cons (specializer-class spec
)
1028 (not (or (eq spec
*the-class-t
*)
1029 (eq spec
*the-class-slot-object
*)
1030 (eq spec
*the-class-standard-object
*)
1031 (eq spec
*the-class-structure-object
*)))
1032 (let ((sc (class-direct-subclasses spec
)))
1034 (mapcan (lambda (class)
1035 (mec-all-classes-internal class precompute-p
))
1038 (defun mec-all-classes (spec precompute-p
)
1039 (let ((classes (mec-all-classes-internal spec precompute-p
)))
1040 (if (null (cdr classes
))
1042 (let* ((a-classes (cons nil classes
))
1044 (loop (when (null (cdr tail
))
1045 (return (cdr a-classes
)))
1046 (let ((class (cadr tail
))
1047 (ttail (cddr tail
)))
1048 (if (dolist (c ttail nil
)
1049 (when (eq class c
) (return t
)))
1050 (setf (cdr tail
) (cddr tail
))
1051 (setf tail
(cdr tail
)))))))))
1053 (defun mec-all-class-lists (spec-list precompute-p
)
1054 (if (null spec-list
)
1056 (let* ((car-all-classes (mec-all-classes (car spec-list
)
1058 (all-class-lists (mec-all-class-lists (cdr spec-list
)
1060 (mapcan (lambda (list)
1061 (mapcar (lambda (c) (cons c list
)) car-all-classes
))
1064 (defun make-emf-cache (generic-function valuep cache classes-list new-class
)
1065 (let* ((arg-info (gf-arg-info generic-function
))
1066 (nkeys (arg-info-nkeys arg-info
))
1067 (metatypes (arg-info-metatypes arg-info
))
1068 (wrappers (unless (eq nkeys
1) (make-list nkeys
)))
1069 (precompute-p (gf-precompute-dfun-and-emf-p arg-info
)))
1070 (flet ((add-class-list (classes)
1071 (when (or (null new-class
) (memq new-class classes
))
1072 (let ((%wrappers
(get-wrappers-from-classes
1073 nkeys wrappers classes metatypes
)))
1074 (when (and %wrappers
(not (probe-cache cache %wrappers
)))
1075 (let ((value (cond ((eq valuep t
)
1076 (sdfun-for-caching generic-function
1078 ((eq valuep
:constant-value
)
1079 (value-for-caching generic-function
1081 ;; need to get them again, as finalization might
1082 ;; have happened in between, which would
1083 ;; invalidate wrappers.
1084 (let ((wrappers (get-wrappers-from-classes
1085 nkeys wrappers classes metatypes
)))
1086 (when (if (atom wrappers
)
1087 (not (invalid-wrapper-p wrappers
))
1088 (every (complement #'invalid-wrapper-p
)
1090 (setq cache
(fill-cache cache wrappers value
))))))))))
1092 (mapc #'add-class-list classes-list
)
1093 (dolist (method (generic-function-methods generic-function
))
1094 (mapc #'add-class-list
1095 (mec-all-class-lists (method-specializers method
)
1099 (defmacro class-test
(arg class
)
1101 ((eq class
*the-class-t
*) t
)
1102 ((eq class
*the-class-standard-object
*)
1103 `(or (std-instance-p ,arg
) (fsc-instance-p ,arg
)))
1104 ((eq class
*the-class-funcallable-standard-object
*)
1105 `(fsc-instance-p ,arg
))
1106 ;; This is going to be cached (in *fgens*),
1107 ;; and structure type tests do not check for invalid layout.
1108 ;; Cache the wrapper itself, which is going to be different after
1110 ((structure-class-p class
)
1111 `(sb-c::%instance-typep
,arg
,(class-wrapper class
)))
1113 `(typep ,arg
',(class-name class
)))))
1115 (defmacro class-eq-test
(arg class
)
1116 `(eq (class-of ,arg
) ',class
))
1118 (defun dnet-methods-p (form)
1120 (or (eq (car form
) 'methods
)
1121 (eq (car form
) 'unordered-methods
))))
1123 ;;; This is CASE, but without gensyms.
1124 (defmacro scase
(arg &rest clauses
)
1125 `(let ((.case-arg.
,arg
))
1126 (cond ,@(mapcar (lambda (clause)
1127 (list* (cond ((null (car clause
))
1129 ((consp (car clause
))
1130 (if (null (cdar clause
))
1135 ((member (car clause
) '(t otherwise
))
1138 `(eql .case-arg.
',(car clause
))))
1143 (defmacro mcase
(arg &rest clauses
) `(scase ,arg
,@clauses
))
1145 (defun generate-discrimination-net (generic-function methods types sorted-p
)
1146 (let* ((arg-info (gf-arg-info generic-function
))
1147 (c-a-m-emf-std-p (gf-info-c-a-m-emf-std-p arg-info
))
1148 (precedence (arg-info-precedence arg-info
)))
1149 (generate-discrimination-net-internal
1150 generic-function methods types
1151 (lambda (methods known-types
)
1153 (and c-a-m-emf-std-p
1155 (let ((sorted-methods nil
))
1157 (copy-list methods
) precedence
1159 (when sorted-methods
(return-from one-order-p nil
))
1160 (setq sorted-methods methods
)))
1161 (setq methods sorted-methods
))
1163 `(methods ,methods
,known-types
)
1164 `(unordered-methods ,methods
,known-types
)))
1165 (lambda (position type true-value false-value
)
1166 (let ((arg (dfun-arg-symbol position
)))
1167 (if (eq (car type
) 'eql
)
1168 (let* ((false-case-p (and (consp false-value
)
1169 (or (eq (car false-value
) 'scase
)
1170 (eq (car false-value
) 'mcase
))
1171 (eq arg
(cadr false-value
))))
1172 (false-clauses (if false-case-p
1174 `((t ,false-value
))))
1175 (case-sym (if (and (dnet-methods-p true-value
)
1177 (eq (car false-value
) 'mcase
)
1178 (dnet-methods-p false-value
)))
1181 (type-sym `(,(cadr type
))))
1183 (,type-sym
,true-value
)
1185 `(if ,(let ((arg (dfun-arg-symbol position
)))
1187 (class `(class-test ,arg
,(cadr type
)))
1188 (class-eq `(class-eq-test ,arg
,(cadr type
)))))
1193 (defun class-from-type (type)
1194 (if (or (atom type
) (eq (car type
) t
))
1197 (and (dolist (type (cdr type
) *the-class-t
*)
1198 (when (and (consp type
) (not (eq (car type
) 'not
)))
1199 (return (class-from-type type
)))))
1201 (eql (class-of (cadr type
)))
1202 (class-eq (cadr type
))
1203 (class (cadr type
)))))
1205 ;;; We know that known-type implies neither new-type nor `(not ,new-type).
1206 (defun augment-type (new-type known-type
)
1207 (if (or (eq known-type t
)
1208 (eq (car new-type
) 'eql
))
1210 (let ((so-far (if (and (consp known-type
) (eq (car known-type
) 'and
))
1212 (list known-type
))))
1213 (unless (eq (car new-type
) 'not
)
1215 (mapcan (lambda (type)
1216 (unless (*subtypep new-type type
)
1221 `(and ,new-type
,@so-far
)))))
1223 (defun generate-discrimination-net-internal
1224 (gf methods types methods-function test-fun type-function
)
1225 (let* ((arg-info (gf-arg-info gf
))
1226 (precedence (arg-info-precedence arg-info
))
1227 (nreq (arg-info-number-required arg-info
))
1228 (metatypes (arg-info-metatypes arg-info
)))
1229 (labels ((do-column (p-tail contenders known-types
)
1231 (let* ((position (car p-tail
))
1232 (known-type (or (nth position types
) t
)))
1233 (if (eq (nth position metatypes
) t
)
1234 (do-column (cdr p-tail
) contenders
1235 (cons (cons position known-type
)
1237 (do-methods p-tail contenders
1238 known-type
() known-types
)))
1239 (funcall methods-function contenders
1240 (let ((k-t (make-list nreq
)))
1241 (dolist (index+type known-types
)
1242 (setf (nth (car index
+type
) k-t
)
1245 (do-methods (p-tail contenders known-type winners known-types
)
1247 ;; is a (sorted) list of methods that must be discriminated.
1249 ;; is the type of this argument, constructed from tests
1252 ;; is a (sorted) list of methods that are potentially
1253 ;; applicable after the discrimination has been made.
1254 (if (null contenders
)
1255 (do-column (cdr p-tail
)
1257 (cons (cons (car p-tail
) known-type
)
1259 (let* ((position (car p-tail
))
1260 (method (car contenders
))
1261 (specl (nth position
(method-specializers method
)))
1262 (type (funcall type-function
1263 (type-from-specializer specl
))))
1264 (multiple-value-bind (app-p maybe-app-p
)
1265 (specializer-applicable-using-type-p type known-type
)
1266 (flet ((determined-to-be (truth-value)
1267 (if truth-value app-p
(not maybe-app-p
)))
1268 (do-if (truth &optional implied
)
1269 (let ((ntype (if truth type
`(not ,type
))))
1274 (augment-type ntype known-type
))
1276 (append winners
`(,method
))
1279 (cond ((determined-to-be nil
) (do-if nil t
))
1280 ((determined-to-be t
) (do-if t t
))
1281 (t (funcall test-fun position type
1282 (do-if t
) (do-if nil
))))))))))
1283 (do-column precedence methods
()))))
1285 (defvar *eq-case-table-limit
* 15)
1286 (defvar *case-table-limit
* 10)
1288 (defun compute-mcase-parameters (case-list)
1289 (unless (eq t
(caar (last case-list
)))
1290 (error "The key for the last case arg to mcase was not T"))
1291 (let* ((eq-p (dolist (case case-list t
)
1292 (unless (or (eq (car case
) t
)
1293 (symbolp (caar case
)))
1295 (len (1- (length case-list
)))
1296 (type (cond ((= len
1)
1300 *eq-case-table-limit
*
1301 *case-table-limit
*))
1307 (defmacro mlookup
(key info default
&optional eq-p type
)
1308 (unless (or (eq eq-p t
) (null eq-p
))
1309 (bug "Invalid eq-p argument: ~S" eq-p
))
1313 (declare (optimize (inhibit-warnings 3)))
1314 (,(if eq-p
'eq
'eql
) ,key
(car ,info
)))
1318 `(dolist (e ,info
,default
)
1320 (declare (optimize (inhibit-warnings 3)))
1321 (,(if eq-p
'eq
'eql
) (car e
) ,key
))
1324 `(gethash ,key
,info
,default
))))
1326 (defun net-test-converter (form)
1328 (default-test-converter form
)
1330 ((invoke-effective-method-function invoke-fast-method-call
1331 invoke-effective-narrow-method-function
)
1338 `(mlookup ,(cadr form
)
1341 ,@(compute-mcase-parameters (cddr form
))))
1342 (t (default-test-converter form
)))))
1344 (defun net-code-converter (form)
1346 (default-code-converter form
)
1348 ((methods unordered-methods
)
1349 (let ((gensym (gensym)))
1353 (let ((mp (compute-mcase-parameters (cddr form
)))
1354 (gensym (gensym)) (default (gensym)))
1355 (values `(mlookup ,(cadr form
) ,gensym
,default
,@mp
)
1356 (list gensym default
))))
1358 (default-code-converter form
)))))
1360 (defun net-constant-converter (form generic-function
)
1361 (or (let ((c (methods-converter form generic-function
)))
1364 (default-constant-converter form
)
1367 (let* ((mp (compute-mcase-parameters (cddr form
)))
1368 (list (mapcar (lambda (clause)
1369 (let ((key (car clause
))
1370 (meth (cadr clause
)))
1371 (cons (if (consp key
) (car key
) key
)
1373 meth generic-function
))))
1375 (default (car (last list
))))
1376 (list (list* :mcase mp
(nbutlast list
))
1379 (default-constant-converter form
))))))
1381 (defun methods-converter (form generic-function
)
1382 (cond ((and (consp form
) (eq (car form
) 'methods
))
1384 ;; force to heap since the method list is stored in the %CACHE slot
1385 (get-effective-method-function1 generic-function
1386 (ensure-heap-list (cadr form
)))))
1387 ((and (consp form
) (eq (car form
) 'unordered-methods
))
1388 (default-secondary-dispatch-function generic-function
))))
1390 (defun convert-methods (constant method-alist wrappers
)
1391 (if (and (consp constant
)
1392 (eq (car constant
) '.methods.
))
1393 (funcall (cdr constant
) method-alist wrappers
)
1396 (defun convert-table (constant method-alist wrappers
)
1397 (cond ((and (consp constant
)
1398 (eq (car constant
) :mcase
))
1399 (let ((alist (mapcar (lambda (k+m
)
1401 (convert-methods (cdr k
+m
)
1405 (mp (cadr constant
)))
1412 (let ((table (sb-vm:without-arena
1413 (make-hash-table :test
(if (car mp
) 'eq
'eql
)))))
1415 (setf (gethash (car k
+m
) table
) (cdr k
+m
)))
1418 (defun compute-secondary-dispatch-function1 (generic-function net
&optional function-p
)
1420 ((and (eq (car net
) 'methods
) (not function-p
))
1421 (get-effective-method-function1 generic-function
(cadr net
)))
1423 (let* ((name (generic-function-name generic-function
))
1424 (arg-info (gf-arg-info generic-function
))
1425 (metatypes (arg-info-metatypes arg-info
))
1426 (nargs (length metatypes
))
1427 (applyp (arg-info-applyp arg-info
))
1428 (fmc-arg-info (cons nargs applyp
))
1429 (arglist (if function-p
1430 (make-dfun-lambda-list nargs applyp
)
1431 (make-fast-method-call-lambda-list nargs applyp
))))
1432 (multiple-value-bind (cfunction constants
)
1433 ;; We don't want NAMED-LAMBDA for any expressions handed to FNGEN,
1434 ;; because name mismatches will render the hashing ineffective.
1435 (get-fun `(lambda ,arglist
1436 (declare (optimize (sb-c::store-closure-debug-pointer
3)))
1437 ,@(unless function-p
1438 `((declare (ignore .pv. .next-method-call.
))))
1439 (locally (declare #.
*optimize-speed
*)
1441 ,(make-emf-call nargs applyp
'emf
))))
1442 #'net-test-converter
1443 #'net-code-converter
1445 (net-constant-converter form generic-function
)))
1446 (lambda (method-alist wrappers
)
1447 (let* ((alist (list nil
))
1449 (dolist (constant constants
)
1450 (let* ((a (or (dolist (a alist nil
)
1451 (when (eq (car a
) constant
)
1455 constant method-alist wrappers
)
1457 constant method-alist wrappers
)))))
1459 (setf (cdr alist-tail
) new
)
1460 (setf alist-tail new
)))
1461 (let ((function (apply cfunction
(mapcar #'cdr
(cdr alist
)))))
1463 (set-fun-name function
`(gf-dispatch ,name
))
1464 (make-fast-method-call
1465 :function
(set-fun-name function
`(sdfun-method ,name
))
1466 :arg-info fmc-arg-info
))))))))))
1468 (defvar *show-make-unordered-methods-emf-calls
* nil
)
1470 (defun make-unordered-methods-emf (generic-function methods
)
1471 (when *show-make-unordered-methods-emf-calls
*
1472 (format t
"~&make-unordered-methods-emf ~S~%"
1473 (generic-function-name generic-function
)))
1474 (lambda (&rest args
)
1475 (let* ((types (types-from-args generic-function args
'eql
))
1476 (smethods (sort-applicable-methods generic-function
1479 (emf (get-effective-method-function generic-function smethods
)))
1480 (invoke-emf emf args
))))
1482 ;;; The value returned by compute-discriminating-function is a function
1483 ;;; object. It is called a discriminating function because it is called
1484 ;;; when the generic function is called and its role is to discriminate
1485 ;;; on the arguments to the generic function and then call appropriate
1486 ;;; method functions.
1488 ;;; A discriminating function can only be called when it is installed as
1489 ;;; the funcallable instance function of the generic function for which
1490 ;;; it was computed.
1492 ;;; More precisely, if compute-discriminating-function is called with
1493 ;;; an argument <gf1>, and returns a result <df1>, that result must
1494 ;;; not be passed to apply or funcall directly. Rather, <df1> must be
1495 ;;; stored as the funcallable instance function of the same generic
1496 ;;; function <gf1> (using SET-FUNCALLABLE-INSTANCE-FUNCTION). Then the
1497 ;;; generic function can be passed to funcall or apply.
1499 ;;; An important exception is that methods on this generic function are
1500 ;;; permitted to return a function which itself ends up calling the value
1501 ;;; returned by a more specific method. This kind of `encapsulation' of
1502 ;;; discriminating function is critical to many uses of the MOP.
1504 ;;; As an example, the following canonical case is legal:
1506 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1507 ;;; (let ((std (call-next-method)))
1509 ;;; (print (list 'call-to-gf gf arg))
1510 ;;; (funcall std arg))))
1512 ;;; Because many discriminating functions would like to use a dynamic
1513 ;;; strategy in which the precise discriminating function changes with
1514 ;;; time it is important to specify how a discriminating function is
1515 ;;; permitted itself to change the funcallable instance function of the
1516 ;;; generic function.
1518 ;;; Discriminating functions may set the funcallable instance function
1519 ;;; of the generic function, but the new value must be generated by making
1520 ;;; a call to COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any
1521 ;;; more specific methods which may have encapsulated the discriminating
1522 ;;; function will get a chance to encapsulate the new, inner discriminating
1525 ;;; This implies that if a discriminating function wants to modify itself
1526 ;;; it should first store some information in the generic function proper,
1527 ;;; and then call compute-discriminating-function. The appropriate method
1528 ;;; on compute-discriminating-function will see the information stored in
1529 ;;; the generic function and generate a discriminating function accordingly.
1531 ;;; The following is an example of a discriminating function which modifies
1532 ;;; itself in accordance with this protocol:
1534 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1536 ;;; (cond (<some condition>
1537 ;;; <store some info in the generic function>
1538 ;;; (set-funcallable-instance-function
1540 ;;; (compute-discriminating-function gf))
1541 ;;; (funcall gf arg))
1543 ;;; <call-a-method-of-gf>))))
1545 ;;; Whereas this code would not be legal:
1547 ;;; (defmethod compute-discriminating-function ((gf my-generic-function))
1549 ;;; (cond (<some condition>
1550 ;;; (set-funcallable-instance-function
1552 ;;; (lambda (a) ..))
1553 ;;; (funcall gf arg))
1555 ;;; <call-a-method-of-gf>))))
1557 ;;; NOTE: All the examples above assume that all instances of the class
1558 ;;; my-generic-function accept only one argument.
1560 (defun slot-value-using-class-dfun (class object slotd
)
1561 (declare (ignore class
))
1562 (funcall (slot-info-reader (slot-definition-info slotd
)) object
))
1564 (defun setf-slot-value-using-class-dfun (new-value class object slotd
)
1565 (declare (ignore class
))
1566 (funcall (slot-info-writer (slot-definition-info slotd
)) new-value object
))
1568 (defun slot-boundp-using-class-dfun (class object slotd
)
1569 (declare (ignore class
))
1570 (funcall (slot-info-boundp (slot-definition-info slotd
)) object
))
1572 (defun slot-makunbound-using-class-dfun (class object slotd
)
1573 (declare (ignore class
))
1574 (funcall (slot-info-makunbound (slot-definition-info slotd
)) object
))
1576 (defun special-case-for-compute-discriminating-function-p (gf)
1577 (or (eq gf
#'slot-value-using-class
)
1578 (eq gf
#'(setf slot-value-using-class
))
1579 (eq gf
#'slot-boundp-using-class
)
1580 (eq gf
#'slot-makunbound-using-class
)))
1582 ;;; this is the normal function for computing the discriminating
1583 ;;; function of a standard-generic-function
1584 (let (initial-print-object-cache)
1585 (defun standard-compute-discriminating-function (gf)
1586 (declare (notinline slot-value
))
1587 (let ((dfun-state (slot-value gf
'dfun-state
)))
1588 (when (special-case-for-compute-discriminating-function-p gf
)
1589 ;; if we have a special case for
1590 ;; COMPUTE-DISCRIMINATING-FUNCTION, then (at least for the
1591 ;; special cases implemented as of 2006-05-09) any information
1592 ;; in the cache is misplaced.
1593 (aver (null dfun-state
)))
1594 (typecase dfun-state
1596 (when (eq gf
(load-time-value #'compute-applicable-methods t
))
1597 (update-all-c-a-m-gf-info gf
))
1598 (cond ((eq gf
(load-time-value #'slot-value-using-class t
))
1599 (update-slot-value-gf-info gf
'reader
)
1600 #'slot-value-using-class-dfun
)
1601 ((eq gf
(load-time-value #'(setf slot-value-using-class
) t
))
1602 (update-slot-value-gf-info gf
'writer
)
1603 #'setf-slot-value-using-class-dfun
)
1604 ((eq gf
(load-time-value #'slot-boundp-using-class t
))
1605 (update-slot-value-gf-info gf
'boundp
)
1606 #'slot-boundp-using-class-dfun
)
1607 ((eq gf
(load-time-value #'slot-makunbound-using-class t
))
1608 (update-slot-value-gf-info gf
'makunbound
)
1609 #'slot-makunbound-using-class-dfun
)
1610 ;; KLUDGE: PRINT-OBJECT is not a special-case in the sense
1611 ;; of having a desperately special discriminating function.
1612 ;; However, it is important that the machinery for printing
1613 ;; conditions for stack and heap exhaustion, and the
1614 ;; restarts offered by the debugger, work without consuming
1615 ;; many extra resources. -- CSR, 2008-06-09
1616 ((eq gf
(locally (declare (optimize (safety 0))) #'print-object
))
1617 (let ((nkeys (nth-value 3 (get-generic-fun-info gf
))))
1619 ;; KLUDGE: someone has defined a method
1620 ;; specialized on the second argument: punt.
1621 (setf initial-print-object-cache nil
)
1622 (make-initial-dfun gf
))
1623 (initial-print-object-cache
1624 (multiple-value-bind (dfun cache info
)
1625 (make-caching-dfun gf
(copy-cache initial-print-object-cache
))
1626 (set-dfun gf dfun cache info
)))
1627 ;; the relevant PRINT-OBJECT methods get defined
1628 ;; late, by delayed DEFMETHOD. We mustn't cache
1629 ;; the effective method for our classes earlier
1630 ;; than the relevant PRINT-OBJECT methods are
1632 ((boundp '*!delayed-defmethod-args
*)
1633 (make-initial-dfun gf
))
1634 (t (multiple-value-bind (dfun cache info
)
1635 (make-final-dfun-internal
1637 (mapcar (lambda (x) (list (find-class x
)))
1638 '(sb-kernel::control-stack-exhausted
1639 sb-kernel
::binding-stack-exhausted
1640 sb-kernel
::alien-stack-exhausted
1641 sb-kernel
::heap-exhausted-error
1643 (setq initial-print-object-cache cache
)
1644 (set-dfun gf dfun
(copy-cache cache
) info
))))))
1645 ((gf-precompute-dfun-and-emf-p (slot-value gf
'arg-info
))
1646 (make-final-dfun gf
))
1648 (make-initial-dfun gf
))))
1649 (function dfun-state
)
1650 (cons (car dfun-state
))))))
1652 ;;; in general we need to support SBCL's encapsulation for generic
1653 ;;; functions: the default implementation of encapsulation changes the
1654 ;;; identity of the function bound to a name, which breaks anything
1655 ;;; class-based, so we implement the encapsulation ourselves in the
1656 ;;; discriminating function.
1657 (defun sb-impl::encapsulate-generic-function
(gf type function
)
1658 (push (cons type function
) (generic-function-encapsulations gf
))
1659 (reinitialize-instance gf
))
1661 (defun sb-impl::unencapsulate-generic-function
(gf type
)
1662 (setf (generic-function-encapsulations gf
)
1663 (remove type
(generic-function-encapsulations gf
)
1664 :key
#'car
:count
1))
1665 (reinitialize-instance gf
))
1666 (defun sb-impl::encapsulated-generic-function-p
(gf type
)
1667 (position type
(generic-function-encapsulations gf
) :key
#'car
))
1668 (defun maybe-encapsulate-discriminating-function (gf encs std
)
1671 (let ((inner (maybe-encapsulate-discriminating-function
1673 (function (cdar encs
)))
1674 (lambda (&rest args
)
1675 (apply function inner args
)))))
1676 (defmethod compute-discriminating-function ((gf standard-generic-function
))
1677 (standard-compute-discriminating-function gf
))
1678 (defmethod compute-discriminating-function :around
((gf standard-generic-function
))
1679 (maybe-encapsulate-discriminating-function
1680 gf
(generic-function-encapsulations gf
) (call-next-method)))
1682 (defmethod (setf class-name
) (new-value class
)
1683 (let ((classoid (layout-classoid (class-wrapper class
))))
1684 (if (and new-value
(symbolp new-value
))
1685 (setf (classoid-name classoid
) new-value
)
1686 (setf (classoid-name classoid
) nil
)))
1687 (reinitialize-instance class
:name new-value
)
1690 (defmethod (setf generic-function-name
) (new-value generic-function
)
1691 (reinitialize-instance generic-function
:name new-value
)
1694 (defmethod function-keywords ((method standard-method
))
1695 (multiple-value-bind (llks nreq nopt keywords
)
1696 (analyze-lambda-list (if (consp method
)
1697 (early-method-lambda-list method
)
1698 (method-lambda-list method
)))
1699 (declare (ignore nreq nopt
))
1700 (values keywords
(ll-kwds-allowp llks
))))
1702 ;;; This is based on the rules of method lambda list congruency
1703 ;;; defined in the spec. The lambda list it constructs is the pretty
1704 ;;; union of the lambda lists of the generic function and of all its
1705 ;;; methods. It doesn't take method applicability into account; we
1706 ;;; also ignore non-public parts of the interface (e.g. &AUX, default
1707 ;;; and supplied-p parameters)
1708 ;;; The compiler uses this for type-checking that callers pass acceptable
1709 ;;; keywords, so don't make this do anything fancy like looking at effective
1710 ;;; methods without also fixing the compiler.
1711 (defmethod generic-function-pretty-arglist ((gf standard-generic-function
) &optional methods-in-compilation-unit
)
1712 (let ((gf-lambda-list (generic-function-lambda-list gf
))
1713 (methods (generic-function-methods gf
)))
1714 (flet ((lambda-list (m)
1715 (or (and methods-in-compilation-unit
1716 (gethash (cons (method-qualifiers m
)
1717 (unparse-specializers gf
(method-specializers m
)))
1718 methods-in-compilation-unit
))
1719 (method-lambda-list m
)))
1721 (multiple-value-bind (kw var
)
1722 (parse-key-arg-spec k
)
1723 (if (and (eql (symbol-package kw
) *keyword-package
*)
1726 (list (list kw var
))))))
1727 (multiple-value-bind (llks required optional rest keys
)
1728 (parse-lambda-list gf-lambda-list
:silent t
)
1729 (if (or (ll-kwds-keyp llks
)
1730 (ll-kwds-restp llks
))
1731 (collect ((keys (mapcar #'canonize keys
)))
1732 ;; Possibly extend the keyword parameters of the gf by
1733 ;; additional key parameters of its methods:
1734 (flet ((process (lambda-list)
1735 (binding* (((m.llks nil nil nil m.keys
)
1736 (parse-lambda-list lambda-list
:silent t
)))
1737 (setq llks
(logior llks m.llks
))
1739 (unless (member (parse-key-arg-spec k
) (keys)
1740 :key
#'parse-key-arg-spec
:test
#'eq
)
1741 (keys (canonize k
)))))))
1743 (process (lambda-list m
))))
1744 (make-lambda-list llks nil required optional rest
(keys)))
1745 (make-lambda-list llks nil required optional
))))))
1747 (defun gf-merge-arglists (methods-in-compilation-unit)
1748 (flet ((canonize (k)
1749 (multiple-value-bind (kw var
)
1750 (parse-key-arg-spec k
)
1751 (if (and (eql (symbol-package kw
) *keyword-package
*)
1754 (list (list kw var
))))))
1755 (with-hash-table-iterator (iterator methods-in-compilation-unit
)
1756 (multiple-value-bind (llks required optional rest keys
)
1757 (parse-lambda-list (nth-value 2 (iterator)) :silent t
)
1758 (if (or (ll-kwds-keyp llks
)
1759 (ll-kwds-restp llks
))
1760 (collect ((keys (mapcar #'canonize keys
)))
1761 ;; Possibly extend the keyword parameters of the gf by
1762 ;; additional key parameters of its methods:
1763 (flet ((process (lambda-list)
1764 (binding* (((m.llks nil nil nil m.keys
)
1765 (parse-lambda-list lambda-list
:silent t
)))
1766 (setq llks
(logior llks m.llks
))
1768 (unless (member (parse-key-arg-spec k
) (keys)
1769 :key
#'parse-key-arg-spec
:test
#'eq
)
1770 (keys (canonize k
)))))))
1773 (multiple-value-bind (more key value
) (iterator)
1774 (declare (ignore key
))
1778 (make-lambda-list llks nil required optional rest
(keys))))
1779 (make-lambda-list llks nil required optional
))))))