allow ,option on-error report instead of debug

* module/system/repl/command.scm:
* module/system/repl/debug.scm (terminal-width): Move terminal-width
  here, make it thread-local, and export it.
  (print-locals, print-frame, print-frames): Default width to
  terminal-width.

* module/system/repl/error-handling.scm (call-with-error-handling): Add
  `report' and `backtrace' on-error handlers.

* module/system/repl/common.scm (repl-default-options): Add on-error
  REPL option, defaulting to `debug', but which may be changed.

* module/system/repl/repl.scm (run-repl): Pass the #:on-error REPL
  option to call-with-error-handling.

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 685eebb..87ab993 100644 (file)
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -71,20 +71,6 @@
 (define *show-table*
   '((show (warranty w) (copying c) (version v))))
 
-(define terminal-width
-  (let ((set-width #f))
-    (case-lambda
-      (()
-       (or set-width
-           (let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
-             (and (integer? w) (exact? w) (> w 0) w))
-           72))
-      ((w)
-       (if (or (not w) (and (integer? w) (exact? w) (> w 0)))
-           (set! set-width w)
-           (error "Expected a column number (a positive integer)" w))))))
-
-
 (define (group-name g) (car g))
 (define (group-commands g) (cdr g))
 

diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 24a583c..a5267c6 100644 (file)
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -121,7 +121,14 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
       ,(value-history-enabled?)
       ,(lambda (x)
          (if x (enable-value-history!) (disable-value-history!))
-         (->bool x))))))
+         (->bool x)))
+     (on-error
+      debug
+      ,(let ((vals '(debug backtrace report pass)))
+         (lambda (x)
+           (if (memq x vals)
+               x
+               (error "Bad on-error value ~a; expected one of ~a" x vals))))))))
 
 (define %make-repl make-repl)
 (define* (make-repl lang #:optional debug)

diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
index 46ea6b4..cf40806 100644 (file)
--- a/module/system/repl/debug.scm
+++ b/module/system/repl/debug.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM debugging facilities
 
-;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -32,6 +32,7 @@
   #:export (<debug>
             make-debug debug?
             debug-frames debug-index debug-error-message debug-for-trap?
+            terminal-width
             print-registers print-locals print-frame print-frames frame->module
             stack->vector narrow-stack->vector
             frame->stack-vector))
@@ -58,6 +59,25 @@
 
 \f
 
+;; A fluid, because terminals are usually implicitly associated with
+;; threads.
+;;
+(define terminal-width
+  (let ((set-width (make-fluid)))
+    (case-lambda
+      (()
+       (or (fluid-ref set-width)
+           (let ((w (false-if-exception (string->number (getenv "COLUMNS")))))
+             (and (integer? w) (exact? w) (> w 0) w))
+           72))
+      ((w)
+       (if (or (not w) (and (integer? w) (exact? w) (> w 0)))
+           (fluid-set! set-width w)
+           (error "Expected a column number (a positive integer)" w))))))
+
+
+\f
+
 (define (reverse-hashq h)
   (let ((ret (make-hash-table)))
     (hash-for-each
@@ -79,7 +99,7 @@
   (print "fp = #x~x\n" (frame-address frame)))
 
 (define* (print-locals frame #:optional (port (current-output-port))
-                       #:key (width 72) (per-line-prefix "  "))
+                       #:key (width (terminal-width)) (per-line-prefix "  "))
   (let ((bindings (frame-bindings frame)))
     (cond
      ((null? bindings)
@@ -99,8 +119,8 @@
        (frame-bindings frame))))))
 
 (define* (print-frame frame #:optional (port (current-output-port))
-                      #:key index (width 72) (full? #f) (last-source #f)
-                      next-source?)
+                      #:key index (width (terminal-width)) (full? #f)
+                      (last-source #f) next-source?)
   (define (source:pretty-file source)
     (if source
         (or (source:file source) "current input")
@@ -120,8 +140,8 @@
 
 (define* (print-frames frames
                        #:optional (port (current-output-port))
-                       #:key (width 72) (full? #f) (forward? #f) count
-                       for-trap?)
+                       #:key (width (terminal-width)) (full? #f)
+                       (forward? #f) count for-trap?)
   (let* ((len (vector-length frames))
          (lower-idx (if (or (not count) (positive? count))
                         0

diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index d41dea6..c94db24 100644 (file)
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -143,6 +143,34 @@
                 (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)
+           (if (not (memq key pass-keys))
+               (begin
+                 (with-saved-ports
+                  (lambda ()
+                    (run-hook before-error-hook)
+                    (print-exception err #f key args)
+                    (run-hook after-error-hook)
+                    (force-output err)))
+                 (if #f #f)))))
+        ((backtrace)
+         (lambda (key . args)
+           (if (not (memq key pass-keys))
+               (let* ((tag (and (pair? (fluid-ref %stacks))
+                                (cdar (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)
+                    (run-hook before-error-hook)
+                    (print-exception err #f key args)
+                    (run-hook after-error-hook)
+                    (force-output err)))
+                 (if #f #f)))))
         ((pass)
          (lambda (key . args)
            ;; fall through to rethrow

diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 39f2319..5bab778 100644 (file)
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -190,8 +190,10 @@
                                        (abort-on-error "parsing expression"
                                          (repl-parse repl exp))))))
                                (run-hook before-eval-hook exp)
-                               (with-error-handling
-                                 (with-stack-and-prompt thunk)))
+                               (call-with-error-handling
+                                (lambda ()
+                                  (with-stack-and-prompt thunk))
+                                #:on-error (repl-option-ref repl 'on-error)))
                              (lambda (k) (values))))
                       (lambda l
                         (for-each (lambda (v)
@@ -199,6 +201,7 @@
                                   l))))
                   (lambda (k . args)
                     (abort args))))
+              #:on-error (repl-option-ref repl 'on-error)
               #:trap-handler 'disabled)))
            (flush-to-newline) ;; consume trailing whitespace
            (prompt-loop))))