src/code/toplevel.lisp

   1 ;;;; stuff related to the toplevel read-eval-print loop, plus some
   2 ;;;; other miscellaneous functions that we don't have any better place
   3 ;;;; for
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!IMPL")
  15 \f
  16 ;;;; magic specials initialized by GENESIS
  17
  18 ;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
  19 ;;; of all static symbols in early-impl.lisp.
  20 (progn
  21   (defvar sb!vm::*current-catch-block*)
  22   (defvar sb!vm::*current-unwind-protect-block*)
  23   #!+hpux (defvar sb!vm::*c-lra*)
  24   (defvar *free-interrupt-context-index*))
  25 \f
  26 ;;; specials initialized by !COLD-INIT
  27
  28 ;;; FIXME: These could be converted to DEFVARs.
  29 (declaim (special #!+(or x86 x86-64) *pseudo-atomic-bits*
  30                   *allow-with-interrupts*
  31                   *interrupts-enabled*
  32                   *interrupt-pending*
  33                   #!+sb-thruption *thruption-pending*))
  34
  35 ;;;; default initfiles
  36
  37 (defun sysinit-pathname ()
  38   (or (let ((sbcl-homedir (sbcl-homedir-pathname)))
  39         (when sbcl-homedir
  40           (probe-file (merge-pathnames "sbclrc" sbcl-homedir))))
  41       #!+win32
  42       (merge-pathnames "sbcl\\sbclrc"
  43                        (sb!win32::get-folder-pathname
  44                         sb!win32::csidl_common_appdata))
  45       #!-win32
  46       "/etc/sbclrc"))
  47
  48 (defun userinit-pathname ()
  49   (merge-pathnames ".sbclrc" (user-homedir-pathname)))
  50
  51 (defvar *sysinit-pathname-function* #'sysinit-pathname
  52   "Designator for a function of zero arguments called to obtain a
  53 pathname designator for the default sysinit file, or NIL. If the
  54 function returns NIL, no sysinit file is used unless one has been
  55 specified on the command-line.")
  56
  57 (defvar *userinit-pathname-function* #'userinit-pathname
  58   "Designator for a function of zero arguments called to obtain a
  59 pathname designator or a stream for the default userinit file, or NIL.
  60 If the function returns NIL, no userinit file is used unless one has
  61 been specified on the command-line.")
  62
  63 \f
  64 ;;;; miscellaneous utilities for working with with TOPLEVEL
  65
  66 ;;; Execute BODY in a context where any %END-OF-THE-WORLD (thrown e.g.
  67 ;;; by QUIT) is caught and any final processing and return codes are
  68 ;;; handled appropriately.
  69 (defmacro handling-end-of-the-world (&body body)
  70   `(without-interrupts
  71      (catch '%end-of-the-world
  72        (unwind-protect
  73             (with-local-interrupts
  74               (unwind-protect
  75                    (progn ,@body)
  76                 (call-exit-hooks)))
  77          (%exit)))))
  78
  79 (defvar *exit-lock*)
  80 (defvar *exit-in-process* nil)
  81 (declaim (type (or null real) *exit-timeout*))
  82 (defvar *exit-timeout* 60
  83   "Default amount of seconds, if any, EXIT should wait for other
  84 threads to finish after terminating them. Default value is 60. NIL
  85 means to wait indefinitely.")
  86
  87 (defun os-exit-handler (condition)
  88   (declare (ignore condition))
  89   (os-exit *exit-in-process* :abort t))
  90
  91 (defvar *exit-error-handler* #'os-exit-handler)
  92
  93 (defun call-exit-hooks ()
  94   (unless *exit-in-process*
  95     (setf *exit-in-process* 0))
  96   (handler-bind ((serious-condition *exit-error-handler*))
  97     (call-hooks "exit" *exit-hooks* :on-error :warn)))
  98
  99 (defun %exit ()
 100   ;; If anything goes wrong, we will exit immediately and forcibly.
 101   (handler-bind ((serious-condition *exit-error-handler*))
 102     (let ((ok nil)
 103           (code *exit-in-process*))
 104       (if (consp code)
 105           ;; Another thread called EXIT, and passed the buck to us -- only
 106           ;; final call left to do.
 107           (os-exit (car code) :abort nil)
 108           (unwind-protect
 109                (progn
 110                  (flush-standard-output-streams)
 111                  (sb!thread::%exit-other-threads)
 112                  (setf ok t))
 113             (os-exit code :abort (not ok)))))))
 114 \f
 115 ;;;; miscellaneous external functions
 116
 117 (declaim (inline split-ratio-for-sleep))
 118 (defun split-ratio-for-sleep (seconds)
 119   (declare (ratio seconds)
 120            (muffle-conditions t))
 121   (multiple-value-bind (quot rem) (truncate (numerator seconds)
 122                                             (denominator seconds))
 123     (values quot
 124             (* rem
 125                #.(if (sb!xc:typep 1000000000 'fixnum)
 126                      '(truncate 1000000000 (denominator seconds))
 127                      ;; Can't truncate a bignum by a fixnum without consing
 128                      '(* 10 (truncate 100000000 (denominator seconds))))))))
 129
 130 (defun split-seconds-for-sleep (seconds)
 131   (declare (muffle-conditions t))
 132   ;; KLUDGE: This whole thing to avoid consing floats
 133   (flet ((split-float ()
 134            (let ((whole-seconds (truly-the fixnum (%unary-truncate seconds))))
 135              (values whole-seconds
 136                      (truly-the (integer 0 #.(expt 10 9))
 137                                 (%unary-truncate (* (- seconds (float whole-seconds seconds))
 138                                                     (load-time-value 1f9 t))))))))
 139     (declare (inline split-float))
 140     (typecase seconds
 141       ((single-float 0f0 #.(float sb!xc:most-positive-fixnum 1f0))
 142        (split-float))
 143       ((double-float 0d0 #.(float sb!xc:most-positive-fixnum 1d0))
 144        (split-float))
 145       (ratio
 146        (split-ratio-for-sleep seconds))
 147       (t
 148        (multiple-value-bind (sec frac)
 149            (truncate seconds)
 150          (values sec (truncate frac (load-time-value 1f-9 t))))))))
 151
 152 (defun sleep (seconds)
 153   "This function causes execution to be suspended for SECONDS. SECONDS may be
 154 any non-negative real number."
 155   (declare (explicit-check))
 156   (when (or (not (realp seconds))
 157             (minusp seconds))
 158     (error 'simple-type-error
 159            :format-control "Invalid argument to SLEEP: ~S, ~
 160                             should be a non-negative real."
 161            :format-arguments (list seconds)
 162            :datum seconds
 163            :expected-type '(real 0)))
 164   #!-(and win32 (not sb-thread))
 165   (typecase seconds
 166     #!-win32
 167     (double-float
 168      (sb!unix::nanosleep-double seconds))
 169     #!-win32
 170     (single-float
 171      (sb!unix::nanosleep-float seconds))
 172     (t
 173      (multiple-value-bind (sec nsec)
 174          (if (integerp seconds)
 175              (values seconds 0)
 176              #!-win32
 177              (split-ratio-for-sleep seconds)
 178              #!+win32
 179              (split-seconds-for-sleep seconds))
 180        ;; nanosleep() accepts time_t as the first argument, but on some platforms
 181        ;; it is restricted to 100 million seconds. Maybe someone can actually
 182        ;; have a reason to sleep for over 3 years?
 183        (loop while (> sec (expt 10 8))
 184              do (decf sec (expt 10 8))
 185                 (sb!unix:nanosleep (expt 10 8) 0))
 186        (sb!unix:nanosleep sec nsec))))
 187   #!+(and win32 (not sb-thread))
 188   (sb!win32:millisleep (truncate (* seconds 1000)))
 189   nil)
 190 \f
 191 ;;;; the default toplevel function
 192
 193 (defvar / nil
 194   "a list of all the values returned by the most recent top level EVAL")
 195 (defvar //  nil "the previous value of /")
 196 (defvar /// nil "the previous value of //")
 197 (defvar *   nil "the value of the most recent top level EVAL")
 198 (defvar **  nil "the previous value of *")
 199 (defvar *** nil "the previous value of **")
 200 (defvar +   nil "the value of the most recent top level READ")
 201 (defvar ++  nil "the previous value of +")
 202 (defvar +++ nil "the previous value of ++")
 203 (defvar -   nil "the form currently being evaluated")
 204
 205 (defun interactive-eval (form &key (eval #'eval))
 206   "Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
 207 +++, ++, +, ///, //, /, and -."
 208   (setf - form)
 209   (unwind-protect
 210        (let ((results (multiple-value-list (funcall eval form))))
 211          (setf /// //
 212                // /
 213                / results
 214                *** **
 215                ** *
 216                * (car results)))
 217     (setf +++ ++
 218           ++ +
 219           + -))
 220   (unless (boundp '*)
 221     ;; The bogon returned an unbound marker.
 222     ;; FIXME: It would be safer to check every one of the values in RESULTS,
 223     ;; instead of just the first one.
 224     (setf * nil)
 225     (cerror "Go on with * set to NIL."
 226             "EVAL returned an unbound marker."))
 227   (values-list /))
 228
 229 ;;; Flush anything waiting on one of the ANSI Common Lisp standard
 230 ;;; output streams before proceeding.
 231 (defun flush-standard-output-streams ()
 232   (let ((null (make-broadcast-stream)))
 233     (dolist (name '(*debug-io*
 234                     *error-output*
 235                     *query-io*
 236                     *standard-output*
 237                     *trace-output*
 238                     *terminal-io*))
 239       ;; 0. Pull out the underlying stream, so we know what it is.
 240       ;; 1. Handle errors on it. We're doing this on entry to
 241       ;;    debugger, so we don't want recursive errors here.
 242       ;; 2. Rebind the stream symbol in case some poor sod sees
 243       ;;    a broken stream here while running with *BREAK-ON-ERRORS*.
 244       (let ((stream (stream-output-stream (symbol-value name))))
 245         ;; This is kind of crummy because it checks in globaldb for each
 246         ;; stream symbol whether it can be bound to a stream. The translator
 247         ;; for PROGV could skip ABOUT-TO-MODIFY-SYMBOL-VALUE based on
 248         ;; an aspect of a policy, but if users figure that out they could
 249         ;; do something horrible like rebind T and NIL.
 250         (progv (list name) (list null)
 251           (handler-bind ((stream-error
 252                            (lambda (c)
 253                              (when (eq stream (stream-error-stream c))
 254                                (go :next)))))
 255             (force-output stream))))
 256       :next))
 257   (values))
 258
 259 (defun process-init-file (specified-pathname kind)
 260   (multiple-value-bind (context default-function)
 261       (ecase kind
 262         (:system
 263          (values "sysinit" *sysinit-pathname-function*))
 264         (:user
 265          (values "userinit" *userinit-pathname-function*)))
 266     (if specified-pathname
 267         (with-open-file (stream (parse-native-namestring specified-pathname)
 268                                 :if-does-not-exist nil)
 269           (if stream
 270               (load-as-source stream :context context)
 271               (cerror "Ignore missing init file"
 272                       "The specified ~A file ~A was not found."
 273                       context specified-pathname)))
 274         (let ((default (funcall default-function)))
 275           (when default
 276             (with-open-file (stream (pathname default) :if-does-not-exist nil)
 277               (when stream
 278                 (load-as-source stream :context context))))))))
 279
 280 (defun process-eval/load-options (options)
 281   (/show0 "handling --eval and --load options")
 282   (flet ((process-1 (cons)
 283            (destructuring-bind (opt . value) cons
 284              (ecase opt
 285                (:eval
 286                 (with-simple-restart (continue "Ignore runtime option --eval ~S."
 287                                                value)
 288                   (multiple-value-bind (expr pos) (read-from-string value)
 289                     (if (eq value (read-from-string value nil value :start pos))
 290                         (eval expr)
 291                         (error "Multiple expressions in --eval option: ~S"
 292                                value)))))
 293                (:load
 294                 (with-simple-restart (continue "Ignore runtime option --load ~S."
 295                                                value)
 296                   (load (native-pathname value))))
 297                (:quit
 298                 (exit))))
 299            (flush-standard-output-streams)))
 300     (with-simple-restart (abort "Skip rest of --eval and --load options.")
 301       (dolist (option options)
 302         (process-1 option)))))
 303
 304 (defun process-script (script)
 305   (flet ((load-script (stream)
 306            ;; Scripts don't need to be stylish or fast, but silence is usually a
 307            ;; desirable quality...
 308            (handler-bind (((or style-warning compiler-note) #'muffle-warning)
 309                           (stream-error (lambda (e)
 310                                           ;; Shell-style.
 311                                           (when (member (stream-error-stream e)
 312                                                         (list *stdout* *stdin* *stderr*))
 313                                             (exit)))))
 314              ;; Let's not use the *TTY* for scripts, ok? Also, normally we use
 315              ;; synonym streams, but in order to have the broken pipe/eof error
 316              ;; handling right we want to bind them for scripts.
 317              (let ((*terminal-io* (make-two-way-stream *stdin* *stdout*))
 318                    (*debug-io* (make-two-way-stream *stdin* *stderr*))
 319                    (*standard-input* *stdin*)
 320                    (*standard-output* *stdout*)
 321                    (*error-output* *stderr*))
 322                (load stream :verbose nil :print nil)))))
 323     (handling-end-of-the-world
 324       (if (eq t script)
 325           (load-script *stdin*)
 326           (with-open-file (f (native-pathname script) :element-type :default)
 327             (sb!fasl::maybe-skip-shebang-line f)
 328             (load-script f))))))
 329
 330 ;; Errors while processing the command line cause the system to EXIT,
 331 ;; instead of trying to go into the Lisp debugger, because trying to
 332 ;; go into the Lisp debugger would get into various annoying issues of
 333 ;; where we should go after the user tries to return from the
 334 ;; debugger.
 335 (defun startup-error (control-string &rest args)
 336   (format *error-output*
 337           "fatal error before reaching READ-EVAL-PRINT loop: ~%  ~?~%"
 338           control-string
 339           args)
 340   (exit :code 1))
 341
 342 ;;; the default system top level function
 343 (defun toplevel-init ()
 344   (/show0 "entering TOPLEVEL-INIT")
 345   (let ( ;; value of --sysinit option
 346         (sysinit nil)
 347         ;; t if --no-sysinit option given
 348         (no-sysinit nil)
 349         ;; value of --userinit option
 350         (userinit nil)
 351         ;; t if --no-userinit option given
 352         (no-userinit nil)
 353         ;; t if --disable-debugger option given
 354         (disable-debugger nil)
 355         ;; list of (<kind> . <string>) conses representing --eval and --load
 356         ;; options. options. --eval options are stored as strings, so that
 357         ;; they can be passed to READ only after their predecessors have been
 358         ;; EVALed, so that things work when e.g. REQUIRE in one EVAL form
 359         ;; creates a package referred to in the next EVAL form. Storing the
 360         ;; original string also makes for easier debugging.
 361         (reversed-options nil)
 362         ;; Has a --noprint option been seen?
 363         (noprint nil)
 364         ;; Has a --script option been seen?
 365         (script nil)
 366         ;; Quit after processing other options?
 367         (finally-quit nil)
 368         ;; everything in *POSIX-ARGV* except for argv[0]=programname
 369         (options (rest *posix-argv*)))
 370
 371     (declare (type list options))
 372
 373     (/show0 "done with outer LET in TOPLEVEL-INIT")
 374
 375     ;; FIXME: There are lots of ways for errors to happen around here
 376     ;; (e.g. bad command line syntax, or READ-ERROR while trying to
 377     ;; READ an --eval string). Make sure that they're handled
 378     ;; reasonably.
 379
 380     ;; Process command line options.
 381     (loop while options do
 382          (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
 383          (let ((option (first options)))
 384            (flet ((pop-option ()
 385                     (if options
 386                         (pop options)
 387                         (startup-error
 388                          "unexpected end of command line options"))))
 389              (cond ((string= option "--script")
 390                     (pop-option)
 391                     (setf disable-debugger t
 392                           no-userinit t
 393                           no-sysinit t
 394                           script (if options (pop-option) t))
 395                     (return))
 396                    ((string= option "--sysinit")
 397                     (pop-option)
 398                     (if sysinit
 399                         (startup-error "multiple --sysinit options")
 400                         (setf sysinit (pop-option))))
 401                    ((string= option "--no-sysinit")
 402                     (pop-option)
 403                     (setf no-sysinit t))
 404                    ((string= option "--userinit")
 405                     (pop-option)
 406                     (if userinit
 407                         (startup-error "multiple --userinit options")
 408                         (setf userinit (pop-option))))
 409                    ((string= option "--no-userinit")
 410                     (pop-option)
 411                     (setf no-userinit t))
 412                    ((string= option "--eval")
 413                     (pop-option)
 414                     (push (cons :eval (pop-option)) reversed-options))
 415                    ((string= option "--load")
 416                     (pop-option)
 417                     (push (cons :load (pop-option)) reversed-options))
 418                    ((string= option "--noprint")
 419                     (pop-option)
 420                     (setf noprint t))
 421                    ((string= option "--disable-debugger")
 422                     (pop-option)
 423                     (setf disable-debugger t))
 424                    ((string= option "--quit")
 425                     (pop-option)
 426                     (setf finally-quit t))
 427                    ((string= option "--non-interactive")
 428                     ;; This option is short for --quit and --disable-debugger,
 429                     ;; which are needed in combination for reliable non-
 430                     ;; interactive startup.
 431                     (pop-option)
 432                     (setf finally-quit t)
 433                     (setf disable-debugger t))
 434                    ((string= option "--end-toplevel-options")
 435                     (pop-option)
 436                     (return))
 437                    (t
 438                     ;; Anything we don't recognize as a toplevel
 439                     ;; option must be the start of user-level
 440                     ;; options.. except that if we encounter
 441                     ;; "--end-toplevel-options" after we gave up
 442                     ;; because we didn't recognize an option as a
 443                     ;; toplevel option, then the option we gave up on
 444                     ;; must have been an error. (E.g. in
 445                     ;;  "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options"
 446                     ;; this test will let us detect that the string
 447                     ;; "--eval(b)" is an error.)
 448                     (if (find "--end-toplevel-options" options
 449                               :test #'string=)
 450                         (startup-error "bad toplevel option: ~S"
 451                                        (first options))
 452                         (return)))))))
 453     (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
 454
 455     ;; Delete all the options that we processed, so that only
 456     ;; user-level options are left visible to user code.
 457     (when *posix-argv*
 458       (setf (rest *posix-argv*) options))
 459
 460     ;; Disable debugger before processing initialization files & co.
 461     (when disable-debugger
 462       (disable-debugger))
 463
 464     ;; Handle initialization files.
 465     (/show0 "handling initialization files in TOPLEVEL-INIT")
 466     ;; This CATCH is needed for the debugger command TOPLEVEL to
 467     ;; work.
 468     (catch 'toplevel-catcher
 469       ;; We wrap all the pre-REPL user/system customized startup
 470       ;; code in a restart.
 471       ;;
 472       ;; (Why not wrap everything, even the stuff above, in this
 473       ;; restart? Errors above here are basically command line
 474       ;; or Unix environment errors, e.g. a missing file or a
 475       ;; typo on the Unix command line, and you don't need to
 476       ;; get into Lisp to debug them, you should just start over
 477       ;; and do it right at the Unix level. Errors below here
 478       ;; are generally errors in user Lisp code, and it might be
 479       ;; helpful to let the user reach the REPL in order to help
 480       ;; figure out what's going on.)
 481       (restart-case
 482           (progn
 483             (unless no-sysinit
 484               (process-init-file sysinit :system))
 485             (unless no-userinit
 486               (process-init-file userinit :user))
 487             (when finally-quit
 488               (push (list :quit) reversed-options))
 489             (process-eval/load-options (nreverse reversed-options))
 490             (when script
 491               (process-script script)
 492               (bug "PROCESS-SCRIPT returned")))
 493         (abort ()
 494           :report (lambda (s)
 495                     (write-string
 496                      (if script
 497                          ;; In case script calls (enable-debugger)!
 498                          "Abort script, exiting lisp."
 499                          "Skip to toplevel READ/EVAL/PRINT loop.")
 500                      s))
 501           (/show0 "CONTINUEing from pre-REPL RESTART-CASE")
 502           (values))                     ; (no-op, just fall through)
 503         (exit ()
 504           :report "Exit SBCL (calling #'EXIT, killing the process)."
 505           :test (lambda (c) (declare (ignore c)) (not script))
 506           (/show0 "falling through to EXIT from pre-REPL RESTART-CASE")
 507           (exit :code 1))))
 508
 509     ;; one more time for good measure, in case we fell out of the
 510     ;; RESTART-CASE above before one of the flushes in the ordinary
 511     ;; flow of control had a chance to operate
 512     (flush-standard-output-streams)
 513
 514     (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
 515     (toplevel-repl noprint)
 516     ;; (classic CMU CL error message: "You're certainly a clever child.":-)
 517     (critically-unreachable "after TOPLEVEL-REPL")))
 518
 519 ;;; hooks to support customized toplevels like ACL-style toplevel from
 520 ;;; KMR on sbcl-devel 2002-12-21.  Altered by CSR 2003-11-16 for
 521 ;;; threaded operation: altered *REPL-FUN* to *REPL-FUN-GENERATOR*.
 522 (defvar *repl-read-form-fun* #'repl-read-form-fun
 523   "A function of two stream arguments IN and OUT for the toplevel REPL to
 524 call: Return the next Lisp form to evaluate (possibly handling other magic --
 525 like ACL-style keyword commands -- which precede the next Lisp form). The OUT
 526 stream is there to support magic which requires issuing new prompts.")
 527 (defvar *repl-prompt-fun* #'repl-prompt-fun
 528   "A function of one argument STREAM for the toplevel REPL to call: Prompt
 529 the user for input.")
 530 (defvar *repl-fun-generator* (constantly #'repl-fun)
 531   "A function of no arguments returning a function of one argument NOPRINT
 532 that provides the REPL for the system. Assumes that *STANDARD-INPUT* and
 533 *STANDARD-OUTPUT* are set up.")
 534
 535 ;;; read-eval-print loop for the default system toplevel
 536 (defun toplevel-repl (noprint)
 537   (/show0 "entering TOPLEVEL-REPL")
 538   (let ((* nil) (** nil) (*** nil)
 539         (- nil)
 540         (+ nil) (++ nil) (+++ nil)
 541         (/// nil) (// nil) (/ nil))
 542     (/show0 "about to funcall *REPL-FUN-GENERATOR*")
 543     (let ((repl-fun (funcall *repl-fun-generator*)))
 544       ;; Each REPL in a multithreaded world should have bindings of
 545       ;; most CL specials (most critically *PACKAGE*).
 546       (with-rebound-io-syntax
 547           (handler-bind ((step-condition 'invoke-stepper))
 548             (loop
 549                (/show0 "about to set up restarts in TOPLEVEL-REPL")
 550                ;; CLHS recommends that there should always be an
 551                ;; ABORT restart; we have this one here, and one per
 552                ;; debugger level.
 553                (with-simple-restart
 554                    (abort "~@<Exit debugger, returning to top level.~@:>")
 555                  (catch 'toplevel-catcher
 556                    ;; In the event of a control-stack-exhausted-error, we
 557                    ;; should have unwound enough stack by the time we get
 558                    ;; here that this is now possible.
 559                    #!-win32
 560                    (sb!kernel::reset-control-stack-guard-page)
 561                    (funcall repl-fun noprint)
 562                    (critically-unreachable "after REPL")))))))))
 563
 564 ;;; Our default REPL prompt is the minimal traditional one.
 565 (defun repl-prompt-fun (stream)
 566   (fresh-line stream)
 567   (write-string "* " stream)) ; arbitrary but customary REPL prompt
 568
 569 ;;; Our default form reader does relatively little magic, but does
 570 ;;; handle the Unix-style EOF-is-end-of-process convention.
 571 (defun repl-read-form-fun (in out)
 572   (declare (type stream in out) (ignore out))
 573   ;; KLUDGE: *READ-SUPPRESS* makes the REPL useless, and cannot be
 574   ;; recovered from -- flip it here.
 575   (when *read-suppress*
 576     (warn "Setting *READ-SUPPRESS* to NIL to restore toplevel usability.")
 577     (setf *read-suppress* nil))
 578   (let* ((eof-marker (cons nil nil))
 579          (form (read in nil eof-marker)))
 580     (if (eq form eof-marker)
 581         (exit)
 582         form)))
 583
 584 (defun repl-fun (noprint)
 585   (/show0 "entering REPL")
 586   (loop
 587    (unwind-protect
 588         (progn
 589           ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
 590           (scrub-control-stack)
 591           (sb!thread::get-foreground)
 592           (unless noprint
 593             (flush-standard-output-streams)
 594             (funcall *repl-prompt-fun* *standard-output*)
 595             ;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
 596             ;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
 597             ;; be done here, so leaving it up to *REPL-PROMPT-FUN* seems
 598             ;; odd. But maybe there *is* a valid reason in some
 599             ;; circumstances? perhaps some deadlock issue when being driven
 600             ;; by another process or something...)
 601             (force-output *standard-output*))
 602           (let* ((form (funcall *repl-read-form-fun*
 603                                 *standard-input*
 604                                 *standard-output*))
 605                  (results (multiple-value-list (interactive-eval form))))
 606             (unless noprint
 607               (dolist (result results)
 608                 (fresh-line)
 609                 (prin1 result)))))
 610      ;; If we started stepping in the debugger we want to stop now.
 611      (disable-stepping))))
 612 \f
 613 ;;; a convenient way to get into the assembly-level debugger
 614 (defun %halt ()
 615   (%primitive sb!c:halt))