/* Copyright 2009-2024
 * Kaz Kylheku <kaz@kylheku.com>
 * Vancouver, Canada
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * 1. Redistributions of source code must retain the above copyright notice,
 *    this list of conditions and the following disclaimer.
 *
 * 2. Redistributions in binary form must reproduce the above copyright notice,
 *    this list of conditions and the following disclaimer in the documentation
 *    and/or other materials provided with the distribution.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 */

#define UTF8_DECL_OPENDIR
#include <stdio.h>
#include <string.h>
#include <stddef.h>
#include <dirent.h>
#include <stdarg.h>
#include <stdlib.h>
#include <errno.h>
#include <ctype.h>
#include <wchar.h>
#include <wctype.h>
#include <signal.h>
#include "config.h"
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef __CYGWIN__
#include <sys/utsname.h>
#endif
#if HAVE_FCNTL
#include <fcntl.h>
#endif
#include <float.h>
#if HAVE_SYS_WAIT
#include <sys/wait.h>
#endif
#if HAVE_WINDOWS_H
#include <windows.h>
#endif
#if HAVE_WSPAWN || HAVE_SPAWN
#include <process.h>
#endif
#if HAVE_ZLIB
#include <zlib.h>
#endif
#include "alloca.h"
#include "lib.h"
#include "gc.h"
#include "signal.h"
#include "unwind.h"
#include "args.h"
#include "sysif.h"
#include "stream.h"
#include "utf8.h"
#include "eval.h"
#include "regex.h"
#include "txr.h"
#include "buf.h"
#if HAVE_ZLIB
#include "gzio.h"
#endif

#define max(a, b) ((a) > (b) ? (a) : (b))
#define min(a, b) ((a) < (b) ? (a) : (b))

/* Adhere to ISO C rules about direction switching on update streams. */
#ifndef __gnu_linux__
#define CONFIG_STDIO_STRICT 1
#endif

val stdin_s, stdout_s, stddebug_s, stderr_s, stdnull_s;

val put_string_s, put_char_s, put_byte_s, get_line_s, get_char_s;
val get_byte_s, unget_char_s, unget_byte_s, put_buf_s, fill_buf_s;
val flush_s, seek_s, truncate_s, get_prop_s, set_prop_s;
val get_error_s, get_error_str_s, clear_error_s, get_fd_s;

val print_flo_precision_s, print_flo_digits_s, print_flo_format_s;
val pprint_flo_format_s, print_base_s, print_circle_s;
val print_json_format_s, print_json_type_s;

val from_start_k, from_current_k, from_end_k;
val real_time_k, name_k, addr_k, fd_k, byte_oriented_k;
val standard_k;
val format_s;

val stdio_stream_s;

#if HAVE_SOCKETS
val socket_error_s;
#endif

struct cobj_class *stream_cls, *stdio_stream_cls;

const wchli_t *path_sep_chars = wli("/");
wchar_t path_var_sep_char = ':';

val top_stderr;

static val shell, shell_arg;

void strm_base_init(struct strm_base *s)
{
  static struct strm_base init = { indent_off, 60, 10, 0, 0, 0, 0, 0, nil, 0 };
  *s = init;
}

void strm_base_cleanup(struct strm_base *s)
{
  bug_unless (s->ctx == 0);
}

void strm_base_mark(struct strm_base *s)
{
  if (s->close_result)
    gc_mark(s->close_result);
}

void stream_print_op(val stream, val out, val pretty, struct strm_ctx *ctx)
{
  val name = stream_get_prop(stream, name_k);
  (void) pretty;
  (void) ctx;
  format(out, lit("#<~a ~p>"), name, stream, nao);
}

void stream_destroy_op(val stream)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  strm_base_cleanup(s);
  free(s);
}

void stream_mark_op(val stream)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  strm_base_mark(s);
}

static NORETURN void unimpl(val stream, val op)
{
  uw_throwf(file_error_s, lit("~a: not supported by stream ~s"),
            op, stream, nao);
  abort();
}

static NORETURN val unimpl_put_string(val stream, val str)
{
  (void) str;
  unimpl(stream, lit("put-string"));
}

static NORETURN val unimpl_put_char(val stream, val ch)
{
  (void) ch;
  unimpl(stream, lit("put-char"));
}

static NORETURN val unimpl_put_byte(val stream, int byte)
{
  (void) byte;
  unimpl(stream, lit("put-byte"));
}

static NORETURN val unimpl_get_line(val stream)
{
  unimpl(stream, lit("get-line"));
}

static NORETURN val unimpl_get_char(val stream)
{
  unimpl(stream, lit("get-char"));
}

static NORETURN val unimpl_get_byte(val stream)
{
  unimpl(stream, lit("get-byte"));
}

static NORETURN val unimpl_unget_char(val stream, val ch)
{
  (void) ch;
  unimpl(stream, lit("unget-char"));
}

static NORETURN val unimpl_unget_byte(val stream, int byte)
{
  (void) byte;
  unimpl(stream, lit("unget-byte"));
}

static NORETURN ucnum unimpl_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  (void) ptr;
  (void) len;
  (void) pos;
  unimpl(stream, lit("put-buf"));
}

static NORETURN ucnum unimpl_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  (void) ptr;
  (void) len;
  (void) pos;
  unimpl(stream, lit("fill-buf"));
}

static NORETURN val unimpl_seek(val stream, val off, enum strm_whence whence)
{
  (void) off;
  (void) whence;
  unimpl(stream, lit("seek-stream"));
}

static NORETURN val unimpl_truncate(val stream, val len)
{
  (void) len;
  unimpl(stream, lit("truncate-stream"));
}

static NORETURN val unimpl_get_sock_family(val stream)
{
  unimpl(stream, lit("sock-family"));
}

static NORETURN val unimpl_get_sock_type(val stream)
{
  unimpl(stream, lit("sock-type"));
}

static NORETURN val unimpl_get_sock_peer(val stream)
{
  unimpl(stream, lit("sock-peer"));
}

static NORETURN val unimpl_set_sock_peer(val stream, val peer)
{
  (void) peer;
  unimpl(stream, lit("sock-set-peer"));
}

static val null_put_string(val stream, val str)
{
  (void) stream;
  (void) str;
  return nil;
}

static val null_put_char(val stream, val ch)
{
  (void) stream;
  (void) ch;
  return nil;
}

static val null_put_byte(val stream, int byte)
{
  (void) stream;
  (void) byte;
  return nil;
}

static val null_get_line(val stream)
{
  (void) stream;
  return nil;
}

static val null_get_char(val stream)
{
  (void) stream;
  return nil;
}

static val null_get_byte(val stream)
{
  (void) stream;
  return nil;
}

static val null_close(val stream, val throw_on_error)
{
  (void) stream;
  (void) throw_on_error;
  return nil;
}

static val null_flush(val stream)
{
  (void) stream;
  return nil;
}

static val null_seek(val stream, val off, enum strm_whence whence)
{
  (void) stream;
  (void) off;
  (void) whence;
  return nil;
}

static val null_get_prop(val stream, val ind)
{
  if (ind == name_k) {
    struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
    return static_str(ops->name);
  }

  return nil;
}

static val null_set_prop(val stream, val ind, val value)
{
  (void) stream;
  (void) ind;
  (void) value;
  return nil;
}

static val null_get_error(val stream)
{
  (void) stream;
  return nil;
}

static val null_get_error_str(val stream)
{
  (void) stream;
  return nil;
}

static val null_clear_error(val stream)
{
  (void) stream;
  return nil;
}

static val null_get_fd(val stream)
{
  (void) stream;
  return nil;
}

static ucnum generic_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
  ucnum i;

  if (pos >= len)
    return len;

  for (i = pos; i < len; i++)
    ops->put_byte(stream, *ptr++);

  if (i > len)
    i = len;

  return i;
}

static ucnum generic_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  val self = lit("fill-buf");
  struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
  ucnum i;

  for (i = pos; i < len; i++) {
    val byte = ops->get_byte(stream);
    if (!byte)
      break;
    *ptr++ = c_num(byte, self);
  }

  if (i > len)
    i = len;

  return i;
}

void fill_stream_ops(struct strm_ops *ops)
{
  if (!ops->put_string)
    ops->put_string = unimpl_put_string;
  if (!ops->put_char)
    ops->put_char = unimpl_put_char;
  if (!ops->put_byte)
    ops->put_byte = unimpl_put_byte;
  if (!ops->get_line)
    ops->get_line = unimpl_get_line;
  if (!ops->get_char)
    ops->get_char = unimpl_get_char;
  if (!ops->get_byte)
    ops->get_byte = unimpl_get_byte;
  if (!ops->unget_char)
    ops->unget_char = unimpl_unget_char;
  if (!ops->unget_byte)
    ops->unget_byte = unimpl_unget_byte;
  if (!ops->put_buf)
    ops->put_buf = (ops->get_byte ? generic_put_buf : unimpl_put_buf);
  if (!ops->fill_buf)
    ops->fill_buf = (ops->put_byte ? generic_fill_buf : unimpl_fill_buf);
  if (!ops->close)
    ops->close = null_close;
  if (!ops->flush)
    ops->flush = null_flush;
  if (!ops->seek)
    ops->seek = unimpl_seek;
  if (!ops->truncate)
    ops->truncate = unimpl_truncate;
  if (!ops->get_prop)
    ops->get_prop = null_get_prop;
  if (!ops->set_prop)
    ops->set_prop = null_set_prop;
  if (!ops->get_error)
    ops->get_error = null_get_error;
  if (!ops->get_error_str)
    ops->get_error_str = null_get_error_str;
  if (!ops->clear_error)
    ops->clear_error = null_clear_error;
  if (!ops->get_fd)
    ops->get_fd = null_get_fd;
  if (!ops->get_sock_family)
    ops->get_sock_family = unimpl_get_sock_family;
  if (!ops->get_sock_type)
    ops->get_sock_type = unimpl_get_sock_type;
  if (!ops->get_sock_peer)
    ops->get_sock_peer = unimpl_get_sock_peer;
  if (!ops->set_sock_peer)
    ops->set_sock_peer = unimpl_set_sock_peer;
}

struct dev_null {
  struct strm_base a;
  int fd;
};

static val dev_null_close(val stream, val throw_on_error)
{
  struct dev_null *n = coerce(struct dev_null *, stream->co.handle);
  (void) throw_on_error;
  if (n->fd != -1) {
    close(n->fd);
    n->fd = -1;
    return t;
  }
  return nil;
}

static val dev_null_get_fd(val stream)
{
  struct dev_null *n = coerce(struct dev_null *, stream->co.handle);
  if (n->fd == -1 && (n->fd = open("/dev/null", O_RDWR)) == -1) {
    int eno = errno;
    uw_ethrowf(errno_to_file_error(eno), lit("error opening /dev/null: ~d/~s"),
               num(eno), errno_to_str(eno), nao);
  }
  return num(n->fd);
}

static val dev_null_get_prop(val stream, val ind)
{
  if (ind == name_k)
    return null_get_prop(stream, ind);

  if (ind == fd_k)
    return dev_null_get_fd(stream);

  return nil;
}

static struct strm_ops null_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              stream_destroy_op,
                              stream_mark_op,
                              cobj_eq_hash_op,
                              0),
                wli("null-stream"),
                null_put_string, null_put_char, null_put_byte, null_get_line,
                null_get_char, null_get_byte,
                unimpl_unget_char, unimpl_unget_byte,
                unimpl_put_buf, unimpl_fill_buf,
                dev_null_close, null_flush, null_seek, unimpl_truncate,
                dev_null_get_prop, null_set_prop,
                null_get_error, null_get_error_str, null_clear_error,
                dev_null_get_fd);

val make_null_stream(void)
{
  struct dev_null *n = coerce(struct dev_null *, chk_malloc(sizeof *n));
  strm_base_init(&n->a);
  n->fd = -1;
  return cobj(coerce(mem_t *, n), stream_cls, &null_ops.cobj_ops);
}

#if CONFIG_STDIO_STRICT
enum stdio_op { stdio_none, stdio_read, stdio_write };
#endif

struct stdio_handle {
  struct strm_base a;
  FILE *f;
  val descr;
  val unget_c;
  utf8_decoder_t ud;
  val err;
  char *buf;
#if HAVE_FORK_STUFF
  pid_t pid;
#endif
  val mode; /* used by tail */
  unsigned is_rotated : 8; /* used by tail */
  unsigned is_real_time : 8;
  unsigned is_byte_oriented : 8;
#if CONFIG_STDIO_STRICT
  enum stdio_op last_op;
#endif
#if HAVE_SOCKETS
  val family;
  val type;
  val peer;
  val addr;
#endif
};

static void stdio_stream_print(val stream, val out, val pretty,
                               struct strm_ctx *ctx)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
  val name = static_str(ops->name);
  val descr = ops->get_prop(stream, name_k);

  (void) pretty;
  (void) ctx;

  if (h->pid)
    format(out, lit("#<~a ~a ~a ~p>"), name, descr, num(h->pid), stream, nao);
  else
    format(out, lit("#<~a ~a ~p>"), name, descr, stream, nao);
}

static void stdio_stream_destroy(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  close_stream(stream, nil);
  strm_base_cleanup(&h->a);
  free(h->buf);
  free(h);
}

static void stdio_stream_mark(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  strm_base_mark(&h->a);
  gc_mark(h->descr);
  gc_mark(h->mode);
  gc_mark(h->err);
#if HAVE_SOCKETS
  gc_mark(h->family);
  gc_mark(h->type);
  gc_mark(h->peer);
  gc_mark(h->addr);
#endif
}

val errno_to_string(val err)
{
  val self = lit("get-error-str");
  if (is_num(err))
    return errno_to_str(c_num(err, self));
  else if (!err)
    return lit("no error");
  else if (err == t)
    return lit("eof");
  else
    return lit("invalid error code");
}

static val stdio_maybe_read_error(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  if (h->f == 0)
    uw_throwf(file_error_s, lit("error reading ~s: file closed"), stream, nao);
  if (ferror(h->f)) {
    int eno = errno;
    val err = num(eno);
    h->err = err;
#ifdef EAGAIN
    if (eno == EAGAIN)
      uw_ethrowf(timeout_error_s, lit("timed out reading ~s"), stream, nao);
#endif
    uw_ethrowf(file_error_s, lit("error reading ~s: ~d/~s"),
               stream, err, errno_to_string(err), nao);
  }
  if (feof(h->f))
    h->err = t;
  return nil;
}

static val stdio_maybe_error(val stream, val action)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  val err = num(errno);
  if (h->f == 0)
    uw_ethrowf(file_error_s, lit("error ~a ~s: file closed"), action, stream, nao);
  h->err = err;
#ifdef EAGAIN
  if (errno == EAGAIN)
    uw_ethrowf(timeout_error_s, lit("timed out on ~s"), stream, nao);
#endif
  uw_ethrowf(file_error_s, lit("error ~a ~s: ~d/~s"),
             action, stream, err, errno_to_string(err), nao);
}

static int se_putc(int ch, FILE *f)
{
  int ret;
  sig_save_enable;
  ret = putc(ch, f);
  sig_restore_enable;
  return ret;
}

static int se_getc(FILE *f)
{
  int ret;
  sig_save_enable;
  ret = getc(f);
  sig_restore_enable;
  return ret;
}

static int se_fflush(FILE *f)
{
  int ret;
  sig_save_enable;
  ret = fflush(f);
  sig_restore_enable;
  return ret;
}

#if CONFIG_STDIO_STRICT
static void stdio_switch(struct stdio_handle *h, enum stdio_op op)
{
  if (h->last_op != op) {
    if (h->f) {
      switch (h->last_op) {
      case stdio_read:
        stdio_fseek(h->f, zero, strm_cur);
        break;
      case stdio_write:
        se_fflush(h->f);
        break;
      default:
        break;
      }
    }

    h->last_op = op;
  }
}
#else
#define stdio_switch(X, Y) ((void) 0)
#endif

static int stdio_put_char_callback(int ch, mem_t *f)
{
  int ret = se_putc(ch, coerce(FILE *, f)) != EOF;
  return ret;
}

static int stdio_get_char_callback(mem_t *f)
{
  return se_getc(coerce(FILE *, f));
}

static val stdio_put_string(val stream, val str)
{
  val self = lit("put-string");
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  errno = 0;

  if (h->f != 0) {
    const wchar_t *s = c_str(str, self);

    stdio_switch(h, stdio_write);

    while (*s) {
      if (!utf8_encode(*s++, stdio_put_char_callback, coerce(mem_t *, h->f)))
        return stdio_maybe_error(stream, lit("writing"));
    }
    return t;
  }
  return stdio_maybe_error(stream, lit("writing"));
}

static val stdio_put_char(val stream, val ch)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  errno = 0;
  stdio_switch(h, stdio_write);
  return h->f != 0 && utf8_encode(c_chr(ch), stdio_put_char_callback,
                                  coerce(mem_t *, h->f))
         ? t : stdio_maybe_error(stream, lit("writing"));
}

static val stdio_put_byte(val stream, int b)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  errno = 0;
  stdio_switch(h, stdio_write);
  return h->f != 0 && se_putc(b, coerce(FILE *, h->f)) != EOF
         ? t : stdio_maybe_error(stream, lit("writing"));
}

static val stdio_flush(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  errno = 0;
#if CONFIG_STDIO_STRICT
  if (h->f && h->last_op != stdio_write)
    return t;
#endif
  return (h->f != 0 && se_fflush(h->f) == 0)
         ? t : stdio_maybe_error(stream, lit("flushing"));
}

static val stdio_seek(val stream, val offset, enum strm_whence whence)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  errno = 0;

  if (h->f != 0) {
    if (offset == zero && whence == strm_cur) {
      return stdio_ftell(h->f);
    } else {
      if (stdio_fseek(h->f, offset, whence)) {
        utf8_decoder_init(&h->ud);
        h->unget_c = nil;
        return t;
      }
    }
  }

  return stdio_maybe_error(stream, lit("seeking"));
}

static val stdio_get_prop(val stream, val ind)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  if (ind == real_time_k) {
    return h->is_real_time ? t : nil;
  } else if (ind == name_k) {
    return h->descr;
  } else if (ind == byte_oriented_k) {
    return h->is_byte_oriented ? t : nil;
  }
  return nil;
}

static val stdio_set_prop(val stream, val ind, val prop)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  if (ind == real_time_k) {
    h->is_real_time = prop ? 1 : 0;
    return t;
  } else if (ind == byte_oriented_k) {
    h->is_byte_oriented = prop ? 1 : 0;
    return t;
  } else if (ind == name_k) {
    h->descr = prop;
    return t;
  }
  return nil;
}

static val stdio_get_error(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  if (h->f != 0 && feof(h->f))
    return t;
  return h->err;
}

static val stdio_get_error_str(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  if (h->f != 0 && feof(h->f))
    return lit("eof");

  return errno_to_string(h->err);
}

static val stdio_clear_error(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  val ret = h->err;
  if (h->f != 0)
    clearerr(h->f);
  h->err = nil;
  return ret;
}

static val stdio_get_fd(val stream)
{
  val self = lit("stream-fd");
  struct stdio_handle *h = coerce(struct stdio_handle *,
                                  cobj_handle(self, stream, stdio_stream_cls));
  return h->f ? num(fileno(h->f)) : nil;
}

val generic_get_line(val stream)
{
  struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
  const size_t min_size = 512;
  size_t size = 0;
  size_t fill = 0;
  wchar_t *volatile buf = 0;
  val out = nil;

  uw_simple_catch_begin;

  for (;;) {
    val chr = ops->get_char(stream);
    wint_t ch = chr ? convert(wint_t, c_chr(chr)) : WEOF;

    if (ch == WEOF && buf == 0)
      break;

    if (fill >= size) {
      size_t newsize = size ? size * 2 : min_size;
      buf = coerce(wchar_t *, chk_grow_vec(coerce(mem_t *, buf),
                                           size, newsize, sizeof *buf));
      size = newsize;
    }

    if (ch == '\n' || ch == WEOF) {
      buf[fill++] = 0;
      break;
    }
    buf[fill++] = ch;
  }

  /* Trim to actual size */
  if (buf) {
    wchar_t *sbuf = coerce(wchar_t *, chk_realloc(coerce(mem_t *, buf),
                                                  fill * sizeof *buf));
    if (sbuf)
      buf = sbuf;

    out = string_own(buf);
    buf = 0;
  }

  uw_unwind {
    free(buf);
  }

  uw_catch_end;

  return out;
}

static val stdio_get_char(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  if (h->unget_c)
    return rcyc_pop(&h->unget_c);

  if (h->f) {
    wint_t ch;

    stdio_switch(h, stdio_read);

    if (h->is_byte_oriented) {
      ch = se_getc(h->f);
      if (ch == 0)
        ch = 0xDC00;
    } else {
        ch = utf8_decode(&h->ud, stdio_get_char_callback,
                         coerce(mem_t *, h->f));
    }

    return (ch != WEOF) ? chr(ch) : stdio_maybe_read_error(stream);
  }
  return stdio_maybe_read_error(stream);
}

static val stdio_get_byte(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  stdio_switch(h, stdio_read);

  if (h->f) {
    int ch = se_getc(h->f);
    return (ch != EOF) ? num(ch) : stdio_maybe_read_error(stream);
  }
  return stdio_maybe_read_error(stream);
}

static val stdio_unget_char(val stream, val ch)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  mpush(ch, mkloc(h->unget_c, stream));
  return ch;
}

static val stdio_unget_byte(val stream, int byte)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  errno = 0;
  return h->f != 0 && ungetc(byte, coerce(FILE *, h->f)) != EOF
         ? num_fast(byte)
         : stdio_maybe_error(stream, lit("writing"));
}

static ucnum stdio_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  val self = lit("put-buf");
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  if (convert(size_t, len) != len || len > INT_PTR_MAX)
    uw_throwf(error_s, lit("~a: buffer too large"), self, nao);
  if (pos >= len)
    return len;
  errno = 0;
  if (h->f != 0) {
    cnum nwrit = fwrite(ptr + pos, 1, len - pos, h->f);
    if (nwrit > 0)
      return pos + nwrit;
  }
  stdio_maybe_error(stream, lit("writing"));
  return 0;
}

static ucnum stdio_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  val self = lit("fill-buf");
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  if (convert(size_t, len) != len || len > INT_PTR_MAX)
    uw_throwf(error_s, lit("~a: buffer too large"), self, nao);
  if (pos >= len)
    return len;
  errno = 0;
  if (h->f != 0) {
    cnum nread = fread(ptr + pos, 1, len - pos, h->f);
    if (nread > 0)
      return pos + nread;
  }
  stdio_maybe_read_error(stream);
  return pos;
}

static val stdio_close(val stream, val throw_on_error)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  if (h->f != 0 && h->f != stdin && h->f != stdout && h->f != stderr) {
    int result = fclose(h->f);
    h->f = 0;
    if (result == EOF && default_null_arg(throw_on_error)) {
      h->err = num(errno);
      uw_ethrowf(file_error_s, lit("error closing ~s: ~d/~s"),
                 stream, num(errno), errno_to_str(errno), nao);
    }
    return result != EOF ? t : nil;
  }
  return nil;
}

#if HAVE_FTRUNCATE || HAVE_CHSIZE
static val stdio_truncate(val stream, val len)
{
  val self = lit("truncate-stream");
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  cnum l = c_num(len, self);
#if HAVE_FTRUNCATE
  typedef off_t trunc_off_t;
  int (*truncfun)(int, off_t) = ftruncate;
#else
  typedef long trunc_off_t;
  int (*truncfun)(int, long) = chsize;
#endif

  if (convert(cnum, convert(trunc_off_t, l)) != l)
    uw_throwf(error_s, lit("truncate-stream: ~s is too large"), len, nao);

  return (h->f != 0 && truncfun(fileno(h->f), l) == 0)
         ? t
         : stdio_maybe_error(stream, lit("truncating"));
}
#else
#define stdio_truncate unimpl_truncate
#endif

#if HAVE_SOCKETS

static val sock_get_prop(val stream, val ind)
{
  if (ind == addr_k) {
    struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
    return h->addr;
  }

  if (ind == name_k) {
    struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

    if (!h->f)
      return h->descr = lit("closed");

    if (h->descr)
      return h->descr;

    if (h->addr)
      return set(mkloc(h->descr, stream),
                 format(nil, lit("passive ~s"), h->addr, nao));

    if (h->peer)
      return set(mkloc(h->descr, stream),
                 format(nil, lit("active ~s"), h->peer, nao));

    return h->descr = lit("disconnected");
  }

  return stdio_get_prop(stream, ind);
}

static val sock_set_prop(val stream, val ind, val prop)
{
  if (ind == addr_k) {
    struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
    set(mkloc(h->addr, stream), prop);
    h->descr = nil;
    return t;
  }

  return stdio_set_prop(stream, ind, prop);
}

static val stdio_get_sock_family(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  return h->family;
}

static val stdio_get_sock_type(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  return h->type;
}

static val stdio_get_sock_peer(val stream)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  return h->peer;
}

static val stdio_set_sock_peer(val stream, val peer)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  h->descr = nil;
  return set(mkloc(h->peer, stream), peer);
}

#endif

static struct strm_ops stdio_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stdio_stream_print,
                              stdio_stream_destroy,
                              stdio_stream_mark,
                              cobj_eq_hash_op,
                              0),
                wli("file-stream"),
                stdio_put_string,
                stdio_put_char,
                stdio_put_byte,
                generic_get_line,
                stdio_get_char,
                stdio_get_byte,
                stdio_unget_char,
                stdio_unget_byte,
                stdio_put_buf,
                stdio_fill_buf,
                stdio_close,
                stdio_flush,
                stdio_seek,
                stdio_truncate,
                stdio_get_prop,
                stdio_set_prop,
                stdio_get_error,
                stdio_get_error_str,
                stdio_clear_error,
                stdio_get_fd);

#if HAVE_SOCKETS
static struct strm_ops stdio_sock_ops;
#endif

#if HAVE_FCNTL
int w_open_mode(const wchar_t *wname, const struct stdio_mode m)
{
  char *name = utf8_dup_to(wname);
  size_t nsiz = strlen(name) + 1;
  int flags = (if3(m.read && m.write, O_RDWR, 0) |
               if3(m.read && !m.write, O_RDONLY, 0) |
               if3(!m.read && m.write, O_WRONLY, 0) |
               if3(m.create, if3(!m.notrunc, O_TRUNC, 0) | O_CREAT, 0) |
               if3(m.append, O_APPEND, 0) |
               if3(m.excl, O_EXCL, 0) |
#if O_TMPFILE
               if3(m.tmpfile, O_TMPFILE, 0) |
#endif
               if3(m.nonblock, O_NONBLOCK, 0));
  char *stkname = coerce(char *, alloca(nsiz));
  int fd;

  memcpy(stkname, name, nsiz);
  free(name);

  sig_save_enable;
  fd = open(stkname, flags, 0666);
  sig_restore_enable;

  return fd;
}
#endif

static FILE *w_fopen_mode(const wchar_t *wname, const wchar_t *mode,
                          const struct stdio_mode m)
{
#if HAVE_FCNTL
  int fd = w_open_mode(wname, m);
  return (fd < 0) ? NULL : w_fdopen(fd, mode);
#else
  /* TODO: detect if fopen supports "x" in mode */
  if (m.notrunc || m.excl || m.nonblock)
    uw_throwf(file_error_s,
              lit("open-file: specified mode not supported on this system"),
                  nao);
  return w_fopen(wname, mode);
#endif
}


static void tail_calc(unsigned long *state, int *usec, int *mod)
{
  unsigned long count = (*state)++;
  if (count > 32)
    count = 32;
  *usec = 1048576 << (count / 8);
  *mod = 8 >> (count / 8);
  if (*mod == 0)
    *mod = 1;
}

static void tail_strategy(val stream, unsigned long *state)
{
  val self = lit("open-tail");
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  int usec = 0, mod = 0;
  val mode = nil;
  struct stdio_mode m, m_r = stdio_mode_init_r;

  tail_calc(state, &usec, &mod);

  if (h->is_rotated) {
    /* We already know that the file has rotated. The caller
     * has read through to the end of the old open file, and
     * so we can close it now and open a new file.
     */
    fclose(h->f);
    h->f = 0;
    h->is_rotated = 0;
  } else if (h->f != 0) {
    /* We have a file and it hasn't rotated; so sleep on it. */
    sig_save_enable;
    usleep_wrap(num(usec));
    sig_restore_enable;
  }

  /* If the state indicates we should poll for a file rotation,
   * or we have no file ...
   */
  if (h->f == 0 || *state % mod == 0) {
    long save_pos = 0, size;

    if (h->f != 0 && (save_pos = ftell(h->f)) == -1)
      return;

    for (;;) {
      FILE *newf;

      if (!mode)
        mode = normalize_mode(&m, h->mode, m_r,  self);

      /* Try to open the file.
       */
      if (!(newf = w_fopen_mode(c_str(h->descr, self), c_str(mode, self), m))) {
        /* If already have the file open previously, and the name
         * does not open any more, then the file has rotated.
         * Have the caller try to read the last bit of data
         * from the old h->f.
         */
        if (h->f) {
          h->is_rotated = 1;
          return;
        }

        /* Unable to open; keep trying. */
        tail_calc(state, &usec, &mod);
        sig_save_enable;
        usleep_wrap(num(usec));
        sig_restore_enable;
        continue;
      }

      /* We opened the new file. If we have no old file,
       * then this is all we have.
       */
      if (!h->f) {
        h->f = newf;
#if CONFIG_STDIO_STRICT
        h->last_op = stdio_none;
#endif
        (void) set_mode_props(m, stream);
        break;
      }

      /* Obtain size of new file. If we can't, then let's just pretend we never
       * opened it and bail out.
       */
      if (fseek(newf, 0, SEEK_END) == -1 || (size = ftell(newf)) == -1) {
        fclose(newf);
        return;
      }

      /* The newly opened file is smaller than the previously opened
       * file. The file has rotated and is quite possibly a new object.
       * We just close newf, and let the caller read the last bit of data from
       * the old stream before cutting over.
       */
      if (size < save_pos) {
        /* TODO: optimize: keep newf in the handle so as not to have to
           re-open it again. */
        h->is_rotated = 1;
        fclose(newf);
        return;
      }

      /* Newly opened file is not smaller. We take a gamble and say
       * that it's the same object as h->f, since rotating files
       * are usually large and it is unlikely that it is a new file
       * which has grown larger than the original. Just in case,
       * though, we take the new file handle. But we do not reset
       * the UTF8 machine.
       */
      if (save_pos)
        fseek(newf, save_pos, SEEK_SET);
      fclose(h->f);
      h->f = newf;
#if CONFIG_STDIO_STRICT
      h->last_op = stdio_none;
#endif
      (void) set_mode_props(m, stream);
      return;
    }

    utf8_decoder_init(&h->ud);
  }
}

static val tail_get_line(val stream)
{
  unsigned long state = 0;
  val ret;

  while ((ret = generic_get_line(stream)) == nil)
    tail_strategy(stream, &state);

  return ret;
}

static val tail_get_char(val stream)
{
  unsigned long state = 0;
  val ret;

  while ((ret = stdio_get_char(stream)) == nil)
    tail_strategy(stream, &state);

  return ret;
}

static val tail_get_byte(val stream)
{
  unsigned long state = 0;
  val ret;

  while ((ret = stdio_get_byte(stream)) == nil)
    tail_strategy(stream, &state);

  return ret;
}

static struct strm_ops tail_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stdio_stream_print,
                              stdio_stream_destroy,
                              stdio_stream_mark,
                              cobj_eq_hash_op,
                              0),
                wli("tail-stream"),
                stdio_put_string,
                stdio_put_char,
                stdio_put_byte,
                tail_get_line,
                tail_get_char,
                tail_get_byte,
                stdio_unget_char,
                stdio_unget_byte,
                stdio_put_buf,
                stdio_fill_buf,
                stdio_close,
                stdio_flush,
                stdio_seek,
                stdio_truncate,
                stdio_get_prop,
                stdio_set_prop,
                stdio_get_error,
                stdio_get_error_str,
                stdio_clear_error,
                stdio_get_fd);

#if HAVE_FORK_STUFF
static int pipevp_close(FILE *f, pid_t pid)
{
  int status;
  fclose(f);
  sig_save_enable;
  while (waitpid(pid, &status, 0) == -1 && errno == EINTR)
    ;
  sig_restore_enable;
  return status;
}

val pipe_close_status_helper(val stream, val throw_on_error,
                             int status, val self)
{
  if (status < 0) {
    if (throw_on_error)
      uw_ethrowf(process_error_s,
                 lit("~a: stream ~s: unable to obtain status of process: ~d/~s"),
                 self, stream, num(errno), errno_to_str(errno), nao);
    return nil;
  } else {
#if HAVE_SYS_WAIT
    if (WIFEXITED(status)) {
      int exitstatus = WEXITSTATUS(status);
      return num(exitstatus);
    } else if (default_null_arg(throw_on_error)) {
      if (WIFSIGNALED(status)) {
        int termsig = WTERMSIG(status);
        uw_throwf(process_error_s, lit("~a: stream ~s: process terminated by signal ~a"),
                  self, stream, num(termsig), nao);
      }
    }
#endif
    return status == 0 ? zero : nil;
  }
}

static val pipe_close(val stream, val throw_on_error)
{
  val self = lit("close-stream");
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

  if (h->f != 0) {
    int status = pipevp_close(h->f, h->pid);
    h->f = 0;

    return pipe_close_status_helper(stream, throw_on_error, status, self);
  }

  return nil;
}

static struct strm_ops pipe_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stdio_stream_print,
                              stdio_stream_destroy,
                              stdio_stream_mark,
                              cobj_eq_hash_op,
                              0),
                wli("pipe-stream"),
                stdio_put_string,
                stdio_put_char,
                stdio_put_byte,
                generic_get_line,
                stdio_get_char,
                stdio_get_byte,
                stdio_unget_char,
                stdio_unget_byte,
                stdio_put_buf,
                stdio_fill_buf,
                pipe_close,
                stdio_flush,
                0, /* seek: not on pipes */
                0, /* truncate: not on pipes */
                stdio_get_prop,
                stdio_set_prop,
                stdio_get_error,
                stdio_get_error_str,
                stdio_clear_error,
                stdio_get_fd);
#endif

static struct stdio_mode do_parse_mode(val mode_str, struct stdio_mode m_dfl,
                                       val self)
{
  struct stdio_mode m = stdio_mode_init_blank;
  const wchar_t *ms = c_str(default_arg_strict(mode_str, null_string), self);
  int nredir = 0;

  switch (*ms) {
  case 'r':
    ms++;
    m.read = 1;
    break;
  case 'w':
    ms++;
    m.write = 1;
    m.create = 1;
    break;
  case 'a':
    ms++;
    m.write = 1;
    m.create = 1;
    m.append = 1;
    m.notrunc = 1;
    break;
  case 'm':
    ms++;
    m.write = 1;
    m.create = 1;
    m.notrunc = 1;
    break;
  case 'T':
    ms++;
#if O_TMPFILE
    m.read = 1;
    m.write = 1;
    m.tmpfile = 1;
#else
    m.malformed = 1;
#endif
    break;
  default:
    break;
  }

  if (*ms == '+') {
    ms++;
    m.read = 1;
    m.write = 1;
  }

  if (!m.read && !m.write)
    m = m_dfl;

  for (; *ms; ms++) {
    switch (*ms) {
    case 'b':
      m.binary = 1;
      break;
    case 'x':
      /* Ensure only "w" and "w+" can have the "x" option. */
      if (!m.write || !m.create || m.notrunc) {
        m.malformed = 1;
        return m;
      }
      m.excl = 1;
      break;
    case 'i':
      m.interactive = 1;
      break;
    case 'l':
      if (m.unbuf) {
        m.malformed = 1;
        return m;
      }
      m.linebuf = 1;
      break;
    case 'u':
      if (m.linebuf) {
        m.malformed = 1;
        return m;
      }
      m.unbuf = 1;
      break;
    case 'n':
      m.nonblock = 1;
      break;
    case '0': case '1': case '2': case '3': case '4':
    case '5': case '6': case '7': case '8': case '9':
      if (m.unbuf) {
        m.malformed = 1;
        return m;
      }
      m.buforder = *ms - '0';
      break;
    case '>':
      if (nredir >= STDIO_MODE_NREDIRS) {
        m.malformed = 1;
        return m;
      }

      if (ms[1] != '(') {
        if (!isdigit(convert(unsigned char, ms[1])) || !ms[2]) {
          m.malformed = 1;
          return m;
        }

        m.redir[nredir][0] = ms[1] - '0';
        if (isdigit(convert(unsigned char, ms[2]))) {
          m.redir[nredir][1] = ms[2] - '0';
        } else switch (ms[2]) {
        case 'n': case 'x':
          m.redir[nredir][1] = ms[2];
          break;
        default:
          m.malformed = 1;
          return m;
        }

        ms += 2;
        nredir++;
        break;
      }

      {
        char code[2];
        char rpar[2];
        unsigned to, from;

        if (swscanf(ms, L">(%u %[nx]%[)]", &to, code, rpar) == 3) {
          m.redir[nredir][0] = to;
          m.redir[nredir][1] = code[0];
        } else if (swscanf(ms, L">(%u %u%[)]", &to, &from, rpar) == 3) {
          m.redir[nredir][0] = to;
          m.redir[nredir][1] = from;
        } else {
          m.malformed = 1;
          return m;
        }

        ms = wcschr(ms, ')');
        nredir++;
        break;
      }
    case '?':
      {
        wchar_t *past;
        long val = wcstol(ms + 1, &past, 10);

        if (past == ms + 1 || val < 0 || val >= INT_MAX) {
          m.malformed = 1;
          return m;
        }

        m.streamfd = val;
        ms = past - 1;
        break;
      }
    case 'z':
      m.gzip = 1;
      if (isdigit(convert(unsigned char, ms[1]))) {
        m.gzlevel = *++ms - '0';
        break;
      }
      break;
    default:
      m.malformed = 1;
      return m;
    }
  }

  if (nredir < STDIO_MODE_NREDIRS)
    m.redir[nredir][0] = -1;

  return m;
}

struct stdio_mode parse_mode(val mode_str, struct stdio_mode m_dfl, val self)
{
  struct stdio_mode m = do_parse_mode(mode_str, m_dfl, self);
  if (m.malformed)
    uw_throwf(file_error_s, lit("~a: invalid mode string ~s"), self,
              mode_str, nao);
  return m;
}

static val format_mode(const struct stdio_mode m)
{
  wchar_t buf[8], *ptr = buf;

  if (m.malformed)
    return lit("###");

  if (m.append) {
    *ptr++ = 'a';
    if (m.read)
      *ptr++ = '+';
  } else if (m.create) {
    *ptr++ = 'w';
    if (m.read)
      *ptr++ = '+';
  } else {
    *ptr++ = 'r';
    if (m.write)
      *ptr++ = '+';
  }

  if (m.binary && !m.gzip)
    *ptr++ = 'b';

  if (m.gzip && m.gzlevel)
    *ptr++ = '0' + m.gzlevel;

#ifdef __CYGWIN__
  if (!m.gzip && !m.binary && (opt_compat == 144 || opt_compat == 145))
    *ptr++ = 't';
#endif

  *ptr = 0;
  return string(buf);
}

val normalize_mode(struct stdio_mode *m, val mode_str, struct stdio_mode m_dfl,
                   val self)
{
  *m = do_parse_mode(mode_str, m_dfl, self);

  if (m->malformed)
    uw_throwf(file_error_s, lit("~a: invalid file open mode ~s"),
              self, mode_str, nao);

  return format_mode(*m);
}

val normalize_mode_no_bin(struct stdio_mode *m, val mode_str,
                          struct stdio_mode m_dfl, val self)
{
#ifdef __CYGWIN__
  return normalize_mode(m, mode_str, m_dfl, self);
#else
  *m = do_parse_mode(mode_str, m_dfl, self);

  if (m->malformed)
    uw_throwf(file_error_s, lit("~a: invalid file open mode ~s"),
              self, mode_str, nao);

  m->binary = 0;

  return format_mode(*m);
#endif
}

val set_mode_props(const struct stdio_mode m, val stream)
{
  if (m.interactive || m.linebuf || m.unbuf || m.buforder != -1) {
    struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);

    if (h->f) {
      int size = m.buforder == -1 ? 0 : 1024 << m.buforder;

      if (h->buf) {
        free(h->buf);
        h->buf = 0;
      }

      if (size)
        h->buf = coerce(char *, chk_malloc(size));

      if (m.write && (m.linebuf || (m.interactive && !m.unbuf)))
        setvbuf(h->f, h->buf, _IOLBF, size);
      else if (m.unbuf)
        setbuf(h->f, 0);
      else if (size)
        setvbuf(h->f, h->buf, _IOFBF, size);
    }

    if (m.interactive)
      stream_set_prop(stream, real_time_k, t);
  }
  return stream;
}

static val make_stdio_stream_common(FILE *f, val descr, struct cobj_ops *ops)
{
  struct stdio_handle *h = coerce(struct stdio_handle *, chk_malloc(sizeof *h));
  val stream = cobj(coerce(mem_t *, h), stdio_stream_cls, ops);
  strm_base_init(&h->a);
  h->f = f;
  h->descr = descr;
  h->unget_c = nil;
  utf8_decoder_init(&h->ud);
  h->err = nil;
  h->buf = 0;
  h->pid = 0;
  h->mode = nil;
  h->is_rotated = 0;
#if HAVE_ISATTY
  h->is_real_time = if3(opt_compat && opt_compat <= 105,
                        (h->f != 0 && isatty(fileno(h->f)) == 1), 0);
#else
  h->is_real_time = 0;
#endif
  h->is_byte_oriented = 0;
#if CONFIG_STDIO_STRICT
  h->last_op = stdio_none;
#endif
#if HAVE_SOCKETS
  h->family = nil;
  h->type = nil;
  h->peer = nil;
  h->addr = nil;
#endif
  return stream;
}

val make_stdio_stream(FILE *f, val descr)
{
  return make_stdio_stream_common(f, descr, &stdio_ops.cobj_ops);
}

val make_tail_stream(FILE *f, val descr)
{
  val stream = make_stdio_stream_common(f, descr, &tail_ops.cobj_ops);
  stream_set_prop(stream, real_time_k, t);
  return stream;
}

#if HAVE_SOCKETS
val make_sock_stream(FILE *f, val family, val type)
{
  val s = make_stdio_stream_common(f, nil, &stdio_sock_ops.cobj_ops);
  struct stdio_handle *h = coerce(struct stdio_handle *, s->co.handle);
  h->family = family;
  h->type = type;
  return s;
}
#endif

val stream_fd(val stream)
{
  val self = lit("fileno");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_fd(stream);
}

#if HAVE_SOCKETS
val sock_family(val stream)
{
  val self = lit("sock-family");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_sock_family(stream);
}

val sock_type(val stream)
{
  val self = lit("sock-type");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_sock_type(stream);
}

val sock_peer(val stream)
{
  val self = lit("sock-peer");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_sock_peer(stream);
}

val sock_set_peer(val stream, val peer)
{
  val self = lit("sock-set-peer");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->set_sock_peer(stream, peer);
}
#endif

#if HAVE_FORK_STUFF
static val make_pipevp_stream(FILE *f, val descr, pid_t pid)
{
  val stream = make_stdio_stream_common(f, descr, &pipe_ops.cobj_ops);
  struct stdio_handle *h = coerce(struct stdio_handle *, stream->co.handle);
  h->pid = pid;
  return stream;
}
#endif

struct dir_handle {
  struct strm_base a;
  DIR *d;
  val err;
};

static void dir_destroy(val stream)
{
  struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);
  strm_base_cleanup(&h->a);
  close_stream(stream, nil);
  free(h);
}

static void dir_mark(val stream)
{
  struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);
  strm_base_mark(&h->a);
  gc_mark(h->err);
}

static val dir_get_line(val stream)
{
  struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);

  if (h->d == 0) {
    return nil;
  } else {
    for (;;) {
      struct dirent *e = readdir(h->d);
      if (!e) {
        h->err = num(errno);
        return nil;
      }
      if (!strcmp(e->d_name, ".") || !strcmp(e->d_name, ".."))
        continue;
      return string_utf8(e->d_name);
    }
  }
}

static val dir_close(val stream, val throw_on_error)
{
  struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);
  (void) throw_on_error;

  if (h->d != 0) {
    closedir(coerce(DIR *, h->d));
    h->d = 0;
    return t;
  }

  return nil;
}

static val dir_get_error(val stream)
{
  struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);
  return h->err;
}

static val dir_get_error_str(val stream)
{
  struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);
  return errno_to_string(h->err);
}

static val dir_clear_error(val stream)
{
  struct dir_handle *h = coerce(struct dir_handle *, stream->co.handle);
  val ret = h->err;
  h->err = nil;
  return ret;
}

static struct strm_ops dir_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              dir_destroy,
                              dir_mark,
                              cobj_eq_hash_op,
                              0),
                wli("dir-stream"),
                0, 0, 0,
                dir_get_line,
                0, 0, 0, 0, 0, 0,
                dir_close,
                0, 0, 0, 0, 0,
                dir_get_error,
                dir_get_error_str,
                dir_clear_error,
                0);

static val make_dir_stream(DIR *dir)
{
  struct dir_handle *h = coerce(struct dir_handle *, chk_malloc(sizeof *h));
  strm_base_init(&h->a);
  h->d = dir;
  h->err = nil;
  return cobj(coerce(mem_t *, h), stream_cls, &dir_ops.cobj_ops);
}

struct string_in {
  struct strm_base a;
  val string;
  val pos;
};

static void string_in_stream_mark(val stream)
{
  struct string_in *s = coerce(struct string_in *, stream->co.handle);
  strm_base_mark(&s->a);
  gc_mark(s->string);
  gc_mark(s->pos);
}

static val find_char(val string, val start, val ch)
{
  for (; length_str_gt(string, start); start = succ(start))
    if (chr_str(string, start) == ch)
      return start;

  return nil;
}

static val string_in_get_line(val stream)
{
  struct string_in *s = coerce(struct string_in *, stream->co.handle);

  if (length_str_gt(s->string, s->pos)) {
    val nlpos = find_char(s->string, s->pos, chr('\n'));
    val result = sub_str(s->string, s->pos, nlpos);
    set(mkloc(s->pos, stream), nlpos ? plus(nlpos, one) : length_str(s->string));
    return result;
  }

  return nil;
}

static val string_in_get_char(val stream)
{
  struct string_in *s = coerce(struct string_in *, stream->co.handle);

  if (length_str_gt(s->string, s->pos)) {
    val pos = s->pos;
    set(mkloc(s->pos, stream), plus(pos, one));
    return chr_str(s->string, pos);
  }

  return nil;
}

static val string_in_unget_char(val stream, val ch)
{
  struct string_in *s = coerce(struct string_in *, stream->co.handle);
  val pos = s->pos;

  if (pos == zero)
    uw_throwf(file_error_s,
              lit("unget-char: cannot push past beginning of string"), nao);

  pos = minus(pos, one);

  if (chr_str(s->string, pos) != ch)
    uw_throwf(file_error_s,
              lit("unget-char: ~s doesn't match the character that was read"),
              ch, nao);

  set(mkloc(s->pos, stream), pos);
  return ch;
}

static val string_in_get_prop(val stream, val ind)
{
  if (ind == name_k) {
    struct string_in *s = coerce(struct string_in *, stream->co.handle);
    struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
    val name = static_str(ops->name);
    return format(nil, lit("~a ~s"), name, s->string, nao);
  }

  return nil;
}

static val string_in_get_error(val stream)
{
  struct string_in *s = coerce(struct string_in *, stream->co.handle);
  return if2(ge(s->pos, length_str(s->string)), t);
}

static val string_in_get_error_str(val stream)
{
  return if3(string_in_get_error(stream), lit("eof"), lit("no error"));
}

static struct strm_ops string_in_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              stream_destroy_op,
                              string_in_stream_mark,
                              cobj_eq_hash_op,
                              0),
                wli("string-input-stream"),
                0, 0, 0,
                string_in_get_line,
                string_in_get_char,
                0,
                string_in_unget_char,
                0, 0, 0, 0, 0,
                0, /* TODO: seek */
                0, /* TODO: truncate */
                string_in_get_prop,
                0,
                string_in_get_error,
                string_in_get_error_str,
                0, 0);

val make_string_input_stream(val string)
{
  struct string_in *s = coerce(struct string_in *, chk_malloc(sizeof *s));
  strm_base_init(&s->a);
  s->string = string;
  s->pos = zero;
  return cobj(coerce(mem_t *, s), stream_cls, &string_in_ops.cobj_ops);
}

struct byte_input {
  struct strm_base a;
  unsigned char *buf;
  size_t size;
  size_t index;
};

static void byte_in_stream_destroy(val stream)
{
  struct byte_input *bi = coerce(struct byte_input *, stream->co.handle);
  strm_base_cleanup(&bi->a);
  free(bi->buf);
  bi->buf = 0;
  free(bi);
}

static val byte_in_get_byte(val stream)
{
  struct byte_input *bi = coerce(struct byte_input *, stream->co.handle);

  if (bi->index < bi->size)
    return num(bi->buf[bi->index++]);
  return nil;
}

static val byte_in_unget_byte(val stream, int byte)
{
  struct byte_input *bi = coerce(struct byte_input *, stream->co.handle);

  if (bi->index == 0)
    uw_throwf(file_error_s,
              lit("unget-byte: cannot push past beginning of byte stream"),
              nao);

  bi->buf[--bi->index] = byte;
  return num_fast(byte);
}

static val byte_in_get_error(val stream)
{
  struct byte_input *bi = coerce(struct byte_input *, stream->co.handle);
  return if3(bi->index < bi->size, nil, t);
}

static val byte_in_get_error_str(val stream)
{
  return if3(byte_in_get_error(stream), lit("eof"), lit("no error"));
}

static struct strm_ops byte_in_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              byte_in_stream_destroy,
                              stream_mark_op,
                              cobj_eq_hash_op,
                              0),
                wli("byte-input-stream"),
                0, 0, 0, 0, 0,
                byte_in_get_byte,
                0,
                byte_in_unget_byte, 0, 0,
                0, 0, 0, 0, 0, 0,
                byte_in_get_error,
                byte_in_get_error_str,
                0, 0);

val make_string_byte_input_stream(val string)
{
  val self = lit("make-string-byte-input-stream");
  type_assert (stringp(string), (lit("~a: ~s is not a string"), self, string, nao));

  {
    const wchar_t *wstring = c_str(string, self);
    struct byte_input *bi = coerce(struct byte_input *, chk_malloc(sizeof *bi));
    strm_base_init(&bi->a);
    bi->buf = utf8_dup_to_buf(wstring, &bi->size, 0);
    bi->index = 0;
    return cobj(coerce(mem_t *, bi), stream_cls, &byte_in_ops.cobj_ops);
  }
}

struct strlist_in {
  struct strm_base a;
  val string;
  val pos;
  val list;
};

static void strlist_in_stream_mark(val stream)
{
  struct strlist_in *s = coerce(struct strlist_in *, stream->co.handle);
  strm_base_mark(&s->a);
  gc_mark(s->string);
  gc_mark(s->pos);
  gc_mark(s->list);
}

static val strlist_in_get_line(val stream)
{
  struct strlist_in *s = coerce(struct strlist_in *, stream->co.handle);

  if (s->string) {
    val result = sub_str(s->string, s->pos, t);
    s->string = pop(&s->list);
    s->pos = zero;
    return result;
  }

  return nil;
}

static val strlist_in_get_char(val stream)
{
  struct strlist_in *s = coerce(struct strlist_in *, stream->co.handle);

  if (!s->string)
    return nil;

  if (length_str_le(s->string, s->pos)) {
    s->string = pop(&s->list);
    s->pos = zero;
    return chr('\n');
  } else {
    val pos = s->pos;
    set(mkloc(s->pos, stream), plus(pos, one));
    return chr_str(s->string, pos);
  }

  return nil;
}

static val strlist_in_unget_char(val stream, val ch)
{
  struct strlist_in *s = coerce(struct strlist_in *, stream->co.handle);
  val pos = s->pos;

  if (pos == zero) {
    if (ch == chr('\n')) {
      if (s->string)
        mpush(s->string, mkloc(s->list, stream));
      s->string = null_string;
    } else {
      if (!s->string)
        goto mismatch;
      set(mkloc(s->string, stream), scat(nil, ch, s->string, nao));
    }
    return ch;
  }

  pos = minus(pos, one);

  if (chr_str(s->string, pos) != ch)
    goto mismatch;

  set(mkloc(s->pos, stream), pos);
  return ch;
mismatch:
  uw_throwf(file_error_s,
            lit("unget-char: ~s doesn't match the character that was read"),
            ch, nao);
}

static val strlist_in_get_prop(val stream, val ind)
{
  if (ind == name_k) {
    struct strlist_in *s = coerce(struct strlist_in *, stream->co.handle);
    struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
    val name = static_str(ops->name);
    return format(nil, lit("~a ~s"), name, s->string, nao);
  }

  return nil;
}

static val strlist_in_get_error(val stream)
{
  struct strlist_in *s = coerce(struct strlist_in *, stream->co.handle);
  return if2(!s->string, t);
}

static val strlist_in_get_error_str(val stream)
{
  return if3(strlist_in_get_error(stream), lit("eof"), lit("no error"));
}

static struct strm_ops strlist_in_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              stream_destroy_op,
                              strlist_in_stream_mark,
                              cobj_eq_hash_op,
                              0),
                wli("strlist-input-stream"),
                0, 0, 0,
                strlist_in_get_line,
                strlist_in_get_char,
                0,
                strlist_in_unget_char,
                0, 0, 0, 0, 0,
                0, /* TODO: seek */
                0, /* TODO: truncate */
                strlist_in_get_prop,
                0,
                strlist_in_get_error,
                strlist_in_get_error_str,
                0, 0);

val make_strlist_input_stream(val list)
{
  struct strlist_in *s = coerce(struct strlist_in *, chk_calloc(sizeof *s, 1));
  val stream = cobj(coerce(mem_t *, s), stream_cls, &strlist_in_ops.cobj_ops);
  strm_base_init(&s->a);
  s->string = car(list);
  s->pos = zero;
  s->list = cdr(list);
  return stream;
}

struct string_out {
  struct strm_base a;
  wchar_t *buf;
  size_t size;
  size_t fill;
  utf8_decoder_t ud;
  unsigned char byte_buf[4];
  int head, tail;
};

static void string_out_stream_destroy(val stream)
{
  struct string_out *so = coerce(struct string_out *, stream->co.handle);

  strm_base_cleanup(&so->a);
  free(so->buf);
  so->buf = 0;
  free(so);
}

static int string_out_byte_callback(mem_t *ctx)
{
  struct string_out *so = coerce(struct string_out *, ctx);
  if (so->tail >= so->head)
    return EOF;
  return so->byte_buf[so->tail++];
}

static void string_out_extracted_error(val stream)
{
  uw_throwf(file_error_s, lit("output not possible on ~s: string extracted"),
            stream, nao);
}

static val string_out_put_char(val stream, val ch);

static val string_out_byte_flush(struct string_out *so, val stream)
{
  val result = nil;

  if (so->tail < so->head) {
    wint_t ch = utf8_decode(&so->ud, string_out_byte_callback,
                            coerce(mem_t *, so));
    int remaining = so->head - so->tail;
    if (remaining != 0)
      memmove(so->byte_buf, so->byte_buf + so->tail, remaining);
    so->head = so->tail = remaining;
    utf8_decoder_init(&so->ud);
    if (ch == WEOF)
      internal_error("unexpected WEOF from utf8_decode");
    result = string_out_put_char(stream, chr(ch));
    so->tail = 0;
  }
  return result;
}

static val string_out_put_string(val stream, val str)
{
  val self = lit("put-string");
  struct string_out *so = coerce(struct string_out *, stream->co.handle);

  if (so->buf == 0)
    string_out_extracted_error(stream);

  while (so->head != so->tail)
    string_out_byte_flush(so, stream);

  {
    const wchar_t *s = c_str(str, self);
    size_t len = c_num(length_str(str), self);
    size_t old_size = so->size;
    size_t required_size = len + so->fill + 1;

    if (required_size < len)
      goto oflow;

    while (so->size <= required_size) {
      so->size *= 2;
      if (so->size < old_size)
        goto oflow;
    }

    if (so->size != old_size)
      so->buf = coerce(wchar_t *, chk_grow_vec(coerce(mem_t *, so->buf),
                                               old_size, so->size,
                                               sizeof *so->buf));
    wmemcpy(so->buf + so->fill, s, len + 1);
    so->fill += len;
    return t;
oflow:
    uw_throwf(error_s, lit("~a: string output stream overflow"), self, nao);
  }
}

static val string_out_put_char(val stream, val ch)
{
  wchar_t onech[] = wini(" ");
  wref(onech)[0] = c_chr(ch);
  return string_out_put_string(stream,
                               auto_str(coerce(const wchli_t *, wref(onech))));
}

static val string_out_put_byte(val stream, int ch)
{
  struct string_out *so = coerce(struct string_out *, stream->co.handle);

  if (so->buf == 0)
    string_out_extracted_error(stream);

  so->byte_buf[so->head++] = ch;

  if (so->head >= convert(int, sizeof so->byte_buf))
    return string_out_byte_flush(so, stream);

  return t;
}

static struct strm_ops string_out_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              string_out_stream_destroy,
                              stream_mark_op,
                              cobj_eq_hash_op,
                              0),
                wli("string-output-stream"),
                string_out_put_string,
                string_out_put_char,
                string_out_put_byte,
                0, 0, 0, 0, 0, 0, 0, 0, 0,
                0, /* TODO: seek; fill-with-spaces semantics if past end. */
                0,
                0, 0, 0, 0, 0, 0);

val make_string_output_stream(void)
{
  struct string_out *so = coerce(struct string_out *, chk_malloc(sizeof *so));
  strm_base_init(&so->a);
  so->size = 128;
  so->buf = chk_wmalloc(so->size);
  so->fill = 0;
  so->buf[0] = 0;
  utf8_decoder_init(&so->ud);
  so->head = so->tail = 0;
  return cobj(coerce(mem_t *, so), stream_cls, &string_out_ops.cobj_ops);
}

val get_string_from_stream(val stream)
{
  val self = lit("get-string-from-stream");
  struct string_out *so = coerce(struct string_out *,
                                 cobj_handle(self, stream, stream_cls));

  if (stream->co.ops == &string_out_ops.cobj_ops) {
    val out = nil;
    wchar_t *buf;

    if (!so->buf)
      return out;

    while (so->head != so->tail)
      out = string_out_byte_flush(so, stream);

    /* Trim to actual size */
    buf = coerce(wchar_t *, chk_realloc(coerce(mem_t *, so->buf),
                                        (so->fill + 1) * sizeof *so->buf));
    so->buf = 0;
    out = string_own(buf);
    return out;
  } else {
    type_assert (stream->co.ops == &string_in_ops.cobj_ops,
                 (lit("~a: ~s is not a string stream"), self, stream, nao));
    {
      struct string_in *si = coerce(struct string_in *, stream->co.handle);
      return si->string;
    }
  }
}

struct strlist_out {
  struct strm_base a;
  val lines;
  val strstream;
};

static void strlist_out_mark(val stream)
{
  struct strlist_out *s = coerce(struct strlist_out *, stream->co.handle);
  strm_base_mark(&s->a);
  gc_mark(s->lines);
  gc_mark(s->strstream);
}

static val strlist_out_put_string(val stream, val str)
{
  struct strlist_out *s = coerce(struct strlist_out *, stream->co.handle);
  val lines = s->lines;
  val strstream = s->strstream;

  for (;;) {
    val length = length_str(str);
    val span_to_newline = compl_span_str(str, lit("\n"));

    if (zerop(length))
      break;

    put_string(sub_str(str, nil, span_to_newline), strstream);

    if (equal(span_to_newline, length))
      break;

    str = sub_str(str, plus(span_to_newline, num(1)), nil);
    push(get_string_from_stream(strstream), &lines);
    strstream = make_string_output_stream();
  }

  if (s->lines != lines) {
    set(mkloc(s->lines, stream), lines);
    set(mkloc(s->strstream, stream), strstream);
  }

  return t;
}

static val strlist_out_put_char(val stream, val ch)
{
  struct strlist_out *s = coerce(struct strlist_out *, stream->co.handle);
  val lines = s->lines;
  val strstream = s->strstream;

  if (ch == chr('\n')) {
    push(get_string_from_stream(strstream), &lines);
    strstream = make_string_output_stream();
    set(mkloc(s->lines, stream), lines);
    set(mkloc(s->strstream, stream), strstream);
  } else {
    put_char(ch, strstream);
  }

  return t;
}

static struct strm_ops strlist_out_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              stream_destroy_op,
                              strlist_out_mark,
                              cobj_eq_hash_op,
                              0),
                wli("strlist-output-stream"),
                strlist_out_put_string,
                strlist_out_put_char,
                0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0);

val make_strlist_output_stream(void)
{
  struct strlist_out *s = coerce(struct strlist_out *, chk_malloc(sizeof *s));
  val stream;
  val strstream = make_string_output_stream();
  strm_base_init(&s->a);
  s->lines = nil;
  s->strstream = nil;
  stream = cobj(coerce(mem_t *, s), stream_cls, &strlist_out_ops.cobj_ops);
  s->strstream = strstream;
  return stream;
}

val get_list_from_stream(val stream)
{
  val self = lit("get-list-from-stream");
  struct strlist_out *s = coerce(struct strlist_out *,
                                 cobj_handle(self, stream, stream_cls));

  if (stream->co.ops == &strlist_out_ops.cobj_ops) {
    val stray = get_string_from_stream(s->strstream);
    val lines = s->lines;
    if (!zerop(length_str(stray)))
      push(stray, &lines);
    return nreverse(lines);
  }

  type_mismatch(lit("~a: ~s is not a string list stream"), self, stream, nao);
}

struct cat_strm {
  struct strm_base a;
  val streams;
};

static void cat_stream_print(val stream, val out, val pretty,
                             struct strm_ctx *ctx)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
  val name = static_str(ops->name);

  (void) pretty;
  (void) ctx;

  format(out, lit("#<~a ~s>"), name, s->streams, nao);
}

static val cat_get_line(val stream)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  val streams = s->streams;

  while (streams) {
    val fs = first(streams);
    val line = get_line(fs);
    if (line)
      return line;
    if ((streams = rest(streams)) != nil) {
      close_stream(fs, t);
      set(mkloc(s->streams, stream), streams);
    }
  }

  return nil;
}

static val cat_get_char(val stream)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  val streams = s->streams;

  while (streams) {
    val fs = first(streams);
    val ch = get_char(fs);
    if (ch)
      return ch;
    if ((streams = rest(streams)) != nil) {
      close_stream(fs, t);
      set(mkloc(s->streams, stream), streams);
    }
  }

  return nil;
}

static val cat_get_byte(val stream)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  val streams = s->streams;

  while (streams) {
    val fs = first(streams);
    val byte = get_byte(fs);
    if (byte)
      return byte;
    if ((streams = rest(streams)) != nil) {
      close_stream(fs, t);
      set(mkloc(s->streams, stream), streams);
    }
  }

  return nil;
}

static val cat_unget_byte(val stream, int byte)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);

  if (!s->streams) {
    uw_throwf(file_error_s,
              lit("unget-byte on catenated stream ~s: stream list empty"),
              stream, nao);
  } else {
    val stream = car(s->streams);
    return unget_byte(num_fast(byte), stream);
  }

  return nil;
}

static val cat_unget_char(val stream, val ch)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);

  if (!s->streams) {
    uw_throwf(file_error_s,
              lit("unget-char on catenated stream ~s: stream list empty"),
              stream, nao);
  } else {
    val stream = car(s->streams);
    return unget_char(ch, stream);
  }
}

static val cat_get_prop(val stream, val ind)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);

  if (s->streams)
    return stream_get_prop(first(s->streams), ind);

  return nil;
}

static void cat_mark(val stream)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  strm_base_mark(&s->a);
  gc_mark(s->streams);
}

static val cat_get_error(val stream)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  return if3(s->streams, get_error(first(s->streams)), t);
}

static val cat_get_error_str(val stream)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  return if3(s->streams, get_error_str(first(s->streams)), lit("eof"));
}

static val cat_clear_error(val stream)
{
  struct cat_strm *s = coerce(struct cat_strm *, stream->co.handle);
  return if2(s->streams, clear_error(first(s->streams)));
}

static struct strm_ops cat_stream_ops =
  strm_ops_init(cobj_ops_init(eq,
                              cat_stream_print,
                              stream_destroy_op,
                              cat_mark,
                              cobj_eq_hash_op,
                              0),
                wli("catenated-stream"),
                0, 0, 0,
                cat_get_line,
                cat_get_char,
                cat_get_byte,
                cat_unget_char,
                cat_unget_byte,
                0, 0,
                0, 0, 0, 0,
                cat_get_prop,
                0,
                cat_get_error,
                cat_get_error_str,
                cat_clear_error,
                0);

val make_catenated_stream(val stream_list)
{
  struct cat_strm *s = coerce(struct cat_strm *, chk_malloc(sizeof *s));
  val catstrm = nil;
  strm_base_init(&s->a);
  s->streams = nil;
  catstrm = cobj(coerce(mem_t *, s), stream_cls, &cat_stream_ops.cobj_ops);
  s->streams = stream_list;
  return catstrm;
}

val make_catenated_stream_v(varg streams)
{
  return make_catenated_stream(args_get_list(streams));
}

val catenated_stream_p(val obj)
{
  return if2(streamp(obj), tnil(obj->co.ops == &cat_stream_ops.cobj_ops));
}

val catenated_stream_push(val new_stream, val cat_stream)
{
  val self = lit("catenated-stream-push");

  type_assert (streamp(new_stream),
               (lit("~a: ~s is not a stream"), self, new_stream, nao));
  type_assert (catenated_stream_p(cat_stream),
               (lit("~a: ~s is not a stream"), self, cat_stream, nao));

  {
    struct cat_strm *s = coerce(struct cat_strm *, cat_stream->co.handle);
    mpush(new_stream, mkloc(s->streams, cat_stream));
    return nil;
  }
}

struct delegate_base {
  struct strm_base a;
  val target_stream;
  struct strm_ops *target_ops;
};

static void delegate_base_mark(struct delegate_base *db)
{
  strm_base_mark(&db->a);
  gc_mark(db->target_stream);
}

static val delegate_put_string(val stream, val str)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->put_string(s->target_stream, str);
}

static val delegate_put_char(val stream, val ch)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->put_char(s->target_stream, ch);
}

static val delegate_put_byte(val stream, int byte)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->put_byte(s->target_stream, byte);
}

static val delegate_get_char(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_char(s->target_stream);
}

static val delegate_get_byte(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_byte(s->target_stream);
}

static val delegate_unget_char(val stream, val ch)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->unget_char(s->target_stream, ch);
}

static val delegate_unget_byte(val stream, int byte)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->unget_byte(s->target_stream, byte);
}

static ucnum delegate_put_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->put_buf(s->target_stream, ptr, len, pos);
}

static ucnum delegate_fill_buf(val stream, mem_t *ptr, ucnum len, ucnum pos)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->fill_buf(s->target_stream, ptr, len, pos);
}

static val delegate_close(val stream, val throw_on_error)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->close(s->target_stream, throw_on_error);
}

static val delegate_flush(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->flush(s->target_stream);
}

static val delegate_seek(val stream, val off, enum strm_whence whence)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->seek(s->target_stream, off, whence);
}

static val delegate_truncate(val stream, val len)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->truncate(s->target_stream, len);
}

static val delegate_get_prop(val stream, val ind)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_prop(s->target_stream, ind);
}

static val delegate_set_prop(val stream, val ind, val value)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->set_prop(s->target_stream, ind, value);
}

static val delegate_get_error(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_error(s->target_stream);
}

static val delegate_get_error_str(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_error_str(s->target_stream);
}

static val delegate_clear_error(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->clear_error(s->target_stream);
}

static val delegate_get_fd(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_fd(s->target_stream);
}

#if HAVE_SOCKETS

static val delegate_get_sock_family(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_sock_family(s->target_stream);
}

static val delegate_get_sock_type(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_sock_type(s->target_stream);
}

static val delegate_get_sock_peer(val stream)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->get_sock_peer(s->target_stream);
}

static val delegate_set_sock_peer(val stream, val peer)
{
  struct delegate_base *s = coerce(struct delegate_base *, stream->co.handle);
  return s->target_ops->set_sock_peer(s->target_stream, peer);
}

#endif

static val make_delegate_stream(val self, val orig_stream, size_t handle_size,
                                struct cobj_ops *ops)
{
  struct strm_ops *orig_ops = coerce(struct strm_ops *,
                                     cobj_ops(self, orig_stream, stream_cls));
  struct delegate_base *db = coerce(struct delegate_base *,
                                    chk_calloc(1, handle_size));
  val delegate_stream;

  strm_base_init(&db->a);
  db->target_stream = nil;
  db->target_ops = orig_ops;

  delegate_stream = cobj(coerce(mem_t *, db), stream_cls, ops);

  db->target_stream = orig_stream;

  return delegate_stream;
}

struct record_adapter_base {
  struct delegate_base db;
  val regex;
  val include_match;
};

static void record_adapter_base_mark(struct record_adapter_base *rb)
{
  delegate_base_mark(&rb->db);
  gc_mark(rb->regex);
}

static void record_adapter_mark_op(val stream)
{
  struct record_adapter_base *rb = coerce(struct record_adapter_base *,
                                         stream->co.handle);
  record_adapter_base_mark(rb);
}

static val record_adapter_get_line(val stream)
{
  struct record_adapter_base *rb = coerce(struct record_adapter_base *,
                                         stream->co.handle);
  return read_until_match(rb->regex, rb->db.target_stream, rb->include_match);
}

static struct strm_ops record_adapter_ops =
  strm_ops_init(cobj_ops_init(eq,
                              stream_print_op,
                              stream_destroy_op,
                              record_adapter_mark_op,
                              cobj_eq_hash_op,
                              0),
                wli("record-adapter"),
                delegate_put_string, delegate_put_char, delegate_put_byte,
                record_adapter_get_line, delegate_get_char, delegate_get_byte,
                delegate_unget_char, delegate_unget_byte,
                delegate_put_buf, delegate_fill_buf,
                delegate_close, delegate_flush, delegate_seek,
                delegate_truncate, delegate_get_prop, delegate_set_prop,
                delegate_get_error, delegate_get_error_str,
                delegate_clear_error, delegate_get_fd);

val record_adapter(val regex, val stream, val include_match)
{
  val self = lit("record-adapter");
  val rec_adapter = make_delegate_stream(self,
                                         default_arg_strict(stream, std_input),
                                         sizeof (struct record_adapter_base),
                                         &record_adapter_ops.cobj_ops);
  struct record_adapter_base *rb = coerce(struct record_adapter_base *,
                                          rec_adapter->co.handle);

  rb->regex = regex;
  rb->include_match = default_null_arg(include_match);
  return rec_adapter;
}

val streamp(val obj)
{
  return typep(obj, stream_s);
}

val stream_set_prop(val stream, val ind, val prop)
{
  val self = lit("stream-set-prop");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->set_prop(stream, ind, prop);
}

val stream_get_prop(val stream, val ind)
{
  val self = lit("stream-get-prop");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));

  if (ind == fd_k && ops->get_fd != null_get_fd)
    return ops->get_fd(stream);

  return ops->get_prop(stream, ind);
}

val real_time_stream_p(val obj)
{
  if (streamp(obj)) {
    struct strm_ops *ops = coerce(struct strm_ops *, obj->co.ops);
    return ops->get_prop(obj, real_time_k);
  }

  return nil;
}

val close_stream(val stream, val throw_on_error)
{
  val self = lit("close-stream");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  struct strm_ops *ops = coerce(struct strm_ops *, stream->co.ops);
  val res = s->close_result;

  if (!res) {
    res = ops->close(stream, throw_on_error);

    if (res == colon_k)
      res = t;
    else if (res)
      s->close_result = res;
  }

  return res;
}

val get_error(val stream)
{
  val self = lit("get-error");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_error(stream);
}

val get_error_str(val stream)
{
  val self = lit("get-error-str");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_error_str(stream);
}

val clear_error(val stream)
{
  val self = lit("clear-error");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->clear_error(stream);
}

val get_line(val stream_in)
{
  val self = lit("get-line");
  val stream = default_arg_strict(stream_in, std_input);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_line(stream);
}

val get_char(val stream_in)
{
  val self = lit("get-char");
  val stream = default_arg_strict(stream_in, std_input);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_char(stream);
}

val get_byte(val stream_in)
{
  val self = lit("get-byte");
  val stream = default_arg_strict(stream_in, std_input);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->get_byte(stream);
}

val get_bytes(val self, val stream_in, mem_t *ptr, ucnum len)
{
  val stream = default_arg_strict(stream_in, std_input);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return unum(ops->fill_buf(stream, ptr, len, 0));
}

val unget_char(val ch, val stream_in)
{
  val self = lit("unget-char");
  val stream = default_arg_strict(stream_in, std_input);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  if (!is_chr(ch))
    type_mismatch(lit("~a: ~s is not a character"), self, ch, nao);
  return ops->unget_char(stream, ch);
}

val unget_byte(val byte, val stream_in)
{
  val self = lit("unget-byte");
  cnum b = c_num(byte, self);
  val stream = default_arg_strict(stream_in, std_input);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));

  if (b < 0 || b > 255)
    uw_throwf(file_error_s, lit("~a: stream ~s: byte value ~a out of range"),
              self, stream, byte, nao);

  return ops->unget_byte(stream, b);
}

val put_buf(val buf, val pos_in, val stream_in)
{
  val self = lit("put-buf");
  val stream = default_arg_strict(stream_in, std_output);
  ucnum pos = c_unum(default_arg_strict(pos_in, zero), self);
  ucnum len = c_unum(length_buf(buf), self);
  mem_t *ptr = buf_get(buf, self);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));

  return unum(ops->put_buf(stream, ptr, len, pos));
}

val fill_buf(val buf, val pos_in, val stream_in)
{
  val self = lit("fill-buf");
  val stream = default_arg_strict(stream_in, std_input);
  ucnum pos = c_unum(default_arg_strict(pos_in, zero), self);
  ucnum len = c_unum(length_buf(buf), self);
  mem_t *ptr = buf_get(buf, self);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return unum(ops->fill_buf(stream, ptr, len, pos));
}

val fill_buf_adjust(val buf, val pos_in, val stream_in)
{
  val self = lit("fill-buf-adjust");
  val stream = default_arg_strict(stream_in, std_input);
  ucnum pos = c_unum(default_arg_strict(pos_in, zero), self);
  val alloc_size = buf_alloc_size(buf);
  ucnum len = c_unum(alloc_size, self);
  mem_t *ptr = buf_get(buf, self);
  val readpos;
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  buf_set_length(buf, alloc_size, zero);
  readpos = unum(ops->fill_buf(stream, ptr, len, pos));
  buf_set_length(buf, readpos, zero);
  return readpos;
}

val get_line_as_buf(val stream_in)
{
  val self = lit("get-line-as-buf");
  val stream = default_arg_strict(stream_in, std_input);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  val buf = make_buf(zero, nil, num_fast(128));
  unsigned char bytes[128];
  size_t count = 0;

  for (;;) {
    val b = ops->get_byte(stream);
    if (b == nil || b == num('\n'))
      break;
    bytes[count++] = c_num(b, self);

    if (count == sizeof bytes) {
      buf_put_bytes(buf, length_buf(buf), bytes, count, self);
      count = 0;
    }
  }

  if (count > 0)
    buf_put_bytes(buf, length_buf(buf), bytes, count, self);

  buf_trim(buf);
  return buf;
}

struct fmt {
  const char *type;
  const char *dec;
  const char *oct;
  const char *hex;
  const char *HEX;
};

static struct fmt fmt_tab[] = {
  { "short",      "%hd",   "%ho",   "%hx",   "%hX"   },
  { "int",        "%d",    "%o",    "%x",    "%X"    },
  { "long",       "%ld",   "%lo",   "%lx",   "%lX"   },
  { "long long",  "%lld",  "%llo",  "%llx",  "%llX"  },
  { "long long",  "%Ld",   "%Lo",   "%Lx",   "%LX"   },
  { "long long",  "%qd",   "%qo",   "%qx",   "%qX",  },
  { "int64",      "%I64d", "%I64o", "%I64x", "%I64X" },
  { "__int64",    "%I64d", "%I64o", "%I64x", "%I64X" },
  { 0,            0,       0,       0,       0       }
};

static struct fmt *num_fmt;

static void detect_format_string(void)
{
  struct fmt *f;
  char buf[64];
  cnum num = 1234;
  const char *cnum_type = if3(strcmp(INTPTR_TYPE, "longlong_t") == 0,
                              LONGLONG_TYPE, INTPTR_TYPE);

  for (f = fmt_tab; f->type != 0; f++) {
    if (strcmp(cnum_type, f->type) != 0)
      continue;
    memset(buf, 0, sizeof buf);
    if (sprintf(buf, f->dec, num) != 4 || strcmp(buf, "1234") != 0)
      continue;
    memset(buf, 0, sizeof buf);
    if (sprintf(buf, f->oct, num) != 4 || strcmp(buf, "2322") != 0)
      continue;
    memset(buf, 0, sizeof buf);
    if (sprintf(buf, f->hex, num) != 3 || strcmp(buf, "4d2") != 0)
      continue;
    memset(buf, 0, sizeof buf);
    if (sprintf(buf, f->HEX, num) != 3 || strcmp(buf, "4D2") != 0)
      continue;
    num_fmt = f;
    break;
  }

  bug_unless (num_fmt != 0);
}

enum align { al_left, al_center, al_right };

static void vformat_align_pre(val stream, enum align align, int slack)
{
  int i;

  switch (align) {
  case al_right:
    for (i = 0; i < slack; i++)
      put_char(chr(' '), stream);
    break;
  case al_left:
    break;
  case al_center:
    for (i = 0; i < slack/2; i++)
      put_char(chr(' '), stream);
    break;
  }
}

static void vformat_align_post(val stream, enum align align, int slack)
{
  int i;

  switch (align) {
  case al_right:
    break;
  case al_left:
    for (i = 0; i < slack; i++)
      put_char(chr(' '), stream);
    break;
  case al_center:
    for (i = 0; i < (slack+1)/2; i++)
      put_char(chr(' '), stream);
    break;
  }
}

static void vformat_num(val stream, const char *str,
                        int width, enum align align, int zeropad,
                        int precision, int add_sign)
{
  int sign_char = (str[0] == '-' || str[0] == '+') ? str[0] : 0;
  int have_sign = sign_char == '-';
  int mandatory_sign = have_sign || add_sign == '+';
  int digit_len = strlen(str) - (sign_char != 0);
  int overflow = digit_len > precision;
  int padlen = overflow ? 0 : precision - digit_len;
  int tentative_len = digit_len + padlen + (have_sign || add_sign);
  int total_len = (tentative_len > width &&
                   (have_sign || add_sign)
                   && !mandatory_sign) ? tentative_len - 1 : tentative_len;
  int slack = (total_len < width) ? width - total_len : 0;
  int i;

  vformat_align_pre(stream, align, slack);

  if (!zeropad)
    for (i = 0; i < padlen; i++)
      put_char(chr(' '), stream);

  if (sign_char)
    str++;

  if (mandatory_sign) {
    put_char(chr(have_sign ? sign_char : add_sign), stream);
  } else if (add_sign && tentative_len <= width) {
    put_char(chr(add_sign), stream);
  }

  if (zeropad)
    for (i = 0; i < padlen; i++)
      put_char(chr('0'), stream);

  while (*str)
    put_char(chr(*str++), stream);

  vformat_align_post(stream, align, slack);
}

static cnum calc_fitlen(const wchar_t *cstr, int precision, int width)
{
  cnum i, fitlen;
  wchar_t ch;

  if (width == 0 && precision == 0)
    return INT_PTR_MAX;

  for (i = 0, fitlen = 0; (ch = cstr[i]) != 0; i++) {
    int chw = iswcntrl(ch) ? 0 : 1 + wide_display_char_p(ch);

    if (precision && fitlen + chw > precision)
      break;

    if (width && fitlen + chw > width)
      return INT_PTR_MAX;

    fitlen += chw;
  }

  return fitlen;
}

static void vformat_str(val stream, val str, int width, enum align align,
                        int precision)
{
  val self = lit("format");
  const wchar_t *cstr = c_str(str, self);
  cnum fitlen = calc_fitlen(cstr, precision, width);
  cnum slack = (fitlen < width) ? width - fitlen : 0;
  cnum i, w;
  wchar_t wc;

  vformat_align_pre(stream, align, slack);

  if (fitlen == INT_PTR_MAX) {
    put_string(str, stream);
  } else for (i = 0, w = 0; (wc = cstr[i]) != 0; i++) {
    int cw = iswcntrl(wc) ? 0 : 1 + wide_display_char_p(wc);
    if (w + cw > fitlen)
      break;
    put_char(chr(wc), stream);
    w += cw;
  }

  vformat_align_post(stream, align, slack);

  gc_hint(str);
}

val formatv(val stream_in, val fmtstr, varg al)
{
  uses_or2;
  val stream = if3(stream_in == t,
                   std_output,
                   or2(stream_in, make_string_output_stream()));
  val save_indent = get_indent(stream);
  val save_mode = nil;
  val self = lit("format");

  uw_simple_catch_begin;

  {
    const wchar_t *fmt = c_str(fmtstr, self);
    enum {
      vf_init, vf_width, vf_digits, vf_star, vf_precision, vf_spec
    } state = vf_init, saved_state = vf_init;
    cnum value;
    cnum arg_ix = 0;
    /* conversion variables that are reset before for each conversion */
    int width = 0, precision = 0, precision_p = 0, digits = 0, lt = 0, neg = 0;
    int sign = 0, zeropad = 0;
    enum align align = al_right;
    /* conversion variables that persist across conversions */
    int dfl_precision = 0, dfl_digits = 0, print_base = 0;

    for (;;) {
      val obj;
      type_t typ;
      wchar_t ch = *fmt++;
      char num_buf[512], *pnum = num_buf;

      switch (state) {
      case vf_init:
        switch (ch) {
        case 0:
          break;
        case '~':
          state = vf_width;
          width = precision = precision_p = 0;
          digits = lt = neg = sign = zeropad = 0;
          align = al_right;
          continue;
        default:
          put_char(chr(ch), stream);
          continue;
        }
        break;
      case vf_width:
        switch (ch) {
        case '~':
          put_char(chr('~'), stream);
          state = vf_init;
          continue;
        case '<':
          lt = 1;
          align = al_left;
          continue;
        case '^':
          align = al_center;
          continue;
        case ',':
          state = vf_precision;
          continue;
        case '0': case '1': case '2': case '3': case '4': case '5':
        case '6': case '7': case '8': case '9':
          saved_state = state;
          state = vf_digits;
          digits = ch - '0';
          continue;
        case '-':
          neg = 1;
          continue;
        case '*':
          saved_state = state;
          state = vf_star;
          continue;
        default:
          state = vf_spec;
          --fmt;
          continue;
        }
        break;
      case vf_precision:
        switch (ch) {
        case '0':
          if (!zeropad) {
            zeropad = 1;
            continue;
          }
          /* fallthrough */
        case '1': case '2': case '3': case '4': case '5':
        case '6': case '7': case '8': case '9':
          saved_state = state;
          state = vf_digits;
          digits = ch - '0';
          continue;
        case '+': case ' ':
          sign = ch;
          continue;
        case '-':
          sign = '0';
          continue;
        case '*':
          saved_state = state;
          state = vf_star;
          continue;
        default:
          state = vf_spec;
          --fmt;
          continue;
        }
        break;
      case vf_digits:
        switch (ch) {
        case '0': case '1': case '2': case '3': case '4':
        case '5': case '6': case '7': case '8': case '9':
          digits = (digits * 10) + (ch - '0');
          if (digits > 999999)
            uw_throwf(assert_s, lit("~a: ridiculous precision or field"),
                      self, nao);
          continue;
        default:
  do_digits:
          switch (saved_state) {
          case vf_width:
            if (digits < 0) {
              width = -digits;
              align = al_left;
            } else {
              width = digits;
            }
            if (neg)
              align = al_left;
            if (ch == ',') {
              state = vf_precision;
            } else {
              state = vf_spec;
              --fmt;
            }
            continue;
          case vf_precision:
            precision = digits;
            precision_p = 1;
            state = vf_spec;
            --fmt;
            continue;
          default:
            internal_error("unexpected state in formatter");
          }
        }
        break;
      case vf_star:
        obj = args_get_checked(self, al, &arg_ix);
        digits = c_num(obj, self);
        goto do_digits;
        break;
      case vf_spec:
        state = vf_init;
        if (zeropad && !precision_p) {
          zeropad = precision = 0;
          precision_p = 1;
        }
        switch (ch) {
        case 'x': case 'X':
          obj = args_get_checked(self, al, &arg_ix);
          typ = type(obj);
        hex:
          switch (typ) {
          case BGNUM:
            {
              int nchars = mp_radix_size(mp(obj), 16);
              if (nchars >= convert(int, sizeof (num_buf)))
                pnum = coerce(char *, chk_malloc(nchars + 1));
              mp_toradix_case(mp(obj), coerce(unsigned char *, pnum), 16, ch == 'x');
            }
            break;
          case BUF:
            {
              ucnum len = c_unum(length_buf(obj), self);
              ucnum nchars = 2 * len + 1;

              if (len >= INT_PTR_MAX)
                uw_throwf(error_s, lit("~a: ~~~a conversion given "
                                       "too large a buf argument"),
                          self, chr(ch), nao);

              pnum = coerce(char *, chk_malloc(nchars));
              buf_hex(obj, pnum, nchars, ch == 'X');
            }
            break;
          case NUM:
          case CHR:
          default:
            {
              const char *fmt = ch == 'x' ? num_fmt->hex : num_fmt->HEX;
              value = c_num(obj, self);
              if (value < 0) {
                num_buf[0] = '-';
                sprintf(num_buf + 1, fmt, -value);
              } else {
                sprintf(num_buf, fmt, value);
              }
            }
          }
          goto output_num;
        case 'o': case 'b':
          obj = args_get_checked(self, al, &arg_ix);
          typ = type(obj);
        oct:
          if (typ == BGNUM) {
            int rad = ch == 'o' ? 8 : 2;
            int nchars = mp_radix_size(mp(obj), rad);
            if (nchars >= convert(int, sizeof (num_buf)))
              pnum = coerce(char *, chk_malloc(nchars + 1));
            mp_toradix(mp(obj), coerce(unsigned char *, pnum), rad);
          } else if (ch == 'o') {
            cnum value = c_num(obj, self);
            sprintf(num_buf, num_fmt->oct, value);
          } else {
            cnum val = c_num(obj, self);
            int s = (val < 0);
            int i = sizeof num_buf;

            value = s ? -val : val;

            num_buf[--i] = 0;

            while (i > 0) {
              num_buf[--i] = ((value & 1) ? '1' : '0');
              value >>= 1;
              if (!value)
                break;
            }

            if (s && i > 0)
              num_buf[--i] = '-';

            memmove(num_buf, num_buf + i, sizeof num_buf - i);
          }
          goto output_num;
        case 'f': case 'e':
          obj = args_get_checked(self, al, &arg_ix);

          {
            double n;

            switch (type(obj)) {
            case BGNUM:
              obj = flo_int(obj);
              /* fallthrough */
            case FLNUM:
              n = c_flo(obj, lit("format"));
              break;
            case NUM:
              n = convert(double, c_num(obj, self));
              break;
            default:
              uw_throwf(error_s, lit("~a: ~~~a conversion requires "
                                     "numeric arg: ~s given"),
                        self, chr(ch), obj, nao);
            }

            if (!precision_p) {
              if (!dfl_digits)
                dfl_digits = c_num(cdr(lookup_var(nil, print_flo_digits_s)), self);
              precision = dfl_digits;
            }

            /* guard against num_buf overflow */
            if (precision > 128)
              uw_throwf(error_s, lit("~a: excessive precision: ~s"),
                        self, num(precision), nao);

            if (ch == 'e') {
              sprintf(num_buf, "%.*e", precision, n);
              {
#if CONFIG_LOCALE_TOLERANCE
                char *dec = strchr(num_buf, dec_point);
#else
                char *dec = strchr(num_buf, '.');
#endif
                char *exp = strchr(dec ? dec : num_buf, 'e');

                if (exp) {
                  char *scan = ++exp;

                  if (*scan == '-')
                    *exp++ = *scan++;
                  else if (*scan == '+')
                    scan++;

                  while (*scan == '0')
                    scan++;

                  if (!*scan)
                    *exp++ = '0';
                  else
                    while (*scan)
                      *exp++ = *scan++;

                  *exp = 0;
                }
              }
            } else {
              sprintf(num_buf, "%.*f", precision, n);
            }
            if (!isdigit(num_buf[0]) && !isdigit(num_buf[1])) {
              vformat_str(stream, lit("#<bad-float>"), width, align, 0);
              continue;
            }
            precision = (width ? width - 1 : 0);
#if CONFIG_LOCALE_TOLERANCE
            if (dec_point != '.') {
              char *dot = num_buf;
              while ((dot = strchr(dot, dec_point)) != 0)
                *dot++ = '.';
            }
#endif
            goto output_num;
          }
        case 'd':
          obj = args_get_checked(self, al, &arg_ix);
          typ = type(obj);
          goto dec;
        case 'a': case 's':
          obj = args_get_checked(self, al, &arg_ix);
          typ = type(obj);

          if (typ == NUM || typ == BGNUM) {
            if (!print_base)
              print_base = c_num(cdr(lookup_var(nil, print_base_s)), self);
            switch (print_base) {
            case 0:
            case 2:
              ch = 'b';
              goto oct;
            case 8:
              ch = 'o';
              goto oct;
            case 16:
              ch = 'X';
              goto hex;
            case 10:
            default:
              break;
            }
          }
          /* fallthrough */
        dec:
          switch (typ) {
          case NUM:
            value = c_num(obj, self);
            sprintf(num_buf, num_fmt->dec, value);
            if (width)
              precision = min(precision, width - 1);
            goto output_num;
          case BGNUM:
            {
              int nchars = mp_radix_size(mp(obj), 10);
              if (nchars >= convert(int, sizeof (num_buf)))
                pnum = coerce(char *, chk_malloc(nchars + 1));
              mp_toradix(mp(obj), coerce(unsigned char *, pnum), 10);
            }
            if (width)
              precision = min(precision, width - 1);
            goto output_num;
          case FLNUM:
            if (!precision_p) {
              if (!dfl_precision)
                dfl_precision = c_num(cdr(lookup_var(nil,
                                                     print_flo_precision_s)),
                                      self);
              precision = dfl_precision;
            }

            if (precision > 500)
              uw_throwf(error_s, lit("~a: excessive precision: ~s"),
                        self, num(precision), nao);

            sprintf(num_buf, "%.*g", precision, c_f(obj));

#if CONFIG_LOCALE_TOLERANCE
            if (dec_point != '.') {
              char *dot = num_buf;
              while ((dot = strchr(dot, dec_point)) != 0)
                *dot++ = '.';
            }
#endif

            {
              char *dec = strchr(num_buf, '.');
              char *exp = strchr(dec ? dec : num_buf, 'e');

              if (exp) {
                char *scan = ++exp;

                if (*scan == '-')
                  *exp++ = *scan++;
                else if (*scan == '+')
                  scan++;

                while (*scan == '0')
                  scan++;

                while (*scan)
                  *exp++ = *scan++;

                *exp = 0;
              }

              if (ch == 's' && (!precision_p || precision > 0) && !dec && !exp)
                strcat(num_buf, ".0");
            }

            if (!isdigit(num_buf[0]) && !isdigit(num_buf[1])) {
              vformat_str(stream, lit("#<bad-float>"), width, align, 0);
              continue;
            }

            precision = max(0, min(precision, width - 1));

            goto output_num;
          default:
            if (width != 0 || precision_p) {
              val str = format(nil, ch == 'a' ? lit("~a") : lit("~s"),
                               obj, nao);
              vformat_str(stream, str, width, align, precision);
              continue;
            }
          }
          obj_print(obj, stream, if2(ch == 'a', t));
          continue;
        case 'p':
          {
            val ptr = args_get_checked(self, al, &arg_ix);
            value = coerce(cnum, ptr);
            sprintf(num_buf, num_fmt->hex, value);
          }
          goto output_num;
        case '!':
          save_mode = test_neq_set_indent_mode(stream, num_fast(indent_foff),
                                               num_fast(indent_data));
          if (lt)
            set_indent(stream, plus(save_indent, num(width)));
          else
            inc_indent(stream, num(width));
          continue;
        case 0:
          uw_throwf(error_s, lit("missing format directive character"), nao);
        default:
          uw_throwf(error_s, lit("unknown format directive character ~s"),
                    chr(ch), nao);
        output_num:
          {
            vformat_num(stream, pnum, width, align,
                        zeropad, precision, sign);
            if (pnum != num_buf)
              free(pnum);
            continue;
          }
        }
        continue;
      }

      break;
    }

    if (args_more(al, arg_ix))
      uw_throwf(assert_s, lit("~a: excess arguments"), self, nao);
  }


  uw_unwind {
    set_indent(stream, save_indent);
    if (save_mode)
      set_indent_mode(stream, save_mode);
  }

  uw_catch_end;

  gc_hint(fmtstr);

  return (stream_in) ? t : get_string_from_stream(stream);
}

val vformat(val stream, val fmtstr, va_list vl)
{
  val arg;
  args_decl_constsize(args, ARGS_MAX);

  while ((arg = va_arg(vl, val)) != nao)
    args_add_checked(lit("format"), args, arg);

  return formatv(stream, fmtstr, args);
}

val vformat_to_string(val fmtstr, va_list vl)
{
  val stream = make_string_output_stream();
  (void) vformat(stream, fmtstr, vl);
  return get_string_from_stream(stream);
}

val format(val stream, val str, ...)
{
  val self = lit("format");
  uses_or2;
  val st = if3(stream == t,
               std_output,
               or2(stream, make_string_output_stream()));
  class_check(self, st, stream_cls);

  {
    va_list vl;
    val ret;
    va_start (vl, str);
    ret = vformat(st, str, vl);
    va_end (vl);
    return (stream) ? ret : get_string_from_stream(st);
  }
}

val fmt(val string, varg args)
{
  return formatv(nil, string, args);
}

static val put_indent(val stream, struct strm_ops *ops, cnum chars)
{
  while (chars--)
    if (!ops->put_char(stream, chr(' ')))
      return nil;
  return t;
}

val put_string(val string, val stream_in)
{
  val self = lit("put-string");
  val stream = default_arg_strict(stream_in, std_output);
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));

  if (lazy_stringp(string)) {
    return lazy_str_put(string, stream_in, s);
  } else {
    struct strm_ops *ops = coerce(struct strm_ops *,
                                  cobj_ops(self, stream, stream_cls));
    cnum col = s->column;

    const wchar_t *str = c_str(string, self), *p = str;

    if (s->indent_mode != indent_off && s->indent_mode != indent_foff) {
      while (*str)
        put_char(chr(*str++), stream);
      return t;
    }

    for (; *p; p++) {
      switch (*p) {
      case '\n':
        col = 0;
        s->force_break = 0;
        break;
      case '\t':
        col = (col + 1) | 7;
        break;
      default:
        if (!iswcntrl(*p))
          col += 1 + wide_display_char_p(*p);
        break;
      }
    }

    ops->put_string(stream, string);
    s->column = col;
    return t;
  }
}

val put_char(val ch, val stream_in)
{
  val self = lit("put-char");
  val stream = default_arg_strict(stream_in, std_output);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  wint_t cch = c_chr(ch);

  switch (cch) {
  case L'\n':
    ops->put_char(stream, ch);
    s->column = 0;
    s->force_break = 0;
    break;
  case L'\t':
    if (s->column == 0 && s->indent_mode != indent_off &&
        s->indent_mode != indent_foff)
    {
      put_indent(stream, ops, s->indent_chars);
      s->column = s->indent_chars;
    }
    ops->put_char(stream, ch);
    s->column = (s->column + 1) | 7;
    break;
  default:
    if (s->column == 0 && s->indent_mode != indent_off &&
        s->indent_mode != indent_foff)
    {
      put_indent(stream, ops, s->indent_chars);
      s->column = s->indent_chars;
    }
    ops->put_char(stream, ch);

    if (!iswcntrl(cch))
      s->column += 1 + wide_display_char_p(cch);
    break;
  }

  return t;
}

val put_byte(val byte, val stream_in)
{
  val self = lit("put-byte");
  val stream = default_arg_strict(stream_in, std_output);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  cnum b = c_num(byte, self);

  if (b < 0 || b > 255)
    uw_throwf(file_error_s, lit("~a: stream ~s: byte value ~a out of range"),
              self, stream, byte, nao);

  return ops->put_byte(stream, b);
}

val put_line(val string, val stream_in)
{
  val stream = default_arg_strict(stream_in, std_output);
  return (put_string(default_arg_strict(string, null_string), stream),
          put_char(chr('\n'), stream));
}

val put_strings(val strings, val stream)
{
  strings = nullify(strings);

  for (; strings; strings = cdr(strings))
    put_string(car(strings), stream);
  return t;
}

val put_lines(val lines, val stream)
{
  lines = nullify(lines);

  for (; lines; lines = cdr(lines))
    put_line(car(lines), stream);
  return t;
}

val flush_stream(val stream_in)
{
  val self = lit("flush-stream");
  val stream = default_arg_strict(stream_in, std_output);
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  return ops->flush(stream);
}

val seek_stream(val stream, val offset, val whence)
{
  val self = lit("seek-stream");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  enum strm_whence w;

  if (whence == from_start_k)
    w = strm_start;
  else if (whence == from_current_k)
    w = strm_cur;
  else if (whence == from_end_k)
    w = strm_end;
  else
    uw_throwf(file_error_s, lit("~a: ~s is not a valid whence argument"),
              self, whence, nao);

  return ops->seek(stream, offset, w);
}

val truncate_stream(val stream, val len)
{
  val self = lit("truncate-stream");
  struct strm_ops *ops = coerce(struct strm_ops *,
                                cobj_ops(self, stream, stream_cls));
  if (missingp(len))
    len = ops->seek(stream, zero, strm_cur);
  return ops->truncate(stream, len);
}

val get_indent_mode(val stream)
{
  val self = lit("get-indent-mode");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  return num_fast(s->indent_mode);
}

val test_set_indent_mode(val stream, val compare, val mode)
{
  val self = lit("test-set-indent-mode");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  val oldval = num_fast(s->indent_mode);
  if (oldval == compare)
    s->indent_mode = convert(enum indent_mode, c_num(mode, self));
  return oldval;
}

val test_neq_set_indent_mode(val stream, val compare, val mode)
{
  val self = lit("test-neq-set-indent-mode");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  val oldval = num_fast(s->indent_mode);
  if (oldval != compare)
    s->indent_mode = convert(enum indent_mode, c_num(mode, self));
  return oldval;
}

val set_indent_mode(val stream, val mode)
{
  val self = lit("set-indent-mode");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  val oldval = num_fast(s->indent_mode);
  s->indent_mode = convert(enum indent_mode, c_num(mode, self));
  return oldval;
}

val get_indent(val stream)
{
  val self = lit("get-indent");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  return num(s->indent_chars);
}

val set_indent(val stream, val indent)
{
  val self = lit("set-indent");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  val oldval = num(s->indent_chars);
  s->indent_chars = c_num(indent, self);
  if (s->indent_chars < 0)
    s->indent_chars = 0;
  return oldval;
}

val inc_indent(val stream, val delta)
{
  val self = lit("inc-indent");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  val oldval = num(s->indent_chars);
  val col = num(s->column);
  s->indent_chars = c_num(plus(delta, col), self);
  if (s->indent_chars < 0)
    s->indent_chars = 0;
  return oldval;
}

val inc_indent_abs(val stream, val delta)
{
  val self = lit("inc-indent-abs");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  val oldval = num(s->indent_chars);
  s->indent_chars = c_num(plus(delta, oldval), self);
  if (s->indent_chars < 0)
    s->indent_chars = 0;
  return oldval;
}

val width_check(val stream, val alt)
{
  val self = lit("width-check");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));

  if ((s->indent_mode == indent_code &&
       s->column >= s->indent_chars + s->code_width) ||
      (s->indent_mode == indent_data &&
       s->column >= s->indent_chars + s->data_width) ||
      (s->indent_mode != indent_off &&
       s->indent_mode != indent_foff && s->force_break))
  {
    put_char(chr('\n'), stream);
    s->force_break = 0;
    return t;
  } else if (alt) {
    put_char(alt, stream);
  }

  return nil;
}

val force_break(val stream)
{
  val self = lit("force-break");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  s->force_break = 1;
  return stream;
}

val set_max_length(val stream, val length)
{
  val self = lit("set-max-length");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  cnum old_max = s->max_length;
  s->max_length = c_num(length, self);
  return num(old_max);
}

val set_max_depth(val stream, val depth)
{
  val self = lit("set-max-depth");
  struct strm_base *s = coerce(struct strm_base *,
                               cobj_handle(self, stream, stream_cls));
  cnum old_max = s->max_depth;
  s->max_depth = c_num(depth, self);
  return num(old_max);
}

struct strm_ctx *get_set_ctx(val stream, struct strm_ctx *ctx)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  struct strm_ctx *ret = s->ctx;
  s->ctx = ctx;
  return ret;
}

struct strm_ctx *get_ctx(val stream)
{
  struct strm_base *s = coerce(struct strm_base *, stream->co.handle);
  return s->ctx;
}

val get_string(val stream_in, val nchars_in, val close_after_p)
{
  val stream = default_arg_strict(stream_in, std_input);
  val strstream = make_string_output_stream();
  val nchars = default_null_arg(nchars_in);
  val ch;

  if (nchars) {
    for (; gt(nchars, zero) && (ch = get_char(stream));
         nchars = minus(nchars, one))
      put_char(ch, strstream);
  } else {
    while ((ch = get_char(stream)))
      put_char(ch, strstream);
  }

  if ((missingp(close_after_p) && (!opt_compat || opt_compat > 102)) ||
      default_arg_strict(close_after_p, t))
    close_stream(stream, t);

  return get_string_from_stream(strstream);
}

val open_directory(val path)
{
  val self = lit("open-directory");
  DIR *d = w_opendir(c_str(path, self));

  if (!d) {
    int eno = errno;
    uw_ethrowf(errno_to_file_error(eno),
               lit("error opening directory ~s: ~d/~s"),
               path, num(eno), errno_to_str(eno), nao);
  }

  return make_dir_stream(d);
}

val open_file(val path, val mode_str)
{
  val self = lit("open-file");
  struct stdio_mode m, m_r = stdio_mode_init_r;
  val norm_mode = normalize_mode(&m, mode_str, m_r, self);

#if HAVE_ZLIB
again:
#endif
  if (!m.gzip) {
    FILE *f = w_fopen_mode(c_str(path, self), c_str(norm_mode, self), m);

    if (!f)
      goto error;

    return set_mode_props(m, make_stdio_stream(f, path));
  } else {
#if HAVE_ZLIB
    gzFile f = w_gzopen_mode(c_str(path, self), c_str(norm_mode, self),
                             m, self);

    if (!f)
      goto error;

    if (m.read && gzdirect(f)) {
      gzclose(f);
      m.gzip = 0;
      goto again;
    }

    return make_gzio_stream(f, -1, path, m.write);
#else
    uw_ethrowf(file_error_s, lit("~a: not built with zlib support"),
               self, nao);
#endif
  }

error:
  {
    int eno = errno;
    uw_ethrowf(errno_to_file_error(eno), lit("error opening ~s: ~d/~s"),
               path, num(eno), errno_to_str(eno), nao);
  }
}

val open_fileno(val fd, val mode_str, val pid_opt)
{
  val self = lit("open-fileno");
  struct stdio_mode m, m_r = stdio_mode_init_r;
  val norm_mode = normalize_mode(&m, mode_str, m_r, self);
  val pid = default_arg(pid_opt, nil);

  if (!m.gzip) {
    FILE *f = (errno = 0, w_fdopen(c_num(fd, self),
                                   c_str(norm_mode, self)));

    if (!f)
    {
      int eno = errno;
      close(c_num(fd, self));
      uw_ethrowf(errno_to_file_error(eno),
                 lit("error opening descriptor ~a: ~d/~s"),
                 fd, num(eno), errno_to_str(eno), nao);
    }

    {
      val descr = format(nil, lit("fd ~d"), fd, nao);

#if HAVE_FORK_STUFF
      return set_mode_props(m, if3(pid,
                                   make_pipevp_stream(f, descr,
                                                      c_num(pid, self)),
                                   make_stdio_stream(f, descr)));
#else
      return set_mode_props(m, make_stdio_stream(f, descr));
#endif
    }

  } else {
#if HAVE_ZLIB
    cnum fdn = c_num(fd, self);
    gzFile f = w_gzdopen_mode(fdn, c_str(norm_mode, self), m, self);
    return make_gzio_stream(f, fdn, format(nil, lit("fd ~d"), fd, nao),
                            m.write);
#else
    uw_ethrowf(file_error_s, lit("~a: not built with zlib support"),
               self, nao);
#endif
  }
}

val open_tail(val path, val mode_str, val seek_end_p)
{
  val self = lit("open-tail");
  struct stdio_mode m, m_r = stdio_mode_init_r;
  val mode = normalize_mode(&m, mode_str, m_r, self);
  FILE *f = w_fopen_mode(c_str(path, self), c_str(mode, self), m);
  struct stdio_handle *h;
  val stream;
  unsigned long state = 0;

  if (f && default_null_arg(seek_end_p))
    if (fseek(f, 0, SEEK_END) < 0)
      uw_ethrowf(file_error_s, lit("error seeking to end of ~s: ~d/~s"),
                 path, num(errno), errno_to_str(errno), nao);

  stream = make_tail_stream(f, path);
  h = coerce(struct stdio_handle *, stream->co.handle);
  h->mode = mode_str;
  if (!f)
    tail_strategy(stream, &state);
  return set_mode_props(m, stream);
}

struct save_fds {
  volatile int in;
  volatile int out;
  volatile int err;
  volatile int subin;
  volatile int subout;
  volatile int suberr;
};

#define FDS_IN  1
#define FDS_OUT 2
#define FDS_ERR 4

static void fds_init(struct save_fds *fds)
{
  fds->in = fds->out = fds->err = fds->subin = fds->subin = fds->subin = -1;
}

static int fds_getfd(val stream, val self)
{
  val sfd = stream_fd(stream);
  int fd_sub = if3(integerp(sfd), c_num(sfd, self), INT_MIN);


  if (fd_sub == INT_MIN)
    uw_throwf(file_error_s, lit("~a: (fileno ~s) is ~s, which is unusable"),
              self, stream, sfd, nao);

  return fd_sub;
}

#if HAVE_WSPAWN || HAVE_SPAWN
static int fds_subst(int fd_sub, int fd_std, val self)
{
  if (fd_sub == fd_std)
    return -1;

  {
    int fd_dup = dup(fd_std);

    if (fd_dup != -1) {
      dup2(fd_sub, fd_std);
      return fd_dup;
    }

    uw_ethrowf(file_error_s, lit("~a: failed to duplicate file descriptor: ~d/~s"),
               self, num(errno), errno_to_str(errno), nao);
  }
}
#endif

static void fds_subst_nosave(int fd_sub, int fd_std)
{
  if (fd_sub == fd_std)
    return;
  dup2(fd_sub, fd_std);
}

static void fds_prepare(struct save_fds *fds, int flags, val self)
{
  if ((flags & FDS_IN) != 0)
    fds->subin = fds_getfd(std_input, self);

  if ((flags & FDS_OUT) != 0)
    fds->subout = fds_getfd(std_output, self);

  if ((flags & FDS_ERR) != 0)
    fds->suberr = fds_getfd(std_error, self);
}

#if HAVE_WSPAWN || HAVE_SPAWN
static void fds_swizzle(struct save_fds *fds, int flags, val self)
{
  if ((flags & FDS_IN) != 0)
    fds->in = fds_subst(fds->subin, STDIN_FILENO, self);

  if ((flags & FDS_OUT) != 0)
    fds->out = fds_subst(fds->subout, STDOUT_FILENO, self);

  if ((flags & FDS_ERR) != 0)
    fds->err = fds_subst(fds->suberr, STDERR_FILENO, self);
}

static void fds_restore(struct save_fds *fds)
{
  if (fds->in != -1) {
    dup2(fds->in, STDIN_FILENO);
    close(fds->in);
  }

  if (fds->out != -1) {
    dup2(fds->out, STDOUT_FILENO);
    close(fds->out);
  }

  if (fds->err != -1) {
    dup2(fds->err, STDERR_FILENO);
    close(fds->err);
  }
}
#endif

static void fds_clobber(struct save_fds *fds, int flags)
{
  if ((flags & FDS_IN) != 0)
    fds_subst_nosave(fds->subin, STDIN_FILENO);

  if ((flags & FDS_OUT) != 0)
    fds_subst_nosave(fds->subout, STDOUT_FILENO);

  if ((flags & FDS_ERR) != 0)
    fds_subst_nosave(fds->suberr, STDERR_FILENO);
}

val path_search(val name, val path_in)
{
  val self = lit("path-search");
  val ps = static_str(path_sep_chars);

  if (empty(name) || equal(name, lit(".")) || equal(name, lit(".."))) {
    return nil;
  } else if (break_str(name, ps)) {
    return name;
  } else {
    val path = default_arg_strict(path_in, getenv_wrap(lit("PATH")));
    val spath = if3(listp(path), path, split_str(path, chr(path_var_sep_char)));
    for (; spath; spath = cdr(spath)) {
      val dir = car(spath);
      val full = path_cat(dir, name);
      char *full8 = utf8_dup_to(c_str(full, self));
      int res = access(full8, F_OK);
      free(full8);
      if (res == 0)
        return full;
    }
    return nil;
  }
}

#if HAVE_FORK_STUFF
static val open_subprocess(val name, val mode_str, val args, val fun)
{
  val self = lit("open-subprocess");
  struct stdio_mode m, m_r = stdio_mode_init_r;
  int input = (normalize_mode(&m, mode_str, m_r, self), m.read != 0);
  int fd[2];
  pid_t pid;
  char **argv = 0;
  val iter;
  int i, nargs;
  struct save_fds sfds;
  val ret = nil;
  int fds_flags = (input ? FDS_IN : FDS_OUT) | FDS_ERR;
  int streamfd_in = m.streamfd != -1 ? m.streamfd : STDIN_FILENO;
  int streamfd_out = m.streamfd != -1 ? m.streamfd : STDOUT_FILENO;

  args = default_null_arg(args);
  fun = default_null_arg(fun);
  nargs = c_num(length(args), self) + 1;

  if (!name && !fun)
    uw_throwf(error_s, lit("~a: program name and/or function required"), self, nao);

  if (!input)
    flush_stream(std_output);

  fds_init(&sfds);

  fds_prepare(&sfds, fds_flags, self);

  if (nargs < 0 || nargs == INT_MAX)
    uw_throwf(error_s, lit("~a: argument list overflow"), self, nao);

  if (name)
    argv = coerce(char **, chk_xalloc(nargs + 1, sizeof *argv, self));

  if (pipe(fd) == -1) {
    int eno = errno;
    free(argv);
    uw_ethrowf(errno_to_file_error(eno),
               lit("opening pipe ~s, pipe syscall failed: ~d/~s"),
               name, num(eno), errno_to_str(eno), nao);
  }

  if (argv) {
    for (i = 0, iter = cons(name, args); iter; i++, iter = cdr(iter)) {
      val arg = car(iter);
      argv[i] = utf8_dup_to(c_str(arg, self));
    }
    argv[i] = 0;
  }

  pid = fork();

  if (pid == -1) {
    if (argv) {
      for (i = 0; i < nargs; i++)
        free(argv[i]);
      free(argv);
    }
    uw_ethrowf(process_error_s, lit("opening pipe ~s, fork syscall failed: ~d/~s"),
               name, num(errno), errno_to_str(errno), nao);
  }

  if (pid == 0) {
    fds_clobber(&sfds, fds_flags);

    if (input) {
      dup2(fd[1], streamfd_out);
      if (fd[1] != streamfd_out) /* You never know */
        close(fd[1]);
      close(fd[0]);
    } else {
      dup2(fd[0], streamfd_in);
      if (fd[0] != streamfd_in) /* You never know */
        close(fd[0]);
      close(fd[1]);
    }

    for (i = 0; i < STDIO_MODE_NREDIRS; i++) {
      int to = m.redir[i][0];
      int from = m.redir[i][1];

      if (to < 0)
        break;

      switch (from) {
      case 'n':
#if HAVE_FCNTL
        {
          int n = open("/dev/null", O_RDWR);
          if (n > 0) {
            dup2(n, to);
            close(n);
          }
        }
#endif
        break;
      case 'x':
        close(to);
        break;
      default:
        dup2(from, to);
        break;
      }
    }

    if (fun)
      funcall(fun);

    if (argv) {
      val ch_env = child_env;
      if (ch_env != t)
        replace_env(ch_env);
      execvp(argv[0], argv);
    }
    _exit(errno);
  } else {
    int whichfd;

    if (input) {
      close(fd[1]);
      whichfd = fd[0];
    } else {
      close(fd[0]);
      whichfd = fd[1];
    }

    if (argv) {
      for (i = 0; i < nargs; i++)
        free(argv[i]);
      free(argv);
    }

#if HAVE_FCNTL
    fcntl(whichfd, F_SETFD, FD_CLOEXEC);
#endif

    uw_simple_catch_begin;

    ret = open_fileno(num(whichfd), mode_str, num(pid));

    uw_unwind {
      int status;
      if (ret == nil) {
        int eno = errno;
        kill(pid, SIGINT);
        kill(pid, SIGTERM);
        while (waitpid(pid, &status, 0) == -1 && errno == EINTR)
          ;
        uw_ethrowf(file_error_s, lit("opening pipe ~s: ~d/~s"),
                   name, num(eno), errno_to_str(eno), nao);
      }
    }

    uw_catch_end;
  }

  return ret;
}

val open_process(val name, val mode_str, val args)
{
  return open_subprocess(name, mode_str, args, nil);
}

val open_command(val command, val mode_str)
{
#ifdef __CYGWIN__
  uses_or2;
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
  val interp = if3(psc[0] == '\\',
                   or2(getenv_wrap(lit("COMSPEC")),
                       lit("C:\\WINDOWS\\system32\\cmd.exe")),
                   lit("/bin/sh"));
  val opt = if3(psc[0] == '\\', lit("/c"), lit("-c"));
#else
  val interp = lit("/bin/sh");
  val opt = lit("-c");
#endif
  return open_process(interp, mode_str, list(opt, command, nao));
}

#endif

#if HAVE_WSPAWN || HAVE_SPAWN

#if !HAVE_WSPAWN
static int w_spawnvp(int mode, const wchar_t *wpath, int wargc,
                     const wchar_t **wargv)
{
  char *path = utf8_dup_to(wpath);
  const char **argv = coerce(const char **,
			     chk_malloc(sizeof *argv * (wargc + 1)));
  int i, res;

  for (i = 0; i < wargc; i++)
    argv[i] = utf8_dup_to(wargv[i]);
  argv[i] = 0;

  res = spawnvp(mode, path, argv);

  for (i = 0; i < wargc; i++)
    free(strip_qual(char *, argv[i]));
  free(argv);
  free(path);

  return res;
}
#endif

static val run(val command, val args)
{
  val self = lit("run");
  const wchar_t **wargv = 0;
  val iter;
  int i, nargs, status = 0;
  struct save_fds sfds;
  volatile val save_env, ch_env = child_env;

  args = default_null_arg(args);
  nargs = c_num(length(args), self) + 1;

  flush_stream(std_output);

  fds_init(&sfds);

  uw_simple_catch_begin;

  fds_prepare(&sfds, FDS_IN | FDS_OUT | FDS_ERR, self);

  fds_swizzle(&sfds, FDS_IN | FDS_OUT | FDS_ERR, self);

  if (nargs < 0 || nargs == INT_MAX)
    uw_throwf(error_s, lit("~a: argument list overflow"), self, nao);

  if (ch_env != t) {
    save_env = env();
    replace_env(ch_env);
  }

  wargv = coerce(const wchar_t **, chk_xalloc(nargs + 1, sizeof *wargv, self));

  for (i = 0, iter = cons(command, args); iter; i++, iter = cdr(iter))
    wargv[i] = c_str(car(iter), self);
  wargv[i] = 0;

  if (status == 0) {
#if HAVE_WSPAWN
    status = _wspawnvp(_P_WAIT, c_str(command, self), wargv);
#else
    status = w_spawnvp(_P_WAIT, c_str(command, self), nargs, wargv);
#endif
#ifdef __CYGWIN__
    /* Cygwin spawnvp reports regular termination status in upper 8 bits, and
     * termination signal in lower 8 bits. Let's massage it so that we produce
     * the same behavior as on Linux.
     */
    if (status && status < 0x100)
      status = -1;      /* ensure nil return */
    else
      status >>= 8;
#endif
  }

  free(strip_qual(wchar_t **, wargv));

  gc_hint(args);

  uw_unwind {
    if (ch_env != t)
      replace_env(save_env);
    fds_restore(&sfds);
  }

  uw_catch_end;

  return (status < 0) ? nil : num(status);
}

#elif HAVE_FORK_STUFF

static val run(val name, val args)
{
  val self = lit("run");
  pid_t pid;
  char **argv = 0;
  val iter;
  int i, nargs;
  struct save_fds sfds;
  val ret = nil;

  args = default_null_arg(args);
  nargs = c_num(length(args), self) + 1;

  if (nargs < 0 || nargs == INT_MAX)
    uw_throwf(error_s, lit("~a: argument list overflow"), self, nao);

  argv = coerce(char **, chk_xalloc(nargs + 1, sizeof *argv, self));

  for (i = 0, iter = cons(name, args); iter; i++, iter = cdr(iter)) {
    val arg = car(iter);
    argv[i] = utf8_dup_to(c_str(arg, self));
  }
  argv[i] = 0;

  flush_stream(std_output);

  fds_init(&sfds);

  fds_prepare(&sfds, FDS_IN | FDS_OUT | FDS_ERR, self);

  pid = fork();

  if (pid == -1) {
    for (i = 0; i < nargs; i++)
      free(argv[i]);
    free(argv);
    uw_ethrowf(process_error_s, lit("opening process ~s, fork syscall failed: ~d/~s"),
               name, num(errno), errno_to_str(errno), nao);
  }

  if (pid == 0) {
    val ch_env = child_env;
    fds_clobber(&sfds, FDS_IN | FDS_OUT | FDS_ERR);
    if (ch_env != t)
      replace_env(ch_env);
    execvp(argv[0], argv);
    _exit(errno);
  } else {
    int status, wres;
    for (i = 0; i < nargs; i++)
      free(argv[i]);
    free(argv);
    while ((wres = waitpid(pid, &status, 0)) == -1 && errno == EINTR)
      ;
    if (wres != -1) {
#if HAVE_SYS_WAIT
      if (WIFEXITED(status)) {
        int exitstatus = WEXITSTATUS(status);
        ret = num(exitstatus);
        goto out;
      }
#endif
      ret = (status == 0 ? zero : nil);
    }
  }

out:
  return ret;
}

#endif

#if HAVE_WSPAWN || HAVE_SPAWN || HAVE_FORK_STUFF

static val sh(val command)
{
  return run(shell, list(shell_arg, command, nao));
}

#endif

static val sh_esc_dq(val string)
{
  return str_esc(lit("$`\\\""), chr('\\'), string);
}

static val sh_esc_sq(val string)
{
  return str_esc(lit("'"), lit("'\\'"), string);
}

static val sh_esc_common(val string, int all, val self)
{
  const wchar_t *s, *str = c_str(string, self);
  int sq = 0, dq = 0, es = 0;

  for (s = str; *s; s++)
  {
    wchar_t ch = *s;

    if (ch == '\'')
      es = sq = 1;
    else if (wcschr(L"$`\\\"", ch))
      es = dq = 1;
    else if (wcschr(L"|&;<>() \t\n*?[#~", ch))
      es = 1;
    else if (all && wcschr(L"=%", ch))
      es = 1;
  }

  if (!es)
    return string;

  if (!dq)
    return scat3(chr('"'), string, chr('"'));

  if (!sq)
    return scat3(chr('\''), string, chr('\''));

  return scat3(chr('\''), sh_esc_sq(string), chr('\''));
}

static val sh_esc(val string)
{
  return sh_esc_common(string, 0, lit("sh-esc"));
}

static val sh_esc_all(val string)
{
  return sh_esc_common(string, 1, lit("sh-esc-all"));
}

val remove_path(val path, val throw_on_error)
{
  val self = lit("remove-path");

  if (w_remove(c_str(path, self)) < 0) {
    if (default_null_arg(throw_on_error) || errno != ENOENT) {
      int eno = errno;
      uw_ethrowf(errno_to_file_error(eno), lit("trying to remove ~s: ~d/~s"),
                 path, num(eno), errno_to_str(eno), nao);
    }
    return nil;
  }

  return t;
}

val rename_path(val from, val to)
{
  val self = lit("rename-path");

  if (w_rename(c_str(from, self), c_str(to, self)) < 0) {
    int eno = errno;
    uw_ethrowf(errno_to_file_error(eno),
               lit("trying to rename ~s to ~s: ~d/~s"),
               from, to, num(eno), errno_to_str(eno), nao);
  }

  return t;
}

static val open_files(val file_list, val substitute_stream, val mode)
{
  substitute_stream = default_null_arg(substitute_stream);
  mode = default_null_arg(mode);

  if (nilp(file_list) && substitute_stream) {
    return substitute_stream;
  } else if (mode) {
    return make_catenated_stream(mapcar(pa_12_1(func_n2o(open_file, 1),
                                                mode), file_list));
  } else {
    return make_catenated_stream(mapcar(func_n2o(open_file, 1), file_list));
  }
}

static val open_files_star(val file_list, val substitute_stream, val mode)
{
  substitute_stream = default_null_arg(substitute_stream);
  mode = default_null_arg(mode);

  if (nilp(file_list) && substitute_stream) {
    return substitute_stream;
  } else if (mode) {
    return make_catenated_stream(lazy_mapcar(pa_12_1(func_n2o(open_file, 1),
                                                     mode), file_list));
  } else {
    return make_catenated_stream(lazy_mapcar(func_n2o(open_file, 1), file_list));
  }
}

static val volume_prefix_p(const wchar_t *str)
{
  enum { init, slash } state;

  for (state = init; *str; str++) {
    wchar_t ch = *str;
    switch (state) {
    case init:
      if (iswalnum(ch))
        continue;
      if (ch == ':') {
        state = slash;
        continue;
      }
      return nil;
    case slash:
      if (ch == '/' || ch == '\\')
        return t;
      return nil;
    }
  }

  return nil;
}

static val volume_name_p(const wchar_t *str)
{
  for (; *str; str++) {
    if (iswalnum(*str))
      continue;
    if (*str == ':')
      return t;
    break;
  }

  return nil;
}

val portable_abs_path_p(val path)
{
  val self = lit("portable-abs-path-p");
  const wchar_t *str = c_str(path, self);

  if (*str == 0)
    return nil;
  if (str[0] == '/' || str[0] == '\\')
    return t;
  return volume_prefix_p(str);
}

val abs_path_p(val path)
{
  val self = lit("abs-path-p");
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
  const wchar_t *str = c_str(path, self);

  if (*str == 0)
    return nil;
  if (wcschr(psc, str[0]))
    return t;

  if (psc[0] != '\\')
    return nil;

  return volume_prefix_p(str);
}

val pure_rel_path_p(val path)
{
  val self = lit("pure-rel-path-p");
  const wchar_t *str = c_str(path, self);

  if (str[0] == 0)
    return t;

  if (str[0] == '/' || str[0] == '\\')
    return nil;

  if (str[1] == 0)
    return str[0] == '.' ? nil : t;

  if (str[0] == '.' && (str[1] == '/' || str[1] == '\\'))
    return nil;

  if (volume_name_p(str))
    return nil;

  return t;
}

static void detect_path_separators(void)
{
#ifdef __CYGWIN__
  struct utsname un;

  if (uname(&un) >= 0) {
    if (strncmp(un.sysname, "CYGNAL", 6) == 0) {
      path_sep_chars = wli("\\/");
      path_var_sep_char = ';';
    }
  }
#endif
}

val base_name(val path, val suff)
{
  val self = lit("base-name");
  const wchar_t *wpath = c_str(path, self);
  const wchar_t *end = wpath + c_num(length_str(path), self);
  const wchar_t *rsep;
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);

  if (end == wpath)
    return null_string;

  while (wpath < end && wcschr(psc, end[-1]))
    end--;

  if (end == wpath)
    return lit("/");

  for (rsep = end;
       wpath < rsep && wcschr(psc, rsep[-1]) == 0;
       rsep--)
    ; /* *empty */


  {
    val base = mkustring(num_fast(end - rsep));
    init_str(base, rsep, self);
    return if3(!null_or_missing_p(suff) && ends_with(suff, base, nil, nil) &&
               plusp(length(suff)) && neql(length(suff), length(base)),
               sub(base, zero, neg(length(suff))),
               base);
  }
}

val dir_name(val path)
{
  val self = lit("dir-name");
  const wchar_t *wpath = c_str(path, self);
  const wchar_t *rsep = wpath + c_num(length_str(path), self);
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);

  if (rsep == wpath)
    return lit(".");

  if (wcschr(psc, rsep[-1]))
    rsep--;

  if (rsep == wpath) {
    wchar_t root[2] = { psc[0] };
    return string(root);
  }

  for (; rsep > wpath && wcschr(psc, rsep[-1]) == 0; rsep--)
    ; /* *empty */

  if (rsep == wpath + 1) {
    wchar_t root[2] = { psc[0] };
    return string(root);
  }

  if (rsep == wpath)
    return lit(".");


  {
    val base = mkustring(num_fast(rsep - wpath - 1));
    return init_str(base, wpath, self);
  }
}

val short_suffix(val name, val alt_in)
{
  val self = lit("short-suffix");
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
  const wchar_t *str = c_str(name, self);
  const wchar_t *dot = wcsrchr(str, '.');
  const wchar_t *sl = if3(dot, wcspbrk(dot + 1, psc), 0);
  int sl_trail = if3(sl, sl[wcsspn(sl, psc)] == 0, 0);

  if (!dot || (sl && sl[1] && !sl_trail) || dot == str || wcschr(psc, dot[-1])) {
    return default_null_arg(alt_in);
  } else {
    wchar_t *suff = chk_strdup(dot);
    if (sl)
      suff[sl - dot] = 0;
    return string_own(suff);
  }
}

val long_suffix(val name, val alt_in)
{
  val self = lit("long-suffix");
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
  const wchar_t *str = c_str(name, self);
  const wchar_t *dot = wcschr(str, '.');

  {
    const wchar_t *sl;

    while (dot && (sl = wcspbrk(dot, psc)) && sl[1] && sl[wcsspn(sl, psc)] != 0)
      dot = wcschr(sl + 1, '.');

    if (dot && (dot == str || wcschr(psc, dot[-1])))
      dot = wcschr(dot + 1, '.');

    if (!dot || dot == str) {
      return default_null_arg(alt_in);
    } else {
      wchar_t *suff = chk_strdup(dot);
      if (sl)
        suff[sl - dot] = 0;
      return string_own(suff);
    }
  }
}

val trim_short_suffix(val name)
{
  val self = lit("trim-short-suffix");
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
  const wchar_t *str = c_str(name, self);
  const wchar_t *dot = wcsrchr(str, '.');
  const wchar_t *sl = if3(dot, wcspbrk(dot + 1, psc), 0);
  int sl_trail = if3(sl, sl[wcsspn(sl, psc)] == 0, 0);

  if (!dot || (sl && sl[1] && !sl_trail) || dot == str || wcschr(psc, dot[-1])) {
    return name;
  } else {
    size_t off = dot - str;
    if (sl) {
      size_t slsz = wcslen(sl) + 1;
      size_t nchar = off + slsz;
      wchar_t *out = chk_wmalloc(nchar);
      wmemcpy(out, str, off);
      wmemcpy(out + off, sl, slsz);
      return string_own(out);
    } else {
      wchar_t *pref = chk_substrdup(str, 0, dot - str);
      return string_own(pref);
    }
  }
}

val trim_long_suffix(val name)
{
  val self = lit("trim-long-suffix");
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
  const wchar_t *str = c_str(name, self);
  const wchar_t *dot = wcschr(str, '.');

  {
    const wchar_t *sl;

    while (dot && (sl = wcspbrk(dot, psc)) && sl[1] && sl[wcsspn(sl, psc)] != 0)
      dot = wcschr(sl + 1, '.');

    if (dot && (dot == str || wcschr(psc, dot[-1])))
      dot = wcschr(dot + 1, '.');

    if (!dot || dot == str) {
      return name;
    } else {
      size_t off = dot - str;
      if (sl) {
        size_t slsz = wcslen(sl) + 1;
        size_t nchar = off + slsz;
        wchar_t *out = chk_wmalloc(nchar);
        wmemcpy(out, str, off);
        wmemcpy(out + off, sl, slsz);
        return string_own(out);
      } else {
        wchar_t *pref = chk_substrdup(str, 0, dot - str);
        return string_own(pref);
      }
    }
  }
}

val trim_path_seps(val name)
{
  val self = lit("trim-path-seps");
  const wchar_t *str = c_str(name, self);
  const wchar_t *psc = L"/\\";
  const wchar_t *fsl = 0;
  cnum len = c_num(length_str(name), self);

  if (portable_abs_path_p(name))
    fsl = wcspbrk(str, psc);

  while (len-- > 0)
    if (!wcschr(psc, str[len]) || str + len == fsl)
      break;

  return string_own(chk_substrdup(str, 0, len + 1));
}

val add_suffix(val name, val suffix)
{
  val self = lit("add-suffix");
  size_t len_n = c_unum(length_str(name), self);
  size_t len_s = c_unum(length_str(suffix), self);
  const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
  const wchar_t *nam = c_str(name, self);
  const wchar_t *suf = c_str(suffix, self);
  const wchar_t *sl = wcspbrk(nam, psc);

  if (psc[0] == '\\' || 1) {
    const wchar_t *set = L"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                         L"abcdefghijklmnopqrstuvwxyz"
                         L"0123456789";
    const wchar_t *drv = nam + wcsspn(nam, set);
    if (drv[0] == ':' && sl == drv + 1) {
      if (drv - nam > 1) {
        if (wcschr(psc, drv[2]))
          sl = wcspbrk(drv + 3, psc);
      } else if (drv  > nam) {
        sl = wcspbrk(drv + 2, psc);
      }
    }
  }

  if (sl == nam)
    sl = wcspbrk(nam + 1, psc);

  while (sl) {
    const wchar_t *nsl = sl + 1 + wcsspn(sl + 1, psc);

    if (*nsl == 0) {
      size_t nchar = len_n + len_s + 1;
      size_t offs = sl - nam;
      wchar_t *out = chk_wmalloc(nchar);
      wmemcpy(out, nam, offs);
      wmemcpy(out + offs, suf, len_s);
      wcscpy(out + offs + len_s, sl);
      return string_own(out);
    }

    sl = wcspbrk(nsl, psc);
  }

  return scat2(name, suffix);
}

val path_cat(val dir_name, val base_name)
{
  val dl = length_str(dir_name);
  val bl = length_str(base_name);
  val ps = static_str(path_sep_chars);

  if (dl == zero)
    return base_name;

  if (bl == zero)
    return dir_name;

  if (find(chr_str(dir_name, pred(dl)), ps, nil, nil)) {
    val bl0 = chr_str(base_name, zero);

    if (bl == one && bl0 == chr('.'))
      return dir_name;

    if (dl == two && chr_str(dir_name, zero) == chr('.'))
      return base_name;

    if (!find(bl0, ps, nil, nil))
      return scat(nil, dir_name, base_name, nao);

    return scat(nil, dir_name, sub(base_name, one, t), nao);
  }

  if (find(chr_str(base_name, zero), ps, nil, nil))
    return scat(nil, dir_name, base_name, nao);

  if (bl == one && chr_str(base_name, zero) == chr('.'))
    return dir_name;

  if (dl == one && chr_str(dir_name, zero) == chr('.'))
    return base_name;

  return scat(lit("/"), dir_name, base_name, nao);
}

static val path_vcat(varg args)
{
  cnum ix = 0;

  if (!args_more(args, ix)) {
    return lit(".");
  } else {
    val accum = args_get(args, &ix);

    if (!stringp(accum))
      uw_throwf(file_error_s, lit("path-cat: ~s isn't a string"), accum, nao);

    while (args_more(args, ix))
      accum = path_cat(accum, args_get(args, &ix));

    return accum;
  }
}

val make_byte_input_stream(val obj)
{
  val self = lit("make-byte-input-stream");

  switch (type(obj)) {
  case LIT:
  case STR:
  case LSTR:
    return make_string_byte_input_stream(obj);
  case BUF:
    return make_buf_stream(obj);
  default:
    uw_throwf(file_error_s, lit("~a: ~s is neither a string nor buffer"),
              self, obj, nao);
  }
}

val tmpfile_wrap(void)
{
  val self = lit("tmpfile");
  struct stdio_mode m_blank = stdio_mode_init_blank;
  struct stdio_mode m = do_parse_mode(lit("w+b"), m_blank, self);
  FILE *tf = tmpfile();
  if (tf != 0)
    return set_mode_props(m, make_stdio_stream(tf, self));
  uw_ethrowf(file_error_s, lit("~a failed: ~d/~s"),
             self, num(errno), errno_to_str(errno), nao);
}

#if HAVE_MKDTEMP

val mkdtemp_wrap(val prefix)
{
  val self = lit("mkdtemp");
  char *tmpl = utf8_dup_to(c_str(scat2(prefix, lit("XXXXXX")), self));

  if (mkdtemp(tmpl) != 0) {
    val ret = string_utf8(tmpl);
    free(tmpl);
    return ret;
  }

  free(tmpl);
  uw_ethrowf(file_error_s, lit("mkdtemp failed: ~d/~s"),
             num(errno), errno_to_str(errno), nao);
}

#endif

#if HAVE_MKSTEMP

val mkstemp_wrap(val prefix, val suffix)
{
  val self = lit("mkstemp");
  val suff = default_arg_strict(suffix, null_string);
  val templ = scat3(prefix, lit("XXXXXX"), suff);
  cnum slen = c_num(length(suff), self);
  char *tmpl = utf8_dup_to(c_str(templ, self));
  val name;
  int fd;

#if HAVE_MKSTEMPS
  fd = mkstemps(tmpl, slen);
#else
  if (slen > 0) {
    free(tmpl);
    uw_throwf(system_error_s, lit("~a: suffix not supported"), self, nao);
  }
  fd = mkstemp(tmpl);
#endif
  name = string_utf8(tmpl);
  free(tmpl);
  if (fd != -1) {
    val stream = open_fileno(num(fd), lit("w+b"), nil);
    stream_set_prop(stream, name_k, name);
    return stream;
  }
  uw_ethrowf(file_error_s, lit("~a failed: ~d/~s"),
             self, num(errno), errno_to_str(errno), nao);
}

#endif

static val iobuf_free_list;

val iobuf_get(void)
{
  val buf = iobuf_free_list;

  if (buf) {
    val next = buf->b.len;
    buf->b.len = buf->b.size;
    iobuf_free_list = next;
    return buf;
  } else {
    return make_buf(num_fast(BUFSIZ), nil, nil);
  }
}

void iobuf_put(val buf)
{
  buf->b.len = iobuf_free_list;
  iobuf_free_list = buf;
}

void iobuf_list_empty(void)
{
  iobuf_free_list = nil;
}

void stream_init(void)
{
  prot1(&top_stderr);

  detect_format_string();
  detect_path_separators();

  from_start_k = intern(lit("from-start"), keyword_package);
  from_current_k = intern(lit("from-current"), keyword_package);
  from_end_k = intern(lit("from-end"), keyword_package);
  real_time_k = intern(lit("real-time"), keyword_package);
  name_k = intern(lit("name"), keyword_package);
  addr_k = intern(lit("addr"), keyword_package);
  fd_k = intern(lit("fd"), keyword_package);
  byte_oriented_k = intern(lit("byte-oriented"), keyword_package);
  standard_k = intern(lit("standard"), keyword_package);
  format_s = intern(lit("format"), user_package);
  stdio_stream_s = intern(lit("stdio-stream"), user_package);
#if HAVE_SOCKETS
  socket_error_s = intern(lit("socket-error"), user_package);
#endif

  put_string_s = intern(lit("put-string"), user_package);
  put_char_s = intern(lit("put-char"), user_package);
  put_byte_s = intern(lit("put-byte"), user_package);
  get_line_s = intern(lit("get-line"), user_package);
  get_char_s = intern(lit("get-char"), user_package);
  get_byte_s = intern(lit("get-byte"), user_package);
  unget_char_s = intern(lit("unget-char"), user_package);
  unget_byte_s = intern(lit("unget-byte"), user_package);
  put_buf_s = intern(lit("put-buf"), user_package);
  fill_buf_s = intern(lit("fill-buf"), user_package);
  flush_s = intern(lit("flush"), user_package);
  seek_s = intern(lit("seek"), user_package);
  truncate_s = intern(lit("truncate"), user_package);
  get_prop_s = intern(lit("get-prop"), user_package);
  set_prop_s = intern(lit("set-prop"), user_package);
  get_error_s = intern(lit("get-error"), user_package);
  get_error_str_s = intern(lit("get-error-str"), user_package);
  clear_error_s = intern(lit("clear-error"), user_package);
  get_fd_s = intern(lit("get-fd"), user_package);

  stream_cls = cobj_register(stream_s);
  stdio_stream_cls = cobj_register_super(stdio_stream_s, stream_cls);

  reg_var(stdin_s = intern(lit("*stdin*"), user_package),
          make_stdio_stream(stdin, lit("stdin")));
  reg_var(stdout_s = intern(lit("*stdout*"), user_package),
          make_stdio_stream(stdout, lit("stdout")));
  reg_var(stddebug_s = intern(lit("*stddebug*"), user_package),
          make_stdio_stream(stdout, lit("debug")));
  reg_var(stderr_s = intern(lit("*stderr*"), user_package),
          top_stderr = make_stdio_stream(stderr, lit("stderr")));
  reg_var(stdnull_s = intern(lit("*stdnull*"), user_package),
          make_null_stream());

  reg_var(print_flo_precision_s = intern(lit("*print-flo-precision*"),
                                         user_package),
          num_fast(DBL_DIG));
  reg_var(print_flo_digits_s = intern(lit("*print-flo-digits*"),
                                      user_package),
          num_fast(3));
  reg_var(print_flo_format_s = intern(lit("*print-flo-format*"),
                                      user_package),
          lit("~s"));
  reg_var(pprint_flo_format_s = intern(lit("*pprint-flo-format*"),
                                       user_package),
          lit("~a"));
  reg_var(print_base_s = intern(lit("*print-base*"), user_package),
          num_fast(10));
  reg_var(print_circle_s = intern(lit("*print-circle*"), user_package), nil);
  reg_var(print_json_format_s = intern(lit("*print-json-format*"), user_package), nil);
  reg_var(print_json_type_s = intern(lit("*print-json-type*"), user_package), t);

#if HAVE_ISATTY
  if (isatty(fileno(stdin)) == 1) {
    stream_set_prop(std_input, real_time_k, t);
    setbuf(stdin, 0);
  }
#endif

  reg_fun(format_s, func_n2v(formatv));
  reg_fun(intern(lit("fmt"), user_package), func_n1v(fmt));
  reg_fun(intern(lit("make-string-input-stream"), user_package), func_n1(make_string_input_stream));
  reg_fun(intern(lit("make-string-byte-input-stream"), user_package), func_n1(make_string_byte_input_stream));
  reg_fun(intern(lit("make-strlist-input-stream"), user_package), func_n1(make_strlist_input_stream));
  reg_fun(intern(lit("make-string-output-stream"), user_package), func_n0(make_string_output_stream));
  reg_fun(intern(lit("get-string-from-stream"), user_package), func_n1(get_string_from_stream));
  reg_fun(intern(lit("make-strlist-output-stream"), user_package), func_n0(make_strlist_output_stream));
  reg_fun(intern(lit("get-list-from-stream"), user_package), func_n1(get_list_from_stream));
  reg_fun(intern(lit("make-byte-input-stream"), user_package), func_n1(make_byte_input_stream));
  reg_fun(intern(lit("close-stream"), user_package), func_n2o(close_stream, 1));
  reg_fun(get_error_s, func_n1(get_error));
  reg_fun(get_error_str_s, func_n1(get_error_str));
  reg_fun(clear_error_s, func_n1(clear_error));
  reg_fun(get_line_s, func_n1o(get_line, 0));
  reg_fun(get_char_s, func_n1o(get_char, 0));
  reg_fun(get_byte_s, func_n1o(get_byte, 0));
  reg_fun(intern(lit("get-string"), user_package), func_n3o(get_string, 0));
  reg_fun(put_string_s, func_n2o(put_string, 1));
  reg_fun(intern(lit("put-line"), user_package), func_n2o(put_line, 0));
  reg_fun(put_char_s, func_n2o(put_char, 1));
  reg_fun(put_byte_s, func_n2o(put_byte, 1));
  reg_fun(intern(lit("put-lines"), user_package), func_n2o(put_lines, 1));
  reg_fun(intern(lit("put-strings"), user_package), func_n2o(put_strings, 1));
  reg_fun(unget_char_s, func_n2o(unget_char, 1));
  reg_fun(unget_byte_s, func_n2o(unget_byte, 1));
  reg_fun(put_buf_s, func_n3o(put_buf, 1));
  reg_fun(fill_buf_s, func_n3o(fill_buf, 1));
  reg_fun(intern(lit("get-line-as-buf"), user_package), func_n1o(get_line_as_buf, 0));
  reg_fun(intern(lit("fill-buf-adjust"), user_package), func_n3o(fill_buf_adjust, 1));
  reg_fun(intern(lit("flush-stream"), user_package), func_n1o(flush_stream, 0));
  reg_fun(intern(lit("seek-stream"), user_package), func_n3(seek_stream));
  reg_fun(intern(lit("truncate-stream"), user_package), func_n2o(truncate_stream, 1));
  reg_fun(intern(lit("streamp"), user_package), func_n1(streamp));
  reg_fun(intern(lit("real-time-stream-p"), user_package), func_n1(real_time_stream_p));
  reg_fun(intern(lit("stream-set-prop"), user_package), func_n3(stream_set_prop));
  reg_fun(intern(lit("stream-get-prop"), user_package), func_n2(stream_get_prop));
  reg_fun(intern(lit("fileno"), user_package), func_n1(stream_fd));
#if HAVE_SOCKETS
  reg_fun(intern(lit("sock-family"), user_package), func_n1(sock_family));
  reg_fun(intern(lit("sock-type"), user_package), func_n1(sock_type));
  reg_fun(intern(lit("sock-peer"), user_package), func_n1(sock_peer));
  reg_fun(intern(lit("sock-set-peer"), user_package), func_n2(sock_set_peer));
#endif
  reg_fun(intern(lit("make-catenated-stream"), user_package), func_n0v(make_catenated_stream_v));
  reg_fun(intern(lit("cat-streams"), user_package), func_n1(make_catenated_stream));
  reg_fun(intern(lit("catenated-stream-p"), user_package), func_n1(catenated_stream_p));
  reg_fun(intern(lit("catenated-stream-push"), user_package), func_n2(catenated_stream_push));
  reg_fun(intern(lit("record-adapter"), user_package), func_n3o(record_adapter, 1));
  reg_fun(intern(lit("open-directory"), user_package), func_n1(open_directory));
  reg_fun(intern(lit("open-file"), user_package), func_n2o(open_file, 1));
  reg_fun(intern(lit("open-fileno"), user_package), func_n3o(open_fileno, 1));
  reg_fun(intern(lit("open-tail"), user_package), func_n3o(open_tail, 1));
  reg_fun(intern(lit("path-search"), user_package), func_n2o(path_search, 1));
  reg_fun(intern(lit("open-command"), user_package), func_n2o(open_command, 1));
  reg_fun(intern(lit("open-pipe"), user_package), func_n2(open_command));
  reg_fun(intern(lit("open-process"), user_package), func_n3o(open_process, 2));
#if HAVE_FORK_STUFF
  reg_fun(intern(lit("open-subprocess"), user_package), func_n4o(open_subprocess, 2));
#endif
#if HAVE_WSPAWN || HAVE_SPAWN || HAVE_FORK_STUFF
  reg_fun(intern(lit("sh"), user_package), func_n1(sh));
  reg_fun(intern(lit("run"), user_package), func_n2o(run, 1));
#endif
  reg_fun(intern(lit("sh-esc"), user_package), func_n1(sh_esc));
  reg_fun(intern(lit("sh-esc-all"), user_package), func_n1(sh_esc_all));
  reg_fun(intern(lit("sh-esc-dq"), user_package), func_n1(sh_esc_dq));
  reg_fun(intern(lit("sh-esc-sq"), user_package), func_n1(sh_esc_sq));
  reg_fun(intern(lit("remove-path"), user_package), func_n2o(remove_path, 1));
  reg_fun(intern(lit("rename-path"), user_package), func_n2(rename_path));
  reg_fun(intern(lit("open-files"), user_package), func_n3o(open_files, 1));
  reg_fun(intern(lit("open-files*"), user_package), func_n3o(open_files_star, 1));
  reg_fun(intern(lit("portable-abs-path-p"), user_package), func_n1(portable_abs_path_p));
  reg_fun(intern(lit("abs-path-p"), user_package), func_n1(abs_path_p));
  reg_fun(intern(lit("pure-rel-path-p"), user_package), func_n1(pure_rel_path_p));
  reg_fun(intern(lit("base-name"), user_package), func_n2o(base_name, 1));
  reg_fun(intern(lit("dir-name"), user_package), func_n1(dir_name));
  reg_fun(intern(lit("short-suffix"), user_package), func_n2o(short_suffix, 1));
  reg_fun(intern(lit("long-suffix"), user_package), func_n2o(long_suffix, 1));
  reg_fun(intern(lit("trim-short-suffix"), user_package), func_n1(trim_short_suffix));
  reg_fun(intern(lit("trim-long-suffix"), user_package), func_n1(trim_long_suffix));
  reg_fun(intern(lit("trim-path-seps"), user_package), func_n1(trim_path_seps));
  reg_fun(intern(lit("path-cat"), user_package), func_n0v(path_vcat));
  reg_fun(intern(lit("add-suffix"), user_package), func_n2(add_suffix));
  reg_varl(intern(lit("path-sep-chars"), user_package), static_str(path_sep_chars));
  reg_fun(intern(lit("get-indent-mode"), user_package), func_n1(get_indent_mode));
  reg_fun(intern(lit("test-set-indent-mode"), user_package), func_n3(test_set_indent_mode));
  reg_fun(intern(lit("test-neq-set-indent-mode"), user_package), func_n3(test_neq_set_indent_mode));
  reg_fun(intern(lit("set-indent-mode"), user_package), func_n2(set_indent_mode));
  reg_fun(intern(lit("get-indent"), user_package), func_n1(get_indent));
  reg_fun(intern(lit("set-indent"), user_package), func_n2(set_indent));
  reg_fun(intern(lit("inc-indent"), user_package), func_n2(inc_indent));
  reg_fun(intern(lit("inc-indent-abs"), user_package), func_n2(inc_indent_abs));
  reg_fun(intern(lit("width-check"), user_package), func_n2(width_check));
  reg_fun(intern(lit("force-break"), user_package), func_n1(force_break));
  reg_fun(intern(lit("set-max-length"), user_package), func_n2(set_max_length));
  reg_fun(intern(lit("set-max-depth"), user_package), func_n2(set_max_depth));
  reg_varl(intern(lit("indent-off"), user_package), num_fast(indent_off));
  reg_varl(intern(lit("indent-data"), user_package), num_fast(indent_data));
  reg_varl(intern(lit("indent-code"), user_package), num_fast(indent_code));
  reg_varl(intern(lit("indent-foff"), user_package), num_fast(indent_foff));
  reg_fun(intern(lit("tmpfile"), user_package), func_n0(tmpfile_wrap));
#if HAVE_MKDTEMP
  reg_fun(intern(lit("mkdtemp"), user_package), func_n1(mkdtemp_wrap));
#endif
#if HAVE_MKSTEMP
  reg_fun(intern(lit("mkstemp"), user_package), func_n2o(mkstemp_wrap, 1));
#endif

#if HAVE_SOCKETS
  uw_register_subtype(socket_error_s, error_s);
#endif

  fill_stream_ops(&null_ops);
  fill_stream_ops(&stdio_ops);
  fill_stream_ops(&tail_ops);
#if HAVE_FORK_STUFF
  fill_stream_ops(&pipe_ops);
#endif
  fill_stream_ops(&string_in_ops);
  fill_stream_ops(&byte_in_ops);
  fill_stream_ops(&strlist_in_ops);
  fill_stream_ops(&string_out_ops);
  fill_stream_ops(&strlist_out_ops);
  fill_stream_ops(&dir_ops);
  fill_stream_ops(&cat_stream_ops);

#if HAVE_SOCKETS
  stdio_sock_ops = stdio_ops;
  stdio_sock_ops.name = wli("stream-sock");
  stdio_sock_ops.get_prop = sock_get_prop;
  stdio_sock_ops.set_prop = sock_set_prop;
  stdio_sock_ops.get_sock_family = stdio_get_sock_family;
  stdio_sock_ops.get_sock_type = stdio_get_sock_type;
  stdio_sock_ops.get_sock_peer = stdio_get_sock_peer;
  stdio_sock_ops.set_sock_peer = stdio_set_sock_peer;

  record_adapter_ops.get_sock_family = delegate_get_sock_family;
  record_adapter_ops.get_sock_type = delegate_get_sock_type;
  record_adapter_ops.get_sock_peer = delegate_get_sock_peer;
  record_adapter_ops.set_sock_peer = delegate_set_sock_peer;
#endif


  shell = lit("/bin/sh");
  shell_arg = lit("-c");

#ifdef __CYGWIN__
  {
    const char *sh = getusershell();
    if (sh && strstr(sh, "cmd.exe")) {
      prot1(&shell);
      shell = string_utf8(sh);
      shell_arg = lit("/c");
    }
  }
#endif

#if HAVE_ZLIB
  gzio_init();
#endif
}

void stream_compat_fixup(int compat_ver)
{
  if (compat_ver <= 258)
    reg_fun(intern(lit("abs-path-p"), user_package),
            func_n1(portable_abs_path_p));
}