-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2014
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;;
(define-module (ice-9 scm-style-repl)
+ #:use-module (ice-9 save-stack)
+
#:export (scm-repl-silent
scm-repl-print-unspecified
scm-repl-verbose
- scm-repl-prompt)
-
- ;; #:replace, as with deprecated code enabled these will be in the root env
- #:replace (assert-repl-silence
- assert-repl-print-unspecified
- assert-repl-verbosity
-
- bad-throw
- error-catching-loop
- error-catching-repl
- scm-style-repl))
+ scm-repl-prompt
+ assert-repl-silence
+ assert-repl-print-unspecified
+ assert-repl-verbosity
+
+ default-pre-unwind-handler
+ bad-throw
+ error-catching-loop
+ error-catching-repl
+ scm-style-repl
+ handle-system-error))
(define scm-repl-silent #f)
(define (assert-repl-silence v) (set! scm-repl-silent v))
\f
+(define (default-pre-unwind-handler key . args)
+ ;; Narrow by two more frames: this one, and the throw handler.
+ (save-stack 2)
+ (apply throw key args))
+
+\f
+
+(define has-shown-debugger-hint? #f)
+
(define (error-catching-loop thunk)
(let ((status #f)
(interactive #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)))))
+ (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
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! ensure-batch-mode! (lambda ()
+ (set! interactive #f)
+ (restore-signals)))
(set! batch-mode? (lambda () (not interactive)))
(call-with-blocked-asyncs
(lambda () (loop (lambda () #t))))))
-eval
-print)))
(-quit status))))
+
+(define (handle-system-error key . args)
+ (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))
+ (list-ref args 3)
+ '())))
+ (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)
+ (apply display-error (fluid-ref the-last-stack) cep args)
+ (run-hook after-error-hook)
+ (force-output cep)
+ (throw 'abort key)))