mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

handle-system-error to scm-style-repl

Browse source 
* 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:
Andy Wingo 2010-06-19 11:43:48 +02:00
parent a6025413eb
commit 7034da249b
3 changed files with 31 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

21
module/ice-9/boot-9.scm
View file

@ -2710,27 +2710,6 @@ module '(ice-9 q) '(make-q q-length))}."
narrowing)))
(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)
(apply throw 'quit args))

9
module/ice-9/deprecated.scm
View file

@ -58,7 +58,8 @@
set-batch-mode?!
repl
pre-unwind-handler-dispatch
default-pre-unwind-handler)
default-pre-unwind-handler
handle-system-error)
#: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
`(ice-9 scm-style-repl)' if you need it.")
(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))

24
module/ice-9/scm-style-repl.scm
View file

@ -31,7 +31,8 @@
bad-throw
error-catching-loop
error-catching-repl
scm-style-repl))
scm-style-repl
handle-system-error))
(define scm-repl-silent #f)
(define (assert-repl-silence v) (set! scm-repl-silent v))
@ -257,3 +258,24 @@
-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)))