slot-ref, slot-set! et al bypass "using-class" variants

[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 5ce8185..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,21 +17,22 @@
 ;;;;
 
 (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
-
-             default-pre-unwind-handler
-             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))
@@ -78,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
@@ -257,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)))