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