delete ye olde FIXME relating to unbound variable warnings

[sbcl.git] / src / code / toplevel.lisp

diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index 9fa8189..97199db 100644 (file)
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -30,6 +30,7 @@
                   *allow-with-interrupts*
                   *interrupts-enabled*
                   *interrupt-pending*
+                  #!+sb-thruption *thruption-pending*
                   *type-system-initialized*))
 
 (defvar *cold-init-complete-p*)
@@ -107,13 +108,18 @@ means to wait indefinitely.")
 (defun %exit ()
   ;; If anything goes wrong, we will exit immediately and forcibly.
   (handler-bind ((serious-condition *exit-error-handler*))
-    (let (ok)
-      (unwind-protect
-           (progn
-             (flush-standard-output-streams)
-             (sb!thread::%exit-other-threads)
-             (setf ok t))
-        (os-exit *exit-in-process* :abort (not ok))))))
+    (let ((ok nil)
+          (code *exit-in-process*))
+      (if (consp code)
+          ;; Another thread called EXIT, and passed the buck to us -- only
+          ;; final call left to do.
+          (os-exit (car code) :abort nil)
+          (unwind-protect
+               (progn
+                 (flush-standard-output-streams)
+                 (sb!thread::%exit-other-threads)
+                 (setf ok t))
+            (os-exit code :abort (not ok)))))))
 \f
 ;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
 
@@ -125,7 +131,7 @@ means to wait indefinitely.")
      (let ((*current-error-depth* (1+ *current-error-depth*)))
        (/show0 "in INFINITE-ERROR-PROTECT, incremented error depth")
        ;; arbitrary truncation
-       #!+sb-show (sb!debug:backtrace 8)
+       #!+sb-show (sb!debug:print-backtrace :count 8)
        ,@forms)))
 
 ;;; a helper function for INFINITE-ERROR-PROTECT
@@ -153,38 +159,34 @@ means to wait indefinitely.")
         (t
          (/show0 "returning normally from INFINITE-ERROR-PROTECTOR")
          nil)))
-
-;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at
-;;; one point (shown below), and SBCL cross-compiled it without
-;;; warning about FORMS being undefined. Check whether that problem
-;;; (missing warning) is repeatable in the final system and if so, fix
-;;; it.
-#|
-(defun infinite-error-protector ()
-  `(cond ((not *cold-init-complete-p*)
-          (%primitive print "Argh! error in cold init, halting")
-          (%primitive sb!c:halt))
-         ((or (not (boundp '*current-error-depth*))
-              (not (realp   *current-error-depth*))
-              (not (boundp '*maximum-error-depth*))
-              (not (realp   *maximum-error-depth*)))
-          (%primitive print "Argh! corrupted error depth, halting")
-          (%primitive sb!c:halt))
-         ((> *current-error-depth* *maximum-error-depth*)
-          (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
-          (error-error "Help! "
-                       *current-error-depth*
-                       " nested errors. "
-                       "SB-KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
-          (progn ,@forms)
-          t)
-         (t
-          (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally")
-          nil)))
-|#
 \f
 ;;;; miscellaneous external functions
 
+(defun split-seconds-for-sleep (seconds)
+  (declare (optimize speed))
+  (flet ((split-float ()
+           ;; KLUDGE: This whole thing to avoid consing floats
+           (let ((whole-seconds (truly-the fixnum (%unary-truncate seconds))))
+             (values whole-seconds
+                     (truly-the fixnum
+                                (%unary-truncate (* (- seconds whole-seconds)
+                                                    (load-time-value 1s9 t))))))))
+    (declare (inline split-float))
+    (typecase seconds
+      ((single-float 0s0 #.(float most-positive-fixnum 1s0))
+       (split-float))
+      ((double-float 0d0 #.(float most-positive-fixnum 1d0))
+       (split-float))
+      (ratio
+       (multiple-value-bind (quot rem) (truncate (numerator seconds)
+                                                 (denominator seconds))
+         (values quot
+                 (* rem (/ 1000000000 (denominator seconds))))))
+      (t
+       (multiple-value-bind (sec frac)
+           (truncate seconds)
+         (values sec (truncate frac (load-time-value 1s-9 t))))))))
+
 (defun sleep (seconds)
   #!+sb-doc
   "This function causes execution to be suspended for SECONDS. SECONDS may be
@@ -192,17 +194,16 @@ any non-negative real number."
   (when (or (not (realp seconds))
             (minusp seconds))
     (error 'simple-type-error
-           :format-control "invalid argument to SLEEP: ~S"
+           :format-control "Invalid argument to SLEEP: ~S, ~
+                            should be a non-negative real."
            :format-arguments (list seconds)
            :datum seconds
            :expected-type '(real 0)))
-  #!-win32
+  #!-(and win32 (not sb-thread))
   (multiple-value-bind (sec nsec)
       (if (integerp seconds)
           (values seconds 0)
-          (multiple-value-bind (sec frac)
-              (truncate seconds)
-            (values sec (truncate frac 1e-9))))
+          (split-seconds-for-sleep seconds))
     ;; 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?
@@ -210,7 +211,7 @@ any non-negative real number."
           do (decf sec (expt 10 8))
              (sb!unix:nanosleep (expt 10 8) 0))
     (sb!unix:nanosleep sec nsec))
-  #!+win32
+  #!+(and win32 (not sb-thread))
   (sb!win32:millisleep (truncate (* seconds 1000)))
   nil)
 \f
@@ -490,7 +491,8 @@ any non-negative real number."
 
     ;; Delete all the options that we processed, so that only
     ;; user-level options are left visible to user code.
-    (setf (rest *posix-argv*) options)
+    (when *posix-argv*
+      (setf (rest *posix-argv*) options))
 
     ;; Disable debugger before processing initialization files & co.
     (when disable-debugger