1 (require :sb-introspect
)
3 (defpackage :sb-introspect-test
4 (:use
"SB-INTROSPECT" "CL"))
5 (in-package :sb-introspect-test
)
7 (with-compilation-unit (:source-plist
(list :test-outer
"OUT"))
8 (load (compile-file (merge-pathnames "test.lisp" *load-pathname
*))))
10 (assert (equal (function-lambda-list 'cl-user
::one
)
11 '(cl-user::a cl-user
::b cl-user
::c
)))
12 (assert (equal (function-lambda-list 'the
)
13 '(sb-c::value-type sb-c
::form
)))
15 (assert (equal (function-lambda-list #'(sb-pcl::slow-method cl-user
::j
(t)))
16 '(sb-pcl::method-args sb-pcl
::next-methods
)))
18 (let ((source (find-definition-source #'cl-user
::one
)))
19 (assert (= (definition-source-file-write-date source
)
20 (file-write-date (merge-pathnames "test.lisp" *load-pathname
*))))
21 (assert (equal (getf (definition-source-plist source
) :test-outer
)
24 (let ((plist (definition-source-plist
25 (find-definition-source #'cl-user
::four
))))
26 (assert (equal (getf plist
:test-outer
) "OUT"))
27 (assert (equal (getf plist
:test-inner
) "IN")))
29 (defun matchp (object form-number
)
30 (let ((ds (sb-introspect:find-definition-source object
)))
31 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
33 (first (sb-introspect:definition-source-form-path ds
))))))
35 (defun matchp-name (type object form-number
)
36 (let ((ds (car (sb-introspect:find-definition-sources-by-name object type
))))
37 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
39 (first (sb-introspect:definition-source-form-path ds
))))))
41 (defun matchp-length (type object form-numbers
)
42 (let ((ds (sb-introspect:find-definition-sources-by-name object type
)))
43 (= (length ds
) form-numbers
)))
45 (assert (matchp-name :function
'cl-user
::one
2))
46 (assert (matchp #'cl-user
::one
2))
47 (assert (matchp-name :generic-function
'cl-user
::two
3))
48 (assert (matchp (car (sb-pcl:generic-function-methods
#'cl-user
::two
)) 4))
50 (assert (matchp-name :variable
'cl-user
::*a
* 8))
51 (assert (matchp-name :variable
'cl-user
::*b
* 9))
52 (assert (matchp-name :class
'cl-user
::a
10))
53 (assert (matchp-name :condition
'cl-user
::b
11))
54 (assert (matchp-name :structure
'cl-user
::c
12))
55 (assert (matchp-name :function
'cl-user
::make-c
12))
56 (assert (matchp-name :function
'cl-user
::c-e
12))
57 (assert (matchp-name :structure
'cl-user
::d
13))
58 (assert (matchp-name :function
'cl-user
::make-d
13))
59 (assert (matchp-name :function
'cl-user
::d-e
13))
60 (assert (matchp-name :package
'cl-user
::e
14))
61 (assert (matchp-name :symbol-macro
'cl-user
::f
15))
62 (assert (matchp-name :type
'cl-user
::g
16))
63 (assert (matchp-name :constant
'cl-user
::+h
+ 17))
64 (assert (matchp-length :method
'cl-user
::j
2))
65 (assert (matchp-name :macro
'cl-user
::l
20))
66 (assert (matchp-name :compiler-macro
'cl-user
::m
21))
67 (assert (matchp-name :setf-expander
'cl-user
::n
22))
68 (assert (matchp-name :function
'(setf cl-user
::o
) 23))
69 (assert (matchp-name :method
'(setf cl-user
::p
) 24))
70 (assert (matchp-name :macro
'cl-user
::q
25))
71 (assert (matchp-name :method-combination
'cl-user
::r
26))
72 (assert (matchp-name :setf-expander
'cl-user
::s
27))
74 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
75 (sb-mop:set-funcallable-instance-function fin
#'cl-user
::one
)
76 (assert (matchp fin
2)))
78 (sb-profile:profile cl-user
::one
)
79 (assert (matchp-name :function
'cl-user
::one
2))
80 (sb-profile:unprofile cl-user
::one
)
83 ;;;; Check correctness of FUNCTION-LAMBDA-LIST.
85 (assert (equal (function-lambda-list 'cl-user
::one
)
86 '(cl-user::a cl-user
::b cl-user
::c
)))
87 (assert (equal (function-lambda-list 'the
)
88 '(sb-c::value-type sb-c
::form
)))
90 ;;; Check wrt. interplay of generic functions and their methods.
92 (defgeneric xuuq
(gf.a gf.b
&rest gf.rest
&key gf.k-X
))
93 (defmethod xuuq ((m1.a number
) m1.b
&rest m1.rest
&key gf.k-X m1.k-Y m1.k-Z
)
94 (declare (ignore m1.a m1.b m1.rest gf.k-X m1.k-Y m1.k-Z
))
96 (defmethod xuuq ((m2.a string
) m2.b
&rest m2.rest
&key gf.k-X m1.k-Y m2.k-Q
)
97 (declare (ignore m2.a m2.b m2.rest gf.k-X m1.k-Y m2.k-Q
))
100 ;; XUUQ's lambda list should look similiar to
102 ;; (GF.A GF.B &REST GF.REST &KEY GF.K-X M1.K-Z M1.K-Y M2.K-Q)
104 (multiple-value-bind (required optional restp rest keyp keys allowp
105 auxp aux morep more-context more-count
)
106 (sb-int:parse-lambda-list
(function-lambda-list #'xuuq
))
107 (assert (equal required
'(gf.a gf.b
)))
108 (assert (null optional
))
109 (assert (and restp
(eql rest
'gf.rest
)))
111 (member 'gf.k-X keys
)
112 (member 'm1.k-Y keys
)
113 (member 'm1.k-Z keys
)
114 (member 'm2.k-Q keys
)))
115 (assert (not allowp
))
116 (assert (and (not auxp
) (null aux
)))
117 (assert (and (not morep
) (null more-context
) (not more-count
))))
119 ;;; Check what happens when there's no explicit DEFGENERIC.
121 (defmethod kroolz (r1 r2
&optional opt
&aux aux
)
122 (declare (ignore r1 r2 opt aux
))
124 (assert (equal (function-lambda-list #'kroolz
) '(r1 r2
&optional opt
)))
126 ;;;; Test finding a type that isn't one
127 (assert (not (find-definition-sources-by-name 'fboundp
:type
)))
129 ;;;; Check correctness of DEFTYPE-LAMBDA-LIST.
131 (&whole w
&environment e r1 r2
&optional o
&rest rest
&key k1 k2 k3
)
132 (declare (ignore w e r1 r2 o rest k1 k2 k3
))
135 (assert (multiple-value-bind (arglist found?
) (deftype-lambda-list 'foobar-type
)
137 (equal arglist
'(&whole w
&environment e
138 r1 r2
&optional o
&rest rest
&key k1 k2 k3
)))))
140 (assert (equal (multiple-value-list (deftype-lambda-list (gensym)))
144 ;;;; Test the xref facility
146 (load (merge-pathnames "xref-test.lisp" *load-pathname
*))
148 ;;;; Unix success convention for exit codes
149 (sb-ext:quit
:unix-status
0)