scsh-0.5/scsh/select.scm

;;; select(2) syscall for scsh. -*- Scheme -*-
;;; Copyright (c) 1995 by Olin Shivers.

(foreign-source
  "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  "#include \"select1.h\""
  "" "")

;;; TIMEOUT is 0 for immediate, >0 for timeout, #f for infinite; 
;;;     default is #f.
;;; The sets are vectors of file descriptors & fd ports.
;;; You get three new vectors back.

(define (select read-set write-set exception-set . maybe-timeout)
  (receive (errno rs ws es)
           (apply select/errno read-set write-set exception-set maybe-timeout)
     (if errno
	 (apply errno-error errno select read-set write-set exception-set
		maybe-timeout)
	 (values rs ws es))))

(define (select/errno read-set write-set exception-set . maybe-timeout)
  (let ((timeout (optional-arg maybe-timeout #f))
	(vec-ok? (lambda (v)
		   (vector-every? (lambda (elt)
				    (or (and (integer? elt) (>= elt 0))
					(fdport? elt)))
				  v))))
    ;; Type-check input vectors.
    (check-arg vec-ok?      read-set select/errno)
    (check-arg vec-ok?     write-set select/errno)
    (check-arg vec-ok? exception-set select/errno)
    (check-arg (lambda (x) (or (not x) (integer? x))) timeout select/errno)
	
    (let lp ()
      (receive (errno rsize wsize esize)
	       (%select/errno read-set write-set exception-set timeout)
	(cond ((not errno)
	       (values errno
		       (vector-take read-set      rsize)
		       (vector-take write-set     wsize)
		       (vector-take exception-set esize)))
	      ((= errno errno/intr) (lp))
	      (else (values errno '#() '#() '#())))))))


(define-foreign %select/errno
  (scm_select (vector-desc rvec)
	      (vector-desc wvec)
	      (vector-desc evec)
	      (desc nsecs))		; Integer or #f for infinity.
  desc		; errno or #f
  fixnum	; nread   - number of hits in RVEC
  fixnum	; nwrite  - number of hits in WVEC
  fixnum)	; nexcept - number of hits in EVEC


(define (vector-take vec nelts)
  (let ((short (make-vector nelts)))
    (do ((i (- nelts 1) (- i 1)))
	((< i 0))
      (vector-set! short i (vector-ref vec i)))
    short))