/* mzsocket: BSD/POSIX sockets library for PLT-scheme
 * native implementation
 * 
 * (C) Copyright 2007,2008 Dimitris Vyzovitis <vyzo at media.mit.edu>
 * 
 * mzsocket is free software: you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 * 
 * mzsocket is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 * 
 * You should have received a copy of the GNU Lesser General Public License
 * along with mzsocket.  If not, see <http://www.gnu.org/licenses/>.
 */

#include "_socket.h"

#define SOCKADDR_t(x) (((struct sockaddr*)(x))->sa_family)
#define INADDR_t(x) (((inet_address*)(x))->sa.sa.sa_family)

#define INET_ADDRESSP(obj) \
  (SAME_TYPE (SCHEME_TYPE(obj), inet_address_tag))
#define SOCKETP(obj) \
  (SAME_TYPE (SCHEME_TYPE(obj), sock_tag))

#define EXPECT_INET_ADDRESS(where, arg) \
  if (__CHECKT (!INET_ADDRESSP (argv[arg])))                         \
    scheme_arg_mismatch (where, "expected inet-address, given ", argv[arg])
#define EXPECT_SOCKET(where, arg) \
  if (__CHECKT (!SOCKETP (argv[arg])))                               \
    scheme_arg_mismatch (where, "expected socket, given ", argv[arg])

#define SOCKET_ERROR(x) scheme_raise (new_exn (x, ERRNO))


static Scheme_Type inet_address_tag;
static Scheme_Type sock_tag;
static Scheme_Type sock_evt_tag;
//! struct (exn:fail:socket exn:fail:network) (errno)
static Scheme_Object *exn_type;

typedef struct {
  Scheme_Object tag;
  union {
    struct sockaddr sa;
    struct sockaddr_in sa_in;
#ifdef HAVE_IPV6
    struct sockaddr_in6 sa_in6;
#endif
  } sa;
} inet_address;

typedef struct {
  Scheme_Object tag;
  Scheme_Custodian_Reference* custodian;
  fd_t fd;
  int domain;
} sock;

enum evt_t {
  evt_read = 0x01,
  evt_write = 0x02,
  evt_except = 0x04
};

typedef struct {
  Scheme_Object tag;
  sock *s;
  enum evt_t t;
} sock_evt;

#ifdef WINDOWS
// how about I give you the finger and you give me my phonecall...
#include "_wincompat.c"
#endif

// xform has trouble with this code. Besides, there are a few
// places where it is needed (most functions don't call scheme functions
// that can trigger gc in the middle of execution)
// so the default is to not xform and explicitly mark xform areas with
// BEGIN/END_XFORM blocks
#ifdef MZ_PRECISE_GC
#define BEGIN_XFORM END_XFORM_SKIP;
#define END_XFORM START_XFORM_SKIP;
#define REGISTER_GC(tag, SIZE, MARK, FIXUP, c, a) \
  GC_register_traversers(tag, SIZE, MARK, FIXUP, c, a)
START_XFORM_SKIP;
#else
#define BEGIN_XFORM 
#define END_XFORM
#define REGISTER_GC(tag, SIZE, MARK, FIXUP, c, a)
#endif

// exn:fail:socket
BEGIN_XFORM
static Scheme_Object *new_exn (const char *pre, int err) {
  Scheme_Object *vals[3];
  char msg[256];
  int r;
  
  r = snprintf (msg, sizeof (msg), "%s: %s [%d]", pre, strerror (err), err);
  msg[sizeof(msg)-1] = 0;
  
  vals[0] = scheme_make_locale_string (msg);
  SCHEME_SET_CHAR_STRING_IMMUTABLE (vals[0]);
  vals[1] = scheme_current_continuation_marks (NULL);
  vals[2] = FIXNUM (err);
  return scheme_make_struct_instance (exn_type, 3, vals);
}
END_XFORM

//! make-exn:fail:socket
static Scheme_Object *make_exn (int argc, Scheme_Object **argv) {
  EXPECT_STRING ("make-exn:fail:socket", 0);
  EXPECT_FIXNUM ("make-exn:fail:socket", 1);
  return new_exn (BYTES_VAL (STRING_TO_BYTES (argv[0])), 
                  FIXNUM_VAL (argv[1]));
}

//! exn:fail:socket-errno
static Scheme_Object *exn_errno (int argc, Scheme_Object **argv) {
  if (scheme_is_struct_instance (exn_type, argv[0]))
    return scheme_struct_ref (argv[0], 2);
  scheme_arg_mismatch ("exn:fail:socket-errno", 
                       "expected exn:fail:socket, given ", 
                       argv[0]);
}

//! exn:fail:socket?
static Scheme_Object *exn_p (int argc, Scheme_Object **argv) {
  return BOOLEAN (scheme_is_struct_instance (exn_type, argv[0]));
}

// inet-address
static Scheme_Object *new_inet_address (void *sa) {
  inet_address* ina;
  ina = (inet_address*)scheme_malloc_tagged (sizeof (inet_address));
  ina->tag.type = inet_address_tag;
  switch  (SOCKADDR_t (sa)) {
  case AF_INET:
    memcpy (&ina->sa.sa_in, sa, sizeof (struct sockaddr_in));
    break;
#ifdef HAVE_IPV6
  case AF_INET6:
    memcpy (&ina->sa.sa_in6, sa, sizeof (struct sockaddr_in6));
    break;
#endif
  }

  return (Scheme_Object*)ina;
}

//! make-inet-address (family host port) => <inet-address>
static Scheme_Object *make_inet_address (int argc, Scheme_Object **argv) {
  int family;
  EXPECT_FIXNUM ("make-inet-address", 0);
  EXPECT_BYTES ("make-inet-address", 1);
  EXPECT_FIXNUM ("make-inet-address", 2);
  
  family = FIXNUM_VAL (argv[0]);
  switch (family) {
  case AF_INET: {
    struct sockaddr_in sa;
    if (inet_pton (family, BYTES_VAL (argv[1]), &sa.sin_addr) > 0) {
      sa.sin_family = AF_INET;
      sa.sin_port = htons ((u16)FIXNUM_VAL (argv[2]));
      return new_inet_address (&sa);
    } else goto err;
  }

#ifdef HAVE_IPV6
  case AF_INET6: {
    struct sockaddr_in6 sa;
    if (inet_pton (family, BYTES_VAL (argv[1]), &sa.sin6_addr) > 0) {
      sa.sin6_family = AF_INET6;
      sa.sin6_port = htons ((u16)FIXNUM_VAL (argv[2]));
    } else goto err;
    
    switch (argc) {
    case 3: 
      sa.sin6_flowinfo = 0;
      sa.sin6_scope_id = 0;
      break;
    case 5:
      EXPECT_FIXNUM ("make-inet-address", 3);
      EXPECT_FIXNUM ("make-inet-address", 4);
      sa.sin6_flowinfo = htonl ((u32)FIXNUM_VAL (argv[3]));
      sa.sin6_scope_id = htonl ((u32)FIXNUM_VAL (argv[4]));
      break;
    default:
      ERROR ("inet-address: bad arguments [ipv6]");
    }
    
    return new_inet_address (&sa);
  }
#endif    

  default:
    ERROR ("inet-address: bad address family");
  }
 
 err:
  ERROR ("inet_pton");
}

//! inet-address?
static Scheme_Object *inet_address_p (int argc, Scheme_Object **argv) {
  return BOOLEAN (INET_ADDRESSP (argv[0]));
}

static void print_inet_address (Scheme_Object *v, int dis, 
                                Scheme_Print_Params *pp) {
  char buf[128];
  char pbuf[64];
  int len, proto, port;
  const char* srep;
  inet_address *ina = (inet_address*)v;
  
  switch (INADDR_t (ina)) {
  case AF_INET:
    srep = inet_ntop (AF_INET, &ina->sa.sa_in.sin_addr, 
                      pbuf, sizeof(pbuf));
    proto = 4;
    port = ntohs (ina->sa.sa_in.sin_port);
    break;
#ifdef HAVE_IPV6
  case AF_INET6:
    srep = inet_ntop (AF_INET6, &ina->sa.sa_in6.sin6_addr, 
                      pbuf, sizeof(pbuf));
    proto = 6;
    port = ntohs (ina->sa.sa_in6.sin6_port);
    break;
#endif
  }
  
  len = snprintf (buf, sizeof (buf), "#<inet%d %s:%d>", 
                  proto, (srep? pbuf : "?"), port);
  scheme_print_bytes (pp, buf, 0, len);
}

//! inet-address-family
static Scheme_Object *inet_address_family (int argc, Scheme_Object **argv) {
  EXPECT_INET_ADDRESS ("inet-address-family", 0);
  return FIXNUM (INADDR_t ((inet_address*)argv[0]));
}

static Scheme_Object *inet_ntop_bytes (int af, void *sa) {
  char pbuf[64];
  if (inet_ntop (af, sa, pbuf, sizeof(pbuf)))
    return BYTES (pbuf);
  else ERROR ("inet_ntop");
}

//! inet-address-host
static Scheme_Object *inet_address_host (int argc, Scheme_Object **argv) {
  char pbuf[64];
  int r;
  inet_address *ina;
  EXPECT_INET_ADDRESS ("inet-address-host", 0);

  ina = (inet_address*)argv[0];
  switch (INADDR_t (ina)) {
  case AF_INET:
    return inet_ntop_bytes (AF_INET, &ina->sa.sa_in.sin_addr);
#ifdef HAVE_IPV6
  case AF_INET6:
    return inet_ntop_bytes (AF_INET6, &ina->sa.sa_in6.sin6_addr);
#endif
  }
}

//! inet-address-port
static Scheme_Object *inet_address_port (int argc, Scheme_Object **argv) {
  inet_address *ina;
  EXPECT_INET_ADDRESS ("inet-address-port", 0);
  ina = (inet_address*)argv[0];
  switch (INADDR_t (ina)) {
  case AF_INET:
    return FIXNUM (ntohs (ina->sa.sa_in.sin_port));
#ifdef HAVE_IPV6
  case AF_INET6:
    return FIXNUM (ntohs (ina->sa.sa_in6.sin6_port));
#endif
  }
}

// equal+hash
static int inet_address_equal (Scheme_Object *sx, Scheme_Object *sy, void *c) {
  inet_address *x = (inet_address*)sx; 
  inet_address *y = (inet_address*)sy;
  
  if (INADDR_t (x) == INADDR_t (y)) {
    switch (INADDR_t (x)) {
    case AF_INET:
      return (x->sa.sa_in.sin_port == y->sa.sa_in.sin_port) 
        && (x->sa.sa_in.sin_addr.s_addr == y->sa.sa_in.sin_addr.s_addr);
#ifdef HAVE_IPV6
    case AF_INET6:
      return (x->sa.sa_in6.sin6_port == y->sa.sa_in6.sin6_port) 
        && !memcmp(x->sa.sa_in6.sin6_addr.s6_addr,
                   y->sa.sa_in6.sin6_addr.s6_addr,
                   16)
        && (x->sa.sa_in6.sin6_flowinfo == y->sa.sa_in6.sin6_flowinfo)
        && (x->sa.sa_in6.sin6_scope_id == y->sa.sa_in6.sin6_scope_id);
#endif
    }
  } else return 0;
}

static long inet_address_hash1 (Scheme_Object *x, long base, void *c) {
  inet_address *ina = (inet_address*)x;
  switch (INADDR_t (ina)) {
  case AF_INET:
    return base ^ ina->sa.sa_in.sin_addr.s_addr;
#ifdef HAVE_IPV6
  case AF_INET6: {
    int i, j, k;
    for (i = 0; i < 4; i++) {
      k = 0;
      for (j = 0; j < 4; j++) {
        k |= ina->sa.sa_in6.sin6_addr.s6_addr[(i<<2)+j] << (j << 3);
      }
      base ^= k;
    }
    return base;
  }
#endif
  }
}

static long inet_address_hash2 (Scheme_Object *x, void *c) {
  inet_address *ina = (inet_address*)x;
  switch (INADDR_t (ina)) {
  case AF_INET:
    return inet_address_hash1 (x, ina->sa.sa_in.sin_port, c);
#ifdef HAVE_IPV6
  case AF_INET6:
    return inet_address_hash1 (x, ina->sa.sa_in6.sin6_port, c);
#endif
  }
}

//! inet-address=?
static Scheme_Object *inet_address_equalp (int argc, Scheme_Object **argv) {
  int i;
  EXPECT_INET_ADDRESS ("inet-address=?", 0);
  for (i = 1; i < argc; i++) {
    EXPECT_INET_ADDRESS ("inet-address=?", i);
    if (!inet_address_equal (argv[0], argv[i], NULL))
      return scheme_false;
  }
  
  return scheme_true;
}


//! inet-address->vector (<inet-addr>) =>
//   #(AF_INET <bytes> <int>) ; ipv4
//   #(AF_INET6 <bytes> <int> <int> <int>) ; ipv6
static Scheme_Object *inet_address_to_vec (int argc, Scheme_Object **argv) {
  inet_address *ina;
  Scheme_Object *bs;
  Scheme_Object *vec;
  
  MZ_GC_DECL_REG (2);
  MZ_GC_VAR_IN_REG (0, ina);
  MZ_GC_VAR_IN_REG (1, bs);

  EXPECT_INET_ADDRESS ("inet-address->vector", 0);

  ina = (inet_address*)argv[0];
  bs = NULL;
  MZ_GC_REG ();
  switch (INADDR_t (ina)) {
  case AF_INET: {
    bs = BYTES_SIZE ((char*)&ina->sa.sa_in.sin_addr.s_addr, 4);
    vec = VECTOR (3);
    VECTOR_SET (vec, 0, FIXNUM (AF_INET));
    VECTOR_SET (vec, 1, bs);
    VECTOR_SET (vec, 2, FIXNUM (ntohs (ina->sa.sa_in.sin_port)));
  } break;
#ifdef HAVE_IPV6
  case AF_INET6: {
    bs = BYTES_SIZE (ina->sa.sa_in6.sin6_addr.s6_addr, 16);
    vec = VECTOR (5);
    VECTOR_SET (vec, 0, FIXNUM (AF_INET6));
    VECTOR_SET (vec, 1, bs);
    VECTOR_SET (vec, 2, FIXNUM (ntohs (ina->sa.sa_in6.sin6_port)));
    VECTOR_SET (vec, 3, FIXNUM (ntohl (ina->sa.sa_in6.sin6_flowinfo)));
    VECTOR_SET (vec, 4, FIXNUM (ntohl (ina->sa.sa_in6.sin6_scope_id)));
  } break;
#endif
  }
  MZ_GC_UNREG ();
  return vec;
}

//! vector->inet-address
static Scheme_Object *vec_to_inet_address (int argc, Scheme_Object **argv) {
  int family;
  if (__CHECKT (!(VECTORP (argv[0]) 
                  && (VECTOR_LEN (argv[0]) > 0)
                  && FIXNUMP (VECTOR_REF (argv[0], 0)))))
    goto err;
  
  switch (FIXNUM_VAL (VECTOR_REF (argv[0], 0))) {
  case AF_INET: {
    struct sockaddr_in sa;
    if (__CHECKT (!((VECTOR_LEN (argv[0]) == 3)
                    && BYTESP (VECTOR_REF (argv[0], 1))
                    && (BYTES_LEN (VECTOR_REF (argv[0], 1)) == 4)
                    && FIXNUMP (VECTOR_REF (argv[0], 2)))))
      goto err;
    sa.sin_family = AF_INET;
    sa.sin_addr.s_addr = *(uint32_t*)BYTES_VAL (VECTOR_REF (argv[0], 1));
    sa.sin_port = htons (FIXNUM_VAL (VECTOR_REF (argv[0], 2)));
    return new_inet_address (&sa);
  }
    
  case AF_INET6: {
    struct sockaddr_in6 sa;
    if (__CHECKT (!((VECTOR_LEN (argv[0]) == 5)
                    && BYTESP (VECTOR_REF (argv[0], 1))
                    && (BYTES_LEN (VECTOR_REF (argv[0], 1)) == 16)
                    && FIXNUMP (VECTOR_REF (argv[0], 2))
                    && FIXNUMP (VECTOR_REF (argv[0], 3))
                    && FIXNUMP (VECTOR_REF (argv[0], 4)))))
      goto err;
    sa.sin6_family = AF_INET6;
    memcpy (&sa.sin6_addr.s6_addr, 
            BYTES_VAL (VECTOR_REF (argv[0], 1)), 16);
    sa.sin6_port = htons (FIXNUM_VAL (VECTOR_REF (argv[0], 2)));
    sa.sin6_flowinfo = htonl (FIXNUM_VAL (VECTOR_REF (argv[0], 3)));
    sa.sin6_scope_id = htonl (FIXNUM_VAL (VECTOR_REF (argv[0], 4)));
    return new_inet_address (&sa);
  }
  }
 err:
  scheme_arg_mismatch ("vector->inet-address", "bad vector", argv[0]);
}

#ifdef UNIX
static long unix_path_len (const char *path) {
  long r;
  for (r = 0; r < UNIX_PATH_MAX; r++) if (*path++ == 0) break;
  return r;
}
#endif

// raw sockaddr packing/unpacking (for sendmsg/recvmsg)
static Scheme_Object *pack_sockaddr (int argc, Scheme_Object **argv) {
  if (INET_ADDRESSP (argv[0])) {
    inet_address *ina = (inet_address*)argv[0];
    switch (INADDR_t(ina)) {
    case AF_INET:
      return BYTES_SIZE ((char*)&ina->sa, sizeof (struct sockaddr_in));
#ifdef HAVE_IPV6
    case AF_INET6:
      return BYTES_SIZE ((char*)&ina->sa, sizeof (struct sockaddr_in6));
#endif
    }
  } else if (PATHP (argv[0])) {
    struct sockaddr_un sa;
    memset (&sa, 0, sizeof(struct sockaddr_un));
    sa.sun_family = AF_UNIX;
    memcpy (sa.sun_path, PATH_VAL (argv[0]),
            MIN (UNIX_PATH_MAX, PATH_LEN (argv[0])));
    return BYTES_SIZE ((char*)&sa, sizeof (struct sockaddr_un));
  } else ERROR ("pack-address: bad address");
}

static Scheme_Object *unpack_sockaddr (int argc, Scheme_Object **argv) {
  EXPECT_BYTES ("unpack-address", 0);
  if (__CHECKT (BYTES_LEN (argv[0]) < sizeof(struct sockaddr)))
    ERROR ("unpack-address: bad struct");
  switch (((struct sockaddr*)BYTES_VAL (argv[0]))->sa_family) {
  case AF_INET:
    if (__CHECKT (BYTES_LEN (argv[0]) < sizeof(struct sockaddr_in)))
      ERROR ("unpack-address: bad struct sockaddr_in");
    return new_inet_address (BYTES_VAL (argv[0]));
#ifdef HAVE_IPV6
  case AF_INET6:
    if (__CHECKT (BYTES_LEN (argv[0]) < sizeof(struct sockaddr_in6)))
      ERROR ("unpack-address: bad struct sockaddr_in6");
    return new_inet_address (BYTES_VAL (argv[0]));
#endif
#ifdef UNIX
  case AF_UNIX: {
    struct sockaddr_un* sa;
    if (__CHECKT (BYTES_LEN (argv[0]) < sizeof(struct sockaddr_un)))
      ERROR ("unpack-address: bad struct sockaddr_un");
    sa = (struct sockaddr_un*)BYTES_VAL (argv[0]);
    return PATH_SIZE (sa->sun_path, unix_path_len (sa->sun_path));
  }
#endif
  default:
    ERROR ("unpack address: bad struct");
  }
}

// socket
static void _close_fd (fd_t fd) {
 again:
  if ((close (fd) < 0) && (ERRNO == EINTR)) 
    goto again;
}

static void _socket_close (sock* s) {
  Scheme_Custodian_Reference* custodian;
  if (s->fd != INVALID) {
    _close_fd (s->fd);
    s->fd = INVALID;
    custodian = s->custodian;
    s->custodian = NULL;
    scheme_remove_managed (custodian, (Scheme_Object*)s);
  }
}

static void _socket_fin (void *obj, void *x) {
  _socket_close ((sock*)obj);
}

static void setnonblock (fd_t fd) {
  int flags;
#ifdef UNIX
  flags = fcntl (fd, F_GETFL, 0);
  if (flags < 0) {
    _close_fd (fd);
    SOCKET_ERROR ("fcntl: GETFL");
  }
  flags |= O_NONBLOCK;
  if (fcntl (fd, F_SETFL, flags) < 0) {
    _close_fd (fd);
    SOCKET_ERROR ("fcntl: SETFL");
  }

#else 
  flags = 1;
  if (ioctlsocket (fd, FIONBIO, (u_long FAR*)&flags))
    SOCKET_ERROR ("ioctlsocket");
#endif
}

BEGIN_XFORM
static Scheme_Object *new_socket (fd_t fd, int domain) {
  sock *s;
  Scheme_Custodian_Reference *custodian;
  
  setnonblock (fd);
  s = (sock*)scheme_malloc_tagged (sizeof (sock));
  s->tag.type = sock_tag;
  s->fd = fd;
  s->domain = domain;
  custodian = scheme_add_managed 
    (NULL, 
     (Scheme_Object*)s, 
     (Scheme_Close_Custodian_Client*)_socket_fin,
     NULL, 
     0); // weak ref, allow gc
  s->custodian = custodian;
  scheme_add_finalizer (s, _socket_fin, NULL); // auto close on gc
  return (Scheme_Object*)s;
}
END_XFORM


//! socket (domain type proto)
static Scheme_Object *make_socket (int argc, Scheme_Object **argv) {
  int domain, type, proto;
  fd_t fd;

  domain = PF_INET;
  type = SOCK_STREAM;
  proto = 0;
  
  switch (argc) {
  case 3:
    EXPECT_FIXNUM( "socket", 2 );
    proto = FIXNUM_VAL (argv[2]);
  case 2:
    EXPECT_FIXNUM( "socket", 1 );
    type = FIXNUM_VAL (argv[1]);
  case 1:
    EXPECT_FIXNUM( "socket", 0 );
    domain = FIXNUM_VAL (argv[0]);
  }

  if ((fd = socket (domain, type, proto)) == INVALID) {
    SOCKET_ERROR ("socket");
  }
  
  return new_socket (fd, domain);
}

//! socket?
static Scheme_Object *socket_p (int argc, Scheme_Object **argv) {
  return BOOLEAN (SOCKETP (argv[0]));
}

//! socket-close
static Scheme_Object *socket_close (int argc, Scheme_Object **argv) {
  EXPECT_SOCKET ("socket-close", 0);
  _socket_close ((sock*)argv[0]);
  return scheme_void;
}

//! socket-closed?
static Scheme_Object *socket_closed_p (int argc, Scheme_Object **argv) {
  EXPECT_SOCKET ("socket-closed?", 0);
  return BOOLEAN (((sock*)argv[0])->fd == INVALID);
}


//! socket-shutdown (<sock> <int>)
static Scheme_Object *socket_shutdown (int argc, Scheme_Object **argv) {
  sock *s;
  EXPECT_SOCKET ("socket-shutdown", 0);
  EXPECT_FIXNUM ("socket-shutdown", 1);
  s = (sock*)argv[0];
  if (shutdown (s->fd, FIXNUM_VAL (argv[1])) < 0)
    SOCKET_ERROR ("socket-shutdown");
  return scheme_void;
}

static void inet_address_sockaddr (inet_address *ina, 
                                   struct sockaddr **sa, 
                                   socklen_t *salen) {
  switch (INADDR_t (ina)) {
  case AF_INET:
    *sa = (struct sockaddr*)&ina->sa.sa_in;
    *salen = sizeof (struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case AF_INET6:
    *sa = (struct sockaddr*)&ina->sa.sa_in6;
    *salen = sizeof(struct sockaddr_in6);
#endif
  }
}

//! socket-connect (<sock> <addr>) => <bool>
static Scheme_Object *socket_connect (int argc, Scheme_Object **argv) {
  sock *s;
  struct sockaddr *sa;
  socklen_t salen;
#ifdef UNIX
  struct sockaddr_un sa_un;
#endif
  
  EXPECT_SOCKET ("socket-connect", 0);
  s = (sock*)argv[0];
  
  switch (s->domain) {
  case PF_INET: 
#ifdef HAVE_IPV6
  case PF_INET6:
#endif 
    EXPECT_INET_ADDRESS ("socket-connect", 1);
    inet_address_sockaddr ((inet_address*)argv[1], &sa, &salen);
    break;
    
#ifdef UNIX
  case PF_UNIX: 
    EXPECT_PATH ("socket-connect", 1);
    memset (&sa_un, 0, sizeof (sa_un));
    sa_un.sun_family = AF_UNIX;
    memcpy (sa_un.sun_path, 
            PATH_VAL (argv[1]), 
            MIN (UNIX_PATH_MAX, PATH_LEN (argv[1])));
    sa = (struct sockaddr*)&sa_un;
    salen = (socklen_t)sizeof (struct sockaddr_un);
    break;
#endif
  default:
    ERROR ("socket-connect: bad socket domain");
  }
  
 again:
  if (connect (s->fd, sa, salen) < 0) {
    switch (ERRNO) {
    case EINTR: 
      goto again;
    case EINPROGRESS:
      return scheme_false; // async completion
    default:
      SOCKET_ERROR ("socket-connect");
    }
  } else return scheme_true; // immediate completion
}

//! socket-bind (<sock> <addr>)
static Scheme_Object *socket_bind (int argc, Scheme_Object **argv) {
  sock *s;
  struct sockaddr *sa;
  socklen_t salen;
#ifdef UNIX
  struct sockaddr_un sa_un;
#endif
  
  EXPECT_SOCKET ("socket-bind", 0);
  s = (sock*)argv[0];

  switch (s->domain) {
  case PF_INET:
#ifdef HAVE_IPV6 
  case PF_INET6:
#endif 
    EXPECT_INET_ADDRESS ("socket-bind", 1);
    inet_address_sockaddr ((inet_address*)argv[1], &sa, &salen);
    break;
    
#ifdef UNIX
  case PF_UNIX:
    EXPECT_PATH ("socket-bind", 1);
    memset (&sa_un, 0, sizeof (sa_un));
    sa_un.sun_family = AF_UNIX;
    memcpy (sa_un.sun_path, 
            PATH_VAL (argv[1]), 
            MIN (UNIX_PATH_MAX, PATH_LEN (argv[1])));
    sa = (struct sockaddr*)&sa_un;
    salen = (socklen_t)sizeof (struct sockaddr_un);
    break;
#endif

  default:
    ERROR ("socket-bind: bad socket domain");
  }

  if (bind (s->fd, sa, salen) < 0)
    SOCKET_ERROR ("socket-bind");
  return scheme_void;

}

//! socket-listen (<sock> <int>)
static Scheme_Object *socket_listen (int argc, Scheme_Object **argv) {
  sock *s;
  EXPECT_SOCKET ("socket-listen", 0);
  EXPECT_FIXNUM ("socket-listen", 1);

  s = (sock*)argv[0];
  if (listen (s->fd, FIXNUM_VAL (argv[1])) < 0)
    SOCKET_ERROR ("socket-listen");
  return scheme_void;
}

//! socket-accept (<sock>) => <sock> <addr>
static Scheme_Object *socket_accept (int argc, Scheme_Object **argv) {
  sock *s;
  fd_t fd;
  Scheme_Object *vals[2];
  
  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in6 sa_in6;
#ifdef UNIX
    struct sockaddr_un sa_un;
#endif
  } sa;
  socklen_t salen;
  
  MZ_GC_DECL_REG (4);
  MZ_GC_ARRAY_VAR_IN_REG (0, vals, 2);
  MZ_GC_VAR_IN_REG (3, s);

  EXPECT_SOCKET ("socket-accept", 0);
  s = (sock*)argv[0];

  switch (s->domain) {
  case PF_INET:
    salen = (socklen_t)sizeof (struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    salen = (socklen_t)sizeof (struct sockaddr_in6);
    break;
#endif
#ifdef UNIX
  case PF_UNIX: 
    salen = (socklen_t)sizeof (struct sockaddr_un);
    break;
#endif

  default:
    ERROR ("socket-accept: bad socket domain");
  }

  memset (&sa, 0, (size_t)salen);
 again:
  if ((fd = accept (s->fd, (struct sockaddr*)&sa, &salen)) == INVALID) {
    if (ERRNO == EINTR) goto again;
    else SOCKET_ERROR ("socket-accept");
  }

  vals[0] = vals[1] = NULL;
  MZ_GC_REG();
  vals[0] = new_socket (fd, s->domain);
  switch (s->domain) {
  case PF_INET:
#ifdef HAVE_IPV6
  case PF_INET6:
#endif
    vals[1] = new_inet_address (&sa);
    break;
#ifdef UNIX
  case PF_UNIX:
    vals[1] = PATH_SIZE (sa.sa_un.sun_path,
                         unix_path_len (sa.sa_un.sun_path));
    break;
#endif
  default:
    vals[1] = scheme_false;
  }
  
  // scheme_values does not trigger gc
  MZ_GC_UNREG();
  return scheme_values (2, vals);
}

//! socket-send (<sock> <bytes> [start end flags]) => <int>
static Scheme_Object *socket_send (int argc, Scheme_Object **argv) {
  sock *s;
  char *buf;
  size_t blen;
  int flags, olen;
  
  EXPECT_SOCKET ("socket-send", 0);
  EXPECT_BYTES ("socket-send", 1);

  s = (sock*)argv[0];
  buf = BYTES_VAL (argv[1]);
  blen = BYTES_LEN (argv[1]);
  flags = 0;
  
  if (argc > 2) {
    int b, e = (int)blen;
    switch (argc) {
    case 5:
      EXPECT_FIXNUM ("socket-send", 4);
      flags = FIXNUM_VAL (argv[4]);
    case 4:
      EXPECT_FIXNUM ("socket-send", 3);
      e = FIXNUM_VAL (argv[3]);
    case 3:
      EXPECT_FIXNUM ("socket-send", 2);
      b = FIXNUM_VAL (argv[2]);
    }
    CHECK_BYTES_RANGE( "socket-send", argv[1], b, e );
    buf += b;
    blen = (size_t)(e - b);
  }
  
 again:
  olen = send (s->fd, buf, blen, flags);
  if (olen < 0) {
    if (ERRNO == EINTR) goto again;
    else SOCKET_ERROR ("socket-send");
  }
  
  return FIXNUM (olen);
}

//! socket-sendto (<sock> <addr> <bytes> [start end flags])
static Scheme_Object *socket_sendto (int argc, Scheme_Object **argv) {
  sock *s;
  char *buf;
  size_t blen;
  int flags, olen;
  struct sockaddr* sa;
  socklen_t salen;
#ifdef UNIX
  struct sockaddr_un sa_un;
#endif
  
  EXPECT_SOCKET ("socket-send", 0);
  
  s = (sock*)argv[0];
  switch (s->domain) {
  case PF_INET:
#ifdef HAVE_IPV6 
  case PF_INET6:
#endif
    EXPECT_INET_ADDRESS ("socket-sendto", 1);
    inet_address_sockaddr ((inet_address*)argv[1], &sa, &salen);
    break;
#ifdef UNIX
  case PF_UNIX: 
    EXPECT_PATH ("socket-sendto", 1);
    memset (&sa_un, 0, sizeof(sa_un));
    sa_un.sun_family = AF_UNIX;
    memcpy (sa_un.sun_path, 
            PATH_VAL (argv[1]), 
            MIN (UNIX_PATH_MAX, PATH_LEN (argv[1])));
    sa = (struct sockaddr*)&sa_un;
    salen = (socklen_t)sizeof (struct sockaddr_un);
    break;
#endif
  default:
    ERROR ("socket-sendto: bad socket domain");
  }
  
  EXPECT_BYTES ("socket-sendto", 2);
  buf = BYTES_VAL (argv[2]);
  blen = BYTES_LEN (argv[2]);
  flags = 0;
  
  if (argc > 3) {
    int b, e = (int)blen;
    switch (argc) {
    case 6:
      EXPECT_FIXNUM ("socket-sendto", 5);
      flags = FIXNUM_VAL (argv[5]);
    case 5:
      EXPECT_FIXNUM ("socket-sendto", 4);
      e = FIXNUM_VAL (argv[4]);
    case 4:
      EXPECT_FIXNUM ("socket-sendto", 3);
      b = FIXNUM_VAL (argv[3]);
    }
    CHECK_BYTES_RANGE( "socket-sendto", argv[2], b, e );
    buf += b;
    blen = (size_t)(e - b);
  }
  
 again:
  olen = sendto (s->fd, buf, blen, flags, sa, salen);
  if (olen < 0) {
    if (ERRNO == EINTR) goto again;
    else SOCKET_ERROR ("socket-send");
  }
  
  return FIXNUM( olen );

}

//! socket-recv (<sock> !<bytes> [start end flags]) => <int>
static Scheme_Object *socket_recv (int argc, Scheme_Object **argv) {
  sock* s;
  char* buf;
  size_t blen;
  int flags, ilen;
  
  EXPECT_SOCKET ("socket-recv", 0);
  EXPECT_MUTABLE_BYTES ("socket-recv", 1);

  s = (sock*)argv[0];
  buf = BYTES_VAL (argv[1]);
  blen = BYTES_LEN (argv[1]);
  flags = 0;
  
  if (argc > 2) {
    int b, e = (int)blen;
    switch (argc) {
    case 5:
      EXPECT_FIXNUM ("socket-recv", 4);
      flags = FIXNUM_VAL (argv[4]);
    case 4:
      EXPECT_FIXNUM ("socket-recv", 3);
      e = FIXNUM_VAL (argv[3]);
    case 3:
      EXPECT_FIXNUM ("socket-recv", 2);
      b = FIXNUM_VAL (argv[2]);
    }
    CHECK_BYTES_RANGE( "socket-recv", argv[1], b, e );
    buf += b;
    blen = (size_t)(e - b);
  }
  
 again:
  ilen = recv (s->fd, buf, blen, flags);
  if (ilen < 0) {
    if (ERRNO == EINTR) goto again;
    else SOCKET_ERROR ("socket-recv");
  }
  
  return FIXNUM (ilen);
}

//! socket-recvfrom (<sock> !<bytes> [start end flags]) => <int> <addr>
static Scheme_Object *socket_recvfrom (int argc, Scheme_Object **argv) {
  sock* s;
  char* buf;
  size_t blen;
  int flags, ilen;
  Scheme_Object *vals[2];

  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in6 sa_in6;
#ifdef UNIX
    struct sockaddr_un sa_un;
#endif
  } sa;
  socklen_t salen;

  EXPECT_SOCKET ("socket-recvfrom", 0);
  EXPECT_MUTABLE_BYTES ("socket-recvfrom", 1);

  s = (sock*)argv[0];
  buf = BYTES_VAL (argv[1]);
  blen = BYTES_LEN (argv[1]);
  flags = 0;

  if (argc > 2) {
    int b, e = (int)blen;
    switch (argc) {
    case 5:
      EXPECT_FIXNUM ("socket-recvfrom", 4);
      flags = FIXNUM_VAL (argv[4]);
    case 4:
      EXPECT_FIXNUM ("socket-recvfrom", 3);
      e = FIXNUM_VAL (argv[3]);
    case 3:
      EXPECT_FIXNUM ("socket-recvfrom", 2);
      b = FIXNUM_VAL (argv[2]);
    }
    CHECK_BYTES_RANGE ("socket-recvfrom", argv[1], b, e);
    buf += b;
    blen = (size_t)(e - b);
  }

  switch (s->domain) {
  case PF_INET: 
    salen = sizeof (struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    salen = sizeof (struct sockaddr_in6);
    break;
#endif
#ifdef UNIX
  case PF_UNIX:
    memset (&sa.sa_un, 0, sizeof (struct sockaddr_un));
    salen = sizeof (struct sockaddr_un);
    break;
#endif
  default:
    ERROR ("socket-recvfrom: bad socket domain");
  }
  
 again:
  ilen = recvfrom (s->fd, buf, blen, flags, (struct sockaddr*)&sa, &salen);
  if (ilen < 0) {
    if (ERRNO == EINTR) goto again;
    else SOCKET_ERROR ("socket-recvfrom");
  }

  // No gc decl, since the first val is a fixnum and there is no gc
  // triggered by scheme_values -- a gc during address allocation will
  // not mangle any live object
  vals[0] = FIXNUM (ilen);
  switch (s->domain) {
  case PF_INET:
#ifdef HAVE_IPV6
  case PF_INET6:
#endif
    vals[1] = new_inet_address (&sa);
    break;
#ifdef UNIX
  case PF_UNIX:
    vals[1] = PATH_SIZE (sa.sa_un.sun_path, 
                         unix_path_len (sa.sa_un.sun_path));
    break;
#endif
  default:
    vals[1] = scheme_false;
  }
  
  return scheme_values (2, vals);
}

#define INIT_MSGHDR(where) \
  s = (sock*)argv[0]; \
  memset (&hdr, 0, sizeof(struct msghdr)); \
  if (BYTESP(argv[1])) { \
    hdr.msg_name = BYTES_VAL(argv[1]); \
    hdr.msg_namelen = BYTES_LEN(argv[1]); \
  } \
  if (BYTESP(argv[2])) { \
    iov.iov_base = BYTES_VAL(argv[2]); \
    iov.iov_len = BYTES_LEN(argv[2]); \
    hdr.msg_iov = &iov; \
    hdr.msg_iovlen = 1; \
  } \
  if (BYTESP(argv[3])) { \
    hdr.msg_control = BYTES_VAL(argv[3]); \
    hdr.msg_controllen = BYTES_LEN(argv[3]); \
  } \
  if (argc > 4) { \
    EXPECT_FIXNUM (where, 4); \
    flags = FIXNUM_VAL(argv[4]); \
  } else flags = 0

//! socket-sendmsg (<sock> <bytes>? <bytes>? <bytes>? [<int>]) => <int>
//                          name     data    control  flags 
static Scheme_Object *socket_sendmsg (int argc, Scheme_Object **argv) {
#ifdef UNIX
  struct msghdr hdr;
  struct iovec iov;
  sock *s;
  int flags;
  int r;

  EXPECT_SOCKET ("socket-sendmsg", 0);
  EXPECT_MAYBE_BYTES ("socket-sendmsg", 1);
  EXPECT_MAYBE_BYTES ("socket-sendmsg", 2);
  EXPECT_MAYBE_BYTES ("socket-sendmsg", 3);
  
  INIT_MSGHDR("socket-sendmsg");
  
 again:
  if ((r = sendmsg (s->fd, &hdr, flags)) < 0) {
    if (ERRNO == EINTR) goto again;
    else SOCKET_ERROR ("socket-sendmsg");
  }
  
  return FIXNUM (r);

#else
  ERROR ("socket-sendmsg: not supported in this system");
#endif
}

//! socket-recvmsg (<sock> !<bytes>? !<bytes>? !<bytes>? [<int>]) 
//                            name      data    control  flags 
//   => <int> <int>? <int>? <int>
//             name control flags
static Scheme_Object *socket_recvmsg (int argc, Scheme_Object **argv) {
#ifdef UNIX
  struct msghdr hdr;
  struct iovec iov;
  sock *s;
  int flags;
  int r;
  Scheme_Object *vals[4];

  EXPECT_SOCKET ("socket-revmsg", 0);
  EXPECT_MAYBE_MUTABLE_BYTES ("socket-revmsg", 1);
  EXPECT_MAYBE_MUTABLE_BYTES ("socket-revmsg", 2);
  EXPECT_MAYBE_MUTABLE_BYTES ("socket-revmsg", 3);

  INIT_MSGHDR("socket-revmsg");

 again:
  if ((r = recvmsg (s->fd, &hdr, flags)) < 0) {
    if (ERRNO == EINTR) goto again;
    else SOCKET_ERROR ("socket-recvmsg");
  }
  
  vals[0] = FIXNUM (r);
  if (hdr.msg_name) {
    vals[1] = FIXNUM (hdr.msg_namelen);
  } else vals[1] = scheme_false;
  if (hdr.msg_control) {
    vals[2] = FIXNUM (hdr.msg_controllen);
  } else vals[2] = scheme_false;
  vals[3] = FIXNUM (hdr.msg_flags);
  
  return scheme_values (4, vals);
#else
  ERROR ("socket-recvmsg: not supported in this system");
#endif
}

#ifdef UNIX
typedef int (*namefun_t)(int, struct sockaddr*, socklen_t*);
#else
// fucking hell
typedef int (PASCAL *namefun_t)(int, struct sockaddr*, socklen_t*);
#endif

static Scheme_Object* _getname (sock *s, namefun_t f, const char *fname) {
  union {
    struct sockaddr_in sa_in;
    struct sockaddr_in6 sa_in6;
#ifdef UNIX
    struct sockaddr_un sa_un;
#endif
  } sa;
  socklen_t salen;

  switch (s->domain) {
  case PF_INET: 
    salen = sizeof (struct sockaddr_in);
    break;
#ifdef HAVE_IPV6
  case PF_INET6:
    salen = sizeof (struct sockaddr_in6);
    break;
#endif
#ifdef UNIX
  case PF_UNIX:
    memset (&sa.sa_un, 0, sizeof (struct sockaddr_un));
    salen = sizeof (struct sockaddr_un);
    break;
#endif
  default:
    ERROR2 (fname, "bad socket domain");
  }
  
  if (f (s->fd, (struct sockaddr*)&sa, &salen) < 0)
    SOCKET_ERROR (fname);
  
  switch (s->domain) {
  case PF_INET: 
#ifdef HAVE_IPV6
  case PF_INET6: 
#endif
    return new_inet_address( &sa );
#ifdef UNIX
  case PF_UNIX:
    return PATH_SIZE (sa.sa_un.sun_path, 
                      unix_path_len (sa.sa_un.sun_path ));
#endif
  }
}

//! socket-getsockname
static Scheme_Object *socket_getsockname (int argc, Scheme_Object **argv) {
  EXPECT_SOCKET ("socket-getsockname", 0);
  return _getname ((sock*)argv[0], getsockname, "socket-getsockname");
}

//! socket-getpeername
static Scheme_Object *socket_getpeername (int argc, Scheme_Object **argv) {
  EXPECT_SOCKET ("socket-getpeername", 0);
  return _getname ((sock*)argv[0], getpeername, "socket-getpeername");
}

//! socket-getsockopt-raw (<sock> <int> <int> !<bytes>) => <int>
static Scheme_Object *socket_getsockopt_raw (int argc, Scheme_Object **argv) {
  sock *s;
  socklen_t vlen;

  EXPECT_SOCKET ("socket-getsockopt-raw", 0);
  EXPECT_FIXNUM ("socket-getsockopt-raw", 1);
  EXPECT_FIXNUM ("socket-getsockopt-raw", 2);
  EXPECT_MUTABLE_BYTES ("socket-getsockopt-raw", 3);

  s = (sock*)argv[0];
  vlen = (socklen_t)BYTES_LEN (argv[3]);
  if (getsockopt (s->fd, FIXNUM_VAL(argv[1]), FIXNUM_VAL(argv[2]), 
                  BYTES_VAL(argv[3]), &vlen ) < 0)
    SOCKET_ERROR ("socket-getsockopt-raw");
  return FIXNUM(vlen);
}

//! socket-setsockopt-raw (<sock> <int> <int> <bytes>) => <int>
static Scheme_Object *socket_setsockopt_raw (int argc, Scheme_Object **argv) {
  sock *s;

  EXPECT_SOCKET ("socket-setsockopt-raw", 0);
  EXPECT_FIXNUM ("socket-setsockopt-raw", 1);
  EXPECT_FIXNUM ("socket-setsockopt-raw", 2);
  EXPECT_BYTES ("socket-setsockopt-raw", 3);
  
  s = (sock*)argv[0];
  if (setsockopt (s->fd, FIXNUM_VAL (argv[1]), FIXNUM_VAL (argv[2]), 
                  BYTES_VAL (argv[3]), (socklen_t)BYTES_LEN (argv[3])) < 0)
    SOCKET_ERROR ("socket-setsockopt-raw");
  return scheme_void;
}

#include "sockopt.rules.h"

//! socket-getsockopt (<sock> <int> <int>) => <any>
static Scheme_Object *socket_getsockopt (int argc, Scheme_Object **argv) {
  sock *s;
  int level;
  int opt;
  socklen_t vlen;

  EXPECT_SOCKET ("socket-getsockopt", 0);
  EXPECT_FIXNUM ("socket-getsockopt", 1);
  EXPECT_FIXNUM ("socket-getsockopt", 2);
  
  s = (sock*)argv[0];
  level = FIXNUM_VAL (argv[1]);
  opt = FIXNUM_VAL (argv[2]);
  
  switch (level) {
#include "sockopt.get"
  default:
    ERROR ("socket-getsockopt: bad level");
  }
}

static Scheme_Object *socket_setsockopt (int argc, Scheme_Object **argv) {
  sock *s;
  int level;
  int opt;
  socklen_t vlen;

  EXPECT_SOCKET ("socket-getsockopt", 0);
  EXPECT_FIXNUM ("socket-getsockopt", 1);
  EXPECT_FIXNUM ("socket-getsockopt", 2);
  
  s = (sock*)argv[0];
  level = FIXNUM_VAL (argv[1]);
  opt = FIXNUM_VAL (argv[2]);
  
  switch (level) {
#include "sockopt.set"
  default:
    ERROR ("socket-setsockopt: bad level");
  }
}

static void print_sock ( Scheme_Object *v, int dis, 
                         Scheme_Print_Params *pp ) {
  char buf[64];
  int len;
  sock *s = (sock*)v;

  len = snprintf (buf, sizeof (buf), "#<socket %p %d>", s, s->fd);
  scheme_print_bytes (pp, buf, 0, len);
}

// sock_evt
static Scheme_Object *new_socket_evt (sock *s, enum evt_t t) {
  sock_evt *evt;
  evt = (sock_evt*)scheme_malloc_tagged (sizeof (sock_evt));
  evt->tag.type = sock_evt_tag;
  evt->s = s;
  evt->t = t;
  return (Scheme_Object*)evt;
}

//! socket-evt (<sock> <int>) => <sock-evt>
static Scheme_Object *make_socket_evt (int argc, Scheme_Object **argv) {
  sock *s;
  int t;
  EXPECT_SOCKET ("socket-evt", 0);
  EXPECT_FIXNUM ("socket-evt", 1);
  s = (sock*)argv[0];
  t = FIXNUM_VAL (argv[1]);
  if (s->fd == INVALID) {
    ERROR ("socket-evt: bad socket");
  }
  if (t & (evt_read | evt_write | evt_except)) {
    return new_socket_evt (s, (enum evt_t)t);
  } else {
    ERROR ("socket-evt: bad event");
  }
}

static int sock_evt_ready (Scheme_Object *data) {
  sock_evt *evt = (sock_evt*)data;
  if (evt->s->fd == INVALID) {
    return -1;
  } else {
    static struct timeval tvpoll = {0, 0};
    fd_set rfds, wfds, efds;
    int r;
    
    FD_ZERO (&rfds);
    FD_ZERO (&wfds);
    FD_ZERO (&efds);
    if (evt->t & evt_read) FD_SET (evt->s->fd, &rfds);
    if (evt->t & evt_write) FD_SET (evt->s->fd, &wfds);
    if (evt->t & evt_except) FD_SET (evt->s->fd, &efds);
    
  again:
    r = select (evt->s->fd + 1, &rfds, &wfds, &efds, &tvpoll);
    if ((r < 0) && (ERRNO == EINTR)) goto again;
    return r;
  }
}

static void sock_evt_setfds (Scheme_Object *data, void *fds) {
  sock_evt *evt = (sock_evt*)data;
  if (evt->s->fd != INVALID) {
    if (evt->t & evt_read) MZ_FD_SET (evt->s->fd, MZ_GET_FDSET (fds, 0));
    if (evt->t & evt_write) MZ_FD_SET (evt->s->fd, MZ_GET_FDSET (fds, 1));
    if (evt->t & evt_except) MZ_FD_SET (evt->s->fd, MZ_GET_FDSET (fds, 2));
  }
}

// 3m 
#ifdef MZ_PRECISE_GC
static int inet_address_SIZE (void *p) {
  return gcBYTES_TO_WORDS (sizeof (inet_address));
}

static int inet_address_MARK (void *p) {
  return gcBYTES_TO_WORDS (sizeof (inet_address));
}

static int inet_address_FIXUP (void *p) {
  return gcBYTES_TO_WORDS (sizeof (inet_address));
}

static int sock_SIZE (void *p) {
  return gcBYTES_TO_WORDS (sizeof (sock));
}

static int sock_MARK (void *p) {
  sock *s = (sock*)p;
  if (s->fd != INVALID)
    gcMARK (s->custodian);
  return gcBYTES_TO_WORDS (sizeof (sock));
}

static int sock_FIXUP (void *p) {
  sock *s = (sock*)p;
  if (s->fd != INVALID)
    gcFIXUP (s->custodian);
  return gcBYTES_TO_WORDS (sizeof (sock));
}

static int sock_evt_SIZE (void *p) {
  return gcBYTES_TO_WORDS (sizeof (sock_evt));
}

static int sock_evt_MARK (void *p) {
  sock_evt *e = (sock_evt*)p;
  gcMARK (e->s);
  return gcBYTES_TO_WORDS (sizeof (sock_evt));
}

static int sock_evt_FIXUP (void *p) {
  sock_evt *e = (sock_evt*)p;
  gcFIXUP (e->s);
  return gcBYTES_TO_WORDS (sizeof (sock_evt));
}
#endif

// module
#ifdef UNIX
static void unix_init() {
  signal (SIGPIPE, SIG_IGN);
}
#else
static void winsock_exit() {
  WSACleanUp();
}
static void winsock_init() {
  WSADATA data;
  if (WSAStartup (MAKEWORD(2, 2), &data) < 0)
    scheme_raise_exn (MZEXN_FAIL, "Winsock: initialization failure (%d)", 
                      ERRNO);
  atexit (winsock_exit);
}
#endif

BEGIN_XFORM
Scheme_Object *scheme_reload (Scheme_Env *env) {
  Scheme_Env* module;
  module = scheme_primitive_module (SYMBOL ("_socket" ), env);
  
  DEFVAR ("struct:exn:fail:socket", exn_type);
  DEFUN ("make-exn:fail:socket", make_exn, 2, 2);
  DEFUN ("exn:fail:socket-errno", exn_errno, 1, 1);
  DEFUN ("exn:fail:socket?", exn_p, 1, 1);

  DEFUN ("inet-address", make_inet_address, 3, 5);
  DEFUN ("inet-address?", inet_address_p, 1, 1);
  DEFUN ("inet-address=?", inet_address_equalp, 2, -1);
  DEFUN ("inet-address-family", inet_address_family, 1, 1);
  DEFUN ("inet-address-host", inet_address_host, 1, 1);
  DEFUN ("inet-address-port", inet_address_port, 1, 1);
  DEFUN ("inet-address->vector", inet_address_to_vec, 1, 1);
  DEFUN ("vector->inet-address", vec_to_inet_address, 1, 1);
  DEFUN ("pack-address", pack_sockaddr, 1, 1);
  DEFUN ("unpack-address", unpack_sockaddr, 1, 1);
  
  DEFUN ("socket", make_socket, 0, 3);
  DEFUN ("socket?", socket_p, 1, 1);
  DEFUN ("socket-close", socket_close, 1, 1);
  DEFUN ("socket-closed?", socket_closed_p, 1, 1);
  DEFUN ("socket-shutdown", socket_shutdown, 2, 2);
  DEFUN ("socket-connect", socket_connect, 2, 2);
  DEFUN ("socket-bind", socket_bind, 2, 2);
  DEFUN ("socket-listen", socket_listen, 2, 2);
  DEFUN ("socket-accept", socket_accept, 1, 1);
  DEFUN ("socket-send", socket_send, 2, 5);
  DEFUN ("socket-recv", socket_recv, 2, 5);
  DEFUN ("socket-sendto", socket_sendto, 3, 6);
  DEFUN ("socket-recvfrom", socket_recvfrom, 2, 5);
  DEFUN ("socket-sendmsg", socket_sendmsg, 4, 5);
  DEFUN ("socket-recvmsg", socket_recvmsg, 4, 5);
  DEFUN ("socket-getsockname", socket_getsockname, 1, 1);
  DEFUN ("socket-getpeername", socket_getpeername, 1, 1);
  DEFUN ("socket-getsockopt", socket_getsockopt, 3, 3);
  DEFUN ("socket-setsockopt", socket_setsockopt, 4, 4);
  DEFUN ("socket-getsockopt-raw", socket_getsockopt_raw, 4, 4);
  DEFUN ("socket-setsockopt-raw", socket_setsockopt_raw, 4, 4);

  DEFUN ("socket-evt", make_socket_evt, 2, 2);
  DEFVAR ("socket-evt:read", FIXNUM(evt_read));
  DEFVAR ("socket-evt:write", FIXNUM(evt_write));
  DEFVAR ("socket-evt:except", FIXNUM(evt_except));
  
  scheme_finish_primitive_module( module );
  return scheme_void;
}

Scheme_Object *scheme_initialize (Scheme_Env *env) {
#ifdef UNIX
  unix_init();
#else
  winsock_init();
#endif

  // types
  inet_address_tag = scheme_make_type ("<inet-address>");
  sock_tag = scheme_make_type ("<socket>");
  sock_evt_tag = scheme_make_type ("<socket-evt>");
  REGISTER_GC (inet_address_tag, 
               inet_address_SIZE, inet_address_MARK, inet_address_FIXUP, 
               1, 1);
  REGISTER_GC (sock_tag,
               sock_SIZE, sock_MARK, sock_FIXUP,
               1, 0);
  REGISTER_GC (sock_evt_tag,
               sock_evt_SIZE, sock_evt_MARK, sock_evt_FIXUP,
               1, 0);
  REGISTER_STATIC (exn_type);
  exn_type = 
    scheme_make_struct_type
    (SYMBOL ("exn:fail:socket"),
     scheme_builtin_value ("struct:exn:fail:network"),
     NULL, 1, 0, NULL, NULL, NULL);
  
  scheme_add_evt (sock_evt_tag, sock_evt_ready, sock_evt_setfds, NULL, 0);
  scheme_set_type_printer (inet_address_tag, print_inet_address);
  scheme_set_type_printer (sock_tag, print_sock);
  scheme_set_type_equality (inet_address_tag, 
                            inet_address_equal, 
                            inet_address_hash1, inet_address_hash2);

  return scheme_reload (env);
}

Scheme_Object *scheme_module_name() {
  return SYMBOL ("_socket");
}
END_XFORM

#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif