X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftoplevel.lisp;h=381a2b2d0bc0b88ec5b25088e2094e688101c294;hb=86210c4e406c1b2ff10cc3bac0e71435867db48b;hp=85bc4c878c4b029ae9eebd5d861fba9789676a8c;hpb=ba7659c92f2b7fac7e9532a3db9114c5bdc4ab55;p=sbcl.git diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 85bc4c8..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,10 +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")))) + (concatenate 'string + user-home + "/.sbclrc")))) ;; We wrap all the pre-REPL user/system customized startup code ;; in a restart. @@ -418,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") @@ -452,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) @@ -461,20 +456,30 @@ (- nil) (+ nil) (++ nil) (+++ nil) (/// nil) (// nil) (/ nil)) - (/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).") - (catch 'toplevel-catcher - (sb!unix:unix-sigsetmask 0) ; FIXME: What is this for? - (repl noprint)))))) + ;; 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") @@ -483,14 +488,11 @@ ;; 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? + ;; 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*)) + (write-string "* ") ; arbitrary but customary REPL prompt (flush-standard-output-streams)) (let ((form (read *standard-input* nil eof-marker))) (cond ((eq form eof-marker)