mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 20:30:28 +02:00
Code Activity

* expect.scm: use gettimeofday instead of get-internal-real-time

Browse source 
and use a floating point timeout when calling select.  Untested,
since the regex library is currently AWOL.
This commit is contained in:
Gary Houston 1997-05-15 08:48:38 +00:00
parent a48a89bc17
commit cafa4c681e
2 changed files with 19 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

6
ice-9/ChangeLog
View file

@ -1,3 +1,9 @@
Thu May 15 07:56:08 1997 Gary Houston <ghouston@actrix.gen.nz>
* expect.scm: use gettimeofday instead of get-internal-real-time
and use a floating point timeout when calling select. Untested,
since the regex library is currently AWOL.
Wed May 14 21:00:30 1997 Jim Blandy <jimb@floss.cyclic.com> Wed May 14 21:00:30 1997 Jim Blandy <jimb@floss.cyclic.com>
* boot-9.scm (eval-string): Function deleted; it was already * boot-9.scm (eval-string): Function deleted; it was already

23
ice-9/expect.scm
View file

@ -38,9 +38,13 @@
(timeout (gentemp))) (timeout (gentemp)))
`(let ((,s "") `(let ((,s "")
(,port (or expect-port (current-input-port))) (,port (or expect-port (current-input-port)))
;; when timeout occurs, in floating point seconds.
(,timeout (if expect-timeout (,timeout (if expect-timeout
(+ (* expect-timeout internal-time-units-per-second) (let* ((secs-usecs (gettimeofday)))
(get-internal-real-time)) (+ (car secs-usecs)
expect-timeout
(/ (cdr secs-usecs)
1000000))) ; one million.
#f))) #f)))
(let next-char () (let next-char ()
(if (and expect-timeout (if (and expect-timeout
@ -111,14 +115,13 @@
body)))))))) body))))))))
;;; simplified select: returns #t if input is waiting or #f if timed out. ;;; simplified select: returns #t if input is waiting or #f if timed out.
;;; timeout is absolute in terms of get-internal-real-time. ;;; timeout is an absolute time in floating point seconds.
(define (expect-select port timeout) (define (expect-select port timeout)
(let* ((relative (/ (- timeout (get-internal-real-time)) (let* ((secs-usecs (gettimeofday))
internal-time-units-per-second)) (relative (- timeout
(relative-s (inexact->exact (floor relative))) (car secs-usecs)
(relative-ms (inexact->exact (/ (cdr secs-usecs)
(round (* (- relative relative-s) 1000))))) 1000000)))) ; one million.
(and (> relative 0) (and (> relative 0)
(pair? (car (select (list port) () () (pair? (car (select (list port) () ()
relative-s relative))))))
relative-ms))))))