From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: "Jose A. Ortega Ruiz" Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Add new debug meta-command ,error Date: Mon, 30 Aug 2010 06:52:11 +0200 Message-ID: <1283143931-6220-1-git-send-email-jao@gnu.org> NNTP-Posting-Host: lo.gmane.org X-Trace: dough.gmane.org 1283143975 6418 80.91.229.12 (30 Aug 2010 04:52:55 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Mon, 30 Aug 2010 04:52:55 +0000 (UTC) Cc: jao@gnu.org To: guile-devel@gnu.org, wingo@pobox.com Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Mon Aug 30 06:52:54 2010 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1OpwMS-0007Ez-Ay for guile-devel@m.gmane.org; Mon, 30 Aug 2010 06:52:48 +0200 Original-Received: from localhost ([127.0.0.1]:36643 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OpwMR-0004sv-1w for guile-devel@m.gmane.org; Mon, 30 Aug 2010 00:52:47 -0400 Original-Received: from [140.186.70.92] (port=36357 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OpwMM-0004sq-97 for guile-devel@gnu.org; Mon, 30 Aug 2010 00:52:43 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.69) (envelope-from ) id 1OpwML-00038I-0C for guile-devel@gnu.org; Mon, 30 Aug 2010 00:52:42 -0400 Original-Received: from mail-ww0-f49.google.com ([74.125.82.49]:40289) by eggs.gnu.org with esmtp (Exim 4.69) (envelope-from ) id 1OpwMK-00038A-Mt; Mon, 30 Aug 2010 00:52:40 -0400 Original-Received: by wwb24 with SMTP id 24so2463883wwb.30 for ; Sun, 29 Aug 2010 21:52:38 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma; h=domainkey-signature:received:received:sender:received:from:to:cc :subject:date:message-id:x-mailer; bh=QUFT7+e1K1Y1uwQtUDDHyIEltix5zuJ1JUP76LnUX6U=; b=fx5h2hEUK7mtMO+9mBO+kze0YIvhruyhTbHGQxZn1+Gn0mARJO4zTPybrCTtJKUDun +1hRgXHzxxhFTSojBC4ij5P84EiTDXbzsmCEdyEY7sIfbslmERN/E0p9wh77I3TW1Utn rQBL+I+YmEwMW85l4cxdtbnV13GYYg9gn0jrA= DomainKey-Signature: a=rsa-sha1; c=nofws; d=gmail.com; s=gamma; h=sender:from:to:cc:subject:date:message-id:x-mailer; b=RXooTVoLskA6xysA8wvrRdmkxiOpyrS5/czsOdl+7KfBFPdqYRy9bgi1GhRVDCLpTk hvr/nDJQTI82m855f/oOJPXFFyiiQvsrlRFRvBr+s30dK7VUYhbsTIR2FkeyXGrGiyxs VEPQdgIVuyAL/4dSyqAbhUaaj/kRUddD24MJ0= Original-Received: by 10.227.129.4 with SMTP id m4mr4423765wbs.123.1283143958637; Sun, 29 Aug 2010 21:52:38 -0700 (PDT) Original-Received: from newton.homeunix.net ([83.50.71.238]) by mx.google.com with ESMTPS id o84sm4154495wej.13.2010.08.29.21.52.37 (version=TLSv1/SSLv3 cipher=RC4-MD5); Sun, 29 Aug 2010 21:52:37 -0700 (PDT) Original-Received: from jao by newton.homeunix.net with local (Exim 4.72) (envelope-from ) id 1OpwMD-0001dO-VU; Mon, 30 Aug 2010 06:52:34 +0200 X-Mailer: git-send-email 1.7.1 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 2) X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:10809 Archived-At: * module/system/repl/debug.scm: stores the error string in a new field. * module/system/repl/error-handling.scm: use the error string to construct the instance. * module/system/repl/command.scm: new debug command `error' that extracts the new field. Signed-off-by: Jose A. Ortega Ruiz --- module/system/repl/command.scm | 12 +++++++++--- module/system/repl/debug.scm | 4 ++-- module/system/repl/error-handling.scm | 26 ++++++++++++++++---------- 3 files changed, 27 insertions(+), 15 deletions(-) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 8a62a16..52b0708 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -6,12 +6,12 @@ ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. -;; +;; ;; This library is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;; Lesser General Public License for more details. -;; +;; ;; You should have received a copy of the GNU Lesser General Public ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA @@ -55,7 +55,7 @@ (disassemble x) (disassemble-file xx)) (profile (time t) (profile pr) (trace tr)) (debug (backtrace bt) (up) (down) (frame fr) - (procedure proc) (locals)) + (procedure proc) (locals) (error e)) (inspect (inspect i) (pretty-print pp)) (system (gc) (statistics stat) (option o) (quit q continue cont)))) @@ -474,6 +474,12 @@ Trace execution." body body* ...) (format #t "Nothing to debug.~%")))))))) +(define-meta-command (error repl) + "error +Display the original error message." + (let ((debug (repl-debug repl))) + (format #t "~a~%" (if debug (debug-error-message debug) "")))) + (define-stack-command (backtrace repl #:optional count #:key (width 72) full?) "backtrace [COUNT] [#:width W] [#:full? F] diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 293b790..1876d31 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -30,7 +30,7 @@ #:use-module ((system vm inspect) #:select ((inspect . %inspect))) #:use-module (system vm program) #:export ( - make-debug debug? debug-frames debug-index + make-debug debug? debug-frames debug-index debug-error-message print-locals print-frame print-frames frame->module stack->vector narrow-stack->vector)) @@ -66,7 +66,7 @@ ;;; accessors, and provides some helper functions. ;;; -(define-record frames index) +(define-record frames index error-message) diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index db0beeb..e77ea96 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -32,6 +32,16 @@ ;;; Error handling via repl debugging ;;; +(define (error-string stack key args) + (with-output-to-string + (lambda () + (pmatch args + ((,subr ,msg ,args . ,rest) + (display-error (vector-ref stack 0) (current-output-port) + subr msg args rest)) + (else + (format #t "Throw to key `~a' with args `~s'." key args)))))) + (define* (call-with-error-handling thunk #:key (on-error 'debug) (post-error 'catch) (pass-keys '(quit))) @@ -45,7 +55,7 @@ (lambda () (with-error-to-port err thunk)))))) - + (catch #t (lambda () (%start-stack #t thunk)) @@ -75,7 +85,7 @@ (if (procedure? post-error) post-error ; a handler proc (error "Unknown post-error strategy" post-error)))) - + (case on-error ((debug) (lambda (key . args) @@ -85,22 +95,18 @@ (make-stack #t) ;; Cut three frames from the top of the stack: ;; make-stack, this one, and the throw handler. - 3 + 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))) - (debug (make-debug stack 0))) + (error-msg (error-string stack key args)) + (debug (make-debug stack 0 error-msg))) (with-saved-ports (lambda () - (pmatch args - ((,subr ,msg ,args . ,rest) - (display-error (vector-ref stack 0) (current-output-port) - subr msg args rest)) - (else - (format #t "Throw to key `~a' with args `~s'." key args))) + (format #t 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)))))) -- 1.7.1