khipu/io.cpp

/* Definitions for high-level IO functions.

   This file is part of khipu.

   khipu is free software: you can redistribute it and/or modify
   it under the terms of the GNU Lesser General Public License as published by
   the Free Software Foundation; either version 3 of the License, or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.  */

#include <cctype>
#include <cstdlib>
#include <cstdio>
#include <cstdarg>
#include <cerrno>
#include <new>

#include "khipu.hpp"
#include "utils/chmask.hpp"
#include "utils/raw_acc.hpp"

KP_DECLS_BEGIN

static inline exception
raise_eos (interpreter *interp)
{
  return (interp->raise ("parse-error", "read: premature end of input"));
}

enum
{
  TOK_NONE,
  TOK_OPEN,
  TOK_CLOSE,
  TOK_DOT, 
  TOK_SYM,
  TOK_NUM,
  TOK_CHAR,
  TOK_COMMA,
  TOK_COMMAAT,
  TOK_COMMADOT,
  TOK_BQ,
  TOK_QUOTE,
  TOK_SHARPDOT,
  TOK_LABEL,
  TOK_BACKREF,
  TOK_SHARPQUOTE, 
  TOK_SHARPOPEN, 
  TOK_OPENB,
  TOK_CLOSEB,
  TOK_OPENBRACE,
  TOK_CLOSEBRACE,
  TOK_SHARPSYM,
  TOK_GENSYM,
  TOK_DQUOTE,
  TOK_SHARPDQUOT
};

static inline bool
symchar_p (int c)
{
  static const char SPEC_CHS[] = "()[]{}'\";`,\\| \f\n\r\t\v";
  return (!memchr (SPEC_CHS, c, sizeof (SPEC_CHS) - 1));
}

static result<bool>
numtok_p (interpreter *interp, char *tok, int len)
{
  if (*tok == '\0')
    return (false);
  else if (len == 4 && (memcmp (tok, "-INF", 4) == 0 ||
      memcmp (tok, "+INF", 4) == 0))
    {
      interp->retval = *tok == '-' ? FLT_NINF : FLT_PINF;
      return (true);
    }
  else if (len == 3 && memcmp (tok, "NaN", 3) == 0)
    {
      interp->retval = FLT_QNAN;
      return (true);
    }

  num_info info;

  if (tok[len - 1] == '.')
    tok[len++] = '0';

  if (parse_num (interp, tok, len, info) < 0)
    return (false);
  else if (info.type == typecode::INT)
    {
      int slen = info.dec_end - info.dec_start;
      int rl = invbsize (info.radix, slen) + 1;

      if (rl == 1)
        { // May fit in a fixint.
          intptr_t uval = strtoui1 (tok + info.dec_start, slen, info.radix);
          intptr_t val = info.sign ? -uval : uval;

          interp->retval = intobj (interp, val);
        }
      else
        {
          bigint *lp = as_bigint (alloc_bigint (interp, rl));
          lp->len = strtoui (lp->data, tok + info.dec_start, slen, info.radix);

#ifdef KP_ARCH_WIDE
          interp->retval = lp->as_obj () | (info.sign ? SIGN_BIT : 0);
#else
          if (info.sign)
            lp->len = -lp->len;

          interp->retval = lp->as_obj ();
#endif
        }

      return (true);
    }

  // info.type == typecode::FLOAT
  int expo, slen = info.frac_end - info.dec_start - 1;

  if (info.expo_start != 0)
    {
      uint32_t uev;

      if (invbsize (info.radix, len - info.expo_start) > 1 ||
          (uev = strtoui1 (&tok[info.expo_start], len -
            info.expo_start, info.radix)) >
          0x7fffffffu + info.expo_sign)
        return (interp->raise ("arith-error", "exponent "
                               "too large in floating point value"));

      expo = info.expo_sign ? -(int)uev : uev;
    }
  else
    expo = 0;

  if (info.frac_end != 0)
    expo -= info.frac_end - info.dec_end - info.got_dot;

  /* The maximum number of limbs to be used by 'strtolf' is the
   * sum of the limbs needed by the mantissa and radix^exponent,
   * given that it may end up multiplying them. */
  int nlimbs = invbsize (info.radix, slen) +
               invbsize (info.radix, abs (expo)) + 2;
  tmp_allocator ta { interp };
  limb_t *mp = (limb_t *)ta.alloc (nlimbs * sizeof (*mp));
  memset (mp, 0, nlimbs * sizeof (*mp));

  int ret = strtolf (interp, tok, len, info, expo, mp);
  int b2exp = (expo - ret) * LIMB_BITS;

  if (b2exp >= DBL_MIN_EXP && b2exp <= DBL_MAX_EXP)
    { // See if we can fit it in a double.
      double dbl = uitodbl (mp, ret, expo);
      if (!finf_p (dbl))
        {
          interp->retval = fltobj::make (interp,
                                         info.sign ? -dbl : dbl);
          return (true);
        }
    }

  bigfloat *fp = as_bigfloat (alloc_bigfloat (interp, ret));
  memcpy (fp->data, mp, (fp->len = ret) * sizeof (*fp->data));
  fp->expo = expo;

#ifdef KP_ARCH_WIDE
  interp->retval = fp->as_obj () | (info.sign ? SIGN_BIT : 0);
#else
  if (info.sign)
    fp->len = -fp->len;

  interp->retval = fp->as_obj ();
#endif

  return (true);
}

static const struct
{
  const char *name;
  uint32_t value;
} CHAR_NAMES[] =
{
  { "lf", '\n'  },
  { "tab", '\t' },
  { "sp", ' ' },
  { "nil", '\0' },
  { "bell", '\a' },
  { "back", '\b' },
  { "ret", '\r' },
  { "vtab", '\v' }
};

const char* chobj_repr (uint32_t ch)
{
  for (size_t i = 0; i < KP_NELEM (CHAR_NAMES); ++i)
    if (ch == CHAR_NAMES[i].value)
      return (CHAR_NAMES[i].name);

  return (nullptr);
}

reader::reader (interpreter *ip, object input, package *pkg) :
  interp (ip), pairs_valref (ip), ipkg (pkg)
{
  this->pairs.local_init (this->stpairs, KP_NELEM (this->stpairs));

  this->pair_cnt = 0;
  for (uint32_t i = 0; i < this->pairs.len; ++i)
    this->pairs.data[i] = UNBOUND;

  this->bufmax = KP_NELEM (this->stbuf);
  this->bufp = this->stbuf;

  this->take ();
  this->src = as_stream (input);
  *this->pairs_valref = this->pairs.as_obj ();

  if (!this->ipkg)
    this->ipkg = as_package (ip->xpkg);
}

void reader::take ()
{
  this->toktype = TOK_NONE;
  this->bufcnt = 0;
}

void reader::push_ch (const schar& ch)
{
  if (this->bufcnt + ch.len >= this->bufmax)
    {
      int nsize = (int)upsize (this->bufcnt + ch.len + 1);
      char *nbuf = (char *)xmalloc (nsize);

      memcpy (nbuf, this->bufp, this->bufcnt);
      if (this->bufp != this->stbuf)
        xfree (this->bufp);

      this->bufp = nbuf;
      this->bufmax = nsize;
    }

  fscpy (this->bufp + this->bufcnt, ch.buf, ch.len);
  this->bufcnt += ch.len;
}

result<bool> reader::read_token (schar& ch, int digs)
{
  bool first = true;
  int esc_p = 0, sym_p = 0;
  while (true)
    {
      if (!first)
        {
          bool rv = KP_TRY (this->src->sgetc (this->interp, ch));
          if (!rv)
            goto term;
        }

      first = false;
      if (ch.uc == '|')
        esc_p ^= (sym_p = 1);
      else if (ch.uc == '\\')
        {
          sym_p = 1;
          bool rv = KP_TRY (this->src->sgetc (this->interp, ch));
          if (!rv)
            goto term;

          this->push_ch (ch);
        }
      else if (!esc_p && (!symchar_p (ch.uc) &&
          (!digs || isdigit (ch.uc))))
        break;
      else
        this->push_ch (ch);
    }

  this->src->ungetuc (ch.buf, ch.len);
term:
  this->bufp[this->bufcnt] = '\0';
  return (sym_p != 0);
}

void reader::expand ()
{
  object *p2 = (object *)xmalloc (this->pairs.len * 2);
  copy_objs (p2, this->pairs.data, this->pairs.len);

  this->pairs.len *= 2;
  if (this->pairs.data != this->stpairs)
    xfree (this->pairs.data);

  this->pairs.data = p2;
}

object reader::getlbl (object lbl) const
{
  for (uint32_t i = 0; i < this->pair_cnt; i += 2)
    if (this->pairs.data[i] == lbl)
      return (this->pairs.data[i + 1]);

  return (UNBOUND);
}

object* reader::putlbl (object lbl)
{
  for (uint32_t i = 0; i < this->pair_cnt; i += 2)
    if (this->pairs.data[i] == UNBOUND)
      {
        this->pairs.data[i] = lbl;
        return (&this->pairs.data[i + 1]);
      }
    else if (this->pairs.data[i] == lbl)
      return (&this->pairs.data[i + 1]);

  if (this->pair_cnt == this->pairs.len)
    this->expand ();

  this->pairs.data[this->pair_cnt++] = lbl;
  return (&this->pairs.data[this->pair_cnt]);
}

result<bool> reader::nextc (schar& ch)
{
  do
    {
      bool rv = KP_TRY (this->src->sgetc (this->interp, ch));
      if (!rv)
        return (false);
      else if (ch.uc == ';')
        do
          {
            rv = KP_TRY (this->src->sgetc (this->interp, ch));
            if (!rv)
              return (false);
          }
        while (ch.uc != '\n');

      if (ch.uc == '\n')
        ++this->lineno;
    }
  while (isspace (ch.uc));

  return (true);
}

static inline bool
check_symname (interpreter *interp, const char *name, int len)
{
  num_info info;
  return (parse_num (interp, name, len, info) < 0);
}

static result<void>
update_pkg_expr (interpreter *interp, const char *sname,
  const char *uptr, const char *uend, object& out)
{
  valref key = KP_TRY (symbol::make_kword (interp, uptr, uend - uptr));

  if (out == UNBOUND)
    {
      out = KP_TRY (KP_CALL (interp, list_fct,
                             intern (interp, sname, (uptr - sname) - 2), *key));
    }
  else
    {
      *key = KP_TRY (cons::make (interp, *key, NIL));
      out = KP_TRY (cons::make (interp, out, *key));
    }

  return (0);
}

static result<object>
make_pkg_expr (interpreter *interp, object name, object ipkg)
{
  /* Transform a symbol name of the kind 'a::b::c' into its equivalent
   * expression: ((a :b) :c).
   * This is required when the symbol can't be resolved at read-time,
   * and is therefore delegated to a runtime lookup. */
  const char *sname = str_cdata (name);
  int len = as_str(name)->nbytes;
  valref ret (interp, UNBOUND), key (interp, UNBOUND);

  while (true)
    {
      auto uptr = (const char *)memchr (sname, ':', len);
      if (!uptr)
        { // Last name - Append and we're out.
          *key = KP_TRY (symbol::make_kword (interp, sname, len));
          *key = KP_TRY (cons::make (interp, *key, NIL));
          *ret = KP_TRY (cons::make (interp, *ret, *key));
          break;
        }
      else if (uptr[1] != *uptr)
        return (interp->raise ("parse-error",
                               KP_SPRINTF (interp,
                                           "read: invalid symbol name: %Q",
                                           name)));

      auto u2 = (const char *)memchr (uptr + 2, ':', (sname + len - 2) - uptr);
      if (!u2)
        {
          KP_VTRY (update_pkg_expr (interp, sname, uptr + 2,
                                    sname + len, *ret));
          break;
        }
      else if (u2[1] != *u2)
        return (interp->raise ("parse-error",
                               KP_SPRINTF (interp,
                                           "read: invalid symbol name: %Q",
                                           name)));

      KP_VTRY (update_pkg_expr (interp, sname, uptr + 2, u2, *ret));
      len -= (u2 + 2) - sname;
      sname = u2 + 2;
    }

  kp_return (*ret);
}

result<void> reader::handle_sym (object pkg, object name)
{
  valref xpkg (interp, pkg), tmp (interp, UNBOUND);
  const char *sname = str_cdata (name);
  int len = as_str(name)->nbytes;
  auto ip = this->interp;

  while (true)
    {
      auto uptr = (const char *)memchr (sname, ':', len);
      if (!uptr)
        {
          KP_VTRY (intern (this->interp, sname, len, as_package (*xpkg)));
          return (0);
        }
      else if (uptr[1] != *uptr ||
          !check_symname (interp, sname, uptr - sname))
        return (ip->raise ("parse-error",
                           KP_SPRINTF (ip, "read: invalid symbol name: %Q",
                                       name)));

      *tmp = find_sym (interp, *xpkg, sname, uptr - sname);
      *tmp = !symbol_p (*tmp) ? UNBOUND : symval (*tmp);

      if (package_p (*tmp))
        // Still reachable at read-time - Update the current package.
        *xpkg = *tmp;
      else
        {
          KP_VTRY (make_pkg_expr (interp, name, *xpkg));
          return (0);
        }

      len -= (uptr + 2) - sname;
      sname = uptr + 2;
    }
}

result<uint32_t> reader::peek ()
{
  schar ch;
  bool rv;

  if (this->toktype != TOK_NONE)
    return (this->toktype);

  rv = KP_TRY (this->nextc (ch));
  if (!rv)
    return (TOK_NONE);

  switch (ch.uc)
    {
#define DISPATCH(ch, tok)   \
  case ch:   \
    this->toktype = TOK_##tok;   \
    break

      DISPATCH ('(', OPEN);
      DISPATCH (')', CLOSE);
      DISPATCH ('[', OPENB);
      DISPATCH (']', CLOSEB);
      DISPATCH ('{', OPENBRACE);
      DISPATCH ('}', CLOSEBRACE);
      DISPATCH ('\'', QUOTE);
      DISPATCH ('`', BQ);
      DISPATCH (',', COMMA);
      DISPATCH ('"', DQUOTE);
      DISPATCH ('\\', CHAR);
          
      case '#':
        {
          rv = KP_TRY (this->src->sgetc (this->interp, ch));
          if (!rv)
            return (this->interp->raise ("parse-error",
                                         "read: invalid read macro"));
          else if (ch.uc == '.')
            this->toktype = TOK_SHARPDOT;
          else if (ch.uc == '\'')
            this->toktype = TOK_SHARPQUOTE;
          else if (ch.uc == '(')
            this->toktype = TOK_SHARPOPEN;
          else if (ch.uc == '<')
            return (this->interp->raise ("parse-error",
                                         "read: unreadable object"));
          else if (ch.uc == ':')
            {
              rv = KP_TRY (this->src->sgetc (this->interp, ch));
              if (!rv)
                return (raise_eos (this->interp));

              KP_VTRY (this->read_token (ch, 0));
              bool rv = KP_TRY (numtok_p (this->interp, this->bufp,
                                          this->bufcnt));

              if (rv)
                return (this->interp->raise ("parse-error",
                                             "read: invalid syntax after #: "
                                             "reader macro"));

              this->toktype = TOK_SYM;

              valref tmp = KP_TRY (alloc_sym (interp));
              symname(*tmp) = KP_TRY (string::make (this->interp, this->bufp,
                                                    this->bufcnt));
            }
          else if (isdigit (ch.uc))
            {
              KP_VTRY (this->read_token (ch, 1),
                       this->src->sgetc (this->interp, ch));

              if (ch.uc == '#')
                this->toktype = TOK_BACKREF;
              else if (ch.uc == '=')
                this->toktype = TOK_LABEL;
              else
                return (this->interp->raise ("parse-error",
                                             "read: invalid label"));

              errno = 0;
              char *endp;
              long xv = strtol (bufp, &endp, 10);
              if (*endp != '\0' || errno != 0)
                return (this->interp->raise ("parse-error",
                                             "read: invalid label"));

              this->interp->retval = fixint (xv);
            }
          else if (ch.uc == '!')
            {
              do
                KP_VTRY (this->src->sgetc (this->interp, ch));
              while (ch.uc != UEOF && ch.uc != '\n');

              return (this->peek ());
            }
          else if (ch.uc == '"')
            this->toktype = TOK_SHARPDQUOT;
          else if (ch.uc == '|')
            {
              for (int lvl = 1 ; ; )
                {
                  KP_VTRY (this->src->sgetc (this->interp, ch));
                got_hashp:
                  if (ch.uc == UEOF)
                    return (raise_eos (this->interp));
                  else if (ch.uc == '|')
                    {
                      KP_VTRY (this->src->sgetc (this->interp, ch));
                      if (ch.uc == '#')
                        {
                          if (--lvl == 0)
                            break;

                          continue;
                        }

                      goto got_hashp;
                    }
                  else if (ch.uc == '#')
                    {
                      KP_VTRY (this->src->sgetc (this->interp, ch));
                      if (ch.uc == '|')
                        ++lvl;
                      else
                        goto got_hashp;
                    }
                }

              return (this->peek ());
            }
          else if (ch.uc == '\\')
            { // #\x => (intern ',(symname x))
              object sym = KP_TRY (this->read_sexpr (UNBOUND));
              if (!symbol_p (sym))
                return (this->interp->raise ("type-error",
                                             "expected a symbol after "
                                             "read macro #\\"));

              valref tmp (interp, sym);
              KP_VTRY (alloc_cons (this->interp, 2));
              xcar(this->interp->alval) = symbol::quote;
              xcadr(this->interp->alval) = symname (*tmp);

              *tmp = this->interp->alval;
              KP_VTRY (alloc_cons (this->interp, 2));
              xcar(this->interp->alval) = KP_TRY (intern (this->interp,
                                                          "intern", 6));
              xcadr(this->interp->alval) = *tmp;
              this->interp->retval = this->interp->alval;
              this->toktype = TOK_SYM;
            }
          else
            return (this->interp->raise ("parse-error",
                                         "read: unknown read macro"));

          break;
        }

      default:
        // Number or symbol.
        rv = KP_TRY (this->read_token (ch, 0));
        if (!rv)
          {
            if (*this->bufp == '.' && this->bufp[1] == '\0')
              return (this->toktype = TOK_DOT);

            bool rv = KP_TRY (numtok_p (this->interp, this->bufp,
                                        this->bufcnt));
            if (rv)
              return (this->toktype = TOK_NUM);
          }

        this->toktype = TOK_SYM;
        if (*this->bufp == ':')
          {
            if (this->bufcnt > 1 && this->bufp[1] == ':')
              {
                local_varobj<string> nm;
                nm.local_init (this->bufp + 2);
                KP_VTRY (this->handle_sym (root_package, nm.as_obj ()));
              }
            else
              KP_VTRY (symbol::make_kword (this->interp, this->bufp + 1));
          }
        else
          {
            local_varobj<string> nm;
            nm.local_init (this->bufp);
            KP_VTRY (this->handle_sym (this->ipkg->as_obj (), nm.as_obj ()));
          }

        break;
    }

#undef DISPATCH
  return (this->toktype);
}

result<object> reader::read_array (object lbl)
{
  object dummy, *dstp = lbl != UNBOUND ? this->putlbl (lbl) : &dummy;
  raw_acc<array> ar (3);

  *dstp = ar.as_obj ();
  while (true)
    {
      uint32_t rv = KP_TRY (this->peek ());
      if (rv == TOK_CLOSEB)
        break;
      else if (!this->readable_p ())
        return (raise_eos (this->interp));

      object obj = KP_TRY (this->read_sexpr (UNBOUND));
      ar.add_obj (obj);
    }

  this->take ();
  this->interp->retval = ar.as_obj ();

  array *ap = ar.release ();
  if (ap->len > 0)
    gc_register (this->interp, ap, sizeof (*ap) + ar.alloc);
  else
    {
      xfree (ap);
      this->interp->retval = deref (alloc_array (this->interp, 0));
    }

  return (this->interp->retval);
}

result<object> reader::read_table (object)
{
  sp_guard sg (this->interp);
  // Push equality and hash functions.
  KP_VTRY (this->interp->push (NIL),
           this->interp->push (NIL));

  while (true)
    {
      uint32_t rv = KP_TRY (this->peek ());
      if (rv == TOK_CLOSEBRACE)
        break;
      else if (!this->readable_p ())
        return (raise_eos (this->interp));

      object obj = KP_TRY (this->read_sexpr (UNBOUND));
      KP_VTRY (this->interp->push (obj));
    }

  this->take ();
  return (table_fct (this->interp, this->interp->stack + sg.sp,
                     this->interp->stklen () - sg.sp));
}

result<object> reader::read_tuple (object lbl)
{
  object dummy, *dstp = lbl != UNBOUND ? this->putlbl (lbl) : &dummy;
  valref key (interp, NIL), ret = KP_TRY (alloc_tuple (this->interp, NIL));

  *dstp = *ret;
  while (true)
    {
      uint32_t rv = KP_TRY (this->peek ());
      if (rv == TOK_CLOSE)
        break;
      else if (!this->readable_p ())
        return (raise_eos (this->interp));

      *key = KP_TRY (this->read_sexpr (UNBOUND));
      KP_VTRY (tuple_put (interp, *ret, *key, false));
    }

  this->take ();
  kp_return (*ret);
}

static inline int
escape_char (int ch)
{
  if (ch == 'n')
    return ('\n');
  else if (ch == 't')
    return ('\t');
  else if (ch == 'r')
    return ('\r');
  else if (ch == 'a')
    return ('\a');
  else if (ch == 'b')
    return ('\b');
  else if (ch == '\\' || ch == '"')
    return (ch);
  else if (ch == '0')
    return (0);
  else
    return (-1);
}

static inline exception
raise_eilseq (interpreter *interp, const char *seq)
{
  char buf[100];
  sprintf (buf, "read: invalid escape sequence: %s", seq);
  return (interp->raise ("parse-error", buf));
}

result<object> reader::read_bvector ()
{
  raw_acc<bvector> bv (8);
  char ebuf[8];

  for (ebuf[0] = '\\' ; ; )
    {
      int byte = KP_TRY (this->src->getb (this->interp));

      if (byte < 0)
        return (raise_eos (this->interp));
      else if (byte == '"')
        break;
      else if (byte == '\\')
        {
          int b1 = 0, b2 = 0;
          byte = KP_TRY (this->src->getb (this->interp));

          if (byte < 0)
            return (raise_eos (this->interp));
          else if (byte == 'x')
            {
              b1 = KP_TRY (this->src->getb (this->interp));
              b2 = KP_TRY (this->src->getb (this->interp));

              if ((b1 | b2) < 0)
                return (raise_eos (this->interp));
              else if (!isxdigit (b1) || !isxdigit (b2))
                {
                  ebuf[1] = 'x', ebuf[2] = b1;
                  ebuf[3] = b2, ebuf[4] = 0;
                  return (raise_eilseq (this->interp, ebuf));
                }

              byte = (b1 - '0') * 16 + (b2 - '0');
            }
          else if ((byte = escape_char (byte)) < 0)
            {
              ebuf[1] = byte, ebuf[2] = 0;
              return (raise_eilseq (this->interp, ebuf));
            }
        }

#ifdef KP_LITTLE_ENDIAN
      bv.add_data (&byte, 1);
#else
      unsigned char ub = (unsigned char)byte;
      bv.add_data (&ub, 1);
#endif
    }

  bvector *ret = bv.release ();

  if (ret->nbytes > 0)
    {
      this->interp->retval = ret->as_obj ();
      ret->data[ret->nbytes] = 0;
      gc_register (this->interp, ret, sizeof (*ret) + bv.alloc);
    }
  else
    {
      xfree (ret);
      this->interp->retval = deref (alloc_bvector (this->interp, 0));
    }

  return (this->interp->retval);
}

result<object> reader::read_str ()
{
  raw_acc<string> str (8);
  char buf[16];

  as_str(str.as_obj ())->hval = 0;
  as_str(str.as_obj ())->len = 0;

  for (buf[0] = '\\' ; ; )
    {
      schar ch;
      bool rv = KP_TRY (this->src->sgetc (this->interp, ch));

      if (!rv)
        return (raise_eos (this->interp));
      else if (ch.uc == '"')
        break;
      else if (ch.uc == '\\')
        {
          int n;
          rv = KP_TRY (this->src->sgetc (this->interp, ch));

          if (!rv)
            return (raise_eos (this->interp));
          else if ((ch.uc == 'x' && (n = 2)) ||
                   (ch.uc == 'u' && (n = 4)) ||
                   (ch.uc == 'U' && (n = 8)))
            {
              buf[1] = ch.uc;

              for (int i = 0; i < n; ++i)
                {
                  rv = KP_TRY (this->src->sgetc (this->interp, ch));
                  if (!rv)
                    return (raise_eos (this->interp));

                  buf[2 + i] = *ch.buf;
                  if (!isxdigit (*ch.buf))
                    {
                      buf[3 + i] = 0;
                      return (raise_eilseq (this->interp, buf));
                    }
                }

              buf[2 + n] = 0;
              ch.uc = strtol (&buf[2], nullptr, 16);
              if (ch.uc > MAX_CHAR)
                return (raise_eilseq (this->interp, buf));

              ch.len = u32tou8 ((unsigned char *)ch.buf, ch.uc);
            }
          else
            {
              if ((n = escape_char (ch.uc)) < 0)
                {
                  buf[1] = 'X', buf[2 + ch.len] = 0;
                  memcpy (&buf[2], ch.buf, ch.len);
                  return (raise_eilseq (this->interp, buf));
                }

              *ch.buf = n, ch.len = 1;
            }
        }

      str.add_data (ch.buf, ch.len);
      ++as_str(str.as_obj ())->len;
    }

  string *sp = str.release ();

  if (sp->len > 0)
    {
      sp->vo_full |= FLAGS_CONST;
      this->interp->retval = sp->as_obj ();
      sp->data[sp->nbytes] = '\0';
      gc_register (this->interp, sp, sizeof (*sp) + str.alloc);
    }
  else
    {
      xfree (sp);
      this->interp->retval = deref (alloc_str (this->interp, 0));
    }

  return (this->interp->retval);
}

result<object> reader::read_char ()
{
  schar cv;
  auto ip = this->interp;

  for (bool got = false ; ; got = true)
    {
      schar tmp;
      bool rv = KP_TRY (this->src->sgetc (this->interp, tmp));

      if (!rv)
        return (raise_eos (this->interp));
      else if (tmp.uc <= 0x7f && !symchar_p (tmp.uc) && got)
        {
          this->src->ungetuc (tmp.buf, tmp.len);
          this->bufp[this->bufcnt] = '\0';
          break;
        }
      else if (!isspace (tmp.uc) && (symchar_p (tmp.uc) || !got))
        {
          if (!got)
            cv = tmp;
          this->push_ch (tmp);
        }
      else if (!got)
        return (ip->raise ("parse-error", "read: empty character designator"));
      else
        {
          this->bufp[this->bufcnt] = '\0';
          break;
        }
    }

  local_varobj<string> sn;

  if (this->bufp[1] == '\0')
    ;
  else if (cv.uc == 'u' || cv.uc == 'U' || cv.uc == 'x')
    {
      long rv = strtol (this->bufp + 1, 0, 16);
      if (errno != 0 || rv >= (long)MAX_CHAR)
        return (ip->raise ("parse-error", "read: invalid unicode constant"));

      cv.uc = (uint32_t)rv;
    }
  else if (cv.uc >= 'a' && cv.uc <= 'z')
    {
      cv.uc = ~0u;
      for (size_t i = 0; i < KP_NELEM (CHAR_NAMES); ++i)
        if (strcmp (this->bufp, CHAR_NAMES[i].name) == 0)
          {
            cv.uc = CHAR_NAMES[i].value;
            break;
          }

      if (cv.uc == ~0u)
        {
          sn.local_init (this->bufp);
          return (ip->raise ("parse-error",
                             KP_SPRINTF (ip, "read: unknown character: \\%Q",
                                         sn.as_obj ())));
        }
    }
  else
    {
      sn.local_init (this->bufp);
      return (ip->raise ("parse-error",
                         KP_SPRINTF (ip, "read: unknown character: \\%Q",
                                     sn.as_obj ())));
    }

  this->take ();
  kp_return (charobj (cv.uc));
}

result<object> reader::read_list (object lbl)
{
  object dummy, *dstp = lbl != UNBOUND ? this->putlbl (lbl) : &dummy;
  valref lr (this->interp, NIL), elem (this->interp);
  bool dot = false;
  uint32_t tok = KP_TRY (this->peek ());

  if (tok == TOK_CLOSE)
    {
      this->take ();
      kp_return (*dstp = NIL);
    }
  else if (tok == TOK_SHARPQUOTE)
    {
      KP_VTRY (intern (this->interp, "apply", 5));
      *lr = KP_TRY (cons::make (this->interp, this->interp->retval, *lr));
      this->take ();
    }

  tok = KP_TRY (this->peek ());
  while (tok != TOK_CLOSE)
    {
      *elem = KP_TRY (this->read_sexpr (UNBOUND));
      *lr = KP_TRY (cons::make (this->interp, *elem, *lr));

      tok = KP_TRY (this->peek ());
      if (tok == TOK_DOT)
        {
          this->take ();
          *elem = KP_TRY (this->read_sexpr (UNBOUND));
          tok = KP_TRY (this->peek ());
          if (tok != TOK_CLOSE)
            return (this->interp->raise ("parse-error",
                                         "read: elements follow dot in list"));

          dot = true;
          break;
        }
      else if (!this->readable_p ())
        return (raise_eos (this->interp));
    }

  this->take ();
  if (dot)
    { *lr = KP_TRY (nrevconc (this->interp, *lr, *elem)); }
  else
    { *lr = KP_TRY (nreverse_L (this->interp, *lr)); }

  kp_return (*dstp = *lr);
}

// Backquote implementation.

static bool
bq_member (object elem, object lst)
{
  for (; cons_p (lst); lst = xcdr (lst))
    if (xcar (lst) == elem)
      return (true);

  return (false);
}

static inline exception
bq_nonlist_splice_err (interpreter *interp, bool dot)
{
  char errmsg[] = "read: the syntax `,@form is invalid";
  if (dot)
    errmsg[19] = '.';

  return (interp->raise ("parse-error", errmsg));
}

result<object> reader::read_comma (object lbl)
{
  if (this->bq_level <= 0)
    return (this->interp->raise ("parse-error",
                                 "read: more commas than backquotes"));

  this->unquoted = true;
  --this->bq_level;

  schar next;
  object head = symbol::comma;
  bool rv = KP_TRY (this->src->sgetc (this->interp, next));

  if (!rv)
    return (raise_eos (this->interp));
  else if (*next.buf == '@')
    head = symbol::comma_at;
  else if (*next.buf == '.')
    head = symbol::comma_dot;
  else
    this->src->ungetuc (next.buf, next.len);

  object obj = KP_TRY (this->read_sexpr (UNBOUND));
  KP_VTRY (alloc_cons (this->interp, 2));
  xcar(this->interp->alval) = head;
  xcadr(this->interp->alval) = obj;

  if (lbl != UNBOUND)
    *this->putlbl(lbl) = this->interp->alval;

  ++this->bq_level;
  kp_return (this->interp->alval);
}

result<object> reader::read_bq (object lbl)
{
  bool prev = this->unquoted;
  this->unquoted = false;
  ++this->bq_level;

  object obj = KP_TRY (this->read_sexpr (UNBOUND));
  if (cons_p (obj))
    {
      object head = xcar (obj), tst = symbol::comma_at;

      if (head == symbol::comma_at || head == symbol::comma_dot)
        return (bq_nonlist_splice_err (interp, head == symbol::comma_dot));
      else if (bq_member (tst, obj) ||
          bq_member (tst = symbol::comma_dot, obj))
        {
          char errmsg[] = "read: the syntax `( ... . ,@form) is invalid";
          if (tst == symbol::comma_dot)
            errmsg[27] = '.';

          return (this->interp->raise ("parse-error", errmsg));
        }
    }
  else if (this->unquoted &&
      !(array_p (obj) || table_p (obj) || tuple_p (obj)))
    return (this->interp->raise ("parse-error",
                                 "read: unquote outside sequence"));

  KP_VTRY (alloc_cons (this->interp, 2));
  xcar(this->interp->alval) = symbol::backquote;
  xcadr(this->interp->alval) = obj;

  if (lbl != UNBOUND)
    *this->putlbl(lbl) = this->interp->alval;

  this->unquoted = prev;
  --this->bq_level;
  kp_return (this->interp->alval);
}

static const object BQ_NCONCABLE = fixint (0) | EXTRA_BIT;

static result<object>
bq_list (interpreter *interp, object form1)
{
  return (KP_CALL (interp, list_fct, intern (interp, "list", 4), form1));
}

static result<object>
bq_transform (interpreter *interp, object form)
{
  if (!cons_p (form))
    {
      valref tmp = KP_TRY (expand_bq (interp, form));
      return (bq_list (interp, *tmp));
    }
    
  valref tmp (interp, xcar (form));
  if (*tmp == symbol::comma)
    {
      KP_VTRY (bq_list (interp, *tmp = xcadr (form)));
      return (interp->retval);
    }
  else if (*tmp == symbol::comma_at)
    kp_return (xcadr (form));
  else if (*tmp == symbol::comma_dot)
    {
      KP_VTRY (KP_CALL (interp, list_fct, BQ_NCONCABLE, xcadr (form)));
      return (interp->retval);
    }
  else if (*tmp == symbol::backquote)
    {
      *tmp = KP_TRY (KP_CALL (interp, list_fct, symbol::backquote,
                              expand_bq (interp, xcadr (form))));
      KP_VTRY (bq_list (interp, *tmp));
      return (interp->retval);
    }
  else
    {
      *tmp = KP_TRY (expand_bq (interp, form));
      KP_VTRY (bq_list (interp, *tmp));
      return (interp->retval);
    }
}

static result<object>
bq_expand_list (interpreter *interp, object forms)
{
  valref ret (interp, NIL), tmp (interp, forms), tail (interp);

  while (*tmp != NIL)
    {
      KP_VTRY (bq_transform (interp, xcar (*tmp)));
      *ret = KP_TRY (cons::make (interp, interp->retval, *ret));
      *tail = xcdr (*tmp);

      if (*tail == NIL)
        break;
      else if (!xcons_p (*tail))
        {
          object tx = KP_TRY (KP_CALL (interp, list_fct,
                                       symbol::backquote, *tail));
          *ret = KP_TRY (cons::make (interp, tx, *ret));
          break;
        }
      else if (xcar (*tail) == symbol::comma)
        {
          *ret = KP_TRY (cons::make (interp, xcadr (*tail), *ret));
          break;
        }
      else if (xcar (*tail) == symbol::comma_at ||
               xcar (*tail) == symbol::comma_dot)
        return (bq_nonlist_splice_err (interp,
                                       xcar (*tail) == symbol::comma_dot));
      else
        *tmp = *tail;
    }

  kp_return (*ret);
}
  
static inline bool
bq_splicing_p (interpreter *interp, object form)
{
  valref tmp (interp, form);

  while (true)
    {
      if (!xcons_p (*tmp))
        return (false);
      else if (xcar (*tmp) == symbol::comma)
        *tmp = xcadr (*tmp);
      else
        break;
    }
    
  *tmp = xcar (*tmp);
  return (*tmp == symbol::comma_at || *tmp == symbol::comma_dot);
}

static inline result<object>
bq_non_splicing (interpreter *interp, object form)
{
  if (!bq_splicing_p (interp, form))
    kp_return (form);

  return (KP_CALL (interp, list_fct, intern (interp, "concat", 6), form));
}

static inline bool
bq_cons_test (interpreter *interp, object form)
{
  return (xcons_p (form) && xcar (form) == symbol::quote &&
          xcons_p (xcdr (form)) && xcddr (form) == NIL &&
          !bq_splicing_p (interp, xcadr (form)));
}

static result<object>
bq_cons (interpreter *interp, object f1, object f2)
{
  valref op = KP_TRY (intern (interp,
                              bq_splicing_p (interp, f1) ? "list*" : "cons"));
  valref t2 (interp, f2), t1 (interp, f1);
  
  if (atom_p (*t2))
    return (KP_CALL (interp, list_fct, *op, *t1, *t2));

  object tmp = KP_TRY (intern (interp, "list", 4));
  if (xcar (*t2) == tmp)
    return (KP_CALL (interp, list_star, xcar (*t2), *t1, xcdr (*t2)));
  else if (bq_cons_test (interp, *t2) && bq_cons_test (interp, *t1))
    return (KP_CALL (interp, list_fct, symbol::quote,
                     cons::make (interp, xcadr (*t1), xcadr (*t2))));
  else
    return (KP_CALL (interp, list_fct, *op, *t1, *t2));
}

static result<object>
bq_append (interpreter *interp, object f1, object f2)
{
  valref t1 (interp, f1), t2 (interp, f2), aux (interp, NIL);
  
  if (*t1 == NIL)
    kp_return (*t2);
  else if (*t2 == NIL)
    kp_return (*t1);

  object tmp = KP_TRY (intern (interp, "list", 4));
  if (xcons_p (*t1) && xcar (*t1) == tmp)
    {
      tmp = KP_TRY (last_L (interp, *t1));
      if (xcdr (tmp) == NIL)
        {
          *t2 = KP_TRY (bq_non_splicing (interp, *t2));
          if (xcdr (*t1) == NIL)
            kp_return (*t2);
          else if (xcddr (*t1) == NIL)
            {
              *t2 = KP_TRY (bq_cons (interp, *t1 = xcadr (*t1), *t2));
              kp_return (*t2);
            }
          else
            {
              *t1 = xcdr (*t1), *t2 = KP_TRY (cons::make (interp, *t2, NIL));
              *t1 = KP_TRY (add_LL (interp, *t1, *t2));
              *t2 = KP_TRY (intern (interp, "list*", 5));
              return (cons::make (interp, *t2, *t1));
            }
        }
    }

  if (bq_cons_test (interp, *t1) && xcons_p (*aux = xcadr (*t1)))
    {
      tmp = KP_TRY (last_L (interp, *aux));
      if (xcdr (tmp) == NIL && xcar (*aux) != symbol::comma)
        {
          *t2 = KP_TRY (bq_non_splicing (interp, *t2));
          valref lst = KP_TRY (reverse_L (interp, *aux));

          for (*aux = *t2; *lst != NIL; *lst = xcdr (*lst))
            {
              *t1 = KP_TRY (KP_CALL (interp, list_fct,
                                     symbol::quote, xcar (*lst)));
              *aux = KP_TRY (bq_cons (interp, *t1, *aux));
            }

          kp_return (*aux);
        }
    }

  *aux = KP_TRY (intern (interp, "concat", 6));
  if (xcons_p (*t2) && xcar (*t2) == *aux)
    return (KP_CALL (interp, list_star, *aux, *t1, xcdr (*t2)));
  else
    return (KP_CALL (interp, list_fct, intern (interp, "concat", 6), *t1, *t2));
}

static result<object>
bq_nconc (interpreter *interp, object f1, object f2)
{
  valref t2 (interp, f2);
  
  if (f1 == NIL)
    kp_return (f2);
  else if (f2 == NIL)
    kp_return (f1);
    
  valref lst = KP_TRY (intern (interp, "nconcat", 7));
  auto fn = list_fct;
  
  if (xcons_p (*t2) && xcar (*t2) == *lst)
    *t2 = xcdr (*t2), fn = list_star;

  return (KP_CALL (interp, fn, *lst, f1, *t2));
}

static result<object>
bq_append_multi (interpreter *interp, object forms)
{
  if (forms == NIL)
    kp_return (forms);
    
  bool nc = false;
  valref tf (interp, forms), res (interp, NIL),
         f1 (interp, xcar (*tf)), tmp (interp, NIL);
           
  if (xcons_p (*f1) && xcar (*f1) == BQ_NCONCABLE)
    *res = xcadr (*tf), nc = true;
  else
    *res = *f1;
    
  for (*tf = xcdr (*tf); *tf != NIL; )
    {
      *f1 = xcar (*tf);
      if (xcons_p (*f1) && xcar (*f1) == BQ_NCONCABLE)
        {
          *f1 = xcadr (*f1);
          if (!nc && bq_splicing_p (interp, *res))
            { *tmp = KP_TRY (KP_CALL (interp, list_fct,
                                      intern (interp, "concat", 6), *res)); }
          else
            *tmp = *res;
            
          *res = KP_TRY (bq_nconc (interp, *f1, *tmp));
        }
      else
        {
          if (nc && bq_splicing_p (interp, *res))
            { *tmp = KP_TRY (KP_CALL (interp, list_fct,
                                      intern (interp, "nconcat", 7), *res)); }
          else
            *tmp = *res;
            
          *res = KP_TRY (bq_append (interp, *f1, *tmp));
        }
        
      nc = false;
      *tf = xcdr (*tf);
    }

  return (bq_non_splicing (interp, *res));
}

static result<object>
seq_to_cons (interpreter *interp, object seq)
{
  if (array_p (seq))
    {
      const array *ap = as_array (seq);
      if (ap->len == 0)
        kp_return (NIL);

      KP_VTRY (alloc_cons (interp, ap->len, ap->data, nullptr));
      kp_return (interp->alval);
    }
  else if (table_p (seq))
    {
      valref tmp (interp, NIL);
      for (table::iterator it (interp, seq); it.valid (); ++it)
        { *tmp = KP_TRY (KP_CALL (interp, list_star, it.val (),
                                  it.key (), *tmp)); }

      return (nreverse_L (interp, *tmp));
    }
  else if (tuple_p (seq))
    {
      valref tmp (interp, NIL);
      for (tuple::iterator it (interp, seq); it.valid (); ++it)
        { *tmp = KP_TRY (cons::make (interp, *it, *tmp)); }

      return (nreverse_L (interp, *tmp));
    }

  kp_return (UNBOUND);
}

result<object> expand_bq (interpreter *interp, object form)
{
  if (form == NIL)
    kp_return (NIL);
  else if (xcons_p (form))
    {
      object tmp = xcar (form);
      if (tmp == symbol::comma)
        kp_return (xcadr (form));
      else if (tmp == symbol::comma_at || tmp == symbol::comma_dot)
        return (bq_nonlist_splice_err (interp, tmp == symbol::comma_dot));
      else if (tmp == symbol::backquote)
        return (KP_CALL (interp, list_fct, symbol::backquote,
                         expand_bq (interp, xcadr (form))));
      else
        {
          valref exp = KP_TRY (bq_expand_list (interp, form));
          return (bq_append_multi (interp, *exp));
        }
    }
  else
    {
      valref tmp = KP_TRY (seq_to_cons (interp, form));

      if (*tmp == UNBOUND)
        {
          if (!nksymbol_p (form) && !cons_p (form))
            kp_return (form);

          return (KP_CALL (interp, list_fct, symbol::quote, form));
        }

      *tmp = KP_TRY (expand_bq (interp, *tmp));
      valref app = KP_TRY (intern (interp, "apply", 5));

      if (array_p (form))
        return (KP_CALL (interp, list_fct, *app,
                         intern (interp, "array", 5), *tmp));
      else if (table_p (form))
        return (KP_CALL (interp, list_fct, *app,
                         intern (interp, "table", 5), NIL, NIL, *tmp));
      else
        return (KP_CALL (interp, list_fct, *app,
                         intern (interp, "tuple", 5), NIL, *tmp));
    }
}

result<object> reader::read_sexpr (object lbl)
{
  uint32_t tok = KP_TRY (this->peek ());
  auto ip = this->interp;
  object obj;

  this->take ();

  switch (tok)
    {
      case TOK_NONE:
        kp_return (EOS);
      case TOK_CLOSE:
        return (ip->raise ("parse-error", "read: unexpected ')'"));
      case TOK_CLOSEB:
        return (ip->raise ("parse-error", "read: unexpected ']'"));
      case TOK_CLOSEBRACE:
        return (ip->raise ("parse-error", "read: unexpected '}'"));
      case TOK_DOT:
        return (ip->raise ("parse-error", "read: unexpected '.'"));

      case TOK_SYM:
      case TOK_NUM:
        return (ip->retval);

      case TOK_QUOTE:
        obj = KP_TRY (this->read_sexpr (UNBOUND));
        KP_VTRY (alloc_cons (ip, 2));

        xcar(ip->alval) = symbol::quote;
        xcadr(ip->alval) = obj;

        if (lbl != UNBOUND)
          *this->putlbl(lbl) = ip->alval;

        kp_return (ip->alval);

      case TOK_BQ:
        return (this->read_bq (lbl));

      case TOK_COMMA:
        return (this->read_comma (lbl));

      case TOK_OPEN:
        return (this->read_list (lbl));

      case TOK_DQUOTE:
        return (this->read_str ());

      case TOK_OPENB:
        return (this->read_array (lbl));

      case TOK_OPENBRACE:
        return (this->read_table (lbl));

      case TOK_SHARPOPEN:
        return (this->read_tuple (lbl));

      case TOK_SHARPDQUOT:
        return (this->read_bvector ());

      case TOK_CHAR:
        return (this->read_char ());

      case TOK_SHARPQUOTE:
        {
          obj = KP_TRY (this->read_sexpr (UNBOUND));
          if (!nksymbol_p (obj) && !cons_p (obj))
            return (ip->raise ("parse-error",
                               "read: #' must be used with a symbol or list"));

          valref whole = KP_TRY (alloc_cons (ip, 3));
          xcar(*whole) = KP_TRY (intern (ip, "fct", 3));

          // Set arglist.
          xcadr(*whole) = KP_TRY (alloc_cons (ip));
          xcar(xcadr (*whole)) = KP_TRY (gensym (ip, 0, 0));

          // Set body.
          object body = xcar(xcddr (*whole)) = KP_TRY (alloc_cons (ip, 3));
          xcar(body) = KP_TRY (intern (ip, "apply", 5));
          xcadr(body) = obj;
          xcar(xcddr (body)) = xcar (xcadr (*whole));

          kp_return (*whole);
        }

      case TOK_SHARPDOT:
        {
          object obj = KP_TRY (this->read_sexpr (UNBOUND));
          return (eval (ip, obj));
        }

      case TOK_LABEL:
        if (this->getlbl (ip->retval) != UNBOUND)
          return (ip->raise ("parse-error",
                             KP_SPRINTF (ip, "read: label %Q redefined",
                                         ip->retval)));

        obj = ip->retval;
        KP_TRY (this->read_sexpr (UNBOUND));
        *this->putlbl(obj) = KP_TRY (this->read_sexpr (UNBOUND));
        return (ip->retval);

      case TOK_BACKREF:
        obj = ip->retval;
        if ((ip->retval = this->getlbl (obj)) == UNBOUND)
          return (ip->raise ("parse-error",
                             KP_SPRINTF (ip, "read: undefined label %Q", obj)));

        return (ip->retval);
    }

  return (ip->retval);
}

result<object> reader::read_sexpr ()
{
  auto ret = this->read_sexpr (UNBOUND);
  if (ret.error_p ())
    {
      this->src->discard ();
      this->take ();
    }

  return (ret);
}

reader::~reader ()
{
  if (this->pairs.data != this->stpairs)
    xfree (this->pairs.data);
  if (this->bufp != this->stbuf)
    xfree (this->bufp);
}

// String interpolation.

static result<int64_t>
read_fail (interpreter *, stream&, void *, uint64_t)
{
  return (0);
}

static result<object>
read_from_cstr (interpreter *interp, const void *s, int len, const char **endp)
{
  stream instrm;
  bvector bv;

  bv.vo_type = typecode::BVECTOR;
  bv.nbytes = len;

  instrm.rdbuf.init ((char *)s, len);
  instrm.cookie = 0, instrm.ilock = UNBOUND;
  instrm.bvec = bv.as_obj ();

  instrm.pos = fixint (0);
  instrm.vo_full = 0;
  instrm.vo_type = typecode::STREAM;

  stream::xops ops;
  ops.read = read_fail;
  instrm.ops = &ops;
  instrm.io_flags = STRM_UTF8 | STRM_READ | STRM_NOLOCK;

  reader rd (interp, instrm.as_obj ());
  object ret = KP_TRY (rd.read_sexpr (UNBOUND));

  if (ret != EOS)
    {
      if (instrm.rdbuf.left () == 0)
        *endp = nullptr;
      else if (isspace (*instrm.rdbuf.curr))
        {
          schar ch;
          KP_VTRY (rd.nextc (ch));
          instrm.ungetuc (ch.buf, ch.len);
          *endp = instrm.rdbuf.curr;
        }
      else
        *endp = instrm.rdbuf.curr;
    }

  return (ret);
}

static inline const char*
xmemchr (const void *p, int ch, size_t len)
{
  return ((const char *)memchr (p, ch, len));
}

static int
sanitize_fmt (const char *p1, const char *p2)
{
  chmask mask ("0123456789.$'");

  for (; p1 != p2; ++p1)
    if (!mask.tst (*p1))
      return (*p1);

  return (-1);
}

result<object> expand_str (interpreter *interp, object str)
{
  string *sp = as_str (str);
  auto start = (const char *)sp->data;
  int nb = sp->nbytes;
  auto ptr = xmemchr (start, '$', nb);

  if (!ptr)
    kp_return (str);

  stream *ns = KP_TRY (strstream (interp, deref (alloc_str (interp, 0)),
                                  STRM_WRITE | STRM_NOLOCK));

  KP_VTRY (ns->write (interp, start, ptr - start));
  valref outs (interp, ns->as_obj ()), args (interp, NIL), elem (interp);

  while (true)
    {
      if (ptr[1] == '$')
        {
          KP_VTRY (ns->putb (interp, '$'));
          const char *tp = xmemchr (ptr += 2, '$', nb -= 2);
          if (!tp)
            {
              KP_VTRY (ns->write (interp, ptr, sp->nbytes - (ptr - start)));
              break;
            }

          KP_VTRY (ns->write (interp, ptr, tp - ptr));
          nb -= tp - ptr, ptr = tp;
          continue;
        }

      const char *p1 = xmemchr (ptr + 1, '{', nb - (ptr + 1 - start));

      if (!p1)
        return (interp->raise ("arg-error", "invalid format string "
                               "(expected '{' after '$')"));

      nb = sp->nbytes - (int)(p1 - start);

      const char *p2 = nullptr;
      *elem = KP_TRY (read_from_cstr (interp, p1 + 1, nb - 1, &p2));

      if (!p2 || *p2 != '}')
        return (interp->raise ("arg-error", "invalid format string "
                               "(unbalanced '{}' specifiers)"));
      else if (*elem == EOS)
        return (interp->raise ("arg-error", "invalid format string "
                               "(incomplete argument inside '${}')"));

      *args = KP_TRY (cons::make (interp, *elem, *args));

      {
        int ch = sanitize_fmt (ptr + 1, p1);
        if (ch >= 0)
          {
            char buf[100];
            sprintf (buf, "invalid format specifier: got %c", (char)ch);
            return (interp->raise ("arg-error", buf));
          }
      }

      KP_VTRY (ns->write (interp, ptr, p1 - ptr - 1),
               ns->write (interp, "%Q", 2));
      ptr = p2 + 1;

      nb = sp->nbytes - (ptr - start);
      ptr = xmemchr (ptr, '$', nb);
      if (!ptr)
        {
          KP_VTRY (ns->write (interp, p2 + 1, nb));
          break;
        }

      KP_VTRY (ns->write (interp, p2 + 1, ptr - p2 - 1));
    }

  if (*args == NIL)
    // Simple string.
    return (sstream_get (interp, ns));

  *args = KP_TRY (nreverse_L (interp, *args));
  // The format string must be quoted so that it's not re-evaluated.
  *elem = KP_TRY (sstream_get (interp, ns));
  *elem = KP_TRY (KP_CALL (interp, list_fct, symbol::quote, *elem));
  *args = KP_TRY (cons::make (interp, *elem, *args));
  *elem = KP_TRY (intern (interp, "%fmt-str"));
  *args = KP_TRY (cons::make (interp, *elem, *args));
  kp_return (*args);
}

static result<object>
backquote_fct (interpreter *interp, object *argv, int)
{
  return (expand_bq (interp, *argv));
}

// (De)serialization definitions.

pack_cache::pack_cache (interpreter *interp) : ref (interp)
{
  for (size_t i = 0; i < KP_NELEM (this->st_tab); ++i)
    this->st_tab[i] = UNBOUND;

  this->l_obj.data = this->st_tab;
  this->l_obj.len = (uint32_t)KP_NELEM (this->st_tab);
  this->n_elem = this->n_old = 0;
  this->evict = true;
  *this->ref = this->l_obj.as_obj ();
}

static uint32_t
id_hash (interpreter *interp, object obj)
{
  int itp = itype (obj);
  switch (itp)
    {
      case typecode::INT:
      case typecode::BIGINT:
      case typecode::FLOAT:
      case typecode::BIGFLOAT:
      case typecode::CHAR:
        return (deref (xhash (interp, obj)));

      default:
        if (itp != typecode::CONS && as_varobj(obj)->flagged_p (FLAGS_CONST))
          return (deref (xhash (interp, obj)));
        return (hash_addr (obj));
    }
}

static inline bool
id_equal (interpreter *interp, object x, object y)
{
  int t1 = itype (x), t2 = itype (y);
  if (t1 != t2)
    return (false);

  switch (t1)
    {
      case typecode::INT:
      case typecode::BIGINT:
      case typecode::FLOAT:
      case typecode::BIGFLOAT:
      case typecode::CHAR:
        return (deref (equal (interp, x, y)));

      default:
        if (t1 != typecode::CONS &&
            as_varobj(x)->flagged_p (FLAGS_CONST) &&
            as_varobj(y)->flagged_p (FLAGS_CONST))
          return (deref (equal (interp, x, y)));

        return (x == y);
    }
}

uint32_t pack_cache::size () const
{
  return (len_a (*this->ref) / 2);
}

object* pack_cache::data ()
{
  return (as_array(*this->ref)->data);
}

static object*
pcache_getptr (interpreter *interp, pack_cache& cache,
               object key, object mask)
{
  uint32_t nprobe = 1, idx = id_hash (interp, key) & (cache.size () - 1);
  for (mask = ~mask ; ; )
    {
      object *p = cache.data () + idx * 2;
      if ((*p & mask) == UNBOUND || id_equal (interp, *p & ~EXTRA_BIT, key))
        return (p);

      idx = (idx + nprobe++) & (cache.size () - 1);
    }
}

object pack_cache::get (interpreter *interp, object key)
{
  object *ptr = pcache_getptr (interp, *this, key, 0);
  if (*ptr == UNBOUND)
    return (*ptr);
  else if ((*ptr & EXTRA_BIT) == 0)
    {
      *ptr |= EXTRA_BIT;
      ++this->n_old;
    }

  return (ptr[1]);
}

static void
pcache_cleanup (pack_cache& cache)
{
  object *data = cache.data ();

  for (uint32_t i = 0; i < cache.l_obj.len; i += 2)
    if (data[i] != UNBOUND && (data[i] & EXTRA_BIT) == 0)
      {
        data[i] = data[i + 1] = UNBOUND | EXTRA_BIT;
        --cache.n_elem;
      }
}

static result<void>
pcache_resize (interpreter *interp, pack_cache& cache)
{
  uint32_t nsize = cache.size () * 2;
  object *data = cache.data ();
  valref nv = KP_TRY (alloc_array (interp, nsize * 2));

  for (uint32_t i = 0; i < nsize; i += 2)
    {
      object obj = data[i];
      if ((obj & ~EXTRA_BIT) == UNBOUND)
        continue;

      uint32_t nprobe = 1, idx = id_hash (interp, obj) & (nsize - 1);
      while (true)
        {
          if (xaref (*nv, idx * 2) == UNBOUND)
            {
              xaref(*nv, idx * 2 + 0) = obj;
              xaref(*nv, idx * 2 + 1) = data[i + 1];
              break;
            }

          idx = (idx + nprobe++) & (nsize - 1);
        }
    }

  *cache.ref = *nv;
  return (0);
}

static const uint32_t CLEANUP_THRESHOLD = 10 * 1024;

result<void> pack_cache::put (interpreter *interp, object key, object val)
{
  object *ptr = pcache_getptr (interp, *this, key, EXTRA_BIT);
  if (*ptr != UNBOUND)
    return (0);

  ptr[0] = key, ptr[1] = val;
  if (++this->n_elem * 100 <= this->size () * 75)
    ;
  else if (this->evict && this->n_elem > CLEANUP_THRESHOLD)
    pcache_cleanup (*this);
  else
    return (pcache_resize (interp, *this));

  return (0);
}

pack_info::pack_info (interpreter *interp) :
    map (interp), offset (interp), errmsg (nullptr)
{
}

result<void> pack_info::init (interpreter *interp, bool use_cache)
{
  if (use_cache)
    {
      this->cache = new (this->pcache.ptr ()) pack_cache (interp);
      object base = deref (alloc_bvector (interp, 0));
      this->bstream = KP_TRY (bvstream (interp, base, STRM_RDWR | STRM_NOLOCK));
    }
  else
    {
      this->cache = nullptr;
      *this->map = KP_TRY (KP_CALL (interp, table_fct, NIL, NIL));
    }

  return (0);
}

result<void> pack_info::add_mapping (interpreter *interp, object key, object val)
{
  if (this->cache)
    return (this->cache->put (interp, key, val));

  valref tmp (interp, val);
  object ret = KP_TRY (table_get (interp, *this->map, key, UNBOUND, false));
  if (ret == UNBOUND)
    KP_VTRY (table_put (interp, *this->map, key, *tmp, false));

  return (0);
}

object pack_info::get (interpreter *interp, object obj)
{
  return (this->cache ? this->cache->get (interp, obj) :
                        deref (table_get (interp, *this->map, obj,
                                          UNBOUND, false)));
}

void pack_info::touch (interpreter *interp, int offset)
{
  if (offset < 0)
    return;

  deref (this->bstream->flush (interp));
  as_bvector(this->bstream->extra)->data[offset] |= 0x80;
}

result<int64_t> xpack (interpreter *interp, stream *strm,
                       object obj, object *map, size_t nmap)
{
  pack_info info { interp };
  KP_VTRY (info.init (interp, true));
  for (size_t i = 0; i < nmap; i += 2)
    KP_VTRY (info.add_mapping (interp, map[i] | EXTRA_BIT, map[i + 1]));

  int64_t rv = KP_TRY (xpack (interp, info.bstream, obj, info));
  if (rv < 0 || info.bstream->err_p ())
    return (-1);

  uint32_t nsz;
  unsigned char *data = bvstream_data (info.bstream, nsz);
  auto ret = strm->write (interp, data, nsz);

  deref (info.bstream->close (interp));
  return (ret);
}

result<void> print_backtrace (interpreter *interp, uint32_t frame,
                             stream *strmp, io_info& info)
{
  KP_VTRY (strmp->write (interp, "Backtrace:\n", 11));
  object tr = KP_TRY (interp->stacktrace (frame));

  if (tr == NIL)
    {
      KP_VTRY (strmp->write (interp, "  #<top-level>\n\n", 16));
      return (0);
    }

  uint32_t idx = 0;
  info.flags |= io_info::FLG_SAFE;

  for (cons::iterator it (interp, tr); it.valid (); ++it)
    {
      char sbuf[64];
      object vec = *it;
      uint32_t vl;

      KP_VTRY (strmp->write (interp, sbuf, sprintf (sbuf, "  %d: (", idx++)));
      if (!array_p (vec) || (vl = len_a (vec)) == 0)
        {
          KP_VTRY (strmp->write (interp, "???" ")", 4));
          continue;
        }

      object caller = xaref (vec, 0);

      if (fct_p (caller))
        {
          object nm = fct_name (caller);
          if (nm == NIL)
            KP_VTRY (strmp->write (interp, "#:fct", 5));
          else
            KP_VTRY (xwrite (interp, strmp, nm, info));
        }
      else
        KP_VTRY (strmp->write (interp, "???", 3));

      for (uint32_t i = 1; i < vl; ++i)
        {
          KP_VTRY (strmp->putb (interp, ' '),
                   xwrite (interp, strmp, xaref (vec, i), info));
        }

      KP_VTRY (strmp->write (interp, ")\n", 2));
    }

  KP_VTRY (strmp->putb (interp, '\n'));
  info.flags &= ~io_info::FLG_SAFE;
  return (0);
}

void write_exc (interpreter *interp, stream *strm, object exc, io_info& info)
{
  if (write_S(interp, strm, type_name (type (exc)), info).error_p () ||
      strm->write(interp, ": ", 2).error_p () ||
      xwrite(interp, strm, exc, info).error_p ())
    {
      static const char msg[] = "failed to write raised value";
      deref (strm->write (interp, msg, sizeof (msg) - 1));
    }
}

static int
do_init_io (interpreter *interp)
{
  int ret = init_op::call_deps (interp, &init_symbols);
  if (ret != init_op::result_ok)
    return (ret);

  static native_function backquote_macro;
  auto *bp = ensure_mask (&backquote_macro);

  bp->vo_full = function_base::native_flag;
  bp->vo_type = typecode::FCT;
  bp->fct = backquote_fct;
  bp->min_argc = bp->max_argc = 1;

  auto rs = intern (interp, "backquote");
  if (rs.error_p ())
    return (init_op::result_failed);

  object sym = bp->name = deref (rs);
  symval(sym) = bp->as_obj ();
  as_symbol(sym)->set_flag (symbol::ctv_flag);

  return (ret);
}

init_op init_io (do_init_io, "io");

KP_DECLS_END