f1c896b1d50f934f758e171092e6401afc073e85
[sbcl.git] / contrib / sb-introspect / test-driver.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
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.
9
10 (defpackage :sb-introspect-test
11   (:use "SB-INTROSPECT" "CL" "SB-RT"))
12
13 (in-package :sb-introspect-test)
14
15 (deftest function-lambda-list.1
16     (function-lambda-list 'cl-user::one)
17   (cl-user::a cl-user::b cl-user::c))
18
19 (deftest function-lambda-list.2
20     (function-lambda-list 'the)
21   (sb-c::value-type sb-c::form))
22
23 (deftest function-lambda-list.3
24     (function-lambda-list #'(sb-pcl::slow-method cl-user::j (t)))
25   (sb-pcl::method-args sb-pcl::next-methods))
26
27 (deftest definition-source-plist.1
28     (let* ((source (find-definition-source #'cl-user::one))
29            (plist (definition-source-plist source)))
30       (values (= (definition-source-file-write-date source)
31                  (file-write-date "test.lisp"))
32               (or (equal (getf plist :test-outer)
33                          "OUT")
34                   plist)))
35   t t)
36
37 (deftest definition-source-plist.2
38     (let ((plist (definition-source-plist
39                      (find-definition-source #'cl-user::four))))
40       (values (or (equal (getf plist :test-outer) "OUT")
41                   plist)
42               (or (equal (getf plist :test-inner) "IN")
43                   plist)))
44   t t)
45
46 (defun matchp (object form-number)
47   (let ((ds (sb-introspect:find-definition-source object)))
48     (and (pathnamep (sb-introspect:definition-source-pathname ds))
49          (= form-number
50             (first (sb-introspect:definition-source-form-path ds))))))
51
52 (defun matchp-name (type object form-number)
53   (let ((ds (car (sb-introspect:find-definition-sources-by-name object type))))
54     (and (pathnamep (sb-introspect:definition-source-pathname ds))
55          (= form-number
56             (first (sb-introspect:definition-source-form-path ds))))))
57
58 (defun matchp-length (type object form-numbers)
59   (let ((ds (sb-introspect:find-definition-sources-by-name object type)))
60     (= (length ds) form-numbers)))
61
62 (deftest find-source-stuff.1
63     (matchp-name :function 'cl-user::one 2)
64   t)
65
66 (deftest find-source-stuff.2
67     (matchp #'cl-user::one 2)
68   t)
69
70 (deftest find-source-stuff.3
71     (matchp-name :generic-function 'cl-user::two 3)
72   t)
73
74 (deftest find-source-stuff.4
75     (matchp (car (sb-pcl:generic-function-methods #'cl-user::two)) 4)
76   t)
77
78 (deftest find-source-stuff.5
79     (matchp-name :variable 'cl-user::*a* 8)
80   t)
81
82 (deftest find-source-stuff.6
83     (matchp-name :variable 'cl-user::*b* 9)
84   t)
85
86 (deftest find-source-stuff.7
87     (matchp-name :class 'cl-user::a 10)
88   t)
89
90 (deftest find-source-stuff.8
91     (matchp-name :condition 'cl-user::b 11)
92   t)
93
94 (deftest find-source-stuff.9
95     (matchp-name :structure 'cl-user::c 12)
96   t)
97
98 (deftest find-source-stuff.10
99     (matchp-name :function 'cl-user::make-c 12)
100   t)
101
102 (deftest find-source-stuff.11
103     (matchp-name :function 'cl-user::c-e 12)
104   t)
105
106 (deftest find-source-stuff.12
107     (matchp-name :structure 'cl-user::d 13)
108   t)
109
110 (deftest find-source-stuff.13
111     (matchp-name :function 'cl-user::make-d 13)
112   t)
113
114 (deftest find-source-stuff.14
115     (matchp-name :function 'cl-user::d-e 13)
116   t)
117
118 (deftest find-source-stuff.15
119     (matchp-name :package 'cl-user::e 14)
120   t)
121
122 (deftest find-source-stuff.16
123     (matchp-name :symbol-macro 'cl-user::f 15)
124   t)
125
126 (deftest find-source-stuff.17
127     (matchp-name :type 'cl-user::g 16)
128   t)
129
130 (deftest find-source-stuff.18
131     (matchp-name :constant 'cl-user::+h+ 17)
132   t)
133
134 (deftest find-source-stuff.19
135     (matchp-length :method 'cl-user::j 2)
136   t)
137
138 (deftest find-source-stuff.20
139     (matchp-name :macro 'cl-user::l 20)
140   t)
141
142 (deftest find-source-stuff.21
143     (matchp-name :compiler-macro 'cl-user::m 21)
144   t)
145
146 (deftest find-source-stuff.22
147     (matchp-name :setf-expander 'cl-user::n 22)
148   t)
149
150 (deftest find-source-stuff.23
151     (matchp-name :function  '(setf cl-user::o) 23)
152   t)
153
154 (deftest find-source-stuff.24
155     (matchp-name :method  '(setf cl-user::p) 24)
156   t)
157
158 (deftest find-source-stuff.25
159     (matchp-name :macro  'cl-user::q 25)
160   t)
161
162
163 (deftest find-source-stuff.26
164     (matchp-name :method-combination 'cl-user::r 26)
165   t)
166
167
168 (deftest find-source-stuff.27
169     (matchp-name :setf-expander 'cl-user::s 27)
170   t)
171
172 (deftest find-source-stuff.28
173     (let ((fin (make-instance 'sb-mop:funcallable-standard-object)))
174       (sb-mop:set-funcallable-instance-function fin #'cl-user::one)
175       (matchp fin 2))
176   t)
177
178 (deftest find-source-stuff.29
179     (unwind-protect
180          (progn
181            (sb-profile:profile cl-user::one)
182            (matchp-name :function 'cl-user::one 2))
183       (sb-profile:unprofile cl-user::one))
184   t)
185
186 (deftest find-source-stuff.30
187     ;; Test finding a type that isn't one
188     (not (find-definition-sources-by-name 'fboundp :type))
189   t)
190
191 ;;; Check wrt. interplay of generic functions and their methods.
192
193 (defgeneric xuuq (gf.a gf.b          &rest gf.rest &key gf.k-X))
194 (defmethod  xuuq ((m1.a number) m1.b &rest m1.rest &key gf.k-X m1.k-Y m1.k-Z)
195   (declare (ignore m1.a m1.b m1.rest gf.k-X m1.k-Y m1.k-Z))
196   'm1)
197 (defmethod  xuuq ((m2.a string) m2.b &rest m2.rest &key gf.k-X m1.k-Y m2.k-Q)
198   (declare (ignore m2.a m2.b m2.rest gf.k-X m1.k-Y m2.k-Q))
199   'm2)
200
201 ;; XUUQ's lambda list should look similiar to
202 ;;
203 ;;    (GF.A GF.B &REST GF.REST &KEY GF.K-X M1.K-Z M1.K-Y M2.K-Q)
204 ;;
205 (deftest gf-interplay.1
206     (multiple-value-bind (required optional restp rest keyp keys allowp
207                                 auxp aux morep more-context more-count)
208         (sb-int:parse-lambda-list (function-lambda-list #'xuuq))
209       (and (equal required '(gf.a gf.b))
210            (null optional)
211            (and restp (eql rest 'gf.rest))
212            (and keyp
213                 (member 'gf.k-X keys)
214                 (member 'm1.k-Y keys)
215                 (member 'm1.k-Z keys)
216                 (member 'm2.k-Q keys))
217            (not allowp)
218            (and (not auxp) (null aux))
219            (and (not morep) (null more-context) (not more-count))))
220   t)
221
222 ;;; Check what happens when there's no explicit DEFGENERIC.
223
224 (defmethod kroolz (r1 r2 &optional opt &aux aux)
225   (declare (ignore r1 r2 opt aux))
226   'kroolz)
227
228 (deftest gf-interplay.2
229     (equal (function-lambda-list #'kroolz) '(r1 r2 &optional opt))
230   t)
231
232 ;;;; Check correctness of DEFTYPE-LAMBDA-LIST.
233 (deftype foobar-type
234     (&whole w &environment e r1 r2 &optional o &rest rest &key k1 k2 k3)
235   (declare (ignore w e r1 r2 o rest k1 k2 k3))
236   nil)
237
238 (deftest deftype-lambda-list.1
239     (deftype-lambda-list 'foobar-type)
240   (&whole w &environment e r1 r2 &optional o &rest rest &key k1 k2 k3)
241   t)
242
243 (deftest deftype-lambda-list.2
244     (deftype-lambda-list (gensym))
245   nil
246   nil)
247
248 ;; ARRAY is a primitive type with associated translator function.
249 (deftest deftype-lambda-list.3
250     (deftype-lambda-list 'array)
251   (&optional (sb-kernel::element-type '*) (sb-kernel::dimensions '*))
252   t)
253
254 ;; VECTOR is a primitive type that is defined by means of DEFTYPE.
255 (deftest deftype-lambda-list.4
256     (deftype-lambda-list 'vector)
257   (&optional sb-kernel::element-type sb-kernel::size)
258   t)
259
260 ;;; Test allocation-information
261
262 (defun tai (x kind info &key ignore)
263   (multiple-value-bind (kind2 info2) (sb-introspect:allocation-information x)
264     (unless (eq kind kind2)
265       (error "wanted ~S, got ~S" kind kind2))
266     (when (not (null ignore))
267       (setf info2 (copy-list info2))
268       (dolist (key ignore)
269         (remf info2 key))
270       (setf info (copy-list info))
271       (dolist (key ignore)
272         (remf info key)))
273     (equal info info2)))
274
275 (deftest allocation-infromation.1
276     (tai nil :heap '(:space :static))
277   t)
278
279 (deftest allocation-information.2
280     (tai t :heap '(:space :static))
281   t)
282
283 (deftest allocation-information.3
284     (tai 42 :immediate nil)
285   t)
286
287 (deftest allocation-information.4
288     #+gencgc
289     (tai #'cons :heap
290          ;; FIXME: This is the canonical GENCGC result. On PPC we sometimes get
291          ;; :LARGE T, which doesn't seem right -- but ignore that for now.
292          '(:space :dynamic :generation 6 :write-protected t :boxed t :pinned nil :large nil)
293          :ignore #+ppc '(:large) #-ppc nil)
294     #-gencgc
295     (tai :cons :heap
296          ;; FIXME: Figure out what's the right cheney-result. SPARC at least
297          ;; has exhibited both :READ-ONLY and :DYNAMIC, which seems wrong.
298          '()
299          :ignore '(:space))
300   t)
301
302 #+sb-thread
303 (deftest allocation-information.thread.1
304     (let ((x (list 1 2 3)))
305       (declare (dynamic-extent x))
306       (tai x :stack sb-thread:*current-thread*))
307   t)
308
309 #+sb-thread
310 (progn
311    (defun thread-tai ()
312      (let ((x (list 1 2 3)))
313        (declare (dynamic-extent x))
314        (let ((child (sb-thread:make-thread
315                      (lambda ()
316                        (sb-introspect:allocation-information x)))))
317          (equal (list :stack sb-thread:*current-thread*)
318                 (multiple-value-list (sb-thread:join-thread child))))))
319
320    (deftest allocation-information.thread.2
321        (thread-tai)
322      t)
323
324    (defun thread-tai2 ()
325      (let* ((sem (sb-thread:make-semaphore))
326             (obj nil)
327             (child (sb-thread:make-thread
328                     (lambda ()
329                       (let ((x (list 1 2 3)))
330                         (declare (dynamic-extent x))
331                         (setf obj x)
332                         (sb-thread:wait-on-semaphore sem)))
333                     :name "child")))
334        (loop until obj)
335        (unwind-protect
336             (equal (list :stack child)
337                    (multiple-value-list
338                     (sb-introspect:allocation-information obj)))
339          (sb-thread:signal-semaphore sem)
340          (sb-thread:join-thread child))))
341
342    (deftest allocation-information.thread.3
343        (thread-tai2)
344      t))
345
346 ;;;; Test FUNCTION-TYPE
347
348 (defun type-equal (typespec1 typespec2)
349   (or (equal typespec1 typespec2)   ; TYPE= punts on &keywords in FTYPEs.
350       (sb-kernel:type= (sb-kernel:values-specifier-type typespec1)
351                        (sb-kernel:values-specifier-type typespec2))))
352
353 (defmacro interpret (form)
354   `(let ((sb-ext:*evaluator-mode* :interpret))
355      (eval ',form)))
356
357 ;; Functions
358
359 (declaim (ftype (function (integer &optional string) string) moon))
360 (defun moon (int &optional suffix)
361   (concatenate 'string (princ-to-string int) suffix))
362
363 (deftest function-type.1
364     (values (type-equal (function-type 'moon) (function-type #'moon))
365             (type-equal (function-type #'moon)
366                         '(function (integer &optional string)
367                           (values string &rest t))))
368   t t)
369
370 (defun sun (x y &key k1)
371   (declare (fixnum x y))
372   (declare (boolean k1))
373   (declare (ignore x y k1))
374   t)
375
376 (deftest function-type.2
377     (values (type-equal (function-type 'sun) (function-type #'sun))
378             ;; Does not currently work due to Bug #384892. (1.0.31.26)
379             #+nil
380             (type-equal (function-type #'sun)
381                         '(function (fixnum fixnum &key (:k1 (member nil t)))
382                           (values (member t) &optional))))
383   t #+nil t)
384
385 ;; Local functions
386
387 (deftest function-type.5
388     (flet ((f (s)
389              (declare (symbol s))
390              (values (symbol-name s))))
391       (type-equal (function-type #'f)
392                   '(function (symbol) (values simple-string &optional))))
393   t)
394
395 ;; Closures
396
397 (deftest function-type.6
398     (let ((x 10))
399       (declare (fixnum x))
400       (flet ((closure (y)
401                (declare (fixnum y))
402                (setq x (+ x y))))
403         (type-equal (function-type #'closure)
404                     '(function (fixnum) (values fixnum &optional)))))
405   t)
406
407 ;; Anonymous functions
408
409 (deftest function-type.7
410     (type-equal (function-type #'(lambda (x) (declare (fixnum x)) x))
411                 '(function (fixnum) (values fixnum &optional)))
412   t)
413
414 ;; Interpreted functions
415
416 (deftest function-type.8
417     (type-equal (function-type (interpret (lambda (x) (declare (fixnum x)) x)))
418                 '(function (&rest t) *))
419   t)
420
421 ;; Generic functions
422
423 (defgeneric earth (x y))
424
425 (deftest function-type+gfs.1
426     (values (type-equal (function-type 'earth) (function-type #'earth))
427             (type-equal (function-type 'earth) '(function (t t) *)))
428   t t)
429
430 ;; Implicitly created generic functions.
431
432 ;; (FUNCTION-TYPE 'MARS) => FUNCTION at the moment. (1.0.31.26)
433
434 ;; See LP #520695.
435
436 (defmethod mars (x y) (+ x y))
437
438 #+ nil
439 (deftest function-type+gfs.2
440     (values (type-equal (function-type 'mars) (function-type #'mars))
441             (type-equal (function-type 'mars) '(function (t t) *)))
442   t t)
443
444 ;; DEFSTRUCT created functions
445
446 ;; These do not yet work because SB-KERNEL:%FUN-NAME does not work on
447 ;; functions defined by DEFSTRUCT. (1.0.35.x)
448
449 ;; See LP #520692.
450
451 #+nil
452 (progn
453   
454   (defstruct (struct (:predicate our-struct-p)
455                      (:copier copy-our-struct))
456     (a 42 :type fixnum))
457
458   (deftest function-type+defstruct.1
459       (values (type-equal (function-type 'struct-a)
460                           (function-type #'struct-a))
461               (type-equal (function-type 'struct-a)
462                           '(function (struct) (values fixnum &optional))))
463     t t)
464
465   (deftest function-type+defstruct.2
466       (values (type-equal (function-type 'our-struct-p)
467                           (function-type #'our-struct-p))
468               (type-equal (function-type 'our-struct-p)
469                           '(function (t) (values (member t nil) &optional))))
470     t t)
471
472   (deftest function-type+defstruct.3
473       (values (type-equal (function-type 'copy-our-struct)
474                           (function-type #'copy-our-struct))
475               (type-equal (function-type 'copy-our-struct)
476                           '(function (struct) (values struct &optional))))
477     t t)
478
479   (defstruct (typed-struct :named (:type list)
480                            (:predicate typed-struct-p))
481     (a 42 :type fixnum))
482
483   (deftest function-type+defstruct.4
484       (values (type-equal (function-type 'typed-struct-a)
485                           (function-type #'typed-struct-a))
486               (type-equal (function-type 'typed-struct-a)
487                           '(function (list) (values fixnum &optional))))
488     t t)
489
490   (deftest function-type+defstruct.5
491       (values (type-equal (function-type 'typed-struct-p)
492                           (function-type #'typed-struct-p))
493               (type-equal (function-type 'typed-struct-p)
494                           '(function (t) (values (member t nil) &optional))))
495     t t)
496
497   ) ; #+nil (progn ...
498
499 ;; SETF functions
500
501 (defun (setf sun) (value x y &key k1)
502   (declare (boolean value))
503   (declare (fixnum x y))
504   (declare (boolean k1))
505   (declare (ignore x y k1))
506   value)
507
508 (deftest function-type+setf.1
509     (values (type-equal (function-type '(setf sun))
510                         (function-type #'(setf sun)))
511             (type-equal (function-type '(setf sun))
512                         '(function ((member nil t)
513                                     fixnum fixnum
514                                     &key (:k1 (member nil t)))
515                           *)))
516   t t)
517
518 ;; Misc
519
520 (deftest function-type+misc.1
521     (flet ((nullary ()))
522       (type-equal (function-type #'nullary)
523                   '(function () (values null &optional))))
524   t)