Changeset 13526

Timestamp:

Mar 12, 2010, 1:47:33 PM (15 years ago)

Author:

gz

Message:

From trunk: fix time computations in %timed-wait-on-semaphore-ptr (r13414, r13415, r13525)

Location:

branches/working-0711/ccl

Files:

• . (modified) (1 prop)
• level-1/linux-files.lisp (modified) (5 diffs)

branches/working-0711/ccl/level-1/linux-files.lisp

@@ -59 +59 @@
       (%get-cstring pointer))))
 
-(defun nanoseconds (n)
-  (unless (and (typep n 'fixnum)
-               (>= (the fixnum n) 0))
-    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
+(defun nanoseconds (seconds)
+  (when (and (typep seconds 'fixnum)
+             (>= (the fixnum seconds) 0))
+    (return-from nanoseconds (values seconds 0)))
+  (check-type seconds (real 0 #.(1- (ash 1 (1- target::nbits-in-word)))))
   (multiple-value-bind (q r)
-      (floor n)
+      (floor seconds)
     (if (zerop r)
       (setq r 0)
@@ -70 +71 @@
     (values q r)))
 
-(defun milliseconds (n)
-  (unless (and (typep n 'fixnum)
-               (>= (the fixnum n) 0))
-    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
+(defun milliseconds (seconds)
+  (when (and (typep seconds 'fixnum)
+             (>= (the fixnum seconds) 0))
+    (return-from milliseconds (values seconds 0)))
+  (check-type seconds (real 0 #.(1- (ash 1 (1- target::nbits-in-word)))))
   (multiple-value-bind (q r)
-      (floor n)
+      (floor seconds)
     (if (zerop r)
       (setq r 0)
@@ -81 +83 @@
     (values q r)))
 
-(defun microseconds (n)
-  (unless (and (typep n 'fixnum)
-               (>= (the fixnum n) 0))
-    (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word))))))
+(defun microseconds (seconds)
+  (when (and (typep seconds 'fixnum)
+             (>= (the fixnum seconds) 0))
+    (return-from microseconds (values seconds 0)))
+  (check-type seconds (real 0 #.(1- (ash 1 (1- target::nbits-in-word)))))
   (multiple-value-bind (q r)
-      (floor n)
+      (floor seconds)
     (if (zerop r)
       (setq r 0)
@@ -133 +136 @@
   (or (%wait-on-semaphore-ptr semptr 0 0 notification)
       (with-process-whostate ("Semaphore timed wait")
-        (multiple-value-bind (secs millis) (milliseconds duration)
-          (let* ((now (get-internal-real-time))
-                 (stop (+ now
-                          (* secs 1000)
-                          millis)))
+        (let* ((now (get-internal-real-time))
+               (stop (+ now (floor (* duration internal-time-units-per-second)))))
+          (multiple-value-bind (secs millis) (milliseconds duration)
             (loop
               (multiple-value-bind (success err)
@@ -149 +150 @@
                 (unless (zerop duration)
                   (let* ((diff (- stop now)))
-                    (multiple-value-bind (remaining-seconds remaining-millis)
-                        (floor diff 1000)
+                    (multiple-value-bind (remaining-seconds remaining-itus)
+                        (floor diff internal-time-units-per-second)
                       (setq secs remaining-seconds
-                            millis remaining-millis)))))))))))
+                            millis (floor remaining-itus (/ internal-time-units-per-second 1000)))))))))))))
 
 (defun timed-wait-on-semaphore (s duration &optional notification)