Changeset 13972


Ignore:
Timestamp:
Jul 17, 2010, 10:19:58 AM (9 years ago)
Author:
gb
Message:

Lisp side of WAIT-FOR-SIGNAL.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/linux-files.lisp

    r13675 r13972  
    171171  (%signal-semaphore-ptr (semaphore-value s)))
    172172
     173(defun %timed-wait-for-signal (signo seconds millis)
     174  (let* ((status (ff-call
     175                  (%kernel-import target::kernel-import-wait-for-signal)
     176                  :int signo
     177                  :unsigned seconds
     178                  :unsigned millis
     179                  :int)))
     180    (values (eql status 0) status)))
     181
     182(defun wait-for-signal (s duration)
     183  (or (%timed-wait-for-signal s 0 0)
     184      (with-process-whostate ("signal wait")
     185        (let* ((now (get-internal-real-time))
     186               (stop (+ now (floor (* duration internal-time-units-per-second)))))
     187          (multiple-value-bind (secs millis) (milliseconds duration)
     188            (loop
     189              (multiple-value-bind (success err)
     190                  (progn
     191                    (%timed-wait-for-signal s secs millis))
     192                (when success
     193                  (return t))
     194                (if (or (eql err #$ETIMEDOUT)
     195                        (>= (setq now (get-internal-real-time)) stop))
     196                  (return nil)
     197                  (unless (eql err #$EINTR)
     198                    (error "Error waiting for signal ~d: ~a." s (%strerror err))))
     199                (when (or (not (eql err #$EINTR))
     200                          (>= (setq now (get-internal-real-time)) stop))
     201                  (return nil))
     202                (unless (zerop duration)
     203                  (let* ((diff (- stop now)))
     204                    (multiple-value-bind (remaining-seconds remaining-itus)
     205                        (floor diff internal-time-units-per-second)
     206                      (setq secs remaining-seconds
     207                            millis (floor remaining-itus (/ internal-time-units-per-second 1000)))))))))))))
     208 
    173209(defun %os-getcwd (buf noctets)
    174210  ;; Return N < 0, if error
Note: See TracChangeset for help on using the changeset viewer.