Adapt visit-prompt-control-flow to use intsets.

[bpt/guile.git] / module / ice-9 / scm-style-repl.scm

diff --git a/module/ice-9/scm-style-repl.scm b/module/ice-9/scm-style-repl.scm
index 01e9de4..12c4463 100644 (file)
--- a/module/ice-9/scm-style-repl.scm
+++ b/module/ice-9/scm-style-repl.scm
@@ -1,4 +1,4 @@
-;;;; 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
@@ -17,11 +17,35 @@
 ;;;;
 
 (define-module (ice-9 scm-style-repl)
-  ;; #:replace, as with deprecated code enabled these will be in the root env
-  #:replace (bad-throw
-             error-catching-loop
-             error-catching-repl
-             scm-style-repl))
+  #:use-module (ice-9 save-stack)
+
+  #:export (scm-repl-silent
+            scm-repl-print-unspecified
+            scm-repl-verbose
+            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))
+
+(define scm-repl-print-unspecified #f)
+(define (assert-repl-print-unspecified v) (set! scm-repl-print-unspecified v))
+
+(define scm-repl-verbose #f)
+(define (assert-repl-verbosity v) (set! scm-repl-verbose v))
+
+(define scm-repl-prompt "guile> ")
+
+\f
 
 ;; bad-throw is the hook that is called upon a throw to a an unhandled
 ;; key (unless the throw has four arguments, in which case
@@ -36,6 +60,15 @@
 
 \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))
@@ -46,18 +79,16 @@
                     (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
@@ -107,12 +138,9 @@
                     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))))))
@@ -228,3 +256,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)))