[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-35-g4a
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-35-g4ae3d5a |
|
Date: |
Thu, 10 Jun 2010 12:46:01 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4ae3d5aae8cd0b012483072abb29acf4aeb3dbe8
The branch, master has been updated
via 4ae3d5aae8cd0b012483072abb29acf4aeb3dbe8 (commit)
via 974a74d2242b6d0ac342ef889768211729b435ea (commit)
via 03af6e0953352331adad657f2a7fd752b77e5298 (commit)
via 222a2b19a1d8eb25a1dbc3ff52873ee5274d972b (commit)
via c7317beca603d1a43b2490ba91e1a9df9779eafe (commit)
via 7b69cafd0a2dd77fe39396b6c755a2240f4c372b (commit)
via b93c34c0ca282a7d261f9de7326274fbb3b03774 (commit)
via 11da3f2bd6793e3241f3083a2f12d8b8167caf0e (commit)
from dc232ed059a0af5955d21f077da88af6fdc562a0 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 4ae3d5aae8cd0b012483072abb29acf4aeb3dbe8
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 13:56:13 2010 +0200
deprecate error-catching-loop, error-catching-repl
* module/ice-9/deprecated.scm (error-catching-loop)
(error-catching-repl): Deprecate.
commit 974a74d2242b6d0ac342ef889768211729b435ea
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 13:53:33 2010 +0200
remove commented-out code from boot-9
* module/ice-9/boot-9.scm: Remove commented-out code.
commit 03af6e0953352331adad657f2a7fd752b77e5298
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 13:52:14 2010 +0200
deprecate scm-style-repl
* module/ice-9/deprecated.scm (scm-style-repl): Deprecate.
commit 222a2b19a1d8eb25a1dbc3ff52873ee5274d972b
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 13:44:37 2010 +0200
fix error handling when reading debugger args
* module/system/vm/debug.scm (debugger-repl): Errors reading debugger
args no longer drop us out of the debugger.
commit c7317beca603d1a43b2490ba91e1a9df9779eafe
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 13:41:44 2010 +0200
bind debugging i/o ports in start-repl
* module/system/repl/repl.scm (start-repl): If the debugging ports are
unbound, bind them to the current i/o ports. Allows errors within
with-output-to-foo / with-input-from-foo to be sensibly debugged.
commit 7b69cafd0a2dd77fe39396b6c755a2240f4c372b
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 13:37:01 2010 +0200
repl.scm simplifications
* module/system/repl/repl.scm (prompting-meta-read): Use
call-with-error-handling.
* module/system/vm/debug.scm (call-with-error-handling): Add case for
#:on-error 'pass. Have the catch handler return the unspecified value.
commit b93c34c0ca282a7d261f9de7326274fbb3b03774
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 13:30:55 2010 +0200
start cleaning up repl/debugger error handling
* module/system/repl/repl.scm (prompting-meta-read): Catch and print
read errors here, returning unspecified in that case.
(start-repl): Don't enable the debugger while reading expressions.
Adapt with-backtrace to with-error-handling.
* module/system/vm/debug.scm (run-debugger, debugger-repl): No need to
take a stack, the frames vector is sufficient.
(call-with-error-handling, with-error-handling): New public utilities.
Notably they do not poke the-last-stack.
commit 11da3f2bd6793e3241f3083a2f12d8b8167caf0e
Author: Andy Wingo <address@hidden>
Date: Thu Jun 10 12:05:25 2010 +0200
hygienic with-backtrace
* module/system/repl/repl.scm (with-backtrace): Make a syntax-rules
macro.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/boot-9.scm | 212 -------------------------------------------
module/ice-9/deprecated.scm | 202 ++++++++++++++++++++++++++++++++++++++++-
module/system/repl/repl.scm | 60 +++---------
module/system/vm/debug.scm | 119 +++++++++++++++++-------
4 files changed, 300 insertions(+), 293 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 12714bd..9c286bb 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -2906,87 +2906,6 @@ module '(ice-9 q) '(make-q q-length))}."
(define (set-batch-mode?! arg) #t)
(define (batch-mode?) #t)
-(define (error-catching-loop thunk)
- (let ((status #f)
- (interactive #t))
- (define (loop first)
- (let ((next
- (catch #t
-
- (lambda ()
- (call-with-unblocked-asyncs
- (lambda ()
- (with-traps
- (lambda ()
- (first)
-
- ;; This line is needed because mark
- ;; doesn't do closures quite right.
- ;; Unreferenced locals should be
- ;; collected.
- (set! first #f)
- (let loop ((v (thunk)))
- (loop (thunk)))
- #f)))))
-
- (lambda (key . args)
- (case key
- ((quit)
- (set! status args)
- #f)
-
- ((switch-repl)
- (apply throw 'switch-repl args))
-
- ((abort)
- ;; This is one of the closures that require
- ;; (set! first #f) above
- ;;
- (lambda ()
- (run-hook abort-hook)
- (force-output (current-output-port))
- (display "ABORT: " (current-error-port))
- (write args (current-error-port))
- (newline (current-error-port))
- (if interactive
- (begin
- (if (and
- (not has-shown-debugger-hint?)
- (not (memq 'backtrace
- (debug-options-interface)))
- (stack? (fluid-ref the-last-stack)))
- (begin
- (newline (current-error-port))
- (display
- "Type \"(backtrace)\" to get more
information or \"(debug)\" to enter the debugger.\n"
- (current-error-port))
- (set! has-shown-debugger-hint? #t)))
- (force-output (current-error-port)))
- (begin
- (primitive-exit 1)))
- (set! stack-saved? #f)))
-
- (else
- ;; This is the other cons-leak closure...
- (lambda ()
- (cond ((= (length args) 4)
- (apply handle-system-error key args))
- (else
- (apply bad-throw key args)))))))
-
- default-pre-unwind-handler)))
-
- (if next (loop next) status)))
- (set! set-batch-mode?! (lambda (arg)
- (cond (arg
- (set! interactive #f)
- (restore-signals))
- (#t
- (error "sorry, not implemented")))))
- (set! batch-mode? (lambda () (not interactive)))
- (call-with-blocked-asyncs
- (lambda () (loop (lambda () #t))))))
-
;;(define the-last-stack (make-fluid)) Defined by scm_init_backtrace ()
(define before-signal-stack (make-fluid))
;; FIXME: stack-saved? is broken in the presence of threads.
@@ -3042,30 +2961,6 @@ module '(ice-9 q) '(make-q q-length))}."
(define exit quit)
-;;(define has-shown-backtrace-hint? #f) Defined by scm_init_backtrace ()
-
-;; Replaced by C code:
-;;(define (backtrace)
-;; (if (fluid-ref the-last-stack)
-;; (begin
-;; (newline)
-;; (display-backtrace (fluid-ref the-last-stack) (current-output-port))
-;; (newline)
-;; (if (and (not has-shown-backtrace-hint?)
-;; (not (memq 'backtrace (debug-options-interface))))
-;; (begin
-;; (display
-;;"Type \"(debug-enable 'backtrace)\" if you would like a backtrace
-;;automatically if an error occurs in the future.\n")
-;; (set! has-shown-backtrace-hint? #t))))
-;; (display "No backtrace available.\n")))
-
-(define (error-catching-repl r e p)
- (error-catching-loop
- (lambda ()
- (call-with-values (lambda () (e (r)))
- (lambda the-values (for-each p the-values))))))
-
(define (gc-run-time)
(cdr (assq 'gc-time-taken (gc-stats))))
@@ -3086,113 +2981,6 @@ module '(ice-9 q) '(make-q q-length))}."
(run-hook before-read-hook)
((or reader read) (current-input-port))))
-(define (scm-style-repl)
-
- (letrec (
- (start-gc-rt #f)
- (start-rt #f)
- (repl-report-start-timing (lambda ()
- (set! start-gc-rt (gc-run-time))
- (set! start-rt
(get-internal-run-time))))
- (repl-report (lambda ()
- (display ";;; ")
- (display (inexact->exact
- (* 1000 (/ (- (get-internal-run-time)
start-rt)
-
internal-time-units-per-second))))
- (display " msec (")
- (display (inexact->exact
- (* 1000 (/ (- (gc-run-time) start-gc-rt)
-
internal-time-units-per-second))))
- (display " msec in gc)\n")))
-
- (consume-trailing-whitespace
- (lambda ()
- (let ((ch (peek-char)))
- (cond
- ((eof-object? ch))
- ((or (char=? ch #\space) (char=? ch #\tab))
- (read-char)
- (consume-trailing-whitespace))
- ((char=? ch #\newline)
- (read-char))))))
- (-read (lambda ()
- (let ((val
- (let ((prompt (cond ((string? scm-repl-prompt)
- scm-repl-prompt)
- ((thunk? scm-repl-prompt)
- (scm-repl-prompt))
- (scm-repl-prompt "> ")
- (else ""))))
- (repl-reader prompt))))
-
- ;; As described in R4RS, the READ procedure updates the
- ;; port to point to the first character past the end of
- ;; the external representation of the object. This
- ;; means that it doesn't consume the newline typically
- ;; found after an expression. This means that, when
- ;; debugging Guile with GDB, GDB gets the newline, which
- ;; it often interprets as a "continue" command, making
- ;; breakpoints kind of useless. So, consume any
- ;; trailing newline here, as well as any whitespace
- ;; before it.
- ;; But not if EOF, for control-D.
- (if (not (eof-object? val))
- (consume-trailing-whitespace))
- (run-hook after-read-hook)
- (if (eof-object? val)
- (begin
- (repl-report-start-timing)
- (if scm-repl-verbose
- (begin
- (newline)
- (display ";;; EOF -- quitting")
- (newline)))
- (quit 0)))
- val)))
-
- (-eval (lambda (sourc)
- (repl-report-start-timing)
- (run-hook before-eval-hook sourc)
- (let ((val (start-stack 'repl-stack
- ;; If you change this procedure
- ;; (primitive-eval), please also
- ;; modify the repl-stack case in
- ;; save-stack so that stack cutting
- ;; continues to work.
- (primitive-eval sourc))))
- (run-hook after-eval-hook sourc)
- val)))
-
-
- (-print (let ((maybe-print (lambda (result)
- (if (or scm-repl-print-unspecified
- (not (unspecified? result)))
- (begin
- (write result)
- (newline))))))
- (lambda (result)
- (if (not scm-repl-silent)
- (begin
- (run-hook before-print-hook result)
- (maybe-print result)
- (run-hook after-print-hook result)
- (if scm-repl-verbose
- (repl-report))
- (force-output))))))
-
- (-quit (lambda (args)
- (if scm-repl-verbose
- (begin
- (display ";;; QUIT executed, repl exitting")
- (newline)
- (repl-report)))
- args)))
-
- (let ((status (error-catching-repl -read
- -eval
- -print)))
- (-quit status))))
-
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index d55f20f..ba5434f 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -38,7 +38,8 @@
$tanh
closure?
%nil
- @bind)
+ @bind
+ scm-style-repl)
#:replace (module-ref-submodule module-define-submodule!))
@@ -350,3 +351,202 @@ deprecated. Use set-module-public-interface! instead.")
(lambda (mod iface)
(setter mod iface)
(module-define! mod '%module-public-interface iface))))
+
+(define (error-catching-loop thunk)
+ (issue-deprecation-warning
+ "`error-catching-loop' is deprecated. Use the repl from `(system repl
repl)' instead.")
+ (let ((status #f)
+ (interactive #t))
+ (define (loop first)
+ (let ((next
+ (catch #t
+
+ (lambda ()
+ (call-with-unblocked-asyncs
+ (lambda ()
+ (with-traps
+ (lambda ()
+ (first)
+
+ ;; This line is needed because mark
+ ;; doesn't do closures quite right.
+ ;; Unreferenced locals should be
+ ;; collected.
+ (set! first #f)
+ (let loop ((v (thunk)))
+ (loop (thunk)))
+ #f)))))
+
+ (lambda (key . args)
+ (case key
+ ((quit)
+ (set! status args)
+ #f)
+
+ ((switch-repl)
+ (apply throw 'switch-repl args))
+
+ ((abort)
+ ;; This is one of the closures that require
+ ;; (set! first #f) above
+ ;;
+ (lambda ()
+ (run-hook abort-hook)
+ (force-output (current-output-port))
+ (display "ABORT: " (current-error-port))
+ (write args (current-error-port))
+ (newline (current-error-port))
+ (if interactive
+ (begin
+ (if (and
+ (not has-shown-debugger-hint?)
+ (not (memq 'backtrace
+ (debug-options-interface)))
+ (stack? (fluid-ref the-last-stack)))
+ (begin
+ (newline (current-error-port))
+ (display
+ "Type \"(backtrace)\" to get more
information or \"(debug)\" to enter the debugger.\n"
+ (current-error-port))
+ (set! has-shown-debugger-hint? #t)))
+ (force-output (current-error-port)))
+ (begin
+ (primitive-exit 1)))
+ (set! stack-saved? #f)))
+
+ (else
+ ;; This is the other cons-leak closure...
+ (lambda ()
+ (cond ((= (length args) 4)
+ (apply handle-system-error key args))
+ (else
+ (apply bad-throw key args)))))))
+
+ default-pre-unwind-handler)))
+
+ (if next (loop next) status)))
+ (set! set-batch-mode?! (lambda (arg)
+ (cond (arg
+ (set! interactive #f)
+ (restore-signals))
+ (#t
+ (error "sorry, not implemented")))))
+ (set! batch-mode? (lambda () (not interactive)))
+ (call-with-blocked-asyncs
+ (lambda () (loop (lambda () #t))))))
+
+(define (error-catching-repl r e p)
+ (issue-deprecation-warning
+ "`error-catching-repl' is deprecated. Use the repl from `(system repl
repl)' instead.")
+ (error-catching-loop
+ (lambda ()
+ (call-with-values (lambda () (e (r)))
+ (lambda the-values (for-each p the-values))))))
+
+(define (scm-style-repl)
+ (issue-deprecation-warning
+ "`scm-style-repl' is deprecated. Use the repl from `(system repl repl)'
instead.")
+ (letrec (
+ (start-gc-rt #f)
+ (start-rt #f)
+ (repl-report-start-timing (lambda ()
+ (set! start-gc-rt (gc-run-time))
+ (set! start-rt
(get-internal-run-time))))
+ (repl-report (lambda ()
+ (display ";;; ")
+ (display (inexact->exact
+ (* 1000 (/ (- (get-internal-run-time)
start-rt)
+
internal-time-units-per-second))))
+ (display " msec (")
+ (display (inexact->exact
+ (* 1000 (/ (- (gc-run-time) start-gc-rt)
+
internal-time-units-per-second))))
+ (display " msec in gc)\n")))
+
+ (consume-trailing-whitespace
+ (lambda ()
+ (let ((ch (peek-char)))
+ (cond
+ ((eof-object? ch))
+ ((or (char=? ch #\space) (char=? ch #\tab))
+ (read-char)
+ (consume-trailing-whitespace))
+ ((char=? ch #\newline)
+ (read-char))))))
+ (-read (lambda ()
+ (let ((val
+ (let ((prompt (cond ((string? scm-repl-prompt)
+ scm-repl-prompt)
+ ((thunk? scm-repl-prompt)
+ (scm-repl-prompt))
+ (scm-repl-prompt "> ")
+ (else ""))))
+ (repl-reader prompt))))
+
+ ;; As described in R4RS, the READ procedure updates the
+ ;; port to point to the first character past the end of
+ ;; the external representation of the object. This
+ ;; means that it doesn't consume the newline typically
+ ;; found after an expression. This means that, when
+ ;; debugging Guile with GDB, GDB gets the newline, which
+ ;; it often interprets as a "continue" command, making
+ ;; breakpoints kind of useless. So, consume any
+ ;; trailing newline here, as well as any whitespace
+ ;; before it.
+ ;; But not if EOF, for control-D.
+ (if (not (eof-object? val))
+ (consume-trailing-whitespace))
+ (run-hook after-read-hook)
+ (if (eof-object? val)
+ (begin
+ (repl-report-start-timing)
+ (if scm-repl-verbose
+ (begin
+ (newline)
+ (display ";;; EOF -- quitting")
+ (newline)))
+ (quit 0)))
+ val)))
+
+ (-eval (lambda (sourc)
+ (repl-report-start-timing)
+ (run-hook before-eval-hook sourc)
+ (let ((val (start-stack 'repl-stack
+ ;; If you change this procedure
+ ;; (primitive-eval), please also
+ ;; modify the repl-stack case in
+ ;; save-stack so that stack cutting
+ ;; continues to work.
+ (primitive-eval sourc))))
+ (run-hook after-eval-hook sourc)
+ val)))
+
+
+ (-print (let ((maybe-print (lambda (result)
+ (if (or scm-repl-print-unspecified
+ (not (unspecified? result)))
+ (begin
+ (write result)
+ (newline))))))
+ (lambda (result)
+ (if (not scm-repl-silent)
+ (begin
+ (run-hook before-print-hook result)
+ (maybe-print result)
+ (run-hook after-print-hook result)
+ (if scm-repl-verbose
+ (repl-report))
+ (force-output))))))
+
+ (-quit (lambda (args)
+ (if scm-repl-verbose
+ (begin
+ (display ";;; QUIT executed, repl exitting")
+ (newline)
+ (repl-report)))
+ args)))
+
+ (let ((status (error-catching-repl -read
+ -eval
+ -print)))
+ (-quit status))))
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 92f262c..523f3bb 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -28,7 +28,7 @@
#:use-module (system repl command)
#:use-module (system vm vm)
#:use-module (system vm debug)
- #:export (start-repl call-with-backtrace))
+ #:export (start-repl))
(define meta-command-token (cons 'meta 'command))
@@ -50,47 +50,15 @@
;; repl-reader is a function defined in boot-9.scm, and is replaced by
;; something else if readline has been activated. much of this hoopla is
;; to be able to re-use the existing readline machinery.
+;;
+;; Catches read errors, returning *unspecified* in that case.
(define (prompting-meta-read repl)
- (repl-reader (lambda () (repl-prompt repl))
- (meta-reader (language-reader (repl-language repl))
- (current-module))))
-
-(define (default-catch-handler . args)
- (pmatch args
- ((quit . _)
- (apply throw args))
- ((,key ,subr ,msg ,args . ,rest)
- (let ((cep (current-error-port)))
- (cond ((not (stack? (fluid-ref the-last-stack))))
- ((memq 'backtrace (debug-options-interface))
- (let ((highlights (if (or (eq? key 'wrong-type-arg)
- (eq? key 'out-of-range))
- (car rest)
- '())))
- (run-hook before-backtrace-hook)
- (newline cep)
- (display "Backtrace:\n")
- (display-backtrace (fluid-ref the-last-stack) cep
- #f #f highlights)
- (newline cep)
- (run-hook after-backtrace-hook))))
- (run-hook before-error-hook)
- (display-error (fluid-ref the-last-stack) cep subr msg args rest)
- (run-hook after-error-hook)
- (set! stack-saved? #f)
- (force-output cep)))
- (else
- (format (current-error-port) "\nERROR: uncaught throw to `~a', args: ~a\n"
- (car args) (cdr args)))))
-
-(define (call-with-backtrace thunk)
- (catch #t
- (lambda () (%start-stack #t thunk))
- default-catch-handler
- debug-pre-unwind-handler))
-
-(define-macro (with-backtrace form)
- `(call-with-backtrace (lambda () ,form)))
+ (call-with-error-handling
+ (lambda ()
+ (repl-reader (lambda () (repl-prompt repl))
+ (meta-reader (language-reader (repl-language repl))
+ (current-module))))
+ #:on-error 'pass))
(define* (start-repl #:optional (lang (current-language)) #:key
(level (1+ (or (fluid-ref *repl-level*) -1)))
@@ -100,13 +68,17 @@
(if welcome
(repl-welcome repl))
(with-fluids ((*repl-level* level)
+ (*debug-input-port*
+ (or (fluid-ref *debug-input-port*) (current-input-port)))
+ (*debug-output-port*
+ (or (fluid-ref *debug-output-port*) (current-output-port)))
(the-last-stack #f))
(let prompt-loop ()
- (let ((exp (with-backtrace (prompting-meta-read repl))))
+ (let ((exp (prompting-meta-read repl)))
(cond
((eqv? exp (if #f #f))) ; read error, pass
((eq? exp meta-command-token)
- (with-backtrace (meta-command repl)))
+ (with-error-handling (meta-command repl)))
((eof-object? exp)
(newline)
(set! status '()))
@@ -114,7 +86,7 @@
;; since the input port is line-buffered, consume up to the
;; newline
(flush-to-newline)
- (with-backtrace
+ (with-error-handling
(catch 'quit
(lambda ()
(call-with-values
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 7bbb5c8..8151356 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -31,7 +31,8 @@
#:use-module (system vm program)
#:export (*debug-input-port*
*debug-output-port*
- debug run-debugger debug-pre-unwind-handler))
+ debug run-debugger
+ call-with-error-handling with-error-handling))
@@ -187,7 +188,7 @@
;; context of the error, the debugger should really be a kind of coroutine,
;; having its own dynamic input and output bindings. Delimited continuations
can
;; do this.
-(define* (run-debugger stack frames #:optional (vm (the-vm)) #:key
+(define* (run-debugger frames #:optional (vm (the-vm)) #:key
(input (debug-input-port)) (output (debug-output-port)))
(let* ((db (vm-debugger vm))
(level (debugger-level db)))
@@ -198,13 +199,13 @@
(lambda ()
(dynamic-wind
(lambda () (set! output (set-current-output-port output)))
- (lambda () (debugger-repl db stack frames))
+ (lambda () (debugger-repl db frames))
(lambda () (set! output (set-current-output-port output)))))
(lambda ()
(set! input (set-current-input-port input))
(set! (debugger-level db) level)))))
-(define (debugger-repl db stack frames)
+(define (debugger-repl db frames)
(let* ((index 0)
(top (vector-ref frames index))
(cur top)
@@ -396,13 +397,17 @@ With an argument, select a frame by index, then show it."
(catch 'quit
(lambda ()
(let loop ()
- (apply
- handle
- (save-module-excursion
- (lambda ()
- (set-current-module commands)
- (read-args prompt))))
- (loop)))
+ (let ((args (call-with-error-handling
+ (lambda ()
+ (save-module-excursion
+ (lambda ()
+ (set-current-module commands)
+ (read-args prompt))))
+ #:on-error 'pass)))
+ ;; args will be unspecified if there was a read error.
+ (if (not (unspecified? args))
+ (apply handle args))
+ (loop))))
(lambda (k . args)
(apply values args))))))
@@ -440,32 +445,74 @@ With an argument, select a frame by index, then show it."
(lp (1+ i) (frame-previous frame))))))
v))
-(define (debug-pre-unwind-handler key . args)
- ;; Narrow the stack by three frames: make-stack, this one, and the throw
- ;; handler.
- (cond
- ((make-stack #t 3) =>
- (lambda (stack)
- (pmatch args
- ((,subr ,msg ,args . ,rest)
- (format (debug-output-port) "Throw to key `~a':\n" key)
- (display-error stack (debug-output-port) subr msg args rest))
- (else
- (format (debug-output-port) "Throw to key `~a' with args `~s'." key
args)))
- (format (debug-output-port)
- "Entering the debugger. Type `bt' for a backtrace or `c' to
continue.\n")
- (run-debugger stack
- (stack->vector
- ;; by default, narrow to the most recent start-stack
- (make-stack (stack-ref stack 0) 0
- (and (pair? (fluid-ref %stacks))
- (cdar (fluid-ref %stacks)))))
- 0))))
- (save-stack debug-pre-unwind-handler)
- (apply throw key args))
-
(define (debug)
(let ((stack (fluid-ref the-last-stack)))
(if stack
- (run-debugger stack (stack->vector stack))
+ (run-debugger (stack->vector stack))
(display "Nothing to debug.\n" (debug-output-port)))))
+
+(define (narrow-stack->vector stack . args)
+ (stack->vector (apply make-stack (stack-ref stack 0) args)))
+
+(define* (call-with-error-handling thunk #:key
+ (on-error 'debug) (post-error 'catch)
+ (pass-keys '(quit)))
+ (catch #t
+ (lambda () (%start-stack #t thunk))
+
+ (case post-error
+ ((catch)
+ (lambda (key . args)
+ (if (memq key pass-keys)
+ (apply throw key args)
+ (let ((cep (current-error-port)))
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (run-hook before-error-hook)
+ (display-error #f cep subr msg args rest)
+ (run-hook after-error-hook)
+ (force-output cep))
+ (else
+ (format cep "\nERROR: uncaught throw to `~a', args: ~a\n"
+ key args)))
+ (if #f #f)))))
+ (else
+ (if (procedure? post-error)
+ post-error
+ (error "Unknown post-error strategy" post-error))))
+
+ (case on-error
+ ((debug)
+ (lambda (key . args)
+ (let ((stack (make-stack #t))
+ (dep (debug-output-port)))
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (format dep "Throw to key `~a':\n" key)
+ (display-error stack dep subr msg args rest))
+ (else
+ (format dep "Throw to key `~a' with args `~s'." key args)))
+ (format dep "Entering the debugger. Type `bt' for a backtrace")
+ (format dep " or `c' to continue.\n")
+ (run-debugger
+ (narrow-stack->vector
+ stack
+ ;; 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.
+ (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))))))
+ ((pass)
+ (lambda (key . args)
+ ;; fall through to rethrow
+ #t))
+ (else
+ (if (procedure? on-error)
+ on-error
+ (error "Unknown on-error strategy" on-error))))))
+
+(define-syntax with-error-handling
+ (syntax-rules ()
+ ((_ form)
+ (call-with-error-handling (lambda () form)))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-11-35-g4ae3d5a,
Andy Wingo <=