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