mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-15 16:20:17 +02:00
add (ice-9 poll), a poll wrapper
* libguile/poll.c: * libguile/poll.h: * module/ice-9/poll.scm: New module, (ice-9 poll). * module/Makefile.am: * libguile/init.c: * libguile/Makefile.am: Adapt. * configure.ac: Check for poll.h and poll.
This commit is contained in:
Andy Wingo
parent
0d4e6ca38f
commit
6f81b18abe
7 changed files with 367 additions and 2 deletions
|
|
@ -644,7 +644,7 @@ AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h proces
|
|||
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
|
||||
|
|
@ -741,6 +741,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
|
|||
# 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
|
||||
|
|
@ -753,7 +754,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
|
|||
# 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
|
||||
|
|
|
|||
|
|
@ -170,6 +170,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
|
|||
objprop.c \
|
||||
options.c \
|
||||
pairs.c \
|
||||
poll.c \
|
||||
ports.c \
|
||||
print.c \
|
||||
procprop.c \
|
||||
|
|
@ -541,6 +542,7 @@ modinclude_HEADERS = \
|
|||
objprop.h \
|
||||
options.h \
|
||||
pairs.h \
|
||||
poll.h \
|
||||
ports.h \
|
||||
posix.h \
|
||||
print.h \
|
||||
|
|
|
|||
|
|
@ -88,6 +88,7 @@
|
|||
#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
|
||||
|
|
@ -459,6 +460,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
|
|||
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 */
|
||||
|
|
|
|||
146
libguile/poll.c
Normal file
146
libguile/poll.c
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
/* 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 _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"
|
||||
|
||||
|
||||
#ifdef HAVE_POLL_H
|
||||
#include <poll.h>
|
||||
#endif
|
||||
|
||||
|
||||
|
||||
/* {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 */
|
||||
|
||||
|
||||
|
||||
|
||||
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:
|
||||
*/
|
||||
38
libguile/poll.h
Normal file
38
libguile/poll.h
Normal file
|
|
@ -0,0 +1,38 @@
|
|||
/* 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
|
||||
*/
|
||||
|
||||
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
|
||||
|
||||
SCM_INTERNAL void scm_register_poll (void);
|
||||
|
||||
#endif /* SCM_POLL_H */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
||||
|
|
@ -200,6 +200,7 @@ ICE_9_SOURCES = \
|
|||
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 \
|
||||
|
|
|
|||
175
module/ice-9/poll.scm
Normal file
175
module/ice-9/poll.scm
Normal file
|
|
@ -0,0 +1,175 @@
|
|||
;; 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))
|
||||
Loading…
Add table
Add a link
Reference in a new issue