X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=7643a9144b949875c4f6f6894c6076a0759d3105;hb=1af3faa2b79125b774c2182cab841ed7ee555bed;hp=c02f06d97d5d2d5d74531727e14fd6ed4a42f006;hpb=62b0a9c5190806368487d46d8773734cb1ee3a25;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index c02f06d..7643a91 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -26,9 +26,9 @@ ;;; FIXME: These could be converted to DEFVARs. (declaim (special *gc-inhibit* *need-to-collect-garbage* - *before-gc-hooks* *after-gc-hooks* - #!+x86 *pseudo-atomic-atomic* - #!+x86 *pseudo-atomic-interrupted* + *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* *type-system-initialized*)) @@ -147,13 +147,13 @@ steppers to maintain contextual information.") :format-arguments (list n) :datum n :expected-type '(real 0))) - (multiple-value-bind (sec usec) + (multiple-value-bind (sec nsec) (if (integerp n) (values n 0) (multiple-value-bind (sec frac) (truncate n) - (values sec (truncate frac 1e-6)))) - (sb!unix:unix-select 0 0 0 0 sec usec)) + (values sec (truncate frac 1e-9)))) + (sb!unix:nanosleep sec nsec)) nil) ;;;; SCRUB-CONTROL-STACK @@ -417,13 +417,6 @@ steppers to maintain contextual information.") ((string= option "--noprint") (pop-option) (setf noprint t)) - ;; FIXME: --noprogrammer was deprecated in 0.7.5, and - ;; in a year or so this backwards compatibility can - ;; go away. - ((string= option "--noprogrammer") - (warn "treating deprecated --noprogrammer as --disable-debugger") - (pop-option) - (push "(|DISABLE-DEBUGGER|)" reversed-evals)) ((string= option "--disable-debugger") (pop-option) (push "(|DISABLE-DEBUGGER|)" reversed-evals)) @@ -481,31 +474,34 @@ steppers to maintain contextual information.") (init-file-name (posix-getenv "HOME") ".sbclrc")))) - ;; 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))) - (toplevel () - :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)))) + ;; 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 @@ -549,28 +545,13 @@ steppers to maintain contextual information.") (handler-bind ((step-condition 'invoke-stepper)) (let ((*stepping* nil) (*step* nil)) - ;; WITH-SIMPLE-RESTART doesn't actually restart its body as - ;; some (like WHN for an embarrassingly long time - ;; ca. 2001-12-07) might think, but instead drops control back - ;; out at the end. So when a TOPLEVEL or outermost-ABORT - ;; restart happens, we need this outer LOOP wrapper to grab - ;; control and start over again. (And it also wraps CATCH - ;; 'TOPLEVEL-CATCHER for similar reasons.) (loop (/show0 "about to set up restarts in TOPLEVEL-REPL") - ;; There should only be one TOPLEVEL restart, and it's here, - ;; so restarting at TOPLEVEL always bounces you all the way - ;; out here. - (with-simple-restart (toplevel - "Restart at toplevel READ/EVAL/PRINT loop.") - ;; We add a new ABORT restart for every debugger level, so - ;; restarting at ABORT in a nested debugger gets you out to - ;; the innermost enclosing debugger, and only when you're - ;; in the outermost, unnested debugger level does - ;; restarting at ABORT get you out to here. + ;; CLHS recommends that there should always be an + ;; ABORT restart; we have this one here, and one per + ;; debugger level. (with-simple-restart - (abort "~@") + (abort "~@") (catch 'toplevel-catcher (sb!unix::reset-signal-mask) ;; In the event of a control-stack-exhausted-error, we @@ -578,7 +559,7 @@ steppers to maintain contextual information.") ;; here that this is now possible. (sb!kernel::protect-control-stack-guard-page 1) (funcall repl-fun noprint) - (critically-unreachable "after REPL"))))))))))) + (critically-unreachable "after REPL")))))))))) ;;; Our default REPL prompt is the minimal traditional one. (defun repl-prompt-fun (stream)