-(defun find-ctor-cache (f)
- (let ((code (sb-kernel:fun-code-header f)))
- (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
- for c = (sb-kernel:code-header-ref code i)
- do (when (= sb-vm::value-cell-header-widetag (sb-kernel:widetag-of c))
- (let ((c (sb-vm::value-cell-ref c)))
- (when (and (consp c) (eq 'sb-pcl::ctor-cache (car c)))
- (return c)))))))
-
-;;; FIXME: Move this to test-utils -- compiler tests have / need stuff like this
-;;; as well.
-(defun find-callee (f &key (type t) (name nil namep))
- (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun f))))
- (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
- for c = (sb-kernel:code-header-ref code i)
- do (when (typep c 'sb-impl::fdefn)
- (let ((fun (sb-impl::fdefn-fun c)))
- (when (and (typep fun type)
- (or (not namep)
- (equal name (sb-impl::fdefn-name c))))
- (return fun)))))))
+(defun find-ctor-caches (fun)
+ (remove-if-not (lambda (value)
+ (and (consp value) (eq 'sb-pcl::ctor-cache (car value))))
+ (find-value-cell-values fun)))