\f
(defconstant most-positive-fixnum #.sb!vm:*target-most-positive-fixnum*
#!+sb-doc
- "The fixnum closest in value to positive infinity.")
+ "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.")
+ "the fixnum closest in value to negative infinity")
\f
-;;;; magic specials initialized by genesis
+;;;; magic specials initialized by GENESIS
-#!-gengc
+;;; FIXME: The DEFVAR here is redundant with the (DECLAIM (SPECIAL ..))
+;;; of all static symbols in early-impl.lisp.
(progn
(defvar *current-catch-block*)
(defvar *current-unwind-protect-block*)
\f
;;; specials initialized by !COLD-INIT
-;;; FIXME: These could be converted to DEFVARs, and the stuff shared
-;;; in both #!+GENGC and #!-GENGC (actually everything in #!+GENGC)
-;;; could be made non-conditional.
-(declaim
- #!-gengc
- (special *gc-inhibit* *already-maybe-gcing*
- *need-to-collect-garbage*
- *gc-notify-stream*
- *before-gc-hooks* *after-gc-hooks*
- #!+x86 *pseudo-atomic-atomic*
- #!+x86 *pseudo-atomic-interrupted*
- sb!unix::*interrupts-enabled*
- sb!unix::*interrupt-pending*
- *type-system-initialized*)
- #!+gengc
- (special *before-gc-hooks* *after-gc-hooks*
- *gc-notify-stream*
- *type-system-initialized*))
+;;; FIXME: These could be converted to DEFVARs.
+(declaim (special *gc-inhibit* *already-maybe-gcing*
+ *need-to-collect-garbage*
+ *gc-notify-stream*
+ *before-gc-hooks* *after-gc-hooks*
+ #!+x86 *pseudo-atomic-atomic*
+ #!+x86 *pseudo-atomic-interrupted*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ *type-system-initialized*))
(defvar *cold-init-complete-p*)
\f
;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
-;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
-;;; hyperspace.
+;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out
+;;; of hyperspace.
(defmacro infinite-error-protect (&rest forms)
`(unless (infinite-error-protector)
+ (/show0 "back from INFINITE-ERROR-PROTECTOR")
(let ((*current-error-depth* (1+ *current-error-depth*)))
+ (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
+ #+sb-show (sb-debug:backtrace)
,@forms)))
;;; a helper function for INFINITE-ERROR-PROTECT
(defun infinite-error-protector ()
+ (/show0 "entering INFINITE-ERROR-PROTECTOR, *CURRENT-ERROR-DEPTH*=..")
+ (/hexstr *current-error-depth*)
(cond ((not *cold-init-complete-p*)
(%primitive print "Argh! error in cold init, halting")
(%primitive sb!c:halt))
(%primitive print "Argh! corrupted error depth, halting")
(%primitive sb!c:halt))
((> *current-error-depth* *maximum-error-depth*)
+ (/show0 "*MAXIMUM-ERROR-DEPTH*=..")
+ (/hexstr *maximum-error-depth*)
(/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
(error-error "Help! "
*current-error-depth*
"KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
t)
(t
+ (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
nil)))
;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at
(defconstant bytes-per-scrub-unit 2048)
+;;; Zero the unused portion of the control stack so that old objects
+;;; are not kept alive because of uninitialized stack variables.
+;;;
+;;; FIXME: Why do we need to do this instead of just letting GC read
+;;; the stack pointer and avoid messing with the unused portion of
+;;; the control stack? (Is this a multithreading thing where there's
+;;; one control stack and stack pointer per thread, and it might not
+;;; be easy to tell what a thread's stack pointer value is when
+;;; looking in from another thread?)
(defun scrub-control-stack ()
- #!+sb-doc
- "Zero the unused portion of the control stack so that old objects are not
- kept alive because of uninitialized stack variables."
- ;; FIXME: Why do we need to do this instead of just letting GC read
- ;; the stack pointer and avoid messing with the unused portion of
- ;; the control stack? (Is this a multithreading thing where there's
- ;; one control stack and stack pointer per thread, and it might not
- ;; be easy to tell what a thread's stack pointer value is when
- ;; looking in from another thread?)
(declare (optimize (speed 3) (safety 0))
(values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
(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.)
(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
-;;; FIXME: Most stuff below here can probably be byte-compiled.
-
(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.")
+
+;;; 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 ***, **, *,
(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")
- (%primitive print "//entering TOPLEVEL-INIT") ; REMOVEME
-
(let ((sysinit nil) ; value of --sysinit option
(userinit nil) ; value of --userinit option
(let ((* nil) (** nil) (*** nil)
(- nil)
(+ nil) (++ nil) (+++ nil)
- (/// nil) (// nil) (/ nil)
- (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
+ (/// 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?
- (/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)))))))))))))
+ (repl noprint))))))
+
+(defun repl (noprint)
+ (/show0 "entering REPL")
+ (let ((eof-marker (cons :eof nil)))
+ (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?
+ (/show0 "at head of LOOP")
+ (scrub-control-stack)
+ (/show0 "back from SCRUB-CONTROL-STACK")
+ (unless noprint
+ (fresh-line)
+ (/show0 "back from FRESH-LINE")
+ (princ (if (functionp *prompt*)
+ (funcall *prompt*)
+ *prompt*))
+ (/show0 "back from PRINC")
+ (flush-standard-output-streams)
+ (/show0 "back from FLUSH-STANDARD-OUTPUT-STREAMS"))
+ (let ((form (read *standard-input* nil eof-marker)))
+ (/show0 "back from READ")
+ (if (eq form eof-marker)
+ (quit)
+ (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))
(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