/* Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees.
   See file COPYING. */

#define _WIN32_WINNT 0x0400 /* for QueueUserAPC */

#include <winsock2.h>
#include <mswsock.h>
#include <windows.h>
#include <ws2tcpip.h>

#include <stdio.h>
#include <errno.h>              /* for errno, (POSIX?/ANSI) */
#include "scheme48vm.h"
#include "event.h"
#include "fd-io.h"

extern int s48_utf_8of16_to_utf_16(const unsigned char* utf_8of16,
				   LPWSTR utf_16,
				   int* errorp);

enum stream_descriptor_type {
  STREAM_FILE_REGULAR, /* overlapped I/O works */
  STREAM_FILE_SPECIAL, /* overlapped I/O doesn't work */
  STREAM_SOCKET
};

typedef struct
{
  HANDLE thread_handle; /* parameter */
  HANDLE file_handle; /* parameter */
  HANDLE check_semaphore; /* parameter */
  HANDLE abort_semaphore; /* parameter */

  /* in */
  psbool abort;
  char* buffer;
  size_t requested;

  PAPCFUNC callback;
  HANDLE callback_thread;

  /* out */
  size_t available; /* bytes written, readers only */
  psbool eof; /* readers only */
  psbool error;
  DWORD error_code;
} file_thread_data_t;

typedef struct {
  /* so we can pass this as LPOVERLAPPED; must be at the beginning */
  OVERLAPPED overlap;
  long fd;

  /* for successive calls in the main thread;
     only set and read from there */
  psbool checking; 

  CHAR* buffer;
  CHAR* current;
  size_t current_size, max_size;
} callback_data_t;

typedef struct {
  enum stream_descriptor_type type;

  psbool is_free;

  union {

    struct {
      HANDLE handle;
      DWORD current_offset;
      DWORD current_offset_high;
      psbool eof; /* readers only */
    } file_regular_data;

    struct {
      file_thread_data_t thread_data;
    } file_special_data;
  
    struct {
      SOCKET socket;
      WSABUF wsabuf;
      SOCKET hatched_socket;
      /* callback to set socket hatched by connect/accept  */
      PAPCFUNC hatch_callback;
    } socket_data;
  };

  callback_data_t callback_data;

} stream_descriptor_t;

/* This is the same as DEFAULT-BUFFER-SIZE in rts/port-buffer.scm */
#define FILE_CALLBACK_BUFFER_INITIAL_SIZE 4096

/* If things work smoothly, this will never have to do anything. */

static void
maybe_grow_callback_data_buffer(callback_data_t* callback_data,
				size_t new_max_size)
{
  if (new_max_size <= callback_data->max_size)
    return;

  callback_data->buffer = realloc(callback_data->buffer, new_max_size);
  
  if (callback_data->buffer == NULL)
    {
      fprintf(stderr,
	      "failed to allocate memory for stream buffer\n");
      exit(1);
    }

  callback_data->max_size = new_max_size;
}


#define STREAM_DESCRIPTORS_INITIAL_SIZE 1024

stream_descriptor_t* stream_descriptors;
size_t stream_descriptors_max_size;

static void
setup_stream_descriptor(stream_descriptor_t* stream_descriptor, long fd)
{
  stream_descriptor->is_free = PSTRUE;
  stream_descriptor->callback_data.fd = fd;
  stream_descriptor->callback_data.buffer = NULL;
}


static void
initialize_stream_descriptors(void)
{
  stream_descriptors = malloc(sizeof(stream_descriptor_t) *
			      STREAM_DESCRIPTORS_INITIAL_SIZE);
  if (stream_descriptors == NULL)
    {
      fprintf(stderr,
	      "failed to allocate memory for stream descriptors\n");
      exit(1);
    }
  
  {
    size_t i = 0;
    while (i < STREAM_DESCRIPTORS_INITIAL_SIZE)
      {
	setup_stream_descriptor(&(stream_descriptors[i]), i);
	++i;
      }
  }

  stream_descriptors_max_size = STREAM_DESCRIPTORS_INITIAL_SIZE;
}


/* We might want to do some sort of freelist thing later. */

static void
grow_stream_descriptors(void)
{
  size_t stream_descriptors_previous_max_size = stream_descriptors_max_size;
  stream_descriptors_max_size += STREAM_DESCRIPTORS_INITIAL_SIZE;

  stream_descriptors = realloc(stream_descriptors,
			       stream_descriptors_max_size);
  if (stream_descriptors == NULL)
    {
      fprintf(stderr,
	      "Failed to allocate memory for stream descriptor\n");
      exit(1);
    }

  {
    size_t i = stream_descriptors_previous_max_size;
    while (i < stream_descriptors_max_size)
      {
	setup_stream_descriptor(&(stream_descriptors[i]), i);
	++i;
      }
  }
}

static void
initialize_stream_descriptor(stream_descriptor_t* stream_descriptor,
			     enum stream_descriptor_type type)
{

  stream_descriptor->type = type;
  stream_descriptor->is_free = PSFALSE;

  /* #### this should probably move to the caller */

  switch (type)
    {
    case STREAM_FILE_REGULAR:
      stream_descriptor->file_regular_data.current_offset_high = 0;
      stream_descriptor->file_regular_data.current_offset = 0;
      stream_descriptor->file_regular_data.eof = PSFALSE;
      break;
    }

  stream_descriptor->callback_data.current_size = 0;

  if (stream_descriptor->callback_data.buffer == NULL)
    {
      stream_descriptor->callback_data.current
	= stream_descriptor->callback_data.buffer
	= malloc(FILE_CALLBACK_BUFFER_INITIAL_SIZE);

      if (stream_descriptor->callback_data.buffer == NULL)
	{
	  fprintf(stderr,
		  "Failed to allocate memory for stream buffer\n");
	  exit(1);
	}

      stream_descriptor->callback_data.max_size
	= FILE_CALLBACK_BUFFER_INITIAL_SIZE;
      stream_descriptor->callback_data.current_size = 0;
    }

  stream_descriptor->callback_data.checking = PSFALSE;
}

static void
deallocate_fd(long fd)
{
  stream_descriptors[fd].is_free = PSTRUE;
}

static long
allocate_fd(enum stream_descriptor_type type)
{
  size_t i = 0;

  while ((i < stream_descriptors_max_size)
	 && (!(stream_descriptors[i].is_free)))
      ++i;

  if (i == stream_descriptors_max_size)
    grow_stream_descriptors();

  initialize_stream_descriptor(&(stream_descriptors[i]), type);

  return i;
}


/* Windows allows doing fully asynchronous I/O on files and sockets.
   However, Windows still doesn't fit the Scheme 48 model completely.

   Here are the notable mismatches:

   - Scheme 48 uses longs uniformly to represent stream descriptors.
     Windows uses different types for files and sockets (HANDLE and SOCKET)

   - Scheme 48 reads first, sees that it can't complete immediately,
     queues up that it wants to read, then tries to read again.

     In Windows, you request a read, and a callback will get called
     *with the data*.

   - For writes we're better off because the model of Scheme 48
     actually fits Windows quite closely. */

int
ps_open_fd(char *filename, psbool is_input, long *status)
{
#define FILE_NAME_SIZE 1024
#define PERMISSION 0666   /* read and write for everyone */

  HANDLE handle;
  char filename_temp[FILE_NAME_SIZE];
  char *expanded;
  WCHAR filename_utf16[FILE_NAME_SIZE];
  extern char *s48_expand_file_name(char *, char *, int);

  expanded = s48_expand_file_name(filename, filename_temp, FILE_NAME_SIZE);
  if (expanded == NULL)
    return -1;

  s48_utf_8of16_to_utf_16(expanded, filename_utf16, NULL);

  handle = CreateFileW(filename_utf16,
		       is_input ? GENERIC_READ : GENERIC_WRITE,
		       is_input ? FILE_SHARE_READ : FILE_SHARE_WRITE,
		       NULL,
		       is_input ? OPEN_EXISTING : CREATE_ALWAYS,
		       FILE_ATTRIBUTE_NORMAL | FILE_FLAG_OVERLAPPED,
		       NULL);
  
  if (handle == INVALID_HANDLE_VALUE)
    {
      *status = (long) GetLastError();
      return -1;
    }
  else
    {
      long fd = allocate_fd(STREAM_FILE_REGULAR);
	  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);
	  callback_data_t* callback_data = &(stream_descriptor->callback_data);
      *status = NO_ERRORS;
      /* here, things are always regular */
      stream_descriptor->file_regular_data.handle = handle;
	  callback_data->overlap.Offset = 0;
	  callback_data->overlap.OffsetHigh = 0;
	  
      return fd;
    }
}

/*
 * This is for I/O streams that do not support overlapped I/O or a
 * select-like operations.  (Stdin/out/error don't support overlapped
 * I/O; pipes don't support select.)  The ideas are stolen from
 * MzScheme; the help of Matthew Flatt is gratefully acknowledged.
 *
 * Each such stream has an associated threads which carries out I/O
 * actions on behalf of some other thread.  Upon completion, an
 * asynchronous procedure call to a procedure specified by the caller
 * is registered.
 */

/*
 * This controls the text encoding used.
 */

static BOOL is_STD_INPUT_console,
  is_STD_OUTPUT_console,
  is_STD_ERROR_console;

/* defined and initialized in event.c */
extern HANDLE s48_main_thread;

DWORD WINAPI
reader_thread_proc(LPVOID lpParameter)
{
  DWORD n_read;

  stream_descriptor_t* stream_descriptor = (stream_descriptor_t*)lpParameter;
  callback_data_t* callback_data = &(stream_descriptor->callback_data);
  long fd = callback_data->fd;
  file_thread_data_t* thread_data
    = &(stream_descriptor->file_special_data.thread_data);
  DWORD file_type = GetFileType(thread_data->file_handle);
  BOOL is_console = ((fd == STDIN_FD()) && is_STD_INPUT_console);

  while ((!thread_data->eof) && (!thread_data->error))
    {
      /* this comes from the main thread */
      WaitForSingleObject(thread_data->check_semaphore, INFINITE);

      /* printf("[reader_thread_proc: waited for semaphore]\n"); */

      if (thread_data->abort)
	break;

      /* printf("[reader_thread_proc:want %ld bytes\n", (long) thread_data->requested); */
      
      if (is_console ?
	  ReadConsoleW(thread_data->file_handle, thread_data->buffer,
		       thread_data->requested / 2, &n_read, NULL)
	  : ReadFile(thread_data->file_handle, thread_data->buffer,
		     thread_data->requested, &n_read, NULL))
	{
	  thread_data->error = PSFALSE;
	  /*
	   * Windows reports in terms of characters, not bytes.
	   */
	  thread_data->available = (is_console ? (n_read * 2) : n_read);
	  /* kludge: pressing Ctrl-C looks like EOF on stdin */
	  if ((n_read == 0)  && (file_type != FILE_TYPE_CHAR))
	    thread_data->eof = PSTRUE;
	}
      else
	{
	  thread_data->error = PSTRUE;
	  thread_data->error_code = GetLastError();
	}

      /* printf("[reader_thread_proc:got %ld bytes]\n", (long) n_read); */
      
      /* notify */
       if (!QueueUserAPC(thread_data->callback,
			thread_data->callback_thread,
			(DWORD) stream_descriptor))

	{
	  fprintf(stderr, "QueueUserAPC failed\n");
	  exit(-1);
	}
    }

  /* clean up */
  if (CloseHandle(thread_data->check_semaphore))
    thread_data->error = PSFALSE;
  else
    {
      thread_data->error = PSTRUE;
      thread_data->error_code = GetLastError();
    }
  /* notify */
  ReleaseSemaphore(thread_data->abort_semaphore, 1, NULL);
  ExitThread(0);
  return 0;
}

/* #### most of this is the same as reader_thread_proc #### */

DWORD WINAPI
writer_thread_proc(LPVOID lpParameter)
{
  DWORD n_written;

  stream_descriptor_t* stream_descriptor = (stream_descriptor_t*)lpParameter;
  callback_data_t* callback_data = &(stream_descriptor->callback_data);
  long fd = callback_data->fd;
  file_thread_data_t* thread_data
    = &(stream_descriptor->file_special_data.thread_data);

  BOOL is_console = (((fd == STDOUT_FD()) && is_STD_OUTPUT_console)
		     || ((fd == STDERR_FD()) && is_STD_ERROR_console));

  while (!thread_data->error)
    {
      /* this comes from the main thread */
      WaitForSingleObject(thread_data->check_semaphore, INFINITE);

      /* printf("[writer_thread_proc: waited for semaphore]\n"); */

      if (thread_data->abort)
	break;

      /* printf("[writer_thread_proc:want %ld bytes\n", (long) thread_data->requested); */
      
      if (is_console ?
	  WriteConsoleW(thread_data->file_handle, thread_data->buffer,
			thread_data->requested / 2, &n_written, NULL)
	  : WriteFile(thread_data->file_handle, thread_data->buffer,
		      thread_data->requested, &n_written, NULL))
	{
	  thread_data->error = PSFALSE;
	  /*
	   * Windows reports in terms of characters, not bytes.
	   */
	  thread_data->available = (is_console ? (n_written * 2) : n_written);
	}
      else
	{
	  thread_data->error = PSTRUE;
	  thread_data->error_code = GetLastError();
	}
      
      /* printf("[writer_thread_proc:got %ld bytes]\n", (long) n_written); */
      

      /* notify */
      if (!QueueUserAPC(thread_data->callback,
			thread_data->callback_thread,
			(DWORD) stream_descriptor))

	{
	  fprintf(stderr, "QueueUserAPC failed\n");
	  exit(-1);
	}
    }

  /* clean up */
  if (CloseHandle(thread_data->check_semaphore))
      thread_data->error = PSFALSE;
  else
    {
      thread_data->error = PSTRUE;
      thread_data->error_code = GetLastError();
    }
  /* notify */
  ReleaseSemaphore(thread_data->abort_semaphore, 1, NULL);
  ExitThread(0);
  return 0;
}

extern HANDLE s48_create_mutex_semaphore();

static void
start_reader_slash_writer_thread(HANDLE file_handle,
				 stream_descriptor_t* stream_descriptor,
				 LPTHREAD_START_ROUTINE thread_proc)
{
  file_thread_data_t* thread_data = &(stream_descriptor->file_special_data.thread_data);
  HANDLE thread_handle;
  DWORD id;

  thread_data->abort = PSFALSE;

  thread_data->available = 0;

  thread_data->error = PSFALSE;
  thread_data->eof = PSFALSE;
  
  thread_data->file_handle = file_handle;
  thread_data->check_semaphore = s48_create_mutex_semaphore();
  thread_data->abort_semaphore = s48_create_mutex_semaphore();

  thread_handle = CreateThread(NULL, /* lpThreadAttributes */
			       4096, /* dwStackSize, */
			       (LPTHREAD_START_ROUTINE)thread_proc,
			       stream_descriptor,
			       0, /* dwCreationFlags, */
			       &id);
  if (thread_handle == NULL)
    {
      fprintf(stderr, "CreateThread failed in start_reader_slash_writer_thread\n");
      free(thread_data);
      exit(-1);
    }

  thread_data->thread_handle = thread_handle;
}


static void
open_special_fd(HANDLE handle, size_t fd,
		psbool is_input, BOOL is_redirected)
{
  stream_descriptor_t* stream_descriptor;

  if (fd >= stream_descriptors_max_size)
    grow_stream_descriptors();

  if (!(stream_descriptors[fd].is_free))
    {
      fprintf(stderr, "fd %d isn't available\n", fd);
      exit(-1);
    }

  stream_descriptor = &(stream_descriptors[fd]);

  initialize_stream_descriptor(stream_descriptor, STREAM_FILE_SPECIAL);
  
  start_reader_slash_writer_thread(handle,
				   stream_descriptor,
				   is_input
				   ? (LPTHREAD_START_ROUTINE)reader_thread_proc
				   : (LPTHREAD_START_ROUTINE)writer_thread_proc);
}

int
ps_close_fd(long fd)
{
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);
  int status;

  switch (stream_descriptor->type)
    {
    case STREAM_FILE_REGULAR:
      {
	HANDLE handle = stream_descriptor->file_regular_data.handle;

	if (CloseHandle(handle))
	  status = NO_ERRORS;
	else
	  status = (int) GetLastError();
	break;
      }
    case STREAM_FILE_SPECIAL:
      {
	file_thread_data_t* thread_data =
	  &(stream_descriptor->file_special_data.thread_data);

	thread_data->abort = PSTRUE;
	ReleaseSemaphore(thread_data->check_semaphore, 1, NULL);
	/* wait for completion */
	WaitForSingleObject(thread_data->abort_semaphore, INFINITE);

	status = thread_data->error ? thread_data->error_code : NO_ERRORS;
	break;
      }
    case STREAM_SOCKET:
      {
	SOCKET socket = stream_descriptor->socket_data.socket;

	if (closesocket(socket) == 0)
	  status = NO_ERRORS;
	else
	  status = (int) WSAGetLastError();
	break;
      }
    }
  deallocate_fd(fd);
  return status;
}

extern psbool s48_is_pending(long);
extern void s48_add_ready_fd(long, psbool, psbool, long);

/* This is called as the result of a completed read operation; either
   from the overlapped I/O completion routine, or from the callback
   from the reader thread. */

static void
read_done(DWORD dwErr,
	  size_t bytes_read,
	  stream_descriptor_t* stream_descriptor)
{
  callback_data_t* callback_data = &(stream_descriptor->callback_data);
  long fd = callback_data->fd;

  /* ### need to do offset_high as well */
  stream_descriptor->callback_data.current_size = bytes_read;
  stream_descriptor->callback_data.current = 
    stream_descriptor->callback_data.buffer;

  if (stream_descriptor->type == STREAM_FILE_REGULAR)
    {
      stream_descriptor->file_regular_data.current_offset += bytes_read;
      /* #### need to do offset_high as well */
      stream_descriptor->file_regular_data.eof 
	= ((dwErr == ERROR_HANDLE_EOF) ? PSTRUE : PSFALSE);
    }

  if (callback_data->checking) /* ps_check_fd */
    callback_data->checking = PSFALSE;
    
  if (s48_is_pending(fd))
    {
      if ((dwErr != 0) && (dwErr != ERROR_HANDLE_EOF))
	s48_add_ready_fd(fd, PSTRUE, PSTRUE, dwErr);
      else
	s48_add_ready_fd(fd, PSTRUE, PSFALSE, (long)0); /* *not* bytes_read */
    }
}

/* for regular files; from overlapped I/O */
static VOID WINAPI
read_completed(DWORD dwErr, DWORD cbBytesRead, LPOVERLAPPED lpOverLap)
{
  callback_data_t* callback_data = (callback_data_t*) lpOverLap;
  long fd = callback_data->fd;
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);

  read_done(dwErr, (size_t)cbBytesRead, stream_descriptor);
}

/* for special files; from QueueUserAPC */
static VOID CALLBACK
read_callback(DWORD dwParam)
{
  stream_descriptor_t* stream_descriptor = (stream_descriptor_t*)dwParam;
  file_thread_data_t* thread_data
    = &(stream_descriptor->file_special_data.thread_data);

  read_done(thread_data->error ? thread_data->error_code : NO_ERRORS,
	    (size_t)thread_data->available,
	    stream_descriptor);
}

/* from sockets */
static VOID CALLBACK
recv_completed(DWORD dwErr, DWORD cbBytesRead, LPOVERLAPPED lpOverLap, DWORD dwFlags)
{
  read_completed(dwErr, cbBytesRead, lpOverLap);
}

psbool
ps_check_fd(long fd, psbool is_read, long *status)
{
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);
  callback_data_t* callback_data = &(stream_descriptor->callback_data);

  *status = NO_ERRORS;

  if (!is_read)
    /* conservative */
    return stream_descriptor->callback_data.current_size == 0;

  /* from now on, we know is_read is true */
  if (stream_descriptor->callback_data.current_size > 0)
    /* the buffer is non-empty */
    return PSTRUE;

  switch (stream_descriptor->type) {
  case STREAM_FILE_REGULAR:
    {
      /* we might consider always returning true here */
      HANDLE handle = stream_descriptor->file_regular_data.handle;

      callback_data->overlap.Offset = stream_descriptor->file_regular_data.current_offset;
      callback_data->overlap.OffsetHigh = stream_descriptor->file_regular_data.current_offset_high;

      callback_data->checking = PSTRUE;

      if (ReadFileEx(handle,
		     (LPVOID)callback_data->buffer,
		     (DWORD)1,
		     (LPOVERLAPPED)callback_data,
		     read_completed))
	return PSFALSE;
      else
	{
	  DWORD last_error = GetLastError();

	  if (last_error != ERROR_HANDLE_EOF)
	    *status = (int) last_error;
	  return PSTRUE;
	}
    }
  case STREAM_FILE_SPECIAL:
    {
      file_thread_data_t* thread_data = &(stream_descriptor->file_special_data.thread_data);

      if (thread_data->eof)
	return PSTRUE;

      if (thread_data->error)
	{
	  *status = thread_data->error_code;
	  return PSTRUE;
	}
	
      if (callback_data->checking)
	return PSFALSE;

      /* get the reader thread started */
      callback_data->checking = PSTRUE;

      thread_data->buffer = stream_descriptor->callback_data.buffer;
      thread_data->requested = 1;
      thread_data->callback = read_callback;
      thread_data->callback_thread = s48_main_thread;
      ReleaseSemaphore(thread_data->check_semaphore, 1, NULL);

      return PSFALSE;
    }
  case STREAM_SOCKET:
    {
      SOCKET socket = stream_descriptor->socket_data.socket;
      DWORD numberOfBytesRecvd;
      DWORD flags = 0;
      int wsa_status;
      int block;

      /* just making sure */
      callback_data->overlap.Offset = 0;
      callback_data->overlap.OffsetHigh = 0;

      stream_descriptor->socket_data.wsabuf.len = 1;
      stream_descriptor->socket_data.wsabuf.buf = (char*)callback_data->buffer;

      /* just making sure */
      callback_data->overlap.Offset = 0;
      callback_data->overlap.OffsetHigh = 0;
      callback_data->overlap.hEvent = NULL; /* this is hopefully invalid */

      block = 1; /* non-blocking */
      ioctlsocket(socket, FIONBIO, &block);
      
      wsa_status = WSARecv(socket,
			   (LPWSABUF)&stream_descriptor->socket_data.wsabuf,
			   1,
			   &numberOfBytesRecvd,
			   &flags,
			   (LPOVERLAPPED)callback_data,
			   recv_completed);

	if ((wsa_status == 0)
	    && (numberOfBytesRecvd == 0))
	  return PSTRUE;

      
      if ((wsa_status == 0)
	  || (WSAGetLastError() == WSA_IO_PENDING))
	return PSFALSE;
      else
	{
	  *status = WSAGetLastError();
	  return 0;
	}
    }
  }
  return PSFALSE; /* shouldn't happen */
}



/* waitp doesn't mean it should wait---it only means that the read
   shouldn't be registered anywhere if this is false.
   
   If EOF has been reached (i.e. no characters can be read),
   *eofp is set.

   If the read operation is queued up for asynchronous completion,
   *pending is set.

   Returns number of characters actually read.  (This may be 0.)
*/

long
ps_read_fd(long fd, char *buffer, long max, psbool waitp,
	   psbool *eofp, psbool *pending, long *status)
{
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);
  callback_data_t* callback_data = &(stream_descriptor->callback_data);

  /* for the normal return */
  *eofp = PSFALSE;
  *pending = PSFALSE;
  *status = NO_ERRORS;

  if (callback_data->checking) /* ps_check_fd is active */
    return 0;

  /* there's still stuff in the buffer */
  if (callback_data->current_size > 0)
    {
      /* we want more than what's in the buffer */
      if (max >= (long)callback_data->current_size)
	{
	  size_t size = callback_data->current_size;
	  memcpy(buffer, callback_data->current, size);
	  callback_data->current_size = 0;
	  callback_data->current = stream_descriptor->callback_data.buffer;
	  return size;
	}
      else
	/* less; shouldn't happen */
	{
	  memcpy(buffer, callback_data->current, max);
	  callback_data->current += max;
	  callback_data->current_size -= max;
	  return max;
	}
    }

  switch (stream_descriptor->type)
    {
    case STREAM_FILE_REGULAR:
      {
	HANDLE handle = stream_descriptor->file_regular_data.handle;

	if (stream_descriptor->file_regular_data.eof)
	  {
	    *eofp = PSTRUE;
	    return 0;
	  }
	
	/* There's nothing in the buffer---need to do an actual read. */
	maybe_grow_callback_data_buffer(callback_data, (size_t)max);
	
	callback_data->overlap.Offset = stream_descriptor->file_regular_data.current_offset;
	callback_data->overlap.OffsetHigh = stream_descriptor->file_regular_data.current_offset_high;
	
	if (ReadFileEx(handle,
		       (LPVOID)callback_data->buffer,
		       (DWORD)max,
		       (LPOVERLAPPED)callback_data,
		       read_completed))
	  {
	    /* success */
	    if (waitp)
	      {
		if (!s48_add_pending_fd(fd, PSTRUE))
		  *status = ERROR_OUTOFMEMORY;
		else
		  *pending = PSTRUE;
	      }
	    return 0;
	  }
	else
	  {
	    DWORD last_error = GetLastError();
	    
	    if (last_error == ERROR_HANDLE_EOF)
	      {
		*eofp = PSTRUE;
		return 0;
	      }
	    
	    /* failure */
	    *status = (int) last_error;
	    return 0;
	  }
      }
    case STREAM_FILE_SPECIAL:
      {
	file_thread_data_t* thread_data =
	  &(stream_descriptor->file_special_data.thread_data);
	
	if (thread_data->eof)
	  {
	    *eofp = PSTRUE;
	    return 0;
	  }
	
	/* There's nothing in the buffer---need to do an actual read. */
	maybe_grow_callback_data_buffer(callback_data, (size_t)max);
	
	if (waitp)
	  {
	    if (!s48_add_pending_fd(fd, PSTRUE))
	      {
		*status = ERROR_OUTOFMEMORY;
		return 0;
	      }
	    thread_data->buffer = callback_data->buffer;
	    thread_data->requested = max;
	    thread_data->callback_thread = s48_main_thread;
	    thread_data->callback = read_callback;
	    ReleaseSemaphore(thread_data->check_semaphore, 1, NULL);
	    *pending = PSTRUE;
	  }
	return 0;
      }
    case STREAM_SOCKET:
      {
	SOCKET socket = stream_descriptor->socket_data.socket;
	DWORD numberOfBytesRecvd;
	DWORD flags = 0;
	int wsa_status;
	int block;

	/* There's nothing in the buffer---need to do an actual read. */
	maybe_grow_callback_data_buffer(callback_data, (size_t)max);

	/* just making sure */
	callback_data->overlap.Offset = 0;
	callback_data->overlap.OffsetHigh = 0;

	stream_descriptor->socket_data.wsabuf.len = max;
	stream_descriptor->socket_data.wsabuf.buf = (char*)callback_data->buffer;

	block = 1; /* non-blocking */
	ioctlsocket(socket, FIONBIO, &block);

	wsa_status = WSARecv(socket,
			     (LPWSABUF)&stream_descriptor->socket_data.wsabuf,
			     1,
			     &numberOfBytesRecvd,
			     &flags,
			     (LPOVERLAPPED)callback_data,
			     recv_completed);

	if ((wsa_status == 0)
	    && (numberOfBytesRecvd == 0))
	    *eofp = PSTRUE;

	if ((wsa_status == 0)
	    || (WSAGetLastError() == WSA_IO_PENDING))
	  {
	    if (waitp)
	      {
		if (!s48_add_pending_fd(fd, PSTRUE))
		  *status = ERROR_OUTOFMEMORY;
		else
		  *pending = PSTRUE;
	      }
	    return 0;
	  }
	else
	  {
	    *status = WSAGetLastError();
	    return 0;
	  }
      }
    }
  return 0; /* shouldn't happen */
}

static VOID WINAPI
write_done(DWORD dwErr,
	   size_t bytes_written,
	   stream_descriptor_t* stream_descriptor) 
{
  callback_data_t* callback_data = &(stream_descriptor->callback_data);
  long fd = callback_data->fd;

  if ((bytes_written != 0) && (s48_is_pending(fd)))
    {
      switch (stream_descriptor->type) {
      case STREAM_FILE_REGULAR:
	{
	  stream_descriptor->file_regular_data.current_offset += bytes_written;
	  /* ### need to do offset_high as well */
	  break;
	}
      }
      if (dwErr != 0)
	s48_add_ready_fd(fd, PSFALSE, PSTRUE, dwErr);
      else
	s48_add_ready_fd(fd, PSFALSE, PSFALSE, (long)bytes_written);
    }
}

/* for regular files; from overlapped I/O */
static VOID WINAPI
write_completed(DWORD dwErr, DWORD cbWritten, LPOVERLAPPED lpOverLap) 
{
  callback_data_t* callback_data = (callback_data_t*) lpOverLap;
  long fd = callback_data->fd;
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);

  write_done(dwErr, (size_t)cbWritten, stream_descriptor);
}

/* for special files; from QueueUserAPC */
static VOID CALLBACK
write_callback(DWORD dwParam)
{
  stream_descriptor_t* stream_descriptor = (stream_descriptor_t*)dwParam;
  file_thread_data_t* thread_data
    = &(stream_descriptor->file_special_data.thread_data);

  write_done(thread_data->error ? thread_data->error_code : 0,
	     (size_t)thread_data->available,
	     stream_descriptor);
}

/* for sockets */
static VOID CALLBACK
send_completed(DWORD dwErr, DWORD cbTransferred, LPOVERLAPPED lpOverLap, DWORD dwFlags)
{
  write_completed(dwErr, cbTransferred, lpOverLap);
}

long
ps_write_fd(long fd, char *buffer, long max, psbool *pending, long *status)
{
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);
  callback_data_t* callback_data = &(stream_descriptor->callback_data);

  maybe_grow_callback_data_buffer(callback_data, (size_t)max);

  memcpy(callback_data->buffer, buffer, (size_t)max);

  switch (stream_descriptor->type)
    {
    case STREAM_FILE_REGULAR:
      {
	HANDLE handle = stream_descriptor->file_regular_data.handle;

	callback_data->overlap.Offset = stream_descriptor->file_regular_data.current_offset;
	callback_data->overlap.OffsetHigh = stream_descriptor->file_regular_data.current_offset_high;

	if (WriteFileEx(handle,
			(LPVOID)callback_data->buffer,
			(DWORD)max,
			(LPOVERLAPPED)callback_data,
			write_completed))
	  {
	    if (!s48_add_pending_fd(fd, PSFALSE))
	      {
		*status = ERROR_OUTOFMEMORY;
		return 0;
	      }
	    *pending = PSTRUE;
	    *status = NO_ERRORS;
	  }
	else
	  {
	    *pending = PSFALSE;
	    *status = (int) GetLastError();
	  }
	return 0; /* we always wait for the callback */
      }
    case STREAM_FILE_SPECIAL:
      {
	file_thread_data_t* thread_data =
	  &(stream_descriptor->file_special_data.thread_data);
	thread_data->buffer = callback_data->buffer;
	thread_data->requested = max;
	thread_data->callback_thread = s48_main_thread;
	thread_data->callback = write_callback;
	ReleaseSemaphore(thread_data->check_semaphore, 1, NULL);
	if (!s48_add_pending_fd(fd, PSFALSE))
	  {
	    *status = ERROR_OUTOFMEMORY;
	    return 0;
	  }
	*pending = PSTRUE;
	*status = NO_ERRORS;
	return 0; /* the thread needs to do the work */
      }
    case STREAM_SOCKET:
      {
	SOCKET socket = stream_descriptor->socket_data.socket;
	DWORD numberOfBytesSent;
	DWORD flags = 0;
	int wsa_status;

	/* just making sure */
	callback_data->overlap.Offset = 0;
	callback_data->overlap.OffsetHigh = 0;

	stream_descriptor->socket_data.wsabuf.len = max;
	stream_descriptor->socket_data.wsabuf.buf = (char*)callback_data->buffer;

	wsa_status = WSASend(socket,
			     (LPWSABUF)&stream_descriptor->socket_data.wsabuf,
			     1,
			     &numberOfBytesSent,
			     flags,
			     (LPOVERLAPPED)callback_data,
			     send_completed);

	if ((wsa_status == 0)
	    | (WSAGetLastError() == WSA_IO_PENDING))
	  {
	    /* success */
	    if (!s48_add_pending_fd(fd, PSFALSE))
	      {
		*status = ERROR_OUTOFMEMORY;
		return 0;
	      }
	    *pending = PSTRUE;
	    *status = NO_ERRORS;
	  }
	else
	  {
	    *pending = PSFALSE;
	    *status = (int) WSAGetLastError();
	  }
	return 0; /* we always wait for the callback */
      }
    }
  return 0; /* shouldn't happen */
}

long
ps_io_buffer_size(void)
{
  return 4096;
}

psbool
ps_io_crlf_p(void)
{
  return PSTRUE;
}

char *
ps_console_encoding(long fd_as_long)
{
  if (fd_as_long == STDIN_FD())
    return is_STD_INPUT_console ? "UTF-16LE" : "ISO8859-1";
  else if (fd_as_long == STDOUT_FD())
    return is_STD_OUTPUT_console ? "UTF-16LE" : "ISO8859-1";
  else if (fd_as_long == STDERR_FD())
    return is_STD_ERROR_console ? "UTF-16LE" : "ISO8859-1";
  else
    return NULL;
}

long
ps_abort_fd_op(long fd_as_long)
{
  int fd = (int)fd_as_long;
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[fd]);
  psbool pending_p = s48_is_pending(fd);

  if (!s48_remove_fd(fd))
    fprintf(stderr, "Error: ps_abort_fd_op, no pending operation on fd %d\n",
	            fd);

  switch (stream_descriptor->type)
    {
    case STREAM_FILE_REGULAR:
      {
	HANDLE handle = stream_descriptor->file_regular_data.handle;
	CancelIo(handle);

	/* flush any pending completion routines */
	if (pending_p)
	  while (SleepEx(0, TRUE) == IO_COMPLETION_EVENT)
	    ;

	break;
      }
    case STREAM_SOCKET:
      {
	SOCKET socket = stream_descriptor->socket_data.socket;
	CancelIo((HANDLE) socket);

	/* flush any pending completion routines */
	if (pending_p)
	  while (SleepEx(0, TRUE) == IO_COMPLETION_EVENT)
	    ;

	break;
      }
    }

  return 0;      /* because we do not actually do any I/O in parallel the
		    status is always zero: no characters transfered. */
}

/*
 * This checks that fd's destined for output channels are marked
 * as nonblocking.  Stdout and stderr are a special case because
 * we do not want to screw up the shell, if we were invoked from
 * one.
 */

s48_value
s48_add_channel(s48_value mode, s48_value id, long fd)
{
  /* back to the VM */
  return s48_really_add_channel(mode, id, fd);
}

void
s48_fd_io_init()
{
  DWORD numberOfEventsRead; /* dummy, actually */
  CONSOLE_CURSOR_INFO consoleCursorInfo; /* dummy, too */
  HANDLE handle;

  initialize_stream_descriptors();

  /* these Unix-style indices are hard-wired into the VM */
  handle = GetStdHandle(STD_INPUT_HANDLE);
  /*
   * PeekConsoleInput returns non-zero if we're indeed looking at a
   * console, zero if a handle has been redirected.  We need this info
   * to decide whether to use the console I/O functions and Unicode.
   */
  is_STD_INPUT_console = PeekConsoleInput(handle, NULL, 0, &numberOfEventsRead);
  open_special_fd(handle, 0, PSTRUE, is_STD_INPUT_console);
  handle = GetStdHandle(STD_OUTPUT_HANDLE);
  /*
   * Similarly for GetConsoleCursorInfo.
   */
  is_STD_OUTPUT_console = GetConsoleCursorInfo(handle, &consoleCursorInfo);
  open_special_fd(handle, 1, PSFALSE, is_STD_OUTPUT_console);
  handle = GetStdHandle(STD_ERROR_HANDLE);
  is_STD_ERROR_console = GetConsoleCursorInfo(handle, &consoleCursorInfo);
  open_special_fd(handle, 2, PSFALSE, is_STD_ERROR_console);
}

/*
 * An interface to Windows Sockets 2
 */

/*
 * Windows Sockets 2 is a mumbojumbo of Berkeley sockets, and
 * Microsoft's own stuff thrown in.  Of course, the two halves use
 * different naming conventions, and things are generally confusing.
 * Moreover, socket handles and file handles are distinct (at least
 * partially), so we can't use the file operations we want on sockets.
 */

/* Henry Cejtin says that 5 is the largest safe number for this, at least on Unix. */
#define	LISTEN_QUEUE_SIZE	5

extern void		s48_init_socket(void);
static s48_value	s48_socket(s48_value udp_p, s48_value input_p),
			s48_bind(s48_value socket_channel, s48_value number),
			s48_socket_number(s48_value socket_channel),
			s48_listen(s48_value socket_channel),
			s48_accept(s48_value socket_channel, s48_value retry_p),
			s48_connect(s48_value socket_channel,
				    s48_value machine,
				    s48_value port,
				    s48_value retry_p),
                        s48_dup_socket_channel(s48_value socket_fd),
			s48_close_socket_half(s48_value socket_channel,
					      s48_value input_p),
                        s48_get_host_by_name(s48_value machine),
                        s48_get_host_by_name_result(s48_value event_uid),
                        s48_get_host_by_address(s48_value address),
                        s48_get_host_by_address_result(s48_value event_uid),
			s48_get_host_name(void);

/* Forward declaration. */
static s48_value dup_socket_channel(long socket_fd);

/*
 * Start up the sockets stuff and install all exported functions.
 */

void
s48_init_socket(void)
{
  WORD wVersionRequested;
  WSADATA wsaData;
 
  /* This is the *highest* version we can use.  Great. */
  wVersionRequested = MAKEWORD(2, 0);
 
  if (WSAStartup(wVersionRequested, &wsaData) != 0)
    {
      fprintf(stderr, "Windows Sockets startup failed.\n");
      exit(-1);
    }

  S48_EXPORT_FUNCTION(s48_socket);
  S48_EXPORT_FUNCTION(s48_bind);
  S48_EXPORT_FUNCTION(s48_socket_number);
  S48_EXPORT_FUNCTION(s48_listen);
  S48_EXPORT_FUNCTION(s48_accept);
  S48_EXPORT_FUNCTION(s48_connect);
  S48_EXPORT_FUNCTION(s48_dup_socket_channel);
  S48_EXPORT_FUNCTION(s48_close_socket_half);
  S48_EXPORT_FUNCTION(s48_get_host_by_name);
  S48_EXPORT_FUNCTION(s48_get_host_by_name_result);
  S48_EXPORT_FUNCTION(s48_get_host_by_address);
  S48_EXPORT_FUNCTION(s48_get_host_by_address_result);
  S48_EXPORT_FUNCTION(s48_get_host_name);
}

static void
raise_windows_error(DWORD id)
{
#define ERROR_BUFFER_SIZE 512
  WCHAR buf[ERROR_BUFFER_SIZE + 1];

  for (;;)
    {
      if (FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM,
			 NULL, /* lpSource */
			 id,
			 MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
			 buf, ERROR_BUFFER_SIZE,
			 NULL)) /* arguments ... */
	{
	  char buf_utf8[ERROR_BUFFER_SIZE * 3 + 1];
	  WideCharToMultiByte(CP_UTF8,
			      0, /* dwFlags */
			      buf,
			      -1,
			      buf_utf8, 
			      ERROR_BUFFER_SIZE * 3, 
			      NULL, /* lpDefaultChar */
			      NULL /* lpUsedDefaultChar */
			      );
	  s48_raise_string_os_error(buf_utf8);
	}
      else
	/* risky, but we assume some amount of sanity on the side of
	   the Windows implementors---haha */
	id = GetLastError();
    }
#undef ERROR_BUFFER_SIZE
}


#define S48_MAX_HOST_NAME_LENGTH NI_MAXHOST

struct gethostbyname_handshake
{
  long event_uid;
  char host_name[S48_MAX_HOST_NAME_LENGTH + 1]; /* is enough */
  int errno_val;
  int host_length;
  char* host_addr;
};

/*
 * Only one call can be active at any given time:
 * We expect mutual exclusion at the Scheme end
 */

static DWORD WINAPI
gethostbyname_thread(LPVOID void_handshake)
{
  struct gethostbyname_handshake *handshake = void_handshake;
  struct addrinfo *address_info;
  struct addrinfo hints;
  hints.ai_family = PF_INET;
  hints.ai_socktype = SOCK_STREAM;
  hints.ai_protocol = IPPROTO_TCP;
  hints.ai_flags = AI_CANONNAME;
  hints.ai_addrlen = 0;
  hints.ai_canonname = NULL;
  hints.ai_addr = NULL;
  hints.ai_next = NULL;
  /* ####
   * Unicode note: GetAddrInfoW exists, but Mike doesn't know
   * if just passing in IDNA (which we'll need to do eventually
   * anyway) works aas well.
   */
  handshake->errno_val = getaddrinfo(handshake->host_name,
				     NULL, /* servname */
				     &hints,
				     &address_info);
  if (handshake->errno_val == 0)
    {
      handshake->host_length = sizeof(struct in_addr);
      handshake->host_addr = malloc(handshake->host_length);
      if (handshake->host_addr == NULL)
	handshake->errno_val = ERROR_NOT_ENOUGH_MEMORY;
      else
	handshake->errno_val = 0;
      memcpy(handshake->host_addr,
	     (void *)&(((struct sockaddr_in*)address_info->ai_addr)->sin_addr),
	     handshake->host_length);
    }
  freeaddrinfo(address_info);
  s48_note_external_event((long) handshake->event_uid);
  ExitThread(0);
  return 0;
}

static s48_value
s48_get_host_by_name(s48_value machine)
{
  DWORD id;
  HANDLE thread_handle;
  struct gethostbyname_handshake* handshake;
  
  int machine_length = S48_BYTE_VECTOR_LENGTH(machine);
  if (machine_length > S48_MAX_HOST_NAME_LENGTH)
    s48_raise_argument_type_error(machine);

  handshake = malloc(sizeof(struct gethostbyname_handshake));
  if (handshake == NULL)
    s48_raise_out_of_memory_error();

  memcpy(handshake->host_name, s48_extract_byte_vector(machine), machine_length);
  handshake->host_name[machine_length] = '\0';

  handshake->event_uid = s48_external_event_uid();
  thread_handle = CreateThread(NULL, /* lpThreadAttributes */
			       4096, /* dwStackSize */
			       (LPTHREAD_START_ROUTINE)gethostbyname_thread,
			       (LPVOID) handshake, /* lpParameter */
			       0, /* dwCreationFlags, */
			       &id);

  {
    s48_value sch_event_uid = S48_UNSPECIFIC;
    s48_value sch_handshake = S48_UNSPECIFIC;
    s48_value sch_result;
    S48_DECLARE_GC_PROTECT(2);
    
    S48_GC_PROTECT_2(sch_event_uid, sch_handshake);
    sch_event_uid = s48_enter_integer(handshake->event_uid);
    sch_handshake = s48_enter_pointer(handshake);
    
    sch_result = s48_cons(sch_event_uid, sch_handshake);
    S48_GC_UNPROTECT();
    return sch_result;
  }
}

static s48_value
s48_get_host_by_name_result(s48_value sch_handshake)
{
  struct gethostbyname_handshake* handshake
    = s48_extract_pointer(sch_handshake);

  s48_unregister_external_event_uid(handshake->event_uid);

  if (handshake->errno_val)
    {
      int errno_val = handshake->errno_val;
      free(handshake);
      s48_raise_os_error(errno_val);
      return S48_UNSPECIFIC; /* make Visual C++ happy */
    }
  else
    {
      s48_value sch_result
	= s48_enter_byte_vector(handshake->host_addr, handshake->host_length);
      free(handshake->host_addr);
      free(handshake);
      return sch_result;
    }
}

/*
 * Get the name of the `sch_addr''s host.  If we can't get the real
 * host name we use the numbers-and-dots representation of the
 * address.
 */

struct gethostbyaddr_handshake
{
  long event_uid;
  struct in_addr address;
  char host_name[S48_MAX_HOST_NAME_LENGTH + 1];
  int errno_val;
};

static DWORD WINAPI
gethostbyaddr_thread(LPVOID void_handshake)
{
  struct gethostbyaddr_handshake *handshake = void_handshake;
  struct sockaddr_in address;
  memset(&address, 0, sizeof(address));
  address.sin_family = AF_INET;
  address.sin_addr = handshake->address;

  handshake->errno_val
    = getnameinfo((const struct sockaddr *)&address,
		  sizeof(address),
		  handshake->host_name, S48_MAX_HOST_NAME_LENGTH,
		  NULL, 0, 0);

  s48_note_external_event((long) handshake->event_uid);
  ExitThread(0);
  return 0;
}
 
static s48_value
s48_get_host_by_address(s48_value sch_addr)
{
  DWORD id;
  HANDLE thread_handle;
  struct gethostbyaddr_handshake* handshake;

  handshake = malloc(sizeof(struct gethostbyaddr_handshake));
  if (handshake == NULL)
    s48_raise_out_of_memory_error();

  memcpy(&(handshake->address),
	 (char *) s48_extract_byte_vector(sch_addr), sizeof(struct in_addr));

  handshake->event_uid = s48_external_event_uid();

  thread_handle = CreateThread(NULL, /* lpThreadAttributes */
			       4096, /* dwStackSize */
			       (LPTHREAD_START_ROUTINE)gethostbyaddr_thread,
			       handshake, /* lpParameter */
			       0, /* dwCreationFlags, */
			       &id);
  
  {
    s48_value sch_event_uid = S48_UNSPECIFIC;
    s48_value sch_handshake = S48_UNSPECIFIC;
    s48_value sch_result;
    S48_DECLARE_GC_PROTECT(2);
    
    S48_GC_PROTECT_2(sch_event_uid, sch_handshake);
    sch_event_uid = s48_enter_integer(handshake->event_uid);
    sch_handshake = s48_enter_pointer(handshake);
    
    sch_result = s48_cons(sch_event_uid, sch_handshake);
    S48_GC_UNPROTECT();
    return sch_result;
  }
}
	 
static s48_value 
s48_get_host_by_address_result(s48_value sch_handshake)
{
  struct gethostbyaddr_handshake* handshake
    = s48_extract_pointer(sch_handshake);
  s48_value sch_result;

  s48_unregister_external_event_uid(handshake->event_uid);
  if (handshake->errno_val)
    {
      int errno_val = handshake->errno_val;
      free(handshake);
      s48_raise_os_error(errno_val);
      return S48_UNSPECIFIC; /* make Visual C++ happy */
    }
  else
    {
      sch_result = s48_enter_string_latin_1(handshake->host_name);
      free(handshake);
      return sch_result;
    }
}

/*
 * Create an internet-domain stream (reliable, sequenced) socket.
 * We return an input channel on success and raise an exception on failure.
 * The socket has been made non-blocking.
 */

static s48_value
s48_socket(s48_value udp_p, s48_value input_p)
{
  int mode;
  long fd;
  s48_value channel;
  stream_descriptor_t* stream_descriptor;

  SOCKET socket = WSASocket(AF_INET,
			    (udp_p == S48_FALSE)
			    ? SOCK_STREAM
			    : SOCK_DGRAM,
			    0, /* protocol */
			    NULL,
			    0, /* reserved */
			    WSA_FLAG_OVERLAPPED);

  if (socket == INVALID_SOCKET)
    raise_windows_error(WSAGetLastError());

  mode = (input_p == S48_FALSE)
    ? S48_CHANNEL_STATUS_SPECIAL_OUTPUT
    : S48_CHANNEL_STATUS_SPECIAL_INPUT;

  fd = allocate_fd(STREAM_SOCKET);
  stream_descriptor = &(stream_descriptors[fd]);
  stream_descriptor->socket_data.socket = socket;

  channel = s48_add_channel(mode, s48_enter_string_latin_1("socket"), fd);

  if (!S48_CHANNEL_P(channel))
    {
      ps_close_fd(fd);
      s48_raise_scheme_exception(s48_extract_fixnum(channel), 0);
    };

  return channel;
}

/*
 * Given an internet-domain stream socket and a port number, bind
 * the socket to the port and prepare to receive connections.
 * If the port number is #f, then we bind the socket to any available
 * port.
 * 
 * Nothing useful is returned.
 */

static s48_value
s48_bind(s48_value channel, s48_value port_number)
{
  int socket_fd;
  unsigned short port;
  int status;
  SOCKET socket;
  struct sockaddr_in address;
  stream_descriptor_t* stream_descriptor;

  S48_CHECK_CHANNEL(channel);
  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
  stream_descriptor = &(stream_descriptors[socket_fd]);
  socket = stream_descriptor->socket_data.socket;

  if (port_number == S48_FALSE)
    port = 0;
  else
    port = (unsigned short)s48_extract_fixnum(port_number);

  memset(&address, 0, sizeof(address));
  address.sin_family = AF_INET;
  address.sin_addr.s_addr = htonl(INADDR_ANY);
  address.sin_port = htons(port);

  status = bind(socket,
		(struct sockaddr *)&address,
		sizeof(address));
  if (status == SOCKET_ERROR)
    raise_windows_error(WSAGetLastError());
  
  return S48_UNSPECIFIC;
}

/*
 * Return the port number associated with an internet stream socket.
 */

static s48_value
s48_socket_number(s48_value channel)
{
  int socket_fd;
  int status;
  int len;
  struct sockaddr_in address;
  stream_descriptor_t* stream_descriptor;
  SOCKET socket;

  S48_CHECK_CHANNEL(channel);
  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
  stream_descriptor = &(stream_descriptors[socket_fd]);
  socket = stream_descriptor->socket_data.socket;

  address.sin_addr.s_addr = htonl(INADDR_ANY);

  len = sizeof(address);

  status = getsockname(socket, (struct sockaddr *)&address, &len);

  if (status == SOCKET_ERROR)
    raise_windows_error(WSAGetLastError());

  return s48_enter_fixnum(ntohs(address.sin_port));
}
 
static s48_value
s48_listen(s48_value channel)
{
  int socket_fd;
  int status;
  stream_descriptor_t* stream_descriptor;
  SOCKET socket;

  S48_CHECK_CHANNEL(channel);
  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
  stream_descriptor = &(stream_descriptors[socket_fd]);
  socket = stream_descriptor->socket_data.socket;

  status = listen(socket, LISTEN_QUEUE_SIZE);

  if (status == SOCKET_ERROR)
    raise_windows_error(WSAGetLastError());

  return S48_UNSPECIFIC;
}
 

/*
 * Given an internet-domain stream socket which has been bound
 * accept a connection and return the resulting socket as a pair of channels
 * (after marking it non-blocking).
 *
 * If the accept fails because the client hasn't connected yet, then we
 * return #f.
 *
 * If it fails for any other reason, then an exception is raised.
 */

/*
 * This guy finally registers the completed accept.
 */

static VOID CALLBACK
accept_callback(DWORD dwParam)
{
  stream_descriptor_t* stream_descriptor = (stream_descriptor_t*)dwParam;
  callback_data_t* callback_data = &(stream_descriptor->callback_data);

  s48_add_ready_fd(callback_data->fd, PSTRUE, PSFALSE, (long)0);
}

/*
 *  This guy just waits for the event triggered by an accept,
 *  and notifies the VM.
 */

static DWORD WINAPI
hatch_thread_proc(LPVOID lpParameter)
{
  stream_descriptor_t* stream_descriptor = (stream_descriptor_t*)lpParameter;
  callback_data_t* callback_data = &(stream_descriptor->callback_data);

  WaitForSingleObject(callback_data->overlap.hEvent, INFINITE);

  if (!QueueUserAPC(stream_descriptor->socket_data.hatch_callback,
		    s48_main_thread,
		    (DWORD)stream_descriptor))
    {
      fprintf(stderr, "QueueUserAPC failed\n");
      exit(-1);
    }
  return 0;
}

static s48_value
s48_accept(s48_value channel, s48_value retry_p)
{
  long socket_fd;
  BOOL status;
  s48_value input_channel;
  stream_descriptor_t* stream_descriptor;
  callback_data_t* callback_data;
  SOCKET socket;
  SOCKET accept_socket;
  DWORD bytecount;

  S48_CHECK_CHANNEL(channel);
  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
  stream_descriptor = &(stream_descriptors[socket_fd]);
  callback_data = &(stream_descriptor->callback_data);
  socket = stream_descriptor->socket_data.socket;

  if (retry_p == S48_FALSE)
    /* first time */
    {
      callback_data->overlap.Offset = 0; /* just making sure */
      callback_data->overlap.OffsetHigh = 0;
      callback_data->overlap.hEvent = CreateEvent(NULL, /* no security attributes */
						  TRUE, /* manual reset */
						  FALSE, /* nonsignaled */
						  NULL); /* name */
      
      accept_socket = WSASocket(AF_INET,
				SOCK_STREAM,
				0, /* protocol */
				NULL,
				0, /* reserved */
				WSA_FLAG_OVERLAPPED);
      if (accept_socket == INVALID_SOCKET)
	raise_windows_error(WSAGetLastError());
      
      stream_descriptor->socket_data.hatched_socket = accept_socket;

      maybe_grow_callback_data_buffer(callback_data,
				      /* it's what the manual says: */
				      sizeof(struct sockaddr_in) + 16
				      + sizeof(struct sockaddr_in) + 16);
      
      status = AcceptEx(socket,
			accept_socket,
			callback_data->buffer,
			0,
			sizeof(struct sockaddr_in) + 16,
			sizeof(struct sockaddr_in) + 16,
			&bytecount,
			&callback_data->overlap);
    }
  else
    /* rebound */
    {
      DWORD numberOfBytesTransferred;
      if (GetOverlappedResult((HANDLE)socket,
			      &callback_data->overlap,
			      &numberOfBytesTransferred,
			      FALSE)) /* don't block */
	{
	  accept_socket = stream_descriptor->socket_data.hatched_socket;
	  status = TRUE;
	}
      else if (GetLastError() == ERROR_IO_INCOMPLETE)
	return S48_FALSE; /* still not done */
      else
	raise_windows_error(GetLastError());
    }
			 
  /*
   * Check for a connection.
   */
  
  if (status)
    /* success */
    {
      long accept_socket_fd = allocate_fd(STREAM_SOCKET);
      stream_descriptor_t* accept_stream_descriptor = &(stream_descriptors[accept_socket_fd]);
      accept_stream_descriptor->socket_data.socket = accept_socket;

      CloseHandle(callback_data->overlap.hEvent);
      
      /* We just need to do it, or things behave ... unexpectedly.
       * Go figure.
       */

      if (setsockopt(accept_socket, 
		     SOL_SOCKET, 
		     SO_UPDATE_ACCEPT_CONTEXT, 
		     (char *)&socket, 
		     sizeof(socket))
	  != 0)
	raise_windows_error(WSAGetLastError());

      input_channel = s48_add_channel(S48_CHANNEL_STATUS_INPUT,
				      s48_enter_string_latin_1("socket connection"),
				      accept_socket_fd);

      if (!S48_CHANNEL_P(input_channel))
	{
	  ps_close_fd(accept_socket_fd);
	  s48_raise_scheme_exception(s48_extract_fixnum(input_channel), 0);
	};
    
      return input_channel;
    }

  if (WSAGetLastError() == ERROR_IO_PENDING)
    {
      DWORD id;
      HANDLE thread_handle;

      if (!s48_add_pending_fd(socket_fd, PSTRUE))
	s48_raise_out_of_memory_error();

      stream_descriptor->socket_data.hatch_callback = accept_callback;
      thread_handle = CreateThread(NULL, /* lpThreadAttributes */
				   4096, /* dwStackSize */
				   (LPTHREAD_START_ROUTINE)hatch_thread_proc,
				   stream_descriptor,
				   0, /* dwCreationFlags, */
				   &id);
      return S48_FALSE;
    }
  
  raise_windows_error(WSAGetLastError());
  
  /* not reachable: */
  return S48_FALSE;
}

/*
 * Given an internet-domain stream socket, a machine name and a port number,
 * connect the socket to that machine/port.
 *
 * If this succeeds, it returns an output channel for the connection.
 * If it fails because the connect would block, add the socket to the
 * pending queue (for output) and return #f.
 * If it fails for any other reason, raise an exception.
 */

/*
 * We need to jump through the same hoops as with s48_accept.
 */

static VOID CALLBACK
connect_callback(DWORD dwParam)
{
  stream_descriptor_t* stream_descriptor = (stream_descriptor_t*)dwParam;
  callback_data_t* callback_data = &(stream_descriptor->callback_data);

  s48_add_ready_fd(callback_data->fd, PSFALSE, PSFALSE, (long)0);
}

static s48_value
s48_connect(s48_value channel,
	    s48_value sch_address,
	    s48_value port,
	    s48_value retry_p)
{
  long socket_fd;
  unsigned short port_number;
  struct sockaddr_in address;
  stream_descriptor_t* stream_descriptor;
  callback_data_t* callback_data;
  SOCKET socket;
  int status;

  S48_CHECK_CHANNEL(channel);
  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
  stream_descriptor = &(stream_descriptors[socket_fd]);
  callback_data = &(stream_descriptor->callback_data);
  socket = stream_descriptor->socket_data.socket;

  S48_CHECK_FIXNUM(port);
  port_number = (unsigned short)S48_UNSAFE_EXTRACT_FIXNUM(port);

  memset((void *)&address, 0, sizeof(address));
  address.sin_family = AF_INET;

  if (S48_BYTE_VECTOR_LENGTH(sch_address) > sizeof(address))
    s48_raise_range_error(s48_enter_fixnum(S48_BYTE_VECTOR_LENGTH(sch_address)),
			  S48_UNSAFE_ENTER_FIXNUM(0),
			  s48_enter_fixnum(sizeof(address)));

  memcpy((void *)&address.sin_addr,
	 (void *)s48_extract_byte_vector(sch_address),
	 S48_BYTE_VECTOR_LENGTH(sch_address));
  address.sin_port = htons(port_number);

  /*
   * Try the connection.  If it works we make an output channel and return it.
   * The original socket channel will be used as the input channel.
   */

  /*
   * ConnectEx, which works like AcceptEx, only exists on the very
   * latest Windows versions.
   */

  status = WSAConnect(socket,
		      (const struct sockaddr*)&address,
		      sizeof(address),
		      NULL, /* lpCallerData */
		      NULL, /* lpCalleeData */
		      NULL, /* lpSQOS */
		      NULL); /* lpGQOS */
  /*
   * Check for errors.  If we need to wait we set up a callback
   * and return #F to tell the Scheme procedure to try again.
   */
  if (status == 0)
    /* success */
    {
      S48_STOB_SET(channel, S48_CHANNEL_STATUS_OFFSET, S48_CHANNEL_STATUS_INPUT);
      return dup_socket_channel(socket_fd);
    }
  else if (WSAGetLastError() == WSAEWOULDBLOCK)
    {
      DWORD id;
      HANDLE thread_handle;

      if (!s48_add_pending_fd(socket_fd, PSFALSE))
	s48_raise_out_of_memory_error();

      stream_descriptor->socket_data.hatch_callback = connect_callback;
      thread_handle = CreateThread(NULL, /* lpThreadAttributes */
				   4096, /* dwStackSize */
				   (LPTHREAD_START_ROUTINE)hatch_thread_proc,
				   stream_descriptor,
				   0, /* dwCreationFlags, */
				   &id);
      callback_data->overlap.hEvent = CreateEvent(NULL, /* no security attributes */
						  TRUE, /* manual reset */
						  FALSE, /* nonsignaled */
						  NULL); /* name */
      if (WSAEventSelect(socket, callback_data->overlap.hEvent, FD_ACCEPT)
	  != 0)
	raise_windows_error(WSAGetLastError());
      
      return S48_FALSE;
    }
  else
    raise_windows_error(WSAGetLastError());

  /* not reachable */
  return S48_FALSE;
}

/*
 * dup() `socket_fd' and return an output channel holding the result.
 *
 * We have to versions, one for calling from C and one for calling from Scheme.
 */

static s48_value
s48_dup_socket_channel(s48_value channel)
{
  int			socket_fd;

  S48_CHECK_CHANNEL(channel);
  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
  
  return dup_socket_channel(socket_fd);
}

static s48_value
dup_socket_channel(long socket_fd)
{
  long output_fd;
  SOCKET output_socket;
  s48_value output_channel;
  stream_descriptor_t* stream_descriptor = &(stream_descriptors[socket_fd]);
  callback_data_t* callback_data = &(stream_descriptor->callback_data);
  SOCKET socket = stream_descriptor->socket_data.socket;
  stream_descriptor_t* output_stream_descriptor;
  int buf_size;

  WSAPROTOCOL_INFO protocolInfo;
  if (WSADuplicateSocket(socket,
			 GetCurrentProcessId(),
			 &protocolInfo)
      == SOCKET_ERROR)
    raise_windows_error(WSAGetLastError());

  output_socket = WSASocket(AF_INET,
			    SOCK_STREAM,
			    0, /* protocol */
			    &protocolInfo,
			    0, /* reserved */
			    WSA_FLAG_OVERLAPPED);
  if (output_socket == INVALID_SOCKET)
    raise_windows_error(WSAGetLastError());
  
  buf_size = 0;
  setsockopt(output_socket,
	     SOL_SOCKET, SO_SNDBUF, 
	     (const char*)buf_size,
	     sizeof(buf_size));

  output_fd = allocate_fd(STREAM_SOCKET);
  output_stream_descriptor = &(stream_descriptors[output_fd]);
  output_stream_descriptor->socket_data.socket = output_socket;

  output_channel = s48_add_channel(S48_CHANNEL_STATUS_OUTPUT,
				   s48_enter_string_latin_1("socket connection"),
				   output_fd);
  
  if (!S48_CHANNEL_P(output_channel))
    {
      ps_close_fd(output_fd);
      s48_raise_scheme_exception(s48_extract_fixnum(output_channel), 0);
    }

  return output_channel;
}

/*
 * Close half of a socket; if `input_p' is true we close the input half,
 * otherwise the output half.  This horribleness is forced upon us by
 * Windows's use of bidirectional file descriptors.
 */

static s48_value
s48_close_socket_half(s48_value channel, s48_value input_p)
{
  long socket_fd;
  stream_descriptor_t* stream_descriptor;
  callback_data_t* callback_data;
  SOCKET socket;
  
  S48_CHECK_CHANNEL(channel);
  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
  stream_descriptor = &(stream_descriptors[socket_fd]);
  callback_data = &(stream_descriptor->callback_data);
  socket = stream_descriptor->socket_data.socket;

  /* We ignore `endpoint is not connected' errors, as we just want to get
     the file descriptor closed. */
  if ((shutdown(socket,
	       S48_EXTRACT_BOOLEAN(input_p) ? SD_RECEIVE : SD_SEND)
       == SOCKET_ERROR)
      && (WSAGetLastError() != WSAENOTCONN))
    raise_windows_error(WSAGetLastError());

  return S48_TRUE;
}

/*
 * Get the name of the local machine.
 */

static s48_value
s48_get_host_name(void)
{
  char	mbuff[4096]; /* we don't have MAXHOSTNAMELEN on Windows */

  /* #### Unicode? IDNA? */
  if (gethostname(mbuff, sizeof(mbuff)) == SOCKET_ERROR)
    raise_windows_error(WSAGetLastError());

  return s48_enter_string_latin_1(mbuff);
}