0.8.20.1: fun-name fun, debugger debugged
[sbcl.git] / src / code / toplevel.lisp
index 5367a75..7cf0921 100644 (file)
@@ -18,8 +18,8 @@
 ;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
 ;;; of all static symbols in early-impl.lisp.
 (progn
-  (defvar *current-catch-block*)
-  (defvar *current-unwind-protect-block*)
+  (defvar sb!vm::*current-catch-block*)
+  (defvar sb!vm::*current-unwind-protect-block*)
   (defvar *free-interrupt-context-index*))
 \f
 ;;; specials initialized by !COLD-INIT
 ;;; counts of nested errors (with internal errors double-counted)
 (defvar *maximum-error-depth*)
 (defvar *current-error-depth*)
+
+;;;; stepping control
+(defvar *step*)
+(defvar *stepping*)
+(defvar *step-form-stack* nil 
+  "A place for single steppers to push information about
+STEP-FORM-CONDITIONS avaiting the corresponding
+STEP-VALUES-CONDITIONS. The system is guaranteed to empty the stack
+when stepping terminates, so that it remains in sync, but doesn't
+modify it in any other way: it is provided for implmentors of single
+steppers to maintain contextual information.")
 \f
 ;;;; miscellaneous utilities for working with with TOPLEVEL
 
     `(let ((,caught (catch '%end-of-the-world
                      (/show0 "inside CATCH '%END-OF-THE-WORLD")
                      ,@body)))
-       (/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output")
-       (flush-standard-output-streams)
-       (/show0 "calling UNIX-EXIT")
-       (sb!unix:unix-exit ,caught))))
+      (/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output")
+      (flush-standard-output-streams)
+      (sb!thread::terminate-session)
+      (/show0 "calling UNIX-EXIT")
+      (sb!unix:unix-exit ,caught))))
 \f
 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
 
                 ((= offset bytes-per-scrub-unit)
                  (look (sap+ ptr bytes-per-scrub-unit) 0 count))
                 (t
-                 (setf (sap-ref-32 ptr offset) 0)
+                 (setf (sap-ref-word ptr offset) 0)
                  (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
         (look (ptr offset count)
           (declare (type system-area-pointer ptr)
           (cond ((>= (sap-int ptr) end-of-stack) 0)
                 ((= offset bytes-per-scrub-unit)
                  count)
-                ((zerop (sap-ref-32 ptr offset))
+                ((zerop (sap-ref-word ptr offset))
                  (look ptr (+ offset sb!vm:n-word-bytes) count))
                 (t
                  (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
-      (declare (type (unsigned-byte 32) csp))
+      (declare (type sb!vm::word csp))
       (scrub (int-sap (- csp initial-offset))
             (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
             0)))
                    (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
                          0 count))
                   (t ;; need to fix bug in %SET-STACK-REF
-                   (setf (sap-ref-32 loc 0) 0)
+                   (setf (sap-ref-word loc 0) 0)
                    (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
         (look (ptr offset count)
           (declare (type system-area-pointer ptr)
                    (look ptr (+ offset sb!vm:n-word-bytes) count))
                   (t
                    (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
-      (declare (type (unsigned-byte 32) csp))
+      (declare (type sb!vm::word csp))
       (scrub (int-sap (+ csp initial-offset))
             (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
             0))))
    +++, ++, +, ///, //, /, and -."
   (setf - form)
   (let ((results
-        (multiple-value-list
-         (eval-in-lexenv form
-                         (make-null-interactive-lexenv)))))
+         (multiple-value-list
+          (eval-in-lexenv form
+                          (make-null-interactive-lexenv)))))
     (setf /// //
          // /
          / results
 
 ;;; the default system top level function
 (defun toplevel-init ()
-
-  (/show0 "entering TOPLEVEL-INIT")
-  (setf sb!thread::*session-lock* (sb!thread:make-mutex :name "the terminal"))
-  (sb!thread::get-foreground)
+  (/show0 "entering TOPLEVEL-INIT")  
   (let (;; value of --sysinit option
        (sysinit nil)
        ;; value of --userinit option
     ;; FIXME: There are lots of ways for errors to happen around here
     ;; (e.g. bad command line syntax, or READ-ERROR while trying to
     ;; READ an --eval string). Make sure that they're handled
-    ;; reasonably. Also, perhaps all errors while parsing the command
-    ;; line should cause the system to QUIT, instead of trying to go
-    ;; into the Lisp debugger, since trying to go into the debugger
-    ;; gets into various annoying issues of where we should go after
-    ;; the user tries to return from the debugger.
+    ;; reasonably.
     
-    ;; Parse command line options.
-    (loop while options do
-         (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
-         (let ((option (first options)))
-           (flet ((pop-option ()
-                    (if options
-                        (pop options)
-                        (error "unexpected end of command line options"))))
-             (cond ((string= option "--sysinit")
-                    (pop-option)
-                    (if sysinit
-                        (error "multiple --sysinit options")
-                        (setf sysinit (pop-option))))
-                   ((string= option "--userinit")
-                    (pop-option)
-                    (if userinit
-                        (error "multiple --userinit options")
-                        (setf userinit (pop-option))))
-                   ((string= option "--eval")
-                    (pop-option)
-                    (push (pop-option) reversed-evals))
-                   ((string= option "--load")
-                    (pop-option)
-                    (push
-                     ;; FIXME: see BUG 296
-                     (concatenate 'string "(|LOAD| \"" (pop-option) "\")")
-                     reversed-evals))
-                   ((string= option "--noprint")
-                    (pop-option)
-                    (setf noprint t))
-                   ;; FIXME: --noprogrammer was deprecated in 0.7.5, and
-                   ;; in a year or so this backwards compatibility can
-                   ;; go away.
-                   ((string= option "--noprogrammer")
-                    (warn "treating deprecated --noprogrammer as --disable-debugger")
-                    (pop-option)
-                    (push "(|DISABLE-DEBUGGER|)" reversed-evals))
-                   ((string= option "--disable-debugger")
-                    (pop-option)
-                    (push "(|DISABLE-DEBUGGER|)" reversed-evals))
-                   ((string= option "--end-toplevel-options")
-                    (pop-option)
-                    (return))
-                   (t
-                    ;; Anything we don't recognize as a toplevel
-                    ;; option must be the start of user-level
-                    ;; options.. except that if we encounter
-                    ;; "--end-toplevel-options" after we gave up
-                    ;; because we didn't recognize an option as a
-                    ;; toplevel option, then the option we gave up on
-                    ;; must have been an error. (E.g. in
-                    ;;  "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options"
-                    ;; this test will let us detect that the string
-                    ;; "--eval(b)" is an error.)
-                    (if (find "--end-toplevel-options" options
-                              :test #'string=)
-                        (error "bad toplevel option: ~S" (first options))
-                        (return)))))))
-    (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
-
-    ;; Delete all the options that we processed, so that only
-    ;; user-level options are left visible to user code.
-    (setf (rest *posix-argv*) options)
-
-    ;; Handle initialization files.
-    (/show0 "handling initialization files in TOPLEVEL-INIT")
-    (flet (;; If any of POSSIBLE-INIT-FILE-NAMES names a real file,
-          ;; return its truename.
-          (probe-init-files (&rest possible-init-file-names)
-             (declare (type list possible-init-file-names))
-            (/show0 "entering PROBE-INIT-FILES")
-            (prog1
-                (find-if (lambda (x)
-                           (and (stringp x) (probe-file x)))
-                         possible-init-file-names)
-              (/show0 "leaving PROBE-INIT-FILES"))))
-      (let* ((sbcl-home (posix-getenv "SBCL_HOME"))
-            (sysinit-truename
-             (probe-init-files sysinit
-                               (concatenate 'string sbcl-home "/sbclrc")
-                               "/etc/sbclrc"))
-            (user-home (or (posix-getenv "HOME")
-                           (error "The HOME environment variable is unbound, ~
-                                   so user init file can't be found.")))
-            (userinit-truename (probe-init-files userinit
-                                                 (concatenate 'string
-                                                              user-home
-                                                              "/.sbclrc"))))
-
-       ;; We wrap all the pre-REPL user/system customized startup code 
-       ;; in a restart.
-       ;;
-       ;; (Why not wrap everything, even the stuff above, in this
-       ;; restart? Errors above here are basically command line or
-       ;; Unix environment errors, e.g. a missing file or a typo on
-       ;; the Unix command line, and you don't need to get into Lisp
-       ;; to debug them, you should just start over and do it right
-       ;; at the Unix level. Errors below here are generally errors
-       ;; in user Lisp code, and it might be helpful to let the user
-       ;; reach the REPL in order to help figure out what's going
-       ;; on.)
-       (restart-case
-           (progn
-             (flet ((process-init-file (truename)
-                      (when truename
-                        (unless (load truename)
-                          (error "~S was not successfully loaded." truename))
-                        (flush-standard-output-streams))))
-               (process-init-file sysinit-truename)
-               (process-init-file userinit-truename))
-
-             ;; Process --eval options.
-             (/show0 "handling --eval options in TOPLEVEL-INIT")
-             (dolist (expr-as-string (reverse reversed-evals))
-               (/show0 "handling one --eval option in TOPLEVEL-INIT")
-               (let ((expr (with-input-from-string (eval-stream
-                                                    expr-as-string)
-                             (let* ((eof-marker (cons :eof :eof))
-                                    (result (read eval-stream nil eof-marker))
-                                    (eof (read eval-stream nil eof-marker)))
-                               (cond ((eq result eof-marker)
-                                      (error "unable to parse ~S"
-                                             expr-as-string))
-                                     ((not (eq eof eof-marker))
-                                      (error "more than one expression in ~S"
-                                             expr-as-string))
-                                     (t
-                                      result))))))
-                 (eval expr)
-                 (flush-standard-output-streams))))
-         (continue ()
-           :report
-           "Continue anyway (skipping to toplevel read/eval/print loop)."
-           (/show0 "CONTINUEing from pre-REPL RESTART-CASE")
-           (values)) ; (no-op, just fall through)
-         (quit ()
-           :report "Quit SBCL (calling #'QUIT, killing the process)."
-           (/show0 "falling through to QUIT from pre-REPL RESTART-CASE")
-           (quit))))
-
-      ;; one more time for good measure, in case we fell out of the
-      ;; RESTART-CASE above before one of the flushes in the ordinary
-      ;; flow of control had a chance to operate
-      (flush-standard-output-streams)
-
-      (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
-      (toplevel-repl noprint)
-      ;; (classic CMU CL error message: "You're certainly a clever child.":-)
-      (critically-unreachable "after TOPLEVEL-REPL"))))
+    ;; Process command line options.
+    (flet (;; Errors while processing the command line cause the system
+          ;; to QUIT, instead of trying to go into the Lisp debugger,
+          ;; because trying to go into the Lisp debugger would get
+          ;; into various annoying issues of where we should go after
+          ;; the user tries to return from the debugger.
+          (startup-error (control-string &rest args)
+             (format
+             *error-output*
+             "fatal error before reaching READ-EVAL-PRINT loop: ~%  ~?~%"
+             control-string
+             args)
+             (quit :unix-status 1)))
+      (loop while options do
+           (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
+           (let ((option (first options)))
+             (flet ((pop-option ()
+                      (if options
+                          (pop options)
+                          (startup-error
+                           "unexpected end of command line options"))))
+               (cond ((string= option "--sysinit")
+                      (pop-option)
+                      (if sysinit
+                          (startup-error "multiple --sysinit options")
+                          (setf sysinit (pop-option))))
+                     ((string= option "--userinit")
+                      (pop-option)
+                      (if userinit
+                          (startup-error "multiple --userinit options")
+                          (setf userinit (pop-option))))
+                     ((string= option "--eval")
+                      (pop-option)
+                      (push (pop-option) reversed-evals))
+                     ((string= option "--load")
+                      (pop-option)
+                      (push
+                       ;; FIXME: see BUG 296
+                       (concatenate 'string "(|LOAD| \"" (pop-option) "\")")
+                       reversed-evals))
+                     ((string= option "--noprint")
+                      (pop-option)
+                      (setf noprint t))
+                     ;; FIXME: --noprogrammer was deprecated in 0.7.5, and
+                     ;; in a year or so this backwards compatibility can
+                     ;; go away.
+                     ((string= option "--noprogrammer")
+                      (warn "treating deprecated --noprogrammer as --disable-debugger")
+                      (pop-option)
+                      (push "(|DISABLE-DEBUGGER|)" reversed-evals))
+                     ((string= option "--disable-debugger")
+                      (pop-option)
+                      (push "(|DISABLE-DEBUGGER|)" reversed-evals))
+                     ((string= option "--end-toplevel-options")
+                      (pop-option)
+                      (return))
+                     (t
+                      ;; Anything we don't recognize as a toplevel
+                      ;; option must be the start of user-level
+                      ;; options.. except that if we encounter
+                      ;; "--end-toplevel-options" after we gave up
+                      ;; because we didn't recognize an option as a
+                      ;; toplevel option, then the option we gave up on
+                      ;; must have been an error. (E.g. in
+                      ;;  "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options"
+                      ;; this test will let us detect that the string
+                      ;; "--eval(b)" is an error.)
+                      (if (find "--end-toplevel-options" options
+                                :test #'string=)
+                          (startup-error "bad toplevel option: ~S"
+                                         (first options))
+                          (return)))))))
+      (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
+
+      ;; Delete all the options that we processed, so that only
+      ;; user-level options are left visible to user code.
+      (setf (rest *posix-argv*) options)
+
+      ;; Handle initialization files.
+      (/show0 "handling initialization files in TOPLEVEL-INIT")
+      (flet (;; shared idiom for searching for SYSINITish and
+            ;; USERINITish files
+             (probe-init-files (explicitly-specified-init-file-name
+                               &rest default-init-file-names)
+               (declare (type list default-init-file-names))
+              (if explicitly-specified-init-file-name
+                  (or (probe-file explicitly-specified-init-file-name)
+                        (startup-error "The file ~S was not found."
+                                      explicitly-specified-init-file-name))
+                   (find-if (lambda (x)
+                              (and (stringp x) (probe-file x)))
+                            default-init-file-names)))
+            ;; shared idiom for creating default names for
+            ;; SYSINITish and USERINITish files
+            (init-file-name (maybe-dir-name basename)
+              (and maybe-dir-name
+                   (concatenate 'string maybe-dir-name "/" basename))))
+        (let ((sysinit-truename
+              (probe-init-files sysinit
+                                (init-file-name (posix-getenv "SBCL_HOME")
+                                                "sbclrc")
+                                "/etc/sbclrc"))
+               (userinit-truename
+               (probe-init-files userinit
+                                 (init-file-name (posix-getenv "HOME")
+                                                 ".sbclrc"))))
+
+          ;; We wrap all the pre-REPL user/system customized startup code 
+          ;; in a restart.
+          ;;
+          ;; (Why not wrap everything, even the stuff above, in this
+          ;; restart? Errors above here are basically command line or
+          ;; Unix environment errors, e.g. a missing file or a typo on
+          ;; the Unix command line, and you don't need to get into Lisp
+          ;; to debug them, you should just start over and do it right
+          ;; at the Unix level. Errors below here are generally errors
+          ;; in user Lisp code, and it might be helpful to let the user
+          ;; reach the REPL in order to help figure out what's going
+          ;; on.)
+          (restart-case
+              (progn
+                (flet ((process-init-file (truename)
+                         (when truename
+                           (unless (load truename)
+                             (error "~S was not successfully loaded."
+                                   truename))
+                           (flush-standard-output-streams))))
+                  (process-init-file sysinit-truename)
+                  (process-init-file userinit-truename))
+
+                ;; Process --eval options.
+                (/show0 "handling --eval options in TOPLEVEL-INIT")
+                (dolist (expr-as-string (reverse reversed-evals))
+                  (/show0 "handling one --eval option in TOPLEVEL-INIT")
+                  (let ((expr (with-input-from-string (eval-stream
+                                                       expr-as-string)
+                                (let* ((eof-marker (cons :eof :eof))
+                                       (result (read eval-stream
+                                                    nil
+                                                    eof-marker))
+                                       (eof (read eval-stream nil eof-marker)))
+                                  (cond ((eq result eof-marker)
+                                         (error "unable to parse ~S"
+                                                expr-as-string))
+                                        ((not (eq eof eof-marker))
+                                         (error
+                                         "more than one expression in ~S"
+                                         expr-as-string))
+                                        (t
+                                         result))))))
+                    (eval expr)
+                    (flush-standard-output-streams))))
+            (continue ()
+              :report
+              "Continue anyway (skipping to toplevel read/eval/print loop)."
+              (/show0 "CONTINUEing from pre-REPL RESTART-CASE")
+              (values))                 ; (no-op, just fall through)
+            (quit ()
+              :report "Quit SBCL (calling #'QUIT, killing the process)."
+              (/show0 "falling through to QUIT from pre-REPL RESTART-CASE")
+              (quit))))
+
+        ;; one more time for good measure, in case we fell out of the
+        ;; RESTART-CASE above before one of the flushes in the ordinary
+        ;; flow of control had a chance to operate
+        (flush-standard-output-streams)
+
+        (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
+        (toplevel-repl noprint)
+        ;; (classic CMU CL error message: "You're certainly a clever child.":-)
+        (critically-unreachable "after TOPLEVEL-REPL")))))
+
+;;; hooks to support customized toplevels like ACL-style toplevel from
+;;; KMR on sbcl-devel 2002-12-21.  Altered by CSR 2003-11-16 for
+;;; threaded operation: altered *REPL-FUN* to *REPL-FUN-GENERATOR*.
+(defvar *repl-read-form-fun* #'repl-read-form-fun
+  "a function of two stream arguments IN and OUT for the toplevel REPL to
+  call: Return the next Lisp form to evaluate (possibly handling other
+  magic -- like ACL-style keyword commands -- which precede the next
+  Lisp form). The OUT stream is there to support magic which requires
+  issuing new prompts.")
+(defvar *repl-prompt-fun* #'repl-prompt-fun
+  "a function of one argument STREAM for the toplevel REPL to call: Prompt
+  the user for input.")
+(defvar *repl-fun-generator* (constantly #'repl-fun)
+  "a function of no arguments returning a function of one argument
+  NOPRINT that provides the REPL for the system.  Assumes that
+  *STANDARD-INPUT* and *STANDARD-OUTPUT* are set up.")
 
 ;;; read-eval-print loop for the default system toplevel
 (defun toplevel-repl (noprint)
        (- nil)
        (+ nil) (++ nil) (+++ nil)
        (/// nil) (// nil) (/ nil))
-    ;; WITH-SIMPLE-RESTART doesn't actually restart its body as some
-    ;; (like WHN for an embarrassingly long time ca. 2001-12-07) might
-    ;; think, but instead drops control back out at the end. So when a
-    ;; TOPLEVEL or outermost-ABORT restart happens, we need this outer
-    ;; LOOP wrapper to grab control and start over again. (And it also
-    ;; wraps CATCH 'TOPLEVEL-CATCHER for similar reasons.)
-    (loop
-     (/show0 "about to set up restarts in TOPLEVEL-REPL")
-     ;; There should only be one TOPLEVEL restart, and it's here, so
-     ;; restarting at TOPLEVEL always bounces you all the way out here.
-     (with-simple-restart (toplevel
-                          "Restart at toplevel READ/EVAL/PRINT loop.")
-       ;; We add a new ABORT restart for every debugger level, so 
-       ;; restarting at ABORT in a nested debugger gets you out to the
-       ;; innermost enclosing debugger, and only when you're in the
-       ;; outermost, unnested debugger level does restarting at ABORT 
-       ;; get you out to here.
-       (with-simple-restart
-          (abort
-           "~@<Reduce debugger level (leaving debugger, returning to toplevel).~@:>")
-        (catch 'toplevel-catcher
-          (sb!unix::reset-signal-mask)
-          ;; in the event of a control-stack-exhausted-error, we should
-          ;; have unwound enough stack by the time we get here that this
-          ;; is now possible
-          (sb!kernel::protect-control-stack-guard-page 1)
-          (funcall *repl-fun* noprint)
-          (critically-unreachable "after REPL")))))))
+    (/show0 "about to funcall *REPL-FUN-GENERATOR*")
+    (let ((repl-fun (funcall *repl-fun-generator*)))
+      ;; Each REPL in a multithreaded world should have bindings of
+      ;; most CL specials (most critically *PACKAGE*).
+      (with-rebound-io-syntax
+         (handler-bind ((step-condition 'invoke-stepper))
+           (let ((*stepping* nil)
+                 (*step* nil))
+             ;; WITH-SIMPLE-RESTART doesn't actually restart its body as
+             ;; some (like WHN for an embarrassingly long time
+             ;; ca. 2001-12-07) might think, but instead drops control back
+             ;; out at the end. So when a TOPLEVEL or outermost-ABORT
+             ;; restart happens, we need this outer LOOP wrapper to grab
+             ;; control and start over again. (And it also wraps CATCH
+             ;; 'TOPLEVEL-CATCHER for similar reasons.)
+             (loop
+              (/show0 "about to set up restarts in TOPLEVEL-REPL")
+              ;; There should only be one TOPLEVEL restart, and it's here,
+              ;; so restarting at TOPLEVEL always bounces you all the way
+              ;; out here.
+              (with-simple-restart (toplevel
+                                    "Restart at toplevel READ/EVAL/PRINT loop.")
+                ;; We add a new ABORT restart for every debugger level, so
+                ;; restarting at ABORT in a nested debugger gets you out to
+                ;; the innermost enclosing debugger, and only when you're
+                ;; in the outermost, unnested debugger level does
+                ;; restarting at ABORT get you out to here.
+                (with-simple-restart
+                    (abort "~@<Reduce debugger level (leaving debugger, ~
+                            returning to toplevel).~@:>")
+                  (catch 'toplevel-catcher
+                    (sb!unix::reset-signal-mask)
+                    ;; In the event of a control-stack-exhausted-error, we
+                    ;; should have unwound enough stack by the time we get
+                    ;; here that this is now possible.
+                    (sb!kernel::protect-control-stack-guard-page 1)
+                    (funcall repl-fun noprint)
+                    (critically-unreachable "after REPL")))))))))))
 
 ;;; Our default REPL prompt is the minimal traditional one.
 (defun repl-prompt-fun (stream)
        (quit)
        form)))
 
-;;; hooks to support customized toplevels like ACL-style toplevel
-;;; from KMR on sbcl-devel 2002-12-21
-(defvar *repl-read-form-fun* #'repl-read-form-fun
-  "a function of two stream arguments IN and OUT for the toplevel REPL to
-  call: Return the next Lisp form to evaluate (possibly handling other
-  magic -- like ACL-style keyword commands -- which precede the next
-  Lisp form). The OUT stream is there to support magic which requires
-  issuing new prompts.")
-(defvar *repl-prompt-fun* #'repl-prompt-fun
-  "a function of one argument STREAM for the toplevel REPL to call: Prompt
-  the user for input.")
-(defvar *repl-fun* #'repl-fun
-  "a function of one argument NOPRINT that provides the REPL for the system.
-  Assumes that *standard-input* and *standard-output* are setup.")
-
 (defun repl-fun (noprint)
   (/show0 "entering REPL")
   (loop
-   ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
-   (scrub-control-stack)
-   (sb!thread::get-foreground)
-   (unless noprint
-     (funcall *repl-prompt-fun* *standard-output*)
-     ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
-     ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
-     ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems
-     ;; odd. But maybe there *is* a valid reason in some
-     ;; circumstances? perhaps some deadlock issue when being driven
-     ;; by another process or something...)
-     (force-output *standard-output*))
-   (let* ((form (funcall *repl-read-form-fun*
-                        *standard-input*
-                        *standard-output*))
-         (results (multiple-value-list (interactive-eval form))))
-     (unless noprint
-       (dolist (result results)
-        (fresh-line)
-        (prin1 result))))))
+   (unwind-protect
+       (progn
+         ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
+         (scrub-control-stack)
+         (sb!thread::get-foreground)
+         (unless noprint
+           (funcall *repl-prompt-fun* *standard-output*)
+           ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
+           ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
+           ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems
+           ;; odd. But maybe there *is* a valid reason in some
+           ;; circumstances? perhaps some deadlock issue when being driven
+           ;; by another process or something...)
+           (force-output *standard-output*))
+         (let* ((form (funcall *repl-read-form-fun*
+                               *standard-input*
+                               *standard-output*))
+                (results (multiple-value-list (interactive-eval form))))
+           (unless noprint
+             (dolist (result results)
+               (fresh-line)
+               (prin1 result)))))
+     ;; If we started stepping in the debugger we want to stop now.
+     (setf *stepping* nil
+          *step* nil))))
 \f
 ;;; a convenient way to get into the assembly-level debugger
 (defun %halt ()