From ae8b708eb124058cdb256531f02e1895c637a271 Mon Sep 17 00:00:00 2001
From: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
Date: Sat, 7 Jan 2017 15:35:16 +0100
Subject: [PATCH] tests: new utils
 CHECKED-COMPILE-{CAPTURING,CONDITION}-SOURCE-PATHS

---
 tests/macroexpand.impure.lisp | 39 ++++++++++++---------------------------
 tests/test-util.lisp          | 38 +++++++++++++++++++++++++++++++++++++-
 2 files changed, 49 insertions(+), 28 deletions(-)

diff --git a/tests/macroexpand.impure.lisp b/tests/macroexpand.impure.lisp
index 99c7883f8..4e4f100c1 100644
--- a/tests/macroexpand.impure.lisp
+++ b/tests/macroexpand.impure.lisp
@@ -251,30 +251,15 @@
   `(progn ,a ,b))
 
 (with-test (:name (with-current-source-form :smoke))
-  (labels ((call-capturing-source-paths (thunk)
-             (let ((source-paths '()))
-               (handler-bind
-                   ((condition (lambda (condition)
-                                 (let ((context (sb-c::find-error-context nil)))
-                                   (push (sb-c::compiler-error-context-original-source-path
-                                          context)
-                                         source-paths))
-                                 (muffle-warning condition))))
-                 (funcall thunk))
-               (nreverse source-paths)))
-           (compile-capturing-source-paths (form)
-             (call-capturing-source-paths
-              (lambda () (compile nil form)))))
-
-    (assert (equal (compile-capturing-source-paths
-                    '(lambda () (warnings-in-subforms 1 2)))
-                   '((2 0) (2 0))))
-    (assert (equal (compile-capturing-source-paths
-                    '(lambda () (warnings-in-subforms (progn 1) (progn 2))))
-                   '((1 2 0) (2 2 0))))
-    (assert (equal (compile-capturing-source-paths
-                    '(lambda ()
-                      (warnings-in-subforms
-                       (warnings-in-subforms (progn 1) (progn 2))
-                       (progn 3))))
-                   '((1 2 0) (2 2 0) (1 1 2 0) (2 1 2 0))))))
+  (assert (equal (checked-compile-condition-source-paths
+                  '(lambda () (warnings-in-subforms 1 2)))
+                 '((2 0) (2 0))))
+  (assert (equal (checked-compile-condition-source-paths
+                  '(lambda () (warnings-in-subforms (progn 1) (progn 2))))
+                 '((1 2 0) (2 2 0))))
+  (assert (equal (checked-compile-condition-source-paths
+                  '(lambda ()
+                    (warnings-in-subforms
+                     (warnings-in-subforms (progn 1) (progn 2))
+                     (progn 3))))
+                 '((1 2 0) (2 2 0) (1 1 2 0) (2 1 2 0)))))
diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index dab69e6b3..d79864daa 100644
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -4,7 +4,8 @@
            #:really-invoke-debugger
            #:*break-on-failure* #:*break-on-expected-failure*
            #:make-kill-thread #:make-join-thread
-           #:checked-compile
+           #:checked-compile #:checked-compile-capturing-source-paths
+           #:checked-compile-condition-source-paths
            #:runtime #:split-string))
 
 (in-package :test-util)
@@ -248,6 +249,41 @@
             (values function (when (or failure-p warnings) t)
                     warnings style-warnings notes compiler-errors)))))))
 
+;;; Like CHECKED-COMPILE, but for each captured condition, capture and
+;;; later return a cons
+;;;
+;;;   (CONDITION . SOURCE-PATH)
+;;;
+;;; instead. SOURCE-PATH is the path of the source form associated to
+;;; CONDITION.
+(defun checked-compile-capturing-source-paths (form &rest args)
+  (labels ((context-source-path ()
+             (let ((context (sb-c::find-error-context nil)))
+               (sb-c::compiler-error-context-original-source-path
+                context)))
+           (add-source-path (condition)
+             (cons condition (context-source-path))))
+    (apply #'checked-compile form :condition-transform #'add-source-path
+           args)))
+
+;;; Similar to CHECKED-COMPILE, but allow compilation failure and
+;;; warnings and only return source paths associated to those
+;;; conditions.
+(defun checked-compile-condition-source-paths (form)
+  (let ((source-paths '()))
+    (labels ((context-source-path ()
+               (let ((context (sb-c::find-error-context nil)))
+                 (sb-c::compiler-error-context-original-source-path
+                  context)))
+             (push-source-path (condition)
+               (declare (ignore condition))
+               (push (context-source-path) source-paths)))
+      (checked-compile form
+                       :allow-failure t
+                       :allow-warnings t
+                       :allow-style-warnings t
+                       :condition-transform #'push-source-path))
+    (nreverse source-paths)))
 
 ;;; Repeat calling THUNK until its cumulated runtime, measured using
 ;;; GET-INTERNAL-RUN-TIME, is larger than PRECISION. Repeat this
-- 
2.11.4.GIT