/*
  Racket
  Copyright (c) 2004-2016 PLT Design Inc.
  Copyright (c) 2000-2001 Matthew Flatt

    This library is free software; you can redistribute it and/or
    modify it under the terms of the GNU Library General Public
    License as published by the Free Software Foundation; either
    version 2 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
    Library General Public License for more details.

    You should have received a copy of the GNU Library 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.

  libscheme
  Copyright (c) 1994 Brent Benson
  All rights reserved.
*/

/* This file implements the TCP and UDP interfaces. */

#include "schpriv.h"
#include <ctype.h>

#ifndef NO_TCP_SUPPORT
#ifdef USE_TCP

#ifdef UNISTD_INCLUDE
# include <unistd.h>
#endif
#ifdef USE_ULIMIT
# include <ulimit.h>
#endif
#ifdef FILES_HAVE_FDS
# include <sys/types.h>
# include <sys/time.h>
# ifdef BSTRING_INCLUDE
#  include <bstring.h>
# endif
# ifdef SELECT_INCLUDE
#  include <sys/select.h>
# endif
# ifdef HAVE_POLL_SYSCALL
#  include <poll.h>
# endif
#endif
#ifdef IO_INCLUDE
# include <io.h>
#endif
#ifdef INCLUDE_OSKIT_SOCKET
# include <oskit/net/socket.h>
#endif
#ifdef NO_ERRNO_GLOBAL
static int mzerrno = 0;
# define errno mzerrno
#else
# include <errno.h>
#endif

#ifdef USE_UNIX_SOCKETS_TCP
# include <netinet/in.h>
# include <netdb.h>
# include <sys/socket.h>
# include <fcntl.h>
# define TCP_SOCKSENDBUF_SIZE 32768
# define NOT_WINSOCK(x) x
# define SOCK_ERRNO() errno
# define WAS_EAGAIN(e) ((e == EWOULDBLOCK) || (e == EAGAIN) || (e == EINPROGRESS) || (e == EALREADY))
# define WAS_ECONNREFUSED(e) (e == ECONNREFUSED)
# define WAS_EBADADDRESS(e) (e == EINVAL)
# define WAS_WSAEMSGSIZE(e) 0
# define mz_AFNOSUPPORT EAFNOSUPPORT
#endif

#ifdef CANT_SET_SOCKET_BUFSIZE
# undef SET_SOCKET_BUFFSIZE_ON_CREATE
#endif

#ifdef SET_SOCKET_BUFFSIZE_ON_CREATE
# define mzWHEN_SET_SOCKBUF_SIZE(x) x
#else
# define mzWHEN_SET_SOCKBUF_SIZE(x) /* empty */
#endif

#ifdef USE_WINSOCK_TCP
# include <process.h>
# include <winsock2.h>
# include <ws2tcpip.h>
# ifndef __MINGW32__
#  include <wspiapi.h>
# else
typedef int (WINAPI*gai_t)(const char*, const char*, const struct mz_addrinfo *, struct mz_addrinfo **);
typedef void (WINAPI*fai_t)(struct mz_addrinfo *ai);
# endif
struct SOCKADDR_IN {
  short sin_family;
  unsigned short sin_port;
  struct in_addr sin_addr;
  char sin_zero[8];
};
# define NOT_WINSOCK(x) 0
# define SOCK_ERRNO() WSAGetLastError()
# define WAS_EAGAIN(e) ((e == WSAEWOULDBLOCK) || (e == WSAEINPROGRESS))
# define WAS_WSAEMSGSIZE(e) (e == WSAEMSGSIZE)
# define WAS_ECONNREFUSED(e) (e == WSAECONNREFUSED)
# define WAS_EBADADDRESS(e) 0
# define mz_AFNOSUPPORT WSAEAFNOSUPPORT
extern int scheme_stupid_windows_machine;
# ifdef MZ_USE_PLACES
static HANDLE winsock_sema;
# endif
#endif

intptr_t scheme_socket_errno() {
  return SOCK_ERRNO();
}

#include "schfd.h"

#define TCP_BUFFER_SIZE 4096

#ifdef USE_UNIX_SOCKETS_TCP
typedef intptr_t tcp_t;
# define INVALID_SOCKET (-1)
static void closesocket(intptr_t s) {
  int cr;
  do { 
    cr = close(s);
  } while ((cr == -1) && (errno == EINTR));
}
#endif

#ifdef USE_WINSOCK_TCP
typedef SOCKET tcp_t;
#endif

typedef struct {
  Scheme_Object so;
  Scheme_Custodian_Reference *mref;
  int count;
# ifdef HAVE_POLL_SYSCALL
  struct pollfd *pfd;
# endif
  tcp_t s[mzFLEX_ARRAY_DECL];
} listener_t;

typedef struct Scheme_Tcp_Buf {
  MZTAG_IF_REQUIRED
  short refcount;
  char *buffer, *out_buffer;
  short bufpos, bufmax;
  short hiteof, bufmode;
  short out_bufpos, out_bufmax;
  short out_bufmode;
} Scheme_Tcp_Buf;

typedef struct Scheme_Tcp {
  Scheme_Tcp_Buf b;
  tcp_t tcp;
  int flags;
} Scheme_Tcp;

# define MZ_TCP_ABANDON_OUTPUT 0x1
# define MZ_TCP_ABANDON_INPUT  0x2

#define UDP_IS_SUPPORTED

#ifdef UDP_IS_SUPPORTED

typedef struct Scheme_UDP {
  Scheme_Object so; /* scheme_udp_type */
  MZ_HASH_KEY_EX
  tcp_t s; /* ok, tcp_t was a bad name */
  char bound, connected;
  Scheme_Object *previous_from_addr;
  Scheme_Custodian_Reference *mref;
} Scheme_UDP;

#endif /* UDP_IS_SUPPORTED */

#endif /* USE_TCP */

#if defined(WINDOWS_PROCESSES) || defined(WINDOWS_FILE_HANDLES)
# define DECL_OS_FDSET(n) fd_set n[1]
# define INIT_DECL_OS_FDSET(r, w, e) /* empty */
# define INIT_DECL_OS_RD_FDSET(r) /* empty */
# define INIT_DECL_OS_WR_FDSET(r) /* empty */
# define INIT_DECL_OS_ER_FDSET(r) /* empty */
# define MZ_OS_FD_ZERO(p) FD_ZERO(p)
# define MZ_OS_FD_SET(n, p) FD_SET(n, p)
# define MZ_OS_FD_CLR(n, p) FD_CLR(n, p)
#else
# define DECL_OS_FDSET(n) DECL_FDSET(n, 1)
# define INIT_DECL_OS_FDSET(r, w, e) INIT_DECL_FDSET(r, w, e)
# define INIT_DECL_OS_RD_FDSET(r) INIT_DECL_RD_FDSET(r)
# define INIT_DECL_OS_WR_FDSET(r) INIT_DECL_WR_FDSET(r)
# define INIT_DECL_OS_ER_FDSET(r) INIT_DECL_ER_FDSET(r)
# define MZ_OS_FD_ZERO(p) MZ_FD_ZERO(p)
# define MZ_OS_FD_SET(n, p) MZ_FD_SET(n, p)
# define MZ_OS_FD_CLR(n, p) MZ_FD_CLR(n, p)
#endif
#define MZ_OS_FD_ISSET(n, p) FD_ISSET(n, p)

static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_connect_break(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_listen(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_stop(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_accept_ready(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_accept(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_accept_evt(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_accept_break(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_listener_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[]);
static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[]);

static Scheme_Object *make_udp(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_close(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_bound_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_connected_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_bind(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_connect(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_send_to(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_send(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_send_to_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_send_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_send_to_enable_break(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_send_enable_break(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_receive(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_receive_star(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_receive_enable_break(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_read_ready_evt(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_write_ready_evt(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_read_evt(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_write_evt(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_write_to_evt(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_loopback_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_set_loopback(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_ttl(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_set_ttl(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_interface(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_set_interface(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_join_group(int argc, Scheme_Object *argv[]);
static Scheme_Object *udp_multicast_leave_group(int argc, Scheme_Object *argv[]);

static int tcp_check_accept_evt(Scheme_Object *ae, Scheme_Schedule_Info *sinfo);
static void tcp_accept_evt_needs_wakeup(Scheme_Object *_ae, void *fds);
#ifdef UDP_IS_SUPPORTED
static int udp_evt_check_ready(Scheme_Object *uw, Scheme_Schedule_Info *sinfo);
static void udp_evt_needs_wakeup(Scheme_Object *_uw, void *fds);
#endif

#ifdef MZ_PRECISE_GC
static void register_traversers(void);
#endif

void scheme_init_network(Scheme_Env *env)
{
  Scheme_Env *netenv;

#ifdef MZ_PRECISE_GC
  register_traversers();
#endif

  netenv = scheme_primitive_module(scheme_intern_symbol("#%network"), env);

  GLOBAL_PRIM_W_ARITY2 ( "tcp-connect"               , tcp_connect              , 2 , 4 , 2 , 2 , netenv ) ;
  GLOBAL_PRIM_W_ARITY2 ( "tcp-connect/enable-break"  , tcp_connect_break        , 2 , 4 , 2 , 2 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "tcp-listen"                , tcp_listen               , 1 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "tcp-close"                 , tcp_stop                 , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "tcp-accept-ready?"         , tcp_accept_ready         , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY2 ( "tcp-accept"                , tcp_accept               , 1 , 1 , 2 , 2 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "tcp-accept-evt"            , tcp_accept_evt           , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY2 ( "tcp-accept/enable-break"   , tcp_accept_break         , 1 , 1 , 2 , 2 , netenv ) ;
  GLOBAL_FOLDING_PRIM  ( "tcp-listener?"             , tcp_listener_p           , 1 , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY2 ( "tcp-addresses"             , tcp_addresses            , 1 , 2 , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "tcp-abandon-port"          , tcp_abandon_port         , 1 , 1 , netenv ) ;
  GLOBAL_FOLDING_PRIM  ( "tcp-port?"                 , tcp_port_p               , 1 , 1 , 1 , netenv ) ;

  GLOBAL_PRIM_W_ARITY  ( "udp-open-socket"           , make_udp                 , 0 , 2 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-close"                 , udp_close                , 1 , 1 , netenv ) ;
  GLOBAL_FOLDING_PRIM  ( "udp?"                      , udp_p                    , 1 , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-bound?"                , udp_bound_p              , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-connected?"            , udp_connected_p          , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-bind!"                 , udp_bind                 , 3 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-connect!"              , udp_connect              , 3 , 3 , netenv ) ;

  GLOBAL_PRIM_W_ARITY  ( "udp-send-to"               , udp_send_to              , 4 , 6 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send"                  , udp_send                 , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send-to*"              , udp_send_to_star         , 4 , 6 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send*"                 , udp_send_star            , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send-to/enable-break"  , udp_send_to_enable_break , 4 , 6 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send/enable-break"     , udp_send_enable_break    , 2 , 4 , netenv ) ;

  GLOBAL_PRIM_W_ARITY  ( "udp-receive!"              , udp_receive              , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-receive!*"             , udp_receive_star         , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-receive!/enable-break" , udp_receive_enable_break , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-receive-ready-evt"     , udp_read_ready_evt       , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send-ready-evt"        , udp_write_ready_evt      , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-receive!-evt"          , udp_read_evt             , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send-evt"              , udp_write_evt            , 2 , 4 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-send-to-evt"           , udp_write_to_evt         , 4 , 6 , netenv ) ;

  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-loopback?"   , udp_multicast_loopback_p , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-set-loopback!", udp_multicast_set_loopback,2, 2 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-ttl"         , udp_multicast_ttl        , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-set-ttl!"    , udp_multicast_set_ttl    , 2 , 2 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-interface"   , udp_multicast_interface  , 1 , 1 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-set-interface!", udp_multicast_set_interface,2,2, netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-join-group!" , udp_multicast_join_group , 3 , 3 , netenv ) ;
  GLOBAL_PRIM_W_ARITY  ( "udp-multicast-leave-group!", udp_multicast_leave_group, 3 , 3 , netenv ) ;

  scheme_finish_primitive_module(netenv);

#ifdef USE_WINSOCK_TCP
# ifdef MZ_USE_PLACES
  if (!winsock_sema) {
    winsock_sema = CreateSemaphore(NULL, 1, 1, NULL);
  }
# endif
#endif
}

#ifdef USE_TCP
static int check_fd_sema(tcp_t s, int mode, Scheme_Schedule_Info *sinfo, Scheme_Object *orig)
{
  Scheme_Object *sema;

  sema = scheme_fd_to_semaphore(s, mode, 1);
  
  if (sema) {
    if (!scheme_wait_sema(sema, 1)) {
      if (sinfo && !sinfo->no_redirect)
        scheme_set_sync_target(sinfo, sema, orig, NULL, 0, 0, NULL);
      return 0;
    }
  }

  return 1;
}
#endif

/*========================================================================*/
/*                             TCP glue                                   */
/*========================================================================*/


/* These two need o be outside of USE_TCP */
#define PORT_ID_TYPE "(integer-in 1 65535)"
#define CHECK_PORT_ID(obj) (SCHEME_INTP(obj) && (SCHEME_INT_VAL(obj) >= 1) && (SCHEME_INT_VAL(obj) <= 65535))
#define LISTEN_PORT_ID_TYPE "(integer-in 0 65535)"
#define CHECK_LISTEN_PORT_ID(obj) (SCHEME_INTP(obj) && (SCHEME_INT_VAL(obj) >= 0) && (SCHEME_INT_VAL(obj) <= 65535))

#ifdef USE_TCP

#define REGISTER_SOCKET(s) /**/
#define UNREGISTER_SOCKET(s) /**/

#ifdef USE_UNIX_SOCKETS_TCP
typedef struct sockaddr_in mz_unspec_address;
#endif
#ifdef USE_WINSOCK_TCP
typedef struct SOCKADDR_IN mz_unspec_address;
# undef REGISTER_SOCKET
# undef UNREGISTER_SOCKET
# define REGISTER_SOCKET(s) winsock_remember(s)
# define UNREGISTER_SOCKET(s) winsock_forget(s)
#endif

/******************************* hostnames ************************************/

#if defined(OS_X) || defined(USE_PTHREAD_THREAD_TIMER)
# define PTHREADS_OK_FOR_GHBN
#endif

# ifdef PROTOENT_IS_INT
#  define PROTO_P_PROTO PROTOENT_IS_INT
# else
SHARED_OK static struct protoent *proto;
#  define PROTO_P_PROTO (proto ? proto->p_proto : 0)
# endif

# ifndef MZ_PF_INET
#  define MZ_PF_INET PF_INET
# endif

/* For getting connection names: */
#define MZ_SOCK_NAME_MAX_LEN 256
#define MZ_SOCK_HOST_NAME_MAX_LEN 64
#define MZ_SOCK_SVC_NAME_MAX_LEN 32

/* mz_addrinfo is defined in scheme.h */

#if defined(__MINGW32__) && !defined(HAVE_GETADDRINFO)
/* Although `configure` didn't discover it, we do have getaddrinfo()
   from Winsock */
# define HAVE_GETADDRINFO
#endif

#ifdef HAVE_GETADDRINFO
# define mzAI_PASSIVE AI_PASSIVE 
# define mz_getaddrinfo getaddrinfo
# define mz_freeaddrinfo freeaddrinfo
# define mz_gai_strerror gai_strerror
#else
# define mzAI_PASSIVE 0
static int mz_getaddrinfo(const char *nodename, const char *servname,
			  const struct mz_addrinfo *hints, struct mz_addrinfo **res)
  XFORM_SKIP_PROC
{
  struct hostent *h;

  if (nodename)
    h = gethostbyname(nodename);
  else
    h = NULL;

  if (h || !nodename) {
    GC_CAN_IGNORE struct mz_addrinfo *ai;
    GC_CAN_IGNORE struct sockaddr_in *sa;
    int j, id = 0;

    ai = (struct mz_addrinfo *)malloc(sizeof(struct mz_addrinfo));
    sa = (struct sockaddr_in *)malloc(sizeof(struct sockaddr_in));
    ai->ai_addr = (struct sockaddr *)sa;

    ai->ai_addrlen = sizeof(struct sockaddr_in);
    if (servname) {
      for (j = 0; servname[j]; j++) {
	id = (id * 10) + (servname[j] - '0');
      }
    }

    ai->ai_family = MZ_PF_INET;
    ai->ai_socktype = hints->ai_socktype;
    ai->ai_protocol = hints->ai_protocol;
    ai->ai_next = NULL;

    sa->sin_family = (id ? AF_INET : AF_UNSPEC);
    j = htons(id);
    sa->sin_port = j;
    memset(&(sa->sin_addr), 0, sizeof(sa->sin_addr));
    memset(&(sa->sin_zero), 0, sizeof(sa->sin_zero));
    if (h)
      memcpy(&sa->sin_addr, h->h_addr_list[0], h->h_length); 
    
    *res = ai;
    return 0;
  }
  return h_errno;
}
void mz_freeaddrinfo(struct mz_addrinfo *ai)
  XFORM_SKIP_PROC
{
  free(ai->ai_addr);
  free(ai);
}
const char *mz_gai_strerror(int ecode)
  XFORM_SKIP_PROC
{
  return hstrerror(ecode);
}
#endif

#if defined(USE_WINSOCK_TCP) || defined(PTHREADS_OK_FOR_GHBN)

# ifdef USE_WINSOCK_TCP
#  ifdef __BORLANDC__
#   define MZ_LPTHREAD_START_ROUTINE unsigned int (__stdcall*)(void*)
#  else
#   define MZ_LPTHREAD_START_ROUTINE LPTHREAD_START_ROUTINE
#  endif
# else
#  include <pthread.h>
#   define MZ_LPTHREAD_START_ROUTINE void *(*)(void *)
# endif

typedef struct {
# ifdef USE_WINSOCK_TCP
  HANDLE th;
# else
  int pin;
# endif
  struct mz_addrinfo *result;
  int err;
  int done;
} GHBN_Rec;

/* For in-thread DNS: */
#define MZ_MAX_HOSTNAME_LEN 128
#define MZ_MAX_SERVNAME_LEN 32

typedef struct GHBN_Thread_Data {
  int ghbn_lock;
  char ghbn_hostname[MZ_MAX_HOSTNAME_LEN];
  char ghbn_servname[MZ_MAX_SERVNAME_LEN];
  struct mz_addrinfo ghbn_hints;
# ifdef USE_WINSOCK_TCP
  HANDLE ready_sema;
# else
  int ready_fd;
# endif
  struct mz_addrinfo *ghbn_result;
  int ghbn_err;
} GHBN_Thread_Data;

THREAD_LOCAL_DECL(GHBN_Thread_Data *ghbn_thread_data);

static intptr_t getaddrinfo_in_thread(void *_data)
  XFORM_SKIP_PROC
{
  GHBN_Thread_Data *data = (GHBN_Thread_Data *)_data;
  int ok;
  struct mz_addrinfo *res, hints;
  char hn_copy[MZ_MAX_HOSTNAME_LEN], sn_copy[MZ_MAX_SERVNAME_LEN];
# ifndef USE_WINSOCK_TCP
  int fd = data->ready_fd;
  int cr;
# endif
  
  if (data->ghbn_result) {
    mz_freeaddrinfo(data->ghbn_result);
    data->ghbn_result = NULL;
  }

  strcpy(hn_copy, data->ghbn_hostname);
  strcpy(sn_copy, data->ghbn_servname);
  memcpy(&hints, &data->ghbn_hints, sizeof(hints));

# ifdef USE_WINSOCK_TCP
  ReleaseSemaphore(data->ready_sema, 1, NULL);  
# else
  do {
    cr = write(fd, "?", 1);
  } while ((cr == -1) && (errno == EINTR));
# endif

  res = NULL;

  ok = mz_getaddrinfo(hn_copy[0] ? hn_copy : NULL, 
		      sn_copy[0] ? sn_copy : NULL, 
		      &hints, &res);

  data->ghbn_result = res;
  data->ghbn_err = ok;

# ifndef USE_WINSOCK_TCP
  {
    long v = 1;
    do {
      cr = write(fd, &v, sizeof(v));
    } while ((cr == -1) && (errno == EINTR));
    do {
      cr = close(fd);
    } while ((cr == -1) && (errno == EINTR));
  }
# endif

  return 1;
}

#ifdef USE_WINSOCK_TCP
static unsigned int WINAPI win_getaddrinfo_in_thread(void *_data)
  XFORM_SKIP_PROC
{
  return (unsigned int)getaddrinfo_in_thread(_data);
}
#endif

static void release_ghbn_lock(GHBN_Rec *rec)
{
  ghbn_thread_data->ghbn_lock = 0;
# ifdef USE_WINSOCK_TCP
  CloseHandle(rec->th);
# else
  close(rec->pin);
# endif
}

static int ghbn_lock_avail(Scheme_Object *_ignored)
{
  return !ghbn_thread_data->ghbn_lock;
}

static int ghbn_thread_done(Scheme_Object *_rec)
{
  GHBN_Rec *rec = (GHBN_Rec *)_rec;

  if (rec->done)
    return 1;

# ifdef USE_WINSOCK_TCP
  if (WaitForSingleObject(rec->th, 0) == WAIT_OBJECT_0) {
    rec->result = ghbn_thread_data->ghbn_result;
    ghbn_thread_data->ghbn_result = NULL;
    rec->err = ghbn_thread_data->ghbn_err;
    rec->done = 1;
    return 1;
  }
# else
  {
    long v;
    int cr;
    do {
      cr = read(rec->pin, &v, sizeof(long));
    } while ((cr == -1) && (errno == EINTR));
    if (cr > 0) {
      rec->result = ghbn_thread_data->ghbn_result;
      ghbn_thread_data->ghbn_result = NULL;
      rec->err = ghbn_thread_data->ghbn_err;
      rec->done = 1;
      return 1;
    }
  }
# endif

  return 0;
}

static void ghbn_thread_need_wakeup(Scheme_Object *_rec, void *fds)
{
  GHBN_Rec *rec = (GHBN_Rec *)_rec;

# ifdef USE_WINSOCK_TCP
  scheme_add_fd_handle((void *)rec->th, fds, 0);
# else
  {
    void *fds2;
    
    fds2 = MZ_GET_FDSET(fds, 2);
    
    MZ_FD_SET(rec->pin, (fd_set *)fds);
    MZ_FD_SET(rec->pin, (fd_set *)fds2);
  }
# endif
}

static int MZ_GETADDRINFO(const char *name, const char *svc, struct mz_addrinfo *hints, struct mz_addrinfo **res)
{
  GHBN_Rec *rec;
  int ok;

  if ((name && ((strlen(name) >= MZ_MAX_HOSTNAME_LEN) || !name[0]))
      || (svc && ((strlen(svc) >= MZ_MAX_SERVNAME_LEN) || !svc[0]))) {
    /* Give up on a separate thread. */
    return mz_getaddrinfo(name, svc, hints, res);
  }

  if (!ghbn_thread_data) {
    ghbn_thread_data = (GHBN_Thread_Data *)malloc(sizeof(GHBN_Thread_Data));
    memset(ghbn_thread_data, 0, sizeof(GHBN_Thread_Data));
  }

  rec = MALLOC_ONE_ATOMIC(GHBN_Rec);
  rec->done = 0;

  scheme_block_until(ghbn_lock_avail, NULL, NULL, 0);

  ghbn_thread_data->ghbn_lock = 1;

  if (name)
    strcpy(ghbn_thread_data->ghbn_hostname, name);
  else
    ghbn_thread_data->ghbn_hostname[0] = 0;
  if (svc)
    strcpy(ghbn_thread_data->ghbn_servname, svc);
  else
    ghbn_thread_data->ghbn_servname[0] = 0;
  memcpy(&ghbn_thread_data->ghbn_hints, hints, sizeof(*hints));

# ifdef USE_WINSOCK_TCP
  {
    HANDLE ready_sema;
    unsigned int id;
    intptr_t th;
    
    ready_sema = CreateSemaphore(NULL, 0, 1, NULL);
    ghbn_thread_data->ready_sema = ready_sema;
    th = _beginthreadex(NULL, 5000, 
			win_getaddrinfo_in_thread,
			ghbn_thread_data, 0, &id);
    WaitForSingleObject(ghbn_thread_data->ready_sema, INFINITE);
    CloseHandle(ghbn_thread_data->ready_sema);
    
    rec->th = (HANDLE)th;
    ok = 1;
  }
# else
  {
    int p[2];
    if (pipe(p)) {
      ok = 0;
    } else {
      pthread_t t;
      rec->pin = p[0];
      ghbn_thread_data->ready_fd = p[1];
      if (pthread_create(&t, NULL, 
			 (MZ_LPTHREAD_START_ROUTINE)getaddrinfo_in_thread,
			 ghbn_thread_data)) {
	close(p[0]);
	close(p[1]);
	ok = 0;
      } else {
	char buf[1];
        int cr;
	pthread_detach(t);
        do {
          cr = read(rec->pin, buf, 1);
        } while ((cr == -1) && (errno == EINTR));
	fcntl(rec->pin, F_SETFL, MZ_NONBLOCKING);
	ok = 1;
      }
    }

    if (!ok) {
      getaddrinfo_in_thread(ghbn_thread_data);
      rec->result = ghbn_thread_data->ghbn_result;
      ghbn_thread_data->ghbn_result = NULL;
      rec->err = ghbn_thread_data->ghbn_err;
    }
  }
# endif

  if (ok) {
    BEGIN_ESCAPEABLE(release_ghbn_lock, rec);
    scheme_block_until(ghbn_thread_done, ghbn_thread_need_wakeup, (Scheme_Object *)rec, 0);
    END_ESCAPEABLE();

# ifdef USE_WINSOCK_TCP
    CloseHandle(rec->th);
# else
    close(rec->pin);
# endif
  }

  ghbn_thread_data->ghbn_lock = 0;

  *res = rec->result;

  return rec->err;
}

void scheme_free_ghbn_data() {
  if (ghbn_thread_data) {
    free(ghbn_thread_data);
    ghbn_thread_data = NULL;
  }
}
#else
# define MZ_GETADDRINFO mz_getaddrinfo
void scheme_free_ghbn_data() { }
#endif

struct mz_addrinfo *scheme_get_host_address(const char *address, int id, int *err, 
					    int family, int passive, int tcp)
{
  char buf[32], *service;
  int ok;
  GC_CAN_IGNORE struct mz_addrinfo *r, hints;
  r = NULL;

  if (id >= 0) {
    service = buf;
    sprintf(buf, "%d", id);
  } else
    service = NULL;
  
  if (!address && !service) {
    *err = -1;
    return NULL;
  }

  memset(&hints, 0, sizeof(struct mz_addrinfo));
  hints.ai_family = ((family < 0) ? PF_UNSPEC : family);
  if (passive) {
    hints.ai_flags |= mzAI_PASSIVE;
  }
  if (tcp) {
    hints.ai_socktype = SOCK_STREAM;
# ifndef PROTOENT_IS_INT
    if (!proto) {
      proto = getprotobyname("tcp");
    }
# endif
    hints.ai_protocol= PROTO_P_PROTO;
  } else {
    hints.ai_socktype = SOCK_DGRAM;
  }

  ok = MZ_GETADDRINFO(address, service, &hints, &r);
  *err = ok;
  
  if (!ok)
    return r;
  else
    return NULL;
}

void scheme_free_host_address(struct mz_addrinfo *a)
{
  mz_freeaddrinfo(a);
}

const char *scheme_host_address_strerror(int errnum)
{
  return mz_gai_strerror(errnum);
}

/******************************* WinSock ***********************************/

#ifdef USE_WINSOCK_TCP

static int wsr_size = 0;
static tcp_t *wsr_array;

static void winsock_remember(tcp_t s)
{
  int i, new_size;
  tcp_t *naya;

# ifdef MZ_USE_PLACES
  WaitForSingleObject(winsock_sema, INFINITE);
# endif

  for (i = 0; i < wsr_size; i++) {
    if (!wsr_array[i]) {
      wsr_array[i] = s;
      break;
    }
  }

  if (i >= wsr_size) {
    if (!wsr_size) {
      new_size = 32;
    } else
      new_size = 2 * wsr_size;

    naya = malloc(sizeof(tcp_t) * new_size);
    for (i = 0; i < wsr_size; i++) {
      naya[i] = wsr_array[i];
    }

    naya[wsr_size] = s;

    if (wsr_array) free(wsr_array);

    wsr_array = naya;
    wsr_size = new_size;
  }  

# ifdef MZ_USE_PLACES
  ReleaseSemaphore(winsock_sema, 1, NULL);
# endif
}

static void winsock_forget(tcp_t s)
{
  int i;

# ifdef MZ_USE_PLACES
  WaitForSingleObject(winsock_sema, INFINITE);
# endif

  for (i = 0; i < wsr_size; i++) {
    if (wsr_array[i] == s) {
      wsr_array[i] = (tcp_t)NULL;
      break;
    }
  }

# ifdef MZ_USE_PLACES
  ReleaseSemaphore(winsock_sema, 1, NULL);
# endif
}

static int winsock_done(void)
{
  int i;

  /* only called in the original place */

  for (i = 0; i < wsr_size; i++) {
    if (wsr_array[i]) {
      closesocket(wsr_array[i]);
      wsr_array[i] = (tcp_t)NULL;
    }
  }

  return WSACleanup();
}

static void TCP_INIT(char *name)
{
  static int started = 0;
  
# ifdef MZ_USE_PLACES
  WaitForSingleObject(winsock_sema, INFINITE);
# endif

  if (!started) {
    WSADATA data;
    if (!WSAStartup(MAKEWORD(1, 1), &data)) {
      started = 1;
#ifdef __BORLANDC__
      atexit((void(*)())winsock_done);
#else      
      _onexit(winsock_done);
#endif
    }
  }

  if (!started)
    scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
		     "%s: no winsock driver",
		     name);
  
# ifdef MZ_USE_PLACES
  ReleaseSemaphore(winsock_sema, 1, NULL);
# endif
}
#else
/* Not Winsock */
# define TCP_INIT(x) /* nothing */
#endif

/*========================================================================*/
/*                       TCP ports and listeners                          */
/*========================================================================*/

#define LISTENER_WAS_CLOSED(x) (((listener_t *)(x))->s[0] == INVALID_SOCKET)

/* Forward declaration */
static int stop_listener(Scheme_Object *o);

static Scheme_Object *listener_to_evt(listener_t *listener)
{
  Scheme_Object **a, *sema;
  int i;

  a = MALLOC_N(Scheme_Object*, listener->count);
  for (i = listener->count; i--; ) {
    sema = scheme_fd_to_semaphore(listener->s[i], MZFD_CREATE_READ, 1);
    if (!sema) 
      return NULL;
    a[i] = sema;
  }

  return scheme_make_evt_set(listener->count, a);
}

static int tcp_check_accept(Scheme_Object *_listener, Scheme_Schedule_Info *sinfo)
{
  listener_t *listener = (listener_t *)_listener;
  int sr, i;
# ifndef HAVE_POLL_SYSCALL
  tcp_t s, mx;
  DECL_OS_FDSET(readfds);
  DECL_OS_FDSET(exnfds);
  struct timeval time = {0, 0};
# endif

  if (!sinfo || !sinfo->is_poll) {
    for (i = listener->count; i--; ) {
      if (check_fd_sema(listener->s[i], MZFD_CHECK_READ, NULL, NULL))
        break;
    }
    if (i < 0) return 0;
  }

# ifdef HAVE_POLL_SYSCALL
  if (LISTENER_WAS_CLOSED(listener))
    return 1;

  do {
    sr = poll(listener->pfd, listener->count, 0);
  } while ((sr == -1) && (errno == EINTR));

  if (sr) {
    for (i = listener->count; i--; ) {
      if (listener->pfd[i].revents)
        return i + 1;
    }
  }

  if (sr)
    return sr;
# else

  INIT_DECL_OS_RD_FDSET(readfds);
  INIT_DECL_OS_ER_FDSET(exnfds);

  if (LISTENER_WAS_CLOSED(listener))
    return 1;

  MZ_OS_FD_ZERO(readfds);
  MZ_OS_FD_ZERO(exnfds);

  mx = 0;
  for (i = 0; i < listener->count; i++) {
    s = listener->s[i];
    MZ_OS_FD_SET(s, readfds);
    MZ_OS_FD_SET(s, exnfds);
    if (s > mx)
      mx = s;
  }
  
  do {
    sr = select(mx + 1, readfds, NULL, exnfds, &time);
  } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));

  if (sr) {
    for (i = 0; i < listener->count; i++) {
      s = listener->s[i];
      if (MZ_OS_FD_ISSET(s, readfds)
	  || MZ_OS_FD_ISSET(s, exnfds))
	return i + 1;
    }
  }

  if (sr)
    return sr;
# endif

  if (sinfo && !sinfo->no_redirect) {
    Scheme_Object *evt;
    evt = listener_to_evt(listener);
    if (evt)
      scheme_set_sync_target(sinfo, evt, _listener, NULL, 0, 1, NULL);
  } else {
    for (i = listener->count; i--; ) {
      check_fd_sema(listener->s[i], MZFD_CREATE_READ, NULL, NULL);
    }
  }

  return 0;
}

static void tcp_accept_needs_wakeup(Scheme_Object *_listener, void *fds)
{
  if (!LISTENER_WAS_CLOSED(_listener)) {
    listener_t *listener = (listener_t *)_listener;
    int i;
    tcp_t s;
    void *fds2;

    fds2 = MZ_GET_FDSET(fds, 2);
    
    for (i = 0; i < listener->count; i++) {
      s = listener->s[i];
      MZ_FD_SET(s, (fd_set *)fds);
      MZ_FD_SET(s, (fd_set *)fds2);
    }
  }
}

static int tcp_check_connect(Scheme_Object *connector_p, Scheme_Schedule_Info *sinfo)
{
  tcp_t s;
  int sr;

  s = *(tcp_t *)connector_p;

  if (!sinfo || !sinfo->is_poll) {
    if (!check_fd_sema(s, MZFD_CHECK_WRITE, sinfo, NULL))
      return 0;
  }

# ifdef HAVE_POLL_SYSCALL
  {
    GC_CAN_IGNORE struct pollfd pfd[1];
    pfd[0].fd = s;
    pfd[0].events = POLLOUT;
    do {
      sr = poll(pfd, 1, 0);
    } while ((sr == -1) && (errno == EINTR));

    if (!sr) {
      /* fall through */
    } else if (pfd[0].revents & POLLOUT)
      return 1;
    else
      return -1;
  }
# else
  {
    DECL_OS_FDSET(writefds);
    DECL_OS_FDSET(exnfds);
    struct timeval time = {0, 0};
    
    INIT_DECL_OS_WR_FDSET(writefds);
    INIT_DECL_OS_ER_FDSET(exnfds);

    MZ_OS_FD_ZERO(writefds);
    MZ_OS_FD_ZERO(exnfds);
    
    MZ_OS_FD_SET(s, writefds);
    MZ_OS_FD_SET(s, exnfds);
    
    do {
      sr = select(s + 1, NULL, writefds, exnfds, &time);
    } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
    
    if (!sr) {
      /* fall through */
    } else if (FD_ISSET(s, exnfds))
      return -1;
    else
      return 1;
  }
# endif

  check_fd_sema(s, MZFD_CREATE_WRITE, sinfo, NULL);

  return 0;
}

static void tcp_connect_needs_wakeup(Scheme_Object *connector_p, void *fds)
{
  void *fds1, *fds2;
  tcp_t s = *(tcp_t *)connector_p;
  
  fds1 = MZ_GET_FDSET(fds, 1);
  fds2 = MZ_GET_FDSET(fds, 2);

  MZ_FD_SET(s, (fd_set *)fds1);
  MZ_FD_SET(s, (fd_set *)fds2);
}

static int tcp_check_write(Scheme_Object *port, Scheme_Schedule_Info *sinfo)
{
  Scheme_Tcp *data = (Scheme_Tcp *)((Scheme_Output_Port *)port)->port_data;
    
  if (((Scheme_Output_Port *)port)->closed)
    return 1;

  if (!sinfo || !sinfo->is_poll) {
    if (!check_fd_sema(data->tcp, MZFD_CHECK_WRITE, sinfo, port))
      return 0;
  }

# ifdef HAVE_POLL_SYSCALL
  {
    GC_CAN_IGNORE struct pollfd pfd[1];
    int sr;

    pfd[0].fd = data->tcp;
    pfd[0].events = POLLOUT;
    do {
      sr = poll(pfd, 1, 0);
    } while ((sr == -1) && (errno == EINTR));

    if (!sr) {
      /* fall through */
    } else if (pfd[0].revents & POLLOUT)
      return 1;
    else
      return -1;
  }
# else
  {
    tcp_t s;
    DECL_OS_FDSET(writefds);
    DECL_OS_FDSET(exnfds);
    struct timeval time = {0, 0};
    int sr;
    
    INIT_DECL_OS_WR_FDSET(writefds);
    INIT_DECL_OS_ER_FDSET(exnfds);
    
    s = data->tcp;
    
    MZ_OS_FD_ZERO(writefds);
    MZ_OS_FD_SET(s, writefds);
    MZ_OS_FD_ZERO(exnfds);
    MZ_OS_FD_SET(s, exnfds);
    
    do {
      sr = select(s + 1, NULL, writefds, exnfds, &time);
    } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
    
    if (sr)
      return sr;
  }
# endif

  check_fd_sema(data->tcp, MZFD_CREATE_WRITE, sinfo, port);

  return 0;
}

static void tcp_write_needs_wakeup(Scheme_Object *port, void *fds)
{
  Scheme_Object *conn = ((Scheme_Output_Port *)port)->port_data;
  void *fds1, *fds2;
  tcp_t s = ((Scheme_Tcp *)conn)->tcp;
  
  fds1 = MZ_GET_FDSET(fds, 1);
  fds2 = MZ_GET_FDSET(fds, 2);
  
  MZ_FD_SET(s, (fd_set *)fds1);
  MZ_FD_SET(s, (fd_set *)fds2);
}


static Scheme_Tcp *make_tcp_port_data(tcp_t tcp, int refcount)
{
  Scheme_Tcp *data;
  char *bfr;
  
  data = MALLOC_ONE_RT(Scheme_Tcp);
#ifdef MZTAG_REQUIRED
  data->b.type = scheme_rt_tcp;
#endif
  data->tcp = tcp;

  bfr = (char *)scheme_malloc_atomic(TCP_BUFFER_SIZE);
  data->b.buffer = bfr;
  bfr = (char *)scheme_malloc_atomic(TCP_BUFFER_SIZE);
  data->b.out_buffer = bfr;

  data->b.bufpos = 0;
  data->b.bufmax = 0;
  data->b.hiteof = 0;
  data->b.refcount = refcount;

#ifdef USE_WINSOCK_TCP
  {
    unsigned long ioarg = 1;
    ioctlsocket(tcp, FIONBIO, &ioarg);
  }
#else
  fcntl(tcp, F_SETFL, MZ_NONBLOCKING);
#endif

  return data;
}

static int tcp_byte_ready (Scheme_Input_Port *port, Scheme_Schedule_Info *sinfo)
{
  Scheme_Tcp *data;
  int sr;
# ifndef HAVE_POLL_SYSCALL
  DECL_OS_FDSET(readfds);
  DECL_OS_FDSET(exfds);
  struct timeval time = {0, 0};

  INIT_DECL_OS_RD_FDSET(readfds);
  INIT_DECL_OS_ER_FDSET(exfds);
# endif

  if (port->closed)
    return 1;

  data = (Scheme_Tcp *)port->port_data;

  if (data->b.hiteof)
    return 1;
  if (data->b.bufpos < data->b.bufmax)
    return 1;

  if (!sinfo || !sinfo->is_poll) {
    if (!check_fd_sema(data->tcp, MZFD_CHECK_READ, sinfo, (Scheme_Object *)port))
      return 0;
  }

# ifdef HAVE_POLL_SYSCALL
  {
    GC_CAN_IGNORE struct pollfd pfd[1];

    pfd[0].fd = data->tcp;
    pfd[0].events = POLLIN;
    do {
      sr = poll(pfd, 1, 0);
    } while ((sr == -1) && (errno == EINTR));

    if (sr)
      return sr;
  }
# else
  {
    MZ_OS_FD_ZERO(readfds);
    MZ_OS_FD_ZERO(exfds);
    MZ_OS_FD_SET(data->tcp, readfds);
    MZ_OS_FD_SET(data->tcp, exfds);
    
    do {
      sr = select(data->tcp + 1, readfds, NULL, exfds, &time);
    } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));

    if (sr)
      return sr;
  }
# endif

  check_fd_sema(data->tcp, MZFD_CREATE_READ, sinfo, (Scheme_Object *)port);

  return 0;
}

static intptr_t tcp_get_string(Scheme_Input_Port *port, 
			   char *buffer, intptr_t offset, intptr_t size,
			   int nonblock,
			   Scheme_Object *unless)
{
  int errid;
  int read_amt;
  Scheme_Tcp *data;
  Scheme_Object *sema;

  data = (Scheme_Tcp *)port->port_data;

  while (1) {
    if (scheme_unless_ready(unless))
      return SCHEME_UNLESS_READY;

    if (port->closed) {
      /* Another thread closed the input port while we were waiting. */
      /* Call scheme_get_byte to signal the error */
      scheme_get_byte((Scheme_Object *)port);
    }

    if (data->b.hiteof)
      return EOF;
    
    if (data->b.bufpos < data->b.bufmax) {
      int n;
      n = data->b.bufmax - data->b.bufpos;
      n = ((size <= n)
           ? size
           : n);
      
      memcpy(buffer + offset, data->b.buffer + data->b.bufpos, n);
      data->b.bufpos += n;
      
      return n;
    }
    
    /* No data in buffer, so read from socket: */
    
    if (!data->b.bufmode || (size > TCP_BUFFER_SIZE))
      read_amt = TCP_BUFFER_SIZE;
    else
      read_amt = size;
    
    {
      int rn;
      do {
        rn = recv(data->tcp, data->b.buffer, read_amt, 0);
      } while ((rn == -1) && (NOT_WINSOCK(errno) == EINTR));
      data->b.bufmax = rn;
    }
    errid = SOCK_ERRNO();
    
    if ((data->b.bufmax != -1) || !WAS_EAGAIN(errid)) {
      /* got data or error */
      break;
    } else {
      /* no data/error is immediately avaulable */
      if (nonblock > 0)
        return 0;

      /* block until data is (probably) available */
      sema = scheme_fd_to_semaphore(data->tcp, MZFD_CREATE_READ, 1);
      if (sema)
        scheme_wait_sema(sema, nonblock ? -1 : 0);
      else
        scheme_block_until_unless((Scheme_Ready_Fun)tcp_byte_ready,
                                  scheme_need_wakeup,
                                  (Scheme_Object *)port,
                                  0.0, unless,
                                  nonblock);
      
      scheme_wait_input_allowed(port, nonblock);
    }
  }

  /* getting here means that data or error was ready */
  
  if (data->b.bufmax == -1) {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "tcp-read: error reading\n"
                     "  system error: %E",
		     errid);
    return 0;
  } else if (!data->b.bufmax) {
    data->b.hiteof = 1;
    return EOF;
  }

  {
    int n;
    n = data->b.bufmax;
    if (size < n)
      n = size;
    memcpy(buffer + offset, data->b.buffer, n);
    data->b.bufpos = n;

    return n;
  }
}

static void tcp_need_wakeup(Scheme_Input_Port *port, void *fds)
{
  Scheme_Tcp *data;

  data = (Scheme_Tcp *)port->port_data;

  {
    void *fds2;
  
    fds2 = MZ_GET_FDSET(fds, 2);
    
    MZ_FD_SET(data->tcp, (fd_set *)fds);
    MZ_FD_SET(data->tcp, (fd_set *)fds2);
  }
}

static void tcp_close_input(Scheme_Input_Port *port)
{
  Scheme_Tcp *data;

  data = (Scheme_Tcp *)port->port_data;

  if (!(data->flags & MZ_TCP_ABANDON_INPUT)) {
    int cr;
    do { 
      cr = shutdown(data->tcp, 0);
    } while ((cr == -1) && (errno == EINTR));
  }

  if (--data->b.refcount)
    return;

  UNREGISTER_SOCKET(data->tcp);
  closesocket(data->tcp);

  (void)scheme_fd_to_semaphore(data->tcp, MZFD_REMOVE, 1);
}

static int
tcp_in_buffer_mode(Scheme_Port *p, int mode)
{
  Scheme_Tcp *data;

  data = (Scheme_Tcp *)((Scheme_Input_Port *)p)->port_data;  
  if (mode < 0)
    return data->b.bufmode;
  else {
    data->b.bufmode = mode;
    return mode;
  }
}

static intptr_t tcp_do_write_string(Scheme_Output_Port *port, 
				const char *s, intptr_t offset, intptr_t len, 
				int rarely_block, int enable_break)
{
  /* We've already checked for buffering before we got here. */
  /* If rarely_block is 1, it means only write as much as
     can be flushed immediately, blocking only if nothing
     can be written. */
  /* If rarely_block is 2, it means only write as much as
     can be flushed immediately, never ever blocking. */

  Scheme_Tcp *data;
  int errid, would_block = 0;
  intptr_t sent;

  data = (Scheme_Tcp *)port->port_data;

 top:

  do {
    sent = send(data->tcp, s XFORM_OK_PLUS offset, len, 0);
  } while ((sent == -1) && (NOT_WINSOCK(errno) == EINTR));

  if (sent != len) {
#ifdef USE_WINSOCK_TCP
# define SEND_BAD_MSG_SIZE(e) (e == WSAEMSGSIZE)
#else    
# ifdef SEND_IS_NEVER_TOO_BIG
#  define SEND_BAD_MSG_SIZE(errid) 0
# else
#  define SEND_BAD_MSG_SIZE(errid) (errid == EMSGSIZE)
# endif
#endif
    errid = SOCK_ERRNO();
    if (sent > 0) {
      /* Some data was sent. Return, or recur to handle the rest. */
      if (rarely_block)
	return sent;
      else
	sent += tcp_do_write_string(port, s, offset + sent, len - sent, 0, enable_break);
      errid = 0;
    } else if ((len > 1) && SEND_BAD_MSG_SIZE(errid)) {
      /* split the message and try again: */
      int half = (len / 2);
      sent = tcp_do_write_string(port, s, offset, half, rarely_block, enable_break);
      if (rarely_block)
	return sent;
      sent += tcp_do_write_string(port, s, offset + half, len - half, 0, enable_break);
      errid = 0;
    } else if (WAS_EAGAIN(errid)) {
      errid = 0;
      would_block = 1;
    }
  } else
    errid = 0;

  if (would_block) {
    if (rarely_block == 2)
      return 0;

    /* Block for writing: */
    {
      Scheme_Object *sema;
      sema = scheme_fd_to_semaphore(data->tcp, MZFD_CREATE_WRITE, 1);
      if (sema)
        scheme_wait_sema(sema, enable_break ? -1 : 0);
      else
        scheme_block_until_enable_break((Scheme_Ready_Fun)tcp_check_write, 
                                        tcp_write_needs_wakeup, 
                                        (Scheme_Object *)port, 
                                        (float)0.0, enable_break);
    }

    /* Closed while blocking? */
    if (((Scheme_Output_Port *)port)->closed) {
      /* Call write again to signal the error: */
      scheme_put_byte_string("tcp-write-string", (Scheme_Object *)port, s, offset, len, 0);
      return sent + len; /* shouldn't get here */
    }

    /* Ok - try again! */
    would_block = 0;
    goto top;
  }

  if (errid)
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "tcp-write: error writing\n"
                     "  system error: %E",
		     errid);

  return sent;
}

static int tcp_flush(Scheme_Output_Port *port,
		     int rarely_block, int enable_break)
{
  Scheme_Tcp *data;
  int amt, flushed = 0;
  
  data = (Scheme_Tcp *)port->port_data;

  while (1) {
    if (data->b.out_bufpos == data->b.out_bufmax) {
      data->b.out_bufpos = 0;
      data->b.out_bufmax = 0;
      return flushed;
    }
    amt = tcp_do_write_string(port, data->b.out_buffer, data->b.out_bufpos, 
			      data->b.out_bufmax - data->b.out_bufpos,
			      rarely_block, enable_break);
    flushed += amt;
    data->b.out_bufpos += amt;
    if (rarely_block && (data->b.out_bufpos < data->b.out_bufmax))
      return flushed;
  }
}

static intptr_t tcp_write_string(Scheme_Output_Port *port, 
			     const char *s, intptr_t offset, intptr_t len, 
			     int rarely_block, int enable_break)
{
  Scheme_Tcp *data;

  data = (Scheme_Tcp *)port->port_data;

  if (!len) {
    /* Flush */
    tcp_flush(port, rarely_block, enable_break);
    if (data->b.out_bufpos != data->b.out_bufmax)
      return -1;
    return 0;
  }

  if (rarely_block) {
    tcp_flush(port, rarely_block, enable_break);
    if (data->b.out_bufmax)
      return -1;
  } else {
    if (data->b.out_bufmode < 2) {
      if (data->b.out_bufmax + len < TCP_BUFFER_SIZE) {
	memcpy(data->b.out_buffer + data->b.out_bufmax, s + offset, len);
	data->b.out_bufmax += (short)len;
	if (data->b.out_bufmode == 1) {
	  /* Check for newline */
	  int i;
	  for (i = 0; i < len; i++) {
	    if ((s[offset + i] == '\r')
		|| (s[offset + i] == '\n'))
	      break;
	  }
	  if (i < len)
	    tcp_flush(port, rarely_block, enable_break);
	}
	return len;
      }
    }
    tcp_flush(port, rarely_block, enable_break);
  }

  /* When we get here, the buffer is empty */
  return tcp_do_write_string(port, s, offset, len, rarely_block, enable_break);
}

static void tcp_close_output(Scheme_Output_Port *port)
{
  Scheme_Tcp *data;

  data = (Scheme_Tcp *)port->port_data;

  if (data->b.out_bufmax && !scheme_force_port_closed)
    tcp_flush(port, 0, 0);

  if (!(data->flags & MZ_TCP_ABANDON_OUTPUT)) {
    int cr;
    do { 
      cr = shutdown(data->tcp, 1);
    } while ((cr == -1) && (errno == EINTR));
  }

  if (--data->b.refcount)
    return;

  UNREGISTER_SOCKET(data->tcp);
  closesocket(data->tcp);

  (void)scheme_fd_to_semaphore(data->tcp, MZFD_REMOVE, 1);
}

static int
tcp_out_buffer_mode(Scheme_Port *p, int mode)
{
  Scheme_Tcp *data;

  data = (Scheme_Tcp *)((Scheme_Output_Port *)p)->port_data;  
  if (mode < 0)
    return data->b.out_bufmode;
  else {
    int go;
    go = (mode > data->b.out_bufmode);
    data->b.out_bufmode = mode;
    if (go)
      tcp_flush((Scheme_Output_Port *)p, 0, 0);
    return mode;
  }
}

static Scheme_Object *
make_tcp_input_port_symbol_name(void *data, Scheme_Object *name, Scheme_Object *cust)
{
  Scheme_Input_Port *ip;

  if (cust)
    scheme_set_next_port_custodian((Scheme_Custodian *)cust);
  
  ip = scheme_make_input_port(scheme_tcp_input_port_type,
			      data,
                              name,
			      tcp_get_string,
			      NULL,
			      scheme_progress_evt_via_get,
			      scheme_peeked_read_via_get,
			      (Scheme_In_Ready_Fun)tcp_byte_ready,
			      tcp_close_input,
			      tcp_need_wakeup,
			      1);

  ip->p.buffer_mode_fun = tcp_in_buffer_mode;

  return (Scheme_Object *)ip;
}

static Scheme_Object *
make_tcp_input_port(void *data, const char *name, Scheme_Object *cust)
{
  return make_tcp_input_port_symbol_name(data, scheme_intern_symbol(name), cust);
}

static Scheme_Object *
make_tcp_output_port_symbol_name(void *data, Scheme_Object *name, Scheme_Object *cust)
{
  Scheme_Output_Port *op;

  if (cust)
    scheme_set_next_port_custodian((Scheme_Custodian *)cust);

  op = scheme_make_output_port(scheme_tcp_output_port_type,
						  data,
						  name,
						  scheme_write_evt_via_write,
						  tcp_write_string,
						  (Scheme_Out_Ready_Fun)tcp_check_write,
						  tcp_close_output,
						  (Scheme_Need_Wakeup_Output_Fun)tcp_write_needs_wakeup,
						  NULL,
						  NULL,
						  1);

  op->p.buffer_mode_fun = tcp_out_buffer_mode;

  return (Scheme_Object *)op;
}

static Scheme_Object *
make_tcp_output_port(void *data, const char *name, Scheme_Object *cust)
{
  return make_tcp_output_port_symbol_name(data, scheme_intern_symbol(name), cust);
}

#else

void scheme_free_ghbn_data() { }

#endif /* USE_TCP */

/*========================================================================*/
/*                         TCP Racket interface                           */
/*========================================================================*/

#ifdef USE_TCP
typedef struct Close_Socket_Data {
  tcp_t s;
  struct mz_addrinfo *src_addr, *dest_addr;
} Close_Socket_Data;

static void closesocket_w_decrement(Close_Socket_Data *csd)
{
  closesocket(csd->s);
  (void)scheme_fd_to_semaphore(csd->s, MZFD_REMOVE, 1);
  if (csd->src_addr)
    mz_freeaddrinfo(csd->src_addr);
  mz_freeaddrinfo(csd->dest_addr);  
}
#endif

const char *scheme_hostname_error(int err)
{
#ifdef USE_TCP
  return mz_gai_strerror(err);
#else
  return "?";
#endif
}

static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[])
{
  char * volatile address = "", * volatile src_address, * volatile errmsg = NULL;
  unsigned short origid, id, src_origid, src_id;
  int errpart = 0, errid = 0;
  volatile int nameerr = 0, no_local_spec;
  Scheme_Object *bs, *src_bs;
#ifdef USE_TCP
  GC_CAN_IGNORE struct mz_addrinfo *tcp_connect_dest;
  GC_CAN_IGNORE struct mz_addrinfo * volatile tcp_connect_src;
#endif

  if (!SCHEME_CHAR_STRINGP(argv[0]))
    scheme_wrong_contract("tcp-connect", "string?", 0, argc, argv);
  if (!CHECK_PORT_ID(argv[1]))
    scheme_wrong_contract("tcp-connect", PORT_ID_TYPE, 1, argc, argv);
  if (argc > 2)
    if (!SCHEME_CHAR_STRINGP(argv[2]) && !SCHEME_FALSEP(argv[2]))
      scheme_wrong_contract("tcp-connect", "(or/c string? #f)", 2, argc, argv);
  if (argc > 3)
    if (SCHEME_TRUEP(argv[3]) && !CHECK_PORT_ID(argv[3]))
      scheme_wrong_contract("tcp-connect", "(or/c " PORT_ID_TYPE " #f)", 3, argc, argv);

#ifdef USE_TCP
  TCP_INIT("tcp-connect");
#endif

  bs = argv[0];
  if (SCHEME_CHAR_STRINGP(bs))
    bs = scheme_char_string_to_byte_string(bs);

  address = SCHEME_BYTE_STR_VAL(bs);
  origid = (unsigned short)SCHEME_INT_VAL(argv[1]);

  if ((argc > 2) && SCHEME_TRUEP(argv[2])) {
    src_bs = scheme_char_string_to_byte_string(argv[2]);
    src_address = SCHEME_BYTE_STR_VAL(src_bs);
  } else
    src_address = NULL;
   
  if ((argc > 3) && SCHEME_TRUEP(argv[3])) {
    no_local_spec = 0;
    src_origid = (unsigned short)SCHEME_INT_VAL(argv[3]);
  } else {
    no_local_spec = 1;
    src_origid = 0;
    if (src_address) {
      scheme_contract_error("tcp-connect",
                            "no local port number supplied when local hostname was supplied",
                            "hostname", 1, argv[2],
                            NULL);
    }
  }

  scheme_security_check_network("tcp-connect", address, origid, 1);
  scheme_custodian_check_available(NULL, "tcp-connect", "network");

#ifdef USE_TCP
  id = origid;
  src_id = src_origid;

  tcp_connect_dest = scheme_get_host_address(address, id, &errid, -1, 0, 1);
  if (tcp_connect_dest) {
    if (no_local_spec)
      tcp_connect_src = NULL;
    else
      tcp_connect_src = scheme_get_host_address(src_address, src_id, &errid, -1, 1, 1);
    if (no_local_spec || tcp_connect_src) {
      GC_CAN_IGNORE struct mz_addrinfo * volatile addr;
      for (addr = tcp_connect_dest; addr; addr = addr->ai_next) {
	tcp_t s;
	s = socket(addr->ai_family, addr->ai_socktype, addr->ai_protocol);
	if (s != INVALID_SOCKET) {
	  int status, inprogress;
	  if (no_local_spec
	      || !bind(s, tcp_connect_src->ai_addr, tcp_connect_src->ai_addrlen)) {
#ifdef USE_WINSOCK_TCP
	    unsigned long ioarg = 1;
	    ioctlsocket(s, FIONBIO, &ioarg);
#else
	    mzWHEN_SET_SOCKBUF_SIZE(int size = TCP_SOCKSENDBUF_SIZE);
	    fcntl(s, F_SETFL, MZ_NONBLOCKING);
	    mzWHEN_SET_SOCKBUF_SIZE(setsockopt(s, SOL_SOCKET, SO_SNDBUF, (char *)&size, sizeof(int)));
#endif
	    status = connect(s, addr->ai_addr, addr->ai_addrlen);
#ifdef USE_UNIX_SOCKETS_TCP
	    if (status)
	      status = errno;
	    if (status == EINTR)
	      status = EINPROGRESS;
	
	    inprogress = (status == EINPROGRESS);
#endif
#ifdef USE_WINSOCK_TCP
	    if (status)
	      status = WSAGetLastError();

	    inprogress = (status == WSAEWOULDBLOCK);
	    errno = status;
#endif

	  
	    if (inprogress) {
	      tcp_t *sptr;
	      Close_Socket_Data *csd;
              Scheme_Object *sema;

	      sptr = (tcp_t *)scheme_malloc_atomic(sizeof(tcp_t));
	      *sptr = s;

	      csd = (Close_Socket_Data *)scheme_malloc_atomic(sizeof(Close_Socket_Data));
	      csd->s = s;
	      csd->src_addr = tcp_connect_src;
	      csd->dest_addr = tcp_connect_dest;

              sema = scheme_fd_to_semaphore(s, MZFD_CREATE_WRITE, 1);

	      BEGIN_ESCAPEABLE(closesocket_w_decrement, csd);
              if (sema)
                scheme_wait_sema(sema, 0);
              else
                scheme_block_until((Scheme_Ready_Fun)tcp_check_connect, 
                                   tcp_connect_needs_wakeup, 
                                   (void *)sptr, 
                                   (float)0.0);
	      END_ESCAPEABLE();

	      /* Check whether connect succeeded, or get error: */
	      {
		unsigned int so_len = sizeof(status);
		if (getsockopt(s, SOL_SOCKET, SO_ERROR, (void *)&status, &so_len) != 0) {
		  status = SOCK_ERRNO();
		}
		errno = status; /* for error reporting, below */
	      }

#ifdef USE_WINSOCK_TCP
	      if (scheme_stupid_windows_machine > 0) {
		/* getsockopt() seems not to work in Windows 95, so use the
		   result from select(), which seems to reliably detect an error condition */
		if (!status) {
		  if (tcp_check_connect((Scheme_Object *)sptr, NULL) == -1) {
		    status = 1;
		    errno = WSAECONNREFUSED; /* guess! */
		  }
		}
	      }
#endif
	    }
	
	    if (!status) {
	      Scheme_Object *v[2];
	      Scheme_Tcp *tcp;

	      if (tcp_connect_src)
		mz_freeaddrinfo(tcp_connect_src);
	      mz_freeaddrinfo(tcp_connect_dest);

	      tcp = make_tcp_port_data(s, 2);
	      
	      v[0] = make_tcp_input_port(tcp, address, NULL);
	      v[1] = make_tcp_output_port(tcp, address, NULL);
	      
	      REGISTER_SOCKET(s);

	      return scheme_values(2, v);
	    } else {
	      errid = errno;
	      closesocket(s);
              (void)scheme_fd_to_semaphore(s, MZFD_REMOVE, 1);
	      errpart = 6;
	    }
	  } else {
	    errpart = 5;
	    errid = SOCK_ERRNO();
	  }
	} else {
	  errpart = 4;
	  errid = SOCK_ERRNO();
	}
      }
      if (tcp_connect_src)
	mz_freeaddrinfo(tcp_connect_src);
    } else {
      errpart = 2;
      nameerr = 1;
      errmsg = "local host not found";
    } 
    if (tcp_connect_dest)
      mz_freeaddrinfo(tcp_connect_dest);
  } else {
    errpart = 1;
    nameerr = 1;
    errmsg = "host not found";
  }

  scheme_raise_exn(MZEXN_FAIL_NETWORK,
		   "tcp-connect: connection failed\n"
                   "%s%s%s"
                   "  address: %s\n"
                   "  port number: %d\n"
                   "  step: %d\n"
                   "  system error: %N",
                   errmsg ? "  detail: " : "",
                   errmsg ? errmsg : "",
                   errmsg ? "\n" : "",
		   address, origid, errpart, 
                   nameerr, errid);
#else
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
		   "tcp-connect: " NOT_SUPPORTED_STR);
#endif

  return NULL;
}

static Scheme_Object *
tcp_connect_break(int argc, Scheme_Object *argv[])
{
  return scheme_call_enable_break(tcp_connect, argc, argv);
}

#ifdef USE_TCP
static unsigned short get_no_portno(tcp_t socket, int *_errid)
{
  char here[MZ_SOCK_NAME_MAX_LEN];
  struct sockaddr_in *addr_in;
  unsigned int l = sizeof(here);
  unsigned short no_port;


  if (getsockname(socket, (struct sockaddr *)here, &l)) {
    int errid;
    errid = SOCK_ERRNO();
    *_errid = errid;
    return 0;
  }

  /* don't use ntohs, since the result is put back into another sin_port: */
  addr_in = (struct sockaddr_in *)here;
  no_port = addr_in->sin_port;
  if (!no_port)
    *_errid = 0;
  return no_port;
}
#endif

static Scheme_Object *
tcp_listen(int argc, Scheme_Object *argv[])
{
  unsigned short id, origid;
  int backlog, errid;
  int reuse = 0;
#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
  int no_ipv6 = 0;
#endif
  const char *address;
  
  if (!CHECK_LISTEN_PORT_ID(argv[0]))
    scheme_wrong_contract("tcp-listen", LISTEN_PORT_ID_TYPE, 0, argc, argv);
  if (argc > 1) {
    if (!((SCHEME_INTP(argv[1]) && (SCHEME_INT_VAL(argv[1]) >= 1))
          || (SCHEME_BIGNUMP(argv[1]) && SCHEME_BIGPOS(argv[1]))))
      scheme_wrong_contract("tcp-listen", "exact-positive-integer?", 1, argc, argv);
  }
  if (argc > 2)
    reuse = SCHEME_TRUEP(argv[2]);
  if (argc > 3) {
    if (!SCHEME_CHAR_STRINGP(argv[3]) && !SCHEME_FALSEP(argv[3]))
      scheme_wrong_contract("tcp-listen", "(or/c string? #f)", 3, argc, argv);
  }
    
#ifdef USE_TCP
  TCP_INIT("tcp-listen");
#endif

  origid = (unsigned short)SCHEME_INT_VAL(argv[0]);
  if (argc > 1) {
    if (SCHEME_INTP(argv[1]))
      backlog = SCHEME_INT_VAL(argv[1]);
    else 
      backlog = 1024;
  } else
    backlog = 4;
  if ((argc > 3) && SCHEME_TRUEP(argv[3])) {
    Scheme_Object *bs;
    bs = scheme_char_string_to_byte_string(argv[3]);
    address = SCHEME_BYTE_STR_VAL(bs);
  } else
    address = NULL;

  scheme_security_check_network("tcp-listen", address, origid, 0);
  scheme_custodian_check_available(NULL, "tcp-listen", "network");

#ifdef USE_TCP
  id = origid;
#endif

#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
 retry:
#endif

#ifdef USE_TCP
  {
    GC_CAN_IGNORE struct mz_addrinfo *tcp_listen_addr, *addr;
    int err, count = 0, pos = 0, i;
    listener_t *l = NULL;
#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
    int any_v4 = 0, any_v6 = 0;
#endif

    tcp_listen_addr = scheme_get_host_address(address, id, &err, 
#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
					      no_ipv6 ? MZ_PF_INET : -1,
#else
					      -1, 
#endif
					      1, 1);

    for (addr = tcp_listen_addr; addr; addr = addr->ai_next) {
#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
      if (addr->ai_family == MZ_PF_INET)
	any_v4 = 1;
      else if (addr->ai_family == PF_INET6)
	any_v6 = 1;
#endif
      count++;
    }
		
    if (tcp_listen_addr) {
      tcp_t s;
#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
      /* Try IPv6 listeners first, so we can retry and use just IPv4 if
	 IPv6 doesn't work right. */
      int v6_loop = (any_v6 && any_v4), skip_v6 = 0;
#endif
      int first_time = 1;
      int first_was_zero = 0;
      unsigned short no_port = 0;

      errid = 0;
      for (addr = tcp_listen_addr; addr; ) {
#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
	if ((v6_loop && (addr->ai_family != PF_INET6))
	    || (skip_v6 && (addr->ai_family == PF_INET6))) {
	  addr = addr->ai_next;
	  if (v6_loop && !addr) {
	    v6_loop = 0;
	    skip_v6 = 1;
	    addr = tcp_listen_addr;
	  }
	  continue;
	}
#endif

	s = socket(addr->ai_family, addr->ai_socktype, addr->ai_protocol);

#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
	if (s == INVALID_SOCKET) {
	  /* Maybe it failed because IPv6 is not available: */
	  if ((addr->ai_family == PF_INET6) && (errno == EAFNOSUPPORT)) {
	    if (any_v4 && !pos) {
	      /* Maybe we can make it work with just IPv4. Try again. */
	      no_ipv6 = 1;
	      mz_freeaddrinfo(tcp_listen_addr);
	      goto retry;
	    }
	  }
	}
	if (s != INVALID_SOCKET) {
	  if (any_v4 && (addr->ai_family == PF_INET6)) {
	    int ok;
# ifdef IPV6_V6ONLY
	    int on = 1;
	    ok = setsockopt(s, IPPROTO_IPV6, IPV6_V6ONLY, &on, sizeof(on));
# else
	    ok = -1;
# endif
	    if (ok) {
	      if (!pos) {
		/* IPV6_V6ONLY doesn't work */
		no_ipv6 = 1;
		mz_freeaddrinfo(tcp_listen_addr);
		goto retry;
	      } else {
		errid = errno;
		closesocket(s);
                (void)scheme_fd_to_semaphore(s, MZFD_REMOVE, 1);
		errno = errid;
		s = INVALID_SOCKET;
	      }
	    }
	  }
	}
#endif

	if (s != INVALID_SOCKET) {
#ifdef USE_WINSOCK_TCP
	  unsigned long ioarg = 1;
	  ioctlsocket(s, FIONBIO, &ioarg);
#else
	  fcntl(s, F_SETFL, MZ_NONBLOCKING);
#endif

	  if (reuse) {
	    setsockopt(s, SOL_SOCKET, SO_REUSEADDR, (char *)(&reuse), sizeof(int));
	  }
      
          if (first_was_zero) {
            ((struct sockaddr_in *)addr->ai_addr)->sin_port = no_port;
          }
	  if (!bind(s, addr->ai_addr, addr->ai_addrlen)) {
            if (first_time) {
              if (((struct sockaddr_in *)addr->ai_addr)->sin_port == 0) {
                no_port = get_no_portno(s, &errid);
                first_was_zero = 1;
		if (no_port == 0) {
		  closesocket(s);
		  break;
		}
              }
              first_time = 0;
            }

	    if (!listen(s, backlog)) {
	      if (!pos) {
		l = scheme_malloc_tagged(sizeof(listener_t) + ((count - mzFLEX_DELTA) * sizeof(tcp_t)));
		l->so.type = scheme_listener_type;
		l->count = count;
# ifdef HAVE_POLL_SYSCALL
                {
                  struct pollfd *pfd;
                  pfd = (struct pollfd *)scheme_malloc_atomic(sizeof(struct pollfd) * count);
                  l->pfd = pfd;
                }
# endif
		{
		  Scheme_Custodian_Reference *mref;
		  mref = scheme_add_managed(NULL,
					    (Scheme_Object *)l,
					    (Scheme_Close_Custodian_Client *)stop_listener,
					    NULL,
					    1);
		  l->mref = mref;
		}
	      }
# ifdef HAVE_POLL_SYSCALL
              l->pfd[pos].fd = s;
              l->pfd[pos].events = POLLIN;
# endif
	      l->s[pos++] = s;
	    
	      REGISTER_SOCKET(s);

	      if (pos == count) {
		mz_freeaddrinfo(tcp_listen_addr);

		return (Scheme_Object *)l;
	      }
	    } else {
	      errid = SOCK_ERRNO();
	      closesocket(s);
	      break;
	    }
	  } else {
	    errid = SOCK_ERRNO();
	    closesocket(s);
	    break;
	  }
	} else {
	  errid = SOCK_ERRNO();
	  break;
	}

	addr = addr->ai_next;

#ifdef MZ_TCP_LISTEN_IPV6_ONLY_SOCKOPT
	if (!addr && v6_loop) {
	  v6_loop = 0;
	  skip_v6 = 1;
	  addr = tcp_listen_addr;
	}
#endif
      }

      for (i = 0; i < pos; i++) {
	s = l->s[i];
	UNREGISTER_SOCKET(s);
	closesocket(s);
      }
      
      mz_freeaddrinfo(tcp_listen_addr);
    } else {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "tcp-listen: host lookup failed\n"
                       "  address: %s\n"
                       "  system error: %N",
		       address ? address : "#f", 1, err);
      return NULL;
    }
  }

  scheme_raise_exn(MZEXN_FAIL_NETWORK,
		   "tcp-listen: listen failed\n"
                   "  port number: %d\n"
                   "  system error: %E",
		   (int)origid, errid);
#else
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
		   "tcp-listen: " NOT_SUPPORTED_STR);
#endif

  return NULL;
}

#ifdef USE_TCP
static int stop_listener(Scheme_Object *o)
{
  int was_closed = 0;

  {
    listener_t *listener = (listener_t *)o;
    int i;
    tcp_t s;
    s = listener->s[0];
    if (s == INVALID_SOCKET)
      was_closed = 1;
    else {
      for (i = 0; i < listener->count; i++) {
	s = listener->s[i];
	UNREGISTER_SOCKET(s);
	closesocket(s);
        (void)scheme_fd_to_semaphore(s, MZFD_REMOVE, 1);
	listener->s[i] = INVALID_SOCKET;
      }
      scheme_remove_managed(((listener_t *)o)->mref, o);
    }
  }

  return was_closed;
}
#endif

static Scheme_Object *
tcp_stop(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
  int was_closed;

  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
    scheme_wrong_contract("tcp-close", "tcp-listener?", 0, argc, argv);

  TCP_INIT("tcp-close");

  was_closed = stop_listener(argv[0]);

  if (was_closed) {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "tcp-close: listener was already closed");
    return NULL;
  }

  return scheme_void;
#else
  scheme_wrong_contract("tcp-close", "tcp-listener?", 0, argc, argv);
  return NULL;
#endif
}

static Scheme_Object *
tcp_accept_ready(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
  int ready;

  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
    scheme_wrong_contract("tcp-accept-ready?", "tcp-listener?", 0, argc, argv);

  TCP_INIT("tcp-accept-ready?");

  if (LISTENER_WAS_CLOSED(argv[0])) {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "tcp-accept-ready?: listener is closed");
    return NULL;
  }

  ready = tcp_check_accept(argv[0], NULL);

  return (ready ? scheme_true : scheme_false);
#else
  scheme_wrong_contract("tcp-accept-ready?", "tcp-listener?", 0, argc, argv);
  return NULL;
#endif
}

static Scheme_Object *
do_tcp_accept(int argc, Scheme_Object *argv[], Scheme_Object *cust, char **_fail_reason)
/* If _fail_reason is not NULL, never raise an exception. */
{
#ifdef USE_TCP
  int was_closed = 0, errid, ready_pos;
  Scheme_Object *listener;
  tcp_t s, ls;
  unsigned int l;
  GC_CAN_IGNORE char tcp_accept_addr[MZ_SOCK_NAME_MAX_LEN];

  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
    scheme_wrong_contract("tcp-accept", "tcp-listener?", 0, argc, argv);

  TCP_INIT("tcp-accept");

  listener = argv[0];

  was_closed = LISTENER_WAS_CLOSED(listener);

  if (!was_closed) {
    ready_pos = tcp_check_accept(listener, NULL);
    if (!ready_pos) {
      Scheme_Object *evt;
      evt = listener_to_evt((listener_t *)listener);
      if (evt)
        scheme_sync(1, &evt);
      else
        scheme_block_until((Scheme_Ready_Fun)tcp_check_accept, 
                           tcp_accept_needs_wakeup, 
                           listener, 
                           0.0);
      ready_pos = tcp_check_accept(listener, NULL);
    }
    was_closed = LISTENER_WAS_CLOSED(listener);
  } else
    ready_pos = 0;

  if (was_closed) {
    if (_fail_reason)
      *_fail_reason = "tcp-accept-evt: listener is closed";
    else
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
                       "tcp-accept: listener is closed");
    return NULL;
  }

  if (!_fail_reason)
    scheme_custodian_check_available((Scheme_Custodian *)cust, "tcp-accept", "network");
  else {
    if (!scheme_custodian_is_available((Scheme_Custodian *)cust)) {
      *_fail_reason = "tcp-accept-evt: custodian is shutdown";
      return NULL;
    }
  }
  
  ls = ((listener_t *)listener)->s[ready_pos-1];

  l = sizeof(tcp_accept_addr);

  do {
    s = accept(ls, (struct sockaddr *)tcp_accept_addr, &l);
  } while ((s == -1) && (NOT_WINSOCK(errno) == EINTR));

  if (s != INVALID_SOCKET) {
    Scheme_Object *v[2];
    Scheme_Tcp *tcp;
    
#  ifdef USE_UNIX_SOCKETS_TCP
    mzWHEN_SET_SOCKBUF_SIZE(int size = TCP_SOCKSENDBUF_SIZE);
    mzWHEN_SET_SOCKBUF_SIZE(setsockopt(s, SOL_SOCKET, SO_SNDBUF, (char *)&size, sizeof(int)));
#  endif

    tcp = make_tcp_port_data(s, 2);

    v[0] = make_tcp_input_port(tcp, "tcp-accepted", cust);
    v[1] = make_tcp_output_port(tcp, "tcp-accepted", cust);

    REGISTER_SOCKET(s);
    
    return scheme_values(2, v);
  }
  errid = SOCK_ERRNO();
  
  if (_fail_reason)
    *_fail_reason = "tcp-accept-evt: accept from listener failed";
  else
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
                     "tcp-accept: accept from listener failed\n"
                     "  system error: %E", 
                     errid);
#else
  scheme_wrong_contract("tcp-accept", "tcp-listener?", 0, argc, argv);
#endif

  return NULL;
}

static Scheme_Object *
tcp_accept(int argc, Scheme_Object *argv[])
{
  return do_tcp_accept(argc, argv, NULL, NULL);
}

static Scheme_Object *
tcp_accept_break(int argc, Scheme_Object *argv[])
{
  return scheme_call_enable_break(tcp_accept, argc, argv);
}

void scheme_register_network_evts()
{
#ifdef USE_TCP
  scheme_add_evt(scheme_listener_type, (Scheme_Ready_Fun)tcp_check_accept, tcp_accept_needs_wakeup, NULL, 0);
  scheme_add_evt(scheme_tcp_accept_evt_type, (Scheme_Ready_Fun)tcp_check_accept_evt, tcp_accept_evt_needs_wakeup, NULL, 0);
# ifdef UDP_IS_SUPPORTED
  scheme_add_evt(scheme_udp_evt_type, (Scheme_Ready_Fun)udp_evt_check_ready, udp_evt_needs_wakeup, NULL, 0);
# endif
#endif
}

static Scheme_Object *tcp_listener_p(int argc, Scheme_Object *argv[])
{
   return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type)
	   ? scheme_true
	   : scheme_false);
}

void scheme_getnameinfo(void *sa, int salen, 
			char *host, int hostlen,
			char *serv, int servlen)
{
#ifdef USE_TCP
# ifdef HAVE_GETADDRINFO
  getnameinfo(sa, salen, host, hostlen, serv, servlen,
	      NI_NUMERICHOST | NI_NUMERICSERV);
# else
  if (host) {
    unsigned char *b;
    b = (unsigned char *)&((struct sockaddr_in *)sa)->sin_addr;
    sprintf(host, "%d.%d.%d.%d", b[0], b[1], b[2], b[3]);
  }
  if (serv) {
    int id;
    id = ntohs(((struct sockaddr_in *)sa)->sin_port);
    sprintf(serv, "%d", id);
  }
# endif
#else
  scheme_signal_error("getnameinfo unsupported");
#endif
}

static int extract_svc_value(char *svc_buf)
{
  int id = 0, j;
  for (j = 0; svc_buf[j]; j++) {
    id = (id * 10) + (svc_buf[j] - '0');
  }
  return id;
}

#define SCHEME_LISTEN_PORTP(p) SAME_TYPE(SCHEME_TYPE(p), scheme_listener_type)
#define SCHEME_UDP_PORTP(p) SAME_TYPE(SCHEME_TYPE(p), scheme_udp_type)

static Scheme_Object *tcp_addresses(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
  tcp_t socket = 0;
  Scheme_Tcp *tcp = NULL;
  int closed = 0;
  Scheme_Object *result[4];
  int with_ports = 0;
  int listener = 0;
  int udp = 0;

  if (SCHEME_OUTPUT_PORTP(argv[0])) {
    Scheme_Output_Port *op;
    op = scheme_output_port_record(argv[0]);
    if (op->sub_type == scheme_tcp_output_port_type)
      tcp = op->port_data;
    closed = op->closed;
  } else if (SCHEME_INPUT_PORTP(argv[0])) {
    Scheme_Input_Port *ip;
    ip = scheme_input_port_record(argv[0]);
    if (ip->sub_type == scheme_tcp_input_port_type)
      tcp = ip->port_data;
    closed = ip->closed;
  }

  if (argc > 1)
    with_ports = SCHEME_TRUEP(argv[1]);

  if (tcp) {
    socket = tcp->tcp;
  }
  else {
    if (SCHEME_LISTEN_PORTP(argv[0])) {
      listener = 1;
      socket = ((listener_t *)argv[0])->s[0];
    } else if (SCHEME_UDP_PORTP(argv[0])) {
      udp = 1;
      socket = ((Scheme_UDP *)argv[0])->s;
    } else {
      scheme_wrong_contract("tcp-addresses", "tcp-port?", 0, argc, argv);
    }
  }

  if (closed)
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "tcp-addresses: port is closed");

  {
    unsigned int l;
    char here[MZ_SOCK_NAME_MAX_LEN], there[MZ_SOCK_NAME_MAX_LEN];
    char host_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
    char svc_buf[MZ_SOCK_SVC_NAME_MAX_LEN];
    unsigned int here_len;
    unsigned int there_len = 0;
    int peerrc = 0;

    l = sizeof(here);
    if (getsockname(socket, (struct sockaddr *)here, &l)) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "tcp-addresses: could not get local address\n"
                       "  system error: %E",
		       SOCK_ERRNO());
    }
    here_len = l;

    if (!listener) {
      l = sizeof(there);
      peerrc = getpeername(socket, (struct sockaddr *)there, &l);
      if (peerrc && !udp) {
        scheme_raise_exn(MZEXN_FAIL_NETWORK, 
                         "tcp-addresses: could not get peer address\n"
                         "  system error: %E", 
                         SOCK_ERRNO());
      }
      there_len = l;
    }

    scheme_getnameinfo((struct sockaddr *)here, here_len, 
		       host_buf, sizeof(host_buf),
                       (with_ports ? svc_buf : NULL), 
                       (with_ports ? sizeof(svc_buf) : 0));
    result[0] = scheme_make_utf8_string(host_buf);
    if (with_ports) {
      l = extract_svc_value(svc_buf);
      result[1] = scheme_make_integer(l);
    }

    if (listener || (udp && peerrc)) {
      result[with_ports ? 2 : 1] = scheme_make_utf8_string("0.0.0.0");
      result[3] = scheme_make_integer(0);
    }
    else {
      scheme_getnameinfo((struct sockaddr *)there, there_len, 
          host_buf, sizeof(host_buf),
          (with_ports ? svc_buf : NULL), 
          (with_ports ? sizeof(svc_buf) : 0));
      result[with_ports ? 2 : 1] = scheme_make_utf8_string(host_buf);
      if (with_ports) {
        l = extract_svc_value(svc_buf);
        result[3] = scheme_make_integer(l);
      }
    }
  }

  return scheme_values(with_ports ? 4 : 2, result);
#else
  /* First arg can't possibly be right! */
  scheme_wrong_contract("tcp-addresses", "tcp-port?", 0, argc, argv);
#endif
}

static Scheme_Object *tcp_abandon_port(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
  if (SCHEME_OUTPUT_PORTP(argv[0])) {
    Scheme_Output_Port *op;
    op = scheme_output_port_record(argv[0]);
    if (op->sub_type == scheme_tcp_output_port_type) {
      if (!op->closed) {
	((Scheme_Tcp *)op->port_data)->flags |= MZ_TCP_ABANDON_OUTPUT;
	scheme_close_output_port(argv[0]);
      }
      return scheme_void;
    }
  } else if (SCHEME_INPUT_PORTP(argv[0])) {
    /* Abandon is not really useful on input ports from the Racketeer's
       perspective, but it's here for completeness. */
    Scheme_Input_Port *ip;
    ip = scheme_input_port_record(argv[0]);
    if (ip->sub_type == scheme_tcp_input_port_type) {
      if (!ip->closed) {
	((Scheme_Tcp *)ip->port_data)->flags |= MZ_TCP_ABANDON_INPUT;
	scheme_close_input_port(argv[0]);
      }
      return scheme_void;
    }
  }
#endif

  scheme_wrong_contract("tcp-abandon-port", "tcp-port?", 0, argc, argv);

  return NULL;
}

void scheme_tcp_abandon_port(Scheme_Object *port) {
  tcp_abandon_port(1, &port);
}

static Scheme_Object *tcp_port_p(int argc, Scheme_Object *argv[])
{
#ifdef USE_TCP
  if (SCHEME_OUTPUT_PORTP(argv[0])) {
    Scheme_Output_Port *op;
    op = scheme_output_port_record(argv[0]);
    if (op->sub_type == scheme_tcp_output_port_type) {
      return scheme_true;
    }
  } else if (SCHEME_INPUT_PORTP(argv[0])) {
    Scheme_Input_Port *ip;
    ip = scheme_input_port_record(argv[0]);
    if (ip->sub_type == scheme_tcp_input_port_type) {
      return scheme_true;
    }
  }
#endif

  return scheme_false;
}


static Scheme_Object *tcp_accept_evt(int argc, Scheme_Object *argv[])
{
  Scheme_Object *r, *custodian;

  if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_listener_type))
    scheme_wrong_contract("tcp-accept-evt", "tcp-listener?", 0, argc, argv);

  custodian = scheme_get_param(scheme_current_config(), MZCONFIG_CUSTODIAN);

  scheme_custodian_check_available((Scheme_Custodian *)custodian, "tcp-accept", "network");
  
  r = scheme_alloc_object();
  r->type = scheme_tcp_accept_evt_type;
  SCHEME_PTR1_VAL(r) = argv[0];
  SCHEME_PTR2_VAL(r) = custodian;

  return r;
}

static Scheme_Object *accept_failed(void *_msg, int argc, Scheme_Object **argv)
{
  scheme_raise_exn(MZEXN_FAIL_NETWORK, (char *)_msg);
  return NULL;
} 

static int tcp_check_accept_evt(Scheme_Object *ae, Scheme_Schedule_Info *sinfo)
{
  if (tcp_check_accept(SCHEME_PTR1_VAL(ae), NULL)) {
    Scheme_Object *a[2];
    char *fail_reason = NULL;
    a[0] = SCHEME_PTR1_VAL(ae);
    if (do_tcp_accept(1, a, SCHEME_PTR2_VAL(ae), &fail_reason)) {
      a[0] = scheme_current_thread->ku.multiple.array[0];
      a[1] = scheme_current_thread->ku.multiple.array[1];
      scheme_set_sync_target(sinfo, scheme_build_list(2, a), NULL, NULL, 0, 0, NULL);
      return 1;
    } else {
      /* error on accept */
      scheme_set_sync_target(sinfo, scheme_always_ready_evt, 
                             scheme_make_closed_prim(accept_failed, fail_reason),
                             NULL, 0, 0, NULL);
      return 1;
    }
  } else
    return 0;
}

static void tcp_accept_evt_needs_wakeup(Scheme_Object *ae, void *fds)
{
  tcp_accept_needs_wakeup(SCHEME_PTR1_VAL(ae), fds);
}

int scheme_get_port_socket(Scheme_Object *p, intptr_t *_s)
{
#ifdef USE_TCP
  tcp_t s = 0;
  int s_ok = 0;

  if (SCHEME_OUTPUT_PORTP(p)) {
    Scheme_Output_Port *op;
    op = scheme_output_port_record(p);
    if (op->sub_type == scheme_tcp_output_port_type) {
      if (!op->closed) {
	s = ((Scheme_Tcp *)op->port_data)->tcp;
	s_ok = 1;
      }
    }
  } else if (SCHEME_INPUT_PORTP(p)) {
    Scheme_Input_Port *ip;
    ip = scheme_input_port_record(p);
    if (ip->sub_type == scheme_tcp_input_port_type) {
      if (!ip->closed) {
	s = ((Scheme_Tcp *)ip->port_data)->tcp;
	s_ok = 1;
      }
    }
  }

  if (s_ok) {
    *_s = (intptr_t)s;
    return 1;
  } else
    return 0;
#endif
}

void scheme_socket_to_ports(intptr_t s, const char *name, int takeover,
                            Scheme_Object **_inp, Scheme_Object **_outp)
{
#ifdef USE_TCP
  Scheme_Tcp *tcp;
  Scheme_Object *v;

  tcp = make_tcp_port_data(s, takeover ? 2 : 3);

  v = make_tcp_input_port(tcp, name, NULL);
  *_inp = v;
  v = make_tcp_output_port(tcp, name, NULL);
  *_outp = v;
  
  if (takeover) {
    REGISTER_SOCKET(s);
  }
#else
  *_inp = NULL;
  *_outp = NULL;
#endif
}

void scheme_socket_to_input_port(intptr_t s, Scheme_Object *name, int takeover,
                                 Scheme_Object **_inp)
{
#ifdef USE_TCP
  Scheme_Tcp *tcp;
  Scheme_Object *v;

  tcp = make_tcp_port_data(s, takeover ? 1 : 2);

  v = make_tcp_input_port_symbol_name(tcp, name, NULL);
  *_inp = v;
  
  if (takeover) {
    REGISTER_SOCKET(s);
  }
#else
  *_inp = NULL;
#endif
}

void scheme_socket_to_output_port(intptr_t s, Scheme_Object *name, int takeover,
                                  Scheme_Object **_outp)
{
#ifdef USE_TCP
  Scheme_Tcp *tcp;
  Scheme_Object *v;

  tcp = make_tcp_port_data(s, takeover ? 1 : 2);

  v = make_tcp_output_port_symbol_name(tcp, name, NULL);
  *_outp = v;
  
  if (takeover) {
    REGISTER_SOCKET(s);
  }
#else
  *_outp = NULL;
#endif
}

intptr_t scheme_dup_socket(intptr_t fd) {
#ifdef USE_TCP
# ifdef USE_WINSOCK_TCP
  intptr_t nsocket;
  intptr_t rc;
  WSAPROTOCOL_INFO protocolInfo;
  rc = WSADuplicateSocket(fd, GetCurrentProcessId(), &protocolInfo);
  if (rc)
    return rc;
  nsocket = WSASocket(FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO, FROM_PROTOCOL_INFO, &protocolInfo, 0, WSA_FLAG_OVERLAPPED);
  REGISTER_SOCKET(nsocket);
  return nsocket;
# else
  intptr_t nfd;
  do {
    nfd = dup(fd);
  } while (nfd == -1 && errno == EINTR);
  return nfd;
# endif
#else
  return -1;
#endif
}

void scheme_close_socket_fd(intptr_t fd) 
{
#ifdef USE_TCP
  UNREGISTER_SOCKET(fd);
  closesocket(fd);
  (void)scheme_fd_to_semaphore(fd, MZFD_REMOVE, 1);
#endif
}

/*========================================================================*/
/*                                 UDP                                    */
/*========================================================================*/

/* Based on a design and implemenation by Eduardo Cavazos. */

#ifdef UDP_IS_SUPPORTED

typedef struct Scheme_UDP_Evt {
  Scheme_Object so; /* scheme_udp_evt_type */
  Scheme_UDP *udp;
  short for_read, with_addr;
  int offset, len;
  char *str;
  int dest_addr_count;
  char **dest_addrs;
  int *dest_addr_lens;
} Scheme_UDP_Evt;

static int udp_close_it(Scheme_Object *_udp)
{
  Scheme_UDP *udp = (Scheme_UDP *)_udp;

  if (udp->s != INVALID_SOCKET) {
    closesocket(udp->s);
    (void)scheme_fd_to_semaphore(udp->s, MZFD_REMOVE, 1);
    udp->s = INVALID_SOCKET;

    scheme_remove_managed(udp->mref, (Scheme_Object *)udp);

    return 0;
  }

  return 1;
}

#else

typedef struct Scheme_UDP_Evt { } Scheme_UDP_Evt;
typedef Scheme_Object Scheme_UDP;

#endif

static Scheme_Object *make_udp(int argc, Scheme_Object *argv[])
{
#ifdef UDP_IS_SUPPORTED
  Scheme_UDP *udp;
  tcp_t s;
  char *address = "";
  unsigned short origid, id;

  TCP_INIT("udp-open-socket");

  if ((argc > 0) && !SCHEME_FALSEP(argv[0]) && !SCHEME_CHAR_STRINGP(argv[0]))
    scheme_wrong_contract("udp-open-socket", "(or/c string? #f)", 0, argc, argv);
  if ((argc > 1) && !SCHEME_FALSEP(argv[1]) && !CHECK_PORT_ID(argv[1]))
    scheme_wrong_contract("udp-open-socket", "(or/c " PORT_ID_TYPE " #f)", 1, argc, argv);

  if ((argc > 0) && SCHEME_TRUEP(argv[0])) {
    Scheme_Object *bs;
    bs = scheme_char_string_to_byte_string(argv[0]);
    address = SCHEME_BYTE_STR_VAL(bs);
  } else
    address = NULL;
  if ((argc > 1) && SCHEME_TRUEP(argv[1]))
    origid = (unsigned short)SCHEME_INT_VAL(argv[1]);
  else
    origid = 0;

  scheme_security_check_network("udp-open-socket", address, origid, 0);
  scheme_custodian_check_available(NULL, "udp-open-socket", "network");

  if (address || origid) {
    int err;
    GC_CAN_IGNORE struct mz_addrinfo *udp_bind_addr = NULL;
    if (!origid)
      origid = 1025;
    id = origid;
    udp_bind_addr = scheme_get_host_address(address, id, &err, -1, 1, 0);
    if (!udp_bind_addr) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "udp-open-socket: can't resolve address\n"
                       "  address: %s\n"
                       "  system error: %N", 
		       address ? address : "<unspec>", 1, err);
      return NULL;
    }
    s = socket(udp_bind_addr->ai_family,
	       udp_bind_addr->ai_socktype,
	       udp_bind_addr->ai_protocol);
    mz_freeaddrinfo(udp_bind_addr);
  } else {
    s = socket(MZ_PF_INET, SOCK_DGRAM, 0);
  }

  if (s == INVALID_SOCKET) {
    int errid;
    errid = SOCK_ERRNO();
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "udp-open-socket: creation failed\n"
                     "  system error: %E", 
                     errid);
    return NULL;
  }

  udp = MALLOC_ONE_TAGGED(Scheme_UDP);
  udp->so.type = scheme_udp_type;
  udp->s = s;
  udp->bound = 0;
  udp->connected = 0;
  udp->previous_from_addr = NULL;

#ifdef USE_WINSOCK_TCP
  {
    unsigned long ioarg = 1;
    BOOL bc = 1;
    ioctlsocket(s, FIONBIO, &ioarg);
    setsockopt(s, SOL_SOCKET, SO_BROADCAST, (char *)(&bc), sizeof(BOOL));
  }
#else
  fcntl(s, F_SETFL, MZ_NONBLOCKING);
# ifdef SO_BROADCAST
  {
    int bc = 1;
    setsockopt(s, SOL_SOCKET, SO_BROADCAST, &bc, sizeof(bc));
  }
# endif
#endif

  {
    Scheme_Custodian_Reference *mref;
    mref = scheme_add_managed(NULL,
			      (Scheme_Object *)udp,
			      (Scheme_Close_Custodian_Client *)udp_close_it,
			      NULL,
			      1);
    udp->mref = mref;
  }

  return (Scheme_Object *)udp;
#else
  scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
		   "udp-open-socket: " NOT_SUPPORTED_STR);
  return NULL;
#endif
}

static Scheme_Object *
udp_close(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_UDPP(argv[0]))
    scheme_wrong_contract("udp-close", "udp?", 0, argc, argv);

#ifdef UDP_IS_SUPPORTED
  if (udp_close_it(argv[0])) {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "udp-close: udp socket was already closed");
    return NULL;
  }
#endif

  return scheme_void;
}

static Scheme_Object *
udp_p(int argc, Scheme_Object *argv[])
{
  return (SCHEME_UDPP(argv[0]) ? scheme_true : scheme_false);
}

static Scheme_Object *
udp_bound_p(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_UDPP(argv[0]))
    scheme_wrong_contract("udp-bound?", "udp?", 0, argc, argv);

#ifdef UDP_IS_SUPPORTED
  return (((Scheme_UDP *)argv[0])->bound ? scheme_true : scheme_false);
#else
  return scheme_void;
#endif
}

static Scheme_Object *
udp_connected_p(int argc, Scheme_Object *argv[])
{
  if (!SCHEME_UDPP(argv[0]))
    scheme_wrong_contract("udp-connected?", "udp?", 0, argc, argv);

#ifdef UDP_IS_SUPPORTED
  return (((Scheme_UDP *)argv[0])->connected ? scheme_true : scheme_false);
#else
  return scheme_void;
#endif
}

#ifdef UDP_DISCONNECT_EADRNOTAVAIL_OK
# define OK_DISCONNECT_ERROR(e) (((e) == mz_AFNOSUPPORT) || ((e) == EADDRNOTAVAIL))
#else
# define OK_DISCONNECT_ERROR(e) ((e) == mz_AFNOSUPPORT)
#endif

static Scheme_Object *udp_bind_or_connect(const char *name, int argc, Scheme_Object *argv[], int do_bind)
{
  if (!SCHEME_UDPP(argv[0]))
    scheme_wrong_contract(name, "udp?", 0, argc, argv);

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp;
    char *address = NULL;
    unsigned short port = 0;
    GC_CAN_IGNORE struct mz_addrinfo *udp_bind_addr = NULL, *addr;

    udp = (Scheme_UDP *)argv[0];

    if (!SCHEME_FALSEP(argv[1]) && !SCHEME_CHAR_STRINGP(argv[1]))
      scheme_wrong_contract(name, "(or/c string? #f)", 1, argc, argv);
    if (do_bind && !CHECK_LISTEN_PORT_ID(argv[2]))
      scheme_wrong_contract(name, LISTEN_PORT_ID_TYPE, 2, argc, argv);
    if (!do_bind && !SCHEME_FALSEP(argv[2]) && !CHECK_PORT_ID(argv[2]))
      scheme_wrong_contract(name, "(or/c " PORT_ID_TYPE " #f)", 2, argc, argv);

    if (SCHEME_TRUEP(argv[1])) {
      Scheme_Object *bs;
      bs = scheme_char_string_to_byte_string(argv[1]);
      address = SCHEME_BYTE_STR_VAL(bs);
    }
    if (SCHEME_TRUEP(argv[2]))
      port = (unsigned short)SCHEME_INT_VAL(argv[2]);
    
    if (!do_bind && (SCHEME_TRUEP(argv[1]) != SCHEME_TRUEP(argv[2]))) {
      scheme_contract_error(name,
                            "last second and third arguments must be both #f or both non-#f",
                            "second argument", 1, argv[1], 
                            "third argument", 1, argv[2],
                            NULL);
    }

    scheme_security_check_network(name, address, port, !do_bind);

    if (udp->s == INVALID_SOCKET) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK, 
                       "%s: udp socket was already closed\n"
                       "  socket: %V", 
                       name, udp); 
      return NULL;
    }
    if (do_bind && udp->bound) { 
      scheme_raise_exn(MZEXN_FAIL_NETWORK, 
                       "%s: udp socket is already bound\n"
                       "  socket: %V", 
                       name, udp);
      return NULL;
    }

    if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2])) {
      /* DISCONNECT */
      int errid = 0;
      if (udp->connected) {
        int ok;
#ifdef USE_NULL_TO_DISCONNECT_UDP
        ok = !connect(udp->s, NULL, 0);
#else
        GC_CAN_IGNORE mz_unspec_address ua;
        ua.sin_family = AF_UNSPEC;
        ua.sin_port = 0;
        memset(&(ua.sin_addr), 0, sizeof(ua.sin_addr));
        memset(&(ua.sin_zero), 0, sizeof(ua.sin_zero));
        ok = !connect(udp->s, (struct sockaddr *)&ua, sizeof(ua));
#endif
        if (!ok) errid = SOCK_ERRNO();
        if (ok || OK_DISCONNECT_ERROR(errid)) {
          udp->connected = 0;
          return scheme_void;
        }
        else {
          scheme_raise_exn(MZEXN_FAIL_NETWORK, 
                           "%s: can't disconnect\n"
                           "  address: %s\n"
                           "  port number: %d\n"
                           "  system error: %E",
                           name, 
                           address ? address : "#f", port,
                           errid);
        }
      }
      return scheme_void;
    }

    {
      /* RESOLVE ADDRESS */
      int err;
      udp_bind_addr = scheme_get_host_address(address, port, &err, -1, do_bind, 0);
      if (!udp_bind_addr) {
        scheme_raise_exn(MZEXN_FAIL_NETWORK, 
                         "%s: can't resolve address\n"
                         "  address: %s\n"
                         "  system error: %N", 
                         name, 
                         address, 
                         1, err);
        return NULL;
      }
    }

    if (!do_bind) {
      /* CONNECT CASE */
      int ok, errid = -1;

      /* connect using first address that works: */
      for (addr = udp_bind_addr; addr; addr = addr->ai_next) {
        ok = !connect(udp->s, addr->ai_addr, addr->ai_addrlen);
        if (ok) {
          udp->connected = 1;
          mz_freeaddrinfo(udp_bind_addr);
          return scheme_void;
        } else
          errid = SOCK_ERRNO();
      }

      mz_freeaddrinfo(udp_bind_addr);

      scheme_raise_exn(MZEXN_FAIL_NETWORK, 
                       "%s: can't connect\n"
                       "  address: %s\n"
                       "  port number: %d\n"
                       "  system error: %E", 
                       name, 
                       address ? address : "#f", 
                       port, 
                       errid);

      return NULL;
    } else {
      /* BIND CASE */
      int ok, errid = -1;

      if ((argc > 3) && SCHEME_TRUEP(argv[3])) {
	int one = 1;
	if (setsockopt(udp->s, SOL_SOCKET, SO_REUSEADDR, (void *) &one, sizeof(one))) {
	  scheme_raise_exn(MZEXN_FAIL_NETWORK,
			   "%s: can't set SO_REUSEADDR\n"
			   "  system error: %E",
			   name,
			   SOCK_ERRNO());
	  return NULL;
	}
      }

      /* bind using first address that works: */
      for (addr = udp_bind_addr; addr; addr = addr->ai_next) {
        ok = !bind(udp->s, addr->ai_addr, addr->ai_addrlen);
        if (ok) {
          udp->bound = 1;
          mz_freeaddrinfo(udp_bind_addr);
          return scheme_void;
        } else
          errid = SOCK_ERRNO();
      }

      mz_freeaddrinfo(udp_bind_addr);

      scheme_raise_exn(MZEXN_FAIL_NETWORK, 
                       "%s: can't bind\n"
                       "  address: %s\n"
                       "  port number: %d\n"
                       "  system error: %E",
                       name, 
                       address ? address : "#f", 
                       port, 
                       errid);
      return NULL;
    }
  }
#else
  return scheme_void;
#endif
}

static Scheme_Object *udp_bind(int argc, Scheme_Object *argv[])
{
  return udp_bind_or_connect("udp-bind!", argc, argv, 1);
}

static Scheme_Object *udp_connect(int argc, Scheme_Object *argv[])
{
  return udp_bind_or_connect("udp-connect!", argc, argv, 0);
}

#ifdef UDP_IS_SUPPORTED

static int udp_check_send(Scheme_Object *_udp, Scheme_Schedule_Info *sinfo)
{
  Scheme_UDP *udp = (Scheme_UDP *)_udp;

  if (udp->s == INVALID_SOCKET)
    return 1;

  if (!sinfo || !sinfo->is_poll) {
    if (!check_fd_sema(udp->s, MZFD_CHECK_WRITE, sinfo, NULL))
      return 0;
  }

# ifdef HAVE_POLL_SYSCALL
  {
    GC_CAN_IGNORE struct pollfd pfd[1];
    int sr;

    pfd[0].fd = udp->s;
    pfd[0].events = POLLOUT;
    do {
      sr = poll(pfd, 1, 0);
    } while ((sr == -1) && (errno == EINTR));

    if (sr)
      return sr;
  }
# else
  {
    DECL_OS_FDSET(writefds);
    DECL_OS_FDSET(exnfds);
    struct timeval time = {0, 0};
    int sr;
    
    INIT_DECL_OS_WR_FDSET(writefds);
    INIT_DECL_OS_ER_FDSET(exnfds);
    
    MZ_OS_FD_ZERO(writefds);
    MZ_OS_FD_SET(udp->s, writefds);
    MZ_OS_FD_ZERO(exnfds);
    MZ_OS_FD_SET(udp->s, exnfds);
    
    do {
      sr = select(udp->s + 1, NULL, writefds, exnfds, &time);
    } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
   
    if (sr)
      return sr;
  }
#endif

  check_fd_sema(udp->s, MZFD_CREATE_WRITE, sinfo, NULL);
  
  return 0;
}

static void udp_send_needs_wakeup(Scheme_Object *_udp, void *fds)
{
  Scheme_UDP *udp = (Scheme_UDP *)_udp;
  void *fds1, *fds2;
  tcp_t s = udp->s;
  
  fds1 = MZ_GET_FDSET(fds, 1);
  fds2 = MZ_GET_FDSET(fds, 2);
  
  MZ_FD_SET(s, (fd_set *)fds1);
  MZ_FD_SET(s, (fd_set *)fds2);
}

#endif

#ifdef UDP_IS_SUPPORTED
static Scheme_Object *do_udp_send_it(const char *name, Scheme_UDP *udp,
				     char *bstr, intptr_t start, intptr_t end,
				     char *dest_addr, int dest_addr_len, int can_block,
                                     int ignore_addr_failure)
{
  intptr_t x;
  int errid = 0;

  while (1) {
    if (udp->s == INVALID_SOCKET) {
      /* socket was closed, maybe while we slept */
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "%s: udp socket is closed\n"
                       "  socket: %V",
		       name, udp);
      return NULL;
    }
    if ((!dest_addr && !udp->connected)
	|| (dest_addr && udp->connected)) {
      /* socket is unconnected, maybe disconnected while we slept */
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "%s: udp socket is%s connected\n"
                       "  socket: %V",
		       name, 
		       dest_addr ? "" : " not",
		       udp);
      return NULL;
    }

    udp->bound = 1; /* in case it's not bound already, send[to] binds it */

    if (dest_addr)
      x = sendto(udp->s, bstr XFORM_OK_PLUS start, end - start, 
		 0, (struct sockaddr *)dest_addr, dest_addr_len);
    else
      x = send(udp->s, bstr XFORM_OK_PLUS start, end - start, 0);

    if (x == -1) {
      errid = SOCK_ERRNO();
      if (ignore_addr_failure && WAS_EBADADDRESS(errid)) {
        return NULL;
      } else if (WAS_EAGAIN(errid)) {
	if (can_block) {
	  /* Block and eventually try again. */
          Scheme_Object *sema;
          sema = scheme_fd_to_semaphore(udp->s, MZFD_CREATE_WRITE, 1);
          if (sema)
            scheme_wait_sema(sema, 0);
          else
            scheme_block_until((Scheme_Ready_Fun)udp_check_send, 
                               udp_send_needs_wakeup, 
                               (Scheme_Object *)udp, 
                               0);
	} else
	  return scheme_false;
      } else if (NOT_WINSOCK(errid) != EINTR)
	break;
    } else if (x != (end - start)) {
      /* this isn't supposed to happen: */
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "%s: didn't send enough (%d != %d)", 
		       name,
		       x, end - start);
      return NULL;
    } else
      break;
  }
    
  if (x > -1) {
    return (can_block ? scheme_void : scheme_true);
  } else {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "%s: send failed\n"
                     "  system error: %E", 
		     name,
		     errid);
    return NULL;
  }
}
#endif

static Scheme_Object *udp_send_it(const char *name, int argc, Scheme_Object *argv[],
				  int with_addr, int can_block, Scheme_UDP_Evt *fill_evt)
{
#ifdef UDP_IS_SUPPORTED
  Scheme_UDP *udp;
  char *address = "";
  intptr_t start, end;
  int delta, err;
  unsigned short origid, id;
  GC_CAN_IGNORE struct mz_addrinfo *udp_dest_addr;

  udp = (Scheme_UDP *)argv[0];
#endif

  if (!SCHEME_UDPP(argv[0]))
    scheme_wrong_contract(name, "udp?", 0, argc, argv);

#ifdef UDP_IS_SUPPORTED
  if (with_addr) {
    if (!SCHEME_CHAR_STRINGP(argv[1]))
      scheme_wrong_contract(name, "string?", 1, argc, argv);
    if (!CHECK_PORT_ID(argv[2]))
      scheme_wrong_contract(name, PORT_ID_TYPE, 2, argc, argv);
    delta = 0;
  } else
    delta = -2;

  if (!SCHEME_BYTE_STRINGP(argv[3 + delta]))
    scheme_wrong_contract(name, "bytes?", 3 + delta, argc, argv);
  
  scheme_get_substring_indices(name, argv[3 + delta], 
			       argc, argv,
			       4 + delta, 5 + delta, &start, &end);

  if (with_addr) {
    Scheme_Object *bs;
    bs = scheme_char_string_to_byte_string(argv[1]);
    address = SCHEME_BYTE_STR_VAL(bs);
    origid = (unsigned short)SCHEME_INT_VAL(argv[2]);

    scheme_security_check_network(name, address, origid, 1);

    id = origid;
  } else {
    address = NULL;
    id = origid = 0;
  }

  if (with_addr)
    udp_dest_addr = scheme_get_host_address(address, id, &err, -1, 0, 0);
  else
    udp_dest_addr = NULL;

  if (!with_addr || udp_dest_addr) {
    if (fill_evt) {
      char *s;
      fill_evt->str = SCHEME_BYTE_STR_VAL(argv[3+delta]);
      fill_evt->offset = start;
      fill_evt->len = end - start;
      if (udp_dest_addr) {
        GC_CAN_IGNORE struct mz_addrinfo *addr;
        int j, *lens;
        char **addrs;
        for (j = 0, addr = udp_dest_addr; addr; addr = addr->ai_next) {
          j++;
        }
        fill_evt->dest_addr_count = j;
        addrs = MALLOC_N(char*, j);
        fill_evt->dest_addrs = addrs;
        lens = MALLOC_N_ATOMIC(int, j);
        fill_evt->dest_addr_lens = lens;
        for (j = 0, addr = udp_dest_addr; addr; addr = addr->ai_next, j++) {
          s = (char *)scheme_malloc_atomic(addr->ai_addrlen);
          memcpy(s, addr->ai_addr, addr->ai_addrlen);
          fill_evt->dest_addrs[j] = s;
          fill_evt->dest_addr_lens[j] = addr->ai_addrlen;
        }
        mz_freeaddrinfo(udp_dest_addr);
      }
      return scheme_void;
    } else {
      Scheme_Object *r;
      if (udp_dest_addr) {
        GC_CAN_IGNORE struct mz_addrinfo *addr;
        r = NULL;
        for (addr = udp_dest_addr; !r && addr; addr = addr->ai_next) {
          r = do_udp_send_it(name, udp,
                             SCHEME_BYTE_STR_VAL(argv[3+delta]), start, end,
                             (char *)addr->ai_addr,
                             addr->ai_addrlen,
                             can_block,
                             !!addr->ai_next);
        }
	mz_freeaddrinfo(udp_dest_addr);
      } else {
        r = do_udp_send_it(name, udp,
                           SCHEME_BYTE_STR_VAL(argv[3+delta]), start, end,
                           NULL, 0, can_block, 1);
      }
      return r;
    }
  } else {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "%s: can't resolve address\n"
                     "  address: %s\n"
                     "  system error: %N", 
		     name,
		     address, 1, err);
    return NULL;
  }
#else
  return scheme_void;
#endif
}

static Scheme_Object *udp_send_to(int argc, Scheme_Object *argv[])
{
  return udp_send_it("udp-send-to", argc, argv, 1, 1, NULL);
}

static Scheme_Object *udp_send(int argc, Scheme_Object *argv[])
{
  return udp_send_it("udp-send", argc, argv, 0, 1, NULL);
}

static Scheme_Object *udp_send_to_star(int argc, Scheme_Object *argv[])
{
  return udp_send_it("udp-send-to*", argc, argv, 1, 0, NULL);
}

static Scheme_Object *udp_send_star(int argc, Scheme_Object *argv[])
{
  return udp_send_it("udp-send*", argc, argv, 0, 0, NULL);
}

static Scheme_Object *udp_send_to_enable_break(int argc, Scheme_Object *argv[])
{
  return scheme_call_enable_break(udp_send_to, argc, argv);
}

static Scheme_Object *udp_send_enable_break(int argc, Scheme_Object *argv[])
{
  return scheme_call_enable_break(udp_send, argc, argv);
}

#ifdef UDP_IS_SUPPORTED

static int udp_check_recv(Scheme_Object *_udp, Scheme_Schedule_Info *sinfo)
{
  Scheme_UDP *udp = (Scheme_UDP *)_udp;

  if (udp->s == INVALID_SOCKET)
    return 1;

  if (!sinfo || !sinfo->is_poll) {
    if (!check_fd_sema(udp->s, MZFD_CHECK_READ, sinfo, NULL))
      return 0;
  }

# ifdef HAVE_POLL_SYSCALL
  {
    GC_CAN_IGNORE struct pollfd pfd[1];
    int sr;

    pfd[0].fd = udp->s;
    pfd[0].events = POLLIN;
    do {
      sr = poll(pfd, 1, 0);
    } while ((sr == -1) && (errno == EINTR));

    if (sr)
      return sr;
  }
# else
  {
    DECL_OS_FDSET(readfds);
    DECL_OS_FDSET(exnfds);
    struct timeval time = {0, 0};
    int sr;
    
    INIT_DECL_OS_RD_FDSET(readfds);
    INIT_DECL_OS_ER_FDSET(exnfds);
    
    MZ_OS_FD_ZERO(readfds);
    MZ_OS_FD_SET(udp->s, readfds);
    MZ_OS_FD_ZERO(exnfds);
    MZ_OS_FD_SET(udp->s, exnfds);
    
    do {
      sr = select(udp->s + 1, readfds, NULL, exnfds, &time);
    } while ((sr == -1) && (NOT_WINSOCK(errno) == EINTR));
    
    if (sr)
      return sr;
  }
# endif

  check_fd_sema(udp->s, MZFD_CREATE_READ, sinfo, NULL);

  return 0;
}

static void udp_recv_needs_wakeup(Scheme_Object *_udp, void *fds)
{
  Scheme_UDP *udp = (Scheme_UDP *)_udp;
  void *fds1, *fds2;

  tcp_t s = udp->s;
  
  fds1 = MZ_GET_FDSET(fds, 0);
  fds2 = MZ_GET_FDSET(fds, 2);
  
  MZ_FD_SET(s, (fd_set *)fds1);
  MZ_FD_SET(s, (fd_set *)fds2);
}

#endif

static int do_udp_recv(const char *name, Scheme_UDP *udp, char *bstr, intptr_t start, intptr_t end, 
		       int can_block, Scheme_Object **v)
{
#ifdef UDP_IS_SUPPORTED
  intptr_t x;
  int errid = 0;
  char src_addr[MZ_SOCK_NAME_MAX_LEN];
  unsigned int asize = sizeof(src_addr);

  if (!udp->bound) {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "%s: udp socket is not bound\n"
                     "  socket: %V",
		     name,
		     udp);
    return 0;
  }

  while (1) {
    if (udp->s == INVALID_SOCKET) {
      /* socket was closed, maybe while we slept */
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "%s: udp socket is closed\n"
                       "  socket: %V",
		       name, udp);
      return 0;
    }

    {
      if (end == start) {
        /* recvfrom() doesn't necessarily wait if you pass a buffer size of 0;
           to be consistent with accepting a message but discarding bytes that
           don't fit, accept at least one byte and turn a `1` result into `0` */
        char buf[1];
        x = recvfrom(udp->s, buf, 1, 0, (struct sockaddr *)src_addr, &asize);
        if (x == 1)
          x = 0;
      } else {
        x = recvfrom(udp->s, bstr XFORM_OK_PLUS start, end - start, 0,
                     (struct sockaddr *)src_addr, &asize);
      }
    }

    if (x == -1) {
      errid = SOCK_ERRNO();
      if (WAS_ECONNREFUSED(errid)) {
        /* Delayed ICMP error. Ignore it and try again. */
        errid = 0;
      } else if (WAS_WSAEMSGSIZE(errid)) {
	x = end - start;
	errid = 0;
	break;
      } else if (WAS_EAGAIN(errid)) {
	if (can_block) {
	  /* Block and eventually try again. */
          Scheme_Object *sema;
          sema = scheme_fd_to_semaphore(udp->s, MZFD_CREATE_READ, 1);
          if (sema)
            scheme_wait_sema(sema, 0);
          else
            scheme_block_until((Scheme_Ready_Fun)udp_check_recv, 
                               udp_recv_needs_wakeup, 
                               (Scheme_Object *)udp,
                               0);
	} else {
	  v[0] = scheme_false;
	  v[1] = scheme_false;
	  v[2] = scheme_false;
	  return 0;
	}
      } else if (NOT_WINSOCK(errid) != EINTR)
	break;
    } else
      break;
  }
  
  if (x > -1) {
    char host_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
    char prev_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
    char svc_buf[MZ_SOCK_SVC_NAME_MAX_LEN];
    int j, id;

    v[0] = scheme_make_integer(x);

    scheme_getnameinfo((struct sockaddr *)src_addr, asize,
		       host_buf, sizeof(host_buf),
		       svc_buf, sizeof(svc_buf));
    
    if (udp->previous_from_addr) {
      mzchar *s;
      s = SCHEME_CHAR_STR_VAL(udp->previous_from_addr);
      for (j = 0; s[j]; j++) {
	prev_buf[j] = (char)s[j];
      }
      prev_buf[j] = 0;
    }

    if (udp->previous_from_addr && !strcmp(prev_buf, host_buf)) {
      v[1] = udp->previous_from_addr;
    } else {
      Scheme_Object *vv;
      vv = scheme_make_immutable_sized_utf8_string(host_buf, -1);
      v[1] = vv;
      udp->previous_from_addr = v[1];
    }

    id = extract_svc_value(svc_buf);

    v[2] = scheme_make_integer(id);

    return 1;
  } else {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "%s: receive failed\n"
                     "  system error: %E",
		     name,
		     errid);
    return 0;
  }
#else
  return 0;
#endif
}

static Scheme_Object *udp_recv(const char *name, int argc, Scheme_Object *argv[], 
			       int can_block, Scheme_UDP_Evt *fill_evt)
{
  Scheme_UDP *udp;
  intptr_t start, end;
  Scheme_Object *v[3];

  udp = (Scheme_UDP *)argv[0];

  if (!SCHEME_UDPP(argv[0]))
    scheme_wrong_contract(name, "udp?", 0, argc, argv);
  if (!SCHEME_BYTE_STRINGP(argv[1]) || !SCHEME_MUTABLEP(argv[1]))
    scheme_wrong_contract(name, "(or/c bytes? (not/c immutable?))", 1, argc, argv);
  
#ifdef UDP_IS_SUPPORTED
  scheme_get_substring_indices(name, argv[1], 
			       argc, argv,
			       2, 3, &start, &end);
  if (fill_evt) {
    fill_evt->str = SCHEME_BYTE_STR_VAL(argv[1]);
    fill_evt->offset = start;
    fill_evt->len = end - start;
    return scheme_void;
  } else {
    do_udp_recv(name, udp, SCHEME_BYTE_STR_VAL(argv[1]), start, end, can_block, v);
    
    return scheme_values(3,v);
  }
#else
  return NULL;
#endif
}

static Scheme_Object *udp_receive(int argc, Scheme_Object *argv[])
{
  return udp_recv("udp-receive!", argc, argv, 1, NULL);
}

static Scheme_Object *udp_receive_star(int argc, Scheme_Object *argv[])
{
  return udp_recv("udp-receive!*", argc, argv, 0, NULL);
}

static Scheme_Object *udp_receive_enable_break(int argc, Scheme_Object *argv[])
{
  return scheme_call_enable_break(udp_receive, argc, argv);
}

static Scheme_Object *make_udp_evt(const char *name, int argc, Scheme_Object **argv, int for_read)
{
#ifdef UDP_IS_SUPPORTED
  Scheme_UDP_Evt *uw;
#endif

  if (!SCHEME_UDPP(argv[0]))
    scheme_wrong_contract(name, "udp?", 0, argc, argv);

#ifdef UDP_IS_SUPPORTED
  uw = MALLOC_ONE_TAGGED(Scheme_UDP_Evt);
  uw->so.type = scheme_udp_evt_type;
  uw->udp = (Scheme_UDP *)argv[0];
  uw->for_read = for_read;

  return (Scheme_Object *)uw;
#else
  return scheme_void;
#endif
}

static Scheme_Object *udp_read_ready_evt(int argc, Scheme_Object *argv[])
{
  return make_udp_evt("udp-receive-ready-evt", argc, argv, 1);
}

static Scheme_Object *udp_write_ready_evt(int argc, Scheme_Object *argv[])
{
  return make_udp_evt("udp-send-ready-evt", argc, argv, 0);
}

static Scheme_Object *udp_read_evt(int argc, Scheme_Object *argv[])
{
  Scheme_Object *evt;
  evt = make_udp_evt("udp-receive!-evt", argc, argv, 1);
  udp_recv("udp-receive!-evt", argc, argv, 0, (Scheme_UDP_Evt *)evt);
  return evt;
}

static Scheme_Object *udp_write_evt(int argc, Scheme_Object *argv[])
{
  Scheme_Object *evt;
  evt = make_udp_evt("udp-send-evt", argc, argv, 0);
  udp_send_it("udp-send-evt", argc, argv, 0, 0, (Scheme_UDP_Evt *)evt);
  return evt;
}

static Scheme_Object *udp_write_to_evt(int argc, Scheme_Object *argv[])
{
  Scheme_Object *evt;
  evt = make_udp_evt("udp-send-to-evt", argc, argv, 0);
  udp_send_it("udp-send-to-evt", argc, argv, 1, 0, (Scheme_UDP_Evt *)evt);
#ifdef UDP_IS_SUPPORTED
  ((Scheme_UDP_Evt *)evt)->with_addr = 1;
#endif
  return evt;
}

#ifdef UDP_IS_SUPPORTED
static int udp_evt_check_ready(Scheme_Object *_uw, Scheme_Schedule_Info *sinfo)
{
  Scheme_UDP_Evt *uw = (Scheme_UDP_Evt *)_uw;

  if (uw->for_read) {
    if (uw->str) {
      Scheme_Object *v[3];
      if (do_udp_recv("udp-receive!-evt", uw->udp, 
		      uw->str, uw->offset, uw->offset + uw->len, 
		      0, v)) {
	scheme_set_sync_target(sinfo, scheme_build_list(3, v), NULL, NULL, 0, 0, NULL);
	return 1;
      } else
	return 0;
    } else {
      return udp_check_recv((Scheme_Object *)uw->udp, NULL);
    }
  } else {
    if (uw->str) {
      Scheme_Object *r = NULL;
      int j;
      for (j = 0; !r && (j < (uw->dest_addrs ? uw->dest_addr_count : 1)); j++) {
        r = do_udp_send_it("udp-send-evt", uw->udp, 
                           uw->str, uw->offset, uw->offset + uw->len, 
                           uw->dest_addrs ? uw->dest_addrs[j] : NULL,
                           uw->dest_addrs ? uw->dest_addr_lens[j] : 0,
                           0,
                           j+1 < uw->dest_addr_count);
      }
      if (SCHEME_TRUEP(r)) {
	scheme_set_sync_target(sinfo, scheme_void, NULL, NULL, 0, 0, NULL);
	return 1;
      } else
	return 0;
    } else
      return udp_check_send((Scheme_Object *)uw->udp, NULL);
  }
}

static void udp_evt_needs_wakeup(Scheme_Object *_uw, void *fds)
{
  Scheme_UDP_Evt *uw = (Scheme_UDP_Evt *)_uw;

  if (uw->for_read)
    udp_recv_needs_wakeup((Scheme_Object *)uw->udp, fds);
  else
    udp_send_needs_wakeup((Scheme_Object *)uw->udp, fds);
}
#endif

static int udp_check_open(char const *name, int argc, Scheme_Object *argv[]) {
  if (!SCHEME_UDPP(argv[0])) {
    scheme_wrong_contract(name, "udp?", 0, argc, argv);
    return 0; /* Why does no-one else expect control back after scheme_wrong_contract? */
    /* Or, conversely, why does everyone expect control back after scheme_raise_exn? */
  }

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp = (Scheme_UDP *) argv[0];

    if (udp->s == INVALID_SOCKET) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
                       "%s: udp socket was already closed\n"
                       "  socket: %V",
                       name, udp);
      return 0;
    }

    return 1;
  }
#else
  return 0;
#endif
}

static Scheme_Object *
udp_multicast_loopback_p(int argc, Scheme_Object *argv[])
{
  if (!udp_check_open("udp-multicast-loopback?", argc, argv))
    return NULL;

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp = (Scheme_UDP *) argv[0];
    u_char loop;
    unsigned int loop_len = sizeof(loop);
    int status;
    status = getsockopt(udp->s, IPPROTO_IP, IP_MULTICAST_LOOP, (void *) &loop, &loop_len);
    if (status)
      status = SOCK_ERRNO();
    if (status) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "udp-multicast-loopback?: getsockopt failed\n"
		       "  system error: %N",
		       0, status);
      return NULL;
    } else {
      return (loop ? scheme_true : scheme_false);
    }
  }
#else
  return scheme_void;
#endif
}

static Scheme_Object *
udp_multicast_set_loopback(int argc, Scheme_Object *argv[])
{
  if (!udp_check_open("udp-multicast-set-loopback!", argc, argv))
    return NULL;

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp = (Scheme_UDP *) argv[0];
    u_char loop = SCHEME_TRUEP(argv[1]) ? 1 : 0;
    unsigned int loop_len = sizeof(loop);
    int status;
    status = setsockopt(udp->s, IPPROTO_IP, IP_MULTICAST_LOOP, (void *) &loop, loop_len);
    if (status)
      status = SOCK_ERRNO();
    if (status) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "udp-multicast-set-loopback!: setsockopt failed\n"
		       "  system error: %N",
		       0, status);
      return NULL;
    } else {
      return scheme_void;
    }
  }
#else
  return scheme_void;
#endif
}

static Scheme_Object *
udp_multicast_ttl(int argc, Scheme_Object *argv[])
{
  if (!udp_check_open("udp-multicast-ttl", argc, argv))
    return NULL;

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp = (Scheme_UDP *) argv[0];
    u_char ttl;
    unsigned int ttl_len = sizeof(ttl);
    int status;
    status = getsockopt(udp->s, IPPROTO_IP, IP_MULTICAST_TTL, (void *) &ttl, &ttl_len);
    if (status)
      status = SOCK_ERRNO();
    if (status) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "udp-multicast-ttl: getsockopt failed\n"
		       "  system error: %N",
		       0, status);
      return NULL;
    } else {
      return scheme_make_integer(ttl);
    }
  }
#else
  return scheme_void;
#endif
}

static Scheme_Object *
udp_multicast_set_ttl(int argc, Scheme_Object *argv[])
{
  if (!udp_check_open("udp-multicast-set-ttl!", argc, argv))
    return NULL;
  if (!SCHEME_INTP(argv[1]) || (SCHEME_INT_VAL(argv[1]) < 0) || (SCHEME_INT_VAL(argv[1]) >= 256)) {
    scheme_wrong_contract("udp-multicast-set-ttl!", "byte?", 1, argc, argv);
    return NULL;
  }

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp = (Scheme_UDP *) argv[0];
    u_char ttl = (u_char) SCHEME_INT_VAL(argv[1]);
    unsigned int ttl_len = sizeof(ttl);
    int status;
    status = setsockopt(udp->s, IPPROTO_IP, IP_MULTICAST_TTL, (void *) &ttl, ttl_len);
    if (status)
      status = SOCK_ERRNO();
    if (status) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "udp-multicast-set-ttl!: setsockopt failed\n"
		       "  system error: %N",
		       0, status);
      return NULL;
    } else {
      return scheme_void;
    }
  }
#else
  return scheme_void;
#endif
}

static Scheme_Object *
udp_multicast_interface(int argc, Scheme_Object *argv[])
{
  if (!udp_check_open("udp-multicast-interface", argc, argv))
    return NULL;

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp = (Scheme_UDP *) argv[0];
    GC_CAN_IGNORE struct in_addr intf;
    unsigned int intf_len = sizeof(intf);
    int status;
    status = getsockopt(udp->s, IPPROTO_IP, IP_MULTICAST_IF, (void *) &intf, &intf_len);
    if (status)
      status = SOCK_ERRNO();
    if (status) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "udp-multicast-interface: getsockopt failed\n"
		       "  system error: %N",
		       0, status);
      return NULL;
    } else {
      char host_buf[MZ_SOCK_HOST_NAME_MAX_LEN];
      unsigned char *b = (unsigned char *) &intf; /* yes, this is in network order */
      sprintf(host_buf, "%d.%d.%d.%d", b[0], b[1], b[2], b[3]);
      return scheme_make_utf8_string(host_buf);
    }
  }
#else
  return scheme_void;
#endif
}

static Scheme_Object *
udp_multicast_set_interface(int argc, Scheme_Object *argv[])
{
  if (!udp_check_open("udp-multicast-set-interface!", argc, argv))
    return NULL;
  if (!SCHEME_CHAR_STRINGP(argv[1]) && !SCHEME_FALSEP(argv[1])) {
    scheme_wrong_contract("udp-multicast-set-interface!", "(or/c string? #f)", 1, argc, argv);
    return NULL;
  }

#ifdef UDP_IS_SUPPORTED
  {
    Scheme_UDP *udp = (Scheme_UDP *) argv[0];
    GC_CAN_IGNORE struct in_addr intf;
    unsigned int intf_len = sizeof(intf);
    int status;

    if (SCHEME_FALSEP(argv[1])) {
      intf.s_addr = INADDR_ANY;
    } else {
      Scheme_Object *bs;
      char *address = "";
      GC_CAN_IGNORE struct mz_addrinfo *if_addr = NULL;
      int err;
      bs = scheme_char_string_to_byte_string(argv[1]);
      address = SCHEME_BYTE_STR_VAL(bs);
      if_addr = scheme_get_host_address(address, -1, &err, MZ_PF_INET, 0, 0);
      if (!if_addr) {
	scheme_raise_exn(MZEXN_FAIL_NETWORK,
			 "udp-multicast-set-interface!: can't resolve interface address\n"
			 "  address: %s\n"
			 "  system error: %N",
			 address ? address : "<unspec>", 1, err);
	return NULL;
      }
      intf = ((struct sockaddr_in *)if_addr->ai_addr)->sin_addr;
      mz_freeaddrinfo(if_addr);
    }

    status = setsockopt(udp->s, IPPROTO_IP, IP_MULTICAST_IF, (void *) &intf, intf_len);
    if (status)
      status = SOCK_ERRNO();
    if (status) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "udp-multicast-set-interface!: setsockopt failed\n"
		       "  system error: %N",
		       0, status);
      return NULL;
    } else {
      return scheme_void;
    }
  }
#else
  return scheme_void;
#endif
}

#ifdef UDP_IS_SUPPORTED

static Scheme_Object *
do_udp_multicast_join_or_leave_group(char const *name, int optname, Scheme_UDP *udp, Scheme_Object *multiaddrname, Scheme_Object *ifaddrname)
{
  GC_CAN_IGNORE struct ip_mreq mreq;
  unsigned int mreq_len = sizeof(mreq);
  int status;

  if (SCHEME_FALSEP(ifaddrname)) {
    mreq.imr_interface.s_addr = INADDR_ANY;
  } else {
    Scheme_Object *bs;
    char *address = "";
    GC_CAN_IGNORE struct mz_addrinfo *if_addr = NULL;
    int err;
    bs = scheme_char_string_to_byte_string(ifaddrname);
    address = SCHEME_BYTE_STR_VAL(bs);
    if_addr = scheme_get_host_address(address, -1, &err, MZ_PF_INET, 0, 0);
    if (!if_addr) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "%s: can't resolve interface address\n"
		       "  address: %s\n"
		       "  system error: %N",
		       name, address ? address : "<unspec>", 1, err);
      return NULL;
    }
    mreq.imr_interface = ((struct sockaddr_in *)if_addr->ai_addr)->sin_addr;
    mz_freeaddrinfo(if_addr);
  }

  {
    Scheme_Object *bs;
    char *address = "";
    GC_CAN_IGNORE struct mz_addrinfo *group_addr = NULL;
    int err;
    bs = scheme_char_string_to_byte_string(multiaddrname);
    address = SCHEME_BYTE_STR_VAL(bs);
    group_addr = scheme_get_host_address(address, -1, &err, MZ_PF_INET, 0, 0);
    if (!group_addr) {
      scheme_raise_exn(MZEXN_FAIL_NETWORK,
		       "%s: can't resolve group address\n"
		       "  address: %s\n"
		       "  system error: %N",
		       name, address ? address : "<unspec>", 1, err);
      return NULL;
    }
    mreq.imr_multiaddr = ((struct sockaddr_in *)group_addr->ai_addr)->sin_addr;
    mz_freeaddrinfo(group_addr);
  }

  status = setsockopt(udp->s, IPPROTO_IP, optname, (void *) &mreq, mreq_len);
  if (status)
    status = SOCK_ERRNO();
  if (status) {
    scheme_raise_exn(MZEXN_FAIL_NETWORK,
		     "%s: setsockopt failed\n"
		     "  system error: %N",
		     name, 0, status);
    return NULL;
  } else {
    return scheme_void;
  }
}

#endif

static Scheme_Object *
udp_multicast_join_or_leave_group(char const *name, int optname, int argc, Scheme_Object *argv[])
{
  if (!udp_check_open(name, argc, argv))
    return NULL;
  if (!SCHEME_CHAR_STRINGP(argv[1])) {
    scheme_wrong_contract(name, "string?", 1, argc, argv);
    return NULL;
  }
  if (!SCHEME_CHAR_STRINGP(argv[2]) && !SCHEME_FALSEP(argv[2])) {
    scheme_wrong_contract(name, "(or/c string? #f)", 2, argc, argv);
    return NULL;
  }

#ifdef UDP_IS_SUPPORTED
  return do_udp_multicast_join_or_leave_group(name, optname,
					      (Scheme_UDP *) argv[0], argv[1], argv[2]);
#else
  return scheme_void;
#endif
}

#ifdef UDP_IS_SUPPORTED
# define WHEN_UDP_IS_SUPPORTED(x) x
#else
# define WHEN_UDP_IS_SUPPORTED(x) 0
#endif

static Scheme_Object *
udp_multicast_join_group(int argc, Scheme_Object *argv[])
{
  return udp_multicast_join_or_leave_group("udp-multicast-join-group!",
					   WHEN_UDP_IS_SUPPORTED(IP_ADD_MEMBERSHIP),
					   argc,
					   argv);
}

static Scheme_Object *
udp_multicast_leave_group(int argc, Scheme_Object *argv[])
{
  return udp_multicast_join_or_leave_group("udp-multicast-leave-group!",
					   WHEN_UDP_IS_SUPPORTED(IP_DROP_MEMBERSHIP),
					   argc,
					   argv);
}

/*========================================================================*/
/*                       precise GC traversers                            */
/*========================================================================*/

#ifdef MZ_PRECISE_GC

START_XFORM_SKIP;

#include "mzmark_network.inc"

static void register_traversers(void)
{
#ifdef USE_TCP
  GC_REG_TRAV(scheme_listener_type, mark_listener);
  GC_REG_TRAV(scheme_rt_tcp, mark_tcp);
# ifdef UDP_IS_SUPPORTED
  GC_REG_TRAV(scheme_udp_type, mark_udp);
  GC_REG_TRAV(scheme_udp_evt_type, mark_udp_evt);
# endif
#endif
}

END_XFORM_SKIP;

#endif

#endif /* !NO_TCP_SUPPORT */
