(progn
(defvar sb!vm::*current-catch-block*)
(defvar sb!vm::*current-unwind-protect-block*)
+ #!+hpux (defvar sb!vm::*c-lra*)
(defvar *free-interrupt-context-index*))
\f
;;; specials initialized by !COLD-INIT
*allow-with-interrupts*
*interrupts-enabled*
*interrupt-pending*
+ #!+sb-thruption *thruption-pending*
*type-system-initialized*))
(defvar *cold-init-complete-p*)
(defvar *sysinit-pathname-function* #'sysinit-pathname
#!+sb-doc
- "Designator for a function of zero arguments called to obtain a pathname
-designator for the default sysinit file, or NIL. If the function returns NIL,
-no sysinit file is used unless one has been specified on the command-line.")
+ "Designator for a function of zero arguments called to obtain a
+pathname designator for the default sysinit file, or NIL. If the
+function returns NIL, no sysinit file is used unless one has been
+specified on the command-line.")
(defvar *userinit-pathname-function* #'userinit-pathname
#!+sb-doc
- "Designator for a function of zero arguments called to obtain a pathname
-designator or a stream for the default userinit file, or NIL. If the function
-returns NIL, no userinit file is used unless one has been specified on the
-command-line.")
+ "Designator for a function of zero arguments called to obtain a
+pathname designator or a stream for the default userinit file, or NIL.
+If the function returns NIL, no userinit file is used unless one has
+been specified on the command-line.")
\f
;;;; miscellaneous utilities for working with with TOPLEVEL
;;; by QUIT) is caught and any final processing and return codes are
;;; handled appropriately.
(defmacro handling-end-of-the-world (&body body)
- (with-unique-names (caught)
- `(let ((,caught (catch '%end-of-the-world
- (/show0 "inside CATCH '%END-OF-THE-WORLD")
- ,@body)))
- (/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output")
- (flush-standard-output-streams)
- (sb!thread::terminate-session)
- (/show0 "calling UNIX-EXIT")
- (sb!unix:unix-exit ,caught))))
+ `(without-interrupts
+ (catch '%end-of-the-world
+ (unwind-protect
+ (with-local-interrupts
+ (unwind-protect
+ (progn ,@body)
+ (call-exit-hooks)))
+ (%exit)))))
+
+(defvar *exit-lock*)
+(defvar *exit-in-process* nil)
+(declaim (type (or null real) *exit-timeout*))
+(defvar *exit-timeout* 60
+ "Default amount of seconds, if any, EXIT should wait for other
+threads to finish after terminating them. Default value is 60. NIL
+means to wait indefinitely.")
+
+(defun os-exit-handler (condition)
+ (declare (ignore condition))
+ (os-exit *exit-in-process* :abort t))
+
+(defvar *exit-error-handler* #'os-exit-handler)
+
+(defun call-exit-hooks ()
+ (unless *exit-in-process*
+ (setf *exit-in-process* 0))
+ (handler-bind ((serious-condition *exit-error-handler*))
+ (call-hooks "exit" *exit-hooks* :on-error :warn)))
+
+(defun %exit ()
+ ;; If anything goes wrong, we will exit immediately and forcibly.
+ (handler-bind ((serious-condition *exit-error-handler*))
+ (let ((ok nil)
+ (code *exit-in-process*))
+ (if (consp code)
+ ;; Another thread called EXIT, and passed the buck to us -- only
+ ;; final call left to do.
+ (os-exit (car code) :abort nil)
+ (unwind-protect
+ (progn
+ (flush-standard-output-streams)
+ (sb!thread::%exit-other-threads)
+ (setf ok t))
+ (os-exit code :abort (not ok)))))))
\f
;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
(let ((*current-error-depth* (1+ *current-error-depth*)))
(/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
;; arbitrary truncation
- #!+sb-show (sb!debug:backtrace 8)
+ #!+sb-show (sb!debug:print-backtrace :count 8)
,@forms)))
;;; a helper function for INFINITE-ERROR-PROTECT
(t
(/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
nil)))
-
-;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at
-;;; one point (shown below), and SBCL cross-compiled it without
-;;; warning about FORMS being undefined. Check whether that problem
-;;; (missing warning) is repeatable in the final system and if so, fix
-;;; it.
-#|
-(defun infinite-error-protector ()
- `(cond ((not *cold-init-complete-p*)
- (%primitive print "Argh! error in cold init, halting")
- (%primitive sb!c:halt))
- ((or (not (boundp '*current-error-depth*))
- (not (realp *current-error-depth*))
- (not (boundp '*maximum-error-depth*))
- (not (realp *maximum-error-depth*)))
- (%primitive print "Argh! corrupted error depth, halting")
- (%primitive sb!c:halt))
- ((> *current-error-depth* *maximum-error-depth*)
- (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
- (error-error "Help! "
- *current-error-depth*
- " nested errors. "
- "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
- (progn ,@forms)
- t)
- (t
- (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally")
- nil)))
-|#
\f
;;;; miscellaneous external functions
-(defun sleep (n)
+(defun split-seconds-for-sleep (seconds)
+ (declare (optimize speed))
+ (flet ((split-float ()
+ ;; KLUDGE: This whole thing to avoid consing floats
+ (let ((whole-seconds (truly-the fixnum (%unary-truncate seconds))))
+ (values whole-seconds
+ (truly-the fixnum
+ (%unary-truncate (* (- seconds whole-seconds)
+ (load-time-value 1s9 t))))))))
+ (declare (inline split-float))
+ (typecase seconds
+ ((single-float 0s0 #.(float most-positive-fixnum 1s0))
+ (split-float))
+ ((double-float 0d0 #.(float most-positive-fixnum 1d0))
+ (split-float))
+ (ratio
+ (multiple-value-bind (quot rem) (truncate (numerator seconds)
+ (denominator seconds))
+ (values quot
+ (* rem (/ 1000000000 (denominator seconds))))))
+ (t
+ (multiple-value-bind (sec frac)
+ (truncate seconds)
+ (values sec (truncate frac (load-time-value 1s-9 t))))))))
+
+(defun sleep (seconds)
#!+sb-doc
- "This function causes execution to be suspended for N seconds. N may
- be any non-negative, non-complex number."
- (when (or (not (realp n))
- (minusp n))
+ "This function causes execution to be suspended for SECONDS. SECONDS may be
+any non-negative real number."
+ (when (or (not (realp seconds))
+ (minusp seconds))
(error 'simple-type-error
- :format-control "invalid argument to SLEEP: ~S"
- :format-arguments (list n)
- :datum n
+ :format-control "Invalid argument to SLEEP: ~S, ~
+ should be a non-negative real."
+ :format-arguments (list seconds)
+ :datum seconds
:expected-type '(real 0)))
- #!-win32
+ #!-(and win32 (not sb-thread))
(multiple-value-bind (sec nsec)
- (if (integerp n)
- (values n 0)
- (multiple-value-bind (sec frac)
- (truncate n)
- (values sec (truncate frac 1e-9))))
+ (if (integerp seconds)
+ (values seconds 0)
+ (split-seconds-for-sleep seconds))
+ ;; nanosleep() accepts time_t as the first argument, but on some platforms
+ ;; it is restricted to 100 million seconds. Maybe someone can actually
+ ;; have a reason to sleep for over 3 years?
+ (loop while (> sec (expt 10 8))
+ do (decf sec (expt 10 8))
+ (sb!unix:nanosleep (expt 10 8) 0))
(sb!unix:nanosleep sec nsec))
- #!+win32
- (sb!win32:millisleep (truncate (* n 1000)))
+ #!+(and win32 (not sb-thread))
+ (sb!win32:millisleep (truncate (* seconds 1000)))
nil)
\f
-;;;; SCRUB-CONTROL-STACK
-
-(defconstant bytes-per-scrub-unit 2048)
-
-;;; Zero the unused portion of the control stack so that old objects
-;;; are not kept alive because of uninitialized stack variables.
-
-;;; "To summarize the problem, since not all allocated stack frame
-;;; slots are guaranteed to be written by the time you call an another
-;;; function or GC, there may be garbage pointers retained in your
-;;; dead stack locations. The stack scrubbing only affects the part
-;;; of the stack from the SP to the end of the allocated stack."
-;;; - ram, on cmucl-imp, Tue, 25 Sep 2001
-
-;;; So, as an (admittedly lame) workaround, from time to time we call
-;;; scrub-control-stack to zero out all the unused portion. This is
-;;; supposed to happen when the stack is mostly empty, so that we have
-;;; a chance of clearing more of it: callers are currently (2002.07.18)
-;;; REPL and SUB-GC
-
-(defun scrub-control-stack ()
- (declare (optimize (speed 3) (safety 0))
- (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
-
- #!-stack-grows-downward-not-upward
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (initial-offset (logand csp (1- bytes-per-scrub-unit)))
- (end-of-stack
- (- (sap-int (sb!di::descriptor-sap sb!vm:*control-stack-end*))
- sb!c:*backend-page-size*)))
- (labels
- ((scrub (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (cond ((>= (sap-int ptr) end-of-stack) 0)
- ((= offset bytes-per-scrub-unit)
- (look (sap+ ptr bytes-per-scrub-unit) 0 count))
- (t
- (setf (sap-ref-word ptr offset) 0)
- (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
- (look (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (cond ((>= (sap-int ptr) end-of-stack) 0)
- ((= offset bytes-per-scrub-unit)
- count)
- ((zerop (sap-ref-word ptr offset))
- (look ptr (+ offset sb!vm:n-word-bytes) count))
- (t
- (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
- (declare (type sb!vm::word csp))
- (scrub (int-sap (- csp initial-offset))
- (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
- 0)))
-
- #!+stack-grows-downward-not-upward
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (end-of-stack (+ (sap-int (sb!di::descriptor-sap sb!vm:*control-stack-start*))
- sb!c:*backend-page-size*))
- (initial-offset (logand csp (1- bytes-per-scrub-unit))))
- (labels
- ((scrub (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:n-word-bytes)))))
- (cond ((< (sap-int loc) end-of-stack) 0)
- ((= offset bytes-per-scrub-unit)
- (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
- 0 count))
- (t ;; need to fix bug in %SET-STACK-REF
- (setf (sap-ref-word loc 0) 0)
- (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
- (look (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (let ((loc (int-sap (- (sap-int ptr) offset))))
- (cond ((< (sap-int loc) end-of-stack) 0)
- ((= offset bytes-per-scrub-unit)
- count)
- ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
- (look ptr (+ offset sb!vm:n-word-bytes) count))
- (t
- (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
- (declare (type sb!vm::word csp))
- (scrub (int-sap (+ csp initial-offset))
- (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
- 0))))
-\f
;;;; the default toplevel function
(defvar / nil
(defvar +++ nil #!+sb-doc "the previous value of ++")
(defvar - nil #!+sb-doc "the form currently being evaluated")
-(defun interactive-eval (form)
+(defun interactive-eval (form &key (eval #'eval))
#!+sb-doc
"Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
+++, ++, +, ///, //, /, and -."
(setf - form)
(unwind-protect
- (let ((results (multiple-value-list (eval form))))
+ (let ((results (multiple-value-list (funcall eval form))))
(setf /// //
// /
/ results
;;; Flush anything waiting on one of the ANSI Common Lisp standard
;;; output streams before proceeding.
(defun flush-standard-output-streams ()
- (dolist (name '(*debug-io*
- *error-output*
- *query-io*
- *standard-output*
- *trace-output*
- *terminal-io*))
- ;; FINISH-OUTPUT may block more easily than FORCE-OUTPUT
- (force-output (symbol-value name)))
+ (let ((null (make-broadcast-stream)))
+ (dolist (name '(*debug-io*
+ *error-output*
+ *query-io*
+ *standard-output*
+ *trace-output*
+ *terminal-io*))
+ ;; 0. Pull out the underlying stream, so we know what it is.
+ ;; 1. Handle errors on it. We're doing this on entry to
+ ;; debugger, so we don't want recursive errors here.
+ ;; 2. Rebind the stream symbol in case some poor sod sees
+ ;; a broken stream here while running with *BREAK-ON-ERRORS*.
+ (let ((stream (stream-output-stream (symbol-value name))))
+ (progv (list name) (list null)
+ (handler-bind ((stream-error
+ (lambda (c)
+ (when (eq stream (stream-error-stream c))
+ (go :next)))))
+ (force-output stream))))
+ :next))
(values))
-(defun process-init-file (specified-pathname default-function)
- (restart-case
- (let ((cookie (list)))
- (flet ((process-stream (stream &optional pathname)
- (loop
- (restart-case
- (handler-bind
- ((error (lambda (e)
- (error "Error during processing of ~
- initialization file ~A:~%~% ~A"
- (or pathname stream) e))))
- (let ((form (read stream nil cookie)))
- (if (eq cookie form)
- (return-from process-init-file nil)
- (eval form))))
- (continue ()
- :report "Ignore and continue processing.")))))
- (if specified-pathname
- (with-open-file (stream (parse-native-namestring specified-pathname)
- :if-does-not-exist nil)
- (if stream
- (process-stream stream (pathname stream))
- (error "The specified init file ~S was not found."
- specified-pathname)))
- (let ((default (funcall default-function)))
- (when default
- (with-open-file (stream (pathname default) :if-does-not-exist nil)
- (when stream
- (process-stream stream (pathname stream)))))))))
- (abort ()
- :report "Skip this initialization file.")))
-
-(defun process-eval-options (eval-strings-or-forms)
- (/show0 "handling --eval options")
- (flet ((process-1 (string-or-form)
- (etypecase string-or-form
- (string
- (multiple-value-bind (expr pos) (read-from-string string-or-form)
- (unless (eq string-or-form
- (read-from-string string-or-form nil string-or-form
- :start pos))
- (error "More than one expression in ~S" string-or-form))
- (eval expr)
- (flush-standard-output-streams)))
- (cons (eval string-or-form) (flush-standard-output-streams)))))
- (restart-case
- (dolist (expr-as-string-or-form eval-strings-or-forms)
- (/show0 "handling one --eval option")
- (restart-case
- (handler-bind
- ((error (lambda (e)
- (error "Error during processing of --eval ~
- option ~S:~%~% ~A"
- expr-as-string-or-form e))))
- (process-1 expr-as-string-or-form))
- (continue ()
- :report "Ignore and continue with next --eval option.")))
- (abort ()
- :report "Skip rest of --eval options."))))
-
-;; Errors while processing the command line cause the system to QUIT,
+(defun stream-output-stream (stream)
+ (typecase stream
+ (fd-stream
+ stream)
+ (synonym-stream
+ (stream-output-stream
+ (symbol-value (synonym-stream-symbol stream))))
+ (two-way-stream
+ (stream-output-stream
+ (two-way-stream-output-stream stream)))
+ (t
+ stream)))
+
+(defun process-init-file (specified-pathname kind)
+ (multiple-value-bind (context default-function)
+ (ecase kind
+ (:system
+ (values "sysinit" *sysinit-pathname-function*))
+ (:user
+ (values "userinit" *userinit-pathname-function*)))
+ (if specified-pathname
+ (with-open-file (stream (parse-native-namestring specified-pathname)
+ :if-does-not-exist nil)
+ (if stream
+ (load-as-source stream :context context)
+ (cerror "Ignore missing init file"
+ "The specified ~A file ~A was not found."
+ context specified-pathname)))
+ (let ((default (funcall default-function)))
+ (when default
+ (with-open-file (stream (pathname default) :if-does-not-exist nil)
+ (when stream
+ (load-as-source stream :context context))))))))
+
+(defun process-eval/load-options (options)
+ (/show0 "handling --eval and --load options")
+ (flet ((process-1 (cons)
+ (destructuring-bind (opt . value) cons
+ (ecase opt
+ (:eval
+ (with-simple-restart (continue "Ignore runtime option --eval ~S."
+ value)
+ (multiple-value-bind (expr pos) (read-from-string value)
+ (if (eq value (read-from-string value nil value :start pos))
+ (eval expr)
+ (error "Multiple expressions in --eval option: ~S"
+ value)))))
+ (:load
+ (with-simple-restart (continue "Ignore runtime option --load ~S."
+ value)
+ (load (native-pathname value))))
+ (:quit
+ (exit))))
+ (flush-standard-output-streams)))
+ (with-simple-restart (abort "Skip rest of --eval and --load options.")
+ (dolist (option options)
+ (process-1 option)))))
+
+(defun process-script (script)
+ (flet ((load-script (stream)
+ ;; Scripts don't need to be stylish or fast, but silence is usually a
+ ;; desirable quality...
+ (handler-bind (((or style-warning compiler-note) #'muffle-warning)
+ (stream-error (lambda (e)
+ ;; Shell-style.
+ (when (member (stream-error-stream e)
+ (list *stdout* *stdin* *stderr*))
+ (exit)))))
+ ;; Let's not use the *TTY* for scripts, ok? Also, normally we use
+ ;; synonym streams, but in order to have the broken pipe/eof error
+ ;; handling right we want to bind them for scripts.
+ (let ((*terminal-io* (make-two-way-stream *stdin* *stdout*))
+ (*debug-io* (make-two-way-stream *stdin* *stderr*))
+ (*standard-input* *stdin*)
+ (*standard-output* *stdout*)
+ (*error-output* *stderr*))
+ (load stream :verbose nil :print nil)))))
+ (handling-end-of-the-world
+ (if (eq t script)
+ (load-script *stdin*)
+ (with-open-file (f (native-pathname script) :element-type :default)
+ (sb!fasl::maybe-skip-shebang-line f)
+ (load-script f))))))
+
+;; Errors while processing the command line cause the system to EXIT,
;; instead of trying to go into the Lisp debugger, because trying to
;; go into the Lisp debugger would get into various annoying issues of
;; where we should go after the user tries to return from the
"fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%"
control-string
args)
- (quit :unix-status 1))
+ (exit :code 1))
;;; the default system top level function
(defun toplevel-init ()
(userinit nil)
;; t if --no-userinit option given
(no-userinit nil)
- ;; values of --eval options, in reverse order; and also any
- ;; other options (like --load) which're translated into --eval
- ;;
- ;; The values are stored as strings, so that they can be
- ;; passed to READ only after their predecessors have been
- ;; EVALed, so that things work when e.g. REQUIRE in one EVAL
- ;; form creates a package referred to in the next EVAL form,
- ;; except for forms transformed from syntactically-sugary
- ;; switches like --load and --disable-debugger.
- (reversed-evals nil)
+ ;; t if --disable-debugger option given
+ (disable-debugger nil)
+ ;; list of (<kind> . <string>) conses representing --eval and --load
+ ;; options. options. --eval options are stored as strings, so that
+ ;; they can be passed to READ only after their predecessors have been
+ ;; EVALed, so that things work when e.g. REQUIRE in one EVAL form
+ ;; creates a package referred to in the next EVAL form. Storing the
+ ;; original string also makes for easier debugging.
+ (reversed-options nil)
;; Has a --noprint option been seen?
(noprint nil)
+ ;; Has a --script option been seen?
+ (script nil)
+ ;; Quit after processing other options?
+ (finally-quit nil)
;; everything in *POSIX-ARGV* except for argv[0]=programname
(options (rest *posix-argv*)))
(pop options)
(startup-error
"unexpected end of command line options"))))
- (cond ((string= option "--sysinit")
+ (cond ((string= option "--script")
+ (pop-option)
+ (setf disable-debugger t
+ no-userinit t
+ no-sysinit t
+ script (if options (pop-option) t))
+ (return))
+ ((string= option "--sysinit")
(pop-option)
(if sysinit
(startup-error "multiple --sysinit options")
(setf no-userinit t))
((string= option "--eval")
(pop-option)
- (push (pop-option) reversed-evals))
+ (push (cons :eval (pop-option)) reversed-options))
((string= option "--load")
(pop-option)
- (push
- (list 'cl:load (native-pathname (pop-option)))
- reversed-evals))
+ (push (cons :load (pop-option)) reversed-options))
((string= option "--noprint")
(pop-option)
(setf noprint t))
((string= option "--disable-debugger")
(pop-option)
- (push (list 'sb!ext:disable-debugger) reversed-evals))
+ (setf disable-debugger t))
+ ((string= option "--quit")
+ (pop-option)
+ (setf finally-quit t))
+ ((string= option "--non-interactive")
+ ;; This option is short for --quit and --disable-debugger,
+ ;; which are needed in combination for reliable non-
+ ;; interactive startup.
+ (pop-option)
+ (setf finally-quit t)
+ (setf disable-debugger t))
((string= option "--end-toplevel-options")
(pop-option)
(return))
;; Delete all the options that we processed, so that only
;; user-level options are left visible to user code.
- (setf (rest *posix-argv*) options)
+ (when *posix-argv*
+ (setf (rest *posix-argv*) options))
+
+ ;; Disable debugger before processing initialization files & co.
+ (when disable-debugger
+ (sb!ext:disable-debugger))
;; Handle initialization files.
(/show0 "handling initialization files in TOPLEVEL-INIT")
(restart-case
(progn
(unless no-sysinit
- (process-init-file sysinit *sysinit-pathname-function*))
+ (process-init-file sysinit :system))
(unless no-userinit
- (process-init-file userinit *userinit-pathname-function*))
- (process-eval-options (nreverse reversed-evals)))
+ (process-init-file userinit :user))
+ (when finally-quit
+ (push (list :quit) reversed-options))
+ (process-eval/load-options (nreverse reversed-options))
+ (when script
+ (process-script script)
+ (bug "PROCESS-SCRIPT returned")))
(abort ()
- :report "Skip to toplevel READ/EVAL/PRINT loop."
+ :report (lambda (s)
+ (write-string
+ (if script
+ ;; In case script calls (enable-debugger)!
+ "Abort script, exiting lisp."
+ "Skip to toplevel READ/EVAL/PRINT loop.")
+ s))
(/show0 "CONTINUEing from pre-REPL RESTART-CASE")
(values)) ; (no-op, just fall through)
- (quit ()
- :report "Quit SBCL (calling #'QUIT, killing the process)."
- (/show0 "falling through to QUIT from pre-REPL RESTART-CASE")
- (quit :unix-status 1))))
+ (exit ()
+ :report "Exit SBCL (calling #'EXIT, killing the process)."
+ :test (lambda (c) (declare (ignore c)) (not script))
+ (/show0 "falling through to EXIT from pre-REPL RESTART-CASE")
+ (exit :code 1))))
;; one more time for good measure, in case we fell out of the
;; RESTART-CASE above before one of the flushes in the ordinary
(with-simple-restart
(abort "~@<Exit debugger, returning to top level.~@:>")
(catch 'toplevel-catcher
- #!-win32 (sb!unix::reset-signal-mask)
;; In the event of a control-stack-exhausted-error, we
;; should have unwound enough stack by the time we get
;; here that this is now possible.
#!-win32
- (sb!kernel::protect-control-stack-guard-page 1)
+ (sb!kernel::reset-control-stack-guard-page)
(funcall repl-fun noprint)
(critically-unreachable "after REPL")))))))))
;;; handle the Unix-style EOF-is-end-of-process convention.
(defun repl-read-form-fun (in out)
(declare (type stream in out) (ignore out))
+ ;; KLUDGE: *READ-SUPPRESS* makes the REPL useless, and cannot be
+ ;; recovered from -- flip it here.
+ (when *read-suppress*
+ (warn "Setting *READ-SUPPRESS* to NIL to restore toplevel usability.")
+ (setf *read-suppress* nil))
(let* ((eof-marker (cons nil nil))
(form (read in nil eof-marker)))
(if (eq form eof-marker)
- (quit)
+ (exit)
form)))
(defun repl-fun (noprint)
projects / sbcl.git / blobdiff