: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
(abort ()
:report "Skip rest of initialization file."))))
-(defun process-eval-options (eval-strings)
+(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 ()
(/show0 "entering TOPLEVEL-INIT")
(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)
(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
- ;; FIXME: see BUG 296
- (concatenate 'string "(|LOAD| \"" (pop-option) "\")")
+ (list 'cl:load (native-pathname (pop-option)))
reversed-evals))
((string= option "--noprint")
(pop-option)
(setf noprint t))
((string= option "--disable-debugger")
(pop-option)
- (push "(|DISABLE-DEBUGGER|)" reversed-evals))
+ (push (list 'sb!ext:disable-debugger) reversed-evals))
((string= option "--end-toplevel-options")
(pop-option)
(return))
&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))
+ (or (probe-file
+ (parse-native-namestring
+ 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))))
+ (and (pathnamep x) (probe-file x)))
+ default-init-file-names))))
(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")
+ (let ((sbcl-homedir (sbcl-homedir-pathname)))
+ (when sbcl-homedir
+ (merge-pathnames sbcl-homedir "sbclrc")))
+ #!-win32
+ "/etc/sbclrc"
+ #!+win32
+ (merge-pathnames
+ (sb!win32::get-folder-pathname
+ sb!win32::csidl_common_appdata)
+ "\\sbcl\\sbclrc")))
+ (userinit-truename
+ (probe-init-files userinit
+ (merge-pathnames (user-homedir-pathname)
".sbclrc"))))
-
;; This CATCH is needed for the debugger command TOPLEVEL to
;; work.
(catch 'toplevel-catcher
;; figure out what's going on.)
(restart-case
(progn
- (process-init-file sysinit-truename)
- (process-init-file userinit-truename)
+ (unless no-sysinit (process-init-file sysinit-truename))
+ (unless no-userinit (process-init-file userinit-truename))
(process-eval-options (reverse reversed-evals)))
(abort ()
:report "Skip to toplevel READ/EVAL/PRINT loop."
(with-simple-restart
(abort "~@<Exit debugger, returning to top level.~@:>")
(catch 'toplevel-catcher
- (sb!unix::reset-signal-mask)
+ #!-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"))))))))))
projects / sbcl.git / blobdiff