regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
-direct.h langinfo.h nl_types.h machine/fpu.h])
+direct.h langinfo.h nl_types.h machine/fpu.h poll.h])
# Reasons for testing:
# nl_item - lacking on Cygwin
# gmtime_r - recent posix, not on old systems
# pipe - not in mingw
# _pipe - specific to mingw, taking 3 args
+# poll - since posix 2001
# readdir_r - recent posix, not on old systems
# readdir64_r - not available on HP-UX 11.11
# stat64 - SuS largefile stuff, not on old systems
# utimensat: posix.1-2008
# sched_getaffinity, sched_setaffinity: GNU extensions (glibc)
#
-AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo utimensat sched_getaffinity sched_setaffinity])
+AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid getsid gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe poll readdir_r readdir64_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo utimensat sched_getaffinity sched_setaffinity])
# Reasons for testing:
# netdb.h - not in mingw
objprop.c \
options.c \
pairs.c \
+ poll.c \
ports.c \
print.c \
procprop.c \
objprop.h \
options.h \
pairs.h \
+ poll.h \
ports.h \
posix.h \
print.h \
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
+#include "libguile/poll.h"
#include "libguile/ports.h"
#include "libguile/posix.h"
#ifdef HAVE_REGCOMP
scm_register_foreign ();
scm_register_srfi_1 ();
scm_register_srfi_60 ();
+ scm_register_poll ();
scm_init_strings (); /* Requires array-handle */
scm_init_struct (); /* Requires strings */
--- /dev/null
+/* Copyright (C) 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+\f
+
+#define _GNU_SOURCE
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/numbers.h"
+#include "libguile/error.h"
+#include "libguile/validate.h"
+
+#include "libguile/poll.h"
+
+\f
+#ifdef HAVE_POLL_H
+#include <poll.h>
+#endif
+
+\f
+
+/* {Poll}
+ */
+
+/* Poll a set of file descriptors, waiting until one or more of them is
+ ready to perform input or output.
+
+ This is a low-level interface. See the `(ice-9 poll)' module for a more
+ usable wrapper.
+
+ `pollfds' is expected to be a bytevector, laid out in contiguous blocks of 64
+ bits. Each block has the format of one `struct pollfd': a 32-bit int file
+ descriptor, a 16-bit int events mask, and a 16-bit int revents mask.
+
+ The number of pollfd structures in `pollfds' is specified in
+ `nfds'. `pollfds' must be at least long enough to support that number of
+ structures. It may be longer, in which case the trailing entries are left
+ untouched.
+
+ The pollfds bytevector is modified directly, setting the returned events in
+ the final two bytes (the revents member).
+
+ If timeout is given and is non-negative, the poll will return after that
+ number of milliseconds if no fd became active.
+ */
+#ifdef HAVE_POLL
+static SCM
+scm_primitive_poll (SCM pollfds, SCM nfds, SCM timeout)
+#define FUNC_NAME "primitive-poll"
+{
+ int rv;
+ nfds_t c_nfds;
+ int c_timeout;
+ struct pollfd *fds;
+
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, pollfds);
+ c_nfds = scm_to_uint32 (nfds);
+ c_timeout = scm_to_int (timeout);
+
+ if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (pollfds)
+ < c_nfds * sizeof(struct pollfd)))
+ SCM_OUT_OF_RANGE (SCM_ARG1, nfds);
+
+ fds = (struct pollfd*)SCM_BYTEVECTOR_CONTENTS (pollfds);
+
+ SCM_SYSCALL (rv = poll (fds, c_nfds, c_timeout));
+
+ if (rv == -1)
+ SCM_SYSERROR;
+
+ return scm_from_int (rv);
+}
+#undef FUNC_NAME
+#endif /* HAVE_POLL */
+
+
+\f
+
+static void
+scm_init_poll (void)
+{
+#if HAVE_POLL
+ scm_c_define_gsubr ("primitive-poll", 3, 0, 0, scm_primitive_poll);
+#else
+ scm_misc_error ("%init-poll", "`poll' unavailable on this platform", SCM_EOL);
+#endif
+
+#ifdef POLLIN
+ scm_c_define ("POLLIN", scm_from_int (POLLIN));
+#endif
+#ifdef POLLPRI
+ scm_c_define ("POLLPRI", scm_from_int (POLLPRI));
+#endif
+#ifdef POLLOUT
+ scm_c_define ("POLLOUT", scm_from_int (POLLOUT));
+#endif
+#ifdef POLLRDHUP
+ scm_c_define ("POLLRDHUP", scm_from_int (POLLRDHUP));
+#endif
+#ifdef POLLERR
+ scm_c_define ("POLLERR", scm_from_int (POLLERR));
+#endif
+#ifdef POLLHUP
+ scm_c_define ("POLLHUP", scm_from_int (POLLHUP));
+#endif
+#ifdef POLLNVAL
+ scm_c_define ("POLLNVAL", scm_from_int (POLLNVAL));
+#endif
+
+}
+
+void
+scm_register_poll (void)
+{
+ scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+ "scm_init_poll",
+ (scm_t_extension_init_func) scm_init_poll,
+ NULL);
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
--- /dev/null
+/* classes: h_files */
+
+#ifndef SCM_POLL_H
+#define SCM_POLL_H
+
+/* Copyright (C) 2010 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+\f
+
+SCM_INTERNAL void scm_register_poll (void);
+
+#endif /* SCM_POLL_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
ice-9/occam-channel.scm \
ice-9/optargs.scm \
ice-9/poe.scm \
+ ice-9/poll.scm \
ice-9/popen.scm \
ice-9/posix.scm \
ice-9/q.scm \
--- /dev/null
+;; poll
+
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (ice-9 poll)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (rnrs bytevectors)
+ #:export (make-empty-poll-set
+ poll-set?
+ poll-set-nfds
+ poll-set-find-port
+ poll-set-port
+ poll-set-events
+ set-poll-set-events!
+ poll-set-revents
+ set-poll-set-revents!
+ poll-set-add!
+ poll-set-remove!
+ poll))
+
+(eval-when (eval load compile)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_poll"))
+
+(if (defined? 'POLLIN)
+ (export POLLIN))
+
+(if (defined? 'POLLPRI)
+ (export POLLPRI))
+
+(if (defined? 'POLLOUT)
+ (export POLLOUT))
+
+(if (defined? 'POLLRDHUP)
+ (export POLLRDHUP))
+
+(if (defined? 'POLLERR)
+ (export POLLERR))
+
+(if (defined? 'POLLHUP)
+ (export POLLHUP))
+
+(if (defined? 'POLLNVAL)
+ (export POLLNVAL))
+
+
+(define-record-type <poll-set>
+ (make-poll-set pollfds nfds ports)
+ poll-set?
+ (pollfds pset-pollfds set-pset-pollfds!)
+ (nfds poll-set-nfds set-pset-nfds!)
+ (ports pset-ports set-pset-ports!)
+ )
+
+(define-syntax pollfd-offset
+ (syntax-rules ()
+ ((_ n) (* n 8))))
+
+(define* (make-empty-poll-set #:optional (pre-allocated 4))
+ (make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0)
+ 0
+ (make-vector pre-allocated #f)))
+
+(define (pset-size set)
+ (vector-length (pset-ports set)))
+
+(define (ensure-pset-size! set size)
+ (let ((prev (pset-size set)))
+ (if (< prev size)
+ (let lp ((new prev))
+ (if (< new size)
+ (lp (* new 2))
+ (let ((old-pollfds (pset-pollfds set))
+ (nfds (poll-set-nfds set))
+ (old-ports (pset-ports set))
+ (new-pollfds (make-bytevector (pollfd-offset new) 0))
+ (new-ports (make-vector new #f)))
+ (bytevector-copy! old-pollfds 0 new-pollfds 0
+ (pollfd-offset nfds))
+ (vector-move-left! old-ports 0 nfds new-ports 0)
+ (set-pset-pollfds! set new-pollfds)
+ (set-pset-ports! set new-ports)))))))
+
+(define (poll-set-find-port set port)
+ (let lp ((i 0))
+ (if (< i (poll-set-nfds set))
+ (if (equal? (vector-ref (pset-ports set) i) port)
+ i
+ (lp (1+ i)))
+ #f)))
+
+(define (poll-set-port set idx)
+ (if (< idx (poll-set-nfds set))
+ (vector-ref (pset-ports set) idx)
+ (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-events set idx)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 4))
+ (error "poll set index out of bounds" set idx)))
+
+(define (set-poll-set-events! set idx events)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 4)
+ events)
+ (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-revents set idx)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-ref (pset-pollfds set) (+ (pollfd-offset idx) 6))
+ (error "poll set index out of bounds" set idx)))
+
+(define (set-poll-set-revents! set idx revents)
+ (if (< idx (poll-set-nfds set))
+ (bytevector-u16-native-set! (pset-pollfds set) (+ (pollfd-offset idx) 6)
+ revents)
+ (error "poll set index out of bounds" set idx)))
+
+(define (poll-set-add! set fd-or-port events)
+ (let* ((idx (poll-set-nfds set))
+ (off (pollfd-offset idx))
+ (fd (if (integer? fd-or-port)
+ fd-or-port
+ (port->fdes fd-or-port))))
+
+ (if (port? fd-or-port)
+ ;; As we store the port in the fdset, there is no need to
+ ;; increment the revealed count to prevent the fd from being
+ ;; closed by a gc'd port.
+ (release-port-handle fd-or-port))
+
+ (ensure-pset-size! set (1+ idx))
+ (bytevector-s32-native-set! (pset-pollfds set) off fd)
+ (bytevector-u16-native-set! (pset-pollfds set) (+ off 4) events)
+ (bytevector-u16-native-set! (pset-pollfds set) (+ off 6) 0) ; revents
+ (vector-set! (pset-ports set) idx fd-or-port)
+ (set-pset-nfds! set (1+ idx))))
+
+(define (poll-set-remove! set idx)
+ (if (not (< idx (poll-set-nfds set)))
+ (error "poll set index out of bounds" set idx))
+ (let ((nfds (poll-set-nfds set))
+ (off (pollfd-offset idx))
+ (port (vector-ref (pset-ports set) idx)))
+ (vector-move-left! (pset-ports set) (1+ idx) nfds
+ (pset-ports set) idx)
+ (vector-set! (pset-ports set) (1- nfds) #f)
+ (bytevector-copy! (pset-pollfds set) (pollfd-offset (1+ idx))
+ (pset-pollfds set) off
+ (- (pollfd-offset nfds) (pollfd-offset (1+ idx))))
+ ;; zero the struct pollfd all at once
+ (bytevector-u64-native-set! (pset-pollfds set) (pollfd-offset (1- nfds)) 0)
+ (set-pset-nfds! set (1- nfds))
+ port))
+
+(define* (poll poll-set #:optional (timeout -1))
+ (primitive-poll (pset-pollfds poll-set)
+ (poll-set-nfds poll-set)
+ timeout))
HCoop / bpt / guile.git / commitdiff