(progn
(defvar sb!vm::*current-catch-block*)
(defvar sb!vm::*current-unwind-protect-block*)
+ #!+hpux (defvar sb!vm::*c-lra*)
(defvar *free-interrupt-context-index*))
\f
;;; specials initialized by !COLD-INIT
\f
;;;; miscellaneous external functions
-(defun sleep (n)
+(defun sleep (seconds)
#!+sb-doc
- "This function causes execution to be suspended for N seconds. N may
- be any non-negative, non-complex number."
- (when (or (not (realp n))
- (minusp n))
+ "This function causes execution to be suspended for SECONDS. SECONDS may be
+any non-negative real number."
+ (when (or (not (realp seconds))
+ (minusp seconds))
(error 'simple-type-error
:format-control "invalid argument to SLEEP: ~S"
- :format-arguments (list n)
- :datum n
+ :format-arguments (list seconds)
+ :datum seconds
:expected-type '(real 0)))
#!-win32
(multiple-value-bind (sec nsec)
- (if (integerp n)
- (values n 0)
+ (if (integerp seconds)
+ (values seconds 0)
(multiple-value-bind (sec frac)
- (truncate n)
+ (truncate seconds)
(values sec (truncate frac 1e-9))))
+ ;; nanosleep() accepts time_t as the first argument, but on some platforms
+ ;; it is restricted to 100 million seconds. Maybe someone can actually
+ ;; have a reason to sleep for over 3 years?
+ (loop while (> sec (expt 10 8))
+ do (decf sec (expt 10 8))
+ (sb!unix:nanosleep (expt 10 8) 0))
(sb!unix:nanosleep sec nsec))
#!+win32
- (sb!win32:millisleep (truncate (* n 1000)))
+ (sb!win32:millisleep (truncate (* seconds 1000)))
nil)
\f
-;;;; SCRUB-CONTROL-STACK
-
-(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.
-
-;;; "To summarize the problem, since not all allocated stack frame
-;;; slots are guaranteed to be written by the time you call an another
-;;; function or GC, there may be garbage pointers retained in your
-;;; dead stack locations. The stack scrubbing only affects the part
-;;; of the stack from the SP to the end of the allocated stack."
-;;; - ram, on cmucl-imp, Tue, 25 Sep 2001
-
-;;; So, as an (admittedly lame) workaround, from time to time we call
-;;; scrub-control-stack to zero out all the unused portion. This is
-;;; supposed to happen when the stack is mostly empty, so that we have
-;;; a chance of clearing more of it: callers are currently (2002.07.18)
-;;; REPL and SUB-GC
-
-(defun scrub-control-stack ()
- (declare (optimize (speed 3) (safety 0))
- (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
-
- #!-stack-grows-downward-not-upward
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (initial-offset (logand csp (1- bytes-per-scrub-unit)))
- (end-of-stack
- (- (sap-int (sb!di::descriptor-sap sb!vm:*control-stack-end*))
- sb!c:*backend-page-size*)))
- (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)))
- (cond ((>= (sap-int ptr) end-of-stack) 0)
- ((= offset bytes-per-scrub-unit)
- (look (sap+ ptr bytes-per-scrub-unit) 0 count))
- (t
- (setf (sap-ref-word ptr offset) 0)
- (scrub ptr (+ offset sb!vm:n-word-bytes) count))))
- (look (ptr offset count)
- (declare (type system-area-pointer ptr)
- (type (unsigned-byte 16) offset)
- (type (unsigned-byte 20) count)
- (values (unsigned-byte 20)))
- (cond ((>= (sap-int ptr) end-of-stack) 0)
- ((= offset bytes-per-scrub-unit)
- count)
- ((zerop (sap-ref-word ptr offset))
- (look ptr (+ offset sb!vm:n-word-bytes) count))
- (t
- (scrub ptr offset (+ count sb!vm:n-word-bytes))))))
- (declare (type sb!vm::word csp))
- (scrub (int-sap (- csp initial-offset))
- (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
- 0)))
-
- #!+stack-grows-downward-not-upward
- (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
- (end-of-stack (+ (sap-int (sb!di::descriptor-sap sb!vm:*control-stack-start*))
- sb!c:*backend-page-size*))
- (initial-offset (logand csp (1- bytes-per-scrub-unit))))
- (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:n-word-bytes)))))
- (cond ((< (sap-int loc) end-of-stack) 0)
- ((= 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-word loc 0) 0)
- (scrub ptr (+ offset sb!vm:n-word-bytes) count)))))
- (look (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))))
- (cond ((< (sap-int loc) end-of-stack) 0)
- ((= offset bytes-per-scrub-unit)
- count)
- ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
- (look ptr (+ offset sb!vm:n-word-bytes) count))
- (t
- (scrub ptr offset (+ count sb!vm:n-word-bytes)))))))
- (declare (type sb!vm::word csp))
- (scrub (int-sap (+ csp initial-offset))
- (* (floor initial-offset sb!vm:n-word-bytes) sb!vm:n-word-bytes)
- 0))))
-\f
;;;; the default toplevel function
(defvar / nil
(defvar +++ nil #!+sb-doc "the previous value of ++")
(defvar - nil #!+sb-doc "the form currently being evaluated")
-(defun interactive-eval (form)
+(defun interactive-eval (form &key (eval #'eval))
#!+sb-doc
"Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
+++, ++, +, ///, //, /, and -."
(setf - form)
(unwind-protect
- (let ((results (multiple-value-list (eval form))))
+ (let ((results (multiple-value-list (funcall eval form))))
(setf /// //
// /
/ results
(dolist (option options)
(process-1 option)))))
+(defun process-script (script)
+ (let ((pathname (native-pathname script)))
+ (handling-end-of-the-world
+ (with-open-file (f pathname :element-type :default)
+ (sb!fasl::maybe-skip-shebang-line f)
+ ;; Scripts don't need to be stylish or fast, but silence is usually a
+ ;; desirable quality...
+ (handler-bind (((or style-warning compiler-note) #'muffle-warning))
+ (load f :verbose nil :print nil))
+ (quit)))))
+
;; Errors while processing the command line cause the system to QUIT,
;; instead of trying to go into the Lisp debugger, because trying to
;; go into the Lisp debugger would get into various annoying issues of
(reversed-options nil)
;; Has a --noprint option been seen?
(noprint nil)
+ ;; Has a --script option been seen?
+ (script nil)
;; everything in *POSIX-ARGV* except for argv[0]=programname
(options (rest *posix-argv*)))
(pop options)
(startup-error
"unexpected end of command line options"))))
- (cond ((string= option "--sysinit")
+ (cond ((string= option "--script")
+ (pop-option)
+ (setf disable-debugger t
+ no-userinit t
+ no-sysinit t
+ script (pop-option))
+ (return))
+ ((string= option "--sysinit")
(pop-option)
(if sysinit
(startup-error "multiple --sysinit options")
(process-init-file sysinit :system))
(unless no-userinit
(process-init-file userinit :user))
- (process-eval/load-options (nreverse reversed-options)))
+ (process-eval/load-options (nreverse reversed-options))
+ (when script
+ (process-script script)
+ (bug "PROCESS-SCRIPT returned")))
(abort ()
- :report "Skip to toplevel READ/EVAL/PRINT loop."
+ :report (lambda (s)
+ (write-string
+ (if script
+ ;; In case script calls (enable-debugger)!
+ "Abort script, exiting lisp."
+ "Skip to toplevel READ/EVAL/PRINT loop.")
+ s))
(/show0 "CONTINUEing from pre-REPL RESTART-CASE")
(values)) ; (no-op, just fall through)
(quit ()
:report "Quit SBCL (calling #'QUIT, killing the process)."
+ :test (lambda (c) (declare (ignore c)) (not script))
(/show0 "falling through to QUIT from pre-REPL RESTART-CASE")
(quit :unix-status 1))))
(with-simple-restart
(abort "~@<Exit debugger, returning to top level.~@:>")
(catch 'toplevel-catcher
- #!-win32 (sb!unix::reset-signal-mask)
;; In the event of a control-stack-exhausted-error, we
;; should have unwound enough stack by the time we get
;; here that this is now possible.
#!-win32
- (sb!kernel::protect-control-stack-guard-page 1)
+ (sb!kernel::reset-control-stack-guard-page)
(funcall repl-fun noprint)
(critically-unreachable "after REPL")))))))))
;;; handle the Unix-style EOF-is-end-of-process convention.
(defun repl-read-form-fun (in out)
(declare (type stream in out) (ignore out))
+ ;; KLUDGE: *READ-SUPPRESS* makes the REPL useless, and cannot be
+ ;; recovered from -- flip it here.
+ (when *read-suppress*
+ (warn "Setting *READ-SUPPRESS* to NIL to restore toplevel usability.")
+ (setf *read-suppress* nil))
(let* ((eof-marker (cons nil nil))
(form (read in nil eof-marker)))
(if (eq form eof-marker)
projects / sbcl.git / blobdiff