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 ;; When running the tests which query for a function type, sb-interpreter
22 ;; can return an answer if there were type declarations for the arguments,
23 ;; except that return type is always unknown. The compiler returns a
24 ;; definitive answer, and sb-eval always answers with just FUNCTION.
25 (defun expect-wild-return-type-p (f)
26 (declare (ignorable f
))
27 (or #+sb-fasteval
(typep f
'sb-interpreter
:interpreted-function
)))
29 (deftest function-lambda-list
.1
30 (function-lambda-list 'cl-user
::one
)
31 (cl-user::a cl-user
::b cl-user
::c
))
33 (deftest function-lambda-list
.2
34 (function-lambda-list 'the
)
35 (sb-c::value-type sb-c
::form
))
37 (deftest function-lambda-list
.3
38 (function-lambda-list #'(sb-pcl::slow-method cl-user
::j
(t)))
39 (sb-pcl::method-args sb-pcl
::next-methods
))
41 (deftest macro-lambda-list
.1
42 (equal (function-lambda-list (defmacro macro-lambda-list
.1-m
(x b
)
48 (deftest macro-lambda-list
.2
49 (equal (function-lambda-list (interpret (defmacro macro-lambda-list
.2-m
(x)
54 (deftest macro-lambda-list
.3
55 (equal (function-lambda-list (defmacro macro-lambda-list
.1-m
(x &optional
(b "abc"))
57 '(x &optional
(b "abc")))
60 (deftest macro-lambda-list
.4
61 (equal (function-lambda-list (defmacro macro-lambda-list
.1-m
(x &key
(b "abc"))
66 (deftest definition-source
.1
67 (values (consp (find-definition-sources-by-name 'vectorp
:vop
))
68 (consp (find-definition-sources-by-name 'check-type
:macro
)))
71 (deftest definition-source-plist
.1
72 (let* ((source (find-definition-source #'cl-user
::one
))
73 (plist (definition-source-plist source
))
74 (pathname (definition-source-pathname source
)))
75 (values (equalp pathname
#p
"SYS:CONTRIB;SB-INTROSPECT;TEST.LISP.NEWEST")
76 (= (definition-source-file-write-date source
)
77 (file-write-date pathname
))
78 (or (equal (getf plist
:test-outer
)
83 ;; Not sure why this fails when interpreted, and don't really care too much.
84 ;; The behavior seems right to me anyway.
85 #.
(if (eq sb-ext
:*evaluator-mode
* :compile
)
86 '(deftest definition-source-plist
.2
87 (let ((plist (definition-source-plist
88 (find-definition-source #'cl-user
::four
))))
89 (values (or (equal (getf plist
:test-outer
) "OUT")
91 (or (equal (getf plist
:test-inner
) "IN")
96 (defun matchp (object form-number
)
97 (let ((ds (sb-introspect:find-definition-source object
)))
98 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
100 (first (sb-introspect:definition-source-form-path ds
))))))
102 (defun matchp-name (type object form-number
)
103 (let ((ds (car (sb-introspect:find-definition-sources-by-name object type
))))
104 (and (pathnamep (sb-introspect:definition-source-pathname ds
))
106 (first (sb-introspect:definition-source-form-path ds
))))))
108 (defun matchp-length (type object form-numbers
)
109 (let ((ds (sb-introspect:find-definition-sources-by-name object type
)))
110 (= (length ds
) form-numbers
)))
112 (deftest find-source-stuff
.1
113 (matchp-name :function
'cl-user
::one
2)
116 (deftest find-source-stuff
.2
117 (matchp #'cl-user
::one
2)
120 (deftest find-source-stuff
.3
121 (matchp-name :generic-function
'cl-user
::two
3)
124 (deftest find-source-stuff
.4
125 (matchp (car (sb-pcl:generic-function-methods
#'cl-user
::two
)) 4)
128 (deftest find-source-stuff
.5
129 (matchp-name :variable
'cl-user
::*a
* 8)
132 (deftest find-source-stuff
.6
133 (matchp-name :variable
'cl-user
::*b
* 9)
136 (deftest find-source-stuff
.7
137 (matchp-name :class
'cl-user
::a
10)
140 (deftest find-source-stuff
.8
141 (matchp-name :condition
'cl-user
::b
11)
144 (deftest find-source-stuff
.9
145 (matchp-name :structure
'cl-user
::c
12)
148 (deftest find-source-stuff
.10
149 (matchp-name :function
'cl-user
::make-c
12)
152 (deftest find-source-stuff
.11
153 (matchp-name :function
'cl-user
::c-e
12)
156 (deftest find-source-stuff
.12
157 (matchp-name :structure
'cl-user
::d
13)
160 (deftest find-source-stuff
.13
161 (matchp-name :function
'cl-user
::make-d
13)
164 (deftest find-source-stuff
.14
165 (matchp-name :function
'cl-user
::d-e
13)
168 (deftest find-source-stuff
.15
169 (matchp-name :package
'cl-user
::e
14)
172 (deftest find-source-stuff
.16
173 (matchp-name :symbol-macro
'cl-user
::f
15)
176 (deftest find-source-stuff
.17
177 (matchp-name :type
'cl-user
::g
16)
180 (deftest find-source-stuff
.18
181 (matchp-name :constant
'cl-user
::+h
+ 17)
184 (deftest find-source-stuff
.19
185 (matchp-length :method
'cl-user
::j
2)
188 (deftest find-source-stuff
.20
189 (matchp-name :macro
'cl-user
::l
20)
192 (deftest find-source-stuff
.21
193 (matchp-name :compiler-macro
'cl-user
::m
21)
196 (deftest find-source-stuff
.22
197 (matchp-name :setf-expander
'cl-user
::n
22)
200 (deftest find-source-stuff
.23
201 (matchp-name :function
'(setf cl-user
::o
) 23)
204 (deftest find-source-stuff
.24
205 (matchp-name :method
'(setf cl-user
::p
) 24)
208 (deftest find-source-stuff
.25
209 (matchp-name :macro
'cl-user
::q
25)
213 (deftest find-source-stuff
.26
214 (matchp-name :method-combination
'cl-user
::r
26)
218 (deftest find-source-stuff
.27
219 (matchp-name :setf-expander
'cl-user
::s
27)
222 (deftest find-source-stuff
.28
223 (let ((fin (make-instance 'sb-mop
:funcallable-standard-object
)))
224 (sb-mop:set-funcallable-instance-function fin
#'cl-user
::one
)
228 (deftest find-source-stuff
.29
231 (sb-profile:profile cl-user
::one
)
232 (matchp-name :function
'cl-user
::one
2))
233 (sb-profile:unprofile cl-user
::one
))
236 (deftest find-source-stuff
.30
237 ;; Test finding a type that isn't one
238 (not (find-definition-sources-by-name 'fboundp
:type
))
241 (deftest find-source-stuff
.31
242 (matchp-name :function
'cl-user
::compile-time-too-fun
28)
245 (deftest find-source-stuff
.32
246 (matchp-name :function
'cl-user
::loaded-as-source-fun
3)
249 (deftest find-source-stuff
.33
250 (matchp-name :variable
'cl-user
::**global
** 29)
253 ;;; Check wrt. interplay of generic functions and their methods.
255 (defgeneric xuuq
(gf.a gf.b
&rest gf.rest
&key gf.k-X
))
256 (defmethod xuuq ((m1.a number
) m1.b
&rest m1.rest
&key gf.k-X m1.k-Y m1.k-Z
)
257 (declare (ignore m1.a m1.b m1.rest gf.k-X m1.k-Y m1.k-Z
))
259 (defmethod xuuq ((m2.a string
) m2.b
&rest m2.rest
&key gf.k-X m1.k-Y m2.k-Q
)
260 (declare (ignore m2.a m2.b m2.rest gf.k-X m1.k-Y m2.k-Q
))
263 ;; XUUQ's lambda list should look similiar to
265 ;; (GF.A GF.B &REST GF.REST &KEY GF.K-X M1.K-Z M1.K-Y M2.K-Q)
267 (deftest gf-interplay
.1
268 (multiple-value-bind (llks required optional rest keys aux more
)
269 (sb-int:parse-lambda-list
(function-lambda-list #'xuuq
))
270 (and (equal required
'(gf.a gf.b
))
272 (eq (car rest
) 'gf.rest
)
273 (and (sb-int:ll-kwds-keyp llks
)
274 (member 'gf.k-X keys
)
275 (member 'm1.k-Y keys
)
276 (member 'm1.k-Z keys
)
277 (member 'm2.k-Q keys
))
278 (not (sb-int:ll-kwds-allowp llks
))
283 ;;; Check what happens when there's no explicit DEFGENERIC.
285 (defmethod kroolz (r1 r2
&optional opt
&aux aux
)
286 (declare (ignore r1 r2 opt aux
))
289 (deftest gf-interplay
.2
290 (equal (function-lambda-list #'kroolz
) '(r1 r2
&optional opt
))
293 ;;;; Check correctness of DEFTYPE-LAMBDA-LIST.
295 (&whole w
&environment e r1 r2
&optional o
&rest rest
&key k1 k2 k3
)
296 (declare (ignore w e r1 r2 o rest k1 k2 k3
))
299 (deftest deftype-lambda-list
.1
300 (deftype-lambda-list 'foobar-type
)
301 (r1 r2
&optional o
&rest rest
&key k1 k2 k3
)
304 (deftest deftype-lambda-list
.2
305 (deftype-lambda-list (gensym))
309 ;; ARRAY is a primitive type with associated translator function.
310 (deftest deftype-lambda-list
.3
311 (deftype-lambda-list 'array
)
312 (&optional
(sb-kernel::element-type
'*) (sb-kernel::dimensions
'*))
315 ;; VECTOR is a primitive type that is defined by means of DEFTYPE.
316 (deftest deftype-lambda-list
.4
317 (deftype-lambda-list 'vector
)
318 (&optional sb-kernel
::element-type sb-kernel
::size
)
321 ;;; Test allocation-information
323 (defun tai (x kind info
&key ignore
)
324 (multiple-value-bind (kind2 info2
) (sb-introspect:allocation-information x
)
325 (unless (eq kind kind2
)
326 (error "wanted ~S, got ~S" kind kind2
))
327 (when (not (null ignore
))
328 (setf info2
(copy-list info2
))
331 (setf info
(copy-list info
))
337 (deftest allocation-information
.1
338 (tai nil
:heap
'(:space
:static
))
341 (deftest allocation-information
.2
342 (tai t
:heap
'(:space
:static
))
346 (deftest allocation-information
.2b
347 (tai '*print-base
* :heap
'(:space
:immobile
))
350 (deftest allocation-information
.2c
351 ;; This is a a test of SBCL genesis that leverages sb-introspect.
352 (tai (sb-kernel::find-fdefn
(elt sb-vm
:+static-fdefns
+ 0))
353 :heap
'(:space
#-immobile-space
:static
#+immobile-space
:immobile
))
356 (deftest allocation-information
.3
357 (tai 42 :immediate nil
)
361 (deftest allocation-information
.3b
362 (tai 42s0
:immediate nil
)
365 ;;; -- It appears that this test can also fail due to systematic issues
366 ;;; (possibly with the C compiler used) which we cannot detect based on
367 ;;; *features*. Until this issue has been fixed, I am marking this test
368 ;;; as failing on Windows to allow installation of the contrib on
369 ;;; affected builds, even if the underlying issue is (possibly?) not even
370 ;;; strictly related to windows. C.f. lp1057631. --DFL
372 (deftest* (allocation-information.4
373 ;; Ignored as per the comment above, even though it seems
374 ;; unlikely that this is the right condition.
375 :fails-on
(or :win32
(and :sparc
:gencgc
)))
377 (tai (make-list 1) :heap
378 `(:space
:dynamic
:generation
0 :write-protected nil
379 :boxed t
:pinned nil
:large nil
)
380 :ignore
(list :page
))
383 ;; FIXME: Figure out what's the right cheney-result. SPARC at least
384 ;; has exhibited both :READ-ONLY and :DYNAMIC, which seems wrong.
389 (setq sb-ext
:*evaluator-mode
* :compile
)
390 (sb-ext:defglobal
*large-obj
* nil
)
392 #+(and gencgc
(or x86 x86-64 ppc
) (not win32
))
394 (setq *print-array
* nil
)
395 (setq *large-obj
* (make-array (* sb-vm
:gencgc-card-bytes
4)
396 :element-type
'(unsigned-byte 8)))
397 (sb-ext:gc
:gen
1) ; Array won't move to a large unboxed page until GC'd
398 (deftest allocation-information
.5
399 (tai *large-obj
* :heap
400 `(:space
:dynamic
:generation
1 :boxed nil
:pinned nil
:large t
)
401 :ignore
(list :page
:write-protected
))
404 (defun page-and-gen (thing)
405 (let ((props (nth-value 1 (allocation-information thing
))))
406 (values (getf props
:page
)
407 (getf props
:generation
))))
409 (defun assert-large-page/gen
/boxedp
(thing-name page gen boxedp
)
411 (let ((props (nth-value 1 (allocation-information (symbol-value thing-name
)))))
412 ;; This FORMAT call has the effect of consuming enough stack space
413 ;; to clobber a lingering pointer to THING from the stack.
414 ;; Without it, the next test iteration (after next GC) will fail.
415 (format (make-string-output-stream) "~S~%" props
)
416 ;; Check that uncopyableness isn't due to pin,
417 ;; or else the test proves nothing.
418 (and (eq (getf props
:pinned
:missing
) nil
)
419 (eq (getf props
:large
) t
)
420 (= (getf props
:page
) page
)
421 (= (getf props
:generation
) gen
)
422 (eq (getf props
:boxed
:missing
) boxedp
))))
424 (deftest* (allocation-information.6 :fails-on
(or :sparc
))
425 ;; Remember, all tests run after all toplevel forms have executed,
426 ;; so if this were (DEFGLOBAL *LARGE-CODE* ... ) or something,
427 ;; the garbage collection explicitly requested for ALLOCATION-INFORMATION.5
428 ;; would have already happened, and thus affected this test as well.
429 ;; So we need to make the objects within each test,
430 ;; while avoiding use of lexical vars that would cause conservative pinning.
431 (multiple-value-bind (page gen
)
434 ;; To get a large-object page, a code object has to exceed
435 ;; LARGE_OBJECT_SIZE and not fit within an open region.
436 ;; (This is a minor bug, because one should be able to
437 ;; create regions as large as desired without affecting
438 ;; determination of whether an object is large.
439 ;; Practically it means is that a small object region
440 ;; is limited to at most 3 pages)
441 ;; 32-bit machines use 64K for code allocation regions,
442 ;; but the large object size can be as small as 16K.
443 ;; 16K might fit in the free space of an open region,
444 ;; and by accident would not go on a large object page.
445 (sb-c:allocate-code-object nil
0
446 (max (* 4 sb-vm
:gencgc-card-bytes
) #-
64-bit
65536))))
447 (declare (notinline format
))
448 (format (make-string-output-stream) "~%")
449 (loop for i from
1 to
5
450 always
(assert-large-page/gen
/boxedp
'*large-obj
* page i t
)))
452 (sb-ext:defglobal
*b
* nil
)
453 (sb-ext:defglobal
*negb
* nil
)
454 (sb-ext:defglobal
*small-bignum
* nil
)
455 (defun get-small-bignum-allocation-information ()
456 (setq *small-bignum
* (+ (+ *b
* (ash 1 100)) *negb
*))
457 (nth-value 1 (allocation-information *small-bignum
*)))
459 (deftest allocation-information
.7
461 (declare (notinline format
))
462 ;; Create a bignum using 4 GC cards
463 (setq *b
* (ash 1 (* sb-vm
:gencgc-card-bytes sb-vm
:n-byte-bits
4)))
464 (setq *negb
* (- *b
*))
465 (and (let ((props (get-small-bignum-allocation-information)))
466 ;; *SMALL-BIGNUM* was created as a large boxed object
467 (and (eq (getf props
:large
) t
)
468 (eq (getf props
:boxed
) t
)))
469 (multiple-value-bind (page gen
) (page-and-gen *b
*)
470 (format (make-string-output-stream) "~%")
471 (loop for i from
1 to
5
473 (and (assert-large-page/gen
/boxedp
'*b
* page i nil
)
474 (let ((props (nth-value 1 (allocation-information *small-bignum
*))))
475 ;; Scrub away the ref to *small-bignum* by making a random call
476 (format (make-broadcast-stream) "~S" props
)
477 ;; Assert that *SMALL-BIGNUM* got moved to a small unboxed page
478 (and (not (getf props
:pinned
:fail
))
479 (not (getf props
:large
:fail
))
480 (not (getf props
:boxed
:fail
)))))))))
483 #.
(if (and (eq sb-ext
:*evaluator-mode
* :compile
) (member :sb-thread
*features
*))
484 '(deftest allocation-information.thread
.1
485 (let ((x (list 1 2 3)))
486 (declare (dynamic-extent x
))
487 (tai x
:stack sb-thread
:*current-thread
*))
494 (let ((x (list 1 2 3)))
495 (declare (dynamic-extent x
))
496 (let ((child (sb-thread:make-thread
498 (sb-introspect:allocation-information x
)))))
499 (equal (list :stack sb-thread
:*current-thread
*)
500 (multiple-value-list (sb-thread:join-thread child
))))))
502 (deftest allocation-information.thread
.2
506 (defun thread-tai2 ()
507 (let* ((sem (sb-thread:make-semaphore
))
509 (child (sb-thread:make-thread
511 (let ((x (list 1 2 3)))
512 (declare (dynamic-extent x
))
514 (sb-thread:wait-on-semaphore sem
)))
518 (equal (list :stack child
)
520 (sb-introspect:allocation-information obj
)))
521 (sb-thread:signal-semaphore sem
)
522 (sb-thread:join-thread child
))))
524 (deftest allocation-information.thread
.3
528 ;;;; Test FUNCTION-TYPE
530 (defun type-equal (typespec1 typespec2
)
531 (or (equal typespec1 typespec2
) ; TYPE= punts on &keywords in FTYPEs.
532 (sb-kernel:type
= (sb-kernel:values-specifier-type typespec1
)
533 (sb-kernel:values-specifier-type typespec2
))))
535 (defmacro interpret
(form)
536 `(let ((sb-ext:*evaluator-mode
* :interpret
))
541 (declaim (ftype (function (integer &optional string
) string
) moon
))
542 (defun moon (int &optional suffix
)
543 (concatenate 'string
(princ-to-string int
) suffix
))
545 (deftest function-type
.1
546 (values (type-equal (function-type 'moon
) (function-type #'moon
))
547 (type-equal (function-type #'moon
)
548 '(function (integer &optional string
)
549 (values string
&rest t
))))
552 (defun sun (x y
&key k1
)
553 (declare (fixnum x y
))
554 (declare (boolean k1
))
555 (declare (ignore x y k1
))
558 (deftest function-type
.2
559 (values (type-equal (function-type 'sun
) (function-type #'sun
))
560 (type-equal (function-type #'sun
)
561 '(function (fixnum fixnum
&key
(:k1
(member nil t
)))
562 (values (member t
) &optional
))))
567 (deftest function-type
.5
570 (values (symbol-name s
))))
571 (type-equal (function-type #'f
)
572 (if (expect-wild-return-type-p #'f
)
573 '(function (symbol) *)
574 '(function (symbol) (values simple-string
&optional
)))))
579 (deftest function-type
.6
585 (type-equal (function-type #'closure
)
586 (if (expect-wild-return-type-p #'closure
)
587 '(function (fixnum) *)
588 '(function (fixnum) (values fixnum
&optional
))))))
591 ;; Anonymous functions
593 (deftest function-type
.7
594 (let ((f #'(lambda (x) (declare (fixnum x
)) x
)))
595 (type-equal (function-type f
)
596 (if (expect-wild-return-type-p f
)
597 '(function (fixnum) *)
598 '(function (fixnum) (values fixnum
&optional
)))))
601 ;; Interpreted functions
604 (deftest function-type
.8
605 (type-equal (function-type (interpret (lambda (x) (declare (fixnum x
)) x
)))
606 '(function (&rest t
) *))
611 (defgeneric earth
(x y
))
613 (deftest function-type
+gfs
.1
614 (values (type-equal (function-type 'earth
) (function-type #'earth
))
615 (type-equal (function-type 'earth
) '(function (t t
) *)))
618 ;; Implicitly created generic functions.
620 ;; (FUNCTION-TYPE 'MARS) => FUNCTION at the moment. (1.0.31.26)
624 (defmethod mars (x y
) (+ x y
))
627 (deftest function-type
+gfs
.2
628 (values (type-equal (function-type 'mars
) (function-type #'mars
))
629 (type-equal (function-type 'mars
) '(function (t t
) *)))
634 (defstruct (struct (:predicate our-struct-p
)
635 (:copier copy-our-struct
))
638 ;; This test doesn't work because the XEP for the out-of-line accessor
639 ;; does not include the type test, and the function gets a signature
640 ;; of (FUNCTION (T) (VALUES FIXNUM &OPTIONAL)). This can easily be fixed
641 ;; by deleting (THE <struct> INSTANCE) from the access form
642 ;; and correspondingly adding a declaration on the type of INSTANCE.
644 ;; Yes, it can be fixed, but it is done this way because it produces
647 (deftest function-type
+defstruct
.1
648 (values (type-equal (function-type 'struct-a
)
649 (function-type #'struct-a
))
650 (type-equal (function-type 'struct-a
)
651 '(function (struct) (values fixnum
&optional
))))
654 (deftest function-type
+defstruct
.2
655 (values (type-equal (function-type 'our-struct-p
)
656 (function-type #'our-struct-p
))
657 (type-equal (function-type 'our-struct-p
)
658 '(function (t) (values (member t nil
) &optional
))))
661 (deftest function-type
+defstruct
.3
662 (values (type-equal (function-type 'copy-our-struct
)
663 (function-type #'copy-our-struct
))
664 (type-equal (function-type 'copy-our-struct
)
665 '(function (struct) (values struct
&optional
))))
668 (defstruct (typed-struct :named
(:type list
)
669 (:predicate typed-struct-p
))
672 (deftest function-type
+defstruct
.4
673 (values (type-equal (function-type 'typed-struct-a
)
674 (function-type #'typed-struct-a
))
675 (type-equal (function-type 'typed-struct-a
)
676 '(function (list) (values fixnum
&optional
))))
679 (deftest function-type
+defstruct
.5
680 (values (type-equal (function-type 'typed-struct-p
)
681 (function-type #'typed-struct-p
))
682 (type-equal (function-type 'typed-struct-p
)
683 '(function (t) (values (member t nil
) &optional
))))
690 (defun (setf sun
) (value x y
&key k1
)
691 (declare (boolean value
))
692 (declare (fixnum x y
))
693 (declare (boolean k1
))
694 (declare (ignore x y k1
))
697 (deftest function-type
+setf
.1
698 (values (type-equal (function-type '(setf sun
))
699 (function-type #'(setf sun
)))
700 (type-equal (function-type '(setf sun
))
701 '(function ((member nil t
)
703 &key
(:k1
(member nil t
)))
704 (values (member nil t
) &optional
))))
709 (deftest function-type
+misc
.1
711 (type-equal (function-type #'nullary
)
712 (if (expect-wild-return-type-p #'nullary
)
714 '(function () (values null
&optional
)))))
717 ;;; Defstruct accessor, copier, and predicate
719 (deftest defstruct-fun-sources
720 (let ((copier (find-definition-source #'cl-user
::copy-three
))
721 (accessor (find-definition-source #'cl-user
::three-four
))
722 (predicate (find-definition-source #'cl-user
::three-p
)))
723 (values (and (equalp copier accessor
)
724 (equalp copier predicate
))
725 (equal "TEST.LISP.NEWEST"
726 (file-namestring (definition-source-pathname copier
)))
728 (definition-source-form-path copier
))))
733 (deftest defstruct-fun-sources-by-name
734 (let ((copier (car (find-definition-sources-by-name 'cl-user
::copy-three
:function
)))
735 (accessor (car (find-definition-sources-by-name 'cl-user
::three-four
:function
)))
736 (predicate (car (find-definition-sources-by-name 'cl-user
::three-p
:function
))))
737 (values (and (equalp copier accessor
)
738 (equalp copier predicate
))
739 (equal "TEST.LISP.NEWEST"
740 (file-namestring (definition-source-pathname copier
)))
742 (definition-source-form-path copier
))))
747 (deftest alien-type
.1
748 (matchp-name :alien-type
'cl-user
::test-alien-type
30)
751 (deftest alien-type
.2
752 (matchp-name :alien-type
'cl-user
::test-alien-struct
31)
755 (deftest alien-variable
756 (matchp-name :variable
'cl-user
::test-alien-var
32)
759 (deftest condition-slot-reader
760 (matchp-name :method
'cl-user
::condition-slot-reader
33)
763 (deftest condition-slot-writer
764 (matchp-name :method
'cl-user
::condition-slot-writer
33)
767 (deftest function-with-a-local-function
768 (sb-introspect:definition-source-form-number
769 (car (sb-introspect:find-definition-sources-by-name
770 'cl-user
::with-a-local-function
:function
)))