mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-29 00:10:21 +02:00
handle-system-error to scm-style-repl
* module/ice-9/boot-9.scm: * module/ice-9/scm-style-repl.scm (handle-system-error): Move here from boot-9. * module/ice-9/deprecated.scm (handle-system-error): Keep a deprecated wrapper in the root environment.
This commit is contained in:
parent
a6025413eb
commit
7034da249b
3 changed files with 31 additions and 23 deletions
|
@ -2710,27 +2710,6 @@ module '(ice-9 q) '(make-q q-length))}."
|
||||||
narrowing)))
|
narrowing)))
|
||||||
(set! stack-saved? #t))))
|
(set! stack-saved? #t))))
|
||||||
|
|
||||||
(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)))
|
|
||||||
|
|
||||||
(define (quit . args)
|
(define (quit . args)
|
||||||
(apply throw 'quit args))
|
(apply throw 'quit args))
|
||||||
|
|
||||||
|
|
|
@ -58,7 +58,8 @@
|
||||||
set-batch-mode?!
|
set-batch-mode?!
|
||||||
repl
|
repl
|
||||||
pre-unwind-handler-dispatch
|
pre-unwind-handler-dispatch
|
||||||
default-pre-unwind-handler)
|
default-pre-unwind-handler
|
||||||
|
handle-system-error)
|
||||||
|
|
||||||
#:replace (module-ref-submodule module-define-submodule!))
|
#:replace (module-ref-submodule module-define-submodule!))
|
||||||
|
|
||||||
|
@ -630,3 +631,9 @@ the `(system repl common)' module.")
|
||||||
"`default-pre-unwind-handler' is deprecated. Use it from
|
"`default-pre-unwind-handler' is deprecated. Use it from
|
||||||
`(ice-9 scm-style-repl)' if you need it.")
|
`(ice-9 scm-style-repl)' if you need it.")
|
||||||
(apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
|
(apply (@ (ice-9 scm-style-repl) default-pre-unwind-handler) key args))
|
||||||
|
|
||||||
|
(define (handle-system-error key . args)
|
||||||
|
(issue-deprecation-warning
|
||||||
|
"`handle-system-error' is deprecated. Use it from
|
||||||
|
`(ice-9 scm-style-repl)' if you need it.")
|
||||||
|
(apply (@ (ice-9 scm-style-repl) handle-system-error) key args))
|
||||||
|
|
|
@ -31,7 +31,8 @@
|
||||||
bad-throw
|
bad-throw
|
||||||
error-catching-loop
|
error-catching-loop
|
||||||
error-catching-repl
|
error-catching-repl
|
||||||
scm-style-repl))
|
scm-style-repl
|
||||||
|
handle-system-error))
|
||||||
|
|
||||||
(define scm-repl-silent #f)
|
(define scm-repl-silent #f)
|
||||||
(define (assert-repl-silence v) (set! scm-repl-silent v))
|
(define (assert-repl-silence v) (set! scm-repl-silent v))
|
||||||
|
@ -257,3 +258,24 @@
|
||||||
-eval
|
-eval
|
||||||
-print)))
|
-print)))
|
||||||
(-quit status))))
|
(-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)))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue