stream: split file.d into different stream types

This commit splits one garguntulum file into numerous orthogonal stream types:

- strm_os -- c99/posix/windows streams
- strm_clos -- gray streams
- strm_string -- string streams
- strm_composite -- composite streams (echo, broadcast, synonym ...)
- strm_common -- common errors, byte manipulation routines etc
- strm_sequence -- si_write_sequence and si_read_sequence (fast I/O)
- strm_eformat -- external format processing routines (unicode etc)

After this split file.d contains only open/close. This will be the place to
dispatch to a virtual filesystem.

src/c/Makefile.in

@@ -72,7 +72,9 @@ WRITER_OBJS = print.o printer/float_to_digits.o printer/float_to_string.o
 
 READER_OBJS = read.o reader/parse_integer.o reader/parse_number.o
 
-STREAM_OBJS = stream.o file.o
+STREAM_OBJS = stream.o file.o streams/strm_os.o                                 \
+        streams/strm_clos.o streams/strm_string.o streams/strm_composite.o      \
+        streams/strm_common.o streams/strm_sequence.o streams/strm_eformat.o
 
 FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o
 

src/c/stream.d

@@ -464,3 +464,29 @@ si_copy_stream(cl_object in, cl_object out, cl_object wait)
   ecl_force_output(out);
   @(return ((c==EOF) ? ECL_T : ECL_NIL));
 }
+
+cl_object
+si_file_stream_fd(cl_object s)
+{
+  cl_object ret;
+
+  unlikely_if (!ECL_FILE_STREAM_P(s)) {
+    ecl_not_a_file_stream(s);
+  }
+
+  switch ((enum ecl_smmode)s->stream.mode) {
+  case ecl_smm_input:
+  case ecl_smm_output:
+  case ecl_smm_io:
+    ret = ecl_make_fixnum(fileno(IO_STREAM_FILE(s)));
+    break;
+  case ecl_smm_input_file:
+  case ecl_smm_output_file:
+  case ecl_smm_io_file:
+    ret = ecl_make_fixnum(IO_FILE_DESCRIPTOR(s));
+    break;
+  default:
+    ecl_internal_error("not a file stream");
+  }
+  @(return ret);
+}

src/c/streams/strm_clos.d

@@ -0,0 +1,256 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/*
+ * strm_clos.d - Gray Streams dispatch table
+ *
+ * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
+ * Copyright (c) 1990 Giuseppe Attardi
+ * Copyright (c) 2001 Juan Jose Garcia Ripoll
+ * Copyright (c) 2025 Daniel Kochmanski
+ *
+ * See file 'LICENSE' for the copyright details.
+ *
+ */
+
+#include <ecl/ecl.h>
+#include <ecl/internal.h>
+
+#ifdef ECL_CLOS_STREAMS
+static cl_index
+clos_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  cl_index i;
+  for (i = 0; i < n; i++) {
+    cl_object byte = _ecl_funcall2(@'gray::stream-read-byte', strm);
+    if (!ECL_FIXNUMP(byte))
+      break;
+    c[i] = ecl_fixnum(byte);
+  }
+  return i;
+}
+
+static cl_index
+clos_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  cl_index i;
+  for (i = 0; i < n; i++) {
+    cl_object byte = _ecl_funcall3(@'gray::stream-write-byte', strm,
+                                   ecl_make_fixnum(c[i]));
+    if (!ECL_FIXNUMP(byte))
+      break;
+  }
+  return i;
+}
+
+static cl_object
+clos_stream_read_byte(cl_object strm)
+{
+  cl_object b = _ecl_funcall2(@'gray::stream-read-byte', strm);
+  if (b == @':eof') b = ECL_NIL;
+  return b;
+}
+
+static void
+clos_stream_write_byte(cl_object strm, cl_object c)
+{
+  _ecl_funcall3(@'gray::stream-write-byte', strm, c);
+}
+
+static ecl_character
+clos_stream_read_char(cl_object strm)
+{
+  cl_object output = _ecl_funcall2(@'gray::stream-read-char', strm);
+  cl_fixnum value;
+  if (ECL_CHARACTERP(output))
+    value = ECL_CHAR_CODE(output);
+  else if (ECL_FIXNUMP(output))
+    value = ecl_fixnum(output);
+  else if (output == ECL_NIL || output == @':eof')
+    return EOF;
+  else
+    value = -1;
+  unlikely_if (value < 0 || value > ECL_CHAR_CODE_LIMIT)
+    FEerror("Unknown character ~A", 1, output);
+  return value;
+}
+
+static ecl_character
+clos_stream_write_char(cl_object strm, ecl_character c)
+{
+  _ecl_funcall3(@'gray::stream-write-char', strm, ECL_CODE_CHAR(c));
+  return c;
+}
+
+static void
+clos_stream_unread_char(cl_object strm, ecl_character c)
+{
+  _ecl_funcall3(@'gray::stream-unread-char', strm, ECL_CODE_CHAR(c));
+}
+
+static int
+clos_stream_peek_char(cl_object strm)
+{
+  cl_object out = _ecl_funcall2(@'gray::stream-peek-char', strm);
+  if (out == @':eof') return EOF;
+  return ecl_char_code(out);
+}
+
+static cl_index
+clos_stream_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end)
+{
+  return fixnnint(_ecl_funcall5(@'gray::stream-read-sequence', strm, data, ecl_make_fixnum(start), ecl_make_fixnum(end)));
+}
+
+static cl_index
+clos_stream_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end)
+{
+  _ecl_funcall5(@'gray::stream-write-sequence', strm, data, ecl_make_fixnum(start), ecl_make_fixnum(end));
+  if (start >= end)
+    return start;
+  return end;
+}
+
+static int
+clos_stream_listen(cl_object strm)
+{
+  return !Null(_ecl_funcall2(@'gray::stream-listen', strm));
+}
+
+static void
+clos_stream_clear_input(cl_object strm)
+{
+  _ecl_funcall2(@'gray::stream-clear-input', strm);
+}
+
+static void
+clos_stream_clear_output(cl_object strm)
+{
+  _ecl_funcall2(@'gray::stream-clear-output', strm);
+  return;
+}
+
+static void
+clos_stream_force_output(cl_object strm)
+{
+  _ecl_funcall2(@'gray::stream-force-output', strm);
+}
+
+static void
+clos_stream_finish_output(cl_object strm)
+{
+  _ecl_funcall2(@'gray::stream-finish-output', strm);
+}
+
+static int
+clos_stream_input_p(cl_object strm)
+{
+  return !Null(_ecl_funcall2(@'gray::input-stream-p', strm));
+}
+
+static int
+clos_stream_output_p(cl_object strm)
+{
+  return !Null(_ecl_funcall2(@'gray::output-stream-p', strm));
+}
+
+static int
+clos_stream_interactive_p(cl_object strm)
+{
+  return !Null(_ecl_funcall2(@'gray::stream-interactive-p', strm));
+
+}
+
+static cl_object
+clos_stream_element_type(cl_object strm)
+{
+  return _ecl_funcall2(@'gray::stream-element-type', strm);
+}
+
+static cl_object
+clos_stream_length(cl_object strm)
+{
+  return _ecl_funcall2(@'gray::stream-file-length', strm);
+}
+
+static cl_object
+clos_stream_get_position(cl_object strm)
+{
+  return _ecl_funcall2(@'gray::stream-file-position', strm);
+}
+
+static cl_object
+clos_stream_set_position(cl_object strm, cl_object pos)
+{
+  return _ecl_funcall3(@'gray::stream-file-position', strm, pos);
+}
+
+static cl_object
+clos_stream_string_length(cl_object strm, cl_object string)
+{
+  return _ecl_funcall3(@'gray::stream-file-string-length', strm, string);
+}
+
+static int
+clos_stream_column(cl_object strm)
+{
+  cl_object col = _ecl_funcall2(@'gray::stream-line-column', strm);
+  return Null(col)? -1 : ecl_to_size(ecl_floor1(col));
+}
+
+static cl_object
+clos_stream_pathname(cl_object strm)
+{
+  return _ecl_funcall2(@'gray::pathname', strm);
+}
+
+static cl_object
+clos_stream_truename(cl_object strm)
+{
+  return _ecl_funcall2(@'gray::truename', strm);
+}
+
+static cl_object
+clos_stream_close(cl_object strm)
+{
+  return _ecl_funcall2(@'gray::close', strm);
+}
+
+const struct ecl_file_ops clos_stream_ops = {
+  clos_stream_write_byte8,
+  clos_stream_read_byte8,
+
+  clos_stream_write_byte,
+  clos_stream_read_byte,
+
+  clos_stream_read_char,
+  clos_stream_write_char,
+  clos_stream_unread_char,
+  clos_stream_peek_char,
+
+  clos_stream_read_vector,
+  clos_stream_write_vector,
+
+  clos_stream_listen,
+  clos_stream_clear_input,
+  clos_stream_clear_output,
+  clos_stream_finish_output,
+  clos_stream_force_output,
+
+  clos_stream_input_p,
+  clos_stream_output_p,
+  clos_stream_interactive_p,
+  clos_stream_element_type,
+
+  clos_stream_length,
+  clos_stream_get_position,
+  clos_stream_set_position,
+  clos_stream_string_length,
+  clos_stream_column,
+
+  clos_stream_pathname,
+  clos_stream_truename,
+
+  clos_stream_close
+};
+#endif /* ECL_CLOS_STREAMS */

src/c/streams/strm_common.d

@@ -0,0 +1,539 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/*
+ * strm_common.d - common functions and helpers for streams
+ *
+ * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
+ * Copyright (c) 1990 Giuseppe Attardi
+ * Copyright (c) 2001 Juan Jose Garcia Ripoll
+ * Copyright (c) 2025 Daniel Kochmanski
+ *
+ * See file 'LICENSE' for the copyright details.
+ *
+ */
+
+#include <ecl/ecl.h>
+#include <ecl/internal.h>
+
+/**********************************************************************
+ * NOT A #<stream-type> STREAM
+ */
+
+cl_object
+ecl_not_a_file_stream(cl_object strm)
+{
+  cl_error(9, @'simple-type-error', @':format-control',
+           @"~A is not an file stream",
+           @':format-arguments', cl_list(1, strm),
+           @':expected-type', @'file-stream',
+           @':datum', strm);
+}
+
+void
+ecl_not_an_input_stream(cl_object strm)
+{
+  cl_error(9, @'simple-type-error', @':format-control',
+           @"~A is not an input stream",
+           @':format-arguments', cl_list(1, strm),
+           @':expected-type',
+           cl_list(2, @'satisfies', @'input-stream-p'),
+           @':datum', strm);
+}
+
+void
+ecl_not_an_output_stream(cl_object strm)
+{
+  cl_error(9, @'simple-type-error', @':format-control',
+           @"~A is not an output stream",
+           @':format-arguments', cl_list(1, strm),
+           @':expected-type', cl_list(2, @'satisfies', @'output-stream-p'),
+           @':datum', strm);
+}
+
+static void
+not_a_character_stream(cl_object s)
+{
+  cl_error(9, @'simple-type-error', @':format-control',
+           @"~A is not a character stream",
+           @':format-arguments', cl_list(1, s),
+           @':expected-type', @'character',
+           @':datum', cl_stream_element_type(s));
+}
+
+static void
+not_a_binary_stream(cl_object s)
+{
+  cl_error(9, @'simple-type-error', @':format-control',
+           @"~A is not a binary stream",
+           @':format-arguments', cl_list(1, s),
+           @':expected-type', @'integer',
+           @':datum', cl_stream_element_type(s));
+}
+
+/**********************************************************************
+ * NOT IMPLEMENTED or NOT APPLICABLE OPERATIONS
+ */
+
+cl_index
+ecl_not_output_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  ecl_not_an_output_stream(strm);
+  return 0;
+}
+
+cl_index
+ecl_not_input_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  ecl_not_an_input_stream(strm);
+  return 0;
+}
+
+cl_index
+ecl_not_binary_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  not_a_binary_stream(strm);
+  return 0;
+}
+
+void
+ecl_not_output_write_byte(cl_object strm, cl_object byte)
+{
+  ecl_not_an_output_stream(strm);
+}
+
+cl_object
+ecl_not_input_read_byte(cl_object strm)
+{
+  ecl_not_an_input_stream(strm);
+  return OBJNULL;
+}
+
+void
+ecl_not_binary_write_byte(cl_object strm, cl_object byte)
+{
+  not_a_binary_stream(strm);
+}
+
+cl_object
+ecl_not_binary_read_byte(cl_object strm)
+{
+  not_a_binary_stream(strm);
+  return OBJNULL;
+}
+
+ecl_character
+ecl_not_input_read_char(cl_object strm)
+{
+  ecl_not_an_input_stream(strm);
+  return -1;
+}
+
+ecl_character
+ecl_not_output_write_char(cl_object strm, ecl_character c)
+{
+  ecl_not_an_output_stream(strm);
+  return c;
+}
+
+void
+ecl_not_input_unread_char(cl_object strm, ecl_character c)
+{
+  ecl_not_an_input_stream(strm);
+}
+
+int
+ecl_not_input_listen(cl_object strm)
+{
+  ecl_not_an_input_stream(strm);
+  return -1;
+}
+
+ecl_character
+ecl_not_character_read_char(cl_object strm)
+{
+  not_a_character_stream(strm);
+  return -1;
+}
+
+ecl_character
+ecl_not_character_write_char(cl_object strm, ecl_character c)
+{
+  not_a_character_stream(strm);
+  return c;
+}
+
+ecl_character
+ecl_not_character_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  not_a_character_stream(stream);
+  return EOF;
+}
+
+int
+ecl_not_character_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  not_a_character_stream(stream);
+  return 0;
+}
+
+void
+ecl_not_input_clear_input(cl_object strm)
+{
+  ecl_not_an_input_stream(strm);
+  return;
+}
+
+void
+ecl_not_output_clear_output(cl_object strm)
+{
+  ecl_not_an_output_stream(strm);
+}
+
+void
+ecl_not_output_force_output(cl_object strm)
+{
+  ecl_not_an_output_stream(strm);
+}
+
+void
+ecl_not_output_finish_output(cl_object strm)
+{
+  ecl_not_an_output_stream(strm);
+}
+
+cl_object
+ecl_not_output_string_length(cl_object strm, cl_object string)
+{
+  ecl_not_an_output_stream(strm);
+  return 0;
+}
+
+cl_object
+ecl_not_file_string_length(cl_object strm, cl_object string)
+{
+  ecl_not_a_file_stream(strm);
+  return 0;
+}
+
+int
+ecl_unknown_column(cl_object strm)
+{
+  return -1;
+}
+
+/**********************************************************************
+ * CLOSED STREAM OPS
+ */
+
+static cl_index
+closed_stream_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  FEclosed_stream(strm);
+  return 0;
+}
+
+static cl_index
+closed_stream_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  FEclosed_stream(strm);
+  return 0;
+}
+
+static ecl_character
+closed_stream_read_char(cl_object strm)
+{
+  FEclosed_stream(strm);
+  return 0;
+}
+
+static ecl_character
+closed_stream_write_char(cl_object strm, ecl_character c)
+{
+  FEclosed_stream(strm);
+  return c;
+}
+
+static void
+closed_stream_unread_char(cl_object strm, ecl_character c)
+{
+  FEclosed_stream(strm);
+}
+
+static int
+closed_stream_listen(cl_object strm)
+{
+  FEclosed_stream(strm);
+  return 0;
+}
+
+static void
+closed_stream_clear_input(cl_object strm)
+{
+  FEclosed_stream(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 cl_object
+closed_stream_length(cl_object strm)
+{
+  FEclosed_stream(strm);
+}
+
+#define closed_stream_get_position closed_stream_length
+
+static cl_object
+closed_stream_set_position(cl_object strm, cl_object position)
+{
+  FEclosed_stream(strm);
+}
+
+/**********************************************************************
+ * GENERIC OPERATIONS
+ *
+ * Versions of the methods which are defined in terms of others
+ */
+/*
+ * Byte operations based on octet operators.
+ */
+cl_object
+ecl_generic_read_byte_unsigned8(cl_object strm)
+{
+  unsigned char c;
+  if (strm->stream.ops->read_byte8(strm, &c, 1) < 1) {
+    return ECL_NIL;
+  }
+  return ecl_make_fixnum(c);
+}
+
+void
+ecl_generic_write_byte_unsigned8(cl_object strm, cl_object byte)
+{
+  unsigned char c = ecl_to_uint8_t(byte);
+  strm->stream.ops->write_byte8(strm, &c, 1);
+}
+
+cl_object
+ecl_generic_read_byte_signed8(cl_object strm)
+{
+  signed char c;
+  if (strm->stream.ops->read_byte8(strm, (unsigned char *)&c, 1) < 1)
+    return ECL_NIL;
+  return ecl_make_fixnum(c);
+}
+
+void
+ecl_generic_write_byte_signed8(cl_object strm, cl_object byte)
+{
+  signed char c = ecl_to_int8_t(byte);
+  strm->stream.ops->write_byte8(strm, (unsigned char *)&c, 1);
+}
+
+cl_object
+ecl_generic_read_byte_le(cl_object strm)
+{
+  cl_index (*read_byte8)(cl_object, unsigned char *, cl_index);
+  unsigned char c;
+  cl_index nb, bs;
+  cl_object output = ecl_make_fixnum(0);
+  read_byte8 = strm->stream.ops->read_byte8;
+  bs = strm->stream.byte_size;
+  for (nb = 0; bs >= 8; bs -= 8, nb += 8) {
+    cl_object aux;
+    if (read_byte8(strm, &c, 1) < 1)
+      return ECL_NIL;
+    if (bs <= 8 && (strm->stream.flags & ECL_STREAM_SIGNED_BYTES))
+      aux = ecl_make_fixnum((signed char)c);
+    else
+      aux = ecl_make_fixnum((unsigned char)c);
+    output = cl_logior(2, output, cl_ash(aux, ecl_make_fixnum(nb)));
+  }
+  return output;
+}
+
+void
+ecl_generic_write_byte_le(cl_object strm, cl_object byte)
+{
+  cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n);
+  cl_index bs;
+  write_byte8 = strm->stream.ops->write_byte8;
+  bs = strm->stream.byte_size;
+  do {
+    cl_object b = cl_logand(2, byte, ecl_make_fixnum(0xFF));
+    unsigned char aux = (unsigned char)ecl_fixnum(b);
+    if (write_byte8(strm, &aux, 1) < 1)
+      break;
+    byte = cl_ash(byte, ecl_make_fixnum(-8));
+    bs -= 8;
+  } while (bs);
+}
+
+cl_object
+ecl_generic_read_byte(cl_object strm)
+{
+  cl_index (*read_byte8)(cl_object, unsigned char *, cl_index);
+  unsigned char c;
+  cl_object output = NULL;
+  cl_index bs;
+  read_byte8 = strm->stream.ops->read_byte8;
+  bs = strm->stream.byte_size;
+  for (; bs >= 8; bs -= 8) {
+    if (read_byte8(strm, &c, 1) < 1)
+      return ECL_NIL;
+    if (output) {
+      output = cl_logior(2, ecl_make_fixnum(c),
+                         cl_ash(output, ecl_make_fixnum(8)));
+    } else if (strm->stream.flags & ECL_STREAM_SIGNED_BYTES) {
+      output = ecl_make_fixnum((signed char)c);
+    } else {
+      output = ecl_make_fixnum((unsigned char)c);
+    }
+  }
+  return output;
+}
+
+void
+ecl_generic_write_byte(cl_object strm, cl_object byte)
+{
+  cl_index (*write_byte8)(cl_object strm, unsigned char *c, cl_index n);
+  cl_index bs;
+  write_byte8 = strm->stream.ops->write_byte8;
+  bs = strm->stream.byte_size;
+  do {
+    unsigned char aux;
+    cl_object b;
+    bs -= 8;
+    b = cl_logand(2, ecl_make_fixnum(0xFF),
+                  bs ? cl_ash(byte, ecl_make_fixnum(-bs)) : byte);
+    aux = (unsigned char)ecl_fixnum(b);
+    if (write_byte8(strm, &aux, 1) < 1)
+      break;
+  } while (bs);
+}
+
+ecl_character
+ecl_generic_peek_char(cl_object strm)
+{
+  ecl_character out = ecl_read_char(strm);
+  if (out != EOF) ecl_unread_char(out, strm);
+  return out;
+}
+
+void
+ecl_generic_void(cl_object strm)
+{
+}
+
+int
+ecl_generic_always_true(cl_object strm)
+{
+  return 1;
+}
+
+int
+ecl_generic_always_false(cl_object strm)
+{
+  return 0;
+}
+
+cl_object
+ecl_generic_always_nil(cl_object strm)
+{
+  return ECL_NIL;
+}
+
+int
+ecl_generic_column(cl_object strm)
+{
+  return strm->stream.column;
+}
+
+cl_object
+ecl_generic_set_position(cl_object strm, cl_object pos)
+{
+  return ECL_NIL;
+}
+
+cl_object
+ecl_generic_close(cl_object strm)
+{
+  struct ecl_file_ops *ops = strm->stream.ops;
+  if (ecl_input_stream_p(strm)) {
+    ops->read_byte8 = closed_stream_read_byte8;
+    ops->read_char = closed_stream_read_char;
+    ops->unread_char = closed_stream_unread_char;
+    ops->listen = closed_stream_listen;
+    ops->clear_input = closed_stream_clear_input;
+  }
+  if (ecl_output_stream_p(strm)) {
+    ops->write_byte8 = closed_stream_write_byte8;
+    ops->write_char = closed_stream_write_char;
+    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->close = ecl_generic_close;
+  strm->stream.closed = 1;
+  return ECL_T;
+}
+
+cl_index
+ecl_generic_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end)
+{
+  cl_elttype elttype;
+  const struct ecl_file_ops *ops;
+  if (start >= end)
+    return start;
+  ops = ecl_stream_dispatch_table(strm);
+  elttype = ecl_array_elttype(data);
+  if (elttype == ecl_aet_bc ||
+#ifdef ECL_UNICODE
+      elttype == ecl_aet_ch ||
+#endif
+      (elttype == ecl_aet_object && ECL_CHARACTERP(ecl_elt(data, 0)))) {
+    ecl_character (*write_char)(cl_object, ecl_character) = ops->write_char;                        
+    for (; start < end; start++) {
+      write_char(strm, ecl_char_code(ecl_elt(data, start)));
+    }
+  } else {
+    void (*write_byte)(cl_object, cl_object) = ops->write_byte;
+    for (; start < end; start++) {
+      write_byte(strm, ecl_elt(data, start));
+    }
+  }
+  return start;
+}
+
+cl_index
+ecl_generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end)
+{
+  const struct ecl_file_ops *ops;
+  cl_object expected_type;
+  if (start >= end)
+    return start;
+  expected_type = ecl_stream_element_type(strm);
+  ops = ecl_stream_dispatch_table(strm);
+  if (expected_type == @'base-char' || expected_type == @'character') {
+    ecl_character (*read_char)(cl_object) = ops->read_char;
+    for (; start < end; start++) {
+      ecl_character c = read_char(strm);
+      if (c == EOF) break;
+      ecl_elt_set(data, start, ECL_CODE_CHAR(c));
+    }
+  } else {
+    cl_object (*read_byte)(cl_object) = ops->read_byte;
+    for (; start < end; start++) {
+      cl_object x = read_byte(strm);
+      if (Null(x)) break;
+      ecl_elt_set(data, start, x);
+    }
+  }
+  return start;
+}
+

src/c/streams/strm_composite.d

@@ -0,0 +1,975 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/*
+ * strm_composite.d - Composite Streams dispatch tables
+ *
+ * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
+ * Copyright (c) 1990 Giuseppe Attardi
+ * Copyright (c) 2001 Juan Jose Garcia Ripoll
+ * Copyright (c) 2025 Daniel Kochmanski
+ *
+ * See file 'LICENSE' for the copyright details.
+ *
+ */
+
+#include <ecl/ecl.h>
+#include <ecl/internal.h>
+
+/**********************************************************************
+ * TWO WAY STREAM
+ */
+
+static cl_index
+two_way_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  if (strm == cl_core.terminal_io)
+    ecl_force_output(TWO_WAY_STREAM_OUTPUT(cl_core.terminal_io));
+  return ecl_read_byte8(TWO_WAY_STREAM_INPUT(strm), c, n);
+}
+
+static cl_index
+two_way_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  return ecl_write_byte8(TWO_WAY_STREAM_OUTPUT(strm), c, n);
+}
+
+static void
+two_way_write_byte(cl_object strm, cl_object byte)
+{
+  ecl_write_byte(byte, TWO_WAY_STREAM_OUTPUT(strm));
+}
+
+static cl_object
+two_way_read_byte(cl_object stream)
+{
+  return ecl_read_byte(TWO_WAY_STREAM_INPUT(stream));
+}
+
+static ecl_character
+two_way_read_char(cl_object strm)
+{
+  return ecl_read_char(TWO_WAY_STREAM_INPUT(strm));
+}
+
+static ecl_character
+two_way_write_char(cl_object strm, ecl_character c)
+{
+  return ecl_write_char(c, TWO_WAY_STREAM_OUTPUT(strm));
+}
+
+static void
+two_way_unread_char(cl_object strm, ecl_character c)
+{
+  ecl_unread_char(c, TWO_WAY_STREAM_INPUT(strm));
+}
+
+static ecl_character
+two_way_peek_char(cl_object strm)
+{
+  return ecl_peek_char(TWO_WAY_STREAM_INPUT(strm));
+}
+
+static cl_index
+two_way_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n)
+{
+  strm = TWO_WAY_STREAM_INPUT(strm);
+  return ecl_stream_dispatch_table(strm)->read_vector(strm, data, start, n);
+}
+
+static cl_index
+two_way_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n)
+{
+  strm = TWO_WAY_STREAM_OUTPUT(strm);
+  return ecl_stream_dispatch_table(strm)->write_vector(strm, data, start, n);
+}
+
+static int
+two_way_listen(cl_object strm)
+{
+  return ecl_listen_stream(TWO_WAY_STREAM_INPUT(strm));
+}
+
+static void
+two_way_clear_input(cl_object strm)
+{
+  ecl_clear_input(TWO_WAY_STREAM_INPUT(strm));
+}
+
+static void
+two_way_clear_output(cl_object strm)
+{
+  ecl_clear_output(TWO_WAY_STREAM_OUTPUT(strm));
+}
+
+static void
+two_way_force_output(cl_object strm)
+{
+  ecl_force_output(TWO_WAY_STREAM_OUTPUT(strm));
+}
+
+static void
+two_way_finish_output(cl_object strm)
+{
+  ecl_finish_output(TWO_WAY_STREAM_OUTPUT(strm));
+}
+
+static int
+two_way_interactive_p(cl_object strm)
+{
+  return ecl_interactive_stream_p(TWO_WAY_STREAM_INPUT(strm));
+}
+
+static cl_object
+two_way_element_type(cl_object strm)
+{
+  return ecl_stream_element_type(TWO_WAY_STREAM_INPUT(strm));
+}
+
+static int
+two_way_column(cl_object strm)
+{
+  return ecl_file_column(TWO_WAY_STREAM_OUTPUT(strm));
+}
+
+static cl_object
+two_way_close(cl_object strm)
+{
+  if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) {
+    cl_close(1, TWO_WAY_STREAM_INPUT(strm));
+    cl_close(1, TWO_WAY_STREAM_OUTPUT(strm));
+  }
+  return ecl_generic_close(strm);
+}
+
+const struct ecl_file_ops two_way_ops = {
+  two_way_write_byte8,
+  two_way_read_byte8,
+
+  two_way_write_byte,
+  two_way_read_byte,
+
+  two_way_read_char,
+  two_way_write_char,
+  two_way_unread_char,
+  two_way_peek_char,
+
+  two_way_read_vector,
+  two_way_write_vector,
+
+  two_way_listen,
+  two_way_clear_input,
+  two_way_clear_output,
+  two_way_finish_output,
+  two_way_force_output,
+
+  ecl_generic_always_true, /* input_p */
+  ecl_generic_always_true, /* output_p */
+  two_way_interactive_p,
+  two_way_element_type,
+
+  ecl_not_a_file_stream, /* length */
+  ecl_generic_always_nil, /* get_position */
+  ecl_generic_set_position,
+  ecl_not_file_string_length,
+  two_way_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  two_way_close
+};
+
+
+cl_object
+cl_make_two_way_stream(cl_object istrm, cl_object ostrm)
+{
+  cl_object strm;
+  if (!ecl_input_stream_p(istrm))
+    ecl_not_an_input_stream(istrm);
+  if (!ecl_output_stream_p(ostrm))
+    ecl_not_an_output_stream(ostrm);
+  strm = ecl_alloc_stream();
+  strm->stream.format = cl_stream_external_format(istrm);
+  strm->stream.mode = (short)ecl_smm_two_way;
+  strm->stream.ops = ecl_duplicate_dispatch_table(&two_way_ops);
+  TWO_WAY_STREAM_INPUT(strm) = istrm;
+  TWO_WAY_STREAM_OUTPUT(strm) = ostrm;
+  @(return strm);
+}
+
+cl_object
+cl_two_way_stream_input_stream(cl_object strm)
+{
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm,ecl_smm_two_way))
+    FEwrong_type_only_arg(@[two-way-stream-input-stream],
+                          strm, @[two-way-stream]);
+  @(return TWO_WAY_STREAM_INPUT(strm));
+}
+
+cl_object
+cl_two_way_stream_output_stream(cl_object strm)
+{
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_two_way))
+    FEwrong_type_only_arg(@[two-way-stream-output-stream],
+                          strm, @[two-way-stream]);
+  @(return TWO_WAY_STREAM_OUTPUT(strm));
+}
+
+/**********************************************************************
+ * BROADCAST STREAM
+ */
+
+static cl_index
+broadcast_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  cl_object l;
+  cl_index out = n;
+  for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) {
+    out = ecl_write_byte8(ECL_CONS_CAR(l), c, n);
+  }
+  return out;
+}
+
+static ecl_character
+broadcast_write_char(cl_object strm, ecl_character c)
+{
+  cl_object l;
+  for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) {
+    ecl_write_char(c, ECL_CONS_CAR(l));
+  }
+  return c;
+}
+
+static void
+broadcast_write_byte(cl_object strm, cl_object byte)
+{
+  cl_object l;
+  for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) {
+    ecl_write_byte(byte, ECL_CONS_CAR(l));
+  }
+}
+
+static void
+broadcast_clear_output(cl_object strm)
+{
+  cl_object l;
+  for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) {
+    ecl_clear_output(ECL_CONS_CAR(l));
+  }
+}
+
+static void
+broadcast_force_output(cl_object strm)
+{
+  cl_object l;
+  for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) {
+    ecl_force_output(ECL_CONS_CAR(l));
+  }
+}
+
+static void
+broadcast_finish_output(cl_object strm)
+{
+  cl_object l;
+  for (l = BROADCAST_STREAM_LIST(strm); !Null(l); l = ECL_CONS_CDR(l)) {
+    ecl_finish_output(ECL_CONS_CAR(l));
+  }
+}
+
+static cl_object
+broadcast_element_type(cl_object strm)
+{
+  cl_object l = BROADCAST_STREAM_LIST(strm);
+  if (Null(l))
+    return ECL_T;
+  return ecl_stream_element_type(ECL_CONS_CAR(l));
+}
+
+static cl_object
+broadcast_length(cl_object strm)
+{
+  cl_object l = BROADCAST_STREAM_LIST(strm);
+  if (Null(l))
+    return ecl_make_fixnum(0);
+  return ecl_file_length(ECL_CONS_CAR(ecl_last(l, 1)));
+}
+
+static cl_object
+broadcast_get_position(cl_object strm)
+{
+  cl_object l = BROADCAST_STREAM_LIST(strm);
+  if (Null(l))
+    return ecl_make_fixnum(0);
+  return ecl_file_position(ECL_CONS_CAR(ecl_last(l, 1)));
+}
+
+static cl_object
+broadcast_set_position(cl_object strm, cl_object pos)
+{
+  cl_object l = BROADCAST_STREAM_LIST(strm);
+  if (Null(l))
+    return ECL_NIL;
+  return ecl_file_position_set(ECL_CONS_CAR(l), pos);
+}
+
+cl_object
+broadcast_string_length(cl_object strm, cl_object string)
+{
+  cl_object l = BROADCAST_STREAM_LIST(strm);
+  if (Null(l))
+    return ecl_make_fixnum(1);
+  return ecl_file_string_length(ECL_CONS_CAR(ecl_last(l, 1)), string);
+}
+
+static int
+broadcast_column(cl_object strm)
+{
+  cl_object l = BROADCAST_STREAM_LIST(strm);
+  if (Null(l))
+    return 0;
+  return ecl_file_column(ECL_CONS_CAR(l));
+}
+
+static cl_object
+broadcast_close(cl_object strm)
+{
+  if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) {
+    cl_mapc(2, @'close', BROADCAST_STREAM_LIST(strm));
+  }
+  return ecl_generic_close(strm);
+}
+
+const struct ecl_file_ops broadcast_ops = {
+  broadcast_write_byte8,
+  ecl_not_input_read_byte8,
+
+  broadcast_write_byte,
+  ecl_not_input_read_byte,
+
+  ecl_not_input_read_char,
+  broadcast_write_char,
+  ecl_not_input_unread_char,
+  ecl_generic_peek_char,
+
+  ecl_generic_read_vector,
+  ecl_generic_write_vector,
+
+  ecl_not_input_listen,
+  broadcast_force_output, /* clear_input */ /* FIXME! This is legacy behaviour */
+  broadcast_clear_output,
+  broadcast_finish_output,
+  broadcast_force_output,
+
+  ecl_generic_always_false, /* input_p */
+  ecl_generic_always_true, /* output_p */
+  ecl_generic_always_false,
+  broadcast_element_type,
+
+  broadcast_length,
+  broadcast_get_position,
+  broadcast_set_position,
+  broadcast_string_length,
+  broadcast_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  broadcast_close
+};
+
+@(defun make_broadcast_stream (&rest ap)
+  cl_object x, streams;
+  int i;
+@
+  streams = ECL_NIL;
+  for (i = 0; i < narg; i++) {
+    x = ecl_va_arg(ap);
+    unlikely_if (!ecl_output_stream_p(x))
+      ecl_not_an_output_stream(x);
+    streams = CONS(x, streams);
+  }
+  x = ecl_alloc_stream();
+  x->stream.format = @':default';
+  x->stream.ops = ecl_duplicate_dispatch_table(&broadcast_ops);
+  x->stream.mode = (short)ecl_smm_broadcast;
+  BROADCAST_STREAM_LIST(x) = cl_nreverse(streams);
+  @(return x);
+@)
+
+cl_object
+cl_broadcast_stream_streams(cl_object strm)
+{
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_broadcast))
+    FEwrong_type_only_arg(@[broadcast-stream-streams],
+                          strm, @[broadcast-stream]);
+  return cl_copy_list(BROADCAST_STREAM_LIST(strm));
+}
+
+/**********************************************************************
+ * ECHO STREAM
+ */
+
+static cl_index
+echo_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  cl_index out = ecl_read_byte8(ECHO_STREAM_INPUT(strm), c, n);
+  return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, out);
+}
+
+static cl_index
+echo_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  return ecl_write_byte8(ECHO_STREAM_OUTPUT(strm), c, n);
+}
+
+static void
+echo_write_byte(cl_object strm, cl_object byte)
+{
+  ecl_write_byte(byte, ECHO_STREAM_OUTPUT(strm));
+}
+
+static cl_object
+echo_read_byte(cl_object strm)
+{
+  cl_object out = ecl_read_byte(ECHO_STREAM_INPUT(strm));
+  if (!Null(out)) ecl_write_byte(out, ECHO_STREAM_OUTPUT(strm));
+  return out;
+}
+
+static ecl_character
+echo_read_char(cl_object strm)
+{
+  ecl_character c = strm->stream.last_code[0];
+  if (c == EOF) {
+    c = ecl_read_char(ECHO_STREAM_INPUT(strm));
+    if (c != EOF)
+      ecl_write_char(c, ECHO_STREAM_OUTPUT(strm));
+  } else {
+    strm->stream.last_code[0] = EOF;
+    ecl_read_char(ECHO_STREAM_INPUT(strm));
+  }
+  return c;
+}
+
+static ecl_character
+echo_write_char(cl_object strm, ecl_character c)
+{
+  return ecl_write_char(c, ECHO_STREAM_OUTPUT(strm));
+}
+
+static void
+echo_unread_char(cl_object strm, ecl_character c)
+{
+  unlikely_if (strm->stream.last_code[0] != EOF) {
+    ecl_unread_twice(strm);
+  }
+  strm->stream.last_code[0] = c;
+  ecl_unread_char(c, ECHO_STREAM_INPUT(strm));
+}
+
+static ecl_character
+echo_peek_char(cl_object strm)
+{
+  ecl_character c = strm->stream.last_code[0];
+  if (c == EOF) {
+    c = ecl_peek_char(ECHO_STREAM_INPUT(strm));
+  }
+  return c;
+}
+
+static int
+echo_listen(cl_object strm)
+{
+  return ecl_listen_stream(ECHO_STREAM_INPUT(strm));
+}
+
+static void
+echo_clear_input(cl_object strm)
+{
+  ecl_clear_input(ECHO_STREAM_INPUT(strm));
+}
+
+static void
+echo_clear_output(cl_object strm)
+{
+  ecl_clear_output(ECHO_STREAM_OUTPUT(strm));
+}
+
+static void
+echo_force_output(cl_object strm)
+{
+  ecl_force_output(ECHO_STREAM_OUTPUT(strm));
+}
+
+static void
+echo_finish_output(cl_object strm)
+{
+  ecl_finish_output(ECHO_STREAM_OUTPUT(strm));
+}
+
+static cl_object
+echo_element_type(cl_object strm)
+{
+  return ecl_stream_element_type(ECHO_STREAM_INPUT(strm));
+}
+
+static int
+echo_column(cl_object strm)
+{
+  return ecl_file_column(ECHO_STREAM_OUTPUT(strm));
+}
+
+static cl_object
+echo_close(cl_object strm)
+{
+  if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) {
+    cl_close(1, ECHO_STREAM_INPUT(strm));
+    cl_close(1, ECHO_STREAM_OUTPUT(strm));
+  }
+  return ecl_generic_close(strm);
+}
+
+const struct ecl_file_ops echo_ops = {
+  echo_write_byte8,
+  echo_read_byte8,
+
+  echo_write_byte,
+  echo_read_byte,
+
+  echo_read_char,
+  echo_write_char,
+  echo_unread_char,
+  echo_peek_char,
+
+  ecl_generic_read_vector,
+  ecl_generic_write_vector,
+
+  echo_listen,
+  echo_clear_input,
+  echo_clear_output,
+  echo_finish_output,
+  echo_force_output,
+
+  ecl_generic_always_true, /* input_p */
+  ecl_generic_always_true, /* output_p */
+  ecl_generic_always_false,
+  echo_element_type,
+
+  ecl_not_a_file_stream, /* length */
+  ecl_generic_always_nil, /* get_position */
+  ecl_generic_set_position,
+  ecl_not_file_string_length,
+  echo_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  echo_close
+};
+
+cl_object
+cl_make_echo_stream(cl_object strm1, cl_object strm2)
+{
+  cl_object strm;
+  unlikely_if (!ecl_input_stream_p(strm1))
+    ecl_not_an_input_stream(strm1);
+  unlikely_if (!ecl_output_stream_p(strm2))
+    ecl_not_an_output_stream(strm2);
+  strm = ecl_alloc_stream();
+  strm->stream.format = cl_stream_external_format(strm1);
+  strm->stream.mode = (short)ecl_smm_echo;
+  strm->stream.ops = ecl_duplicate_dispatch_table(&echo_ops);
+  ECHO_STREAM_INPUT(strm) = strm1;
+  ECHO_STREAM_OUTPUT(strm) = strm2;
+  @(return strm);
+}
+
+cl_object
+cl_echo_stream_input_stream(cl_object strm)
+{
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo))
+    FEwrong_type_only_arg(@[echo-stream-input-stream],
+                          strm, @[echo-stream]);
+  @(return ECHO_STREAM_INPUT(strm));
+}
+
+cl_object
+cl_echo_stream_output_stream(cl_object strm)
+{
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_echo))
+    FEwrong_type_only_arg(@[echo-stream-output-stream],
+                          strm, @[echo-stream]);
+  @(return ECHO_STREAM_OUTPUT(strm));
+}
+
+/**********************************************************************
+ * CONCATENATED STREAM
+ */
+
+static cl_index
+concatenated_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  cl_object l = CONCATENATED_STREAM_LIST(strm);
+  cl_index out = 0;
+  while (out < n && !Null(l)) {
+    cl_index delta = ecl_read_byte8(ECL_CONS_CAR(l), c + out, n - out);
+    out += delta;
+    if (out == n) break;
+    CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l);
+  }
+  return out;
+}
+
+static cl_object
+concatenated_read_byte(cl_object strm)
+{
+  cl_object l = CONCATENATED_STREAM_LIST(strm);
+  cl_object c = ECL_NIL;
+  while (!Null(l)) {
+    c = ecl_read_byte(ECL_CONS_CAR(l));
+    if (c != ECL_NIL) break;
+    CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l);
+  }
+  return c;
+}
+
+static ecl_character
+concatenated_read_char(cl_object strm)
+{
+  cl_object l = CONCATENATED_STREAM_LIST(strm);
+  ecl_character c = EOF;
+  while (!Null(l)) {
+    c = ecl_read_char(ECL_CONS_CAR(l));
+    if (c != EOF) break;
+    CONCATENATED_STREAM_LIST(strm) = l = ECL_CONS_CDR(l);
+  }
+  return c;
+}
+
+static void
+concatenated_unread_char(cl_object strm, ecl_character c)
+{
+  cl_object l = CONCATENATED_STREAM_LIST(strm);
+  unlikely_if (Null(l)) {
+    ecl_unread_error(strm);
+  }
+  ecl_unread_char(c, ECL_CONS_CAR(l));
+}
+
+static int
+concatenated_listen(cl_object strm)
+{
+  cl_object l = CONCATENATED_STREAM_LIST(strm);
+  while (!Null(l)) {
+    int f = ecl_listen_stream(ECL_CONS_CAR(l));
+    l = ECL_CONS_CDR(l);
+    if (f == ECL_LISTEN_EOF) {
+      CONCATENATED_STREAM_LIST(strm) = l;
+    } else {
+      return f;
+    }
+  }
+  return ECL_LISTEN_EOF;
+}
+
+static cl_object
+concatenated_close(cl_object strm)
+{
+  if (strm->stream.flags & ECL_STREAM_CLOSE_COMPONENTS) {
+    cl_mapc(2, @'close', CONCATENATED_STREAM_LIST(strm));
+  }
+  return ecl_generic_close(strm);
+}
+
+const struct ecl_file_ops concatenated_ops = {
+  ecl_not_output_write_byte8,
+  concatenated_read_byte8,
+
+  ecl_not_output_write_byte,
+  concatenated_read_byte,
+
+  concatenated_read_char,
+  ecl_not_output_write_char,
+  concatenated_unread_char,
+  ecl_generic_peek_char,
+
+  ecl_generic_read_vector,
+  ecl_generic_write_vector,
+
+  concatenated_listen,
+  ecl_generic_void, /* clear_input */
+  ecl_not_output_clear_output,
+  ecl_not_output_finish_output,
+  ecl_not_output_force_output,
+
+  ecl_generic_always_true, /* input_p */
+  ecl_generic_always_false, /* output_p */
+  ecl_generic_always_false,
+  broadcast_element_type,
+
+  ecl_not_a_file_stream, /* length */
+  ecl_generic_always_nil, /* get_position */
+  ecl_generic_set_position,
+  ecl_not_output_string_length,
+  ecl_unknown_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  concatenated_close
+};
+
+@(defun make_concatenated_stream (&rest ap)
+  cl_object x, streams;
+  int i;
+@
+  streams = ECL_NIL;
+  for (i = 0; i < narg; i++) {
+    x = ecl_va_arg(ap);
+    unlikely_if (!ecl_input_stream_p(x))
+      ecl_not_an_input_stream(x);
+    streams = CONS(x, streams);
+  }
+  x = ecl_alloc_stream();
+  if (Null(streams)) {
+    x->stream.format = @':pass-through';
+  } else {
+    x->stream.format = cl_stream_external_format(ECL_CONS_CAR(streams));
+  }
+  x->stream.mode = (short)ecl_smm_concatenated;
+  x->stream.ops = ecl_duplicate_dispatch_table(&concatenated_ops);
+  CONCATENATED_STREAM_LIST(x) = cl_nreverse(streams);
+  @(return x);
+@)
+
+cl_object
+cl_concatenated_stream_streams(cl_object strm)
+{
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_concatenated))
+    FEwrong_type_only_arg(@[concatenated-stream-streams],
+                          strm, @[concatenated-stream]);
+  return cl_copy_list(CONCATENATED_STREAM_LIST(strm));
+}
+
+/**********************************************************************
+ * SYNONYM STREAM
+ */
+
+static cl_index
+synonym_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  return ecl_read_byte8(SYNONYM_STREAM_STREAM(strm), c, n);
+}
+
+static cl_index
+synonym_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  return ecl_write_byte8(SYNONYM_STREAM_STREAM(strm), c, n);
+}
+
+static void
+synonym_write_byte(cl_object strm, cl_object byte)
+{
+  ecl_write_byte(byte, SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_object
+synonym_read_byte(cl_object strm)
+{
+  return ecl_read_byte(SYNONYM_STREAM_STREAM(strm));
+}
+
+static ecl_character
+synonym_read_char(cl_object strm)
+{
+  return ecl_read_char(SYNONYM_STREAM_STREAM(strm));
+}
+
+static ecl_character
+synonym_write_char(cl_object strm, ecl_character c)
+{
+  return ecl_write_char(c, SYNONYM_STREAM_STREAM(strm));
+}
+
+static void
+synonym_unread_char(cl_object strm, ecl_character c)
+{
+  ecl_unread_char(c, SYNONYM_STREAM_STREAM(strm));
+}
+
+static ecl_character
+synonym_peek_char(cl_object strm)
+{
+  return ecl_peek_char(SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_index
+synonym_read_vector(cl_object strm, cl_object data, cl_index start, cl_index n)
+{
+  strm = SYNONYM_STREAM_STREAM(strm);
+  return ecl_stream_dispatch_table(strm)->read_vector(strm, data, start, n);
+}
+
+static cl_index
+synonym_write_vector(cl_object strm, cl_object data, cl_index start, cl_index n)
+{
+  strm = SYNONYM_STREAM_STREAM(strm);
+  return ecl_stream_dispatch_table(strm)->write_vector(strm, data, start, n);
+}
+
+static int
+synonym_listen(cl_object strm)
+{
+  return ecl_listen_stream(SYNONYM_STREAM_STREAM(strm));
+}
+
+static void
+synonym_clear_input(cl_object strm)
+{
+  ecl_clear_input(SYNONYM_STREAM_STREAM(strm));
+}
+
+static void
+synonym_clear_output(cl_object strm)
+{
+  ecl_clear_output(SYNONYM_STREAM_STREAM(strm));
+}
+
+static void
+synonym_force_output(cl_object strm)
+{
+  ecl_force_output(SYNONYM_STREAM_STREAM(strm));
+}
+
+static void
+synonym_finish_output(cl_object strm)
+{
+  ecl_finish_output(SYNONYM_STREAM_STREAM(strm));
+}
+
+static int
+synonym_input_p(cl_object strm)
+{
+  return ecl_input_stream_p(SYNONYM_STREAM_STREAM(strm));
+}
+
+static int
+synonym_output_p(cl_object strm)
+{
+  return ecl_output_stream_p(SYNONYM_STREAM_STREAM(strm));
+}
+
+static int
+synonym_interactive_p(cl_object strm)
+{
+  return ecl_interactive_stream_p(SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_object
+synonym_element_type(cl_object strm)
+{
+  return ecl_stream_element_type(SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_object
+synonym_length(cl_object strm)
+{
+  return ecl_file_length(SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_object
+synonym_get_position(cl_object strm)
+{
+  return ecl_file_position(SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_object
+synonym_set_position(cl_object strm, cl_object pos)
+{
+  return ecl_file_position_set(SYNONYM_STREAM_STREAM(strm), pos);
+}
+
+static cl_object
+synonym_string_length(cl_object strm, cl_object string)
+{
+  return ecl_file_string_length(SYNONYM_STREAM_STREAM(strm), string);
+}
+
+static int
+synonym_column(cl_object strm)
+{
+  return ecl_file_column(SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_object
+synonym_pathname(cl_object strm)
+{
+  return ecl_stream_pathname(SYNONYM_STREAM_STREAM(strm));
+}
+
+static cl_object
+synonym_truename(cl_object strm)
+{
+  return ecl_stream_truename(SYNONYM_STREAM_STREAM(strm));
+}
+
+const struct ecl_file_ops synonym_ops = {
+  synonym_write_byte8,
+  synonym_read_byte8,
+
+  synonym_write_byte,
+  synonym_read_byte,
+
+  synonym_read_char,
+  synonym_write_char,
+  synonym_unread_char,
+  synonym_peek_char,
+
+  synonym_read_vector,
+  synonym_write_vector,
+
+  synonym_listen,
+  synonym_clear_input,
+  synonym_clear_output,
+  synonym_finish_output,
+  synonym_force_output,
+
+  synonym_input_p,
+  synonym_output_p,
+  synonym_interactive_p,
+  synonym_element_type,
+
+  synonym_length,
+  synonym_get_position,
+  synonym_set_position,
+  synonym_string_length,
+  synonym_column,
+
+  synonym_pathname,
+  synonym_truename,
+
+  ecl_generic_close
+};
+
+cl_object
+cl_make_synonym_stream(cl_object sym)
+{
+  cl_object x;
+
+  sym = ecl_check_cl_type(@'make-synonym-stream',sym,t_symbol);
+  x = ecl_alloc_stream();
+  x->stream.ops = ecl_duplicate_dispatch_table(&synonym_ops);
+  x->stream.mode = (short)ecl_smm_synonym;
+  SYNONYM_STREAM_SYMBOL(x) = sym;
+  @(return x);
+}
+
+cl_object
+cl_synonym_stream_symbol(cl_object strm)
+{
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_synonym))
+    FEwrong_type_only_arg(@[synonym-stream-symbol],
+                          strm, @[synonym-stream]);
+  @(return SYNONYM_STREAM_SYMBOL(strm));
+}

src/c/streams/strm_eformat.d

@@ -0,0 +1,987 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/*
+ * strm_eformat.d - External formats encoding/decoding for streams
+ *
+ * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
+ * Copyright (c) 1990 Giuseppe Attardi
+ * Copyright (c) 2001 Juan Jose Garcia Ripoll
+ * Copyright (c) 2025 Daniel Kochmanski
+ *
+ * See file 'LICENSE' for the copyright details.
+ *
+ */
+
+#include <ecl/ecl.h>
+#include <ecl/internal.h>
+
+/* -- errors ---------------------------------------------------------------- */
+
+#ifdef ECL_UNICODE
+static cl_index
+encoding_error(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  cl_object code = _ecl_funcall4(@'ext::encoding-error', stream,
+                                 cl_stream_external_format(stream),
+                                 ecl_make_integer(c));
+  if (Null(code)) {
+    /* Output nothing */
+    return 0;
+  } else {
+    /* Try with supplied character */
+    return stream->stream.encoder(stream, buffer, ecl_char_code(code));
+  }
+}
+
+static ecl_character
+decoding_error(cl_object stream, unsigned char **buffer, int char_length, unsigned char *buffer_end)
+{
+  cl_object octets = ECL_NIL, code;
+  for (; char_length > 0; char_length--) {
+    octets = CONS(ecl_make_fixnum(*((*buffer)++)), octets);
+  }
+  code = _ecl_funcall4(@'ext::decoding-error', stream,
+                       cl_stream_external_format(stream),
+                       octets);
+  if (Null(code)) {
+    /* Go for next character */
+    return stream->stream.decoder(stream, buffer, buffer_end);
+  } else {
+    /* Return supplied character */
+    return ecl_char_code(code);
+  }
+}
+#endif
+
+/**********************************************************************
+ * CHARACTER AND EXTERNAL FORMAT SUPPORT
+ */
+
+ecl_character
+ecl_eformat_read_char(cl_object strm)
+{
+  unsigned char buffer[ENCODING_BUFFER_MAX_SIZE];
+  ecl_character c;
+  unsigned char *buffer_pos = buffer;
+  unsigned char *buffer_end = buffer;
+  cl_index byte_size = (strm->stream.byte_size / 8);
+  do {
+    if (ecl_read_byte8(strm, buffer_end, byte_size) < byte_size) {
+      c = EOF;
+      break;
+    }
+    buffer_end += byte_size;
+    c = strm->stream.decoder(strm, &buffer_pos, buffer_end);
+  } while(c == EOF && (buffer_end - buffer) < ENCODING_BUFFER_MAX_SIZE);
+  unlikely_if (c == strm->stream.eof_char)
+    return EOF;
+  if (c != EOF) {
+    strm->stream.last_char = c;
+    strm->stream.last_code[0] = c;
+    strm->stream.last_code[1] = EOF;
+  }
+  return c;
+}
+
+void
+ecl_eformat_unread_char(cl_object strm, ecl_character c)
+{
+  unlikely_if (c != strm->stream.last_char) {
+    ecl_unread_twice(strm);
+  }
+  {
+    unsigned char buffer[2*ENCODING_BUFFER_MAX_SIZE];
+    int ndx = 0;
+    cl_object l = strm->stream.byte_stack;
+    cl_fixnum i = strm->stream.last_code[0];
+    if (i != EOF) {
+      ndx += strm->stream.encoder(strm, buffer, i);
+    }
+    i = strm->stream.last_code[1];
+    if (i != EOF) {
+      ndx += strm->stream.encoder(strm, buffer+ndx, i);
+    }
+    while (ndx != 0) {
+      l = CONS(ecl_make_fixnum(buffer[--ndx]), l);
+    }
+    strm->stream.byte_stack = l;
+    strm->stream.last_char = EOF;
+  }
+}
+
+ecl_character
+ecl_eformat_write_char(cl_object strm, ecl_character c)
+{
+  unsigned char buffer[ENCODING_BUFFER_MAX_SIZE];
+  ecl_character nbytes;
+  nbytes = strm->stream.encoder(strm, buffer, c);
+  strm->stream.ops->write_byte8(strm, buffer, nbytes);
+  write_char_increment_column(strm, c);
+  return c;
+}
+
+static ecl_character
+eformat_read_char_cr(cl_object strm)
+{
+  ecl_character c = ecl_eformat_read_char(strm);
+  if (c == ECL_CHAR_CODE_RETURN) {
+    c = ECL_CHAR_CODE_NEWLINE;
+    strm->stream.last_char = c;
+  }
+  return c;
+}
+
+static ecl_character
+eformat_write_char_cr(cl_object strm, ecl_character c)
+{
+  if (c == ECL_CHAR_CODE_NEWLINE) {
+    ecl_eformat_write_char(strm, ECL_CHAR_CODE_RETURN);
+    strm->stream.column = 0;
+    return c;
+  }
+  return ecl_eformat_write_char(strm, c);
+}
+
+static ecl_character
+eformat_read_char_crlf(cl_object strm)
+{
+  ecl_character c = ecl_eformat_read_char(strm);
+  if (c == ECL_CHAR_CODE_RETURN) {
+    c = ecl_eformat_read_char(strm);
+    if (c == ECL_CHAR_CODE_LINEFEED) {
+      strm->stream.last_code[0] = ECL_CHAR_CODE_RETURN;
+      strm->stream.last_code[1] = c;
+      c = ECL_CHAR_CODE_NEWLINE;
+    } else {
+      ecl_eformat_unread_char(strm, c);
+      c = ECL_CHAR_CODE_RETURN;
+      strm->stream.last_code[0] = c;
+      strm->stream.last_code[1] = EOF;
+    }
+    strm->stream.last_char = c;
+  }
+  return c;
+}
+
+static ecl_character
+eformat_write_char_crlf(cl_object strm, ecl_character c)
+{
+  if (c == ECL_CHAR_CODE_NEWLINE) {
+    ecl_eformat_write_char(strm, ECL_CHAR_CODE_RETURN);
+    ecl_eformat_write_char(strm, ECL_CHAR_CODE_LINEFEED);
+    strm->stream.column = 0;
+    return c;
+  }
+  return ecl_eformat_write_char(strm, c);
+}
+
+/*
+ * If we use Unicode, this is LATIN-1, ISO-8859-1, that is the 256
+ * lowest codes of Unicode. Otherwise, we simply assume the file and
+ * the strings use the same format.
+ */
+
+static ecl_character
+passthrough_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  if (*buffer >= buffer_end)
+    return EOF;
+  return *((*buffer)++);
+}
+
+static int
+passthrough_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+#ifdef ECL_UNICODE
+  unlikely_if (c > 0xFF) {
+    return encoding_error(stream, buffer, c);
+  }
+#endif
+  buffer[0] = c;
+  return 1;
+}
+
+#ifdef ECL_UNICODE
+/*
+ * US ASCII, that is the 128 (0-127) lowest codes of Unicode
+ */
+
+static ecl_character
+ascii_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  if (*buffer >= buffer_end)
+    return EOF;
+  if (**buffer > 127) {
+    return decoding_error(stream, buffer, 1, buffer_end);
+  } else {
+    return *((*buffer)++);
+  }
+}
+
+static int
+ascii_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  unlikely_if (c > 127) {
+    return encoding_error(stream, buffer, c);
+  }
+  buffer[0] = c;
+  return 1;
+}
+
+/*
+ * UCS-4 BIG ENDIAN
+ */
+
+static ecl_character
+ucs_4be_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  ecl_character aux;
+  if ((*buffer)+3 >= buffer_end)
+    return EOF;
+  aux = (*buffer)[3]+((*buffer)[2]<<8)+((*buffer)[1]<<16)+((*buffer)[0]<<24);
+  *buffer += 4;
+  return aux;
+}
+
+static int
+ucs_4be_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  buffer[3] = c & 0xFF; c >>= 8;
+  buffer[2] = c & 0xFF; c >>= 8;
+  buffer[1] = c & 0xFF; c >>= 8;
+  buffer[0] = c;
+  return 4;
+}
+
+/*
+ * UCS-4 LITTLE ENDIAN
+ */
+
+static ecl_character
+ucs_4le_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  ecl_character aux;
+  if ((*buffer)+3 >= buffer_end)
+    return EOF;
+  aux = (*buffer)[0]+((*buffer)[1]<<8)+((*buffer)[2]<<16)+((*buffer)[3]<<24);
+  *buffer += 4;
+  return aux;
+}
+
+static int
+ucs_4le_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  buffer[0] = c & 0xFF; c >>= 8;
+  buffer[1] = c & 0xFF; c >>= 8;
+  buffer[2] = c & 0xFF; c >>= 8;
+  buffer[3] = c;
+  return 4;
+}
+
+/*
+ * UCS-4 BOM ENDIAN
+ */
+
+static ecl_character
+ucs_4_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  cl_fixnum c = ucs_4be_decoder(stream, buffer, buffer_end);
+  if (c == EOF)
+    return c;
+  if (c == 0xFEFF) {
+    stream->stream.decoder = ucs_4be_decoder;
+    stream->stream.encoder = ucs_4be_encoder;
+    return ucs_4be_decoder(stream, buffer, buffer_end);
+  } else if (c == 0xFFFE0000) {
+    stream->stream.decoder = ucs_4le_decoder;
+    stream->stream.encoder = ucs_4le_encoder;
+    return ucs_4le_decoder(stream, buffer, buffer_end);
+  } else {
+    stream->stream.decoder = ucs_4be_decoder;
+    stream->stream.encoder = ucs_4be_encoder;
+    return c;
+  }
+}
+
+static int
+ucs_4_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  stream->stream.decoder = ucs_4be_decoder;
+  stream->stream.encoder = ucs_4be_encoder;
+  buffer[0] = buffer[1] = 0;
+  buffer[2] = 0xFE;
+  buffer[3] = 0xFF;
+  return 4 + ucs_4be_encoder(stream, buffer+4, c);
+}
+
+
+/*
+ * UTF-16 BIG ENDIAN
+ */
+
+static ecl_character
+ucs_2be_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  if ((*buffer)+1 >= buffer_end) {
+    return EOF;
+  } else {
+    ecl_character c = ((ecl_character)(*buffer)[0] << 8) | (*buffer)[1];
+    if (((*buffer)[0] & 0xFC) == 0xD8) {
+      if ((*buffer)+3 >= buffer_end) {
+        return EOF;
+      } else {
+        ecl_character aux;
+        if (((*buffer)[2] & 0xFC) != 0xDC) {
+          return decoding_error(stream, buffer, 4, buffer_end);
+        }
+        aux = ((ecl_character)(*buffer)[2] << 8) | (*buffer)[3];
+        *buffer += 4;
+        return ((c & 0x3FF) << 10) + (aux & 0x3FF) + 0x10000;
+      }
+    }
+    *buffer += 2;
+    return c;
+  }
+}
+
+static int
+ucs_2be_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  if (c >= 0x10000) {
+    c -= 0x10000;
+    ucs_2be_encoder(stream, buffer, (c >> 10) | 0xD800);
+    ucs_2be_encoder(stream, buffer+2, (c & 0x3FF) | 0xDC00);
+    return 4;
+  } else {
+    buffer[1] = c & 0xFF; c >>= 8;
+    buffer[0] = c;
+    return 2;
+  }
+}
+
+/*
+ * UTF-16 LITTLE ENDIAN
+ */
+
+static ecl_character
+ucs_2le_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  if ((*buffer)+1 >= buffer_end) {
+    return EOF;
+  } else {
+    ecl_character c = ((ecl_character)(*buffer)[1] << 8) | (*buffer)[0];
+    if (((*buffer)[1] & 0xFC) == 0xD8) {
+      if ((*buffer)+3 >= buffer_end) {
+        return EOF;
+      } else {
+        ecl_character aux;
+        if (((*buffer)[3] & 0xFC) != 0xDC) {
+          return decoding_error(stream, buffer, 4, buffer_end);
+        }
+        aux = ((ecl_character)(*buffer)[3] << 8) | (*buffer)[2];
+        *buffer += 4;
+        return ((c & 0x3FF) << 10) + (aux & 0x3FF) + 0x10000;
+      }
+    }
+    *buffer += 2;
+    return c;
+  }
+}
+
+static int
+ucs_2le_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  if (c >= 0x10000) {
+    c -= 0x10000;
+    ucs_2le_encoder(stream, buffer, (c >> 10) | 0xD800);
+    ucs_2le_encoder(stream, buffer+2, (c & 0x3FF) | 0xDC00);
+    return 4;
+  } else {
+    buffer[0] = c & 0xFF; c >>= 8;
+    buffer[1] = c & 0xFF;
+    return 2;
+  }
+}
+
+/*
+ * UTF-16 BOM ENDIAN
+ */
+
+static ecl_character
+ucs_2_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  ecl_character c = ucs_2be_decoder(stream, buffer, buffer_end);
+  if (c == EOF)
+    return c;
+  if (c == 0xFEFF) {
+    stream->stream.decoder = ucs_2be_decoder;
+    stream->stream.encoder = ucs_2be_encoder;
+    return ucs_2be_decoder(stream, buffer, buffer_end);
+  } else if (c == 0xFFFE) {
+    stream->stream.decoder = ucs_2le_decoder;
+    stream->stream.encoder = ucs_2le_encoder;
+    return ucs_2le_decoder(stream, buffer, buffer_end);
+  } else {
+    stream->stream.decoder = ucs_2be_decoder;
+    stream->stream.encoder = ucs_2be_encoder;
+    return c;
+  }
+}
+
+static int
+ucs_2_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  stream->stream.decoder = ucs_2be_decoder;
+  stream->stream.encoder = ucs_2be_encoder;
+  buffer[0] = 0xFE;
+  buffer[1] = 0xFF;
+  return 2 + ucs_2be_encoder(stream, buffer+2, c);
+}
+
+/*
+ * USER DEFINED ENCODINGS. SIMPLE CASE.
+ */
+
+static ecl_character
+user_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  cl_object table = stream->stream.format_table;
+  cl_object character;
+  if (*buffer >= buffer_end) {
+    return EOF;
+  }
+  character = ecl_gethash_safe(ecl_make_fixnum((*buffer)[0]), table, ECL_NIL);
+  unlikely_if (Null(character)) {
+    return decoding_error(stream, buffer, 1, buffer_end);
+  }
+  if (character == ECL_T) {
+    if ((*buffer)+1 >= buffer_end) {
+      return EOF;
+    } else {
+      cl_fixnum byte = ((*buffer)[0]<<8) + (*buffer)[1];
+      character = ecl_gethash_safe(ecl_make_fixnum(byte), table, ECL_NIL);
+      unlikely_if (Null(character)) {
+        return decoding_error(stream, buffer, 2, buffer_end);
+      }
+    }
+    (*buffer)++;
+  }
+  (*buffer)++;
+  return ECL_CHAR_CODE(character);
+}
+
+static int
+user_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), stream->stream.format_table, ECL_NIL);
+  if (Null(byte)) {
+    return encoding_error(stream, buffer, c);
+  } else {
+    cl_fixnum code = ecl_fixnum(byte);
+    if (code > 0xFF) {
+      buffer[1] = code & 0xFF; code >>= 8;
+      buffer[0] = code;
+      return 2;
+    } else {
+      buffer[0] = code;
+      return 1;
+    }
+  }
+}
+
+/*
+ * USER DEFINED ENCODINGS. SIMPLE CASE.
+ */
+
+static ecl_character
+user_multistate_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  cl_object table_list = stream->stream.format_table;
+  cl_object table = ECL_CONS_CAR(table_list);
+  cl_object character;
+  cl_fixnum i, j;
+  for (i = j = 0; i < ENCODING_BUFFER_MAX_SIZE; ) {
+    if ((*buffer)+i >= buffer_end) {
+      return EOF;
+    }
+    j = (j << 8) | (*buffer)[i];
+    character = ecl_gethash_safe(ecl_make_fixnum(j), table, ECL_NIL);
+    if (ECL_CHARACTERP(character)) {
+      *buffer += i+1;
+      return ECL_CHAR_CODE(character);
+    }
+    unlikely_if (Null(character)) {
+      return decoding_error(stream, buffer, i+1, buffer_end);
+    }
+    if (character == ECL_T) {
+      /* Need more characters */
+      i++;
+      continue;
+    }
+    if (CONSP(character)) {
+      /* Changed the state. */
+      stream->stream.format_table = table_list = character;
+      table = ECL_CONS_CAR(table_list);
+      *buffer += i+1;
+      i = j = 0;
+      continue;
+    }
+    break;
+  }
+  FEerror("Internal error in decoder table.", 0);
+}
+
+static int
+user_multistate_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  cl_object table_list = stream->stream.format_table;
+  cl_object p = table_list;
+  do {
+    cl_object table = ECL_CONS_CAR(p);
+    cl_object byte = ecl_gethash_safe(ECL_CODE_CHAR(c), table, ECL_NIL);
+    if (!Null(byte)) {
+      cl_fixnum code = ecl_fixnum(byte);
+      ecl_character n = 0;
+      if (p != table_list) {
+        /* Must output a escape sequence */
+        cl_object x = ecl_gethash_safe(ECL_T, table, ECL_NIL);
+        while (!Null(x)) {
+          buffer[0] = ecl_fixnum(ECL_CONS_CAR(x));
+          buffer++;
+          x = ECL_CONS_CDR(x);
+          n++;
+        }
+        stream->stream.format_table = p;
+      }
+      if (code > 0xFF) {
+        buffer[1] = code & 0xFF; code >>= 8;
+        buffer[0] = code;
+        return n+2;
+      } else {
+        buffer[0] = code;
+        return n+1;
+      }
+    }
+    p = ECL_CONS_CDR(p);
+  } while (p != table_list);
+  /* Exhausted all lists */
+  return encoding_error(stream, buffer, c);
+}
+
+/*
+ * UTF-8
+ */
+
+static ecl_character
+utf_8_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end)
+{
+  /* In understanding this code:
+   * 0x8 = 1000, 0xC = 1100, 0xE = 1110, 0xF = 1111
+   * 0x1 = 0001, 0x3 = 0011, 0x7 = 0111, 0xF = 1111
+   */
+  ecl_character cum = 0;
+  int nbytes, i;
+  unsigned char aux;
+  if (*buffer >= buffer_end)
+    return EOF;
+  aux = (*buffer)[0];
+  if ((aux & 0x80) == 0) {
+    (*buffer)++;
+    return aux;
+  }
+  unlikely_if ((aux & 0x40) == 0) {
+    return decoding_error(stream, buffer, 1, buffer_end);
+  }
+  if ((aux & 0x20) == 0) {
+    cum = aux & 0x1F;
+    nbytes = 1;
+  } else if ((aux & 0x10) == 0) {
+    cum = aux & 0x0F;
+    nbytes = 2;
+  } else if ((aux & 0x08) == 0) {
+    cum = aux & 0x07;
+    nbytes = 3;
+  } else {
+    return decoding_error(stream, buffer, 1, buffer_end);
+  }
+  if ((*buffer)+nbytes >= buffer_end)
+    return EOF;
+  for (i = 1; i <= nbytes; i++) {
+    unsigned char c = (*buffer)[i];
+    unlikely_if ((c & 0xC0) != 0x80) {
+      return decoding_error(stream, buffer, nbytes+1, buffer_end);
+    }
+    cum = (cum << 6) | (c & 0x3F);
+    unlikely_if (cum == 0) {
+      return decoding_error(stream, buffer, nbytes+1, buffer_end);
+    }
+  }
+  if (cum >= 0xd800) {
+    unlikely_if (cum <= 0xdfff) {
+      return decoding_error(stream, buffer, nbytes+1, buffer_end);
+    }
+    unlikely_if (cum >= 0xFFFE && cum <= 0xFFFF) {
+      return decoding_error(stream, buffer, nbytes+1, buffer_end);
+    }
+  }
+  *buffer += nbytes+1;
+  return cum;
+}
+
+static int
+utf_8_encoder(cl_object stream, unsigned char *buffer, ecl_character c)
+{
+  int nbytes = 0;
+  if (c <= 0x7F) {
+    buffer[0] = c;
+    nbytes = 1;
+  } else if (c <= 0x7ff) {
+    buffer[1] = (c & 0x3f) | 0x80; c >>= 6;
+    buffer[0] = c | 0xC0;
+    /*printf("\n; %04x ;: %04x :: %04x :\n", c_orig, buffer[0], buffer[1]);*/
+    nbytes = 2;
+  } else if (c <= 0xFFFF) {
+    buffer[2] = (c & 0x3f) | 0x80; c >>= 6;
+    buffer[1] = (c & 0x3f) | 0x80; c >>= 6;
+    buffer[0] = c | 0xE0;
+    nbytes = 3;
+  } else if (c <= 0x1FFFFFL) {
+    buffer[3] = (c & 0x3f) | 0x80; c >>= 6;
+    buffer[2] = (c & 0x3f) | 0x80; c >>= 6;
+    buffer[1] = (c & 0x3f) | 0x80; c >>= 6;
+    buffer[0] = c | 0xF0;
+    nbytes = 4;
+  }
+  return nbytes;
+}
+#endif
+
+static int
+parse_external_format(cl_object stream, cl_object format, int flags)
+{
+  if (format == @':default') {
+    format = ecl_symbol_value(@'ext::*default-external-format*');
+  }
+  if (CONSP(format)) {
+    flags = parse_external_format(stream, ECL_CONS_CDR(format), flags);
+    format = ECL_CONS_CAR(format);
+  }
+  if (format == ECL_T) {
+#ifdef ECL_UNICODE
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8;
+#else
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT;
+#endif
+  }
+  if (format == ECL_NIL) {
+    return flags;
+  }
+  if (format == @':CR') {
+    return (flags | ECL_STREAM_CR) & ~ECL_STREAM_LF;
+  }
+  if (format == @':LF') {
+    return (flags | ECL_STREAM_LF) & ~ECL_STREAM_CR;
+  }
+  if (format == @':CRLF') {
+    return flags | (ECL_STREAM_CR+ECL_STREAM_LF);
+  }
+  if (format == @':LITTLE-ENDIAN') {
+    return flags | ECL_STREAM_LITTLE_ENDIAN;
+  }
+  if (format == @':BIG-ENDIAN') {
+    return flags & ~ECL_STREAM_LITTLE_ENDIAN;
+  }
+  if (format == @':pass-through') {
+#ifdef ECL_UNICODE
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1;
+#else
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_DEFAULT_FORMAT;
+#endif
+  }
+#ifdef ECL_UNICODE
+ PARSE_SYMBOLS:
+  if (format == @':UTF-8') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UTF_8; 
+  }
+  if (format == @':UCS-2') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2;
+  }
+  if (format == @':UCS-2BE') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2BE;
+  }
+  if (format == @':UCS-2LE') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_2LE;
+  }
+  if (format == @':UCS-4') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4;
+  }
+  if (format == @':UCS-4BE') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4BE;
+  }
+  if (format == @':UCS-4LE') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_UCS_4LE;
+  }
+  if (format == @':ISO-8859-1') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_ISO_8859_1;
+  }
+  if (format == @':LATIN-1') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_LATIN_1;
+  }
+  if (format == @':US-ASCII') {
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_US_ASCII; 
+  }
+  if (ECL_HASH_TABLE_P(format)) {
+    stream->stream.format_table = format;
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT;
+  }
+  if (ECL_SYMBOLP(format)) {
+    format = _ecl_funcall2(@'ext::make-encoding', format);
+    if (ECL_SYMBOLP(format))
+      goto PARSE_SYMBOLS;
+    stream->stream.format_table = format;
+    return (flags & ~ECL_STREAM_FORMAT) | ECL_STREAM_USER_FORMAT;
+  }
+#endif
+  FEerror("Unknown or unsupported external format: ~A", 1, format);
+  return ECL_STREAM_DEFAULT_FORMAT;
+}
+
+void
+ecl_set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags,
+                        cl_object external_format)
+{
+  cl_object t;
+  if (byte_size < 0) {
+    byte_size = -byte_size;
+    flags |= ECL_STREAM_SIGNED_BYTES;
+    t = @'signed-byte';
+  } else {
+    flags &= ~ECL_STREAM_SIGNED_BYTES;
+    t = @'unsigned-byte';
+  }
+  if (external_format != ECL_NIL) {
+    flags = parse_external_format(stream, external_format, flags);
+  }
+  stream->stream.ops->read_char = ecl_eformat_read_char;
+  stream->stream.ops->write_char = ecl_eformat_write_char;
+  switch (flags & ECL_STREAM_FORMAT) {
+  case ECL_STREAM_BINARY:
+    IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, ecl_make_fixnum(byte_size));
+    stream->stream.format = t;
+    stream->stream.ops->read_char = ecl_not_character_read_char;
+    stream->stream.ops->write_char = ecl_not_character_write_char;
+    stream->stream.decoder = ecl_not_character_decoder;
+    stream->stream.encoder = ecl_not_character_encoder;
+    break;
+#ifdef ECL_UNICODE
+    /*case ECL_ISO_8859_1:*/
+  case ECL_STREAM_LATIN_1:
+    IO_STREAM_ELT_TYPE(stream) = @'base-char';
+    byte_size = 8;
+    stream->stream.format = @':latin-1';
+    stream->stream.encoder = passthrough_encoder;
+    stream->stream.decoder = passthrough_decoder;
+    break;
+  case ECL_STREAM_UTF_8:
+    IO_STREAM_ELT_TYPE(stream) = @'character';
+    byte_size = 8;
+    stream->stream.format = @':utf-8';
+    stream->stream.encoder = utf_8_encoder;
+    stream->stream.decoder = utf_8_decoder;
+    break;
+  case ECL_STREAM_UCS_2:
+    IO_STREAM_ELT_TYPE(stream) = @'character';
+    byte_size = 8*2;
+    stream->stream.format = @':ucs-2';
+    stream->stream.encoder = ucs_2_encoder;
+    stream->stream.decoder = ucs_2_decoder;
+    break;
+  case ECL_STREAM_UCS_2BE:
+    IO_STREAM_ELT_TYPE(stream) = @'character';
+    byte_size = 8*2;
+    if (flags & ECL_STREAM_LITTLE_ENDIAN) {
+      stream->stream.format = @':ucs-2le';
+      stream->stream.encoder = ucs_2le_encoder;
+      stream->stream.decoder = ucs_2le_decoder;
+    } else {
+      stream->stream.format = @':ucs-2be';
+      stream->stream.encoder = ucs_2be_encoder;
+      stream->stream.decoder = ucs_2be_decoder;
+    }
+    break;
+  case ECL_STREAM_UCS_4:
+    IO_STREAM_ELT_TYPE(stream) = @'character';
+    byte_size = 8*4;
+    stream->stream.format = @':ucs-4be';
+    stream->stream.encoder = ucs_4_encoder;
+    stream->stream.decoder = ucs_4_decoder;
+    break;
+  case ECL_STREAM_UCS_4BE:
+    IO_STREAM_ELT_TYPE(stream) = @'character';
+    byte_size = 8*4;
+    if (flags & ECL_STREAM_LITTLE_ENDIAN) {
+      stream->stream.format = @':ucs-4le';
+      stream->stream.encoder = ucs_4le_encoder;
+      stream->stream.decoder = ucs_4le_decoder;
+    } else {
+      stream->stream.format = @':ucs-4be';
+      stream->stream.encoder = ucs_4be_encoder;
+      stream->stream.decoder = ucs_4be_decoder;
+    }
+    break;
+  case ECL_STREAM_USER_FORMAT:
+    IO_STREAM_ELT_TYPE(stream) = @'character';
+    byte_size = 8;
+    stream->stream.format = stream->stream.format_table;
+    if (CONSP(stream->stream.format)) {
+      stream->stream.encoder = user_multistate_encoder;
+      stream->stream.decoder = user_multistate_decoder;
+    } else {
+      stream->stream.encoder = user_encoder;
+      stream->stream.decoder = user_decoder;
+    }
+    break;
+  case ECL_STREAM_US_ASCII:
+    IO_STREAM_ELT_TYPE(stream) = @'base-char';
+    byte_size = 8;
+    stream->stream.format = @':us-ascii';
+    stream->stream.encoder = ascii_encoder;
+    stream->stream.decoder = ascii_decoder;
+    break;
+#else
+  case ECL_STREAM_DEFAULT_FORMAT:
+    IO_STREAM_ELT_TYPE(stream) = @'base-char';
+    byte_size = 8;
+    stream->stream.format = @':pass-through';
+    stream->stream.encoder = passthrough_encoder;
+    stream->stream.decoder = passthrough_decoder;
+    break;
+#endif
+  default:
+    FEerror("Invalid or unsupported external format ~A with code ~D",
+            2, external_format, ecl_make_fixnum(flags));
+  }
+  t = @':LF';
+  if (stream->stream.ops->write_char == ecl_eformat_write_char &&
+      (flags & ECL_STREAM_CR)) {
+    if (flags & ECL_STREAM_LF) {
+      stream->stream.ops->read_char = eformat_read_char_crlf;
+      stream->stream.ops->write_char = eformat_write_char_crlf;
+      t = @':CRLF';
+    } else {
+      stream->stream.ops->read_char = eformat_read_char_cr;
+      stream->stream.ops->write_char = eformat_write_char_cr;
+      t = @':CR';
+    }
+  }
+  stream->stream.format = cl_list(2, stream->stream.format, t);
+  {
+    cl_object (*read_byte)(cl_object);
+    void (*write_byte)(cl_object,cl_object);
+    byte_size = (byte_size+7)&(~(cl_fixnum)7);
+    if (byte_size == 8) {
+      if (flags & ECL_STREAM_SIGNED_BYTES) {
+        read_byte = ecl_generic_read_byte_signed8;
+        write_byte = ecl_generic_write_byte_signed8;
+      } else {
+        read_byte = ecl_generic_read_byte_unsigned8;
+        write_byte = ecl_generic_write_byte_unsigned8;
+      }
+    } else if (flags & ECL_STREAM_LITTLE_ENDIAN) {
+      read_byte = ecl_generic_read_byte_le;
+      write_byte = ecl_generic_write_byte_le;
+    } else {
+      read_byte = ecl_generic_read_byte;
+      write_byte = ecl_generic_write_byte;
+    }
+    if (ecl_input_stream_p(stream)) {
+      stream->stream.ops->read_byte = read_byte;
+    }
+    if (ecl_output_stream_p(stream)) {
+      stream->stream.ops->write_byte = write_byte;
+    }
+  }
+  stream->stream.flags = flags;
+  stream->stream.byte_size = byte_size;
+}
+
+cl_object
+si_stream_external_format_set(cl_object stream, cl_object format)
+{
+#ifdef ECL_CLOS_STREAMS
+  unlikely_if (ECL_INSTANCEP(stream)) {
+    FEerror("Cannot change external format of stream ~A", 1, stream);
+  }
+#endif
+  switch (stream->stream.mode) {
+  case ecl_smm_input:
+  case ecl_smm_input_file:
+  case ecl_smm_output:
+  case ecl_smm_output_file:
+  case ecl_smm_io:
+  case ecl_smm_io_file:
+#ifdef ECL_WSOCK
+  case ecl_smm_input_wsock:
+  case ecl_smm_output_wsock:
+  case ecl_smm_io_wsock:
+  case ecl_smm_io_wcon:
+#endif
+    {
+      cl_object elt_type = ecl_stream_element_type(stream);
+      unlikely_if (elt_type != @'character' && elt_type != @'base-char') {
+        FEerror("Cannot change external format of binary stream ~A", 1, stream);
+      }
+      ecl_set_stream_elt_type(stream, stream->stream.byte_size, stream->stream.flags, format);
+    }
+    break;
+  default:
+    FEerror("Cannot change external format of stream ~A", 1, stream);
+  }
+  @(return);
+}
+
+static cl_index
+compute_char_size(cl_object stream, ecl_character c)
+{
+  unsigned char buffer[5];
+  int l = 0;
+  if (c == ECL_CHAR_CODE_NEWLINE) {
+    int flags = stream->stream.flags;
+    if (flags & ECL_STREAM_CR) {
+      l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_RETURN);
+      if (flags & ECL_STREAM_LF)
+        l += stream->stream.encoder(stream, buffer,
+                                    ECL_CHAR_CODE_LINEFEED);
+    } else {
+      l += stream->stream.encoder(stream, buffer, ECL_CHAR_CODE_LINEFEED);
+    }
+  } else {
+    l += stream->stream.encoder(stream, buffer, c);
+  }
+  return l;
+}
+
+cl_object
+ecl_eformat_file_string_length(cl_object stream, cl_object string)
+{
+  cl_fixnum l = 0;
+  switch (ecl_t_of(string)) {
+#ifdef ECL_UNICODE
+  case t_string:
+#endif
+  case t_base_string: {
+    cl_index i;
+    for (i = 0; i < string->base_string.fillp; i++) {
+      l += compute_char_size(stream, ecl_char(string, i));
+    }
+    break;
+  }
+  case t_character:
+    l = compute_char_size(stream, ECL_CHAR_CODE(string));
+    break;
+  default:
+    FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]);
+  }
+  return ecl_make_fixnum(l);
+}

src/c/streams/strm_sequence.d

@@ -0,0 +1,594 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/*
+ * strm_sequence.d - Sequence Stream dispatch tables
+ *
+ * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
+ * Copyright (c) 1990 Giuseppe Attardi
+ * Copyright (c) 2001 Juan Jose Garcia Ripoll
+ * Copyright (c) 2025 Daniel Kochmanski
+ *
+ * See file 'LICENSE' for the copyright details.
+ *
+ */
+
+#include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
+#define ECL_DEFINE_AET_SIZE
+#include <ecl/internal.h>
+
+/**********************************************************************
+ * SEQUENCE INPUT STREAMS
+ */
+
+static cl_index
+seq_in_read_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+  cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm);
+  cl_fixnum last = SEQ_INPUT_LIMIT(strm);
+  cl_fixnum delta = last - curr_pos;
+  if (delta > 0) {
+    cl_object vector = SEQ_INPUT_VECTOR(strm);
+    if (delta > n) delta = n;
+    ecl_copy(c, vector->vector.self.bc + curr_pos, delta);
+    SEQ_INPUT_POSITION(strm) += delta;
+    return delta;
+  }
+  return 0;
+}
+
+static void
+seq_in_unread_char(cl_object strm, ecl_character c)
+{
+  ecl_eformat_unread_char(strm, c);
+  SEQ_INPUT_POSITION(strm) -= ecl_length(strm->stream.byte_stack);
+  strm->stream.byte_stack = ECL_NIL;
+}
+
+#ifdef ecl_uint16_t
+static ecl_character
+seq_in_ucs2_read_char(cl_object strm)
+{
+  cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm);
+  cl_fixnum last = SEQ_INPUT_LIMIT(strm);
+  if (curr_pos >= last) {
+    return EOF;
+  }
+  cl_object vector = SEQ_INPUT_VECTOR(strm);
+  ecl_character c = vector->vector.self.b16[curr_pos++];
+  cl_object err;
+  if (c >= 0xD800 && c <= 0xDBFF) {
+    if (curr_pos >= last) {
+      err = ecl_list1(ecl_make_fixnum(c));
+      goto DECODING_ERROR;
+    }
+    ecl_character aux = vector->vector.self.b16[curr_pos++];
+    if (aux < 0xDC00 || aux > 0xDFFF) {
+      err = cl_list(2, ecl_make_fixnum(c), ecl_make_fixnum(aux));
+      goto DECODING_ERROR;
+    }
+    c = ((c & 0x3FF) << 10) + (aux & 0x3FF) + 0x10000;
+  }
+  SEQ_INPUT_POSITION(strm) = curr_pos;
+  return c;
+  cl_object code;
+ DECODING_ERROR:
+  code = _ecl_funcall4(@'ext::decoding-error', strm,
+                       cl_stream_external_format(strm),
+                       err);
+  if (Null(code)) {
+    /* Go for next character */
+    return seq_in_ucs2_read_char(strm);
+  } else {
+    /* Return supplied character */
+    return ecl_char_code(code);
+  }
+}
+
+static void
+seq_in_ucs2_unread_char(cl_object strm, ecl_character c)
+{
+  if (c >= 0x10000) {
+    SEQ_INPUT_POSITION(strm) -= 2;
+  } else {
+    SEQ_INPUT_POSITION(strm) -= 1;
+  }
+}
+#endif
+
+#ifdef ecl_uint32_t
+static ecl_character
+seq_in_ucs4_read_char(cl_object strm)
+{
+  cl_fixnum curr_pos = SEQ_INPUT_POSITION(strm);
+  if (curr_pos >= SEQ_INPUT_LIMIT(strm)) {
+    return EOF;
+  }
+  cl_object vector = SEQ_INPUT_VECTOR(strm);
+  SEQ_INPUT_POSITION(strm) += 1;
+  return vector->vector.self.b32[curr_pos];
+}
+
+static void
+seq_in_ucs4_unread_char(cl_object strm, ecl_character c)
+{
+  SEQ_INPUT_POSITION(strm) -= 1;
+}
+#endif
+
+static int
+seq_in_listen(cl_object strm)
+{
+  if (SEQ_INPUT_POSITION(strm) < SEQ_INPUT_LIMIT(strm))
+    return ECL_LISTEN_AVAILABLE;
+  else
+    return ECL_LISTEN_EOF;
+}
+
+static cl_object
+seq_in_get_position(cl_object strm)
+{
+  return ecl_make_unsigned_integer(SEQ_INPUT_POSITION(strm));
+}
+
+static cl_object
+seq_in_set_position(cl_object strm, cl_object pos)
+{
+  cl_fixnum disp;
+  if (Null(pos)) {
+    disp = SEQ_INPUT_LIMIT(strm);
+  }  else {
+    disp = ecl_to_size(pos);
+    if (disp >= SEQ_INPUT_LIMIT(strm)) {
+      disp = SEQ_INPUT_LIMIT(strm);
+    }
+  }
+  SEQ_INPUT_POSITION(strm) = disp;
+  return ECL_T;
+}
+
+static cl_object
+seq_file_element_type(cl_object strm)
+{
+  return IO_FILE_ELT_TYPE(strm);
+}
+
+const struct ecl_file_ops seq_in_ops = {
+  ecl_not_output_write_byte8,
+  seq_in_read_byte8,
+
+  ecl_not_output_write_byte,
+  ecl_generic_read_byte,
+
+  ecl_eformat_read_char,
+  ecl_not_output_write_char,
+  seq_in_unread_char,
+  ecl_generic_peek_char,
+
+  ecl_generic_read_vector,
+  ecl_generic_write_vector,
+
+  seq_in_listen,
+  ecl_generic_void, /* clear-input */
+  ecl_not_output_clear_output,
+  ecl_not_output_finish_output,
+  ecl_not_output_force_output,
+
+  ecl_generic_always_true, /* input_p */
+  ecl_generic_always_false, /* output_p */
+  ecl_generic_always_false,
+  seq_file_element_type,
+
+  ecl_not_a_file_stream, /* length */
+  seq_in_get_position,
+  seq_in_set_position,
+  ecl_not_output_string_length,
+  ecl_unknown_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  ecl_generic_close
+};
+
+static cl_object
+make_sequence_input_stream(cl_object vector, cl_index istart, cl_index iend,
+                           cl_object external_format)
+{
+  cl_object strm;
+  cl_elttype type;
+  cl_object type_name;
+  int byte_size;
+  int flags = 0;
+  if (!ECL_VECTORP(vector)) {
+    FEwrong_type_nth_arg(@[ext::make-sequence-input-stream], 1, vector, @[vector]);
+  }
+  type = ecl_array_elttype(vector);
+  type_name = ecl_elttype_to_symbol(type);
+  byte_size = ecl_normalize_stream_element_type(type_name);
+  /* Character streams always get some external format. For binary
+   * sequences it has to be explicitly mentioned. */
+  strm = ecl_alloc_stream();
+  strm->stream.ops = ecl_duplicate_dispatch_table(&seq_in_ops);
+  strm->stream.mode = (short)ecl_smm_sequence_input;
+  if (!byte_size && Null(external_format)) {
+    external_format = @':default';
+  }
+  if (ecl_aet_size[type] == 1) {
+    ecl_set_stream_elt_type(strm, byte_size, flags, external_format);
+    /* Override byte size */
+    if (byte_size) strm->stream.byte_size = 8;
+  }
+#ifdef ecl_uint16_t
+  else if (ecl_aet_size[type] == 2 && external_format == @':ucs-2') {
+    IO_STREAM_ELT_TYPE(strm) = @'character';
+    strm->stream.format = @':ucs-2';
+    strm->stream.byte_size = 2*8;
+    strm->stream.ops->read_char = seq_in_ucs2_read_char;
+    strm->stream.ops->unread_char = seq_in_ucs2_unread_char;
+  }
+#endif
+#ifdef ecl_uint32_t
+  else if (ecl_aet_size[type] == 4 && external_format == @':ucs-4') {
+    IO_STREAM_ELT_TYPE(strm) = @'character';
+    strm->stream.format = @':ucs-4';
+    strm->stream.byte_size = 4*8;
+    strm->stream.ops->read_char = seq_in_ucs4_read_char;
+    strm->stream.ops->unread_char = seq_in_ucs4_unread_char;
+  }
+#endif
+  else {
+    FEerror("Illegal combination of external-format ~A and input vector ~A for MAKE-SEQUENCE-INPUT-STREAM.~%", 2, external_format, vector);
+  }
+  SEQ_INPUT_VECTOR(strm) = vector;
+  SEQ_INPUT_POSITION(strm) = istart;
+  SEQ_INPUT_LIMIT(strm) = iend;
+  return strm;
+}
+
+@(defun ext::make_sequence_input_stream (vector &key
+                                         (start ecl_make_fixnum(0))
+                                         (end ECL_NIL)
+                                         (external_format ECL_NIL))
+  cl_index_pair p;
+  @
+  p = ecl_vector_start_end(@[ext::make-sequence-input-stream],
+                           vector, start, end);
+  @(return make_sequence_input_stream(vector, p.start, p.end,
+                                      external_format))
+  @)
+
+/**********************************************************************
+ * SEQUENCE OUTPUT STREAMS
+ */
+
+static void
+seq_out_enlarge_vector(cl_object strm)
+{
+  cl_object vector = SEQ_OUTPUT_VECTOR(strm);
+  si_adjust_vector(vector, ecl_ash(ecl_make_fixnum(vector->vector.dim), 1));
+  SEQ_OUTPUT_VECTOR(strm) = vector;
+}
+
+static cl_index
+seq_out_write_byte8(cl_object strm, unsigned char *c, cl_index n)
+{
+ AGAIN:
+  {
+    cl_object vector = SEQ_OUTPUT_VECTOR(strm);
+    cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm);
+    cl_fixnum last = vector->vector.dim;
+    cl_fixnum delta = last - curr_pos;
+    if (delta < n) {
+      seq_out_enlarge_vector(strm);
+      goto AGAIN;
+    }
+    ecl_copy(vector->vector.self.bc + curr_pos, c, n);
+    SEQ_OUTPUT_POSITION(strm) = curr_pos += n;
+    if (vector->vector.fillp < curr_pos)
+      vector->vector.fillp = curr_pos;
+  }
+  return n;
+}
+
+#ifdef ecl_uint16_t
+static ecl_character
+seq_out_ucs2_write_char(cl_object strm, ecl_character c)
+{
+ AGAIN:
+  {
+    cl_object vector = SEQ_OUTPUT_VECTOR(strm);
+    cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm);
+    cl_fixnum n = (c >= 0x10000) ? 2 : 1;
+    if (vector->vector.dim - curr_pos < n) {
+      seq_out_enlarge_vector(strm);
+      goto AGAIN;
+    }
+    if (c >= 0x10000) {
+      c -= 0x10000;
+      vector->vector.self.b16[curr_pos++] = (c >> 10) | 0xD800;
+      vector->vector.self.b16[curr_pos++] = (c & 0x3FF) | 0xDC00;
+    } else {
+      vector->vector.self.b16[curr_pos++] = c;
+    }
+    SEQ_OUTPUT_POSITION(strm) = curr_pos;
+    if (vector->vector.fillp < curr_pos)
+      vector->vector.fillp = curr_pos;
+  }
+  return c;
+}
+#endif
+
+#ifdef ecl_uint32_t
+static ecl_character
+seq_out_ucs4_write_char(cl_object strm, ecl_character c)
+{
+ AGAIN:
+  {
+    cl_object vector = SEQ_OUTPUT_VECTOR(strm);
+    cl_fixnum curr_pos = SEQ_OUTPUT_POSITION(strm);
+    if (vector->vector.dim - curr_pos < 1) {
+      seq_out_enlarge_vector(strm);
+      goto AGAIN;
+    }
+    vector->vector.self.b32[curr_pos++] = c;
+    SEQ_OUTPUT_POSITION(strm) = curr_pos;
+    if (vector->vector.fillp < curr_pos)
+      vector->vector.fillp = curr_pos;
+  }
+  return c;
+}
+#endif
+
+static cl_object
+seq_out_get_position(cl_object strm)
+{
+  return ecl_make_unsigned_integer(SEQ_OUTPUT_POSITION(strm));
+}
+
+static cl_object
+seq_out_set_position(cl_object strm, cl_object pos)
+{
+  cl_object vector = SEQ_OUTPUT_VECTOR(strm);
+  cl_fixnum disp;
+  if (Null(pos)) {
+    disp = vector->vector.fillp;
+  } else {
+    disp = ecl_to_size(pos);
+    if (disp >= vector->vector.dim) {
+      disp = vector->vector.fillp;
+    }
+  }
+  SEQ_OUTPUT_POSITION(strm) = disp;
+  return ECL_T;
+}
+
+const struct ecl_file_ops seq_out_ops = {
+  seq_out_write_byte8,
+  ecl_not_input_read_byte8,
+
+  ecl_generic_write_byte,
+  ecl_not_input_read_byte,
+
+  ecl_not_input_read_char,
+  ecl_eformat_write_char,
+  ecl_not_input_unread_char,
+  ecl_generic_peek_char,
+
+  ecl_generic_read_vector,
+  ecl_generic_write_vector,
+
+  ecl_not_input_listen,
+  ecl_not_input_clear_input,
+  ecl_generic_void, /* clear-output */
+  ecl_generic_void, /* finish-output */
+  ecl_generic_void, /* force-output */
+
+  ecl_generic_always_false, /* input_p */
+  ecl_generic_always_true, /* output_p */
+  ecl_generic_always_false,
+  seq_file_element_type,
+
+  ecl_not_a_file_stream, /* length */
+  seq_out_get_position,
+  seq_out_set_position,
+  ecl_not_output_string_length,
+  ecl_generic_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  ecl_generic_close
+};
+
+static cl_object
+make_sequence_output_stream(cl_object vector, cl_object external_format)
+{
+  cl_object strm;
+  cl_elttype type;
+  cl_object type_name;
+  int byte_size;
+  int flags = 0;
+  if (!ECL_VECTORP(vector)) {
+    FEwrong_type_nth_arg(@[ext::make-sequence-output-stream], 1, vector, @[vector]);
+  }
+  type = ecl_array_elttype(vector);
+  type_name = ecl_elttype_to_symbol(type);
+  byte_size = ecl_normalize_stream_element_type(type_name);
+  /* Character streams always get some external format. For binary
+   * sequences it has to be explicitly mentioned. */
+  strm = ecl_alloc_stream();
+  strm->stream.ops = ecl_duplicate_dispatch_table(&seq_out_ops);
+  strm->stream.mode = (short)ecl_smm_sequence_output;
+  if (!byte_size && Null(external_format)) {
+    external_format = @':default';
+  }
+  if (ecl_aet_size[type] == 1) {
+    ecl_set_stream_elt_type(strm, byte_size, flags, external_format);
+    /* Override byte size */
+    if (byte_size) strm->stream.byte_size = 8;
+  }
+#ifdef ecl_uint16_t
+  else if (ecl_aet_size[type] == 2 && external_format == @':ucs-2') {
+    IO_STREAM_ELT_TYPE(strm) = @'character';
+    strm->stream.format = @':ucs-2';
+    strm->stream.byte_size = 2*8;
+    strm->stream.ops->write_char = seq_out_ucs2_write_char;
+  }
+#endif
+#ifdef ecl_uint32_t
+  else if (ecl_aet_size[type] == 4 && external_format == @':ucs-4') {
+    IO_STREAM_ELT_TYPE(strm) = @'character';
+    strm->stream.format = @':ucs-4';
+    strm->stream.byte_size = 4*8;
+    strm->stream.ops->write_char = seq_out_ucs4_write_char;
+  }
+#endif
+  else {
+    FEerror("Illegal combination of external-format ~A and output vector ~A for MAKE-SEQUENCE-OUTPUT-STREAM.~%", 2, external_format, vector);
+  }
+  SEQ_OUTPUT_VECTOR(strm) = vector;
+  SEQ_OUTPUT_POSITION(strm) = vector->vector.fillp;
+  return strm;
+}
+
+@(defun ext::make_sequence_output_stream (vector &key (external_format ECL_NIL))
+@
+  @(return make_sequence_output_stream(vector, external_format));
+@)
+
+/*******************************tl***************************************
+ * SEQUENCES I/O
+ */
+
+void
+writestr_stream(const char *s, cl_object strm)
+{
+  cl_object buffer = si_get_buffer_string();
+  cl_index size = ecl_fixnum(cl_array_total_size(buffer));
+  cl_index i = 0;
+  while (*s != '\0') {
+    ecl_char_set(buffer, i++, (ecl_character) *s++);
+    if (i >= size) {
+      si_fill_pointer_set(buffer, ecl_make_fixnum(size));
+      si_do_write_sequence(buffer, strm, ecl_make_fixnum(0), ECL_NIL);
+      i = 0;
+    }
+  }
+  si_fill_pointer_set(buffer, ecl_make_fixnum(i));
+  si_do_write_sequence(buffer, strm, ecl_make_fixnum(0), ECL_NIL);
+  si_put_buffer_string(buffer);
+}
+
+
+cl_object
+si_do_write_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e)
+{
+  const struct ecl_file_ops *ops;
+  cl_fixnum start,limit,end;
+
+  /* Since we have called ecl_length(), we know that SEQ is a valid
+     sequence. Therefore, we only need to check the type of the
+     object, and seq == ECL_NIL i.f.f. t = t_symbol */
+  limit = ecl_length(seq);
+  if (ecl_unlikely(!ECL_FIXNUMP(s) ||
+                   ((start = ecl_fixnum(s)) < 0) ||
+                   (start > limit))) {
+    FEwrong_type_key_arg(@[write-sequence], @[:start], s,
+                         ecl_make_integer_type(ecl_make_fixnum(0),
+                                               ecl_make_fixnum(limit-1)));
+  }
+  if (e == ECL_NIL) {
+    end = limit;
+  } else if (ecl_unlikely(!ECL_FIXNUMP(e) ||
+                          ((end = ecl_fixnum(e)) < 0) ||
+                          (end > limit))) {
+    FEwrong_type_key_arg(@[write-sequence], @[:end], e,
+                         ecl_make_integer_type(ecl_make_fixnum(0),
+                                               ecl_make_fixnum(limit)));
+  }
+  if (end <= start) {
+    goto OUTPUT;
+  }
+  ops = ecl_stream_dispatch_table(stream);
+  if (LISTP(seq)) {
+    cl_object elt_type = cl_stream_element_type(stream);
+    bool ischar = (elt_type == @'base-char') || (elt_type == @'character');
+    cl_object s = ecl_nthcdr(start, seq);
+    loop_for_in(s) {
+      if (start < end) {
+        cl_object elt = CAR(s);
+        if (ischar)
+          ops->write_char(stream, ecl_char_code(elt));
+        else
+          ops->write_byte(stream, elt);
+        start++;
+      } else {
+        goto OUTPUT;
+      }
+    } end_loop_for_in;
+  } else {
+    ops->write_vector(stream, seq, start, end);
+  }
+ OUTPUT:
+  @(return seq);
+}
+
+cl_object
+si_do_read_sequence(cl_object seq, cl_object stream, cl_object s, cl_object e)
+{
+  const struct ecl_file_ops *ops;
+  cl_fixnum start,limit,end;
+
+  /* Since we have called ecl_length(), we know that SEQ is a valid
+     sequence. Therefore, we only need to check the type of the
+     object, and seq == ECL_NIL i.f.f. t = t_symbol */
+  limit = ecl_length(seq);
+  if (ecl_unlikely(!ECL_FIXNUMP(s) ||
+                   ((start = ecl_fixnum(s)) < 0) ||
+                   (start > limit))) {
+    FEwrong_type_key_arg(@[read-sequence], @[:start], s,
+                         ecl_make_integer_type(ecl_make_fixnum(0),
+                                               ecl_make_fixnum(limit-1)));
+  }
+  if (e == ECL_NIL) {
+    end = limit;
+  } else if (ecl_unlikely(!ECL_FIXNUMP(e) ||
+                          ((end = ecl_fixnum(e)) < 0) ||
+                          (end > limit))) {
+    FEwrong_type_key_arg(@[read-sequence], @[:end], e,
+                         ecl_make_integer_type(ecl_make_fixnum(0),
+                                               ecl_make_fixnum(limit)));
+  }
+  if (end <= start) {
+    goto OUTPUT;
+  }
+  ops = ecl_stream_dispatch_table(stream);
+  if (LISTP(seq)) {
+    cl_object elt_type = cl_stream_element_type(stream);
+    bool ischar = (elt_type == @'base-char') || (elt_type == @'character');
+    seq = ecl_nthcdr(start, seq);
+    loop_for_in(seq) {
+      if (start >= end) {
+        goto OUTPUT;
+      } else {
+        cl_object c;
+        if (ischar) {
+          int i = ops->read_char(stream);
+          if (i < 0) goto OUTPUT;
+          c = ECL_CODE_CHAR(i);
+        } else {
+          c = ops->read_byte(stream);
+          if (c == ECL_NIL) goto OUTPUT;
+        }
+        ECL_RPLACA(seq, c);
+        start++;
+      }
+    } end_loop_for_in;
+  } else {
+    start = ops->read_vector(stream, seq, start, end);
+  }
+ OUTPUT:
+  @(return ecl_make_fixnum(start));
+}

src/c/streams/strm_string.d

@@ -0,0 +1,352 @@
+/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
+/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
+
+/*
+ * strm_string.d - String Streams dispatch tables
+ *
+ * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
+ * Copyright (c) 1990 Giuseppe Attardi
+ * Copyright (c) 2001 Juan Jose Garcia Ripoll
+ * Copyright (c) 2025 Daniel Kochmanski
+ *
+ * See file 'LICENSE' for the copyright details.
+ *
+ */
+
+#include <ecl/ecl.h>
+#include <ecl/internal.h>
+
+/**********************************************************************
+ * STRING OUTPUT STREAMS
+ */
+
+static ecl_character
+str_out_write_char(cl_object strm, ecl_character c)
+{
+  write_char_increment_column(strm, c);
+  ecl_string_push_extend(STRING_OUTPUT_STRING(strm), c);
+  return c;
+}
+
+static cl_object
+str_out_element_type(cl_object strm)
+{
+  cl_object string = STRING_OUTPUT_STRING(strm);
+  if (ECL_BASE_STRING_P(string))
+    return @'base-char';
+  return @'character';
+}
+
+static cl_object
+str_out_get_position(cl_object strm)
+{
+  return ecl_make_unsigned_integer(STRING_OUTPUT_STRING(strm)->base_string.fillp);
+}
+
+static cl_object
+str_out_string_length(cl_object strm, cl_object string)
+{
+  cl_fixnum l = 0;
+  switch (ecl_t_of(string)) {
+#ifdef ECL_UNICODE
+  case t_string:
+#endif
+  case t_base_string:
+    l = string->base_string.fillp;
+    break;
+  case t_character:
+    l = 1;
+    break;
+  default:
+    FEwrong_type_nth_arg(@[file-string-length], 2, string, @[string]);
+  }
+  return ecl_make_fixnum(l);
+}
+
+static cl_object
+str_out_set_position(cl_object strm, cl_object pos)
+{
+  cl_object string = STRING_OUTPUT_STRING(strm);
+  cl_fixnum disp;
+  if (Null(pos)) {
+    disp = strm->base_string.dim;
+  } else {
+    disp = ecl_to_size(pos);
+  }
+  if (disp < string->base_string.fillp) {
+    string->base_string.fillp = disp;
+  } else {
+    disp -= string->base_string.fillp;
+    while (disp-- > 0)
+      ecl_write_char(' ', strm);
+  }
+  return ECL_T;
+}
+
+const struct ecl_file_ops str_out_ops = {
+  ecl_not_output_write_byte8,
+  ecl_not_binary_read_byte8,
+
+  ecl_not_binary_write_byte,
+  ecl_not_input_read_byte,
+
+  ecl_not_input_read_char,
+  str_out_write_char,
+  ecl_not_input_unread_char,
+  ecl_generic_peek_char,
+
+  ecl_generic_read_vector,
+  ecl_generic_write_vector,
+
+  ecl_not_input_listen,
+  ecl_not_input_clear_input,
+  ecl_generic_void, /* clear-output */
+  ecl_generic_void, /* finish-output */
+  ecl_generic_void, /* force-output */
+
+  ecl_generic_always_false, /* input_p */
+  ecl_generic_always_true, /* output_p */
+  ecl_generic_always_false,
+  str_out_element_type,
+
+  ecl_not_a_file_stream, /* length */
+  str_out_get_position,
+  str_out_set_position,
+  str_out_string_length,
+  ecl_generic_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  ecl_generic_close
+};
+
+
+cl_object
+si_make_string_output_stream_from_string(cl_object s)
+{
+  cl_object strm = ecl_alloc_stream();
+  unlikely_if (!ECL_STRINGP(s) || !ECL_ARRAY_HAS_FILL_POINTER_P(s))
+    FEerror("~S is not a -string with a fill-pointer.", 1, s);
+  strm->stream.ops = ecl_duplicate_dispatch_table(&str_out_ops);
+  strm->stream.mode = (short)ecl_smm_string_output;
+  STRING_OUTPUT_STRING(strm) = s;
+  strm->stream.column = 0;
+#if !defined(ECL_UNICODE)
+  strm->stream.format = @':pass-through';
+  strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT;
+  strm->stream.byte_size = 8;
+#else
+  if (ECL_BASE_STRING_P(s)) {
+    strm->stream.format = @':latin-1';
+    strm->stream.flags = ECL_STREAM_LATIN_1;
+    strm->stream.byte_size = 8;
+  } else {
+    strm->stream.format = @':ucs-4';
+    strm->stream.flags = ECL_STREAM_UCS_4;
+    strm->stream.byte_size = 32;
+  }
+#endif
+  @(return strm);
+}
+
+cl_object
+ecl_make_string_output_stream(cl_index line_length, int extended)
+{
+#ifdef ECL_UNICODE
+  cl_object s = extended?
+    ecl_alloc_adjustable_extended_string(line_length) :
+    ecl_alloc_adjustable_base_string(line_length);
+#else
+  cl_object s = ecl_alloc_adjustable_base_string(line_length);
+#endif
+  return si_make_string_output_stream_from_string(s);
+}
+
+@(defun make-string-output-stream (&key (element_type @'character'))
+  int extended = 0;
+@
+  if (element_type == @'base-char') {
+    (void)0;
+  } else if (element_type == @'character') {
+#ifdef ECL_UNICODE
+    extended = 1;
+#endif
+  } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'base-char'))) {
+    (void)0;
+  } else if (!Null(_ecl_funcall3(@'subtypep', element_type, @'character'))) {
+#ifdef ECL_UNICODE
+    extended = 1;
+#endif
+  } else {
+    FEerror("In MAKE-STRING-OUTPUT-STREAM, the argument :ELEMENT-TYPE (~A) must be a subtype of character",
+            1, element_type);
+  }
+  @(return ecl_make_string_output_stream(128, extended));
+@)
+
+cl_object
+cl_get_output_stream_string(cl_object strm)
+{
+  cl_object strng;
+  unlikely_if (!ECL_ANSI_STREAM_TYPE_P(strm, ecl_smm_string_output))
+    FEwrong_type_only_arg(@[get-output-stream-string],
+                          strm, @[string-stream]);
+  strng = cl_copy_seq(STRING_OUTPUT_STRING(strm));
+  STRING_OUTPUT_STRING(strm)->base_string.fillp = 0;
+  @(return strng);
+}
+
+/**********************************************************************
+ * STRING INPUT STREAMS
+ */
+
+static ecl_character
+str_in_read_char(cl_object strm)
+{
+  cl_fixnum curr_pos = STRING_INPUT_POSITION(strm);
+  ecl_character c;
+  if (curr_pos >= STRING_INPUT_LIMIT(strm)) {
+    c = EOF;
+  } else {
+    c = ecl_char(STRING_INPUT_STRING(strm), curr_pos);
+    STRING_INPUT_POSITION(strm) = curr_pos+1;
+  }
+  return c;
+}
+
+static void
+str_in_unread_char(cl_object strm, ecl_character c)
+{
+  cl_fixnum curr_pos = STRING_INPUT_POSITION(strm);
+  unlikely_if (c <= 0) {
+    ecl_unread_error(strm);
+  }
+  STRING_INPUT_POSITION(strm) = curr_pos - 1;
+}
+
+static ecl_character
+str_in_peek_char(cl_object strm)
+{
+  cl_index pos = STRING_INPUT_POSITION(strm);
+  if (pos >= STRING_INPUT_LIMIT(strm)) {
+    return EOF;
+  } else {
+    return ecl_char(STRING_INPUT_STRING(strm), pos);
+  }
+}
+
+static int
+str_in_listen(cl_object strm)
+{
+  if (STRING_INPUT_POSITION(strm) < STRING_INPUT_LIMIT(strm))
+    return ECL_LISTEN_AVAILABLE;
+  else
+    return ECL_LISTEN_EOF;
+}
+
+static cl_object
+str_in_element_type(cl_object strm)
+{
+  cl_object string = STRING_INPUT_STRING(strm);
+  if (ECL_BASE_STRING_P(string))
+    return @'base-char';
+  return @'character';
+}
+
+static cl_object
+str_in_get_position(cl_object strm)
+{
+  return ecl_make_unsigned_integer(STRING_INPUT_POSITION(strm));
+}
+
+static cl_object
+str_in_set_position(cl_object strm, cl_object pos)
+{
+  cl_fixnum disp;
+  if (Null(pos)) {
+    disp = STRING_INPUT_LIMIT(strm);
+  }  else {
+    disp = ecl_to_size(pos);
+    if (disp >= STRING_INPUT_LIMIT(strm)) {
+      disp = STRING_INPUT_LIMIT(strm);
+    }
+  }
+  STRING_INPUT_POSITION(strm) = disp;
+  return ECL_T;
+}
+
+const struct ecl_file_ops str_in_ops = {
+  ecl_not_output_write_byte8,
+  ecl_not_binary_read_byte8,
+
+  ecl_not_output_write_byte,
+  ecl_not_binary_read_byte,
+
+  str_in_read_char,
+  ecl_not_output_write_char,
+  str_in_unread_char,
+  str_in_peek_char,
+
+  ecl_generic_read_vector,
+  ecl_generic_write_vector,
+
+  str_in_listen,
+  ecl_generic_void, /* clear-input */
+  ecl_not_output_clear_output,
+  ecl_not_output_finish_output,
+  ecl_not_output_force_output,
+
+  ecl_generic_always_true, /* input_p */
+  ecl_generic_always_false, /* output_p */
+  ecl_generic_always_false,
+  str_in_element_type,
+
+  ecl_not_a_file_stream, /* length */
+  str_in_get_position,
+  str_in_set_position,
+  ecl_not_output_string_length,
+  ecl_unknown_column,
+
+  ecl_not_a_file_stream,
+  ecl_not_a_file_stream,
+
+  ecl_generic_close
+};
+
+cl_object
+ecl_make_string_input_stream(cl_object strng, cl_index istart, cl_index iend)
+{
+  cl_object strm;
+
+  strm = ecl_alloc_stream();
+  strm->stream.ops = ecl_duplicate_dispatch_table(&str_in_ops);
+  strm->stream.mode = (short)ecl_smm_string_input;
+  STRING_INPUT_STRING(strm) = strng;
+  STRING_INPUT_POSITION(strm) = istart;
+  STRING_INPUT_LIMIT(strm) = iend;
+#if !defined(ECL_UNICODE)
+  strm->stream.format = @':pass-through';
+  strm->stream.flags = ECL_STREAM_DEFAULT_FORMAT;
+  strm->stream.byte_size = 8;
+#else
+  if (ECL_BASE_STRING_P(strng)) {
+    strm->stream.format = @':latin-1';
+    strm->stream.flags = ECL_STREAM_LATIN_1;
+    strm->stream.byte_size = 8;
+  } else {
+    strm->stream.format = @':ucs-4';
+    strm->stream.flags = ECL_STREAM_UCS_4;
+    strm->stream.byte_size = 32;
+  }
+#endif
+  return strm;
+}
+
+@(defun make_string_input_stream (strng &o (istart ecl_make_fixnum(0)) iend)
+  cl_index_pair p;
+@
+  strng = cl_string(strng);
+  p = ecl_vector_start_end(@[make-string-input-stream], strng, istart, iend);
+  @(return (ecl_make_string_input_stream(strng, p.start, p.end)));
+@)

src/h/internal.h

@@ -395,7 +395,6 @@ const struct ecl_file_ops *ecl_stream_dispatch_table(cl_object strm);
 cl_index ecl_read_byte8(cl_object stream, unsigned char *c, cl_index n);
 cl_index ecl_write_byte8(cl_object stream, unsigned char *c, cl_index n);
 
-
 cl_object si_read_char(cl_object strm, cl_object eof_value);
 cl_object si_unread_char(cl_object strm, cl_object eof_value);
 cl_object si_peek_char(cl_object strm, cl_object eof_value);
@@ -415,6 +414,76 @@ cl_object si_clear_output(cl_object strm);
 #define ecl_unread_error(s) FEerror("Error when using UNREAD-CHAR on stream ~D", 1, s)
 #define ecl_unread_twice(s) FEerror("Used UNREAD-CHAR twice on stream ~D", 1, s);
 
+/* streams/strm_common.d */
+cl_object ecl_not_a_file_stream(cl_object strm);
+void ecl_not_an_input_stream(cl_object strm);
+void ecl_not_an_output_stream(cl_object strm);
+cl_index ecl_not_output_write_byte8(cl_object strm, unsigned char *c, cl_index n);
+cl_index ecl_not_input_read_byte8(cl_object strm, unsigned char *c, cl_index n);
+cl_index ecl_not_binary_read_byte8(cl_object strm, unsigned char *c, cl_index n);
+void ecl_not_output_write_byte(cl_object strm, cl_object byte);
+cl_object ecl_not_input_read_byte(cl_object strm);
+void ecl_not_binary_write_byte(cl_object strm, cl_object byte);
+cl_object ecl_not_binary_read_byte(cl_object strm);
+ecl_character ecl_not_input_read_char(cl_object strm);
+ecl_character ecl_not_output_write_char(cl_object strm, ecl_character c);
+void ecl_not_input_unread_char(cl_object strm, ecl_character c);
+int ecl_not_input_listen(cl_object strm);
+ecl_character ecl_not_character_read_char(cl_object strm);
+ecl_character ecl_not_character_write_char(cl_object strm, ecl_character c);
+ecl_character ecl_not_character_decoder(cl_object stream, unsigned char **buffer, unsigned char *buffer_end);
+int ecl_not_character_encoder(cl_object stream, unsigned char *buffer, ecl_character c);
+void ecl_not_input_clear_input(cl_object strm);
+void ecl_not_output_clear_output(cl_object strm);
+void ecl_not_output_force_output(cl_object strm);
+void ecl_not_output_finish_output(cl_object strm);
+cl_object ecl_not_output_string_length(cl_object strm, cl_object string);
+cl_object ecl_not_file_string_length(cl_object strm, cl_object string);
+int ecl_unknown_column(cl_object strm);
+
+cl_object ecl_generic_read_byte_unsigned8(cl_object strm);
+void ecl_generic_write_byte_unsigned8(cl_object byte, cl_object strm);
+cl_object ecl_generic_read_byte_signed8(cl_object strm);
+void ecl_generic_write_byte_signed8(cl_object byte, cl_object strm);
+cl_object ecl_generic_read_byte_le(cl_object strm);
+void ecl_generic_write_byte_le(cl_object c, cl_object strm);
+cl_object ecl_generic_read_byte(cl_object strm);
+void ecl_generic_write_byte(cl_object c, cl_object strm);
+ecl_character ecl_generic_peek_char(cl_object strm);
+void ecl_generic_void(cl_object strm);
+int ecl_generic_always_true(cl_object strm);
+int ecl_generic_always_false(cl_object strm);
+cl_object ecl_generic_always_nil(cl_object strm);
+int ecl_generic_column(cl_object strm);
+cl_object ecl_generic_set_position(cl_object strm, cl_object pos);
+cl_object ecl_generic_close(cl_object strm);
+cl_index ecl_generic_write_vector(cl_object strm, cl_object data, cl_index start, cl_index end);
+cl_index ecl_generic_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end);
+
+/* streams/strm_eformat.d */
+ecl_character ecl_eformat_read_char(cl_object strm);
+void ecl_eformat_unread_char(cl_object strm, ecl_character c);
+ecl_character ecl_eformat_write_char(cl_object strm, ecl_character c);
+void ecl_set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags,
+                             cl_object external_format);
+cl_object ecl_eformat_file_string_length(cl_object stream, cl_object string);
+
+static inline void
+write_char_increment_column(cl_object strm, ecl_character c)
+{
+  if (c == '\n')
+    strm->stream.column = 0;
+  else if (c == '\t')
+    strm->stream.column = (strm->stream.column & ~((cl_index)07)) + 8;
+  else
+    strm->stream.column++;
+}
+
+/* Maximum number of bytes required to encode a character.  This currently
+ * corresponds to (4 + 4) for the UCS-4 encoding with 4 being the byte-order
+ * mark, 4 for the character. */
+#define ENCODING_BUFFER_MAX_SIZE 8
+
 /* file.d */
 
 /* Windows does not have this flag (POSIX thing) */