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-vec write-vec exception-vec . maybe-timeout)
  (let ((rv (copy-vector read-vec))
	(wv (copy-vector write-vec))
	(ev (copy-vector exception-vec)))
    (receive (nr nw ne) (apply select!/copyback rv wv ev maybe-timeout)
      (values (vector-take rv nr)
	      (vector-take wv nw)
	      (vector-take ev ne)))))


(define (select!/copyback read-vec write-vec exception-vec . maybe-timeout)
  (receive (errno nr nw ne)
           (apply select!/copyback/errno read-vec write-vec exception-vec
		                         maybe-timeout)
     (if errno
	 (apply errno-error errno select!/copyback
		read-vec write-vec exception-vec maybe-timeout)
	 (values nr nw ne))))


(define (select!/copyback/errno read-vec write-vec
				exception-vec . maybe-timeout)
  (let ((timeout (and (pair? maybe-timeout)
		      (if (pair? (cdr maybe-timeout))
			  (apply error "Too many arguments"
				 select!/copyback/errno
				 read-vec write-vec exception-vec
				 maybe-timeout)
			  (real->exact-integer (check-arg real?
							  (car maybe-timeout)
							  select!/copyback/errno)))))
		     
	(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-vec select!/copyback/errno)
    (check-arg vec-ok?     write-vec select!/copyback/errno)
    (check-arg vec-ok? exception-vec select!/copyback/errno)
    (check-arg (lambda (x) (or (not x) (integer? x))) timeout
	       select!/copyback/errno)

    (let lp ()
      (receive (errno nr nw ne)
	       (%select/copyback/errno read-vec write-vec exception-vec timeout)
	(if (and errno (= errno errno/intr))	; Retry on interrupts.
	    (lp)
	    (values errno nr nw ne))))))


(define-foreign %select/copyback/errno
  (select_copyback (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))


;;; SELECT!
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The side-effecting variant. To be documented.

(define (select! read-vec write-vec exception-vec . maybe-timeout)
  (receive (errno nr nw ne)
           (apply select!/errno read-vec write-vec exception-vec maybe-timeout)
     (if errno
	 (apply errno-error errno select! read-vec write-vec exception-vec
		maybe-timeout)
	 (values nr nw ne))))

(define (select!/errno read-vec write-vec exception-vec . maybe-timeout)
  (let ((timeout (and (pair? maybe-timeout)
		      (if (pair? (cdr maybe-timeout))
			  (apply error "Too many arguments"
				 select!/copyback/errno
				 read-vec write-vec exception-vec
				 maybe-timeout)
			  (real->exact-integer (check-arg real?
							  (car maybe-timeout)
							  select!/copyback/errno)))))
		     
	(vec-ok? (lambda (v)
		   (vector-every? (lambda (elt)
				    (or (and (integer? elt) (>= elt 0))
					(not elt)
					(fdport? elt)))
				  v))))
    ;; Type-check input vectors.
    (check-arg vec-ok?      read-vec select!/errno)
    (check-arg vec-ok?     write-vec select!/errno)
    (check-arg vec-ok? exception-vec select!/errno)
    (check-arg (lambda (x) (or (not x) (integer? x))) timeout select!/errno)
	
    (let lp ()
      (receive (errno nr nw ne)
	       (%select!/errno read-vec write-vec exception-vec timeout)
	(if (and errno (= errno errno/intr))	; Retry on interrupts.
	    (lp)
	    (values errno nr nw ne))))))


(define-foreign %select!/errno
  (select_filter (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