MKCL 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.

    See file '../../Copyright' for full details.
*/

/*
	OS-PLATFORM-DEPENDENT

	The file contains code to reclaim the I/O buffer
	by accessing the FILE structure of C, among other things.
*/

#define _FILE_OFFSET_BITS 64

#include <mkcl/mkcl.h>
#include <errno.h>
#include <sys/types.h>
#include <fcntl.h>
#include <string.h>
#include <stdio.h>
#include <mkcl/mkcl-inl.h>
#include <mkcl/internal.h>

#ifdef __unix
# include <sys/socket.h>
# include <unistd.h>
# include <sys/select.h>
typedef int SOCKET;
# define INVALID_SOCKET ((SOCKET)(~0)) /* a Windowsism */
# define SOCKET_ERROR (-1)
#elif defined(MKCL_WINDOWS)
# if 0
#  include <winsock2.h> /* Had to be included before windows.h */
# endif
# include <sys/stat.h>
# define STDIN_FILENO 0
# define STDOUT_FILENO 1
# define STDERR_FILENO 2
# define HAVE_SELECT
#elif defined(HAVE_SYS_IOCTL_H) && !defined(cygwin)
# include <sys/ioctl.h>
#endif

#include <sys/stat.h>

#ifdef HAVE_FSEEKO
# define mkcl_off_t off_t
# define mkcl_fseeko fseeko
# define mkcl_ftello ftello
#elif defined(MKCL_WINDOWS)
# define mkcl_off_t off64_t
# define mkcl_fseeko fseeko64
# define mkcl_ftello ftello64
#else
# define mkcl_off_t int
# define mkcl_fseeko fseek
# define mkcl_ftello ftell
#endif

/* Maximum number of bytes required to encode a character.
 * This currently corresponds to (4 + 2) for the ISO-2022-JP-* encodings
 * with 4 being the charset prefix, 2 for the character.
 */
#define ENCODING_BUFFER_MAX_SIZE 6

static mkcl_index mkcl_read_octet(MKCL, mkcl_object stream, unsigned char *c, mkcl_index n);
static mkcl_index mkcl_write_octet(MKCL, mkcl_object stream, unsigned char *c, mkcl_index n);

static struct mkcl_file_ops *duplicate_dispatch_table(MKCL, const struct mkcl_file_ops *ops);
static const struct mkcl_file_ops *stream_dispatch_table(MKCL, mkcl_object strm);

static int flisten(MKCL, FILE *);
static int file_listen(MKCL, int fileno);
static mkcl_object mkcl_off_t_to_integer(MKCL, mkcl_off_t offset);
static mkcl_off_t mkcl_integer_to_off_t(MKCL, mkcl_object offset);

static mkcl_object alloc_stream(MKCL);

static mkcl_object not_a_file_stream(MKCL, mkcl_object fn);
static void not_an_input_stream(MKCL, mkcl_object fn);
static void not_an_output_stream(MKCL, mkcl_object fn);
static void not_a_character_stream(MKCL, mkcl_object s);
static void not_a_binary_stream(MKCL, mkcl_object s);
static bool restartable_io_error(MKCL, mkcl_object strm, mkcl_interrupt_status * old_intr_ptr);
static void unread_error(MKCL, mkcl_object strm);
static void unread_twice(MKCL, mkcl_object strm);
static void io_error(MKCL, mkcl_object strm);
static void character_size_overflow(MKCL, mkcl_object strm, mkcl_character c);
static void wrong_file_handler(MKCL, mkcl_object strm) __attribute__((noreturn));

static mkcl_index encoding_error(MKCL, mkcl_object stream, unsigned char *buffer, mkcl_character ch);
static mkcl_character decoding_error(MKCL, mkcl_object stream, unsigned char *buffer, int length);

static void socket_error(MKCL, const char *err_msg, mkcl_object strm);

#ifdef MKCL_WINDOWS
static BOOL is_a_console(MKCL, HANDLE hnd);
static BOOL should_try_to_read_again(MKCL, int fd);
#endif

static mkcl_word normalize_stream_element_type(MKCL, mkcl_object element_type);

static const struct mkcl_file_ops socket_stream_input_ops;
static const struct mkcl_file_ops socket_stream_output_ops;
static const struct mkcl_file_ops socket_stream_io_ops;

/*********************************************************************/

static const struct mkcl_file_ops mk_clos_stream_ops;

static inline const struct mkcl_file_ops *
stream_dispatch_table(MKCL, mkcl_object strm)
{
  if (MKCL_INSTANCEP(strm)) {
    return &mk_clos_stream_ops;
  }
  if (mkcl_type_of(strm) != mkcl_t_stream)
    mkcl_FEtype_error_stream(env, strm);
  return (const struct mkcl_file_ops *)strm->stream.ops;
}

static inline struct mkcl_file_ops *
duplicate_dispatch_table(MKCL, const struct mkcl_file_ops *ops)
{
  struct mkcl_file_ops *new_ops = mkcl_alloc(env, sizeof(*ops));
  *new_ops = *ops;
  return new_ops;
}




/**********************************************************************
 * NOT IMPLEMENTED or NOT APPLICABLE OPERATIONS
 */

static mkcl_index
not_output_write_octet(MKCL, mkcl_object strm, unsigned char *c, mkcl_index n)
{
  not_an_output_stream(env, strm);
  return 0;
}

static mkcl_index
not_input_read_octet(MKCL, mkcl_object strm, unsigned char *c, mkcl_index n)
{
  not_an_input_stream(env, strm);
  return 0;
}

static mkcl_index
not_binary_read_octet(MKCL, mkcl_object strm, unsigned char *c, mkcl_index n)
{
  not_a_binary_stream(env, strm);
  return 0;
}

static void
not_output_write_byte(MKCL, mkcl_object c, mkcl_object strm)
{
  not_an_output_stream(env, strm);
}

static mkcl_object
not_input_read_byte(MKCL, mkcl_object strm)
{
  not_an_input_stream(env, strm);
  return MKCL_OBJNULL;
}

static void
not_binary_write_byte(MKCL, mkcl_object c, mkcl_object strm)
{
  not_a_binary_stream(env, strm);
}

static mkcl_object
not_binary_read_byte(MKCL, mkcl_object strm)
{
  not_a_binary_stream(env, strm);
  return MKCL_OBJNULL;
}

static mkcl_character
not_input_read_char(MKCL, mkcl_object strm)
{
  not_an_input_stream(env, strm);
  return -1;
}

static mkcl_character
not_output_write_char(MKCL, mkcl_object strm, mkcl_character c)
{
  not_an_output_stream(env, strm);
  return c;
}

static void
not_input_unread_char(MKCL, mkcl_object strm, mkcl_character c)
{
  not_an_input_stream(env, strm);
}

static int
not_input_listen(MKCL, mkcl_object strm)
{
  not_an_input_stream(env, strm);
  return -1;
}

static mkcl_character
not_character_read_char(MKCL, mkcl_object strm)
{
  not_a_character_stream(env, strm);
  return -1;
}

static mkcl_character
not_character_write_char(MKCL, mkcl_object strm, mkcl_character c)
{
  not_a_character_stream(env, strm);
  return c;
}

static void
not_input_clear_input(MKCL, mkcl_object strm)
{
  not_an_input_stream(env, strm);
  return;
}

static void
not_output_clear_output(MKCL, mkcl_object strm)
{
  not_an_output_stream(env, strm);
}

static void
not_output_force_output(MKCL, mkcl_object strm)
{
  not_an_output_stream(env, strm);
}

static void
not_output_finish_output(MKCL, mkcl_object strm)
{
  not_an_output_stream(env, strm);
}

static mkcl_object
not_implemented_get_position(MKCL, mkcl_object strm)
{
  mkcl_FEerror(env, "file-position not implemented for stream ~S", 1, strm);
  return mk_cl_Cnil;
}

static mkcl_object
not_implemented_set_position(MKCL, mkcl_object strm, mkcl_object pos)
{
  mkcl_FEerror(env, "file-position not implemented for stream ~S", 1, strm);
  return mk_cl_Cnil;
}

/**********************************************************************
 * CLOSED STREAM OPS
 */

static mkcl_index
closed_stream_read_octet(MKCL, mkcl_object strm, unsigned char *c, mkcl_index n)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}

static mkcl_index
closed_stream_write_octet(MKCL, mkcl_object strm, unsigned char *c, mkcl_index n)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}

static void
closed_stream_write_byte(MKCL, mkcl_object c, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
}

static mkcl_object
closed_stream_read_byte(MKCL, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
  return mk_cl_Cnil;
}

static mkcl_character
closed_stream_read_char(MKCL, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}

static mkcl_character
closed_stream_write_char(MKCL, mkcl_object strm, mkcl_character c)
{
  mkcl_FEclosed_stream(env, strm);
  return c;
}

static void
closed_stream_unread_char(MKCL, mkcl_object strm, mkcl_character c)
{
  mkcl_FEclosed_stream(env, strm);
}

static mkcl_character
closed_stream_peek_char(MKCL, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}

static mkcl_index
closed_stream_read_vector(MKCL, mkcl_object strm, mkcl_object data, mkcl_index start, mkcl_index end)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}

static mkcl_index
closed_stream_write_vector(MKCL, mkcl_object strm, mkcl_object data, mkcl_index start, mkcl_index end)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}

static int
closed_stream_listen(MKCL, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}

static void
closed_stream_clear_input(MKCL, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
}

#define closed_stream_clear_output closed_stream_clear_input
#define closed_stream_force_output closed_stream_clear_input
#define closed_stream_finish_output closed_stream_clear_input

static mkcl_object
closed_stream_length(MKCL, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
}

#define closed_stream_get_position closed_stream_length

static mkcl_object
closed_stream_set_position(MKCL, mkcl_object strm, mkcl_object position)
{
  mkcl_FEclosed_stream(env, strm);
}

static int
closed_stream_column(MKCL, mkcl_object strm)
{
  mkcl_FEclosed_stream(env, strm);
  return 0;
}


/**********************************************************************
 * GENERIC OPERATIONS
 *
 * Versions of the methods which are defined in terms of others
 */
/*
 * Byte operations based on octet operators.
 */
static mkcl_object
generic_read_byte_unsigned8(MKCL, mkcl_object strm)
{
  unsigned char c;
  if (strm->stream.ops->read_octet(env, strm, &c, 1) < 1) {
    return mk_cl_Cnil;
  }
  return MKCL_MAKE_FIXNUM(c);
}

static void
generic_write_byte_unsigned8(MKCL, mkcl_object byte, mkcl_object strm)
{
  unsigned char c = mkcl_integer_to_index(env, byte);
  strm->stream.ops->write_octet(env, strm, &c, 1);
}

static mkcl_object
generic_read_byte_signed8(MKCL, mkcl_object strm)
{
  signed char c;
  if (strm->stream.ops->read_octet(env, strm, (unsigned char *)&c, 1) < 1)
    return mk_cl_Cnil;
  return MKCL_MAKE_FIXNUM(c);
}

static void
generic_write_byte_signed8(MKCL, mkcl_object byte, mkcl_object strm)
{
  signed char c = mkcl_integer_to_word(env, byte);
  strm->stream.ops->write_octet(env, strm, (unsigned char *)&c, 1);
}

static mkcl_object
generic_read_byte_le(MKCL, mkcl_object strm)
{
  mkcl_index (*read_octet)(MKCL, mkcl_object, unsigned char *, mkcl_index);
  unsigned char c;
  mkcl_index nb, bs;
  mkcl_object output = MKCL_MAKE_FIXNUM(0);
  read_octet = strm->stream.ops->read_octet;
  bs = strm->stream.byte_size;
  for (nb = 0; bs >= 8; bs -= 8, nb += 8) {
    mkcl_object aux;
    if (read_octet(env, strm, &c, 1) < 1)
      return mk_cl_Cnil;
    if (bs <= 8 && (strm->stream.flags & MKCL_STREAM_SIGNED_BYTES))
      aux = MKCL_MAKE_FIXNUM((signed char)c);
    else
      aux = MKCL_MAKE_FIXNUM((unsigned char)c);
    output = mk_cl_logior(env, 2, output, mk_cl_ash(env, aux, MKCL_MAKE_FIXNUM(nb)));
  }
  return output;
}

static void
generic_write_byte_le(MKCL, mkcl_object c, mkcl_object strm)
{
  mkcl_index (*write_octet)(MKCL, mkcl_object strm, unsigned char *c, mkcl_index n);
  mkcl_index bs;
  write_octet = strm->stream.ops->write_octet;
  bs = strm->stream.byte_size;
  do {
    mkcl_object b = mk_cl_logand(env, 2, c, MKCL_MAKE_FIXNUM(0xFF));
    unsigned char aux = (unsigned char)mkcl_fixnum_to_word(b);
    if (write_octet(env, strm, &aux, 1) < 1)
      break;
    c = mk_cl_ash(env, c, MKCL_MAKE_FIXNUM(-8));
    bs -= 8;
  } while (bs);
}

static mkcl_object
generic_read_byte_be(MKCL, mkcl_object strm)
{
  mkcl_index (*read_octet)(MKCL, mkcl_object, unsigned char *, mkcl_index);
  unsigned char c;
  mkcl_object output = NULL;
  mkcl_index bs;
  read_octet = strm->stream.ops->read_octet;
  bs = strm->stream.byte_size;
  for (; bs >= 8; bs -= 8) {
    if (read_octet(env, strm, &c, 1) < 1)
      return mk_cl_Cnil;
    if (output) {
      output = mk_cl_logior(env, 2, MKCL_MAKE_FIXNUM(c),
			    mk_cl_ash(env, output, MKCL_MAKE_FIXNUM(8)));
    } else if (strm->stream.flags & MKCL_STREAM_SIGNED_BYTES) {
      output = MKCL_MAKE_FIXNUM((signed char)c);
    } else {
      output = MKCL_MAKE_FIXNUM((unsigned char)c);
    }
  }
  return output;
}

static void
generic_write_byte_be(MKCL, mkcl_object c, mkcl_object strm)
{
  mkcl_index (*write_octet)(MKCL, mkcl_object strm, unsigned char *c, mkcl_index n);
  mkcl_index bs;
  write_octet = strm->stream.ops->write_octet;
  bs = strm->stream.byte_size;
  do {
    unsigned char aux;
    mkcl_object b;
    bs -= 8;
    b = mk_cl_logand(env, 2,
		     MKCL_MAKE_FIXNUM(0xFF),
		     bs ? mk_cl_ash(env, c, MKCL_MAKE_FIXNUM(-bs)) : c);
    aux = (unsigned char)mkcl_fixnum_to_word(b);
    if (write_octet(env, strm, &aux, 1) < 1)
      break;
  } while (bs);
}

static mkcl_character
generic_peek_char(MKCL, mkcl_object strm)
{
  mkcl_character out = mkcl_read_char(env, strm);

  if (out != EOF) mkcl_unread_char(env, out, strm);
  return out;
}

static void
generic_void(MKCL, mkcl_object strm)
{
}

static bool
generic_always_true(MKCL, mkcl_object strm)
{
  return TRUE;
}

static bool
generic_always_false(MKCL, mkcl_object strm)
{
  return FALSE;
}

static mkcl_object
generic_always_nil(MKCL, mkcl_object strm)
{
  return mk_cl_Cnil;
}

static int
generic_column(MKCL, mkcl_object strm)
{
  return 0;
}

static mkcl_object
generic_set_position(MKCL, mkcl_object strm, mkcl_object pos)
{
  return mk_cl_Cnil;
}

static mkcl_object
generic_close(MKCL, mkcl_object strm)
{
  struct mkcl_file_ops *ops = strm->stream.ops;
  if (mkcl_input_stream_p(env, strm)) {
    ops->read_octet = closed_stream_read_octet;
    ops->read_byte = closed_stream_read_byte;
    ops->read_char = closed_stream_read_char;
    ops->unread_char = closed_stream_unread_char;
    ops->peek_char = closed_stream_peek_char;
    ops->read_vector = closed_stream_read_vector;
    ops->listen = closed_stream_listen;
    ops->clear_input = closed_stream_clear_input;
  }
  if (mkcl_output_stream_p(env, strm)) {
    ops->write_octet = closed_stream_write_octet;
    ops->write_byte = closed_stream_write_byte;
    ops->write_char = closed_stream_write_char;
    ops->write_vector = closed_stream_write_vector;
    ops->clear_output = closed_stream_clear_output;
    ops->force_output = closed_stream_force_output;
    ops->finish_output = closed_stream_finish_output;
  }
  ops->get_position = closed_stream_get_position;
  ops->set_position = closed_stream_set_position;
  ops->length = closed_stream_length;
  ops->column = closed_stream_column;
  ops->close = generic_close;
  strm->stream.closed = TRUE;
  return mk_cl_Ct;
}

static mkcl_index
generic_write_vector(MKCL, mkcl_object strm, mkcl_object data, mkcl_index start, mkcl_index end)
{
  mkcl_elttype elttype;
  const struct mkcl_file_ops *ops;
  if (start >= end)
    return start;
  ops = stream_dispatch_table(env, strm);

  mkcl_type t = mkcl_type_of(data);
  if (t == mkcl_t_base_string)
    {
      mkcl_character (*write_char)(MKCL, mkcl_object, mkcl_character) = ops->write_char;
      for (; start < end; start++)
	write_char(env, strm, mkcl_base_char_index_raw(env, data, start));
    }
  else if (t == mkcl_t_string)
    {
      mkcl_character (*write_char)(MKCL, mkcl_object, mkcl_character) = ops->write_char;
      for (; start < end; start++)
	write_char(env, strm, mkcl_character_index_raw(env, data, start));
    }
  else if (MKCL_VECTOR_TYPE_P(t))
    {
      mkcl_elttype elttype = mkcl_array_elttype(env, data);

      /* FIXME: Why does the first element of "data" play a special role here? JCB */
      if (elttype == mkcl_aet_object && MKCL_CHARACTERP(mkcl_vref_index(env, data, 0))) {
	mkcl_character (*write_char)(MKCL, mkcl_object, mkcl_character) = ops->write_char;
	for (; start < end; start++) {
	  write_char(env, strm, mkcl_char_code(env, mkcl_vref_index(env, data, start)));
	}
      } else {
	void (*write_byte)(MKCL, mkcl_object, mkcl_object) = ops->write_byte;
	for (; start < end; start++) {
	  write_byte(env, mkcl_vref_index(env, data, start), strm);
	}
      }
    }
  else mkcl_FEwrong_type_argument(env, @'array', data);

  return start;
}

static mkcl_index
generic_read_vector(MKCL, mkcl_object strm, mkcl_object data, mkcl_index start, mkcl_index end)
{
  const struct mkcl_file_ops *ops;
  mkcl_object expected_type;
  if (start >= end)
    return start;
  expected_type = mkcl_stream_element_type(env, strm);
  ops = stream_dispatch_table(env, strm);
  if (expected_type == @'base-char' || expected_type == @'character') {
    mkcl_character (*read_char)(MKCL, mkcl_object) = ops->read_char;
    for (; start < end; start++) {
      mkcl_word c = read_char(env, strm);
      if (c == EOF) break;
      mkcl_elt_set(env, data, start, MKCL_CODE_CHAR(c));
    }
  } else {
    mkcl_object (*read_byte)(MKCL, mkcl_object) = ops->read_byte;
    for (; start < end; start++) {
      mkcl_object x = read_byte(env, strm);
      if (mkcl_Null(x)) break;
      mkcl_elt_set(env, data, start, x);
    }
  }
  return start;
}

/**********************************************************************
 * CHARACTER AND EXTERNAL FORMAT SUPPORT
 */

static void
eformat_unread_char(MKCL, mkcl_object strm, mkcl_character c)
{
  if (c != strm->stream.last_char) {
    unread_twice(env, strm);
  }
  {
    mkcl_object l = mk_cl_Cnil;
    unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE];
    mkcl_index ndx = 0;
    mkcl_word i = strm->stream.last_code[0];
    if (i != EOF) {
      ndx += strm->stream.encoder(env, strm, buffer, i);
    }
    i = strm->stream.last_code[1];
    if (i != EOF) {
      ndx += strm->stream.encoder(env, strm, buffer, i);
    }
    while (ndx != 0) {
      l = MKCL_CONS(env, MKCL_MAKE_FIXNUM(buffer[--ndx]), l);
    }
    strm->stream.byte_stack = mkcl_nconc(env, strm->stream.byte_stack, l);
    strm->stream.last_char = EOF;
  }
}

static mkcl_character
eformat_read_char(MKCL, mkcl_object strm)
{
  mkcl_character c = strm->stream.decoder(env, strm, strm->stream.ops->read_octet, strm);
  if (c != EOF) {
    strm->stream.last_char = c;
    strm->stream.last_code[0] = c;
    strm->stream.last_code[1] = EOF;
  }
  return c;
}

static mkcl_character
eformat_write_char(MKCL, mkcl_object strm, mkcl_character c)
{
  unsigned char buffer[ENCODING_BUFFER_MAX_SIZE];
  mkcl_index nbytes = strm->stream.encoder(env, strm, buffer, c);
  if (nbytes == 0) {
    character_size_overflow(env, strm, c);
  }
  strm->stream.ops->write_octet(env, strm, buffer, nbytes);
  if (c == '\n')
    MKCL_IO_STREAM_COLUMN(strm) = 0;
  else if (c == '\t')
    MKCL_IO_STREAM_COLUMN(strm) = (MKCL_IO_STREAM_COLUMN(strm)&~((mkcl_word) 07)) + 8;
  else
    MKCL_IO_STREAM_COLUMN(strm)++;
  return c;
}

static mkcl_character
eformat_read_char_cr(MKCL, mkcl_object strm)
{
  mkcl_character c = eformat_read_char(env, strm);
  if (c == MKCL_CHAR_CODE_RETURN) {
    c = MKCL_CHAR_CODE_NEWLINE;
    strm->stream.last_char = c;
  }
  return c;
}

static mkcl_character
eformat_write_char_cr(MKCL, mkcl_object strm, mkcl_character c)
{
  if (c == MKCL_CHAR_CODE_NEWLINE) {
    eformat_write_char(env, strm, MKCL_CHAR_CODE_RETURN);
    MKCL_IO_STREAM_COLUMN(strm) = 0;
    return c;
  }
  return eformat_write_char(env, strm, c);
}

static mkcl_character
eformat_read_char_crlf(MKCL, mkcl_object strm)
{
  mkcl_character c = eformat_read_char(env, strm);
  if (c == MKCL_CHAR_CODE_RETURN) {
    c = eformat_read_char(env, strm);
    if (c == MKCL_CHAR_CODE_LINEFEED) {
      strm->stream.last_code[1] = c;
      c = MKCL_CHAR_CODE_NEWLINE;
    } else {
      eformat_unread_char(env, strm, c);
      c = MKCL_CHAR_CODE_RETURN;
      strm->stream.last_code[0] = c;
      strm->stream.last_code[1] = EOF;
    }
    strm->stream.last_char = c;
  }
  return c;
}

static mkcl_character
eformat_write_char_crlf(MKCL, mkcl_object strm, mkcl_character c)
{
  if (c == MKCL_CHAR_CODE_NEWLINE) {
    eformat_write_char(env, strm, MKCL_CHAR_CODE_RETURN);
    eformat_write_char(env, strm, MKCL_CHAR_CODE_LINEFEED);
    MKCL_IO_STREAM_COLUMN(strm) = 0;
    return c;
  }
  return eformat_write_char(env, strm, c);
}

/*
 * If we use Unicode, this is LATIN-1, ISO-8859-1, that is the 256
 * lowest codes of Unicode.
 */

static mkcl_character
passthrough_decoder(MKCL, mkcl_object stream, mkcl_eformat_read_octet read_octet, mkcl_object source)
{
  unsigned char aux;

  if (read_octet(env, source, &aux, 1) < 1)
    return EOF;
  else
    return aux;
}

static mkcl_index
passthrough_encoder(MKCL, mkcl_object stream, unsigned char *buffer, mkcl_character c)
{
  if (c <= 0xFF) {
    buffer[0] = c;
    return 1;
  }
  else
    return encoding_error(env, stream, buffer, c);
}

/*
 * US ASCII, that is the 128 (0 to 127) lowest codes of Unicode
 */

static mkcl_character
ascii_decoder(MKCL, mkcl_object stream, mkcl_eformat_read_octet read_octet, mkcl_object source)
{
  unsigned char aux;

  if (read_octet(env, source, &aux, 1) < 1) {
    return EOF;
  } else if (aux > 0x7F) {
    return decoding_error(env, stream, &aux, 1);
  } else {
    return aux;
  }
}

static mkcl_index
ascii_encoder(MKCL, mkcl_object stream, unsigned char *buffer, mkcl_character c)
{
  if (c <= 0x7F) {
    buffer[0] = c;
    return 1;
  }
  else
    return encoding_error(env, stream, buffer, c);
}

/*
 * UTF-32 BIG ENDIAN
 */

static mkcl_character
utf_32be_decoder(MKCL, mkcl_object stream, mkcl_eformat_read_octet read_octet, mkcl_object source)
{
  unsigned char buffer[4] = { '\0', '\0', '\0', '\0' };
  mkcl_index nb_ch = 0;

  if ((nb_ch = read_octet(env, source, buffer, 4)) < 4) {
    if (nb_ch)
      return decoding_error(env, stream, buffer, 4);
    else    
      return EOF;
  } else {
    return buffer[3] | (buffer[2]<<8) | (buffer[1]<<16) | (buffer[0]<<24);
  }
}

static mkcl_index
utf_32be_encoder(MKCL, mkcl_object stream, unsigned char *buffer, mkcl_character c)
{
  if (c <= 0x10FFFF) {
    buffer[3] = c & 0xFF; c >>= 8;
    buffer[2] = c & 0xFF; c >>= 8;
    buffer[1] = c & 0xFF; c >>= 8;
    buffer[0] = c;
    return 4;
  } else
    return encoding_error(env, stream, buffer, c);
}

/*
 * UTF-32 LITTLE ENDIAN
 */

static mkcl_character
utf_32le_decoder(MKCL, mkcl_object stream, mkcl_eformat_read_octet read_octet, mkcl_object source)
{
  unsigned char buffer[4] = { '\0', '\0', '\0', '\0' };
  mkcl_index nb_ch = 0;

  if ((nb_ch = read_octet(env, source, buffer, 4)) < 4) {
    if (nb_ch)
      return decoding_error(env, stream, buffer, 4);
    else    
      return EOF;
  } else {
    return buffer[0] | (buffer[1]<<8) | (buffer[2]<<16) | (buffer[3]<<24);
  }
}

static mkcl_index
utf_32le_encoder(MKCL, mkcl_object stream, unsigned char *buffer, mkcl_character c)
{
  if (c <= 0x10FFFF) {
    buffer[0] = c & 0xFF; c >>= 8;
    buffer[1] = c & 0xFF; c >>= 8;
    buffer[2] = c & 0xFF; c >>= 8;
    buffer[3] = c;
    return 4;
  } else
    return encoding_error(env, stream, buffer, c);
}

/*
 * UTF-32 BOM ENDIAN
 */

static mkcl_character
utf_32_decoder(MKCL, mkcl_object stream, mkcl_eformat_read_octet read_octet, mkcl_object source)
{
  mkcl_word c = utf_32be_decoder(env, stream, read_octet, source); /* What about EOF? JCB */
  if (c == 0x0000FEFF) {
    stream->stream.decoder = utf_32be_decoder;
    stream->stream.encoder = utf_32be_encoder;
    return utf_32be_decoder(env, stream, read_octet, source);
  } else if (c == 0xFFFE0000) {
    stream->stream.decoder = utf_32le_decoder;
    stream->stream.encoder = utf_32le_encoder;
    return utf_32le_decoder(env, stream, read_octet, source);
  } else {
    stream->stream.decoder = utf_32be_decoder;
    stream->stream.encoder = utf_32be_encoder;
    return c;
  }
}

static mkcl_index
utf_32_encoder(MKCL, mkcl_object stream, unsigned char *buffer, mkcl_character c)
{
  stream->stream.decoder = utf_32be_decoder; /* This way an unspecified UTF-32 stream always goes big-endian. */
  stream->stream.encoder = utf_32be_encoder;
  /* Output a big-endian BOM. */
  buffer[0] = 0xFF;
  buffer[1] = 0xFE;
  buffer[2] = buffer[3] = 0;
  return 4 + utf_32be_encoder(env, stream, buffer+4, c);
}


/*
 * UTF-16 BIG ENDIAN
 */

static mkcl_character
utf_16be_decoder(MKCL, mkcl_object stream, mkcl_eformat_read_octet read_octet, mkcl_object source)
{
  unsigned char buffer[2] = { '\0', '\0' };
  mkcl_index nb_ch = 0;

  if ((nb_ch = read_octet(env, source, buffer, 2)) < 2) {
    if (nb_ch)
      return decoding_error(env, stream, buffer, 2);
    else
      return EOF;
  } else {
    mkcl_character c = ((mkcl_character)buffer[0] << 8) | buffer[1];

    if ((buffer[0] & 0xFC) == 0xD8) {
      if ((nb_ch = read_octet(env, source, buffer, 2)) < 2) {
	if (nb_ch)
	  return decoding_error(env, stream, buffer, 2);
	else
	  return EOF;
      } else {
	mkcl_character aux = ((mkcl_character)buffer[0] << 8) | buffer[1];

	if ((buffer[0] & 0xFC) != 0xDC)
	  return decoding_error(env, stream, buffer, 2);
	else
	  return ((c & 0x3FF) << 10) + (aux & 0x3FF) + 0x10000;
      }
    } else {
      return c;
    }
  }
}

static mkcl_index
utf_16be_encoder(MKCL, mkcl_object stream, unsigned char *buffer, mkcl_character c)
{
  if (c < 0x10000)  {
    buffer[1] = c;
    buffer[0] = c >> 8;
    return 2;
  } else if (c <= 0x10FFFF) {
    c -= 0x10000;
    unsigned short high_surrogate = ((c >> 10) & 0x3FF) | 0xD800;
    buffer[1] = high_surrogate;
    buffer[0] = high_surrogate >> 8;
    buffer += 2;
    unsigned short low_surrogate = (c & 0x3FF) | 0xDC00;
    buffer[1] = low_surrogate;
    buffer[0] = low_surrogate >> 8;
    return 4;
  } else
    return encoding_error(env, stream, buffer, c);
}

/*
 * UTF-16 LITTLE ENDIAN
 */

static mkcl_character
utf_16le_decoder(MKCL, mkcl_object stream, mkcl_eformat_read_octet read_octet, mkcl_object source)
{
  unsigned char buffer[2] = { '\0', '\0' };
  mkcl_index nb_ch = 0;

  if ((nb_ch = read_octet(env, source, buffer, 2)) < 2) {