1 ;;;; stuff related to the toplevel read-eval-print loop, plus some
2 ;;;; other miscellaneous functions that we don't have any better place
5 ;;;; This software is part of the SBCL system. See the README file for
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.
14 (in-package "SB!IMPL")
16 ;;;; magic specials initialized by GENESIS
18 ;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
19 ;;; of all static symbols in early-impl.lisp.
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*))
26 ;;; specials initialized by !COLD-INIT
28 ;;; FIXME: These could be converted to DEFVARs.
29 (declaim (special #!+(or x86 x86-64) *pseudo-atomic-bits*
30 *allow-with-interrupts*
33 #!+sb-thruption *thruption-pending*
34 *type-system-initialized*))
36 (defvar *cold-init-complete-p*)
38 ;;; counts of nested errors (with internal errors double-counted)
39 (defvar *maximum-error-depth*)
40 (defvar *current-error-depth*)
42 ;;;; default initfiles
44 (defun sysinit-pathname ()
45 (or (let ((sbcl-homedir (sbcl-homedir-pathname)))
47 (probe-file (merge-pathnames "sbclrc" sbcl-homedir))))
49 (merge-pathnames "sbcl\\sbclrc"
50 (sb!win32::get-folder-pathname
51 sb!win32::csidl_common_appdata))
55 (defun userinit-pathname ()
56 (merge-pathnames ".sbclrc" (user-homedir-pathname)))
58 (defvar *sysinit-pathname-function* #'sysinit-pathname
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.")
65 (defvar *userinit-pathname-function* #'userinit-pathname
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.")
73 ;;;; miscellaneous utilities for working with with TOPLEVEL
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)
80 (catch '%end-of-the-world
82 (with-local-interrupts
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.")
96 (defun os-exit-handler (condition)
97 (declare (ignore condition))
98 (os-exit *exit-in-process* :abort t))
100 (defvar *exit-error-handler* #'os-exit-handler)
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)))
109 ;; If anything goes wrong, we will exit immediately and forcibly.
110 (handler-bind ((serious-condition *exit-error-handler*))
112 (code *exit-in-process*))
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)
119 (flush-standard-output-streams)
120 (sb!thread::%exit-other-threads)
122 (os-exit code :abort (not ok)))))))
124 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
126 ;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out
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)
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*
157 "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
160 (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
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
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*
184 "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
188 (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally")
192 ;;;; miscellaneous external functions
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
201 (%unary-truncate (* (- seconds whole-seconds)
202 (load-time-value 1s9 t))))))))
203 (declare (inline split-float))
205 ((single-float 0s0 #.(float most-positive-fixnum 1s0))
207 ((double-float 0d0 #.(float most-positive-fixnum 1d0))
210 (multiple-value-bind (quot rem) (truncate (numerator seconds)
211 (denominator seconds))
213 (* rem (/ 1000000000 (denominator seconds))))))
215 (multiple-value-bind (sec frac)
217 (values sec (truncate frac (load-time-value 1s-9 t))))))))
219 (defun sleep (seconds)
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))
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)
230 :expected-type '(real 0)))
231 #!-(and win32 (not sb-thread))
232 (multiple-value-bind (sec nsec)
233 (if (integerp seconds)
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)))
247 ;;;; the default toplevel function
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")
262 (defun interactive-eval (form &key (eval #'eval))
264 "Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
265 +++, ++, +, ///, //, /, and -."
268 (let ((results (multiple-value-list (funcall eval form))))
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.
283 (cerror "Go on with * set to NIL."
284 "EVAL returned an unbound marker."))
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*
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
306 (when (eq stream (stream-error-stream c))
308 (force-output stream))))
312 (defun stream-output-stream (stream)
317 (stream-output-stream
318 (symbol-value (synonym-stream-symbol stream))))
320 (stream-output-stream
321 (two-way-stream-output-stream stream)))
325 (defun process-init-file (specified-pathname kind)
326 (multiple-value-bind (context default-function)
329 (values "sysinit" *sysinit-pathname-function*))
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)
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)))
342 (with-open-file (stream (pathname default) :if-does-not-exist nil)
344 (load-as-source stream :context context))))))))
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
352 (with-simple-restart (continue "Ignore runtime option --eval ~S."
354 (multiple-value-bind (expr pos) (read-from-string value)
355 (if (eq value (read-from-string value nil value :start pos))
357 (error "Multiple expressions in --eval option: ~S"
360 (with-simple-restart (continue "Ignore runtime option --load ~S."
362 (load (native-pathname value))))
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)))))
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)
377 (when (member (stream-error-stream e)
378 (list *stdout* *stdin* *stderr*))
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
391 (load-script *stdin*)
392 (with-open-file (f (native-pathname script) :element-type :default)
393 (sb!fasl::maybe-skip-shebang-line f)
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
401 (defun startup-error (control-string &rest args)
402 (format *error-output*
403 "fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%"
408 ;;; the default system top level function
409 (defun toplevel-init ()
410 (/show0 "entering TOPLEVEL-INIT")
411 (let ( ;; value of --sysinit option
413 ;; t if --no-sysinit option given
415 ;; value of --userinit option
417 ;; t if --no-userinit option given
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?
430 ;; Has a --script option been seen?
432 ;; Quit after processing other options?
434 ;; everything in *POSIX-ARGV* except for argv[0]=programname
435 (options (rest *posix-argv*)))
437 (declare (type list options))
439 (/show0 "done with outer LET in TOPLEVEL-INIT")
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
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 ()
454 "unexpected end of command line options"))))
455 (cond ((string= option "--script")
457 (setf disable-debugger t
460 script (if options (pop-option) t))
462 ((string= option "--sysinit")
465 (startup-error "multiple --sysinit options")
466 (setf sysinit (pop-option))))
467 ((string= option "--no-sysinit")
470 ((string= option "--userinit")
473 (startup-error "multiple --userinit options")
474 (setf userinit (pop-option))))
475 ((string= option "--no-userinit")
477 (setf no-userinit t))
478 ((string= option "--eval")
480 (push (cons :eval (pop-option)) reversed-options))
481 ((string= option "--load")
483 (push (cons :load (pop-option)) reversed-options))
484 ((string= option "--noprint")
487 ((string= option "--disable-debugger")
489 (setf disable-debugger t))
490 ((string= option "--quit")
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.
498 (setf finally-quit t)
499 (setf disable-debugger t))
500 ((string= option "--end-toplevel-options")
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
516 (startup-error "bad toplevel option: ~S"
519 (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
521 ;; Delete all the options that we processed, so that only
522 ;; user-level options are left visible to user code.
524 (setf (rest *posix-argv*) options))
526 ;; Disable debugger before processing initialization files & co.
527 (when disable-debugger
528 (sb!ext:disable-debugger))
530 ;; Handle initialization files.
531 (/show0 "handling initialization files in TOPLEVEL-INIT")
532 ;; This CATCH is needed for the debugger command TOPLEVEL to
534 (catch 'toplevel-catcher
535 ;; We wrap all the pre-REPL user/system customized startup
536 ;; code in a restart.
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.)
550 (process-init-file sysinit :system))
552 (process-init-file userinit :user))
554 (push (list :quit) reversed-options))
555 (process-eval/load-options (nreverse reversed-options))
557 (process-script script)
558 (bug "PROCESS-SCRIPT returned")))
563 ;; In case script calls (enable-debugger)!
564 "Abort script, exiting lisp."
565 "Skip to toplevel READ/EVAL/PRINT loop.")
567 (/show0 "CONTINUEing from pre-REPL RESTART-CASE")
568 (values)) ; (no-op, just fall through)
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")
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)
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")))
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
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
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)
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.")
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)
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))
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
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.
629 (sb!kernel::reset-control-stack-guard-page)
630 (funcall repl-fun noprint)
631 (critically-unreachable "after REPL")))))))))
633 ;;; Our default REPL prompt is the minimal traditional one.
634 (defun repl-prompt-fun (stream)
636 (write-string "* " stream)) ; arbitrary but customary REPL prompt
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)
653 (defun repl-fun (noprint)
654 (/show0 "entering REPL")
658 ;; (See comment preceding the definition of SCRUB-CONTROL-STACK.)
659 (scrub-control-stack)
660 (sb!thread::get-foreground)
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*
674 (results (multiple-value-list (interactive-eval form))))
676 (dolist (result results)
679 ;; If we started stepping in the debugger we want to stop now.
680 (disable-stepping))))
682 ;;; a convenient way to get into the assembly-level debugger
684 (%primitive sb!c:halt))