Welcome to the CHICKEN Scheme pasting service

From 5edb8a1c3094e5804507375e345123acfff325d1 Mon Sep 17 00:00:00 2001
From: Jim Ursetto 
Date: Mon, 11 Jul 2011 02:17:22 -0500
Subject: [PATCH] revamp polling with opaque poll item object

---
 zmq.scm |  156 ++++++++++++++++++++++++++++++++-------------------------------
 1 files changed, 80 insertions(+), 76 deletions(-)

diff --git a/zmq.scm b/zmq.scm
index c226478..891c477 100644
--- a/zmq.scm
+++ b/zmq.scm
@@ -5,8 +5,11 @@
  make-socket socket? close-socket bind-socket connect-socket
  socket-option-set! socket-option socket-fd
  send-message receive-message receive-message*
- make-poll-item poll poll-item-socket
- poll-item-fd poll-item-in? poll-item-out? poll-item-error?)
+ poll poll-items
+ for-each-poll-item
+ ;; make-poll-item poll-item-socket
+ ;; poll-item-fd poll-item-in? poll-item-out? poll-item-error?
+ )
 
 (import (except chicken errno) scheme foreign data-structures)
 (use lolevel foreigners srfi-1 srfi-18 srfi-13)
@@ -351,79 +354,80 @@
 
 ;; polling
 
-(define %make-poll-item make-poll-item)
-
-(define (make-poll-item socket/fd #!key in out)
-  (let ((item (%make-poll-item (make-foreign-poll-item)
-                               (and (socket? socket/fd) socket/fd)
-                               in out)))
-    (if (socket? socket/fd)
-        (%poll-item-socket-set! (poll-item-pointer item) (socket-pointer socket/fd))
-        (%poll-item-fd-set! (poll-item-pointer item) socket/fd))
-
-    (%poll-item-events-set! (poll-item-pointer item)
-                            (bitwise-ior (if in zmq/pollin 0)
-                                         (if out zmq/pollout 0)))
-
-    (%poll-item-revents-set! (poll-item-pointer item) 0)
-
-    (set-finalizer! item (lambda (i) 
-                           (free-foreign-poll-item (poll-item-pointer i))))))
-
-(define (poll-item-fd item)
-  (%poll-item-fd (poll-item-pointer item)))
-
-(define (poll-item-revents item)
-  (%poll-item-revents (poll-item-pointer item)))
-
-(define (poll-item-in? item)
-  (not (zero? (bitwise-and zmq/pollin (poll-item-revents item)))))
-
-(define (poll-item-out? item)
-  (not (zero? (bitwise-and zmq/pollout (poll-item-revents item)))))
-
-(define (poll-item-error? item)
-  (not (zero? (bitwise-and zmq/pollerr (poll-item-revents item)))))
-
+(define _zmq_pollitem_size (foreign-value "sizeof(zmq_pollitem_t)" int))
+(define %poll-items-init/socket
+  (foreign-lambda* void ((scheme-pointer p) (int i) (socket s) (short events))
+    "zmq_pollitem_t *pi = (zmq_pollitem_t *)p+i;"
+    "pi->socket = s; pi->fd = 0; pi->events = events; pi->revents = 0;"))
+(define %poll-items-init/fd
+  (foreign-lambda* void ((scheme-pointer p) (int i) (int fd) (short events))
+    "zmq_pollitem_t *pi = (zmq_pollitem_t *)p+i;"
+    "pi->socket = 0; pi->fd = fd; pi->events = events; pi->revents = 0;"))
+(define %poll-items-in?
+  (foreign-lambda* bool ((scheme-pointer p) (int i))
+    "return(((zmq_pollitem_t *)p+i)->revents & ZMQ_POLLIN);"))
+(define %poll-items-out?
+  (foreign-lambda* bool ((scheme-pointer p) (int i))
+    "return(((zmq_pollitem_t *)p+i)->revents & ZMQ_POLLOUT);"))
 (define %poll-sockets
-  (foreign-safe-lambda* int
-                        ((scheme-object poll_item_ref)
-                         (unsigned-int length)
-                         (long timeout))
-                        "zmq_pollitem_t items[length];
-                         zmq_pollitem_t *item_ptrs[length];
-                         int i;
-
-                         for (i = 0; i < length; i++) {
-                           C_save(C_fix(i));
-                           item_ptrs[i] = (zmq_pollitem_t *)C_pointer_address(C_callback(poll_item_ref, 1));
-                         }
-
-                         for (i = 0; i < length; i++) {
-                           items[i] = *item_ptrs[i];
-                         }
-
-                         int rc = zmq_poll(items, length, timeout);
-
-                         if (rc != -1) {
-                           for (i = 0; i < length; i++) {
-                             (*item_ptrs[i]).revents = items[i].revents;
-                           }
-                         }
-
-                         C_return(rc);"))
-
-(define (poll poll-items timeout/block)
-  (if (null? poll-items)
-      (error 'poll "null list passed for poll-items")
-      (let ((result (%poll-sockets (lambda (i) 
-                                     (poll-item-pointer (list-ref poll-items i)))
-                                   (length poll-items)
-                                   (case timeout/block
-                                     ((#f) 0)
-                                     ((#t) -1)
-                                     (else timeout/block)))))
-        (if (= result -1)
-            (zmq-error 'poll)
-            result))))
+  (foreign-lambda* int ((scheme-pointer p)
+                        (unsigned-int length) (long timeout))
+    "return(zmq_poll((zmq_pollitem_t *)p, length, timeout));"))
+
+(define-record poll-items store sockets)   ;; blob, vector
+(define (poll-items-length items)
+  (vector-length (poll-items-sockets items)))
+(define (poll-items-socket items i)             ;; can also be used for fds
+  (vector-ref (poll-items-sockets items) i))
+(define (poll-items-in? items i)
+  (when (or (< i 0) (>= i (poll-items-length items)))
+        (error 'poll-items-out? "index out of range" i items))
+  (%poll-items-in? (poll-items-store items) i))
+(define (poll-items-out? items i)
+  (when (or (< i 0) (>= i (poll-items-length items)))
+    (error 'poll-items-out? "index out of range" i items))
+  (%poll-items-out? (poll-items-store items) i))
+
+(define (poll-items in out)
+  (let* ((ilen (length in))
+         (olen (length out))
+         (len (+ ilen olen)))
+    (when (= 0 len)
+      (error 'poll-items "no items to poll"))
+    (let ((store (make-blob (* _zmq_pollitem_size len))))
+      (let loop ((i 0) (in in))
+        (unless (null? in)
+          (let ((s (car in)))
+            (if (socket? s)
+                (%poll-items-init/socket store i (socket-pointer s) zmq/pollin)
+                (%poll-items-init/fd store i s zmq/pollin)))
+          (loop (+ i 1) (cdr in))))
+      (let loop ((i ilen) (out out))
+        (unless (null? out)
+          (let ((s (car out)))
+            (if (socket? s)
+                (%poll-items-init/socket store i (socket-pointer s) zmq/pollout)
+                (%poll-items-init/fd store i s zmq/pollout)))
+          (loop (+ i 1) (cdr out))))
+      (make-poll-items store (list->vector (append in out))))))
+
+(define (poll items timeout/block)
+  (let ((result (%poll-sockets (poll-items-store items)
+                               (poll-items-length items)
+                               (case timeout/block
+                                 ((#f) 0)
+                                 ((#t) -1)
+                                 (else timeout/block)))))
+    (if (= result -1)
+        (zmq-error 'poll)
+        result)))
+
+(define (for-each-poll-item items in out)
+  (do ((i 0 (+ i 1)))
+      ((= i (poll-items-length items)))
+    (cond ((poll-items-in? items i)
+           (in (poll-items-socket items i)))
+          ((poll-items-out? items i)
+           (out (poll-items-socket items i))))))
+
 )
-- 
1.7.4.1