From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Andrew Whatson Newsgroups: gmane.lisp.guile.devel Subject: [DRAFT] Improve reporting of exception locations Date: Wed, 12 Oct 2022 16:42:40 +1000 Message-ID: <20221012064239.30295-1-whatson@gmail.com> References: Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="14023"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Andrew Whatson To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Wed Oct 12 08:48:03 2022 Return-path: Envelope-to: guile-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1oiVX8-0003Nn-Qa for guile-devel@m.gmane-mx.org; Wed, 12 Oct 2022 08:48:03 +0200 Original-Received: from localhost ([::1]:51166 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1oiVX7-0003yR-Ch for guile-devel@m.gmane-mx.org; Wed, 12 Oct 2022 02:48:01 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:42080) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oiVU7-0003vx-Vt for guile-devel@gnu.org; Wed, 12 Oct 2022 02:44:56 -0400 Original-Received: from mail-pj1-x1033.google.com ([2607:f8b0:4864:20::1033]:51725) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oiVU5-0004UK-Iu for guile-devel@gnu.org; Wed, 12 Oct 2022 02:44:55 -0400 Original-Received: by mail-pj1-x1033.google.com with SMTP id b15so14494971pje.1 for ; Tue, 11 Oct 2022 23:44:52 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=9uoidwDr4Apy3lNvj00eSJqEvczt9wYnG4g6G3tQebA=; b=ik5paHff4H2pmV2sxulUB2/bGBq3cs4IjfYmvZqzelovVU/e/U9UR42i0Gq3kRjhIh BRZUIc7pLM94pG3hE/onqLhQ3Z441JjnDeZFUXLLqJ4JXZpk5qplxQK0x4Leop1emgPi 5x79H8TW+Ml2m7VyZ1p4pmN/yppBMQk67zKz8U6gME/d2dt+sAYvOzFJjyPlWq+0aCxr qngnWE2bhqm1R3U4MSa/2eV+GKas+TPw0V+aKs81s1jkPBjfdKrwVB+EVzYtGWpPCMWp FxW1cnh33zoT0BlcGRTWlnfEjLl/uISN4dnNICpaijigqGiyf28OG0dsT7Vh2+1yU2Ng 4JCw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=9uoidwDr4Apy3lNvj00eSJqEvczt9wYnG4g6G3tQebA=; b=Vs0iJhwB6S32rKDci7/mRSebWSbYEpiKf7aI/lykwYUl0fXvoEh2SCgu2ain+iufYa ajoSZJd+DROO1HywlVh9Azf9lysks1aj/jojhhiKmtZRKcAZrn+CfMaL23wf0IkRkWxV zePfGU7fwqwl2tv532CnMeJ6I8AperBWnJucB8rPCJEDhci3OHi8cK3x704Ce9H1/tPk MzIllQ52UeOAf+s3/os72qMLOeNhVEHxXbfVR5uEBZzX0zVp8Kvr8UW/iPdqxLxQ87+E EiJ9NEUf8ensZSXoEle01rlJoZ96aJVpvjr+zIcoFbZV1mtISJYbQj9waZa/6o141VZR l7lA== X-Gm-Message-State: ACrzQf0boqtFvIoNuAS6LcRKcST1YdPnHPbUj8pxmA5TaiiBaDYPcWQk DCQXHBPhITTnXmuzImls1GkzC2aJZOXHmQ== X-Google-Smtp-Source: AMsMyM6q/RAHLNq8cLgQRXDWN/5vYEQFDtW8LBbao5v3PqZffgDveuoRjYkw+vOwTcANcgITfS0uUA== X-Received: by 2002:a17:902:ce85:b0:184:5289:d6d7 with SMTP id f5-20020a170902ce8500b001845289d6d7mr2903497plg.104.1665557091446; Tue, 11 Oct 2022 23:44:51 -0700 (PDT) Original-Received: from fumo.fritz.box (124-148-103-155.tpgi.com.au. [124.148.103.155]) by smtp.gmail.com with ESMTPSA id n8-20020a17090a090800b0020a9f7405aesm664935pjn.13.2022.10.11.23.44.48 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 11 Oct 2022 23:44:50 -0700 (PDT) X-Mailer: git-send-email 2.38.0 In-Reply-To: Received-SPF: pass client-ip=2607:f8b0:4864:20::1033; envelope-from=whatson@gmail.com; helo=mail-pj1-x1033.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane-mx.org@gnu.org Original-Sender: "guile-devel" Xref: news.gmane.io gmane.lisp.guile.devel:21398 Archived-At: TODO: use exception-stack in other error handlers TODO: print-exception variant for exception objects TODO: test cases for other kinds of errors * module/ice-9/exceptions.scm (&stack): New exception type. (convert-guile-exception): Capture the stack when creating an exception. * module/system/repl/error-handling.scm (call-with-error-handling): Use the exception stack if available. * test-suite/Makefile.am (SCM_TESTS): Add sample code. * test-suite/tests/exceptions.test ("exception location"): New tests. * test-suite/tests/exceptions/error.scm: * test-suite/tests/exceptions/error-with-throw-handler-1.scm: * test-suite/tests/exceptions/error-with-throw-handler-2.scm: * test-suite/tests/exceptions/error-with-throw-handler-3.scm: Sample code for exception location tests. --- module/ice-9/exceptions.scm | 8 +- module/system/repl/error-handling.scm | 153 ++++++++++-------- test-suite/Makefile.am | 5 + test-suite/tests/exceptions.test | 48 +++++- .../exceptions/error-with-throw-handler-1.scm | 6 + .../exceptions/error-with-throw-handler-2.scm | 11 ++ .../exceptions/error-with-throw-handler-3.scm | 16 ++ test-suite/tests/exceptions/error.scm | 1 + 8 files changed, 183 insertions(+), 65 deletions(-) create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-1.scm create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-2.scm create mode 100644 test-suite/tests/exceptions/error-with-throw-handler-3.scm create mode 100644 test-suite/tests/exceptions/error.scm diff --git a/module/ice-9/exceptions.scm b/module/ice-9/exceptions.scm index 143e7aa3e..207c79e2a 100644 --- a/module/ice-9/exceptions.scm +++ b/module/ice-9/exceptions.scm @@ -48,6 +48,7 @@ make-exception-with-message exception-with-message? exception-message + exception-stack &warning make-warning @@ -154,6 +155,10 @@ make-exception-with-origin exception-with-origin? (origin exception-origin)) +(define-exception-type &stack &exception + make-exception-with-stack exception-with-stack? + (stack exception-stack)) + (define-exception-type-procedures &non-continuable &programming-error make-non-continuable-error non-continuable-error?) @@ -198,7 +203,8 @@ (let ((converter (assv-ref guile-exception-converters key))) (make-exception (or (and converter (converter key args)) (default-guile-exception-converter key args)) - (make-exception-with-kind-and-args key args)))) + (make-exception-with-kind-and-args key args) + (make-exception-with-stack (make-stack #t 4))))) (define (raise-continuable obj) (raise-exception obj #:continuable? #t)) diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index 8d5a8a5f0..e2a2458c0 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -23,6 +23,7 @@ #:use-module (system base pmatch) #:use-module (system vm trap-state) #:use-module (system repl debug) + #:use-module (ice-9 exceptions) #:use-module (ice-9 format) #:export (call-with-error-handling with-error-handling)) @@ -101,83 +102,109 @@ (run-hook after-error-hook) (force-output err)))) - (catch #t - (lambda () - (with-default-trap-handler le-trap-handler - (lambda () (%start-stack #t thunk)))) - + (define post-error-handler (case post-error ((report) - (lambda (key . args) - (if (memq key pass-keys) - (apply throw key args) - (begin - (report-error key args) - (if #f #f))))) + (lambda (exn) + (let ((key (exception-kind exn)) + (args (exception-args exn))) + (when (memq key pass-keys) + (raise-exception exn)) + (report-error key args) + (if #f #f)))) ((catch) - (lambda (key . args) - (when (memq key pass-keys) - (apply throw key args)) - (when (memq key report-keys) - (report-error key args)) - (if #f #f))) + (lambda (exn) + (let ((key (exception-kind exn)) + (args (exception-args exn))) + (when (memq key pass-keys) + (raise-exception exn)) + (when (memq key report-keys) + (report-error key args)) + (if #f #f)))) (else (if (procedure? post-error) - (lambda (k . args) - (apply (if (memq k pass-keys) throw post-error) k args)) - (error "Unknown post-error strategy" post-error)))) - + (lambda (exn) + (let ((key (exception-kind exn)) + (args (exception-args exn))) + (when (memq key pass-keys) + (raise-exception exn)) + (apply post-error key args))) + (error "Unknown post-error strategy" post-error))))) + + (define on-error-handler (case on-error ((debug) - (lambda (key . args) - (if (not (memq key pass-keys)) - (let* ((tag (and (pair? (fluid-ref %stacks)) - (cdr (fluid-ref %stacks)))) - (stack (narrow-stack->vector - (make-stack #t) - ;; Cut three frames from the top of the stack: - ;; make-stack, this one, and the throw handler. - 3 - ;; Narrow the end of the stack to the most recent - ;; start-stack. - tag - ;; And one more frame, because %start-stack invoking - ;; the start-stack thunk has its own frame too. - 0 (and tag 1))) - (error-msg (error-string stack key args)) - (debug (make-debug stack 0 error-msg))) - (with-saved-ports - (lambda () - (format #t "~a~%" error-msg) - (format #t "Entering a new prompt. ") - (format #t "Type `,bt' for a backtrace or `,q' to continue.\n") - ((@ (system repl repl) start-repl) #:debug debug))))))) + (lambda (exn) + (let ((key (exception-kind exn)) + (args (exception-args exn))) + (if (not (memq key pass-keys)) + (let* ((tag (and (pair? (fluid-ref %stacks)) + (cdr (fluid-ref %stacks)))) + (stack (or (exception-stack exn) + ;; Cut three frames from the top of the stack: + ;; make-stack, this one, and the throw handler. + (make-stack #t 3))) + (stack (narrow-stack->vector + stack + ;; Narrow the end of the stack to the most recent + ;; start-stack. + 0 tag + ;; And one more frame, because %start-stack invoking + ;; the start-stack thunk has its own frame too. + 0 (and tag 1))) + (error-msg (error-string stack key args)) + (debug (make-debug stack 0 error-msg))) + (with-saved-ports + (lambda () + (format #t "~a~%" error-msg) + (format #t "Entering a new prompt. ") + (format #t "Type `,bt' for a backtrace or `,q' to continue.\n") + ((@ (system repl repl) start-repl) #:debug debug)))))))) ((report) - (lambda (key . args) - (unless (memq key pass-keys) - (report-error key args)) - (if #f #f))) + (lambda (exn) + (let ((key (exception-kind exn)) + (args (exception-args exn))) + (unless (memq key pass-keys) + (report-error key args)) + (if #f #f)))) ((backtrace) - (lambda (key . args) - (if (not (memq key pass-keys)) - (let* ((tag (and (pair? (fluid-ref %stacks)) - (cdr (fluid-ref %stacks)))) - (frames (narrow-stack->vector - (make-stack #t) - ;; Narrow as above, for the debugging case. - 3 tag 0 (and tag 1)))) - (with-saved-ports (lambda () (print-frames frames))) - (report-error key args) - (if #f #f))))) + (lambda (exn) + (let ((key (exception-kind exn)) + (args (exception-args exn))) + (if (not (memq key pass-keys)) + (let* ((tag (and (pair? (fluid-ref %stacks)) + (cdr (fluid-ref %stacks)))) + (frames (narrow-stack->vector + (make-stack #t) + ;; Narrow as above, for the debugging case. + 3 tag 0 (and tag 1)))) + (with-saved-ports (lambda () (print-frames frames))) + (report-error key args) + (if #f #f)))))) ((pass) - (lambda (key . args) + (lambda (exn) ;; fall through to rethrow #t)) (else (if (procedure? on-error) - (lambda (k . args) - (apply (if (memq k pass-keys) throw on-error) k args)) - (error "Unknown on-error strategy" on-error))))))) + (lambda (exn) + (let ((key (exception-kind exn)) + (args (exception-args exn))) + (when (memq k pass-keys) + (raise-exception exn)) + (apply on-error key args))) + (error "Unknown on-error strategy" on-error))))) + + (with-exception-handler post-error-handler + (lambda () + (with-exception-handler + (lambda (exn) + (on-error-handler exn) + (raise-exception exn)) + (lambda () + (with-default-trap-handler le-trap-handler + (lambda () (%start-stack #t thunk)))))) + #:unwind? #t))) (define-syntax-rule (with-error-handling form) (call-with-error-handling (lambda () form))) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 35f264195..fb44e2841 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -54,6 +54,11 @@ SCM_TESTS = tests/00-initial-env.test \ tests/eval.test \ tests/eval-string.test \ tests/exceptions.test \ + tests/exceptions.test \ + tests/exceptions/error.scm \ + tests/exceptions/error-with-throw-handler-1.scm \ + tests/exceptions/error-with-throw-handler-2.scm \ + tests/exceptions/error-with-throw-handler-3.scm \ tests/fdes-finalizers.test \ tests/filesys.test \ tests/fluids.test \ diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 291e10e26..66b7cfbdb 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -17,7 +17,8 @@ (define-module (test-suite exceptions) - #:use-module (test-suite lib)) + #:use-module (test-suite lib) + #:use-module (ice-9 exceptions)) (define-syntax-parameter push (lambda (stx) @@ -392,3 +393,48 @@ (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar)))) (thunk2 (catch* 'bar (lambda () (thunk1))))) (thunk2)))) + +(with-test-prefix "exception location" + (define (test-file filename) + (string-append + (dirname (current-filename)) "/" filename)) + + (define (try-load filename) + (with-exception-handler values + (lambda () + (load filename) + #f) ;; success is failure + #:unwind? #t)) + + (define (check-location expected) + (lambda (exn) + (pk exn) + (let* ((key (exception-kind exn)) + (args (exception-args exn)) + (stack (exception-stack exn)) + (frame (and stack (stack-ref stack 0))) + (message (call-with-output-string + (lambda (port) + (print-exception port frame key args))))) + ;; (when stack + ;; (display-backtrace stack (current-warning-port))) + ;; (format (current-warning-port) + ;; "\n;;; message: ~s\n;;; expected: ~s\n\n" + ;; message expected) + (number? (string-contains message expected))))) + + (pass-if "error" + (and=> (try-load (test-file "exceptions/error.scm")) + (check-location "exceptions/error.scm:1"))) + + (pass-if "error with one throw handler" + (and=> (try-load (test-file "exceptions/error-with-throw-handler-1.scm")) + (check-location "exceptions/error-with-throw-handler-1.scm:3"))) + + (pass-if "error with two throw handlers" + (and=> (try-load (test-file "exceptions/error-with-throw-handler-2.scm")) + (check-location "exceptions/error-with-throw-handler-2.scm:5"))) + + (pass-if "error with three throw handlers" + (and=> (try-load (test-file "exceptions/error-with-throw-handler-3.scm")) + (check-location "exceptions/error-with-throw-handler-3.scm:7")))) diff --git a/test-suite/tests/exceptions/error-with-throw-handler-1.scm b/test-suite/tests/exceptions/error-with-throw-handler-1.scm new file mode 100644 index 000000000..4acaa7256 --- /dev/null +++ b/test-suite/tests/exceptions/error-with-throw-handler-1.scm @@ -0,0 +1,6 @@ +(with-throw-handler 'foo + (lambda () + (error "whoops!")) + (lambda () + ;; unused + (values))) diff --git a/test-suite/tests/exceptions/error-with-throw-handler-2.scm b/test-suite/tests/exceptions/error-with-throw-handler-2.scm new file mode 100644 index 000000000..8dc04c081 --- /dev/null +++ b/test-suite/tests/exceptions/error-with-throw-handler-2.scm @@ -0,0 +1,11 @@ +(with-throw-handler 'bar + (lambda () + (with-throw-handler 'foo + (lambda () + (error "whoops!")) + (lambda () + ;; unused + (values)))) + (lambda () + ;; unused + (values))) diff --git a/test-suite/tests/exceptions/error-with-throw-handler-3.scm b/test-suite/tests/exceptions/error-with-throw-handler-3.scm new file mode 100644 index 000000000..62c8b033b --- /dev/null +++ b/test-suite/tests/exceptions/error-with-throw-handler-3.scm @@ -0,0 +1,16 @@ +(with-throw-handler 'baz + (lambda () + (with-throw-handler 'bar + (lambda () + (with-throw-handler 'foo + (lambda () + (error "whoops!")) + (lambda () + ;; unused + (values)))) + (lambda () + ;; unused + (values)))) + (lambda () + ;; unused + (values))) diff --git a/test-suite/tests/exceptions/error.scm b/test-suite/tests/exceptions/error.scm new file mode 100644 index 000000000..7ba405341 --- /dev/null +++ b/test-suite/tests/exceptions/error.scm @@ -0,0 +1 @@ +(error "whoops!") -- 2.38.0