sb-introspect: Skip tests if #-sb-source-locations (lp#1635349)

Couldn't even build because of a style-warning.
And the test file itself caused style-warnings.
Failures occur in several other test files though. Not important.

contrib/sb-introspect/test-driver.lisp

@@ -43,7 +43,7 @@
 
 (deftest macro-lambda-list.1
     (equal (function-lambda-list (defmacro macro-lambda-list.1-m (x b)
-                                   `(x b)))
+                                   `(,x ,b)))
            '(x b))
   t)
 
@@ -60,26 +60,24 @@
 
 (deftest macro-lambda-list.3
     (equal (function-lambda-list (defmacro macro-lambda-list.1-m (x &optional (b "abc"))
-                                   `(x b)))
+                                   `(,x ,b)))
            '(x &optional (b "abc")))
   t)
 
 (deftest macro-lambda-list.4
     (equal (function-lambda-list (defmacro macro-lambda-list.1-m (x &key (b "abc"))
-                                   `(x b)))
+                                   `(,x ,b)))
            '(x &key (b "abc")))
   t)
 
-(deftest definition-source.1
+(test-util:with-test (:name definition-source.1 :skipped-on :no-source-locs)
-    (values (consp (find-definition-sources-by-name 'vectorp :vop))
+  (assert (consp (find-definition-sources-by-name 'vectorp :vop)))
-            (consp (find-definition-sources-by-name 'check-type :macro)))
+  (assert (consp (find-definition-sources-by-name 'check-type :macro))))
-  t t)
 
 (deftest definition-source-plist.1
     (let* ((source (find-definition-source #'cl-user::one))
            (plist (definition-source-plist source))
            (pathname (definition-source-pathname source)))
-      (declare (ignore source))
       ;; the full pathname isn't important
       (values (equalp (pathname-name pathname) "TEST")
               (= (definition-source-file-write-date source)
@@ -121,33 +119,26 @@
     (matchp #'cl-user::one 2)
   t)
 
-(deftest find-source-stuff.3
+(test-util:with-test (:name find-source-stuff.3 :skipped-on :no-source-locs)
-    (matchp-name :generic-function 'cl-user::two 3)
+  (assert (matchp-name :generic-function 'cl-user::two 3)))
-  t)
 
-(deftest find-source-stuff.4
+(test-util:with-test (:name find-source-stuff.4 :skipped-on :no-source-locs)
-    (matchp (car (sb-mop:generic-function-methods #'cl-user::two)) 4)
+  (assert (matchp (car (sb-mop:generic-function-methods #'cl-user::two)) 4)))
-  t)
 
-(deftest find-source-stuff.5
+(test-util:with-test (:name find-source-stuff.5 :skipped-on :no-source-locs)
-    (matchp-name :variable 'cl-user::*a* 8)
+  (assert (matchp-name :variable 'cl-user::*a* 8)))
-  t)
 
-(deftest find-source-stuff.6
+(test-util:with-test (:name find-source-stuff.6 :skipped-on :no-source-locs)
-    (matchp-name :variable 'cl-user::*b* 9)
+  (assert (matchp-name :variable 'cl-user::*b* 9)))
-  t)
 
-(deftest find-source-stuff.7
+(test-util:with-test (:name find-source-stuff.7 :skipped-on :no-source-locs)
-    (matchp-name :class 'cl-user::a 10)
+  (assert (matchp-name :class 'cl-user::a 10)))
-  t)
 
-(deftest find-source-stuff.8
+(test-util:with-test (:name find-source-stuff.8 :skipped-on :no-source-locs)
-    (matchp-name :condition 'cl-user::b 11)
+  (assert (matchp-name :condition 'cl-user::b 11)))
-  t)
 
-(deftest find-source-stuff.9
+(test-util:with-test (:name find-source-stuff.9 :skipped-on :no-source-locs)
-    (matchp-name :structure 'cl-user::c 12)
+  (assert (matchp-name :structure 'cl-user::c 12)))
-  t)
 
 (deftest find-source-stuff.10
     (matchp-name :function 'cl-user::make-c 12)
@@ -157,9 +148,8 @@
     (matchp-name :function 'cl-user::c-e 12)
   t)
 
-(deftest find-source-stuff.12
+(test-util:with-test (:name find-source-stuff.12 :skipped-on :no-source-locs)
-    (matchp-name :structure 'cl-user::d 13)
+  (assert (matchp-name :structure 'cl-user::d 13)))
-  t)
 
 (deftest find-source-stuff.13
     (matchp-name :function 'cl-user::make-d 13)
@@ -169,21 +159,17 @@
     (matchp-name :function 'cl-user::d-e 13)
   t)
 
-(deftest find-source-stuff.15
+(test-util:with-test (:name find-source-stuff.15 :skipped-on :no-source-locs)
-    (matchp-name :package 'cl-user::e 14)
+  (assert (matchp-name :package 'cl-user::e 14)))
-  t)
 
-(deftest find-source-stuff.16
+(test-util:with-test (:name find-source-stuff.16 :skipped-on :no-source-locs)
-    (matchp-name :symbol-macro 'cl-user::f 15)
+  (assert (matchp-name :symbol-macro 'cl-user::f 15)))
-  t)
 
-(deftest find-source-stuff.17
+(test-util:with-test (:name find-source-stuff.17 :skipped-on :no-source-locs)
-    (matchp-name :type 'cl-user::g 16)
+  (assert (matchp-name :type 'cl-user::g 16)))
-  t)
 
-(deftest find-source-stuff.18
+(test-util:with-test (:name find-source-stuff.18 :skipped-on :no-source-locs)
-    (matchp-name :constant 'cl-user::+h+ 17)
+  (assert (matchp-name :constant 'cl-user::+h+ 17)))
-  t)
 
 (deftest find-source-stuff.19
     (matchp-length :method 'cl-user::j 2)
@@ -202,21 +188,19 @@
   t)
 
 (deftest find-source-stuff.23
-    (matchp-name :function  '(setf cl-user::o) 23)
+    (matchp-name :function '(setf cl-user::o) 23)
   t)
 
-(deftest find-source-stuff.24
+(test-util:with-test (:name find-source-stuff.24 :skipped-on :no-source-locs)
-    (matchp-name :method  '(setf cl-user::p) 24)
+  (assert (matchp-name :method '(setf cl-user::p) 24)))
-  t)
 
 (deftest find-source-stuff.25
     (matchp-name :macro  'cl-user::q 25)
   t)
 
 
-(deftest find-source-stuff.26
+(test-util:with-test (:name find-source-stuff.26 :skipped-on :no-source-locs)
-    (matchp-name :method-combination 'cl-user::r 26)
+  (assert (matchp-name :method-combination 'cl-user::r 26)))
-  t)
 
 
 (deftest find-source-stuff.27
@@ -251,9 +235,8 @@
     (matchp-name :function 'cl-user::loaded-as-source-fun 3)
   t)
 
-(deftest find-source-stuff.33
+(test-util:with-test (:name find-source-stuff.33 :skipped-on :no-source-locs)
-    (matchp-name :variable 'cl-user::**global** 29)
+  (assert (matchp-name :variable 'cl-user::**global** 29)))
-  t)
 
 ;;; Check wrt. interplay of generic functions and their methods.
 
@@ -743,25 +726,20 @@
   t
   t)
 
-(deftest alien-type.1
+(test-util:with-test (:name alien-type.1 :skipped-on :no-source-locs)
-  (matchp-name :alien-type 'cl-user::test-alien-type 30)
+  (assert (matchp-name :alien-type 'cl-user::test-alien-type 30)))
-  t)
 
-(deftest alien-type.2
+(test-util:with-test (:name alien-type.2 :skipped-on :no-source-locs)
-  (matchp-name :alien-type 'cl-user::test-alien-struct 31)
+  (assert (matchp-name :alien-type 'cl-user::test-alien-struct 31)))
-  t)
 
-(deftest alien-variable
+(test-util:with-test (:name alien-variable :skipped-on :no-source-locs)
-  (matchp-name :variable 'cl-user::test-alien-var 32)
+  (assert (matchp-name :variable 'cl-user::test-alien-var 32)))
-  t)
 
-(deftest condition-slot-reader
+(test-util:with-test (:name condition-slot-reader :skipped-on :no-source-locs)
-  (matchp-name :method 'cl-user::condition-slot-reader 33)
+  (matchp-name :method 'cl-user::condition-slot-reader 33))
-  t)
 
-(deftest condition-slot-writer
+(test-util:with-test (:name condition-slot-writer :skipped-on :no-source-locs)
-  (matchp-name :method 'cl-user::condition-slot-writer 33)
+  (matchp-name :method 'cl-user::condition-slot-writer 33))
-  t)
 
 (deftest function-with-a-local-function
     (sb-introspect:definition-source-form-number

src/code/source-location.lisp

@@ -114,7 +114,7 @@
   (defun source-location ()
     (make-definition-source-location)))
 
-#-sb-source-locations
+#+(and (not sb-source-locations) (not sb-xc-host)) ; defined in cross-misc in make-host-1
 (defun source-location () nil)
 
 (in-package "SB-IMPL")

tests/sb-introspect.impure.lisp

@@ -1,4 +1,5 @@
 (require :sb-introspect)
+(unless (sb-c:source-location) (push :no-source-locs *features*))
 (test-util:with-scratch-file (f "fasl")
   (load (compile-file "../contrib/sb-introspect/xref-test-data.lisp" :output-file f))
   (load "../contrib/sb-introspect/xref-test.lisp")

tests/test-util.lisp

@@ -238,17 +238,18 @@
 ;;; but the nice side effect is that the tests finish quicker.
 (defmacro with-test ((&key fails-on broken-on skipped-on name serial slow)
                      &body body)
-  (flet ((name-ok (x y)
+  ;; Failing and skipped tests are written into a summary file which is later read back.
-           (declare (ignore y))
+  ;; To guarantee readability there can't be symbols in random packages.
-           (typecase x
+  (setq name (sb-int:named-let ensure-ok ((x name))
-             (symbol (let ((package (symbol-package x)))
+               (etypecase x
-                       (or (null package)
+                 (cons (cons (ensure-ok (car x)) (ensure-ok (cdr x))))
-                           (sb-int:system-package-p package)
+                 (symbol (let ((package (symbol-package x)))
-                           (eql package (find-package "CL"))
+                           (if (or (null package)
-                           (eql package (find-package "KEYWORD")))))
+                                   (sb-int:system-package-p package)
-             (integer t))))
+                                   (eql package (find-package "CL"))
-    (unless (tree-equal name name :test #'name-ok)
+                                   (eql package (find-package "KEYWORD")))
-      (error "test name must be all-keywords: ~S" name))) ; WHY????
+                               x (copy-symbol x))))
+                 (integer x))))
   (cond
     ((broken-p broken-on)
      `(progn