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 definition-source-plist
.1
34 (let* ((source (find-definition-source #'cl-user
::one
))
35 (plist (definition-source-plist source
))
36 (pathname (definition-source-pathname source
)))
37 (values (equalp pathname
#p
"SYS:CONTRIB;SB-INTROSPECT;TEST.LISP.NEWEST")
38 (= (definition-source-file-write-date source
)
39 (file-write-date pathname
))
40 (or (equal (getf plist
:test-outer
)
45 (deftest definition-source-plist
.2
46 (let ((plist (definition-source-plist
47 (find-definition-source #'cl-user
::four
))))
48 (values (or (equal (getf plist
:test-outer
) "OUT")
50 (or (equal (getf plist
:test-inner
) "IN")
54 (defun matchp (object form-number
)
55 (let ((ds (sb-introspect:find-definition-source object
)))
56 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
58 (first (sb-introspect:definition-source-form-path ds
))))))
60 (defun matchp-name (type object form-number
)
61 (let ((ds (car (sb-introspect:find-definition-sources-by-name object type
))))
62 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
64 (first (sb-introspect:definition-source-form-path ds
))))))
66 (defun matchp-length (type object form-numbers
)
67 (let ((ds (sb-introspect:find-definition-sources-by-name object type
)))
68 (= (length ds
) form-numbers
)))
70 (deftest find-source-stuff
.1
71 (matchp-name :function
'cl-user
::one
2)
74 (deftest find-source-stuff
.2
75 (matchp #'cl-user
::one
2)
78 (deftest find-source-stuff
.3
79 (matchp-name :generic-function
'cl-user
::two
3)
82 (deftest find-source-stuff
.4
83 (matchp (car (sb-pcl:generic-function-methods
#'cl-user
::two
)) 4)
86 (deftest find-source-stuff
.5
87 (matchp-name :variable
'cl-user
::*a
* 8)
90 (deftest find-source-stuff
.6
91 (matchp-name :variable
'cl-user
::*b
* 9)
94 (deftest find-source-stuff
.7
95 (matchp-name :class
'cl-user
::a
10)
98 (deftest find-source-stuff
.8
99 (matchp-name :condition
'cl-user
::b
11)
102 (deftest find-source-stuff
.9
103 (matchp-name :structure
'cl-user
::c
12)
106 (deftest find-source-stuff
.10
107 (matchp-name :function
'cl-user
::make-c
12)
110 (deftest find-source-stuff
.11
111 (matchp-name :function
'cl-user
::c-e
12)
114 (deftest find-source-stuff
.12
115 (matchp-name :structure
'cl-user
::d
13)
118 (deftest find-source-stuff
.13
119 (matchp-name :function
'cl-user
::make-d
13)
122 (deftest find-source-stuff
.14
123 (matchp-name :function
'cl-user
::d-e
13)
126 (deftest find-source-stuff
.15
127 (matchp-name :package
'cl-user
::e
14)
130 (deftest find-source-stuff
.16
131 (matchp-name :symbol-macro
'cl-user
::f
15)
134 (deftest find-source-stuff
.17
135 (matchp-name :type
'cl-user
::g
16)
138 (deftest find-source-stuff
.18
139 (matchp-name :constant
'cl-user
::+h
+ 17)
142 (deftest find-source-stuff
.19
143 (matchp-length :method
'cl-user
::j
2)
146 (deftest find-source-stuff
.20
147 (matchp-name :macro
'cl-user
::l
20)
150 (deftest find-source-stuff
.21
151 (matchp-name :compiler-macro
'cl-user
::m
21)
154 (deftest find-source-stuff
.22
155 (matchp-name :setf-expander
'cl-user
::n
22)
158 (deftest find-source-stuff
.23
159 (matchp-name :function
'(setf cl-user
::o
) 23)
162 (deftest find-source-stuff
.24
163 (matchp-name :method
'(setf cl-user
::p
) 24)
166 (deftest find-source-stuff
.25
167 (matchp-name :macro
'cl-user
::q
25)
171 (deftest find-source-stuff
.26
172 (matchp-name :method-combination
'cl-user
::r
26)
176 (deftest find-source-stuff
.27
177 (matchp-name :setf-expander
'cl-user
::s
27)
180 (deftest find-source-stuff
.28
181 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
182 (sb-mop:set-funcallable-instance-function fin
#'cl-user
::one
)
186 (deftest find-source-stuff
.29
189 (sb-profile:profile cl-user
::one
)
190 (matchp-name :function
'cl-user
::one
2))
191 (sb-profile:unprofile cl-user
::one
))
194 (deftest find-source-stuff
.30
195 ;; Test finding a type that isn't one
196 (not (find-definition-sources-by-name 'fboundp
:type
))
199 (deftest find-source-stuff
.31
200 (matchp-name :function
'cl-user
::compile-time-too-fun
28)
203 (deftest find-source-stuff
.32
204 (matchp-name :function
'cl-user
::loaded-as-source-fun
3)
207 (deftest find-source-stuff
.33
208 (matchp-name :variable
'cl-user
::**global
** 29)
211 ;;; Check wrt. interplay of generic functions and their methods.
213 (defgeneric xuuq
(gf.a gf.b
&rest gf.rest
&key gf.k-X
))
214 (defmethod xuuq ((m1.a number
) m1.b
&rest m1.rest
&key gf.k-X m1.k-Y m1.k-Z
)
215 (declare (ignore m1.a m1.b m1.rest gf.k-X m1.k-Y m1.k-Z
))
217 (defmethod xuuq ((m2.a string
) m2.b
&rest m2.rest
&key gf.k-X m1.k-Y m2.k-Q
)
218 (declare (ignore m2.a m2.b m2.rest gf.k-X m1.k-Y m2.k-Q
))
221 ;; XUUQ's lambda list should look similiar to
223 ;; (GF.A GF.B &REST GF.REST &KEY GF.K-X M1.K-Z M1.K-Y M2.K-Q)
225 (deftest gf-interplay
.1
226 (multiple-value-bind (required optional restp rest keyp keys allowp
227 auxp aux morep more-context more-count
)
228 (sb-int:parse-lambda-list
(function-lambda-list #'xuuq
))
229 (and (equal required
'(gf.a gf.b
))
231 (and restp
(eql rest
'gf.rest
))
233 (member 'gf.k-X keys
)
234 (member 'm1.k-Y keys
)
235 (member 'm1.k-Z keys
)
236 (member 'm2.k-Q keys
))
238 (and (not auxp
) (null aux
))
239 (and (not morep
) (null more-context
) (not more-count
))))
242 ;;; Check what happens when there's no explicit DEFGENERIC.
244 (defmethod kroolz (r1 r2
&optional opt
&aux aux
)
245 (declare (ignore r1 r2 opt aux
))
248 (deftest gf-interplay
.2
249 (equal (function-lambda-list #'kroolz
) '(r1 r2
&optional opt
))
252 ;;;; Check correctness of DEFTYPE-LAMBDA-LIST.
254 (&whole w
&environment e r1 r2
&optional o
&rest rest
&key k1 k2 k3
)
255 (declare (ignore w e r1 r2 o rest k1 k2 k3
))
258 (deftest deftype-lambda-list
.1
259 (deftype-lambda-list 'foobar-type
)
260 (&whole w
&environment e r1 r2
&optional o
&rest rest
&key k1 k2 k3
)
263 (deftest deftype-lambda-list
.2
264 (deftype-lambda-list (gensym))
268 ;; ARRAY is a primitive type with associated translator function.
269 (deftest deftype-lambda-list
.3
270 (deftype-lambda-list 'array
)
271 (&optional
(sb-kernel::element-type
'*) (sb-kernel::dimensions
'*))
274 ;; VECTOR is a primitive type that is defined by means of DEFTYPE.
275 (deftest deftype-lambda-list
.4
276 (deftype-lambda-list 'vector
)
277 (&optional sb-kernel
::element-type sb-kernel
::size
)
280 ;;; Test allocation-information
282 (defun tai (x kind info
&key ignore
)
283 (multiple-value-bind (kind2 info2
) (sb-introspect:allocation-information x
)
284 (unless (eq kind kind2
)
285 (error "wanted ~S, got ~S" kind kind2
))
286 (when (not (null ignore
))
287 (setf info2
(copy-list info2
))
290 (setf info
(copy-list info
))
295 (deftest allocation-infromation
.1
296 (tai nil
:heap
'(:space
:static
))
299 (deftest allocation-information
.2
300 (tai t
:heap
'(:space
:static
))
303 (deftest allocation-information
.3
304 (tai 42 :immediate nil
)
307 (deftest allocation-information
.3b
308 (tai 42s0
:immediate nil
)
311 ;;; Skip the whole damn test on GENCGC PPC -- the combination is just
312 ;;; to flaky for this to make too much sense. GENCGC SPARC almost
313 ;;; certainly exhibits the same behavior patterns (or antipatterns) as
316 ;;; -- It appears that this test can also fail due to systematic issues
317 ;;; (possibly with the C compiler used) which we cannot detect based on
318 ;;; *features*. Until this issue has been fixed, I am marking this test
319 ;;; as failing on Windows to allow installation of the contrib on
320 ;;; affected builds, even if the underlying issue is (possibly?) not even
321 ;;; strictly related to windows. C.f. lp1057631. --DFL
323 (deftest* (allocation-information.4
324 ;; Ignored as per the comment above, even though it seems
325 ;; unlikely that this is the right condition.
326 :fails-on
(or :win32
(and (or :ppc
:sparc
) :gencgc
)))
329 ;; FIXME: This is the canonical GENCGC result. On PPC we sometimes get
330 ;; :LARGE T, which doesn't seem right -- but ignore that for now.
331 ;; Also the :write-protected value NIL, indicating that the page
332 ;; has been written, seems ok to me, so ignore that too.
333 `(:space
:dynamic
:generation
,sb-vm
:+pseudo-static-generation
+
334 :boxed t
:pinned nil
:large nil
)
335 :ignore
(list :page
:write-protected
#+ppc
:large
))
338 ;; FIXME: Figure out what's the right cheney-result. SPARC at least
339 ;; has exhibited both :READ-ONLY and :DYNAMIC, which seems wrong.
345 (deftest allocation-information.thread
.1
346 (let ((x (list 1 2 3)))
347 (declare (dynamic-extent x
))
348 (tai x
:stack sb-thread
:*current-thread
*))
354 (let ((x (list 1 2 3)))
355 (declare (dynamic-extent x
))
356 (let ((child (sb-thread:make-thread
358 (sb-introspect:allocation-information x
)))))
359 (equal (list :stack sb-thread
:*current-thread
*)
360 (multiple-value-list (sb-thread:join-thread child
))))))
362 (deftest allocation-information.thread
.2
366 (defun thread-tai2 ()
367 (let* ((sem (sb-thread:make-semaphore
))
369 (child (sb-thread:make-thread
371 (let ((x (list 1 2 3)))
372 (declare (dynamic-extent x
))
374 (sb-thread:wait-on-semaphore sem
)))
378 (equal (list :stack child
)
380 (sb-introspect:allocation-information obj
)))
381 (sb-thread:signal-semaphore sem
)
382 (sb-thread:join-thread child
))))
384 (deftest allocation-information.thread
.3
388 ;;;; Test FUNCTION-TYPE
390 (defun type-equal (typespec1 typespec2
)
391 (or (equal typespec1 typespec2
) ; TYPE= punts on &keywords in FTYPEs.
392 (sb-kernel:type
= (sb-kernel:values-specifier-type typespec1
)
393 (sb-kernel:values-specifier-type typespec2
))))
395 (defmacro interpret
(form)
396 `(let ((sb-ext:*evaluator-mode
* :interpret
))
401 (declaim (ftype (function (integer &optional string
) string
) moon
))
402 (defun moon (int &optional suffix
)
403 (concatenate 'string
(princ-to-string int
) suffix
))
405 (deftest function-type
.1
406 (values (type-equal (function-type 'moon
) (function-type #'moon
))
407 (type-equal (function-type #'moon
)
408 '(function (integer &optional string
)
409 (values string
&rest t
))))
412 (defun sun (x y
&key k1
)
413 (declare (fixnum x y
))
414 (declare (boolean k1
))
415 (declare (ignore x y k1
))
418 (deftest function-type
.2
419 (values (type-equal (function-type 'sun
) (function-type #'sun
))
420 (type-equal (function-type #'sun
)
421 '(function (fixnum fixnum
&key
(:k1
(member nil t
)))
422 (values (member t
) &optional
))))
427 (deftest function-type
.5
430 (values (symbol-name s
))))
431 (type-equal (function-type #'f
)
432 '(function (symbol) (values simple-string
&optional
))))
437 (deftest function-type
.6
443 (type-equal (function-type #'closure
)
444 '(function (fixnum) (values fixnum
&optional
)))))
447 ;; Anonymous functions
449 (deftest function-type
.7
450 (type-equal (function-type #'(lambda (x) (declare (fixnum x
)) x
))
451 '(function (fixnum) (values fixnum
&optional
)))
454 ;; Interpreted functions
457 (deftest function-type
.8
458 (type-equal (function-type (interpret (lambda (x) (declare (fixnum x
)) x
)))
459 '(function (&rest t
) *))
464 (defgeneric earth
(x y
))
466 (deftest function-type
+gfs
.1
467 (values (type-equal (function-type 'earth
) (function-type #'earth
))
468 (type-equal (function-type 'earth
) '(function (t t
) *)))
471 ;; Implicitly created generic functions.
473 ;; (FUNCTION-TYPE 'MARS) => FUNCTION at the moment. (1.0.31.26)
477 (defmethod mars (x y
) (+ x y
))
480 (deftest function-type
+gfs
.2
481 (values (type-equal (function-type 'mars
) (function-type #'mars
))
482 (type-equal (function-type 'mars
) '(function (t t
) *)))
487 (defstruct (struct (:predicate our-struct-p
)
488 (:copier copy-our-struct
))
491 ;; This test doesn't work because the XEP for the out-of-line accessor
492 ;; does not include the type test, and the function gets a signature
493 ;; of (FUNCTION (T) (VALUES FIXNUM &OPTIONAL)). This can easily be fixed
494 ;; by deleting (THE <struct> INSTANCE) from the access form
495 ;; and correspondingly adding a declaration on the type of INSTANCE.
497 ;; Yes, it can be fixed, but it is done this way because it produces
500 (deftest function-type
+defstruct
.1
501 (values (type-equal (function-type 'struct-a
)
502 (function-type #'struct-a
))
503 (type-equal (function-type 'struct-a
)
504 '(function (struct) (values fixnum
&optional
))))
507 (deftest function-type
+defstruct
.2
508 (values (type-equal (function-type 'our-struct-p
)
509 (function-type #'our-struct-p
))
510 (type-equal (function-type 'our-struct-p
)
511 '(function (t) (values (member t nil
) &optional
))))
514 (deftest function-type
+defstruct
.3
515 (values (type-equal (function-type 'copy-our-struct
)
516 (function-type #'copy-our-struct
))
517 (type-equal (function-type 'copy-our-struct
)
518 '(function (struct) (values struct
&optional
))))
521 (defstruct (typed-struct :named
(:type list
)
522 (:predicate typed-struct-p
))
525 (deftest function-type
+defstruct
.4
526 (values (type-equal (function-type 'typed-struct-a
)
527 (function-type #'typed-struct-a
))
528 (type-equal (function-type 'typed-struct-a
)
529 '(function (list) (values fixnum
&optional
))))
532 (deftest function-type
+defstruct
.5
533 (values (type-equal (function-type 'typed-struct-p
)
534 (function-type #'typed-struct-p
))
535 (type-equal (function-type 'typed-struct-p
)
536 '(function (t) (values (member t nil
) &optional
))))
543 (defun (setf sun
) (value x y
&key k1
)
544 (declare (boolean value
))
545 (declare (fixnum x y
))
546 (declare (boolean k1
))
547 (declare (ignore x y k1
))
550 (deftest function-type
+setf
.1
551 (values (type-equal (function-type '(setf sun
))
552 (function-type #'(setf sun
)))
553 (type-equal (function-type '(setf sun
))
554 '(function ((member nil t
)
556 &key
(:k1
(member nil t
)))
557 (values (member nil t
) &optional
))))
562 (deftest function-type
+misc
.1
564 (type-equal (function-type #'nullary
)
565 '(function () (values null
&optional
))))
568 ;;; Defstruct accessor, copier, and predicate
570 (deftest defstruct-fun-sources
571 (let ((copier (find-definition-source #'cl-user
::copy-three
))
572 (accessor (find-definition-source #'cl-user
::three-four
))
573 (predicate (find-definition-source #'cl-user
::three-p
)))
574 (values (and (equalp copier accessor
)
575 (equalp copier predicate
))
576 (equal "TEST.LISP.NEWEST"
577 (file-namestring (definition-source-pathname copier
)))
579 (definition-source-form-path copier
))))
584 (deftest defstruct-fun-sources-by-name
585 (let ((copier (car (find-definition-sources-by-name 'cl-user
::copy-three
:function
)))
586 (accessor (car (find-definition-sources-by-name 'cl-user
::three-four
:function
)))
587 (predicate (car (find-definition-sources-by-name 'cl-user
::three-p
:function
))))
588 (values (and (equalp copier accessor
)
589 (equalp copier predicate
))
590 (equal "TEST.LISP.NEWEST"
591 (file-namestring (definition-source-pathname copier
)))
593 (definition-source-form-path copier
))))