khipu/types.cpp

/* Definitions for the type system interface.

   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"
#include "utils/sorted_list.hpp"

KP_DECLS_BEGIN

#define TYPE(name)   \
  static object name##_type

// builtin types.
TYPE (typespec);
TYPE (int);
TYPE (char);
TYPE (cons);
TYPE (float);
TYPE (bvector);
TYPE (str);
TYPE (array);
TYPE (table);
TYPE (tuple);
TYPE (stream);
TYPE (symbol);
TYPE (fct);
TYPE (coro);
TYPE (thread);
TYPE (pkg);

#undef TYPE

// Offsets into a typespec definition.
enum
{
  TSPEC_NAME,
  TSPEC_PARENTS,
  TSPEC_SLOTDEFS,
  TSPEC_NSLOTS,
  TSPEC_SHARED,
  TSPEC_NUM_MEMBERS
};

static inline object&
tspec_name (object ts)
{
  return (xaref (as_instance(ts)->tspec, TSPEC_NAME));
}

static inline object&
tspec_parents (object ts)
{
  return (xaref (as_instance(ts)->tspec, TSPEC_PARENTS));
}

static inline object&
tspec_slotdefs (object ts)
{
  return (xaref (as_instance(ts)->tspec, TSPEC_SLOTDEFS));
}

static inline object&
tspec_nslots (object ts)
{
  return (xaref (as_instance(ts)->tspec, TSPEC_NSLOTS));
}

static inline object&
tspec_shared (object ts)
{
  return (xaref (as_instance(ts)->tspec, TSPEC_SHARED));
}

// Offsets into a slot definition.
enum
{
  SLOTDEF_NAME,
  SLOTDEF_TYPE,
  SLOTDEF_INIT,
  SLOTDEF_FLAGS,
  SLOTDEF_PROPS,
  SLOTDEF_INDEX,
  SLOTDEF_NUM_MEMBERS
};

// Slot definition flags.
enum
{
  SLOTDEF_SHARED_FLG = 0x1,
  SLOTDEF_GETTER_FLG = 0x2,
  SLOTDEF_CONST_FLG = 0x4
};

static inline object&
slotdef_name (object slotdef)
{
  return (xaref (slotdef, SLOTDEF_NAME));
}

static inline object&
slotdef_type (object slotdef)
{
  return (xaref (slotdef, SLOTDEF_TYPE));
}

static inline object&
slotdef_init (object slotdef)
{
  return (xaref (slotdef, SLOTDEF_INIT));
}

static inline object&
slotdef_flags (object slotdef)
{
  return (xaref (slotdef, SLOTDEF_FLAGS));
}

static inline object&
slotdef_props (object slotdef)
{
  return (xaref (slotdef, SLOTDEF_PROPS));
}

static inline object&
slotdef_index (object slotdef)
{
  return (xaref (slotdef, SLOTDEF_INDEX));
}

struct slot_cmp
{
  int operator() (intptr_t left, intptr_t right) const
    {
      return ((intptr_t)slotdef_name (left) - (intptr_t)slotdef_name (right));
    }
};

typedef sorted_list<slot_cmp> slotname_list_t;

static result<int>
add_slot_names (interpreter *interp, object tx,
                slotname_list_t& lst, uint32_t idx)
{
  const array *sp = as_array (tspec_slotdefs (tx));
  for (uint32_t i = 0; i < sp->len; ++i)
    if (sp->data[i] != fixint (0) &&
        !lst.add (sp->data[i], idx))
      return (interp->raise ("arg-error",
                             KP_SPRINTF (interp, "got repeated slot: %Q",
                                         slotdef_name (sp->data[i]))));

  return (0);
}

static result<object>
sorted_list_toarray (interpreter *interp, sorted_list_base& lst)
{
  object ret = KP_TRY (alloc_array (interp, lst.len ()));
  uint32_t ix = 0;

  for (sorted_list_base::iterator it (lst); it.valid (); ++it)
    xaref(ret, ix++) = it.key ();

  return (ret);
}

static inline int
slot_spec_index (const string *sp)
{
  if (sp->nbytes != 4)
    return (-1);
  else if (memcmp (sp->data, "type", 4) == 0)
    return (SLOTDEF_TYPE);
  else if (memcmp (sp->data, "init", 4) == 0)
    return (SLOTDEF_INIT);

  return (-1);
}

static inline result<int>
parse_slotdef (interpreter *interp, object slotdef,
               object elem, object val, uintptr_t& xflags)
{
  const string *sp = as_str (symname (elem));
  int idx = slot_spec_index (sp);
  if (idx >= 0)
    {
      if (idx == SLOTDEF_INIT)
        xflags |= instance::init_flag;

      xaref(slotdef, idx) = val;
    }
  else if (sp->nbytes == 6 && (*sp->data == 'g' || *sp->data == 's') &&
           memcmp (sp->data + 1, "etter", 5) == 0)
    {
      object *p = &xaref(slotdef, SLOTDEF_PROPS);
      if (*p == UNBOUND)
        { *p = KP_TRY (alloc_array (interp, 2)); }

      xaref(*p, *sp->data != 'g') = val;
      xaref(slotdef, SLOTDEF_FLAGS) |= fixint (SLOTDEF_GETTER_FLG);
    }
  else if (sp->nbytes == 6 && memcmp (sp->data, "shared", 6) == 0 && val != NIL)
    xaref(slotdef, SLOTDEF_FLAGS) |= fixint (SLOTDEF_SHARED_FLG);
  else if (sp->nbytes == 5 && memcmp (sp->data, "const", 6) == 0 && val != NIL)
    xaref(slotdef, SLOTDEF_FLAGS) |= fixint (SLOTDEF_CONST_FLG);
  else
    return (interp->raise ("arg-error",
                           KP_SPRINTF (interp,
                                       "'%Q' is not a valid slot specification",
                                       elem)));
  return (0);
}

static inline result<uintptr_t>
validate_slotdef (interpreter *interp, object slotdef, uintptr_t& xflags)
{
  object *ptr = &slotdef_name(slotdef);
  if (!nksymbol_p (*ptr))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp,
                                       "expected a symbol as slot name, got %Q",
                                       *ptr)));

  // Store slot name as a keyword if it's not uninterned
  if (!nil_p (sympkg (*ptr)))
    { *ptr = KP_TRY (symbol::make_kword (interp, symname (*ptr))); }

  // Verify slot initializer.
  ptr = &slotdef_init(slotdef);
  if (*ptr == UNBOUND)
    ;
  else if (!fct_p (*ptr))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "expected a function as slot "
                                               "initializer, got %Q", *ptr)));
  else if (slotdef_flags (slotdef) & fixint (SLOTDEF_SHARED_FLG))
    xflags &= ~instance::init_flag;

  // Verify slot type.
  ptr = &slotdef_type(slotdef);
  if (*ptr != UNBOUND && !typespec_p (*ptr))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "expected a typespec as slot "
                                               "type, got %Q", *ptr)));

  // Verify getter and setter.
  ptr = &slotdef_props(slotdef);
  if (*ptr != UNBOUND)
    {
      ptr = &xaref(*ptr, 0);
      if ((*ptr != UNBOUND && !fct_p (*ptr)) ||
          (*++ptr != UNBOUND && !fct_p (*ptr)))
        return (interp->raise ("type-error",
                               KP_SPRINTF (interp, "expected a function as "
                                                   "getter/setter, got %Q",
                                                   *ptr)));
    }

  return (xflags);
}

static inline void
init_local_slotdef (object slotdef)
{
  slotdef_type(slotdef) = slotdef_init(slotdef) =
    slotdef_props(slotdef) = UNBOUND;
  slotdef_name(slotdef) = slotdef_flags(slotdef) = fixint (0);
  slotdef_index(slotdef) = fixint (-1);
}

static inline uint32_t
hash_slot_name (interpreter *interp, object name)
{
  uint32_t ret = hash_s (interp, symname (name));
  if (kp_unlikely (nil_p (sympkg (name))))
    ret = ~ret;

  return (ret);
}

static uint32_t
slots_insert (interpreter *interp, object sdef, object *ptr, uint32_t size)
{
  uint32_t pos = hash_slot_name (interp, slotdef_name (sdef)) & (size - 1);
  uint32_t probe = 1;

  while (true)
    {
      if (ptr[pos] == fixint (0))
        {
          ptr[pos] = sdef;
          return (pos);
        }

      pos = (pos + probe++) & (size - 1);
    }
}

static result<object>
make_slotdefs (interpreter *interp, object slotdefs,
               slotname_list_t& lst, uintptr_t& xflags, object ts)
{
  valref cur (interp), elem (interp), ar (interp, NIL);
  local_varobj<array> lsdef;
  object space[SLOTDEF_NUM_MEMBERS];

  lsdef.local_init (space, KP_NELEM (space));
  valref local_sd (interp, lsdef.as_obj ());

  for (cons::iterator sd { interp, slotdefs }; sd.valid (); ++sd)
    {
      init_local_slotdef (*local_sd);
      uintptr_t lf = 0;

      *cur = *sd;
      if (nksymbol_p (*cur))
        {
          auto& ld = slotdef_name (*local_sd);
          ld = KP_TRY (nil_p (sympkg (*cur)) ?
                       *cur : symbol::make_kword (interp, symname (*cur)));
        }
      else if (xcons_p (*cur))
        {
          cons::iterator sub { interp, *cur };
          slotdef_name(*local_sd) = *sub;

          while ((++sub).valid ())
            {
              *elem = *sub;
              if (!keyword_p (*elem))
                return (interp->raise ("type-error",
                                       KP_SPRINTF (interp, "slot option must be"
                                                           " a keyword, got %Q",
                                                           *elem)));
              else if (!(++sub).valid ())
                return (interp->raise ("arg-error",
                                       "slot options must come in pairs"));

              KP_VTRY (parse_slotdef (interp, *local_sd, *elem, *sub, lf));
            }

          xflags |= KP_TRY (validate_slotdef (interp, *local_sd, lf));
        }
      else
        return (interp->raise ("type-error",
                               KP_SPRINTF (interp, "expected a symbol or cons "
                                                   "for the slot, got %Q",
                                                   *cur)));

      *elem = KP_TRY (alloc_array (interp, SLOTDEF_NUM_MEMBERS));
      copy_objs (&xaref(*elem, 0), lsdef.data, lsdef.len);
      slotdef_index(*elem) = *ar;

      if (!lst.add (*elem, 0))
        return (interp->raise ("arg-error",
                               KP_SPRINTF (interp, "got repeated slot: %Q",
                                           slotdef_name (*local_sd))));

      *ar = *elem;
    }

  if (!lst.len ())
    kp_return (deref (alloc_array (interp, 0)));

  uint32_t size = upsize (lst.len () + 1), ix = 0, nshared = 0;
  *cur = KP_TRY (alloc_array (interp, size, fixint (0)));

  object *ptr = &xaref(*cur, 0);
  for (slotname_list_t::iterator it (lst); it.valid (); ++it)
    {
      object tmp = it.key ();
      if (fixint_p (slotdef_index (tmp)))
        { // This slot comes from a parent type.
          tmp = KP_TRY (copy_a (interp, tmp, false));
          *elem = tmp;
        }

      slots_insert (interp, tmp, ptr, size);
      if (slotdef_flags (tmp) & fixint (SLOTDEF_SHARED_FLG))
        {
          ++nshared;
          if (fixint_p (slotdef_index (tmp)))
            { // Inherited shared slot.
              int ipos = as_int (slotdef_index (tmp)) & 0x3fff;
              slotdef_index(tmp) = fixint (ipos | (it.val () << 14));
            }
        }
      else
        slotdef_index(tmp) = slotdef_flags (tmp) & fixint (SLOTDEF_GETTER_FLG) ?
                                                   NIL : fixint (ix++);
    }

  if (nshared)
    {
      nshared = nshared < 4 ? 4 : upsize (nshared);
      object sh = KP_TRY (alloc_array (interp, nshared, fixint (0)));
      xaref(ts, TSPEC_SHARED) = sh;

      for (uint32_t j = 0; j < len_a (*cur); ++j)
        {
          object tmp = ptr[j];
          if (tmp == fixint (0) ||
              !(slotdef_flags (tmp) & fixint (SLOTDEF_SHARED_FLG)))
            continue;

          *elem = KP_TRY (copy_a (interp, tmp, false));
          auto off = slots_insert (interp, *elem, &xaref(sh, 0), nshared);

          if (!fixint_p (slotdef_index (tmp)))
            { // A shared slot that belongs to this type.
              slotdef_index(tmp) = fixint (off);
              slotdef_index(*elem) = UNBOUND;
              slotdef_flags(*elem) &= ~fixint (SLOTDEF_SHARED_FLG);
              if (slotdef_init (tmp) != UNBOUND)
                xflags |= instance::ishared_flag;
            }
        }
    }
  else
    xaref(ts, TSPEC_SHARED) = deref (alloc_array (interp, 0));

  xaref(ts, TSPEC_NSLOTS) = fixint (ix);
  kp_return (*cur);
}

static inline bool
lst_addend (sorted_list<>& lst, object x)
{
  for (sorted_list<>::iterator it (lst); it.valid (); ++it)
    if ((object)it.key () == x)
      return (false);

  lst.add_end (x, 0);
  return (true);
}

static inline void
array_del_pos (array *ap, int pos)
{
  move_objs (&ap->data[pos], &ap->data[pos + 1], ap->len - pos - 1);
  --ap->len;
}

static void
insert_type (sorted_list<>& out, object obj)
{
  for (sorted_list<>::iterator it (out); it.valid (); ++it)
    {
      object ty = it.key ();
      int dist = subtype_p (ty, obj);
      if (!dist)
        continue;

      for (++it; it.valid (); ++it)
        if (subtype_p (obj, it.key ()) < dist)
          break;

      out.insert (it.link()->prev, obj, 0);
      return;
    }

  out.add_end (obj, 0);
}

static result<object>
c3_merge_aux (interpreter *interp, array *heads, sorted_list<>& out)
{
  bool found = false;
  object h1 = fixint (0);

  for (uint32_t ix = 0; ix < heads->len; ++ix)
    {
      array *ap = as_array (heads->data[ix]);
      h1 = fixint (0);
      if (!ap->len)
        continue;

      h1 = ap->data[0];

      for (uint32_t jx = 0; jx < heads->len; ++jx)
        {
          if (ix == jx)
            continue;

          array *p2 = as_array (heads->data[jx]);
          for (uint32_t kx = 1; kx < p2->len; ++kx)
            if (p2->data[kx] == h1)
              goto skip;
        }

      found = true;
      for (uint32_t jx = 0; jx < heads->len; ++jx)
        {
          array *p2 = as_array (heads->data[jx]);
          if (p2->len && p2->data[0] == h1)
            array_del_pos (p2, 0);
        }

      break;
    skip: ;
    }

  if (h1 == fixint (0))
    return (sorted_list_toarray (interp, out));
  else if (!found)
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "inconsistency in base types "
                                               "when adding %Q",
                                               tspec_name (h1))));

  insert_type (out, h1);
  return (c3_merge_aux (interp, heads, out));
}

static result<object>
c3_merge (interpreter *interp, sorted_list<>& parents)
{
  if (parents.len () == 0)
    return (alloc_array (interp, 0));
  else if (parents.len () == 1)
    return (alloc_array (interp, 1, parents.root.next->key));

  tmp_allocator ta { interp };
  object *bp = (object *)ta.alloc ((parents.len () + 1) * sizeof (*bp));

  local_varobj<array> heads;
  heads.local_init (bp, parents.len () + 1);

  memset (bp, 0, heads.len * sizeof (*bp));
  valref lheads (interp, heads.as_obj ());

  heads.data[0] = KP_TRY (sorted_list_toarray (interp, parents));
  int ix = 0;
  sorted_list<> out;

  for (sorted_list<>::iterator it (parents); it.valid (); ++it)
    {
      const array *inp = as_array (tspec_parents (it.key ()));
      KP_VTRY (alloc_array (interp, inp->len + 1, it.key ()));
      array *tp = as_array (interp->alval);

      copy_objs (&tp->data[1], inp->data, inp->len);
      heads.data[++ix] = tp->as_obj ();
    }

  object ret = KP_TRY (c3_merge_aux (interp, &heads, out));
  return (ret);
}

result<object> type (interpreter *interp, object name,
                     object parents, object slotdefs)
{
  if (!nksymbol_p (name))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "name argument must be a "
                                               "symbol, got: %Q", name)));

  sorted_list<> p;
  uintptr_t xflags = 0;
  object builtin = UNBOUND;

  if (!xcons_p (parents))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "parent types must be a list, "
                                               "got: %Q", parents)));

  for (cons::iterator it (interp, parents); it.valid (); ++it)
    {
      object px = *it;
      if (!typespec_p (px))
        return (interp->raise ("type-error", "parent must be a typespec"));
      else if (!lst_addend (p, px))
        return (interp->raise ("arg-error",
                               KP_SPRINTF (interp, "duplicate base type: %Q",
                                           tspec_name (px))));
      else if (as_instance(px)->flagged_p (instance::init_flag))
        xflags |= instance::init_flag;

      if (as_instance(px)->builtin == UNBOUND)
        ;
      else if (builtin != UNBOUND && builtin != as_instance(px)->builtin)
        return (interp->raise ("arg-error", "cannot use more than one builtin "
                                            "type as a parent"));
      else
        builtin = as_instance(px)->builtin;
    }

  auto eg = KP_TRY (evh_guard::make (interp));
  valref ts = KP_TRY (alloc_array (interp, TSPEC_NUM_MEMBERS));
  valref tmp = KP_TRY (c3_merge (interp, p));
  slotname_list_t slots;

  for (uint32_t tidx = 0; tidx < len_a (*tmp); ++tidx)
    KP_VTRY (add_slot_names (interp, xaref (*tmp, tidx), slots, tidx + 1));

  xaref(*ts, TSPEC_NAME) = name;
  xaref(*ts, TSPEC_PARENTS) = *tmp;
  xaref(*ts, TSPEC_SLOTDEFS) = KP_TRY (make_slotdefs (interp, slotdefs,
                                                      slots, xflags, *ts));

  instance *ret = alloch<instance> ();
  ret->ptype = typespec_type;
  ret->slots = deref (alloc_array (interp, 0));
  ret->tspec = *ts;
  ret->builtin = builtin;
  ret->vo_full |= xflags | (builtin != UNBOUND ? instance::init_flag : 0);

  interp->alval = ret->as_obj ();
  gc_register (interp, ret, sizeof (*ret));

  if (xflags & instance::ishared_flag)
    {
      auto shared = as_array (xaref (*ts, TSPEC_SHARED));
      *tmp = interp->alval;

      for (uint32_t tidx = 0; tidx < shared->len; ++tidx)
        {
          object tmp = shared->data[tidx];
          if (tmp == fixint (0) || slotdef_init (tmp) == UNBOUND)
            continue;

          KP_VTRY (interp->push (slotdef_init (tmp)));
          slotdef_index(tmp) = KP_TRY (call_n (interp, 0));
          deref (gc_wbarrier (interp, tmp, interp->retval));
        }

      interp->alval = *tmp;
    }

  kp_return (interp->alval);
}

object type (object obj)
{
  switch (itype (obj))
    {
#define DISPATCH_1(code, type)   \
  case typecode::code:   \
    return (type##_type)

#define DISPATCH_2(code_1, code_2, type)   \
  case typecode::code_1:   \
  DISPATCH_1 (code_2, type)

      DISPATCH_2 (INT, BIGINT, int);
      DISPATCH_1 (CHAR, char);
      DISPATCH_1 (CONS, cons);
      DISPATCH_2 (FLOAT, BIGFLOAT, float);
      DISPATCH_1 (BVECTOR, bvector);
      DISPATCH_1 (STR, str);
      DISPATCH_1 (ARRAY, array);
      DISPATCH_1 (TABLE, table);
      DISPATCH_1 (TUPLE, tuple);
      DISPATCH_1 (STREAM, stream);
      DISPATCH_1 (SYMBOL, symbol);
      DISPATCH_1 (FCT, fct);
      DISPATCH_1 (CORO, coro);
      DISPATCH_1 (THREAD, thread);
      DISPATCH_1 (PKG, pkg);

      case typecode::INSTANCE:
        return (as_instance(obj)->ptype);

      case typecode::CUSTOM:
        return (as_custom(obj)->type ());

#undef DISPATCH_1
#undef DISPATCH_2
    }

  return (NIL);
}

static const array*
slotdef_get (interpreter *interp, object ts,
             object name, const array *defs)
{
  if (defs->len == 0)
    return (nullptr);

  uint32_t pos = hash_slot_name (interp, name);
  uint32_t nprobe = 1, len_m1 = defs->len - 1;

  for (pos &= len_m1 ; ; pos = (pos + nprobe++) & len_m1)
    {
      if (defs->data[pos] == fixint (0))
        return (nullptr);

      const array *entry = as_array (defs->data[pos]);
      if (entry->data[SLOTDEF_NAME] == name)
        return (entry);
    }
}

static inline object*
slot_at_ts (const array *entry, object inst)
{
  if (entry->data[SLOTDEF_FLAGS] & fixint (SLOTDEF_SHARED_FLG))
    { // Inherited shared slot.
      int ix = as_int (entry->data[SLOTDEF_INDEX]);
      int i1 = ix & 0x3fff, i2 = ix >> 14;

      inst = xaref (tspec_parents (inst), i2 - 1);
      entry = as_array (xaref (tspec_shared (inst), i1));
    }

  return (&entry->data[SLOTDEF_INDEX]);
}

static object*
slot_ptr_ts (interpreter *interp, object inst,
             object name, const array **outpp)
{
  auto entry = slotdef_get (interp, as_instance(inst)->tspec, name,
                            as_array (tspec_shared (inst)));

  if (!entry)
    return (nullptr);

  *outpp = entry;
  return (slot_at_ts (entry, inst));
}

static inline object*
slot_at (const array *entry, object inst, object ts)
{
  int ix = as_int (entry->data[SLOTDEF_INDEX]);
  if (kp_unlikely (ix == -1))
    return (&as_instance(inst)->builtin);
  else if (entry->data[SLOTDEF_FLAGS] & fixint (SLOTDEF_SHARED_FLG))
    { // Inherited shared slot.
      int i1 = ix & 0x3fff, i2 = ix >> 14;
      if (i2 != 0)
        ts = xaref (tspec_parents (ts), i2 - 1);

      object def = xaref (tspec_shared (ts), i1);
      return (&xaref(def, SLOTDEF_INDEX));
    }

  return (&xaref(as_instance(inst)->slots, ix));
}

static object*
slot_ptr (interpreter *interp, object inst,
          object name, const array **outpp)
{
  if (typespec_p (inst))
    return (slot_ptr_ts (interp, inst, name, outpp));

  object ts = as_instance(inst)->ptype;
  auto entry = slotdef_get (interp, ts, name,
                            as_array (tspec_slotdefs (ts)));

  if (!entry)
    return (nullptr);

  *outpp = entry;
  return (slot_at (entry, inst, ts));
}

instance::slotdef_iter::slotdef_iter (interpreter *interp, object inst) :
  slotdefs (interp, tspec_slotdefs (as_instance(inst)->ptype)),
  idx (-1), builtin (interp, UNBOUND)
{
  static_assert (KP_NELEM (this->bt_room) >= SLOTDEF_NUM_MEMBERS,
                 "insufficient room for builtin slot definition");

  const auto ptype = as_instance (as_instance(inst)->ptype);

  if (ptype->builtin != UNBOUND)
    {
      this->bt_room[SLOTDEF_NAME] =
        this->bt_room[SLOTDEF_TYPE] = ptype->builtin;
      this->bt_room[SLOTDEF_INIT] = as_instance(ptype->builtin)->slots;
      this->bt_room[SLOTDEF_FLAGS] = fixint (0);
      this->bt_room[SLOTDEF_PROPS] = UNBOUND;
      this->bt_room[SLOTDEF_INDEX] = fixint (-1);

      this->bt_mem.local_init (this->bt_room, KP_NELEM (this->bt_room));
      *this->builtin = this->bt_mem.as_obj ();
    }
  else
    ++*this;
}

object instance::slotdef_iter::operator* () const
{
  if (*this->builtin != UNBOUND)
    return (*this->builtin);

  return (xaref (*this->slotdefs, this->idx));
}

instance::slotdef_iter& instance::slotdef_iter::operator++ ()
{
  *this->builtin = UNBOUND;
  while (++this->idx < len_a (*this->slotdefs))
    {
      object sdef = xaref (*this->slotdefs, this->idx);
      if (sdef != fixint (0))
        return (*this);
    }

  *this->slotdefs = UNBOUND;
  return (*this);
}

instance::slotdef_iter instance::slotdef_iter::operator++ (int)
{
  slotdef_iter ret { interpreter::self (), *this };
  ++*this;
  return (ret);
}

static result<bool>
nput_slot (interpreter *interp, object inst, object key, object val,
           const array *sdef, object *ptr)
{
  if (!ptr)
    return (interp->raise ("unbound-error",
                           KP_SPRINTF (interp, "object has no slot named %Q",
                                       key)));
  else if (sdef->data[SLOTDEF_FLAGS] & fixint (SLOTDEF_GETTER_FLG))
    {
      KP_VTRY (interp->growstk (3));
      *interp->stkend++ = xaref (sdef->data[SLOTDEF_PROPS], 1);

      if (interp->stktop () == UNBOUND)
        return (interp->raise ("arg-error",
                               KP_SPRINTF (interp, "no setter defined for "
                                                   "slot %Q", key)));

      *interp->stkend++ = inst;
      *interp->stkend++ = val;
      KP_TRY (call_n (interp, 2));
      return (false);
    }
  else if (kp_unlikely (sdef->data[SLOTDEF_TYPE] != UNBOUND &&
           instanceof (val, sdef->data[SLOTDEF_TYPE]) < 1))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "slot %Q must be of type %Q, "
                                               "got %Q",
                                               key, sdef->data[SLOTDEF_TYPE],
                                               type (val))));

  *ptr = val;
  return (true);
}

static inline bool
slot_name_p (object x)
{
  if (!symbol_p (x))
    return (false);

  x = sympkg (x);
  return (x == kword_package || nil_p (x));
}

static result<bool>
nput_helper (interpreter *interp, object inst, object key,
             object val, object cflag = fixint (SLOTDEF_CONST_FLG))
{
  if (builtin_typespec_p (key) &&
      key == type (as_instance(inst)->builtin))
    {
      instance::slotdef_iter it { interp, inst };
      return (nput_slot (interp, inst, key, val,
                         as_array (*it), &as_instance(inst)->builtin));
    }
  else if (!slot_name_p (key))
    return (interp->raise ("type-error", "slot name must be a keyword or "
                                         "uninterned symbol"));

  const array *sdef = nullptr;
  object *ptr = slot_ptr (interp, inst, key, &sdef);
  if (sdef->data[SLOTDEF_FLAGS] & cflag)
    return (interp->raise ("const-error",
                           KP_SPRINTF (interp, "cannot set read-only slot %Q",
                                       key)));

  return (nput_slot (interp, inst, key, val, sdef, ptr));
}

enum
{
  pack_idx_typespec,
  pack_idx_int,
  pack_idx_char,
  pack_idx_cons,
  pack_idx_float,
  pack_idx_bvector,
  pack_idx_str,
  pack_idx_array,
  pack_idx_table,
  pack_idx_tuple,
  pack_idx_stream,
  pack_idx_symbol,
  pack_idx_fct,
  pack_idx_coro,
  pack_idx_thread,
  pack_idx_pkg,
};

static inline result<object>
builtin_slot_init (interpreter *interp, const array *sdef)
{
  int idx = as_int (sdef->data[SLOTDEF_INIT]);
  switch (idx)
    {
      case pack_idx_int:
        kp_return (fixint (0));
      case pack_idx_char:
        kp_return (charobj ('\0'));
      case pack_idx_cons:
        kp_return (NIL);
      case pack_idx_float:
        kp_return (fltobj::make (interp, 0));
      case pack_idx_bvector:
        kp_return (deref (alloc_bvector (interp, 0)));
      case pack_idx_str:
        kp_return (deref (alloc_str (interp, 0)));
      case pack_idx_array:
        kp_return (deref (alloc_array (interp, 0)));
      case pack_idx_table:
        return (KP_CALL (interp, table_fct, NIL, NIL));
      case pack_idx_tuple:
        return (KP_CALL (interp, tuple_fct, NIL));
      default:
        return (interp->raise ("arg-error",
                               KP_SPRINTF (interp, "cannot default initialize "
                                                   "builtin slot of type %Q",
                                                   sdef->data[SLOTDEF_NAME])));
    }
}

result<object> alloc_inst (interpreter *interp, object type,
                           object *argv, int argc)
{
  if (!typespec_p (type))
    return (interp->raise ("type-error",
                           KP_SPRINTF (interp, "expected a type, got %Q",
                                       type)));

  auto eg = KP_TRY (evh_guard::make (interp));
  instance *inst = alloch<instance> ();
  inst->ptype = type;
  inst->slots = KP_TRY (alloc_array (interp, as_int (tspec_nslots (type))));
  inst->tspec = inst->builtin = UNBOUND;

  interp->alval = inst->as_obj ();
  gc_register (interp, inst, sizeof (*inst));

  valref saved (interp, interp->alval);
  for (int i = 0; i < argc; i += 2)
    {
      if (i + 1 >= argc)
        return (interp->raise ("arg-error", "expected an even number of "
                                            "slot initializers"));

      KP_VTRY (nput_helper (interp, *saved, argv[i], argv[i + 1], 0));
    }

  if (!as_instance(type)->flagged_p (instance::init_flag))
    return (interp->alval);

  // We may need to run additional slot initializers.
  valref value (interp);
  instance::slotdef_iter it { interp, interp->alval };

  for (; it.valid (); ++it)
    {
      const array *sdef = as_array (*it);
      if (sdef->data[SLOTDEF_INIT] == UNBOUND ||
          (sdef->data[SLOTDEF_FLAGS] & fixint (SLOTDEF_SHARED_FLG |
                                               SLOTDEF_GETTER_FLG)))
        continue;

      object *ptr = slot_at (sdef, *saved, type);
      if (*ptr != UNBOUND)
        continue;
      else if (fixint_p (sdef->data[SLOTDEF_INIT]))
        { *value = KP_TRY (builtin_slot_init (interp, sdef)); }
      else
        {
          KP_VTRY (interp->push (sdef->data[SLOTDEF_INIT]));
          *value = KP_TRY (call_n (interp, 0));
        }

      bool rv = KP_TRY (nput_slot (interp, *saved, sdef->data[SLOTDEF_NAME],
                                   *value, sdef, ptr));
      if (rv)
        deref (gc_wbarrier (interp, *saved, *value));
    }

  return (interp->alval = *saved);
}

result<object> get_w (interpreter *interp, object inst,
                      object key, object dfl)
{
  if (kp_unlikely (dfl != UNBOUND))
    return (interp->raise_nargs (2, 2, 3));
  else if (builtin_typespec_p (key) &&
           key == type (as_instance(inst)->builtin))
    kp_return (as_instance(inst)->builtin);
  else if (!slot_name_p (key))
    return (interp->raise ("type-error", "slot name must be a keyword or "
                                         "uninterned symbol"));

  const array *sdef = nullptr;
  object *ptr = slot_ptr (interp, inst, key, &sdef);

  if (sdef)
    {
      if (sdef->data[SLOTDEF_FLAGS] & fixint (SLOTDEF_GETTER_FLG))
        {
          object getter = xaref (sdef->data[SLOTDEF_PROPS], 0);
          if (getter == UNBOUND)
            return (interp->raise ("arg-error",
                                   KP_SPRINTF (interp,
                                               "no getter defined for slot %Q",
                                               key)));

          KP_PUSH_ALL (interp, getter, inst);
          KP_TRY (call_n (interp, 1));

          if (kp_unlikely (sdef->data[SLOTDEF_TYPE] != UNBOUND &&
                           instanceof (interp->retval,
                                       sdef->data[SLOTDEF_TYPE]) < 1))
            return (interp->raise ("type-error",
                                   KP_SPRINTF (interp, "slot %Q must be of type"
                                                       " %Q, got %Q",
                                               key, sdef->data[SLOTDEF_TYPE],
                                               type (interp->retval))));

          return (interp->retval);
        }
      else if (*ptr != UNBOUND)
        kp_return (*ptr);
    }

  return (interp->raise ("unbound-error",
                         KP_SPRINTF (interp, "slot %Q is unbound", key)));
}

result<object> nput_w (interpreter *interp, object inst,
                       object key, object val)
{
  if (kp_unlikely (as_varobj(inst)->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());

  bool rv = KP_TRY (nput_helper (interp, inst, key, val));
  if (!rv)
    return (interp->retval);

  deref (gc_wbarrier (interp, inst, val));
  kp_return (val);
}

result<int64_t> write_w (interpreter *interp, stream *strm,
                         object x, io_info& info)
{
  int64_t ret = KP_TRY (strm->write (interp, "#<", 2));
  const instance *inst = as_instance (x);

  if (inst->tspec == UNBOUND)
    {
      ret += KP_TRY (xwrite (interp, strm, tspec_name (inst->ptype), info));

      char buf[64];
      ret += KP_TRY (strm->write (interp, buf,
                                  sprintf (buf, " object at %p",
                                           (const void *)inst)));
    }
  else
    {
      if (!fixint_p (inst->slots))
        { ret += KP_TRY (strm->write (interp, "type ", 5)); }

      ret += KP_TRY (xwrite (interp, strm,
                             xaref (inst->tspec, TSPEC_NAME), info));
    }

  ret += KP_TRY (strm->putb (interp, '>'));
  return (ret);
}

static inline result<int64_t>
maybe_pack (interpreter *interp, stream *strm, object obj, pack_info& info)
{
  if (obj == UNBOUND)
    obj = NIL;

  return (xpack (interp, strm, obj, info));
}

result<int64_t> pack_w (interpreter *interp, stream *strm,
                        object obj, pack_info& info)
{
  const instance *inst = as_instance (obj);
  int64_t ret = KP_TRY (maybe_pack (interp, strm, inst->ptype, info));
  ret += KP_TRY (maybe_pack (interp, strm, inst->slots, info));
  ret += KP_TRY (maybe_pack (interp, strm, inst->tspec, info));
  ret += KP_TRY (xpack (interp, strm, inst->builtin == UNBOUND ?
                                      fixint (0) : inst->builtin, info));
  return (ret);
}

unsigned int instance::type_code () const
{
  return (fixint_p (this->slots) ? as_int (this->slots) : 0xff);
}

result<object> unpack_w (interpreter *interp, stream *strm,
                         pack_info& info, bool save)
{
  valref ptype (interp), slots (interp), tspec (interp), builtin (interp);

  *ptype = KP_TRY (xunpack (interp, strm, info));
  if (!array_p (*ptype))
    return (info.error ("invalid parent type read"));

  *slots = KP_TRY (xunpack (interp, strm, info));
  if (!array_p (*slots))
    return (info.error ("invalid slots read"));

  *tspec = KP_TRY (xunpack (interp, strm, info));
  if (*tspec == NIL)
    *tspec = UNBOUND;
  else if (!array_p (*tspec))
    return (info.error ("invalid typespec read"));

  *builtin = KP_TRY (xunpack (interp, strm, info));
  if (*builtin == fixint (0))
    *builtin = UNBOUND;
  else if (!builtin_typespec_p (*builtin))
    return (info.error ("invalid builtin specifier read"));

  auto inst = alloch<instance> ();
  inst->ptype = *ptype;
  inst->slots = *slots;
  inst->tspec = *tspec;
  inst->builtin = *builtin;
  interp->retval = inst->as_obj ();
  gc_register (interp, inst);

  if (save)
    KP_VTRY (info.add_mapping (interp, *info.offset, inst->as_obj ()));

  kp_return (inst->as_obj ());
}

object builtin_type (unsigned int code)
{
  switch (code)
    {
#define TYPE(name)   \
  case pack_idx_##name:   \
    return (name##_type)
        
      TYPE (typespec);
      TYPE (int);
      TYPE (char);
      TYPE (cons);
      TYPE (float);
      TYPE (bvector);
      TYPE (str);
      TYPE (array);
      TYPE (table);
      TYPE (tuple);
      TYPE (stream);
      TYPE (symbol);
      TYPE (fct);
      TYPE (coro);
      TYPE (thread);
      TYPE (pkg);
      default:
        return (UNBOUND);

#undef TYPE
    }
}

static inline int
isa_1 (object objtype, object tspec)
{
  if (objtype == tspec)
    return (1);

  const auto ptypes = as_array (tspec_parents (objtype));
  for (uint32_t i = 0; i < ptypes->len; ++i)
    if (ptypes->data[i] == tspec)
      return ((int)(i + 2));

  return (0);
}

int subtype_p (object ty, object ts)
{
  return (typespec_p (ts) ? isa_1 (ty, ts) : -1);
}

int instanceof (object obj, object ts)
{
  return (subtype_p (type (obj), ts));
}

object type_name (object obj)
{
  return (typespec_p (obj) ? tspec_name (obj) : NIL);
}

object builtin_member (object obj)
{
  return (instance_p (obj) ? as_instance(obj)->builtin : obj);
}

struct builtin_typespec
{
  const char *name;
  object *outp;
  int pack_idx;

  void init (interpreter *interp)
    {
      valref ts (interp, deref (alloc_array (interp, TSPEC_NUM_MEMBERS)));
      valref sym (interp, deref (intern (interp, this->name, nullptr,
                                         FLAGS_CONST | symbol::literal_flag)));

      xaref(*ts, TSPEC_NAME) = *sym;
      xaref(*ts, TSPEC_PARENTS) = xaref(*ts, TSPEC_SHARED) =
        xaref(*ts, TSPEC_SLOTDEFS) = deref (alloc_array (interp, 0));
      xaref(*ts, TSPEC_NSLOTS) = fixint (0);

      instance *inst = alloch<instance> ();
      *this->outp = inst->as_obj ();
      inst->ptype = typespec_type;
      inst->slots = fixint (this->pack_idx);
      inst->tspec = *ts;
      inst->builtin = this->pack_idx == pack_idx_typespec ?
                                        UNBOUND : inst->as_obj ();

      inst->vo_full |= FLAGS_CONST;
      interp->alval = *this->outp;
      gc_register (interp, inst, sizeof (*inst));
      symval(*sym) = *this->outp;
    }
};

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

  builtin_typespec builtin_types[] =
  {
    // typespec must come first.
    { "typespec", &typespec_type, pack_idx_typespec },

#define TYPE(name)   \
    { #name "-t", &name##_type, pack_idx_##name }
    TYPE (int), TYPE (char), TYPE (cons), TYPE (float), TYPE (bvector),
    TYPE (str), TYPE (array), TYPE (table), TYPE (tuple), TYPE (stream),
    TYPE (symbol), TYPE (fct), TYPE (coro), TYPE (thread), TYPE (pkg)
  };

  evh_safeguard eg { interp };
  for (size_t i = 0; i < KP_NELEM (builtin_types); ++i)
    builtin_types[i].init (interp);

#undef TYPE
  return (init_op::result_ok);
}

init_op init_types (do_init_types, "types");

KP_DECLS_END