scsh-0.6/scsh/select.scm

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

(foreign-init-name "select")


(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.

; The following routines copy ports to fd's, and copy fd's back to fd's and
; ports, so that select can take numbers and ports, simultaneously.

; This is a C procedure in scheme.  So sue me.  At least it's tail-recursive
(define (fd-filter filter-me)
  (let* ((len (vector-length filter-me))
	 (vector-to-return (make-vector len)))
    (let loop ((count (- len 1)))
      (if (>= count 0)
	  (let ((ref (vector-ref filter-me count)))
	    (if (integer? ref)
		(vector-set! vector-to-return count ref)
		(vector-set! vector-to-return count (port->fdes ref)))
	    (loop (- count 1)))))
    vector-to-return))

; ! means side-effect, the next one is more functional.
(define (fd-copyback! orig form)
  (let loop ((count (- (vector-length orig) 1)))
    (if (>= count 0)
	(begin
	  (if (not (vector-ref form count))
	      (vector-set! orig count #f)
	      (vector-set! form count (vector-ref orig count)))
	  (loop (- count 1)))))
  orig)

(define (fd-copyback orig form)
  (let* ((len (vector-length orig))
	 (vector-to-return (make-vector len #f)))
    (let loop ((count (- len 1)))
      (if (>= count 0)
	  (begin
	    (if (vector-ref form count)
		(vector-set! vector-to-return count (vector-ref orig count)))
	    (loop (- count 1)))))
    vector-to-return))
    
(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! rv wv ev maybe-timeout)
      (values (vector-take-form read-vec rv nr)
	      (vector-take-form write-vec wv nw)
	      (vector-take-form exception-vec 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 ((prop-read-vec (fd-filter read-vec))
	  (prop-write-vec (fd-filter write-vec))
	  (prop-exception-vec (fd-filter exception-vec)))
      (let lp ()
	(receive (errno nr nw ne)
		 (%select/copyback/errno prop-read-vec prop-write-vec prop-exception-vec timeout)
  	  (if (and errno (= errno errno/intr))	; Retry on interrupts.
	      (lp)
	      (values errno 
		      (fd-copyback read-vec nr)
		      (fd-copyback write-vec nw)
		      (fd-copyback exception-vec 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-form vec form nelts)
  (let ((short (make-vector nelts)))
    (do ((i (- (vector-length vec) 1) (- i 1)))
	((< i 0))
      (if (vector-ref form i)
	  (begin
	    (set! nelts (- nelts 1))
	    (vector-set! short nelts (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 ((prop-read-vec (fd-filter read-vec))
	  (prop-write-vec (fd-filter write-vec))
	  (prop-exception-vec (fd-filter exception-vec)))
      (let lp ()
	(receive (errno nr nw ne)
		 (%select!/errno prop-read-vec prop-write-vec prop-exception-vec timeout)
  	  (if (and errno (= errno errno/intr))	; Retry on interrupts.
	      (lp)
	      (begin
		(fd-copyback! read-vec prop-read-vec)
		(fd-copyback! write-vec prop-write-vec)
		(fd-copyback! exception-vec prop-exception-vec)
		(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