From fb83aae919b90005b4f9a0298cfe4130fb58a13f Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Thu, 4 Feb 2021 19:14:37 -0800 Subject: 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. --- share/txr/stdlib/error.tl | 26 ++++++++++++++++++-------- 1 file 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 ())))) -- cgit v1.2.3