X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=11bb423a0c1f9c6fedd7fd4e9fb0b6dc4be42c51;hb=568daf6b160280428701670b921f419aabd9eba0;hp=f77abc194853746e475e20af61e0ac9620163bcd;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index f77abc1..11bb423 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -25,9 +25,7 @@ ;;; 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* +(declaim (special #!+(or x86 x86-64) *pseudo-atomic-atomic* #!+(or x86 x86-64) *pseudo-atomic-interrupted* sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending* @@ -147,6 +145,7 @@ steppers to maintain contextual information.") :format-arguments (list n) :datum n :expected-type '(real 0))) + #!-win32 (multiple-value-bind (sec nsec) (if (integerp n) (values n 0) @@ -154,6 +153,8 @@ steppers to maintain contextual information.") (truncate n) (values sec (truncate frac 1e-9)))) (sb!unix:nanosleep sec nsec)) + #!+win32 + (sb!win32:millisleep (truncate (* n 1000))) nil) ;;;; SCRUB-CONTROL-STACK @@ -184,7 +185,7 @@ steppers to maintain contextual information.") (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) @@ -217,7 +218,7 @@ steppers to maintain contextual information.") #!+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 @@ -271,16 +272,17 @@ steppers to maintain contextual information.") "Evaluate FORM, returning whatever it returns and adjusting ***, **, *, +++, ++, +, ///, //, /, and -." (setf - form) - (let ((results (multiple-value-list (eval form)))) - (setf /// // - // / - / results - *** ** - ** * - * (car results))) - (setf +++ ++ - ++ + - + -) + (unwind-protect + (let ((results (multiple-value-list (eval form)))) + (setf /// // + // / + / results + *** ** + ** * + * (car results))) + (setf +++ ++ + ++ + + + -)) (unless (boundp '*) ;; The bogon returned an unbound marker. ;; FIXME: It would be safer to check every one of the values in RESULTS, @@ -297,8 +299,10 @@ steppers to maintain contextual information.") *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) @@ -323,23 +327,29 @@ steppers to maintain contextual information.") (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 () @@ -350,15 +360,21 @@ steppers to maintain contextual information.") (/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) @@ -400,26 +416,31 @@ steppers to maintain contextual information.") (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)) @@ -465,14 +486,24 @@ steppers to maintain contextual information.") (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")) + #!-win32 (probe-init-files sysinit + (init-file-name (posix-getenv "SBCL_HOME") + "sbclrc") + "/etc/sbclrc") + #!+win32 (probe-init-files sysinit + (init-file-name (posix-getenv "SBCL_HOME") + "sbclrc") + (concatenate 'string + (sb!win32::get-folder-path 35) ;;SB-WIN32::CSIDL_COMMON_APPDATA + "\\sbcl\\sbclrc"))) + (userinit-truename - (probe-init-files userinit - (init-file-name (posix-getenv "HOME") - ".sbclrc")))) + #!-win32 (probe-init-files userinit + (init-file-name (posix-getenv "HOME") + ".sbclrc")) + #!+win32 (probe-init-files userinit + (init-file-name (namestring (user-homedir-pathname)) + ".sbclrc")))) ;; This CATCH is needed for the debugger command TOPLEVEL to ;; work. @@ -491,8 +522,8 @@ steppers to maintain contextual information.") ;; 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." @@ -553,7 +584,7 @@ steppers to maintain contextual information.") (with-simple-restart (abort "~@") (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. @@ -585,6 +616,7 @@ steppers to maintain contextual information.") (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