1 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
10 (defpackage :sb-introspect-test
11 (:use
"SB-INTROSPECT" "CL" "SB-RT"))
13 (in-package :sb-introspect-test
)
15 (defmacro deftest
* ((name &key fails-on
) form
&rest results
)
17 (when (sb-impl::featurep
',fails-on
)
18 (pushnew ',name sb-rt
::*expected-failures
*))
19 (deftest ,name
,form
,@results
)))
21 (deftest function-lambda-list
.1
22 (function-lambda-list 'cl-user
::one
)
23 (cl-user::a cl-user
::b cl-user
::c
))
25 (deftest function-lambda-list
.2
26 (function-lambda-list 'the
)
27 (sb-c::value-type sb-c
::form
))
29 (deftest function-lambda-list
.3
30 (function-lambda-list #'(sb-pcl::slow-method cl-user
::j
(t)))
31 (sb-pcl::method-args sb-pcl
::next-methods
))
33 (deftest macro-lambda-list
.1
34 (equal (function-lambda-list (defmacro macro-lambda-list
.1-m
(x b
)
40 (deftest macro-lambda-list
.2
41 (equal (function-lambda-list (interpret (defmacro macro-lambda-list
.2-m
(x)
46 (deftest definition-source
.1
47 (values (consp (find-definition-sources-by-name 'check-type
:vop
))
48 (consp (find-definition-sources-by-name 'check-type
:macro
)))
51 (deftest definition-source-plist
.1
52 (let* ((source (find-definition-source #'cl-user
::one
))
53 (plist (definition-source-plist source
))
54 (pathname (definition-source-pathname source
)))
55 (values (equalp pathname
#p
"SYS:CONTRIB;SB-INTROSPECT;TEST.LISP.NEWEST")
56 (= (definition-source-file-write-date source
)
57 (file-write-date pathname
))
58 (or (equal (getf plist
:test-outer
)
63 (deftest definition-source-plist
.2
64 (let ((plist (definition-source-plist
65 (find-definition-source #'cl-user
::four
))))
66 (values (or (equal (getf plist
:test-outer
) "OUT")
68 (or (equal (getf plist
:test-inner
) "IN")
72 (defun matchp (object form-number
)
73 (let ((ds (sb-introspect:find-definition-source object
)))
74 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
76 (first (sb-introspect:definition-source-form-path ds
))))))
78 (defun matchp-name (type object form-number
)
79 (let ((ds (car (sb-introspect:find-definition-sources-by-name object type
))))
80 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
82 (first (sb-introspect:definition-source-form-path ds
))))))
84 (defun matchp-length (type object form-numbers
)
85 (let ((ds (sb-introspect:find-definition-sources-by-name object type
)))
86 (= (length ds
) form-numbers
)))
88 (deftest find-source-stuff
.1
89 (matchp-name :function
'cl-user
::one
2)
92 (deftest find-source-stuff
.2
93 (matchp #'cl-user
::one
2)
96 (deftest find-source-stuff
.3
97 (matchp-name :generic-function
'cl-user
::two
3)
100 (deftest find-source-stuff
.4
101 (matchp (car (sb-pcl:generic-function-methods
#'cl-user
::two
)) 4)
104 (deftest find-source-stuff
.5
105 (matchp-name :variable
'cl-user
::*a
* 8)
108 (deftest find-source-stuff
.6
109 (matchp-name :variable
'cl-user
::*b
* 9)
112 (deftest find-source-stuff
.7
113 (matchp-name :class
'cl-user
::a
10)
116 (deftest find-source-stuff
.8
117 (matchp-name :condition
'cl-user
::b
11)
120 (deftest find-source-stuff
.9
121 (matchp-name :structure
'cl-user
::c
12)
124 (deftest find-source-stuff
.10
125 (matchp-name :function
'cl-user
::make-c
12)
128 (deftest find-source-stuff
.11
129 (matchp-name :function
'cl-user
::c-e
12)
132 (deftest find-source-stuff
.12
133 (matchp-name :structure
'cl-user
::d
13)
136 (deftest find-source-stuff
.13
137 (matchp-name :function
'cl-user
::make-d
13)
140 (deftest find-source-stuff
.14
141 (matchp-name :function
'cl-user
::d-e
13)
144 (deftest find-source-stuff
.15
145 (matchp-name :package
'cl-user
::e
14)
148 (deftest find-source-stuff
.16
149 (matchp-name :symbol-macro
'cl-user
::f
15)
152 (deftest find-source-stuff
.17
153 (matchp-name :type
'cl-user
::g
16)
156 (deftest find-source-stuff
.18
157 (matchp-name :constant
'cl-user
::+h
+ 17)
160 (deftest find-source-stuff
.19
161 (matchp-length :method
'cl-user
::j
2)
164 (deftest find-source-stuff
.20
165 (matchp-name :macro
'cl-user
::l
20)
168 (deftest find-source-stuff
.21
169 (matchp-name :compiler-macro
'cl-user
::m
21)
172 (deftest find-source-stuff
.22
173 (matchp-name :setf-expander
'cl-user
::n
22)
176 (deftest find-source-stuff
.23
177 (matchp-name :function
'(setf cl-user
::o
) 23)
180 (deftest find-source-stuff
.24
181 (matchp-name :method
'(setf cl-user
::p
) 24)
184 (deftest find-source-stuff
.25
185 (matchp-name :macro
'cl-user
::q
25)
189 (deftest find-source-stuff
.26
190 (matchp-name :method-combination
'cl-user
::r
26)
194 (deftest find-source-stuff
.27
195 (matchp-name :setf-expander
'cl-user
::s
27)
198 (deftest find-source-stuff
.28
199 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
200 (sb-mop:set-funcallable-instance-function fin
#'cl-user
::one
)
204 (deftest find-source-stuff
.29
207 (sb-profile:profile cl-user
::one
)
208 (matchp-name :function
'cl-user
::one
2))
209 (sb-profile:unprofile cl-user
::one
))
212 (deftest find-source-stuff
.30
213 ;; Test finding a type that isn't one
214 (not (find-definition-sources-by-name 'fboundp
:type
))
217 (deftest find-source-stuff
.31
218 (matchp-name :function
'cl-user
::compile-time-too-fun
28)
221 (deftest find-source-stuff
.32
222 (matchp-name :function
'cl-user
::loaded-as-source-fun
3)
225 (deftest find-source-stuff
.33
226 (matchp-name :variable
'cl-user
::**global
** 29)
229 ;;; Check wrt. interplay of generic functions and their methods.
231 (defgeneric xuuq
(gf.a gf.b
&rest gf.rest
&key gf.k-X
))
232 (defmethod xuuq ((m1.a number
) m1.b
&rest m1.rest
&key gf.k-X m1.k-Y m1.k-Z
)
233 (declare (ignore m1.a m1.b m1.rest gf.k-X m1.k-Y m1.k-Z
))
235 (defmethod xuuq ((m2.a string
) m2.b
&rest m2.rest
&key gf.k-X m1.k-Y m2.k-Q
)
236 (declare (ignore m2.a m2.b m2.rest gf.k-X m1.k-Y m2.k-Q
))
239 ;; XUUQ's lambda list should look similiar to
241 ;; (GF.A GF.B &REST GF.REST &KEY GF.K-X M1.K-Z M1.K-Y M2.K-Q)
243 (deftest gf-interplay
.1
244 (multiple-value-bind (llks required optional rest keys aux more
)
245 (sb-int:parse-lambda-list
(function-lambda-list #'xuuq
))
246 (and (equal required
'(gf.a gf.b
))
248 (eq (car rest
) 'gf.rest
)
249 (and (sb-int:ll-kwds-keyp llks
)
250 (member 'gf.k-X keys
)
251 (member 'm1.k-Y keys
)
252 (member 'm1.k-Z keys
)
253 (member 'm2.k-Q keys
))
254 (not (sb-int:ll-kwds-allowp llks
))
259 ;;; Check what happens when there's no explicit DEFGENERIC.
261 (defmethod kroolz (r1 r2
&optional opt
&aux aux
)
262 (declare (ignore r1 r2 opt aux
))
265 (deftest gf-interplay
.2
266 (equal (function-lambda-list #'kroolz
) '(r1 r2
&optional opt
))
269 ;;;; Check correctness of DEFTYPE-LAMBDA-LIST.
271 (&whole w
&environment e r1 r2
&optional o
&rest rest
&key k1 k2 k3
)
272 (declare (ignore w e r1 r2 o rest k1 k2 k3
))
275 (deftest deftype-lambda-list
.1
276 (deftype-lambda-list 'foobar-type
)
277 (r1 r2
&optional o
&rest rest
&key k1 k2 k3
)
280 (deftest deftype-lambda-list
.2
281 (deftype-lambda-list (gensym))
285 ;; ARRAY is a primitive type with associated translator function.
286 (deftest deftype-lambda-list
.3
287 (deftype-lambda-list 'array
)
288 (&optional
(sb-kernel::element-type
'*) (sb-kernel::dimensions
'*))
291 ;; VECTOR is a primitive type that is defined by means of DEFTYPE.
292 (deftest deftype-lambda-list
.4
293 (deftype-lambda-list 'vector
)
294 (&optional sb-kernel
::element-type sb-kernel
::size
)
297 ;;; Test allocation-information
299 (defun tai (x kind info
&key ignore
)
300 (multiple-value-bind (kind2 info2
) (sb-introspect:allocation-information x
)
301 (unless (eq kind kind2
)
302 (error "wanted ~S, got ~S" kind kind2
))
303 (when (not (null ignore
))
304 (setf info2
(copy-list info2
))
307 (setf info
(copy-list info
))
312 (deftest allocation-infromation
.1
313 (tai nil
:heap
'(:space
:static
))
316 (deftest allocation-information
.2
317 (tai t
:heap
'(:space
:static
))
320 (deftest allocation-information
.3
321 (tai 42 :immediate nil
)
324 (deftest allocation-information
.3b
325 (tai 42s0
:immediate nil
)
329 (deftest allocation-information.thread
.1
330 (let ((x (list 1 2 3)))
331 (declare (dynamic-extent x
))
332 (tai x
:stack sb-thread
:*current-thread
*))
338 (let ((x (list 1 2 3)))
339 (declare (dynamic-extent x
))
340 (let ((child (sb-thread:make-thread
342 (sb-introspect:allocation-information x
)))))
343 (equal (list :stack sb-thread
:*current-thread
*)
344 (multiple-value-list (sb-thread:join-thread child
))))))
346 (deftest allocation-information.thread
.2
350 (defun thread-tai2 ()
351 (let* ((sem (sb-thread:make-semaphore
))
353 (child (sb-thread:make-thread
355 (let ((x (list 1 2 3)))
356 (declare (dynamic-extent x
))
358 (sb-thread:wait-on-semaphore sem
)))
362 (equal (list :stack child
)
364 (sb-introspect:allocation-information obj
)))
365 (sb-thread:signal-semaphore sem
)
366 (sb-thread:join-thread child
))))
368 (deftest allocation-information.thread
.3
372 ;;;; Test FUNCTION-TYPE
374 (defun type-equal (typespec1 typespec2
)
375 (or (equal typespec1 typespec2
) ; TYPE= punts on &keywords in FTYPEs.
376 (sb-kernel:type
= (sb-kernel:values-specifier-type typespec1
)
377 (sb-kernel:values-specifier-type typespec2
))))
379 (defmacro interpret
(form)
380 `(let ((sb-ext:*evaluator-mode
* :interpret
))
385 (declaim (ftype (function (integer &optional string
) string
) moon
))
386 (defun moon (int &optional suffix
)
387 (concatenate 'string
(princ-to-string int
) suffix
))
389 (deftest function-type
.1
390 (values (type-equal (function-type 'moon
) (function-type #'moon
))
391 (type-equal (function-type #'moon
)
392 '(function (integer &optional string
)
393 (values string
&rest t
))))
396 (defun sun (x y
&key k1
)
397 (declare (fixnum x y
))
398 (declare (boolean k1
))
399 (declare (ignore x y k1
))
402 (deftest function-type
.2
403 (values (type-equal (function-type 'sun
) (function-type #'sun
))
404 (type-equal (function-type #'sun
)
405 '(function (fixnum fixnum
&key
(:k1
(member nil t
)))
406 (values (member t
) &optional
))))
411 (deftest function-type
.5
414 (values (symbol-name s
))))
415 (type-equal (function-type #'f
)
416 '(function (symbol) (values simple-string
&optional
))))
421 (deftest function-type
.6
427 (type-equal (function-type #'closure
)
428 '(function (fixnum) (values fixnum
&optional
)))))
431 ;; Anonymous functions
433 (deftest function-type
.7
434 (type-equal (function-type #'(lambda (x) (declare (fixnum x
)) x
))
435 '(function (fixnum) (values fixnum
&optional
)))
438 ;; Interpreted functions
441 (deftest function-type
.8
442 (type-equal (function-type (interpret (lambda (x) (declare (fixnum x
)) x
)))
443 '(function (&rest t
) *))
448 (defgeneric earth
(x y
))
450 (deftest function-type
+gfs
.1
451 (values (type-equal (function-type 'earth
) (function-type #'earth
))
452 (type-equal (function-type 'earth
) '(function (t t
) *)))
455 ;; Implicitly created generic functions.
457 ;; (FUNCTION-TYPE 'MARS) => FUNCTION at the moment. (1.0.31.26)
461 (defmethod mars (x y
) (+ x y
))
464 (deftest function-type
+gfs
.2
465 (values (type-equal (function-type 'mars
) (function-type #'mars
))
466 (type-equal (function-type 'mars
) '(function (t t
) *)))
471 (defstruct (struct (:predicate our-struct-p
)
472 (:copier copy-our-struct
))
475 ;; This test doesn't work because the XEP for the out-of-line accessor
476 ;; does not include the type test, and the function gets a signature
477 ;; of (FUNCTION (T) (VALUES FIXNUM &OPTIONAL)). This can easily be fixed
478 ;; by deleting (THE <struct> INSTANCE) from the access form
479 ;; and correspondingly adding a declaration on the type of INSTANCE.
481 ;; Yes, it can be fixed, but it is done this way because it produces
484 (deftest function-type
+defstruct
.1
485 (values (type-equal (function-type 'struct-a
)
486 (function-type #'struct-a
))
487 (type-equal (function-type 'struct-a
)
488 '(function (struct) (values fixnum
&optional
))))
491 (deftest function-type
+defstruct
.2
492 (values (type-equal (function-type 'our-struct-p
)
493 (function-type #'our-struct-p
))
494 (type-equal (function-type 'our-struct-p
)
495 '(function (t) (values (member t nil
) &optional
))))
498 (deftest function-type
+defstruct
.3
499 (values (type-equal (function-type 'copy-our-struct
)
500 (function-type #'copy-our-struct
))
501 (type-equal (function-type 'copy-our-struct
)
502 '(function (struct) (values struct
&optional
))))
505 (defstruct (typed-struct :named
(:type list
)
506 (:predicate typed-struct-p
))
509 (deftest function-type
+defstruct
.4
510 (values (type-equal (function-type 'typed-struct-a
)
511 (function-type #'typed-struct-a
))
512 (type-equal (function-type 'typed-struct-a
)
513 '(function (list) (values fixnum
&optional
))))
516 (deftest function-type
+defstruct
.5
517 (values (type-equal (function-type 'typed-struct-p
)
518 (function-type #'typed-struct-p
))
519 (type-equal (function-type 'typed-struct-p
)
520 '(function (t) (values (member t nil
) &optional
))))
527 (defun (setf sun
) (value x y
&key k1
)
528 (declare (boolean value
))
529 (declare (fixnum x y
))
530 (declare (boolean k1
))
531 (declare (ignore x y k1
))
534 (deftest function-type
+setf
.1
535 (values (type-equal (function-type '(setf sun
))
536 (function-type #'(setf sun
)))
537 (type-equal (function-type '(setf sun
))
538 '(function ((member nil t
)
540 &key
(:k1
(member nil t
)))
541 (values (member nil t
) &optional
))))
546 (deftest function-type
+misc
.1
548 (type-equal (function-type #'nullary
)
549 '(function () (values null
&optional
))))
552 ;;; Defstruct accessor, copier, and predicate
554 (deftest defstruct-fun-sources
555 (let ((copier (find-definition-source #'cl-user
::copy-three
))
556 (accessor (find-definition-source #'cl-user
::three-four
))
557 (predicate (find-definition-source #'cl-user
::three-p
)))
558 (values (and (equalp copier accessor
)
559 (equalp copier predicate
))
560 (equal "TEST.LISP.NEWEST"
561 (file-namestring (definition-source-pathname copier
)))
563 (definition-source-form-path copier
))))
568 (deftest defstruct-fun-sources-by-name
569 (let ((copier (car (find-definition-sources-by-name 'cl-user
::copy-three
:function
)))
570 (accessor (car (find-definition-sources-by-name 'cl-user
::three-four
:function
)))
571 (predicate (car (find-definition-sources-by-name 'cl-user
::three-p
:function
))))
572 (values (and (equalp copier accessor
)
573 (equalp copier predicate
))
574 (equal "TEST.LISP.NEWEST"
575 (file-namestring (definition-source-pathname copier
)))
577 (definition-source-form-path copier
))))
582 (deftest alien-type
.1
583 (matchp-name :alien-type
'cl-user
::test-alien-type
30)
586 (deftest alien-type
.2
587 (matchp-name :alien-type
'cl-user
::test-alien-struct
31)
590 (deftest alien-variable
591 (matchp-name :variable
'cl-user
::test-alien-var
32)