khipu/eval.cpp

/* Definitions for the 'eval' function.

   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 <cstdio>
#include "khipu.hpp"

KP_DECLS_BEGIN

static result<uint32_t>
process_keys (interpreter *interp, object kwtab, uint32_t nreq,
              uint32_t nkw, uint32_t nopt, uint32_t bp, uint32_t nargs, bool va)
{
  uint32_t extra = nopt + nkw;
  uint32_t total = nreq + extra;

  if (nargs < nreq)
    return (interp->raise_nargs (nreq, total, nargs));

  tmp_allocator ta { interp };
  object *argv = (object *)ta.alloc (extra * sizeof (*argv));
  uint32_t ix, ax = 0;
  object uv, saved_data[4];
  local_varobj<array> saved;

  saved.local_init (saved_data, KP_NELEM (saved_data));

  saved.data[0] = *(interp->stkend - 1);
  saved.data[1] = *(interp->stkend - 2);
  saved.data[2] = *(interp->stkend - 4);
  saved.data[3] = *(interp->stkend - 5);
  interp->aux = saved.as_obj ();

  for (ix = 0; ix < extra; ++ix)
    argv[ix] = UNBOUND;

  uint32_t n = len_a (kwtab) / 2;

  for (ix = nreq; ix < nargs; ++ix)
    {
      uv = interp->stack[bp + ix];
      if (keyword_p (uv))
        break;
      else if (ax >= nopt)
        goto done;

      argv[ax++] = uv;
    }

  if (ix >= nargs)
    goto done;

  do
    {
      if (++ix >= nargs)
        return (interp->raise ("arg-error",
                               KP_SPRINTF (interp,
                                           "keyword %Q requires an argument",
                                           uv)));

      uint32_t pos = hash_S (interp, uv) & (n - 1);
      while (true)
        {
          object *keyp = &xaref(kwtab, pos * 2);
          if (*keyp == fixint (0))
            return (interp->raise ("arg-error",
                                   KP_SPRINTF (interp,
                                               "invalid keyword %Q", uv)));
          else if (*keyp == uv)
            {
              pos = as_int (*++keyp);
              break;
            }

          pos = (pos + 1) & (n - 1);
        }

      if (argv[pos] == UNBOUND)
        argv[pos] = interp->stack[bp + ix];

      if (++ix >= nargs)
        break;

      uv = interp->stack[bp + ix];
    }
  while (keyword_p (uv));

done:
  uint32_t nrest = nargs - ix;
  if (!va && nrest > 0)
    return (interp->raise ("arg-error",
                           KP_SPRINTF (interp,
                                       "wrong number of positional arguments "
                                       "for %Q (expected %Q, got %Q)",
                                       interp->caller (),
                                       fixint (nreq + nopt), fixint (nargs))));

  nargs = total + nrest;
  move_objs (interp->stack + bp + total, interp->stack + bp + ix, nrest);
  copy_objs (interp->stack + bp + nreq, argv, extra);

  interp->stkend = interp->stack + bp + nargs;
  KP_VTRY (interp->growstk (interpreter::frame_size));
  *interp->stkend++ = saved.data[3];
  *interp->stkend++ = saved.data[2];
  *interp->stkend++ = fixint (nargs);
  *interp->stkend++ = saved.data[1];
  *interp->stkend++ = saved.data[0];

  interp->aux = UNBOUND;
  interp->cur_frame = interp->stklen ();
  return (nargs);
}

// Index a sequence with N arguments on the stack.
static result<object>
call_indexer (interpreter *interp, indexer_t fp, object seq, int n)
{
  return (fp (interp, seq, *(interp->stkend - n),
              n > 1 ? interp->stktop () : UNBOUND));
}

static inline result<bool>
call_sequence (interpreter *interp, object seq, int n)
{
  indexer_t fp = index_seq (seq);
  if (!fp)
    return (false);
  else if (n == 0)
    return (interp->raise ("arg-error", "missing index for sequence"));
  else if (n > 2)
    {
      local_varobj<string> sn;
      sn.local_init ("#:index", 7);
      return (interp->raise_nargs (sn.as_obj (), 1, 2, n));
    }

  *(interp->stkend - 1) = KP_TRY (call_indexer (interp, fp, seq, n));
  return (true);
}

static uint32_t
fetch32 (const uint8_t*& ptr)
{
  uint32_t ret = get32 (ptr);
  ptr += sizeof (ret);
  return (ret);
}

static inline uint32_t
ip_ival (const uint8_t*& ip)
{
  return (!bcode_long_p (*(ip - 1)) ? *ip++ : fetch32 (ip));
}

static result<int>
push_seq (interpreter *interp, object seq, int n)
{
  int ret = 0;

  if (xcons_p (seq))
    {
      cons::iterator it { interp, seq };
      for (; it.valid (); ++it, ++ret)
        KP_VTRY (interp->push (*it));

      if (!xcons_p (it.node ()))
        return (interp->raise ("arg-error",
                               "list argument must be a proper list"));
    }
  else if (array_p (seq))
    {
      uint32_t len = len_a (seq);
      KP_VTRY (interp->growstk (len));
      for (; ret < (int)len; ++ret)
        *interp->stkend++ = xaref (seq, ret);
    }
  else if (table_p (seq))
    for (table::iterator it (interp, seq); it.valid (); ++it, ++ret)
      KP_VTRY (interp->push (it.key ()));
  else if (tuple_p (seq))
    for (tuple::iterator it (interp, seq); it.valid (); ++it, ++ret)
      KP_VTRY (interp->push (*it));
  else if (fct_p (*(interp->stkend - n + 1)))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "cannot interpret object of "
                                               "type %Q as a sequence",
                                               type (seq))));
  else
    {
      KP_VTRY (interp->push (seq),
               interp->push (fixint (0)),
               intern (interp, "g-apply", 7));
      valref meth (interp, symval (interp->retval));

      object *lp = interp->stkend - n - 1;

      if (*meth == UNBOUND)
        return (interp->raise ("type-error",
                               KP_SPRINTF (interp, "cannot apply object of "
                                                   "type %Q", type (*lp))));

      move_objs (lp + 1, lp, n);
      *lp = *meth;
      ret = 2;
    }

  return (ret);
}

static result<bool>
captenv (interpreter *interp, uint32_t bp, function *fp)
{
  const array *ap = as_array (fp->env);
  object env = KP_TRY (alloc_array (interp, ap->len + 1));

  for (uint32_t i = 0; i < ap->len; ++i)
    xaref(env, i) = interp->stack[bp + as_int (ap->data[i])];

  if (!native_fct_p (interp->stack[--bp]))
    xaref(env, ap->len) = fct_env (interp->stack[bp]);

  fp->env = env;
  return (true);
}

static inline result<bool>
push_symval (interpreter *interp, object sym)
{
  interp->retval = sym;
  if (as_symbol(sym)->flagged_p (symbol::ctv_flag) ||
      (interp->aux = symval (interp->retval)) == UNBOUND)
    return (interp->raise ("unbound-error",
                           KP_SPRINTF (interp,
                                       "symbol %Q is unbound",
                                       interp->retval)));

  *interp->stkend++ = interp->aux;
  return (true);
}

static inline result<bool>
set_symval (interpreter *interp, object sym)
{
  symbol *sp = as_symbol (sym);

  if (sp->flagged_p (FLAGS_CONST))
    return (interp->raise ("const-error",
                           KP_SPRINTF (interp,
                                       "cannot assign to constant %Q",
                                       sp->as_obj ())));
  else if (kp_likely (!sp->tl_idx || interp->n_tlsyms <= sp->tl_idx))
    {
      sp->value = interp->stktop ();
      deref (gc_wbarrier (interp, sym, sp->value));
    }
  else
    interp->tl_syms[sp->tl_idx - 1] = interp->stktop ();

  return (true);
}

static inline object&
closure_var (interpreter *interp, uint32_t bp, uint32_t n, uint32_t idx)
{
  array *ap = as_array (fct_env (interp->stack[bp - 1]));
  for (uint32_t i = 0; i < n; ++i)
    ap = as_array (ap->data[ap->len - 1]);

  return (ap->data[idx]);
}

// Additional data used in function calls.
struct call_data
{
  uint32_t ip_offset;
  uint32_t topf;
};

struct cont_data
{
  coroutine *crp;
  object value;
};

static result<object> __attribute__((hot))
run_bytecode (interpreter *interp, uint32_t nargs,
              cont_data *cont = nullptr, const call_data *cdp = nullptr)
{
  uint32_t top_frame = interp->cur_frame;
  uint32_t n = 0, bp, ix;
  int32_t sx = 0;
  const uint8_t *ip;
  object fn;
  object* stack = interp->stack, *fvals;
  object*& stkend = interp->stkend;
  object& retval = interp->retval;
  cons *cnp;

#if defined (__GNUC__) && !defined (KP_NO_THREADED_GOTO)
#  define GOTO_LABELS
  const void* const LABELS[] =
    {
#  define P_(opc)   [OP_##opc] = &&OP_LBL_##opc
      P_(NOP), P_(DUP), P_(POP), P_(RET), P_(IS), P_(NOT), P_(CONS),
      P_(CAR), P_(CDR), P_(CADR), P_(APPLY), P_(TAPPLY), P_(LOADT),
      P_(LOADNIL), P_(LOAD0), P_(LOAD1), P_(LOADA0), P_(LOADA1), P_(LOADC00),
      P_(LOADC01), P_(MKCONT), P_(CLOSURE), P_(VFRAME), P_(TRYEND),
      P_(LDCALLER), P_(CLREXC), P_(SYMNAME), P_(SYMPKG), P_(COROVAL),
      P_(TYPEP), P_(TYPEP2), P_(RAISE), P_(LOADI8), P_(LOADI32), P_(LOADCHR8),
      P_(LOADCHR32), P_(VARGC), P_(VARGCL), P_(JMP), P_(JMPL), P_(BRT),
      P_(BRTL), P_(BRN), P_(BRNL), P_(BRNEQ), P_(BRNEQL), P_(TCALL), P_(TCALLL),
      P_(CALL), P_(CALLL), P_(RECUR), P_(RECURL), P_(TRECUR), P_(TRECURL),
      P_(SETC0), P_(SETC0L), P_(SETC), P_(SETCL), P_(SETA), P_(SETAL),
      P_(SETG), P_(SETGL), P_(SETFGS), P_(SETFGSL), P_(LOADC0), P_(LOADC0L),
      P_(LOADC), P_(LOADCL), P_(LOADA), P_(LOADAL), P_(LOADG), P_(LOADGL),
      P_(LOADV), P_(LOADVL), P_(LOADX), P_(LOADXL), P_(LOADFGS), P_(LOADFGSL),
      P_(BIND), P_(BINDL), P_(TRYBEGIN), P_(TRYBEGINL), P_(SETAPOP),
      P_(SETAPOPL), P_(IRTJMP), P_(IRTJMPL), P_(OPTARGS), P_(OPTARGSL),
      P_(BRBOUND), P_(BRBOUNDL), P_(KWARGS), P_(KWARGSL), P_(JMPT), P_(JMPTL),
      P_(JMPN), P_(JMPNL), P_(BOX), P_(BOXL), P_(LOADB), P_(LOADBL), P_(SETB),
      P_(SETBL), P_(SKIP), P_(SKIPL), P_(UNBIND), P_(UNBINDL)
    };

#  undef P_
#else
  uint32_t op;
#endif

#define U_PUSH(val)   *stkend++ = val
#define r_stkend(off)   *(stkend - (off))

  if (cdp)
    { // Restored from a caught exception.
      top_frame = cdp->topf;
      nargs = as_int (stack[interp->cur_frame - 3]);
      bp = interp->cur_frame - interpreter::frame_size - nargs;
      fn = stack[bp - 1];
      ip = as_bvector(fct_bcode (fn))->data + cdp->ip_offset;
    }
  else if (cont)
    { // Resume execution from coroutine.
      interp->cur_frame = cont->crp->frame;
      nargs = as_int (stack[interp->cur_frame - 3]);
      bp = interp->cur_frame - interpreter::frame_size - nargs;
      fn = stack[bp - 1];
      ip = as_bvector(fct_bcode (fn))->data + cont->crp->ip_offset;
      U_PUSH (cont->value);
    }
  else
    { // Regular function call.
    top:
      fn = r_stkend (nargs + 1);
      ip = as_bvector(fct_bcode (fn))->data;
      bp = interp->stklen () - nargs;
      KP_VTRY (interp->push_frame (as_fct(fn)->env, nargs, 0),
               as_fct(fn)->test_nargs (interp, nargs),
               interp->growstk (as_fct(fn)->max_sp));
      stack = interp->stack;
    }

  fvals = as_array(fct_vals (stack[bp - 1]))->data;

#ifdef GOTO_LABELS
#  define OP_(code)   OP_LBL_##code
#  define NEXT_OP     goto *LABELS[*ip++]
  NEXT_OP;
#else

#  define OP_(code)   case OP_##code
#  define NEXT_OP     goto next_op

next_op:
  op = *ip++;
dispatch:
  switch (op)
#endif
  {
    OP_(NOP):
      NEXT_OP;

    OP_(VARGC):
    OP_(VARGCL):
      ix = ip_ival (ip);
      sx = (int32_t)nargs - (int32_t)ix;
      if (sx > 0)
        {
          stack[bp + ix] = KP_TRY (list_fct (interp, &stack[bp + ix], sx));
          if (sx > 1)
            {
              stack[bp + ix + 1] = stack[bp + nargs + 0];
              stack[bp + ix + 2] = stack[bp + nargs + 1];
              stack[bp + ix + 3] = fixint (ix + 1);
              stack[bp + ix + 5] = fixint (0);
              stkend = stack + bp + ix + 6;
              interp->cur_frame = interp->stklen ();
            }
        }
      else
        {
          U_PUSH (fixint (0));
          r_stkend(3) = fixint (ix + 1);
          r_stkend(4) = r_stkend (5);
          r_stkend(5) = r_stkend (6);
          r_stkend(6) = NIL;
          interp->cur_frame = interp->stklen ();
        }

      nargs = ix + 1;
      NEXT_OP;

    OP_(BRBOUND):
    OP_(BRBOUNDL):
      U_PUSH (stack[bp + ip_ival (ip)] != UNBOUND ? symbol::t : NIL);
      NEXT_OP;

    OP_(DUP):
      retval = r_stkend(1);
      U_PUSH (retval);
      NEXT_OP;

    OP_(POP):
      interp->popn ();
      NEXT_OP;

    OP_(TRECUR):
    OP_(TRECURL):
      KP_VTRY (interp->handle_evs ());
      n = ip_ival (ip);
      bp = interp->cur_frame - interpreter::frame_size - nargs;
      interp->cur_frame = as_int (stack[interp->cur_frame - 4]);
      move_objs (&stack[bp - 1], stkend - n - 1, n + 1);
      stkend = stack + bp + n;
      nargs = n;
      goto top;

    OP_(TCALL):
    OP_(TCALLL):
      KP_VTRY (interp->handle_evs ());
      n = ip_ival (ip);
    do_tcall:
      fn = r_stkend (n + 1);
      if (fct_p (fn))
        {
          if (native_fct_p (fn))
            {
              KP_VTRY (as_native_fct(fn)->call (interp, n));
              stack = interp->stack;
              U_PUSH (retval);
              NEXT_OP;
            }

          bp = interp->cur_frame - interpreter::frame_size - nargs;
          interp->cur_frame = as_int (stack[interp->cur_frame - 4]);
          move_objs (&stack[bp - 1], stkend - n - 1, n + 1);

          stkend = stack + bp + n;
          nargs = n;
          goto top;
        }
      else
        {
          bool rv = KP_TRY (call_sequence (interp, fn, n));
          if (rv)
            {
              stack = interp->stack, stkend -= n;
              r_stkend(1) = retval;
              NEXT_OP;
            }
        }

      return (interp->raise ("type-error",
                             KP_SPRINTF (interp,
                                         "object of type %Q is not callable",
                                         type (fn))));

    OP_(RECUR):
    OP_(RECURL):
      nargs = ip_ival (ip);
      stack[interp->cur_frame - 2] = fixint (ip -
        as_bvector(fct_bcode (stack[bp - 1]))->data);
      goto top;

    OP_(CALL):
    OP_(CALLL):
      n = ip_ival (ip);
    do_call:
      fn = r_stkend (n + 1);
      if (fct_p (fn))
        {
          if (native_fct_p (fn))
            {
              KP_VTRY (as_native_fct(fn)->call (interp, n));
              stack = interp->stack;
              U_PUSH (retval);
              NEXT_OP;
            }

          stack[interp->cur_frame - 2] = fixint (ip -
            as_bvector(fct_bcode (stack[bp - 1]))->data);
          nargs = n;
          goto top;
        }
      else
        {
          bool rv = KP_TRY (call_sequence (interp, fn, n));
          if (rv)
            {
              stack = interp->stack, stkend -= n;
              r_stkend(1) = retval;
              NEXT_OP;
            }
        }
      
      return (interp->raise ("type-error",
                             KP_SPRINTF (interp,
                                         "object of type %Q is not callable",
                                         type (fn))));

    OP_(IRTJMP):
      KP_VTRY (interp->handle_evs ());
    OP_(JMP):
      ip += (int16_t)get16 (ip);
      NEXT_OP;

    OP_(IRTJMPL):
      KP_VTRY (interp->handle_evs ());
    OP_(JMPL):
      ip += (int32_t)get32 (ip);
      NEXT_OP;

    OP_(BRN):
      interp->pop ();
      ip += retval == NIL ? (int16_t)get16 (ip) : sizeof (int16_t);
      NEXT_OP;

    OP_(BRNL):
      interp->pop ();
      ip += retval == NIL ? (int32_t)get32 (ip) : sizeof (int32_t);
      NEXT_OP;

    OP_(BRT):
      interp->pop ();
      ip += retval != NIL ? (int16_t)get16 (ip) : sizeof (int16_t);
      NEXT_OP;

    OP_(BRTL):
      interp->pop ();
      ip += retval != NIL ? (int32_t)get32 (ip) : sizeof (int32_t);
      NEXT_OP;

    OP_(BRNEQ):
      ip += r_stkend (2) != r_stkend (1) ?
        (int16_t)get16 (ip) : sizeof (int16_t);
      interp->popn (2);
      NEXT_OP;

    OP_(BRNEQL):
      ip += r_stkend (2) != r_stkend (1) ?
        (int32_t)get32 (ip) : sizeof (int32_t);
      interp->popn (2);
      NEXT_OP;

    OP_(JMPT):
    OP_(JMPTL):
      sx = *(ip - 1) - OP_JMPT;
      if (r_stkend (1) != NIL)
        ip += sx ? (int32_t)get32 (ip) : (int16_t)get16 (ip);
      else
        {
          interp->popn ();
          ip += sizeof (int16_t) << sx;
        }

      NEXT_OP;

    OP_(JMPN):
    OP_(JMPNL):
      sx = *(ip - 1) - OP_JMPN;
      if (r_stkend (1) == NIL)
        ip += sx ? (int32_t)get32 (ip) : (int16_t)get16 (ip);
      else
        {
          interp->popn ();
          ip += sizeof (int16_t) << sx;
        }

      NEXT_OP;

    OP_(RET):
      retval = r_stkend (1);
      stkend = stack + interp->cur_frame;
      interp->cur_frame = as_int (stack[interp->cur_frame - 4]);
      if (interp->cur_frame == top_frame)
        return (retval);

      stkend -= interpreter::frame_size + nargs;
      nargs = as_int (stack[interp->cur_frame - 3]);
      bp = interp->cur_frame - interpreter::frame_size - nargs;
      fn = stack[bp - 1];

      fvals = as_array(fct_vals (fn))->data;
      ip = as_bvector(fct_bcode (fn))->data +
           as_int (stack[interp->cur_frame - 2]);

      r_stkend(1) = retval;
      NEXT_OP;

    OP_(IS):
      r_stkend(2) = r_stkend (2) == r_stkend (1) ? symbol::t : NIL;
      interp->popn ();
      NEXT_OP;

    OP_(NOT):
      r_stkend(1) = r_stkend (1) == NIL ? symbol::t : NIL;
      NEXT_OP;

    OP_(CONS):
      r_stkend(2) = KP_TRY (cons::make (interp, r_stkend (2), r_stkend (1)));
      interp->popn ();
      NEXT_OP;

    OP_(CAR):
      if (!(cnp = as<cons> (r_stkend (1))))
        return (interp->raise ("type-error", "car: value is not a cons"));
      r_stkend(1) = cnp->car;
      NEXT_OP;

    OP_(CDR):
      if (!(cnp = as<cons> (r_stkend (1))))
        return (interp->raise ("type-error", "cdr: value is not a cons"));
      r_stkend(1) = cnp->cdr;
      NEXT_OP;

    OP_(CADR):
      if (!(cnp = as<cons> (r_stkend (1))) ||
          !(cnp = as<cons> (cnp->cdr)))
        return (interp->raise ("type-error", "cadr: value is not a cons"));

      r_stkend(1) = cnp->car;
      NEXT_OP;

    OP_(SYMNAME):
    OP_(SYMPKG):
      {
        symbol *sp = as<symbol> (r_stkend (1));
        if (kp_unlikely (!sp))
          {
            char err[] = "name\0pkg";
            char buf[100];

            sprintf (buf, "sym%s: argument must be a symbol",
                     err + (*(ip - 1) - OP_SYMNAME) * 5);
            return (interp->raise ("type-error", buf));
          }

        r_stkend(1) = (&sp->name)[*(ip - 1) - OP_SYMNAME];
        NEXT_OP;
      }

    OP_(COROVAL):
      {
        auto crp = as<coroutine> (r_stkend (1));
        if (kp_unlikely (!crp))
          return (interp->raise ("type-error",
                                 "coro-val: argument must be a coroutine"));

        r_stkend(1) = crp->value;
        NEXT_OP;
      }

    OP_(TYPEP2):
      ix = itype (r_stkend (1));
      sx = *ip++;

      if (sx == (int32_t)ix ||
          itype (builtin_member (r_stkend (1))) == sx)
        {
          ++ip;   // Skip the second typecode.
          r_stkend(1) = symbol::t;
          NEXT_OP;
        }

      // FALLTHROUGH.

    OP_(TYPEP):
      ix = itype (r_stkend (1));
      sx = *ip++;

      r_stkend(1) = sx == (int32_t)ix ||
        itype (builtin_member (r_stkend (1))) == sx ?
        symbol::t : NIL;
      NEXT_OP;

    OP_(TAPPLY):
    OP_(APPLY):
      sx = *(ip - 1) == OP_APPLY;
      n = ip_ival (ip);
      n += -2 + KP_TRY (push_seq (interp, interp->pop (), n));
      stack = interp->stack;   // Could get moved by the above operation.

      if (sx)
        goto do_call;
      else
        goto do_tcall;

    OP_(LOADT):
      U_PUSH (symbol::t);
      NEXT_OP;

    OP_(LOADNIL):
      U_PUSH (NIL);
      NEXT_OP;

    OP_(LOAD0):
      U_PUSH (fixint (0));
      NEXT_OP;

    OP_(LOAD1):
      U_PUSH (fixint (1));
      NEXT_OP;

    OP_(LOADI8):
      U_PUSH (fixint ((int8_t)*ip++));
      NEXT_OP;

    OP_(LOADI32):
      U_PUSH (fixint (fetch32 (ip)));
      NEXT_OP;

    OP_(LOADCHR8):
      U_PUSH (charobj (*ip++));
      NEXT_OP;

    OP_(LOADCHR32):
      U_PUSH (charobj (fetch32 (ip)));
      NEXT_OP;

    OP_(LOADV):
      U_PUSH (fvals[*ip++]);
      NEXT_OP;

    OP_(LOADVL):
      U_PUSH (fvals[fetch32 (ip)]);
      NEXT_OP;

    OP_(LOADG):
      KP_VTRY (push_symval (interp, fvals[*ip++]));
      NEXT_OP;

    OP_(LOADGL):
      KP_VTRY (push_symval (interp, fvals[fetch32 (ip)]));
      NEXT_OP;

    OP_(LOADFGS):
      KP_VTRY (push_symval (interp, symbol::fast_global_syms[*ip++]));
      NEXT_OP;

    OP_(LOADFGSL):
      KP_VTRY (push_symval (interp, symbol::fast_global_syms[fetch32 (ip)]));
      NEXT_OP;

    OP_(SETG):
    OP_(SETGL):
      KP_VTRY (set_symval (interp, fvals[ip_ival (ip)]));
      NEXT_OP;

    OP_(SETFGS):
    OP_(SETFGSL):
      KP_VTRY (set_symval (interp, symbol::fast_global_syms[ip_ival (ip)]));
      NEXT_OP;

    OP_(LOADA0):
      U_PUSH (stack[bp]);
      NEXT_OP;

    OP_(LOADA1):
      U_PUSH (stack[bp + 1]);
      NEXT_OP;

    OP_(LOADA):
      U_PUSH (stack[bp + *ip++]);
      NEXT_OP;

    OP_(LOADAL):
      U_PUSH (stack[bp + fetch32 (ip)]);
      NEXT_OP;

    OP_(SETA):
    OP_(SETAL):
      stack[bp + ip_ival (ip)] = r_stkend (1);
      NEXT_OP;

    OP_(SETAPOP):
    OP_(SETAPOPL):
      stack[bp + ip_ival (ip)] = r_stkend (1);
      --stkend;
      NEXT_OP;

    OP_(LOADC):
    OP_(LOADCL):
      sx = ip_ival (ip);
      U_PUSH (xcar (closure_var (interp, bp, sx, ip_ival (ip))));
      NEXT_OP;

    OP_(LOADC0):
    OP_(LOADC0L):
      U_PUSH (xcar (xaref (as_fct(stack[bp - 1])->env, ip_ival (ip))));
      NEXT_OP;

    OP_(LOADC00):
      U_PUSH (xcar (xaref (as_fct(stack[bp - 1])->env, 0)));
      NEXT_OP;

    OP_(LOADC01):
      U_PUSH (xcar (xaref (as_fct(stack[bp - 1])->env, 1)));
      NEXT_OP;

    OP_(SETC):
    OP_(SETCL):
      sx = ip_ival (ip);
      KP_VTRY (nputcar (interp, closure_var (interp, bp, sx, ip_ival (ip)),
                        r_stkend (1)));
      NEXT_OP;

    OP_(SETC0):
    OP_(SETC0L):
      KP_VTRY (nputcar (interp, xaref (as_fct(stack[bp - 1])->env,
                                       ip_ival (ip)),
                        r_stkend (1)));
      NEXT_OP;

    OP_(CLREXC):
      interp->last_err = NIL;
      NEXT_OP;

    OP_(TRYBEGIN):
    OP_(TRYBEGINL):
      if (kp_likely (*(ip - 1) == OP_TRYBEGIN))
        sx = get16 (ip) - sizeof (int16_t), ip += sizeof (int16_t);
      else
        sx = fetch32 (ip) - sizeof (int32_t);

      sx += ip - as_bvector(fct_bcode (stack[bp - 1]))->data;
      U_PUSH (fixint (interp->exc_offset));
      U_PUSH (fixint (sx));
      interp->exc_offset = interp->stklen () - 2;
      NEXT_OP;

    OP_(TRYEND):
      interp->pop ();
      interp->exc_offset = as_int (r_stkend (2));
      interp->popn (2);
      U_PUSH (retval);
      NEXT_OP;

    OP_(LOADX):
    OP_(LOADXL):
      interp->aux = fvals[ip_ival (ip)];
      if ((retval = symval (interp, interp->aux)) == UNBOUND)
        return (interp->raise ("unbound-error",
                               KP_SPRINTF (interp,
                                           "symbol %Q is unbound",
                                           interp->aux)));

      U_PUSH (retval);
      NEXT_OP;

    OP_(OPTARGS):
    OP_(OPTARGSL):
      if (kp_likely (!bcode_long_p (*(ip - 1))))
        ix = *ip++, n = (int8_t)*ip++;
      else
        ix = fetch32 (ip), n = fetch32 (ip);

      if ((int32_t)n <= 0)
        n = -(int32_t)n;

      if (n > nargs)
        {
          n -= nargs;
          stkend += n;
          r_stkend(1) = r_stkend (n + 1);
          r_stkend(2) = r_stkend (n + 2);
          r_stkend(3) = fixint (nargs + n);
          r_stkend(4) = r_stkend (n + 4);
          r_stkend(5) = r_stkend (n + 5);

          interp->cur_frame = interp->stklen ();
          for (ix = 0; ix < n; ++ix)
            stack[bp + nargs + ix] = UNBOUND;

          nargs += n;
        }

      NEXT_OP;

    OP_(LDCALLER):
      U_PUSH (stack[bp - 1]);
      NEXT_OP;

    OP_(KWARGS):
    OP_(KWARGSL):
      if (kp_likely (*(ip - 1) == OP_KWARGS))
        {
          ix = (int8_t)*ip++;
          n = (int8_t)*ip++;
          sx = (int8_t)*ip++;
        }
      else
        {
          ix = fetch32 (ip);
          n = fetch32 (ip);
          sx = fetch32 (ip);
        }

      nargs = KP_TRY (process_keys (interp, *fvals, ix, n, abs (sx) - ix - n,
                                    bp, nargs, sx < 0));
      NEXT_OP;

    OP_(MKCONT):
      {
        interp->pop ();
        coroutine *crp;

        if (cont && cont->crp->frame == interp->cur_frame)
          { // Update coroutine.
            crp = cont->crp;
            crp->argv = interp->stkobj;
            crp->exc_off = interp->exc_offset;
          }
        else
          {
            KP_VTRY (coroutine::make (interp, bp));
            crp = as_coro (interp->alval);
          }

        sx = *ip++;

        crp->ip_offset = sx + (ip -
          as_bvector (fct_bcode(stack[bp - 1]))->data);
        crp->value = retval;
        crp->sp_diff = interp->stklen () - interp->cur_frame;

        U_PUSH (crp->as_obj ());
        NEXT_OP;
      }

    OP_(BOX):
    OP_(BOXL):
      sx = ip_ival (ip);
      if (!xcons_p (stack[bp + sx]) ||
          xcdr (stack[bp + sx]) != NIL | EXTRA_BIT)
        { stack[bp + sx] = KP_TRY (cons::make (interp, stack[bp + sx],
                                               NIL | EXTRA_BIT)); }
      NEXT_OP;

    OP_(LOADB):
    OP_(LOADBL):
      U_PUSH (xcar (stack[bp + ip_ival (ip)]));
      NEXT_OP;

    OP_(SETB):
    OP_(SETBL):
      KP_VTRY (nputcar (interp, stack[bp + ip_ival (ip)], r_stkend (1)));
      NEXT_OP;

    OP_(VFRAME):
      U_PUSH (stack[interp->cur_frame - 1]);
      U_PUSH (fixint (0));
      stack[interp->cur_frame - 1] =
        fixint (interp->stklen () - interp->cur_frame - 1);
      NEXT_OP;

    OP_(BIND):
    OP_(BINDL):
      U_PUSH (fvals[ip_ival (ip)]);
      r_stkend(2) = KP_TRY (interp->dbind (r_stkend (1), r_stkend (2)));
      stack[interp->cur_frame +
            as_int (stack[interp->cur_frame - 1])] += fixint (1);
      NEXT_OP;

    OP_(UNBIND):
      KP_VTRY (interp->unbind ((uint32_t)(int8_t)*ip++,
                               cont ? cont->crp : nullptr));
      NEXT_OP;

    OP_(UNBINDL):
      KP_VTRY (interp->unbind (fetch32 (ip), cont ? cont->crp : nullptr));
      NEXT_OP;

    OP_(SKIP):
    OP_(SKIPL):
      retval = r_stkend (1);
      stkend -= ip_ival (ip);
      r_stkend(1) = retval;
      NEXT_OP;

    OP_(RAISE):
      sx = *ip;
      if (sx == 0)
        {
          if (nil_p (interp->last_err))
            return (interp->raise ("runtime error", "no exception to reraise"));
          return (interp->raise (interp->last_err));
        }
      else
        {
          object exc = r_stkend (sx);
          cnp = as<cons> (sx == 1 ? NIL : r_stkend (1));
          if (!cnp)
            return (interp->raise ("arg-error",
                                   "raise: traceback argument must be a list"));

          interp->last_tb = cnp->as_obj ();
          return (interp->raise (exc));
        }

    OP_(CLOSURE):
      {
        KP_VTRY (alloc_fct (interp));
        function *fp = as_fct (interp->alval);
        as_fct(r_stkend (1))->copy_into (fp);

        r_stkend(1) = fp->as_obj ();
        KP_VTRY (captenv (interp, bp, fp));
        NEXT_OP;
      }

#ifndef GOTO_LABELS
    default:
      goto dispatch;
#endif
  }

#ifdef GOTO_LABELS
  return (UNBOUND);   // NOTREACHED
#else
  goto dispatch;
#endif

#undef GOTO_LABELS
#undef U_PUSH
#undef r_stkend
}

static result<object>
apply_n (interpreter *interp, uint32_t nargs, cont_data *conp = nullptr)
{
  call_data cd, *cdp = nullptr;
  cd.topf = interp->cur_frame;

  while (true)
    {
      auto ret = run_bytecode (interp, nargs, conp, cdp);

      if (!ret.error_p ())
        return (*ret);

      bool exh = KP_TRY (interp->exc_handle ());
      if (!exh)
        /* No catch frame to handle this exception. Now it's the
         * top level's responsibility. */
        return (exception ());

      cd.ip_offset = as_int (interp->aux);
      cdp = &cd;
    }
}

result<object> call_coroutine (interpreter *interp,
                               coroutine *crp, object value)
{
  cont_data cd;
  cd.crp = crp;
  cd.value = value;
  return (apply_n (interp, 0, &cd));
}

result<object> call_n (interpreter *interp, uint32_t nargs)
{
  object fn = *(interp->stkend - nargs - 1);
  if (native_fct_p (fn))
    return (as_native_fct(fn)->call (interp, nargs));

  call_guard g (interp, nargs + 1);

  if (indexer_t seq = index_seq (fn))
    KP_VTRY (call_indexer (interp, seq, fn, nargs));
  else if (!fct_p (fn))
    return (interp->raise ("arg-error",
                           KP_SPRINTF (interp,
                                       "object of type %Q is not callable",
                                       type (fn))));
  else
    KP_VTRY (apply_n (interp, nargs));

  return (interp->retval);
}

// (apply fn arg1 [...args])
result<object> apply_fct (interpreter *interp, object *argv, int argc)
{
  uint32_t sp = interp->stklen ();

  KP_VTRY (interp->growstk (argc - 1));
  for (int i = 0; i < argc - 1; ++i)
    *interp->stkend++ = argv[i];

  KP_VTRY (push_seq (interp, argv[argc - 1], argc));
  return (call_n (interp, interp->stklen () - sp - 1));
}

result<object> eval (interpreter *interp, object expr)
{
  valref tmp (interp, expr);

  // Avoid compiling the expression for trivial cases.
  switch (itype (expr))
    {
      case typecode::SYMBOL:
        if (as_symbol(expr)->flagged_p (symbol::ctv_flag | symbol::alias_flag))
          break;

        interp->retval = symval (expr);
        if (interp->retval == UNBOUND)
          return (interp->raise ("unbound-error",
                                 KP_SPRINTF (interp,
                                             "symbol %Q is unbound", expr)));
        return (interp->retval);

      case typecode::CONS:
        if (expr == NIL)
          kp_return (expr);
        else if (xcar (expr) == symbol::quote &&
            cons_p (xcdr (expr)) && xcddr (expr) == NIL)
          kp_return (xcadr (expr));
        break;

      case typecode::ARRAY:
      case typecode::TABLE:
      case typecode::TUPLE:
        // These need special handling to resolve local symbols.
        break;

      case typecode::STR:
        // Handle string interpolation.
        *tmp = expr = KP_TRY (expand_str (interp, expr));
        if (str_p (expr))
          kp_return (expr);
        break;

      default:
        kp_return (expr);
    }

  valref e2 = KP_TRY (macroexp (interp, expr));
  KP_PUSH_ALL (interp, compile_expr (interp, *e2));
  return (call_n (interp, 0));
}

KP_DECLS_END