Ignore:
Timestamp:
Jan 25, 2008, 7:51:08 AM (12 years ago)
Author:
gb
Message:

Milliseconds, %timeval<=.

File:
1 edited

Legend:

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

    r8241 r8267  
    6666      (setq r 0)
    6767      (setq r (floor (* r 1000))))
     68    (values q r)))
     69
     70(defun microseconds (n)
     71  (unless (and (typep n 'fixnum)
     72               (>= (the fixnum n) 0))
     73    (check-type n (real 0 #xffffffff)))
     74  (multiple-value-bind (q r)
     75      (floor n)
     76    (if (zerop r)
     77      (setq r 0)
     78      (setq r (floor (* r 1000000))))
    6879    (values q r)))
    6980
     
    433444          (pref result :timeval.tv_usec) micros)
    434445    result))
     446
     447;;; Return T iff the time denoted by the timeval a is not later than the
     448;;; time denoted by the timeval b.
     449(defun %timeval<= (a b)
     450  (let* ((asec (pref a :timeval.tv_sec))
     451         (bsec (pref b :timeval.tv_sec)))
     452    (or (< asec bsec)
     453        (and (= asec bsec)
     454             (< (pref a :timeval.tv_usec)
     455                (pref b :timeval.tv_usec))))))
    435456
    436457
     
    828849         (token (external-process-token p))
    829850         (terminated))
    830     (loop
    831       (when (and terminated (null in-fd))
    832         (signal-semaphore (external-process-completed p))
    833         (return))
    834       (if in-fd
    835         (when (fd-input-available-p in-fd *ticks-per-second*)
    836           (%stack-block ((buf 1024))
    837             (let* ((n (fd-read in-fd buf 1024)))
    838               (declare (fixnum n))
    839               (if (<= n 0)
    840                 (progn
    841                   (without-interrupts
    842                    (decf (car token))
    843                    (fd-close in-fd)
    844                    (setq in-fd nil)))
    845                 (let* ((string (make-string 1024)))
    846                   (declare (dynamic-extent string))
    847                   (%str-from-ptr buf n string)
    848                   (write-sequence string out-stream :end n)))))))
    849       (let* ((statusflags (check-pid (external-process-pid p)
    850                                      (logior
    851                                       (if in-fd #$WNOHANG 0)
    852                                       #$WUNTRACED)))
    853              (oldstatus (external-process-%status p)))
    854         (cond ((null statusflags)
    855                (remove-external-process p)
    856                (setq terminated t))
    857               ((eq statusflags t))      ; Running.
    858               (t
    859                (multiple-value-bind (status code core)
    860                    (cond ((wifstopped statusflags)
    861                           (values :stopped (wstopsig statusflags)))
    862                          ((wifexited statusflags)
    863                           (values :exited (wexitstatus statusflags)))
    864                          (t
    865                           (let* ((signal (wtermsig statusflags)))
    866                             (declare (fixnum signal))
    867                             (values
    868                              (if (or (= signal #$SIGSTOP)
    869                                      (= signal #$SIGTSTP)
    870                                      (= signal #$SIGTTIN)
    871                                      (= signal #$SIGTTOU))
    872                                :stopped
    873                                :signaled)
    874                              signal
    875                              (logtest #$WCOREFLAG statusflags)))))
    876                  (setf (external-process-%status p) status
    877                        (external-process-%exit-code p) code
    878                        (external-process-core p) core)
    879                  (let* ((status-hook (external-process-status-hook p)))
    880                    (when (and status-hook (not (eq oldstatus status)))
    881                      (funcall status-hook p)))
    882                  (when (or (eq status :exited)
    883                            (eq status :signaled))
    884                    (remove-external-process p)
    885                    (setq terminated t)))))))))
     851    (rlet ((tv :timeval))
     852      (loop
     853        (when (and terminated (null in-fd))
     854          (signal-semaphore (external-process-completed p))
     855          (return))
     856        (when in-fd
     857          (when (fd-input-available-p in-fd tv)
     858            (%stack-block ((buf 1024))
     859              (let* ((n (fd-read in-fd buf 1024)))
     860                (declare (fixnum n))
     861                (if (<= n 0)
     862                  (progn
     863                    (without-interrupts
     864                     (decf (car token))
     865                     (fd-close in-fd)
     866                     (setq in-fd nil)))
     867                  (let* ((string (make-string 1024)))
     868                    (declare (dynamic-extent string))
     869                    (%str-from-ptr buf n string)
     870                    (write-sequence string out-stream :end n)))))))
     871        (let* ((statusflags (check-pid (external-process-pid p)
     872                                       (logior
     873                                        (if in-fd #$WNOHANG 0)
     874                                        #$WUNTRACED)))
     875               (oldstatus (external-process-%status p)))
     876          (cond ((null statusflags)
     877                 (remove-external-process p)
     878                 (setq terminated t))
     879                ((eq statusflags t))    ; Running.
     880                (t
     881                 (multiple-value-bind (status code core)
     882                     (cond ((wifstopped statusflags)
     883                            (values :stopped (wstopsig statusflags)))
     884                           ((wifexited statusflags)
     885                            (values :exited (wexitstatus statusflags)))
     886                           (t
     887                            (let* ((signal (wtermsig statusflags)))
     888                              (declare (fixnum signal))
     889                              (values
     890                               (if (or (= signal #$SIGSTOP)
     891                                       (= signal #$SIGTSTP)
     892                                       (= signal #$SIGTTIN)
     893                                       (= signal #$SIGTTOU))
     894                                 :stopped
     895                                 :signaled)
     896                               signal
     897                               (logtest #$WCOREFLAG statusflags)))))
     898                   (setf (external-process-%status p) status
     899                         (external-process-%exit-code p) code
     900                         (external-process-core p) core)
     901                   (let* ((status-hook (external-process-status-hook p)))
     902                     (when (and status-hook (not (eq oldstatus status)))
     903                       (funcall status-hook p)))
     904                   (when (or (eq status :exited)
     905                             (eq status :signaled))
     906                     (remove-external-process p)
     907                     (setq terminated t))))))))))
    886908     
    887909(defun run-external-process (proc in-fd out-fd error-fd &optional env)
Note: See TracChangeset for help on using the changeset viewer.