;;; specials initialized by !COLD-INIT
;;; FIXME: These could be converted to DEFVARs.
-(declaim (special *gc-inhibit* *need-to-collect-garbage*
- *after-gc-hooks*
- #!+(or x86 x86-64) *pseudo-atomic-atomic*
- #!+(or x86 x86-64) *pseudo-atomic-interrupted*
- sb!unix::*interrupts-enabled*
- sb!unix::*interrupt-pending*
+(declaim (special #!+(or x86 x86-64) *pseudo-atomic-bits*
+ *allow-with-interrupts*
+ *interrupts-enabled*
+ *interrupt-pending*
*type-system-initialized*))
(defvar *cold-init-complete-p*)
(defvar *maximum-error-depth*)
(defvar *current-error-depth*)
-;;;; stepping control
-(defvar *step*)
-(defvar *stepping*)
-(defvar *step-form-stack* nil
- "A place for single steppers to push information about
-STEP-FORM-CONDITIONS avaiting the corresponding
-STEP-VALUES-CONDITIONS. The system is guaranteed to empty the stack
-when stepping terminates, so that it remains in sync, but doesn't
-modify it in any other way: it is provided for implmentors of single
-steppers to maintain contextual information.")
+;;;; default initfiles
+
+(defun sysinit-pathname ()
+ (or (let ((sbcl-homedir (sbcl-homedir-pathname)))
+ (when sbcl-homedir
+ (probe-file (merge-pathnames "sbclrc" sbcl-homedir))))
+ #!+win32
+ (merge-pathnames "sbcl\\sbclrc"
+ (sb!win32::get-folder-pathname
+ sb!win32::csidl_common_appdata))
+ #!-win32
+ "/etc/sbclrc"))
+
+(defun userinit-pathname ()
+ (merge-pathnames ".sbclrc" (user-homedir-pathname)))
+
+(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.")
+
+(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.")
+
\f
;;;; miscellaneous utilities for working with with TOPLEVEL
:format-arguments (list n)
:datum n
:expected-type '(real 0)))
+ #!-win32
(multiple-value-bind (sec nsec)
(if (integerp n)
(values n 0)
(truncate n)
(values sec (truncate frac 1e-9))))
(sb!unix:nanosleep sec nsec))
+ #!+win32
+ (sb!win32:millisleep (truncate (* n 1000)))
nil)
\f
;;;; SCRUB-CONTROL-STACK
(let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
(initial-offset (logand csp (1- bytes-per-scrub-unit)))
(end-of-stack
- (- (sb!vm:fixnumize sb!vm:*control-stack-end*)
+ (- (sap-int (sb!di::descriptor-sap sb!vm:*control-stack-end*))
sb!c:*backend-page-size*)))
(labels
((scrub (ptr offset count)
#!+stack-grows-downward-not-upward
(let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (end-of-stack (+ (sb!vm:fixnumize sb!vm:*control-stack-start*)
+ (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
(defvar - nil #!+sb-doc "the form currently being evaluated")
(defun interactive-eval (form)
+ #!+sb-doc
"Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
- +++, ++, +, ///, //, /, and -."
++++, ++, +, ///, //, /, and -."
(setf - form)
(unwind-protect
(let ((results (multiple-value-list (eval form))))
*error-output*
*query-io*
*standard-output*
- *trace-output*))
- (finish-output (symbol-value name)))
+ *trace-output*
+ *terminal-io*))
+ ;; FINISH-OUTPUT may block more easily than FORCE-OUTPUT
+ (force-output (symbol-value name)))
(values))
-(defun process-init-file (truename)
- (when truename
- (restart-case
- (with-open-file (s truename :if-does-not-exist nil)
- (flet ((next ()
- (let ((form (read s nil s)))
- (if (eq s form)
- (return-from process-init-file nil)
- (eval form)))))
- (loop
- (restart-case
- (handler-bind ((error (lambda (e)
- (error
- "Error during processing of ~
- initialization file ~A:~%~% ~A"
- truename e))))
- (next))
- (continue ()
- :report "Ignore and continue processing.")))))
- (abort ()
- :report "Skip rest of initialization file."))))
-
-(defun process-eval-options (eval-strings)
+(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)
- (multiple-value-bind (expr pos) (read-from-string string)
- (unless (eq string (read-from-string string nil string :start pos))
- (error "More the one expression in ~S" string))
- (eval expr)
- (flush-standard-output-streams))))
+ (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 eval-strings)
+ (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 e))))
- (process-1 expr-as-string))
+ (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,
+;; 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
+;; debugger.
+(defun startup-error (control-string &rest args)
+ (format *error-output*
+ "fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%"
+ control-string
+ args)
+ (quit :unix-status 1))
+
;;; the default system top level function
(defun toplevel-init ()
(/show0 "entering TOPLEVEL-INIT")
- (let (;; value of --sysinit option
+ (let ( ;; value of --sysinit option
(sysinit nil)
+ ;; t if --no-sysinit option given
+ (no-sysinit nil)
;; value of --userinit option
(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.
+ ;; 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)
;; Has a --noprint option been seen?
(noprint nil)
;; reasonably.
;; Process command line options.
- (flet (;; Errors while processing the command line cause the system
- ;; to QUIT, 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 debugger.
- (startup-error (control-string &rest args)
- (format
- *error-output*
- "fatal error before reaching READ-EVAL-PRINT loop: ~% ~?~%"
- control-string
- args)
- (quit :unix-status 1)))
- (loop while options do
- (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
- (let ((option (first options)))
- (flet ((pop-option ()
- (if options
- (pop options)
- (startup-error
- "unexpected end of command line options"))))
- (cond ((string= option "--sysinit")
- (pop-option)
- (if sysinit
- (startup-error "multiple --sysinit options")
- (setf sysinit (pop-option))))
- ((string= option "--userinit")
- (pop-option)
- (if userinit
- (startup-error "multiple --userinit options")
- (setf userinit (pop-option))))
- ((string= option "--eval")
- (pop-option)
- (push (pop-option) reversed-evals))
- ((string= option "--load")
- (pop-option)
- (push
- ;; FIXME: see BUG 296
- (concatenate 'string "(|LOAD| \"" (pop-option) "\")")
- reversed-evals))
- ((string= option "--noprint")
- (pop-option)
- (setf noprint t))
- ((string= option "--disable-debugger")
- (pop-option)
- (push "(|DISABLE-DEBUGGER|)" reversed-evals))
- ((string= option "--end-toplevel-options")
- (pop-option)
- (return))
- (t
- ;; Anything we don't recognize as a toplevel
- ;; option must be the start of user-level
- ;; options.. except that if we encounter
- ;; "--end-toplevel-options" after we gave up
- ;; because we didn't recognize an option as a
- ;; toplevel option, then the option we gave up on
- ;; must have been an error. (E.g. in
- ;; "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options"
- ;; this test will let us detect that the string
- ;; "--eval(b)" is an error.)
- (if (find "--end-toplevel-options" options
- :test #'string=)
- (startup-error "bad toplevel option: ~S"
- (first options))
- (return)))))))
- (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
-
- ;; Delete all the options that we processed, so that only
- ;; user-level options are left visible to user code.
- (setf (rest *posix-argv*) options)
-
- ;; Handle initialization files.
- (/show0 "handling initialization files in TOPLEVEL-INIT")
- (flet (;; shared idiom for searching for SYSINITish and
- ;; USERINITish files
- (probe-init-files (explicitly-specified-init-file-name
- &rest default-init-file-names)
- (declare (type list default-init-file-names))
- (if explicitly-specified-init-file-name
- (or (probe-file explicitly-specified-init-file-name)
- (startup-error "The file ~S was not found."
- explicitly-specified-init-file-name))
- (find-if (lambda (x)
- (and (stringp x) (probe-file x)))
- default-init-file-names)))
- ;; shared idiom for creating default names for
- ;; SYSINITish and USERINITish files
- (init-file-name (maybe-dir-name basename)
- (and maybe-dir-name
- (concatenate 'string maybe-dir-name "/" basename))))
- (let ((sysinit-truename
- (probe-init-files sysinit
- (init-file-name (posix-getenv "SBCL_HOME")
- "sbclrc")
- "/etc/sbclrc"))
- (userinit-truename
- (probe-init-files userinit
- (init-file-name (posix-getenv "HOME")
- ".sbclrc"))))
-
- ;; This CATCH is needed for the debugger command TOPLEVEL to
- ;; work.
- (catch 'toplevel-catcher
- ;; We wrap all the pre-REPL user/system customized startup
- ;; code in a restart.
- ;;
- ;; (Why not wrap everything, even the stuff above, in this
- ;; restart? Errors above here are basically command line
- ;; or Unix environment errors, e.g. a missing file or a
- ;; typo on the Unix command line, and you don't need to
- ;; get into Lisp to debug them, you should just start over
- ;; and do it right at the Unix level. Errors below here
- ;; are generally errors in user Lisp code, and it might be
- ;; helpful to let the user reach the REPL in order to help
- ;; figure out what's going on.)
- (restart-case
- (progn
- (process-init-file sysinit-truename)
- (process-init-file userinit-truename)
- (process-eval-options (reverse reversed-evals)))
- (abort ()
- :report "Skip to toplevel READ/EVAL/PRINT loop."
- (/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)))))
-
- ;; one more time for good measure, in case we fell out of the
- ;; RESTART-CASE above before one of the flushes in the ordinary
- ;; flow of control had a chance to operate
- (flush-standard-output-streams)
-
- (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
- (toplevel-repl noprint)
- ;; (classic CMU CL error message: "You're certainly a clever child.":-)
- (critically-unreachable "after TOPLEVEL-REPL")))))
+ (loop while options do
+ (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
+ (let ((option (first options)))
+ (flet ((pop-option ()
+ (if options
+ (pop options)
+ (startup-error
+ "unexpected end of command line options"))))
+ (cond ((string= option "--sysinit")
+ (pop-option)
+ (if sysinit
+ (startup-error "multiple --sysinit options")
+ (setf sysinit (pop-option))))
+ ((string= option "--no-sysinit")
+ (pop-option)
+ (setf no-sysinit t))
+ ((string= option "--userinit")
+ (pop-option)
+ (if userinit
+ (startup-error "multiple --userinit options")
+ (setf userinit (pop-option))))
+ ((string= option "--no-userinit")
+ (pop-option)
+ (setf no-userinit t))
+ ((string= option "--eval")
+ (pop-option)
+ (push (pop-option) reversed-evals))
+ ((string= option "--load")
+ (pop-option)
+ (push
+ (list 'cl:load (native-pathname (pop-option)))
+ reversed-evals))
+ ((string= option "--noprint")
+ (pop-option)
+ (setf noprint t))
+ ((string= option "--disable-debugger")
+ (pop-option)
+ (push (list 'sb!ext:disable-debugger) reversed-evals))
+ ((string= option "--end-toplevel-options")
+ (pop-option)
+ (return))
+ (t
+ ;; Anything we don't recognize as a toplevel
+ ;; option must be the start of user-level
+ ;; options.. except that if we encounter
+ ;; "--end-toplevel-options" after we gave up
+ ;; because we didn't recognize an option as a
+ ;; toplevel option, then the option we gave up on
+ ;; must have been an error. (E.g. in
+ ;; "sbcl --eval '(a)' --eval'(b)' --end-toplevel-options"
+ ;; this test will let us detect that the string
+ ;; "--eval(b)" is an error.)
+ (if (find "--end-toplevel-options" options
+ :test #'string=)
+ (startup-error "bad toplevel option: ~S"
+ (first options))
+ (return)))))))
+ (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL-INIT")
+
+ ;; Delete all the options that we processed, so that only
+ ;; user-level options are left visible to user code.
+ (setf (rest *posix-argv*) options)
+
+ ;; Handle initialization files.
+ (/show0 "handling initialization files in TOPLEVEL-INIT")
+ ;; This CATCH is needed for the debugger command TOPLEVEL to
+ ;; work.
+ (catch 'toplevel-catcher
+ ;; We wrap all the pre-REPL user/system customized startup
+ ;; code in a restart.
+ ;;
+ ;; (Why not wrap everything, even the stuff above, in this
+ ;; restart? Errors above here are basically command line
+ ;; or Unix environment errors, e.g. a missing file or a
+ ;; typo on the Unix command line, and you don't need to
+ ;; get into Lisp to debug them, you should just start over
+ ;; and do it right at the Unix level. Errors below here
+ ;; are generally errors in user Lisp code, and it might be
+ ;; helpful to let the user reach the REPL in order to help
+ ;; figure out what's going on.)
+ (restart-case
+ (progn
+ (unless no-sysinit
+ (process-init-file sysinit *sysinit-pathname-function*))
+ (unless no-userinit
+ (process-init-file userinit *userinit-pathname-function*))
+ (process-eval-options (nreverse reversed-evals)))
+ (abort ()
+ :report "Skip to toplevel READ/EVAL/PRINT loop."
+ (/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))))
+
+ ;; one more time for good measure, in case we fell out of the
+ ;; RESTART-CASE above before one of the flushes in the ordinary
+ ;; flow of control had a chance to operate
+ (flush-standard-output-streams)
+
+ (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT")
+ (toplevel-repl noprint)
+ ;; (classic CMU CL error message: "You're certainly a clever child.":-)
+ (critically-unreachable "after TOPLEVEL-REPL")))
;;; hooks to support customized toplevels like ACL-style toplevel from
;;; KMR on sbcl-devel 2002-12-21. Altered by CSR 2003-11-16 for
;;; threaded operation: altered *REPL-FUN* to *REPL-FUN-GENERATOR*.
(defvar *repl-read-form-fun* #'repl-read-form-fun
- "a function of two stream arguments IN and OUT for the toplevel REPL to
- call: Return the next Lisp form to evaluate (possibly handling other
- magic -- like ACL-style keyword commands -- which precede the next
- Lisp form). The OUT stream is there to support magic which requires
- issuing new prompts.")
+ #!+sb-doc
+ "A function of two stream arguments IN and OUT for the toplevel REPL to
+call: Return the next Lisp form to evaluate (possibly handling other magic --
+like ACL-style keyword commands -- which precede the next Lisp form). The OUT
+stream is there to support magic which requires issuing new prompts.")
(defvar *repl-prompt-fun* #'repl-prompt-fun
- "a function of one argument STREAM for the toplevel REPL to call: Prompt
- the user for input.")
+ #!+sb-doc
+ "A function of one argument STREAM for the toplevel REPL to call: Prompt
+the user for input.")
(defvar *repl-fun-generator* (constantly #'repl-fun)
- "a function of no arguments returning a function of one argument
- NOPRINT that provides the REPL for the system. Assumes that
- *STANDARD-INPUT* and *STANDARD-OUTPUT* are set up.")
+ #!+sb-doc
+ "A function of no arguments returning a function of one argument NOPRINT
+that provides the REPL for the system. Assumes that *STANDARD-INPUT* and
+*STANDARD-OUTPUT* are set up.")
;;; read-eval-print loop for the default system toplevel
(defun toplevel-repl (noprint)
;; most CL specials (most critically *PACKAGE*).
(with-rebound-io-syntax
(handler-bind ((step-condition 'invoke-stepper))
- (let ((*stepping* nil)
- (*step* nil))
- (loop
+ (loop
(/show0 "about to set up restarts in TOPLEVEL-REPL")
- ;; CLHS recommends that there should always be an
- ;; ABORT restart; we have this one here, and one per
- ;; debugger level.
- (with-simple-restart
- (abort "~@<Exit debugger, returning to top level.~@:>")
- (catch 'toplevel-catcher
- (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.
- (sb!kernel::protect-control-stack-guard-page 1)
- (funcall repl-fun noprint)
- (critically-unreachable "after REPL"))))))))))
+ ;; CLHS recommends that there should always be an
+ ;; ABORT restart; we have this one here, and one per
+ ;; debugger level.
+ (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)
+ (funcall repl-fun noprint)
+ (critically-unreachable "after REPL")))))))))
;;; Our default REPL prompt is the minimal traditional one.
(defun repl-prompt-fun (stream)
(scrub-control-stack)
(sb!thread::get-foreground)
(unless noprint
+ (flush-standard-output-streams)
(funcall *repl-prompt-fun* *standard-output*)
;; (Should *REPL-PROMPT-FUN* be responsible for doing its own
;; FORCE-OUTPUT? I can't imagine a valid reason for it not to
(fresh-line)
(prin1 result)))))
;; If we started stepping in the debugger we want to stop now.
- (setf *stepping* nil
- *step* nil))))
+ (disable-stepping))))
\f
;;; a convenient way to get into the assembly-level debugger
(defun %halt ()
projects / sbcl.git / blobdiff