1 ;;;; Utilities for verifying features of compiled code
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (defpackage :compiler-test-util
16 (:use :cl :sb-c :sb-kernel)
17 (:export #:compiler-derived-type
18 #:find-value-cell-values
19 #:find-named-callees))
23 (unless (fboundp 'compiler-derived-type)
24 (defknown compiler-derived-type (t) (values t t) (movable flushable unsafe))
25 (deftransform compiler-derived-type ((x) * * :node node)
26 (sb-c::delay-ir1-transform node :optimize)
27 `(values ',(type-specifier (sb-c::lvar-type x)) t))
28 (defun compiler-derived-type (x)
32 (defun find-value-cell-values (fun)
33 (let ((code (fun-code-header (%fun-fun fun))))
34 (loop for i from sb-vm::code-constants-offset below (get-header-data code)
35 for c = (code-header-ref code i)
36 when (= sb-vm::value-cell-header-widetag (widetag-of c))
37 collect (sb-vm::value-cell-ref c))))
39 (defun find-named-callees (fun &key (type t) (name nil namep))
40 (let ((code (sb-kernel:fun-code-header (sb-kernel:%fun-fun fun))))
41 (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code)
42 for c = (sb-kernel:code-header-ref code i)
43 when (and (typep c 'sb-impl::fdefn)
44 (let ((fun (sb-impl::fdefn-fun c)))
47 (equal name (sb-impl::fdefn-name c))))))
48 collect (sb-impl::fdefn-fun c))))