X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=381a2b2d0bc0b88ec5b25088e2094e688101c294;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=a2a141f42f6874ea688e406b8e5b73c88741dea0;hpb=5ec8d0c1c8b7939818b75118b472fac1af554f9a;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index a2a141f..381a2b2 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -13,14 +13,6 @@ (in-package "SB!IMPL") -(defconstant most-positive-fixnum #.sb!vm:*target-most-positive-fixnum* - #!+sb-doc - "the fixnum closest in value to positive infinity") - -(defconstant most-negative-fixnum #.sb!vm:*target-most-negative-fixnum* - #!+sb-doc - "the fixnum closest in value to negative infinity") - ;;;; magic specials initialized by GENESIS ;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..)) @@ -140,15 +132,17 @@ be any non-negative, non-complex number." (when (or (not (realp n)) (minusp n)) - (error "Invalid argument to SLEEP: ~S.~%~ - Must be a non-negative, non-complex number." - n)) + (error 'simple-type-error + :format-control "invalid argument to SLEEP: ~S" + :format-arguments (list n) + :datum n + :expected-type '(real 0))) (multiple-value-bind (sec usec) (if (integerp n) (values n 0) (multiple-value-bind (sec frac) (truncate n) - (values sec(truncate frac 1e-6)))) + (values sec (truncate frac 1e-6)))) (sb!unix:unix-select 0 0 0 0 sec usec)) nil) @@ -169,7 +163,7 @@ (declare (optimize (speed 3) (safety 0)) (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES? - #!-x86 ; machines where stack grows upwards (I guess) -- WHN 19990906 + #!-stack-grows-downward-not-upward (labels ((scrub (ptr offset count) (declare (type system-area-pointer ptr) @@ -199,7 +193,7 @@ (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes) 0))) - #!+x86 ;; (Stack grows downwards.) + #!+stack-grows-downward-not-upward (labels ((scrub (ptr offset count) (declare (type system-area-pointer ptr) @@ -247,10 +241,6 @@ (defvar +++ nil #!+sb-doc "the previous value of ++") (defvar - nil #!+sb-doc "the form currently being evaluated") -;;; the top level prompt string, or a function of no arguments that -;;; returns a simple-string -(defvar *prompt* "* ") - (defun interactive-eval (form) "Evaluate FORM, returning whatever it returns and adjusting ***, **, *, +++, ++, +, ///, //, /, and -." @@ -292,9 +282,10 @@ (let ((sysinit nil) ; value of --sysinit option (userinit nil) ; value of --userinit option - (reversed-evals nil) ; values of --eval options, in reverse order + (reversed-evals nil) ; values of --eval options, in reverse order; and + ; also --load options, translated into --eval (noprint nil) ; Has a --noprint option been seen? - (noprogrammer nil) ; Has a --noprogammer option been seen? + (noprogrammer nil) ; Has a --noprogrammer option been seen? (options (rest *posix-argv*))) ; skipping program name (/show0 "done with outer LET in TOPLEVEL-INIT") @@ -304,7 +295,9 @@ ;; READ an --eval string). Make sure that they're handled ;; reasonably. Also, perhaps all errors while parsing the command ;; line should cause the system to QUIT, instead of trying to go - ;; into the Lisp debugger. + ;; into the Lisp debugger, since trying to go into the debugger + ;; gets into various annoying issues of where we should go after + ;; the user tries to return from the debugger. ;; Parse command line options. (loop while options do @@ -339,6 +332,9 @@ eval-as-string)) (t (push eval reversed-evals))))))) + ((string= option "--load") + (pop-option) + (push `(load ,(pop-option)) reversed-evals)) ((string= option "--noprint") (pop-option) (setf noprint t)) @@ -377,9 +373,6 @@ (setf *debugger-hook* 'noprogrammer-debugger-hook-fun *debug-io* *error-output*)) - ;; FIXME: Verify that errors in init files and/or --eval operations - ;; lead to reasonable behavior. - ;; Handle initialization files. (/show0 "handling initialization files in TOPLEVEL-INIT") (flet (;; If any of POSSIBLE-INIT-FILE-NAMES names a real file, @@ -394,10 +387,9 @@ (let* ((sbcl-home (posix-getenv "SBCL_HOME")) (sysinit-truename (if sbcl-home (probe-init-files sysinit - (concatenate - 'string - sbcl-home - "/sbclrc")) + (concatenate 'string + sbcl-home + "/sbclrc")) (probe-init-files sysinit "/etc/sbclrc" "/usr/local/etc/sbclrc"))) @@ -405,12 +397,9 @@ (error "The HOME environment variable is unbound, ~ so user init file can't be found."))) (userinit-truename (probe-init-files userinit - (concatenate - 'string - user-home - "/.sbclrc")))) - (/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME") - + (concatenate 'string + user-home + "/.sbclrc")))) ;; We wrap all the pre-REPL user/system customized startup code ;; in a restart. @@ -420,17 +409,19 @@ ;; 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 usually 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.) + ;; 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 - (flet ((process-init-file (truename) - (when truename - (unless (load truename) - (error "~S was not successfully loaded." truename)) - (flush-standard-output-streams)))) - (process-init-file sysinit-truename) - (process-init-file userinit-truename) + (progn + (flet ((process-init-file (truename) + (when truename + (unless (load truename) + (error "~S was not successfully loaded." truename)) + (flush-standard-output-streams)))) + (process-init-file sysinit-truename) + (process-init-file userinit-truename)) ;; Process --eval options. (/show0 "handling --eval options in TOPLEVEL-INIT") @@ -439,11 +430,14 @@ (eval eval) (flush-standard-output-streams))) (continue () - :report "Continue anyway (skipping to toplevel read/eval/print loop)." - (values)) ; (no-op, just fall through) + :report + "Continue anyway (skipping 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)." - (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 @@ -451,7 +445,9 @@ (flush-standard-output-streams) (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL-INIT") - (toplevel-repl noprint)))) + (toplevel-repl noprint) + ;; (classic CMU CL error message: "You're certainly a clever child.":-) + (critically-unreachable "after TOPLEVEL-REPL")))) ;;; read-eval-print loop for the default system toplevel (defun toplevel-repl (noprint) @@ -459,50 +455,60 @@ (let ((* nil) (** nil) (*** nil) (- nil) (+ nil) (++ nil) (+++ nil) - (/// nil) (// nil) (/ nil) - (eof-marker (cons :eof nil))) + (/// nil) (// nil) (/ 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. + (with-simple-restart + (abort + "Reduce debugger level (leaving debugger, returning to toplevel).") + (catch 'toplevel-catcher + #!-sunos (sb!unix:unix-sigsetmask 0) ; FIXME: What is this for? + (repl noprint) + (critically-unreachable "after REPL"))))))) + +(defun repl (noprint) + (/show0 "entering REPL") + (let ((eof-marker (cons :eof nil))) (loop - (/show0 "at head of outer LOOP 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. - (with-simple-restart (abort - "Reduce debugger level (leaving debugger).") - (catch 'toplevel-catcher - (sb!unix:unix-sigsetmask 0) ; FIXME: What is this for? - (/show0 "about to enter inner LOOP in TOPLEVEL-REPL") - (loop ; FIXME: Do we need this inner LOOP? - ;; FIXME: It seems bad to have GC behavior depend on scrubbing - ;; the control stack before each interactive command. Isn't - ;; there some way we can convince the GC to just ignore - ;; dead areas of the control stack, so that we don't need to - ;; rely on this half-measure? - (scrub-control-stack) - (unless noprint - (fresh-line) - (princ (if (functionp *prompt*) - (funcall *prompt*) - *prompt*)) - (flush-standard-output-streams)) - (let ((form (read *standard-input* nil eof-marker))) - (if (eq form eof-marker) - (quit) - (let ((results - (multiple-value-list (interactive-eval form)))) - (unless noprint - (dolist (result results) - (fresh-line) - (prin1 result))))))))))))) + ;; FIXME: It seems bad to have GC behavior depend on scrubbing the + ;; control stack before each interactive command. Isn't there some + ;; way we can convince the GC to just ignore dead areas of the + ;; control stack, so that we don't need to rely on this half-measure? + (scrub-control-stack) + (unless noprint + (fresh-line) + (write-string "* ") ; arbitrary but customary REPL prompt + (flush-standard-output-streams)) + (let ((form (read *standard-input* nil eof-marker))) + (cond ((eq form eof-marker) + (/show0 "doing QUIT for EOF in REPL") + (quit)) + (t + (let ((results (multiple-value-list (interactive-eval form)))) + (unless noprint + (dolist (result results) + (fresh-line) + (prin1 result)))))))))) (defun noprogrammer-debugger-hook-fun (condition old-debugger-hook) (declare (ignore old-debugger-hook)) (flet ((failure-quit (&key recklessly-p) + (/show0 "in FAILURE-QUIT (in noprogrammer debugger hook)") (quit :unix-status 1 :recklessly-p recklessly-p))) ;; This HANDLER-CASE is here mostly to stop output immediately ;; (and fall through to QUIT) when there's an I/O error. Thus, @@ -512,12 +518,14 @@ (handler-case (progn (format *error-output* - "~@~2%" + "~&~@~2%" (type-of condition) condition) ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that - ;; even if we hit an error within BACKTRACE we'll at least - ;; have the CONDITION printed out before we die. + ;; even if we hit an error within BACKTRACE (e.g. a bug in + ;; the debugger's own frame-walking code, or a bug in a user + ;; PRINT-OBJECT method) we'll at least have the CONDITION + ;; printed out before we die. (finish-output *error-output*) ;; (Where to truncate the BACKTRACE is of course arbitrary, but ;; it seems as though we should at least truncate it somewhere.)