khipu/builtins.cpp

/* Definitions for builtin 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 <cstdio>
#include <new>
#include "khipu.hpp"
#include "utils/lazy.hpp"

KP_DECLS_BEGIN

static exception
invalid_arg (interpreter *interp, const char *name)
{
  char buf[128];
  sprintf (buf, "invalid argument(s) passed to '%s'", name);
  return (interp->raise ("arg-error", buf));
}

static result<int64_t>
write_generic (interpreter *interp, stream *strm,
               object obj, io_info& info)
{
  char buf[64];
  int64_t ret = KP_TRY (strm->write (interp, "#<", 2));
  ret += KP_TRY (write_S (interp, strm, type_name (type (obj)), info));
  ret += KP_TRY (strm->write (interp, " object at ", 11));
  ret += KP_TRY (strm->write (interp, buf, sprintf (buf, "%p", unmask (obj))));
  ret += KP_TRY (strm->putb (interp, '>'));
  return (ret);
}

#define INTERN(name)   \
  intern (interp, name, sizeof (name) - 1, as_package (root_package))

#define INTERN_N(name)   \
  intern (interp, name, as_package (root_package))

static inline object
safe_symval (result<object> obj)
{
  return (symbol_p (*obj) ? symval (*obj) : UNBOUND);
}

static result<object>
call_binary (interpreter *interp, object x, object y,
             result<object> (*fn) (interpreter *, object , object),
             const char *method)
{
  object ret = KP_TRY (fn (interp, x, y));
  if (ret != UNBOUND)
    return (interp->retval);

  KP_PUSH_ALL (interp, safe_symval (INTERN_N (method)), x, y);
  bool rv = KP_TRY (method_call (interp, 2));
  if (rv)
    return (interp->retval);

  valref sub_x (interp, builtin_member (x));
  valref sub_y (interp, builtin_member (y));

  if (*sub_x != UNBOUND && *sub_y != UNBOUND)
    {
      ret = KP_TRY (fn (interp, *sub_x, *sub_y));
      if (ret != UNBOUND)
        return (interp->retval);
    }

  return (interp->raise ("type-error",
                         KP_SPRINTF (interp, "invalid types: got %Q and %Q",
                                     type (x), type (y))));
}

static result<int64_t>
write_any (interpreter *interp, stream *strm,
           object obj, io_info& info)
{
  KP_PUSH_ALL (interp, safe_symval (INTERN ("g-write")), obj, strm->as_obj ());
  bool rv = KP_TRY (method_call (interp, 2));
  if (rv)
    return (0);

  object tname = type_name (obj);
  if (tname == NIL)
    return (write_generic (interp, strm, obj, info));

  int64_t ret = KP_TRY (strm->write (interp, "#<type ", 7));
  ret += KP_TRY (xwrite (interp, strm, tname, info));
  ret += KP_TRY (strm->putb (interp, '>'));
  return (ret);
}

result<int64_t> xwrite (interpreter *interp, stream *strm,
                        object obj, io_info& info)
{
  int64_t ret;
  int itp = itype (obj);

  switch (itp)
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (write_##suffix (interp, strm, obj, info));   \
    break

      DISPATCH (INT, i);
      DISPATCH (CHAR, c);
      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (FCT, x);
      DISPATCH (PKG, P);

      default:
        if (obj == UNBOUND)
          { ret = KP_TRY (strm->write (interp, "#<unbound>", 10)); }
        else if (itp == typecode::CORO || itp == typecode::STREAM ||
            (info.flags & io_info::FLG_SAFE))
         { ret = KP_TRY (write_generic (interp, strm, obj, info)); }
        else
         { ret = KP_TRY (write_any (interp, strm, obj, info)); }

#undef DISPATCH
    }

  return (strm->err_p () ? -1 : ret);
}

static inline bool
ref_obj_p (object obj, int tp)
{
  switch (tp)
    {
      case typecode::INT:
      case typecode::CHAR:
        return (false);
      case typecode::PKG:
        return (obj != root_package && obj != kword_package);
      case typecode::FCT:
        return (!as_varobj(obj)->flagged_p (function::artificial_flag));
      default:
        return (true);
    }
}

result<int64_t> xpack (interpreter *interp, stream *strm,
                       object obj, pack_info& info)
{
  int64_t ret = 0;
  int tp = itype (obj);

  if (nil_p (obj))
    return (strm->putb (interp, PACK_NIL));
  else if (array_p (obj) && len_a (obj) == 0)
    return (strm->putb (interp, PACK_EMPTY_ARRAY));
  else if ((str_p (obj) || bvector_p (obj)) && as_bvector(obj)->nbytes == 0)
    return (strm->putb (interp, str_p (obj) ?
      PACK_EMPTY_STR : PACK_EMPTY_BVECTOR));
  else if (tp == typecode::CHAR && as_char (obj) <= 0xff)
    {
      unsigned char data[] = { PACK_CHAR8, (unsigned char)as_char (obj) };
      return (strm->write (interp, data, sizeof (data)));
    }
  else if (tp == typecode::INT && as_int (obj) <= 0x7f && as_int (obj) >= -128)
    {
      unsigned char data[] = { PACK_INT8, (unsigned char)as_int (obj) };
      return (strm->write (interp, data, sizeof (data)));
    }
  else if (tp == typecode::INSTANCE && builtin_typespec_p (obj))
    {
      unsigned char data[] = { PACK_TYPESPEC,
        (unsigned char)as_instance(obj)->type_code () };
      return (strm->write (interp, data, sizeof (data)));
    }

  {
    object off = info.get (interp, obj);
    if (off != UNBOUND)
      {
        int ioff = as_int (off);
        info.touch (interp, ioff);
        ret += KP_TRY (strm->putb (interp, PACK_REF_INT32));
        ret += KP_TRY (strm->write (interp, &ioff));
        return (ret);
      }
  }

  if (ref_obj_p (obj, tp))
    {
      object pos = KP_TRY (strm->tell (interp));
      KP_VTRY (info.add_mapping (interp, obj, pos));
    }

  ret += KP_TRY (strm->putb (interp, tp));

  switch (tp)
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret += KP_TRY (pack_##suffix (interp, strm, obj, info));   \
    break

      DISPATCH (INT, i);
      DISPATCH (CHAR, c);
      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (FCT, x);
      DISPATCH (CORO, G);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
      default:
        // XXX: Other objects.
        return (invalid_arg (interp, "pack"));
#undef DISPATCH
    }

  return (strm->err_p () ? -1 : ret);
}

result<object> xunpack (interpreter *interp, stream *strm, pack_info& info)
{
  object ret = KP_TRY (strm->tell (interp));
  *info.offset = KP_TRY (copy (interp, ret));
  int tp = KP_TRY (strm->getb (interp));

  if (tp < 0)
    return (info.error ("failed to read typecode"));

  bool save = (tp & 0x80) != 0;
  tp &= ~0x80;

  switch (tp)
    {
      case PACK_NIL:
        kp_return (NIL);
      case PACK_EMPTY_ARRAY:
        kp_return (deref (alloc_array (interp, 0)));
      case PACK_EMPTY_BVECTOR:
        kp_return (deref (alloc_bvector (interp, 0)));
      case PACK_EMPTY_STR:
        kp_return (deref (alloc_str (interp, 0)));

      case PACK_INT8:
      case PACK_CHAR8:
        {
          int b = KP_TRY (strm->getb (interp));
          if (b < 0)
            return (info.error ("failed to read byte"));
          kp_return (tp == PACK_INT8 ? fixint ((int8_t)b) :
                                       charobj ((uint8_t)b));
        }

      case PACK_REF_INT32:
        {
          int off;
          bool rv = KP_TRY (strm->sread (interp, &off));

          if (!rv)
            return (info.error ("failed to read integer"));

          interp->retval = info.get (interp, intobj (interp, off));
          if (interp->retval == UNBOUND)
            return (info.error ("invalid back reference to object"));
          return (interp->retval);
        }

      case PACK_REF_OBJ:
        {
          object rv = KP_TRY (xunpack (interp, strm, info));
          if ((interp->retval = info.get (interp, rv)) == UNBOUND)
            return (info.error ("invalid back reference to object"));
          return (interp->retval);
        }

      case PACK_TYPESPEC:
        tp = KP_TRY (strm->getb (interp));
        if (tp < 0)
          return (info.error ("failed to read typespec code"));
        else if ((interp->retval = builtin_type (tp)) == UNBOUND)
          return (info.error ("invalid typespec"));

        return (interp->retval);
    
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (unpack_##suffix (interp, strm, info, save));   \
    break

      DISPATCH (INT, i);
      DISPATCH (CHAR, c);
      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (FCT, x);
      DISPATCH (CORO, G);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
      default:
        // XXX: Other objects.
        return (invalid_arg (interp, "unpack"));
#undef DISPATCH
    }

  kp_return (ret);
}

result<object> copy (interpreter *interp, object obj, bool deep)
{
  if (immediate_p (obj) || (varobj_p (obj) &&
      (as_varobj(obj)->flagged_p (FLAGS_CONST))))
    kp_return (obj);

  switch (itype (obj))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    KP_VTRY (copy_##suffix (interp, obj, deep));   \
    return (interp->retval)

      DISPATCH (CONS, L);
      DISPATCH (BVECTOR, b);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      default:
        return (invalid_arg (interp, "copy"));
#undef DISPATCH
    }
}

uint32_t hash_addr (object obj)
{
#ifndef KP_ARCH_WIDE
  return ((uint32_t)obj >> 3);
#else
  return (mix_hash (obj >> 32, obj & 0xffffffff));
#endif
}

static result<uint32_t>
hash_helper (interpreter *interp, object obj, bool& got)
{
  uint32_t ret;
  got = true;

  switch (itype (obj))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (hash_##suffix (interp, obj));   \
    return (ret)

#define hash_w(ip, x)   (bool)(got = false)

      DISPATCH (CONS, L);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (ARRAY, a);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (SYMBOL, S);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
#undef DISPATCH
#undef hash_w
      default:
        return (hash_addr (obj));
    }
}

result<uint32_t> xhash (interpreter *interp, object obj)
{
  bool got;
  uint32_t ret = KP_TRY (hash_helper (interp, obj, got));

  if (got)
    return (ret);

  KP_PUSH_ALL (interp, safe_symval (INTERN ("g-hash")), obj);
  got = KP_TRY (method_call (interp, 1));

  if (got)
    {
      int iv;

      if (as<int> (interp->retval, iv))
        return (iv);
      else if (bigint *lp = as<bigint> (interp->retval))
        return (hash_I (interp, lp->as_obj ()));
      return (interp->raise ("type-error",
                             "hash function must return an integer"));
    }

  valref sub_obj (interp, builtin_member (obj));
  if (*sub_obj != UNBOUND)
    return (hash_helper (interp, *sub_obj, got));
  return (ret);
}

result<object> length (interpreter *interp, object obj)
{
  switch (itype (obj))
    {
      case typecode::ARRAY:
        return (fixint (len_a (obj)));
      case typecode::TUPLE:
        return (fixint (len_o (obj)));
      case typecode::BVECTOR:
        return (fixint (len_b (obj)));
      case typecode::STR:
        return (fixint (len_s (obj)));
      case typecode::TABLE:
        return (fixint (len_u (obj)));
      case typecode::CONS:
        {
          auto ret = KP_TRY (len_L (interp, obj));
          return (fixint (ret));
        }
      default:
        {
          KP_PUSH_ALL (interp, safe_symval (INTERN ("g-len")), obj);
          bool rv = KP_TRY (method_call (interp, 1));
          if (rv)
            return (interp->raise ("dispatch-error",
                                   "no applicable method found for g-len"));

          int out;
          if (as<int> (interp->retval, out) || as<bigint> (interp->retval))
            return (interp->retval);

          return (interp->raise ("type-error", "len must return an integer"));
        }
    }
}

// Binary operations.

#define MIX(t1, t2)   ((t1) + ((t2) * typecode::LAST))

static result<object>
add_helper (interpreter *interp, object x, object y)
{
  object ret;

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    ret = KP_TRY (add_##suffix##suffix (interp, x, y));   \
    return (ret)

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    ret = KP_TRY (add_##s1##s2 (interp, x, y));   \
    return (ret);   \
  case MIX (typecode::t2, typecode::t1):   \
    ret = KP_TRY (add_##s1##s2 (interp, y, x));   \
    return (ret)

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);
      
      DISPATCH_1 (BIGFLOAT, F);

      DISPATCH_1 (CHAR, c);

      DISPATCH_1 (STR, s);

      // Need to handle this case manually, since addition is not commutative.
      case MIX (typecode::STR, typecode::CHAR):
        return (add_sc (interp, x, y));
      case MIX (typecode::CHAR, typecode::STR):
        return (add_cs (interp, x, y));

      DISPATCH_1 (BVECTOR, b);

      DISPATCH_1 (ARRAY, a);

      DISPATCH_1 (CONS, L);

      default:
        return (UNBOUND);

#undef DISPATCH_1
#undef DISPATCH_2
    }
}

result<object> add (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, add_helper, "g-add"));
}

#ifndef KP_ARCH_WIDE

template <typename T>
static inline void inplace_neg (T& val)
{
  val = -val;
}

#endif

static result<object>
sub_helper (interpreter *interp, object x, object y)
{
  object ret;

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    ret = KP_TRY (sub_##suffix##suffix (interp, x, y));   \
    return (ret)

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    ret = KP_TRY (sub_##s1##s2 (interp, x, y));   \
    return (ret);   \
  case MIX (typecode::t2, typecode::t1):   \
    ret = KP_TRY (sub_##s1##s2 (interp, y, x));   \
    break

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      default:
        return (UNBOUND);
    }

#undef DISPATCH_1
#undef DISPATCH_2

  /* Instead of doing (x - y), we performed (y - x), so we now have to
   * negate the result. We can do this in-place, since the return value
   * can only be seen by us. */

  if (fixint_p (ret))
    (void)neg_i (interp, ret);
  else if (varobj_p (ret))
#ifdef KP_ARCH_WIDE
    ret ^= SIGN_BIT;
#else
    switch (itype (ret))
      {
        case typecode::BIGINT:
          inplace_neg (as_bigint(ret)->len);
          break;
        case typecode::FLOAT:
          inplace_neg (as_fltobj(ret)->val);
          break;
        case typecode::BIGFLOAT:
          inplace_neg (as_bigfloat(ret)->len);
          break;
      }
#endif

  kp_return (ret);
}

result<object> sub (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, sub_helper, "g-sub"));
}

static result<object>
mul_helper (interpreter *interp, object x, object y)
{
  object ret;

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    ret = KP_TRY (mul_##suffix##suffix (interp, x, y));   \
    return (ret)

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    ret = KP_TRY (mul_##s1##s2 (interp, x, y));   \
    return (ret);   \
  case MIX (typecode::t2, typecode::t1):   \
    ret = KP_TRY (mul_##s1##s2 (interp, y, x));   \
    return (ret)

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);
      DISPATCH_2 (INT, CHAR, i, c);
      DISPATCH_2 (INT, ARRAY, i, a);
      DISPATCH_2 (INT, BVECTOR, i, b);
      DISPATCH_2 (INT, STR, i, s);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

     default:
       return (UNBOUND);
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

result<object> mul (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, mul_helper, "g-mul"));
}

static result<object>
div_helper (interpreter *interp, object x, object y)
{
  object ret;

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    ret = KP_TRY (div_##suffix##suffix (interp, x, y));   \
    return (ret)

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    ret = KP_TRY (div_##s1##s2 (interp, x, y));   \
    return (ret);   \
  case MIX (typecode::t2, typecode::t1):   \
    ret = KP_TRY (div_##s2##s1 (interp, x, y));   \
    return (ret)

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      default:
        return (UNBOUND);
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

result<object> div (interpreter *interp, object x, object y)
{
  return (call_binary (interp, x, y, div_helper, "g-div"));
}

result<object> modulo (interpreter *interp, object x, object y)
{
  object ret;

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    ret = KP_TRY (mod_##suffix##suffix (interp, x, y));   \
    return (ret)

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    ret = KP_TRY (mod_##s1##s2 (interp, x, y));   \
    return (ret);   \
  case MIX (typecode::t2, typecode::t1):   \
    ret = KP_TRY (mod_##s2##s1 (interp, x, y));   \
    return (ret)

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      default:
        return (invalid_arg (interp, "mod"));
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

result<bool> equal (interpreter *interp, object x, object y)
{
  if (x == y)
    // Identical objects compare equal iff they're not NaN or INF.
    return (x != FLT_QNAN && x != FLT_PINF && x != FLT_NINF);

#define eq_ii(interp, x, y)   false
#define eq_cc(interp, x, y)   false

  bool ret = false;

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    ret = KP_TRY (eq_##suffix##suffix (interp, x, y));   \
    return (ret)

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    ret = KP_TRY (eq_##s1##s2 (interp, x, y));   \
    return (ret);   \
  case MIX (typecode::t2, typecode::t1):   \
    ret = KP_TRY (eq_##s1##s2 (interp, y, x));   \
    return (ret)

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, FLOAT, i, f);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);

      DISPATCH_1 (BIGFLOAT, F);

      DISPATCH_1 (BVECTOR, b);
      DISPATCH_2 (BVECTOR, STR, b, s);

      DISPATCH_1 (STR, s);

      DISPATCH_1 (ARRAY, a);

      DISPATCH_1 (CONS, L);

      DISPATCH_1 (CHAR, c);

      DISPATCH_1 (FCT, x);

      default:
        // XXX: Custom types.
        return (invalid_arg (interp, "equal"));
    }

#undef eq_ii
#undef eq_cc
#undef DISPATCH_1
#undef DISPATCH_2
}

result<int> xcmp (interpreter *interp, object x, object y)
{
  if (x == y)
    return (x != FLT_QNAN ? 0 : -1);

  int ret;

  switch (MIX (itype (x), itype (y)))
    {
#define DISPATCH_1(type, suffix)   \
  case MIX (typecode::type, typecode::type):   \
    ret = KP_TRY (cmp_##suffix##suffix (interp, x, y));   \
    return (ret)

#define DISPATCH_2(t1, t2, s1, s2)   \
  case MIX (typecode::t1, typecode::t2):   \
    ret = KP_TRY (cmp_##s1##s2 (interp, x, y));   \
    return (ret);   \
  case MIX (typecode::t2, typecode::t1):   \
    ret = KP_TRY (cmp_##s1##s2 (interp, y, x));   \
    return (-ret)

      DISPATCH_1 (INT, i);
      DISPATCH_2 (INT, BIGINT, i, I);
      DISPATCH_2 (INT, FLOAT, i, f);
      DISPATCH_2 (INT, BIGFLOAT, i, F);

      DISPATCH_1 (BIGINT, I);
      DISPATCH_2 (BIGINT, FLOAT, I, f);
      DISPATCH_2 (BIGINT, BIGFLOAT, I, F);

      DISPATCH_1 (FLOAT, f);
      DISPATCH_2 (FLOAT, BIGFLOAT, f, F);

      DISPATCH_1 (BIGFLOAT, F);

      DISPATCH_1 (ARRAY, a);

      DISPATCH_1 (CONS, L);

      DISPATCH_1 (BVECTOR, b);
      DISPATCH_2 (BVECTOR, STR, b, s);

      DISPATCH_1 (STR, s);

      default:
        // XXX: Custom types.
        return (x < y ? -1 : 1);
    }

#undef DISPATCH_1
#undef DISPATCH_2
}

#define DEFBUILTIN(name)   \
  result<object> name (interpreter *interp, object *argv, int argc)

// (car arg)
static DEFBUILTIN (car_fct)
{
  cons *cnp = as<cons> (*argv);
  if (!cnp)
    return (interp->raise ("type-error", "car: value is not a cons"));

  kp_return (cnp->car);
}

// (cdr arg)
static DEFBUILTIN (cdr_fct)
{
  cons *cnp = as<cons> (*argv);
  if (!cnp)
    return (interp->raise ("type-error", "cdr: value is not a cons"));

  kp_return (cnp->cdr);
}

// (cons arg1 arg2)
static DEFBUILTIN (cons_fct)
{
  return (cons::make (interp, argv[0], argv[1]));
}

// (list [...args])
DEFBUILTIN (list_fct)
{
  if (argc == 0)
    kp_return (NIL);

  KP_VTRY (alloc_cons (interp, argc, argv, nullptr));
  kp_return (interp->alval);
}

// (list* arg1 [...args])
DEFBUILTIN (list_star)
{
  if (argc == 1)
    kp_return (*argv);

  object *tail, lst = KP_TRY (alloc_cons (interp, argc - 1, argv, &tail));
  *tail = argv[argc - 1];
  kp_return (lst);
}

// (+ [...args])
DEFBUILTIN (add_fct)
{
  if (argc == 0)
    kp_return (fixint (0));
  else if (argc == 1)
    {
      object tmp = *argv;
      switch (itype (tmp))
        {
          case typecode::INT:
          case typecode::FLOAT:
          case typecode::BIGINT:
          case typecode::BIGFLOAT:
            kp_return (tmp);
          default:
            // XXX: Custom types.
            return (invalid_arg (interp, "+"));
        }
    }

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    { *rv = KP_TRY (add (interp, *rv, argv[i])); }

  kp_return (*rv);
}

// (- arg1 [...args])
DEFBUILTIN (sub_fct)
{
  if (argc == 1)
    {
      object tmp = *argv;
      switch (itype (tmp))
        {
          case typecode::INT:
            return (neg_i (interp, tmp));
#ifdef KP_ARCH_WIDE
          case typecode::BIGINT:
          case typecode::FLOAT:
          case typecode::BIGFLOAT:
            kp_return (tmp ^ SIGN_BIT);
#else
          case typecode::BIGINT:
            return (neg_I (interp, tmp));
          case typecode::FLOAT:
            return (neg_f (interp, tmp));
          case typecode::BIGFLOAT:
            return (neg_F (interp, tmp));
#endif
          // XXX: Custom types.
          default:
            return (invalid_arg (interp, "-"));
        }
    }

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    { *rv = KP_TRY (sub (interp, *rv, argv[i])); }

  kp_return (*rv);
}

// (* [...args])
DEFBUILTIN (mul_fct)
{
  if (argc == 0)
    kp_return (fixint (1));

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    { *rv = KP_TRY (mul (interp, *rv, argv[i])); }

  kp_return (*rv);
}

// (/ arg1 [...args])
DEFBUILTIN (div_fct)
{
  if (argc == 1)
    return (div (interp, fixint (1), *argv));

  valref rv (interp, *argv);
  for (int i = 1; i < argc; ++i)
    { *rv = KP_TRY (div (interp, *rv, argv[i])); }

  kp_return (*rv);
}

// (lsh x shift)
DEFBUILTIN (lsh_fct)
{
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (lsh_##suffix##i (interp, argv[0], argv[1]))

      DISPATCH (INT, i);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);

      default:
        if (bigint_p (argv[1]))
          return (interp->raise ("arith-error", "shift overflow"));
        return (invalid_arg (interp, "lsh"));
    }

#undef DISPATCH
}

// (rsh x shift)
DEFBUILTIN (rsh_fct)
{
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    return (rsh_##suffix##i (interp, argv[0], argv[1]))

      DISPATCH (INT, i);
      DISPATCH (BIGINT, I);
      DISPATCH (FLOAT, f);
      DISPATCH (BIGFLOAT, F);

      default:
        if (bigint_p (argv[1]))
          return (interp->raise ("arith-error", "shift overflow"));
        return (invalid_arg (interp, "rsh"));
    }

#undef DISPATCH
}

// (< arg1 [...args])
DEFBUILTIN (lt_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    {
      int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
      if (c >= 0)
        kp_return (NIL);
    }

  kp_return (symbol::t);
}

// (> arg1 [...args])
DEFBUILTIN (gt_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    {
      int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
      if (c <= 0)
        kp_return (NIL);
    }

  kp_return (symbol::t);
}

// (<= arg1 [...args])
DEFBUILTIN (lte_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    {
      int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
      if (c > 0)
        kp_return (NIL);
    }

  kp_return (symbol::t);
}

// (>= arg1 [...args])
DEFBUILTIN (gte_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    {
      int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
      if (c < 0)
        kp_return (NIL);
    }

  kp_return (symbol::t);
}

// (!= arg1 [...args])
DEFBUILTIN (ne_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    {
      int c = KP_TRY (xcmp (interp, argv[i], argv[i + 1]));
      if (c == 0)
        kp_return (NIL);
    }

  kp_return (symbol::t);
}

// (nputcar val lst)
static DEFBUILTIN (nputcar_fct)
{
  cons *cnp = as<cons> (argv[1]);
  if (!cnp || cnp == as_cons (NIL))
    return (interp->raise ("type-error", "value is not a cons"));

  return (nputcar (interp, cnp->as_obj (), argv[0]));
}

// (nputcdr val lst)
static DEFBUILTIN (nputcdr_fct)
{
  cons *cnp = as<cons> (argv[1]);
  if (!cnp || cnp == as_cons (NIL))
    return (interp->raise ("type-error", "value is not a cons"));

  return (nputcdr (interp, cnp->as_obj (), argv[0]));
}

// (is x y)
static DEFBUILTIN (is_fct)
{
  kp_return (argv[0] == argv[1] ? symbol::t : NIL);
}

// (= x y [...args])
static DEFBUILTIN (eq_fct)
{
  for (int i = 0; i < argc - 1; ++i)
    {
      bool rv = KP_TRY (equal (interp, argv[i], argv[i + 1]));
      if (!rv)
        kp_return (NIL);
    }

  kp_return (symbol::t);
}

// (array [...args])
DEFBUILTIN (array_fct)
{
  object ret = KP_TRY (alloc_array (interp, argc));
  copy_objs (&xaref(ret, 0), argv, argc);
  kp_return (ret);
}

// (tuple test_fn [...args])
DEFBUILTIN (tuple_fct)
{
  valref ret = KP_TRY (alloc_tuple (interp, *argv));

  for (int i = 1; i < argc; ++i)
    KP_VTRY (tuple_put (interp, *ret, argv[i], false));

  kp_return (*ret);
}

// (%putd symbol code definition)
DEFBUILTIN (p_putd)
{
  if (!fixint_p (argv[1]))
    return (interp->raise ("type-error", "second argument must be an integer"));
  else if (!symbol_p (*argv))
    return (interp->raise ("type-error", "first argument must be a symbol"));
  else if (as_symbol(*argv)->flagged_p (FLAGS_CONST))
    return (interp->raise ("const-error", "cannot assign to a constant"));

  uint32_t eflags = 0;
  int type = as_int (argv[1]);

  switch (type)
    {
      case 0:  // function.
      case 5:  // regular symbol.
        break;

      case 6:   // literal.
        eflags |= symbol::literal_flag;
        // FALLTHROUGH.

      case 1:   // constant.
        eflags |= FLAGS_CONST;
        break;

      case 2:   // special variable.
        eflags |= symbol::special_flag;
        break;

      case 3:   // macro.
        eflags |= symbol::ctv_flag;
        break;

      case 4:   // alias.
        eflags |= symbol::alias_flag;
        break;

      default:
        return (interp->raise ("arg-error", "invalid code specified"));
    }

  if (type == 0 || type == 3)
    {
      function *fp = as<function> (argv[2]);
      if (!fp)
        return (interp->raise ("type-error", "argument must be a function"));

      if (nil_p (fp->name))
        // Mutate the argument and set the name.
        fp->name = *argv;
      else
        { // Copy the function with the new name.
          KP_VTRY (alloc_fct (interp));
          function *f2 = as_fct (interp->alval);
          fp->copy_into (f2);
          f2->name = *argv;
          argv[2] = f2->as_obj ();
        }
    }

  symval(*argv) = argv[2];
  if (eflags)
    {
      symbol *sp = as_symbol (*argv);
      sp->cas_flag (symbol::special_flag | symbol::ctv_flag |
                    symbol::alias_flag, eflags);
      if ((eflags & symbol::special_flag) && !sp->tl_idx)
        { sp->tl_idx = KP_TRY (symbol::alloc_tl_idx (interp)); }
    }

  kp_return (argv[2]);
}

static inline object
strm_out (interpreter *interp)
{
  object obj = find_sym (interp, "*out*", 5);
  return (symbol_p (obj) ? symval (interp, obj) : out_stream);
}

static result<object>
print_helper (interpreter *interp, object strm,
  object *argv, int argc, bool nl)
{
  stream *out = as<stream> (strm);
  stream_guard sg { interp, nullptr };
  auto lg = KP_TRY (lock_guard::make (interp));

  if (out)
    ;
  else if (string *sp = as<string> (strm))
    {
      *sg = out = KP_TRY (strstream (interp, sp->as_obj (),
                                     STRM_WRITE | STRM_APP | STRM_NOLOCK));
    }
  else
    return (interp->raise ("type-error",
                           "output argument must be a string or stream"));

  if (!singlethr_p () && !sg.strmp)
    KP_VTRY (lg.set (as_lock (out->ilock)));

  io_info info { io_info::FLG_RAW };
  interp->retval = symbol::t;

  for (int i = 0; i < argc; ++i)
    {
      int64_t rv = KP_TRY (xwrite (interp, out, argv[i], info));
      if (rv < 0)
        {
          interp->retval = NIL;
          break;
        }
    }

  if (nl && !nil_p (interp->retval))
    {
      int b = KP_TRY (out->putb (interp, '\n'));
      if (b < 0)
        interp->retval = NIL;
    }

  if (sg.strmp)
    KP_VTRY (sstream_get (interp, sg.strmp));

  return (interp->retval);
}

// (print-to stream arg1 [...args])
static DEFBUILTIN (print_to_fct)
{
  return (print_helper (interp, *argv, argv + 1, argc - 1, false));
}

// (say-to stream [...args])
static DEFBUILTIN (say_to_fct)
{
  return (print_helper (interp, *argv, argv + 1, argc - 1, true));
}

// (print arg1 [...args])
static DEFBUILTIN (print_fct)
{
  return (print_helper (interp, strm_out (interp), argv, argc, false));
}

// (say [...args])
static DEFBUILTIN (say_fct)
{
  return (print_helper (interp, strm_out (interp), argv, argc, true));
}

// (copy obj [deep])
static DEFBUILTIN (copy_fct)
{
  return (copy (interp, *argv, argc == 2 && !nil_p (argv[1])));
}

// (reverse obj)
DEFBUILTIN (reverse_fct)
{
  object ret;

  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (reverse_##suffix (interp, *argv));   \
    return (ret)

      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (CONS, L);
      default:
        return (invalid_arg (interp, "reverse"));
#undef DISPATCH
    }
}

// (nreverse obj)
DEFBUILTIN (nreverse_fct)
{
  object ret;

  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (nreverse_##suffix (interp, *argv));   \
    return (ret)

      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (CONS, L);
      default:
        return (invalid_arg (interp, "nreverse"));
#undef DISPATCH
    }
}

// (nput sequence key value)
DEFBUILTIN (nput_fct)
{
  object ret;

  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (nput_##suffix (interp, argv[0], argv[1], argv[2]));   \
    return (ret)

      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (CONS, L);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (PKG, P);
      DISPATCH (INSTANCE, w);
      default:
        return (invalid_arg (interp, "nput"));

#undef DISPATCH
    }
}

// (disasm function [stream])
static DEFBUILTIN (disasm_fct)
{
  object out;
  bool allocated = false;

  if (argc < 2)
    {
      out = strm_out (interp);
      if (str_p (out))
        {
          auto tmp = KP_TRY (strstream (interp, out, STRM_WRITE |
                                        STRM_APP | STRM_NOLOCK));
          out = tmp->as_obj ();
          allocated = true;
        }
    }
  else
    out = argv[1];

  KP_VTRY (disasm (interp, *argv, out));

  if (allocated)
    {
      stream *ostr = as_stream (out);
      KP_VTRY (sstream_get (interp, ostr));
      deref (ostr->close (interp));
    }
  else
    interp->retval = symbol::t;

  return (interp->retval);
}

// (not obj)
static DEFBUILTIN (not_fct)
{
  kp_return (nil_p (*argv) ? *argv : symbol::t);
}

// (len obj)
static DEFBUILTIN (len_fct)
{
  interp->retval = KP_TRY (length (interp, *argv));
  return (interp->retval);
}

struct custom_comparator : public comparator
{
  object cb;

  custom_comparator (interpreter *ip, object obj) : comparator (ip), cb (obj)
    {
    }

  result<bool> operator() (object x, object y)
    {
      KP_VTRY (this->interp->growstk (3));
      *this->interp->stkend++ = this->cb;
      *this->interp->stkend++ = x;
      *this->interp->stkend++ = y;
      KP_VTRY (call_n (this->interp, 2));
      return (interp->retval != NIL);
    }
};

// (nsort seq [comparison])
DEFBUILTIN (nsort_fct)
{
  lazy<comparator> c1;
  lazy<custom_comparator> c2;
  comparator *cx;

  if (argc == 1)
    cx = new (c1.ptr ()) comparator (interp);
  else
    cx = new (c2.ptr ()) custom_comparator (interp, argv[1]);

  switch (itype (*argv))
    {
      case typecode::CONS:
        KP_VTRY (nsort_L (interp, *argv, *cx));
      case typecode::ARRAY:
        KP_VTRY (nsort_a (interp, *argv, *cx));
      case typecode::TUPLE:
        kp_return (*argv);
      default:
        return (invalid_arg (interp, "nsort"));
    }

  return (interp->retval);
}

// (subseq seq arg-1 [arg-2])
DEFBUILTIN (subseq_fct)
{
  object i2 = argc == 3 ? argv[2] : UNBOUND, ret;
  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (subseq_##suffix (interp, argv[0], argv[1], i2));   \
    return (ret)

      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      default:
        return (invalid_arg (interp, "subseq"));

#undef DISPATCH
    }
}

// (concat [...args])
DEFBUILTIN (concat_fct)
{
  if (argc == 0)
    kp_return (NIL);

  object ret;

  switch (itype (*argv))
    {
#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (concat_##suffix (interp, argv, argc));   \
    return (ret)

      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      default:
        return (invalid_arg (interp, "concat"));

#undef DISPATCH
    }
}

// (nrevconc obj)
static DEFBUILTIN (nrevconc_fct)
{
  return (nrevconc (interp, *argv, argv[1]));
}

// (load path)
DEFBUILTIN (load_fct)
{
  object path = *argv;
  if (!str_p (path))
    return (interp->raise ("type-error", "path must be a string"));

  auto fptr = KP_TRY (fstream_open (interp, str_cdata (path), "r"));
  if (!fptr)
    // XXX: Report why the file couldn't be opened.
    return (interp->raise ("load-error",
                           KP_SPRINTF (interp,
                                       "could not open file '%Q'", path)));

  stream_guard sg { interp, fptr };
  reader rd (interp, sg.as_obj ());

  while (true)
    {
      object expr = KP_TRY (rd.read_sexpr ());
      if (expr == EOS)
        break;

      KP_VTRY (eval (interp, expr));
    }

  kp_return (symbol::t);
}

// (macroexp-1 expr)
static DEFBUILTIN (macroexp_1_fct)
{
  return (macroexp_1 (interp, *argv));
}

// (macroexp expr)
static DEFBUILTIN (macroexp_fct)
{
  return (macroexp (interp, *argv));
}

// (coro-val coroutine)
static DEFBUILTIN (coro_val)
{
  auto cnp = as<coroutine> (*argv);
  if (!cnp)
    return (interp->raise ("type-error", "argument must be a coroutine"));

  kp_return (cnp->value);
}

// (symname symbol)
static DEFBUILTIN (symname_fct)
{
  symbol *sym = as<symbol> (*argv);
  if (!sym)
    return (interp->raise ("type-error", "argument must be a symbol"));

  kp_return (sym->name);
}

// (symval symbol [default-value])
static DEFBUILTIN (symval_fct)
{
  symbol *sym = as<symbol> (*argv);
  if (!sym)
    return (interp->raise ("type-error", "first argument must be a symbol"));

  object ret = sym->value;
  if (ret != UNBOUND)
    kp_return (ret);
  else if (argc == 2)
    kp_return (argv[1]);
  else
    return (interp->raise ("unbound-error",
                           KP_SPRINTF (interp, "symbol %Q has no value",
                                       sym->as_obj ())));
}

// (sympkg symbol)
static DEFBUILTIN (sympkg_fct)
{
  symbol *sym = as<symbol> (*argv);
  if (!sym)
    return (interp->raise ("type-error", "argument must be a symbol or nil"));

  kp_return (sym->pkg);
}

// (%use name (:as alias) (:pull (:all symbols...)))
static DEFBUILTIN (p_use_fct)
{
  object a1 = argc < 2 ? NIL : argv[1];
  object a2 = argc < 3 ? NIL : argv[2];
  return (pull_pkg (interp, *argv, a1, a2));
}

// (%gc)
static DEFBUILTIN (p_gc)
{
  KP_VTRY (gc (false));
  kp_return (NIL);
}

// (%iter sequence token [advance])
static DEFBUILTIN (p_iter)
{
  object token = argc < 2 ? UNBOUND : argv[1], ret;
  bool adv = argc == 3 && !nil_p (argv[2]);

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (iter_##suffix (interp, *argv, token, adv));   \
    return (ret)

  switch (itype (*argv))
    {
      DISPATCH (ARRAY, a);
      DISPATCH (CONS, L);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      default:
        // XXX: Custom types
        return (invalid_arg (interp, "%iter"));
    }

#undef DISPATCH
}

// (macro-fct symbol)
static DEFBUILTIN (macro_fct)
{
  object sym = *argv;
  if (!symbol_p (sym))
    return (interp->raise ("type-error", "argument must be a symbol"));
  else if (!as_symbol(sym)->flagged_p (symbol::ctv_flag))
    kp_return (NIL);

  sym = symval (sym);
  kp_return (fct_p (sym) ? sym : NIL);
}

// (nzap sequence key flags fn [...args])
DEFBUILTIN (nzap_fct)
{
  uint32_t flags = (fixint_p (argv[2]) ? as_int (argv[2]) : 0) |
                    (singlethr_p () ? NZAP_NOMT : 0);

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    KP_VTRY (nzap_##suffix (interp, argv[0], argv[1], flags,   \
                            argv[3], &argv[4], argc - 4));   \
    return (interp->retval)

  switch (itype (*argv))
    {
      DISPATCH (ARRAY, a);
      DISPATCH (CONS, L);
      DISPATCH (TABLE, u);
      DISPATCH (TUPLE, o);
      DISPATCH (PKG, P);
      default:
        return (invalid_arg (interp, "nzap"));
    }

#undef DISPATCH
}

// (intern string [package])
static DEFBUILTIN (intern_fct)
{
  string *name = as<string> (*argv);
  if (!name)
    return (interp->raise ("type-error", "first argument must be a string"));

  package *p = nullptr;
  if (argc == 1)
    ;
  else if (!(p = as<package> (argv[1])))
    return (interp->raise ("type-error", "second argument must be a package"));

  return (intern (interp, name, p));
}

// (fct-name function)
static DEFBUILTIN (fct_name_fct)
{
  object fn = *argv;
  if (!fct_p (fn))
    return (interp->raise ("type-error", "argument must be a function"));

  kp_return (fct_name (fn));
}

// (type object [parents slot-definitions])
static DEFBUILTIN (type_fct)
{
  if (argc == 1)
    kp_return (type (argv[0]));
  else if (argc == 2)
    return (type (interp, argv[0], argv[1], NIL));
  else
    return (type (interp, argv[0], argv[1], argv[2]));
}

// (make type [...args])
DEFBUILTIN (make_fct)
{
  KP_VTRY (alloc_inst (interp, *argv, argv + 1, argc - 1));
  kp_return (interp->alval);
}

// (isa object type1 [...types])
static DEFBUILTIN (isa_fct)
{
  for (int i = 1; i < argc; ++i)
    {
      int rv = instanceof (*argv, argv[i]);
      if (rv < 0)
        return (interp->raise ("type-error", "argument must be a typespec"));
      else if (rv)
        kp_return (symbol::t);
    }

  kp_return (NIL);
}

// (%symtst symbol code)
static DEFBUILTIN (p_symtst)
{
  int code;
  const symbol *sym = as<symbol> (*argv);

  if (!sym)
    return (interp->raise ("type-error", "first argument must be a symbol"));
  else if (!as<int> (argv[1], code))
    return (interp->raise ("type-error", "second argument must be an integer"));
  else if (code == 6)
    kp_return (sym->value != UNBOUND &&
      !sym->flagged_p (symbol::ctv_flag | symbol::alias_flag) ?
        symbol::t : NIL);

  const uint32_t flags[] =
    {
      FLAGS_CONST,
      symbol::specform_flag,
      symbol::special_flag,
      symbol::ctv_flag,
      symbol::alias_flag,
      symbol::literal_flag
    };

  if (code < 0 || code >= (int)KP_NELEM (flags))
    return (interp->raise ("arg-error", "invalid code"));

  kp_return (sym->flagged_p (flags[code]) ? symbol::t : NIL);
}

// (last sequence)
static DEFBUILTIN (last_fct)
{
  object obj = *argv, ret;

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (last_##suffix (interp, obj));   \
    return (ret)

  switch (itype (obj))
    {
      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      default:
        return (invalid_arg (interp, "last"));
    }

#undef DISPATCH
}

// (last-err [include-traceback])
static DEFBUILTIN (last_err_fct)
{
  if (argc == 1 && !nil_p (*argv) && !nil_p (interp->last_err))
    {
      object ret = KP_TRY (alloc_cons (interp, 2));
      xcar(ret) = interp->last_err;
      xcar(xcdr (ret)) = interp->last_tb;
      kp_return (ret);
    }

  kp_return (interp->last_err);
}

static DEFBUILTIN (find_fct)
{
  object obj = argv[0], key = argv[1], ret;
  object start = UNBOUND, end = UNBOUND, test = UNBOUND;

  KP_VTRY (kwargs_parse (interp, argv + 2, argc - 2, "start", &start,
                         "end", &end, "test", &test));

#define DISPATCH(type, suffix)   \
  case typecode::type:   \
    ret = KP_TRY (find_##suffix (interp, obj, key, start, end, test));   \
    return (ret)

  switch (itype (obj))
    {
      DISPATCH (CONS, L);
      DISPATCH (ARRAY, a);
      DISPATCH (BVECTOR, b);
      DISPATCH (STR, s);
      default:
        return (invalid_arg (interp, "find"));
    }

#undef DISPATCH
}

// Names for the builtins.
static const char BUILTIN_NAMES[] =
  "car\0"
  "cdr\0"
  "cons\0"
  "list\0"
  "list*\0"
  "+\0-\0*\0/\0"
  "<\0>\0<=\0>=\0!=\0"
  "lsh\0"
  "rsh\0"
  "nputcar\0"
  "nputcdr\0"
  "apply\0"
  "is\0=\0"
  "array\0"
  "table\0"
  "tuple\0"
  "%putd\0"
  "gensym\0"
  "print-to\0"
  "say-to\0"
  "print\0"
  "say\0"
  "copy\0"
  "reverse\0"
  "nreverse\0"
  "nput\0"
  "disasm\0"
  "not\0"
  "len\0"
  "%fmt-str\0"
  "nsort\0"
  "subseq\0"
  "concat\0"
  "nconcat\0"
  "nrevconc\0"
  "load\0"
  "macroexp-1\0"
  "macroexp\0"
  "coro-val\0"
  "coro-next\0"
  "symname\0"
  "symval\0"
  "sympkg\0"
  "%use\0"
  "%gc\0"
  "%iter\0"
  "exit\0"
  "macro-fct\0"
  "nzap\0"
  "intern\0"
  "fct-name\0"
  "type\0"
  "make\0"
  "isa\0"
  "%symtst\0"
  "last\0"
  "last-err\0"
  "%meth-ctl\0"
  "find\0"
;

// List of builtins.

struct builtin_entry
{
  native_function::fn_type fn;
  int8_t min_argc;
  int8_t max_argc;
};

static const builtin_entry BUILTINS[] =
{
  { car_fct, 1, 1 },
  { cdr_fct, 1, 1 },
  { cons_fct, 2, 2 },
  { list_fct, 0, -1 },
  { list_star, 1, -1 },
  { add_fct, 0, -1 },
  { sub_fct, 1, -1 },
  { mul_fct, 0, -1 },
  { div_fct, 0, -1 },
  { lt_fct, 1, -1 },
  { gt_fct, 1, -1 },
  { lte_fct, 1, -1 },
  { gte_fct, 1, -1 },
  { ne_fct, 1, -1 },
  { lsh_fct, 2, 2 },
  { rsh_fct, 2, 2 },
  { nputcar_fct, 2, 2 },
  { nputcdr_fct, 2, 2 },
  { apply_fct, 2, -1 },
  { is_fct, 2, 2 },
  { eq_fct, 2, -1 },
  { array_fct, 0, -1 },
  { table_fct, 2, -1 },
  { tuple_fct, 1, -1 },
  { p_putd, 3, 3 },
  { gensym, 0, 0 },
  { print_to_fct, 2, -1 },
  { say_to_fct, 1, -1 },
  { print_fct, 1, -1 },
  { say_fct, 0, -1 },
  { copy_fct, 1, 2 },
  { reverse_fct, 1, 1 },
  { nreverse_fct, 1, 1 },
  { nput_fct, 3, 3 },
  { disasm_fct, 1, 2 },
  { not_fct, 1, 1 },
  { len_fct, 1, 1 },
  { p_fmt_str, 1, -1 },
  { nsort_fct, 1, 2 },
  { subseq_fct, 2, 3 },
  { concat_fct, 0, -1 },
  { nconcat, 0, -1 },
  { nrevconc_fct, 2, 2 },
  { load_fct, 1, 1 },
  { macroexp_1_fct, 1, 1 },
  { macroexp_fct, 1, 1 },
  { coro_val, 1, 1 },
  { coro_next, 1, 2 },
  { symname_fct, 1, 1 },
  { symval_fct, 1, 2 },
  { sympkg_fct, 1, 1 },
  { p_use_fct, 1, 3 },
  { p_gc, 0, -1 },
  { p_iter, 1, 3 },
  { exit_fct, 0, 1 },
  { macro_fct, 1, 1 },
  { nzap_fct, 4, -1 },
  { intern_fct, 1, 2 },
  { fct_name_fct, 1, 1 },
  { type_fct, 1, 3 },
  { make_fct, 1, -1 },
  { isa_fct, 2, -1 },
  { p_symtst, 2, 2 },
  { last_fct, 1, 1 },
  { last_err_fct, 0, 1 },
  { p_meth_ctl, 1, -1 },
  { find_fct, 2, 6 },
};

static native_function global_builtins[KP_NELEM (BUILTINS)];
object symbol::fast_global_syms[KP_NELEM (BUILTINS) + symbol::N_SPECFORMS + 1];

indexer_t index_seq (object seq)
{
  switch (itype (seq))
    {
      case typecode::CONS:
        return (get_L);
      case typecode::ARRAY:
        return (get_a);
      case typecode::BVECTOR:
        return (get_b);
      case typecode::STR:
        return (get_s);
      case typecode::TABLE:
        return (get_u);
      case typecode::TUPLE:
        return (get_o);
      case typecode::PKG:
        return (get_P);
      case typecode::INSTANCE:
        return (get_w);
      default:
        return (nullptr);
    }
}

builtin_iter::builtin_iter () : curp (BUILTIN_NAMES)
{
}

void builtin_iter::adv ()
{
  this->curp += strlen (this->curp) + 1;
}

bool builtin_iter::valid () const
{
  return (*this->curp != 0);
}

int builtin_idx (interpreter *interp, const char *name)
{
  int ix = 0;
  for (builtin_iter it; it.valid (); it.adv (), ++ix)
    if (strcmp (it.name (), name) == 0)
      return (ix + symbol::N_SPECFORMS);

  return (-1);
}

object builtin_fct (interpreter *interp, const char *name)
{
  int ix = builtin_idx (interp, name) - symbol::N_SPECFORMS;
  return (ix < 0 ? UNBOUND : global_builtins[ix].as_obj ());
}

object builtin_fct (interpreter *interp, int ix)
{
  return (ix < 0 || ix >= (int)KP_NELEM (BUILTINS) ?
          UNBOUND : global_builtins[ix].as_obj ());
}

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

  int ix = 0;

  for (builtin_iter it; it.valid (); it.adv (), ++ix)
    {
      auto *outp = ensure_mask (&global_builtins[ix]);

      outp->vo_full = function_base::native_flag;
      outp->vo_type = typecode::FCT;
      outp->fct = BUILTINS[ix].fn;
      outp->min_argc = BUILTINS[ix].min_argc;
      outp->max_argc = BUILTINS[ix].max_argc;

      auto rs = INTERN_N (it.name ());
      if (rs.error_p ())
        return (init_op::result_failed);

      object sym = outp->name = *rs;
      symval(sym) = outp->as_obj ();
      symbol::fast_global_syms[ix + symbol::N_SPECFORMS] = sym;
    }

  // Mark the end of the builtin symbols.
  symbol::fast_global_syms[KP_NELEM (BUILTINS) + symbol::N_SPECFORMS] = UNBOUND;
  return (ret);
}

init_op init_builtins (do_init_builtins, "builtins");

#undef INTERN
#undef INTERN_N

KP_DECLS_END