error: improve compiler error location reporting.

* share/txr/stdlib/error.tl (sys:dig): New function. If the
form has no source location, but has macro ancestry, thens
try to search through that.
(sys:loc): Don't bother with the conditional; source-loc-str
always returns something. When there is no source location
there is a "source loc n/a" string.
(compile-error, compile-warning, compile-defr-warning): Use
sys:dig to take advanage of macro ancestry information.

1 files changed, 18 insertions, 8 deletions

diff --git a/share/txr/stdlib/error.tl b/share/txr/stdlib/error.tl
index 0425f02c..8a0a93fa 100644
--- a/share/txr/stdlib/error.tl
+++ b/share/txr/stdlib/error.tl
@@ -24,26 +24,36 @@
 ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
+(defun sys:dig (ctx)
+  (whilet ((form (sys:ctx-form ctx))
+           (anc (unless (source-loc form)
+                  (macro-ancestor form))))
+    (set ctx anc))
+  ctx)
+
 (defun sys:loc (ctx)
-  (iflet ((loc (source-loc-str (sys:ctx-form ctx))))
-    `(@loc) ` ""))
+  (let ((form (sys:ctx-form ctx)))
+    `(@(source-loc-str form)) `))
 
 (defun compile-error (ctx fmt . args)
-  (let ((loc (sys:loc ctx))
-        (name (sys:ctx-name ctx)))
+  (let* ((nctx (sys:dig ctx))
+         (loc (sys:loc nctx))
+         (name (sys:ctx-name nctx)))
     (dump-deferred-warnings *stderr*)
     (throwf 'eval-error `@loc~s: @fmt` name . args)))
 
 (defun compile-warning (ctx fmt . args)
-  (let ((loc (sys:loc ctx))
-        (name (sys:ctx-name ctx)))
+  (let* ((nctx (sys:dig ctx))
+         (loc (sys:loc nctx))
+         (name (sys:ctx-name nctx)))
     (usr:catch
       (throwf 'warning `@loc~s: @fmt` name . args)
       (continue ()))))
 
 (defun compile-defr-warning (ctx tag fmt . args)
-  (let ((loc (sys:loc ctx))
-        (name (sys:ctx-name ctx)))
+  (let* ((nctx (sys:dig ctx))
+         (loc (sys:loc nctx))
+         (name (sys:ctx-name nctx)))
     (usr:catch
       (throw 'defr-warning (fmt `@loc~s: @fmt` name . args)  tag)
       (continue ()))))