(in-package "SB!IMPL")
\f
-(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")
-\f
;;;; magic specials initialized by GENESIS
;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
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)
\f
(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)
(look (sap+ ptr bytes-per-scrub-unit) 0 count))
(t
(setf (sap-ref-32 ptr offset) 0)
- (scrub ptr (+ offset sb!vm:word-bytes) count))))
+ (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
(look (ptr offset count)
(declare (type system-area-pointer ptr)
(type (unsigned-byte 16) offset)
(cond ((= offset bytes-per-scrub-unit)
count)
((zerop (sap-ref-32 ptr offset))
- (look ptr (+ offset sb!vm:word-bytes) count))
+ (look ptr (+ offset sb!vm:n-word-bytes) count))
(t
- (scrub ptr offset (+ count sb!vm:word-bytes))))))
+ (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
(let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
(initial-offset (logand csp (1- bytes-per-scrub-unit))))
(declare (type (unsigned-byte 32) csp))
(scrub (int-sap (- csp initial-offset))
- (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
+ (* (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)
(type (unsigned-byte 16) offset)
(type (unsigned-byte 20) count)
(values (unsigned-byte 20)))
- (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:word-bytes)))))
+ (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:n-word-bytes)))))
(cond ((= offset bytes-per-scrub-unit)
(look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
0 count))
(t ;; need to fix bug in %SET-STACK-REF
(setf (sap-ref-32 loc 0) 0)
- (scrub ptr (+ offset sb!vm:word-bytes) count)))))
+ (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
(look (ptr offset count)
(declare (type system-area-pointer ptr)
(type (unsigned-byte 16) offset)
(cond ((= offset bytes-per-scrub-unit)
count)
((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
- (look ptr (+ offset sb!vm:word-bytes) count))
+ (look ptr (+ offset sb!vm:n-word-bytes) count))
(t
- (scrub ptr offset (+ count sb!vm:word-bytes)))))))
+ (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
(let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
(initial-offset (logand csp (1- bytes-per-scrub-unit))))
(declare (type (unsigned-byte 32) csp))
(scrub (int-sap (+ csp initial-offset))
- (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
+ (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
0))))
\f
;;;; the default toplevel function
(defvar / nil
#!+sb-doc
- "a list of all the values returned by the most recent top-level EVAL")
+ "a list of all the values returned by the most recent top level EVAL")
(defvar // nil #!+sb-doc "the previous value of /")
(defvar /// nil #!+sb-doc "the previous value of //")
-(defvar * nil #!+sb-doc "the value of the most recent top-level EVAL")
+(defvar * nil #!+sb-doc "the value of the most recent top level EVAL")
(defvar ** nil #!+sb-doc "the previous value of *")
(defvar *** nil #!+sb-doc "the previous value of **")
-(defvar + nil #!+sb-doc "the value of the most recent top-level READ")
+(defvar + nil #!+sb-doc "the value of the most recent top level READ")
(defvar ++ nil #!+sb-doc "the previous value of +")
(defvar +++ nil #!+sb-doc "the previous value of ++")
(defvar - nil #!+sb-doc "the form currently being evaluated")
-(defvar *prompt* "* "
- #!+sb-doc
- "The top-level prompt string. This also may be a function of no arguments
- that returns a simple-string.")
(defun interactive-eval (form)
"Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
(finish-output (symbol-value name)))
(values))
-;;; the default system top-level function
+;;; the default system top level function
(defun toplevel-init ()
(/show0 "entering TOPLEVEL-INIT")
(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")
;; 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
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))
(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,
(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")))
(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.
;; 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")
(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
(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)
(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 'top-level-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,
(handler-case
(progn
(format *error-output*
- "~@<unhandled condition (of type ~S): ~2I~_~A~:>~2%"
+ "~&~@<unhandled condition (of type ~S): ~2I~_~A~:>~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.)
projects / sbcl.git / blobdiff