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

catch errors in the repl, with poor backtraces

Browse source 
* module/system/repl/repl.scm (default-pre-unwind-handler)
  (default-catch-handler): New procedures, to do some error handling in
  the repl.
  (start-repl): Catch errors in the repl loop.
This commit is contained in:
Andy Wingo 2008-05-12 23:27:14 +02:00
parent db917b4152
commit 9cd17db7dc
1 changed files with 41 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

47
module/system/repl/repl.scm
View file

@ -21,6 +21,7 @@
(define-module (system repl repl)
:use-syntax (system base syntax)
:use-module (system base pmatch)
:use-module (system base compile)
:use-module (system base language)
:use-module (system repl common)
@ -49,6 +50,41 @@
(with-fluid* current-reader (meta-reader lread)
(lambda () (repl-reader (lambda () (repl-prompt repl)))))))
(define (default-pre-unwind-handler key . args)
(save-stack default-pre-unwind-handler)
(apply throw key args))
(define (default-catch-handler . args)
(pmatch args
((quit . _)
(apply throw args))
((vm-error ,fun ,msg ,args)
(display "VM error: ")
(apply format #t msg args)
(newline))
((,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)
(apply 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
(apply bad-throw args))))
(define (start-repl lang)
(let ((repl (make-repl lang)))
(repl-welcome repl)
@ -60,20 +96,19 @@
((eof-object? exp)
(throw 'quit))
(else
(catch 'vm-error
(catch #t
(lambda ()
(call-with-values (lambda ()
(run-hook before-eval-hook exp)
(repl-eval repl exp))
(start-stack repl-eval
(repl-eval repl exp)))
(lambda l
(for-each (lambda (v)
(run-hook before-print-hook v)
(repl-print repl v))
l))))
(lambda (key fun msg args)
(display "ERROR: ")
(apply format #t msg args)
(newline)))))
default-catch-handler
default-pre-unwind-handler)))
(next-char #f) ;; consume trailing whitespace
(prompt-loop)))))