;;; FIXME: These could be converted to DEFVARs.
(declaim (special #!+(or x86 x86-64) *pseudo-atomic-bits*
- sb!unix::*interrupts-enabled*
- sb!unix::*interrupt-pending*
+ *allow-with-interrupts*
+ *interrupts-enabled*
+ *interrupt-pending*
*type-system-initialized*))
(defvar *cold-init-complete-p*)
(defun sysinit-pathname ()
(or (let ((sbcl-homedir (sbcl-homedir-pathname)))
(when sbcl-homedir
- (probe-file (merge-pathnames sbcl-homedir "sbclrc"))))
+ (probe-file (merge-pathnames "sbclrc" sbcl-homedir))))
#!+win32
(merge-pathnames "sbcl\\sbclrc"
(sb!win32::get-folder-pathname
(with-unique-names (caught)
`(let ((,caught (catch '%end-of-the-world
(/show0 "inside CATCH '%END-OF-THE-WORLD")
- ,@body)))
+ (unwind-protect
+ (progn ,@body)
+ (call-hooks "exit" *exit-hooks*)))))
(/show0 "back from CATCH '%END-OF-THE-WORLD, flushing output")
(flush-standard-output-streams)
(sb!thread::terminate-session)
(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*)))
+ sb!c:*backend-page-bytes*)))
(labels
((scrub (ptr offset count)
(declare (type system-area-pointer ptr)
#!+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*))
+ sb!c:*backend-page-bytes*))
(initial-offset (logand csp (1- bytes-per-scrub-unit))))
(labels
((scrub (ptr offset count)
(force-output (symbol-value name)))
(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."))))
+(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*)))
+ (flet ((process-stream (stream pathname)
+ (with-simple-restart (abort "Skip rest of ~A file ~S."
+ context (native-namestring pathname))
+ (loop
+ (with-simple-restart
+ (continue "Ignore error and continue processing ~A file ~S."
+ context (native-namestring pathname))
+ (let ((form (read stream nil stream)))
+ (if (eq stream form)
+ (return-from process-init-file nil)
+ (eval form))))))))
+ (if specified-pathname
+ (with-open-file (stream (parse-native-namestring specified-pathname)
+ :if-does-not-exist nil)
+ (if stream
+ (process-stream stream (pathname stream))
+ (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
+ (process-stream stream (pathname stream))))))))))
+
+(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))))))
+ (flush-standard-output-streams)))
+ (with-simple-restart (abort "Skip rest of --eval and --load options.")
+ (dolist (option options)
+ (process-1 option)))))
+
+;;; Skips past the shebang line on stream, if any.
+(defun maybe-skip-shebang-line (stream)
+ (let ((p (file-position stream)))
+ (flet ((next () (read-byte stream nil)))
+ (unwind-protect
+ (when (and (eq (next) (char-code #\#))
+ (eq (next) (char-code #\!)))
+ (setf p nil)
+ (loop for x = (next)
+ until (or (not x) (eq x (char-code #\newline)))))
+ (when p
+ (file-position stream p))))
+ t))
+
+(defun process-script (script)
+ (let ((pathname (native-pathname script))
+ (ok nil))
+ (unwind-protect
+ (with-open-file (f pathname :element-type :default)
+ (maybe-skip-shebang-line f)
+ (load f :verbose nil :print nil)
+ (setf ok t))
+ (quit :unix-status (if ok 0 1)))))
;; Errors while processing the command line cause the system to QUIT,
;; instead of trying to go into the Lisp debugger, because trying to
(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)
;; 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 (pop-option))
+ (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 "--end-toplevel-options")
(pop-option)
(return))
;; user-level options are left visible to user code.
(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")
;; This CATCH is needed for the debugger command TOPLEVEL to
(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))
+ (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)."
+ :test (lambda (c) (declare (ignore c)) (not script))
(/show0 "falling through to QUIT from pre-REPL RESTART-CASE")
(quit :unix-status 1))))
;;; 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)
projects / sbcl.git / blobdiff