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