khipu/cons.cpp

/* Definitions for the cons type.

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

KP_DECLS_BEGIN

static inline exception
raise_circular (interpreter *interp)
{
  return (interp->raise ("arg-error", "argument must not be circular"));
}

static inline exception
raise_dotted (interpreter *interp)
{
  return (interp->raise ("arg-error", "argument must not be dotted"));
}

int32_t len_L (interpreter *, object lst, object& dotc)
{
  int ret = 0;
  cons::unsafe_iter it (lst);
  for (; it.valid (); ++it, ++ret);

  if (it.circular ())
    return (-1);

  dotc = it.node ();
  return (ret);
}

result<int32_t> len_L (interpreter *interp, object lst)
{
  object tail;
  int ret = len_L (interp, lst, tail);

  if (tail != NIL && ret > 0)
    return (raise_dotted (interp));

  return (ret);
}

result<object> cons::make (interpreter *interp, object car, object cdr)
{
  object ret = KP_TRY (alloc_cons (interp));
  cons *p = as_cons (ret);
  p->car = car, p->cdr = cdr;
  kp_return (ret);
}

result<object> nputcar (interpreter *interp, object lst, object obj)
{
  xcar(lst) = obj;
  KP_VTRY (gc_wbarrier (interp, lst, obj));
  kp_return (lst);
}

result<object> nputcdr (interpreter *interp, object lst, object obj)
{
  xcdr(lst) = obj;
  KP_VTRY (gc_wbarrier (interp, lst, obj));
  kp_return (lst);
}

static result<object>
cons_ref (interpreter *interp, int idx, object& obj)
{
  cons::unsafe_iter it (obj);
  if (idx < 0)
    {
      object tail;
      int rl = len_L (interp, obj, tail);
      if (rl < 0)
        return (raise_circular (interp));
      else if ((idx += rl) < 0)
        return (interp->raise_oob (0, -1));
    }

  for (; idx > 0 && it.valid (); --idx, ++it);
  if (!it.valid ())
    return (interp->raise_oob (0, -1));

  return (obj = it.node ());
}

result<object> nthcdr (interpreter *interp, object idx, object obj)
{
  int iv;

  if (!as<int> (idx, iv))
    return (interp->raise ("type-error", "first argument must be an integer"));
  else if (!xcons_p (obj))
    return (interp->raise ("type-error", "second argument must be a cons"));

  object ret = KP_TRY (cons_ref (interp, iv, obj));
  kp_return (ret);
}

result<object> get_L (interpreter *interp, object obj, object idx, object dfl)
{
  int iv;

  if (kp_unlikely (dfl != UNBOUND))
    return (interp->raise_nargs (2, 2, 3));
  else if (!as<int> (idx, iv))
    return (interp->raise ("type-error", "index is not an integer"));

  object ret = KP_TRY (cons_ref (interp, iv, obj));
  kp_return (xcar (ret));
}

result<object> nput_L (interpreter *interp, object obj, object idx, object val)
{
  int iv;

  if (kp_unlikely (!as<int> (idx, iv)))
    return (interp->raise ("type-error", "index is not an integer"));

  object ret = KP_TRY (cons_ref (interp, iv, obj));
  KP_VTRY (nputcar (interp, ret, val));
  kp_return (val);
}

result<object> last_L (interpreter *interp, object lst)
{
  cons::unsafe_iter it (lst);
  for (; cons_p (xcdr (it.node ())); ++it)
    if (it.circular ())
      return (raise_circular (interp));

  kp_return (it.node ());
}

static result<int>
adjust_idx (interpreter *interp, object obj, int& ix, int *p)
{
  object tail;
  int rl = len_L (interp, obj, tail);

  if (rl < 0)
    return (raise_circular (interp));

  ix += rl;
  if (p)
    *p += rl;

  return (0);
}

result<object> subseq_L (interpreter *interp, object obj,
                         object ix1, object ix2)
{
  if (ix2 == UNBOUND)
    {
      valref tmp = KP_TRY (nthcdr (interp, ix1, obj));
      return (copy (interp, *tmp, false));
    }

  int i1, i2;

  if (kp_unlikely (!as<int> (ix1, i1) || !as<int> (ix2, i2)))
    return (interp->raise ("type-error", "indices must be integers"));
  else if (i1 < 0)
    KP_VTRY (adjust_idx (interp, obj, i1, i2 < 0 ? &i2 : nullptr));
  else if (i2 < 0)
    KP_VTRY (adjust_idx (interp, obj, i2, nullptr));

  if ((i1 | i2) < 0 || i1 > i2)
    return (interp->raise ("index-error", "indices out of bounds"));

  int rlen = i2 - i1;
  object ret = KP_TRY (alloc_cons (interp, rlen));
  cons::unsafe_iter it (obj);

  for (int i = 0; i < i1 && it.valid (); ++i, ++it);
  for (; i1 < i2 && it.valid (); ++i1, ++it)
    {
      xcar(ret) = *it;
      ret = xcdr (ret);
    }

  xcdr(ret) = NIL;
  kp_return (interp->alval);
}

static inline result<int>
revcopy (interpreter *interp, object& acc, cons::iterator& it)
{
  for (; it.valid (); ++it)
    {
      object obj = KP_TRY (copy (interp, *it, true));
      acc = KP_TRY (cons::make (interp, obj, acc));
    }

  return (0);
}

static inline result<int>
revcopy_shallow (interpreter *interp, object& acc, cons::iterator& it)
{
  for (; it.valid (); ++it)
    { acc = KP_TRY (cons::make (interp, *it, acc)); }

  return (0);
}

result<object> copy_L (interpreter *interp, object obj, bool deep)
{
  if (obj == NIL)
    kp_return (obj);

  valref acc (interp, NIL);
  cons::iterator it (interp, obj);
  KP_VTRY (revcopy (interp, *acc, it));

  interp->aux = KP_TRY (nreverse_L (interp, *acc));

  if (it.circular ())
    KP_VTRY (nputcdr (interp, *acc, it.prev_node ()));
  else if (!xcons_p (it.node ()))
    KP_VTRY (nputcdr (interp, *acc, it.node ()));

  kp_return (interp->aux);
}

static const uint32_t CONS_HASH_SEED = 1936617315;

result<uint32_t> hash_L (interpreter *interp, object obj)
{
  uint32_t ret = CONS_HASH_SEED;
  if (obj == NIL)
    return (ret);

  cons::iterator it (interp, obj);

  while (true)
    {
      uint32_t tmp = KP_TRY (xhash (interp, *it));
      ret = mix_hash (ret, tmp);

      if (!(++it).valid ())
        {
          object pt = it.node ();
          if (pt != UNBOUND && pt != NIL)
            { // Dotted list - Hash the tail and mix it again.
              tmp = KP_TRY (xhash (interp, pt));
              ret = mix_hash (ret, tmp);
            }

          break;
        }
    }

  return (ret);
}

result<object> iter_L (interpreter *interp, object obj, object token, bool adv)
{
  if (token == UNBOUND)
    kp_return (obj);
  else if (!cons_p (token))
    return (interp->raise ("arg-error", "invalid token"));
  else if (!adv)
    kp_return (xcar (token));

  if (!xcons_p (interp->retval = xcdr (token)))
    return (raise_dotted (interp));

  return (interp->retval);
}

result<object> nreverse_L (interpreter *interp, object obj)
{
  object prev = NIL, tmp = obj;
  object *pp = &prev;

  while (tmp != NIL)
    {
      object qx = xcdr (tmp);
      if (!xcons_p (qx))
        return (raise_dotted (interp));

      /* Write barriers shouldn't be necessary here, since we are rearranging
       * an existing list; that is the responsibility of other mutators. */

      xcdr(tmp) = *pp;
      *pp = tmp, tmp = qx;
    }

  kp_return (prev);
}

result<object> reverse_L (interpreter *interp, object obj)
{
  valref ret (interp, NIL);
  cons::iterator it (interp, obj);

  for (; it.valid (); ++it)
    { *ret = KP_TRY (cons::make (interp, *it, *ret)); }

  if (!xcons_p (it.node ()))
    return (interp->raise ("arg-error", "argument is not a proper list"));

  kp_return (*ret);
}

result<object> concat_L (interpreter *interp, object *argv, int argc)
{
  if (argc == 1)
    kp_return (*argv);

  valref acc (interp, NIL);
  for (int i = 0; i < argc - 1; ++i)
    {
      if (xcons_p (argv[i]))
        {
          cons::iterator it (interp, argv[i]);
          KP_VTRY (revcopy_shallow (interp, *acc, it));

          if (it.node () == NIL)
            continue;
        }

      return (interp->raise ("arg-error", "arguments must be proper lists"));
    }

  if (*acc == NIL)
    kp_return (argv[argc - 1]);

  KP_VTRY (nreverse_L (interp, *acc));
  xcdr(*acc) = argv[argc - 1];
  return (interp->retval);
}

result<object> add_LL (interpreter *interp, object l1, object l2)
{
  object args[] = { l1, l2 };
  return (concat_L (interp, args, 2));
}

result<object> nsort_L (interpreter *interp, object obj, comparator& cmp)
{
  valref nm (interp);
  cons::iterator it (interp, obj), tmp (interp, NIL);

  for (; it.valid (); ++it)
    {
      tmp.reset (it);
      *nm = it.node ();

      while ((++tmp).valid ())
        {
          bool rv = KP_TRY (cmp (*tmp, xcar (*nm)));
          if (rv)
            *nm = tmp.node ();
        }

      if (tmp.circular ())
        return (raise_circular (interp));
      else if (it.node () != *nm)
        swap (xcar (it.node ()), xcar (*nm));
    }

  kp_return (obj);
}

result<object> nconcat (interpreter *interp, object *argv, int argc)
{
  if (!argc)
    kp_return (NIL);
  else if (argc == 1)
    kp_return (*argv);

  int i;
  for (i = 0; i < argc; ++i)
    if (!xcons_p (argv[i]))
      {
        if (i == argc - 1)
          kp_return (argv[i]);

        return (interp->raise ("type-error", "arguments must be lists"));
      }
    else if (argv[i] != NIL)
      break;

  if (i == argc)
    kp_return (argv[i - 1]);

  valref ret (interp, argv[i++]), tail = KP_TRY (last_L (interp, *ret));

  for (; i < argc - 1; ++i)
    {
      if (argv[i] == NIL)
        continue;
      else if (!xcons_p (argv[i]))
        return (interp->raise ("type-error", "arguments must be lists"));

      KP_VTRY (nputcdr (interp, *tail, argv[i]));
      *tail = KP_TRY (last_L (interp, argv[i]));
    }

  KP_VTRY (nputcdr (interp, *tail, argv[argc - 1]));
  kp_return (*ret);
}

result<object> nrevconc (interpreter *interp, object lst, object tail)
{
  if (!xcons_p (lst))
    return (interp->raise ("type-error", "first argument must be a list"));

  valref sl (interp, lst), rv = KP_TRY (nreverse_L (interp, *sl));
  KP_VTRY (nputcdr (interp, *sl, tail));
  kp_return (*rv);
}

result<bool> eq_LL (interpreter *interp, object l1, object l2)
{
  cons::iterator l_it (interp, l1), r_it (interp, l2);

  for (; l_it.valid () && r_it.valid (); ++l_it, ++r_it)
    {
      bool rv = KP_TRY (equal (interp, *l_it, *r_it));
      if (!rv)
        return (rv);
    }

  if (l_it.node () == NIL)
    return (r_it.node () == NIL);

  bool rv = !l_it.circular () && !r_it.circular ();
  if (rv)
    { rv = KP_TRY (equal (interp, l_it.node (), r_it.node ())); }

  return (rv);
}

result<int> cmp_LL (interpreter *interp, object l1, object l2)
{
  cons::iterator l_it (interp, l1), r_it (interp, l2);

  for (; l_it.valid () && r_it.valid (); ++l_it, ++r_it)
    {
      int rv = KP_TRY (xcmp (interp, *l_it, *r_it));
      if (rv != 0)
        return (rv);
    }

  if (l_it.circular () || r_it.circular ())
    return (-1);
  else if (r_it.node () == NIL)
    return (l_it.node () != r_it.node ());
  else if (l_it.node () == NIL)
    return (-(r_it.node () != l_it.node ()));

  int rv = KP_TRY (xcmp (interp, l_it.node (), r_it.node ()));
  return (rv);
}

result<object> nzap_L (interpreter *interp, object obj, object key,
                       uint32_t flags, object fn, object *argv, int argc)
{
  int iv;

  if (kp_unlikely (!as<int> (key, iv)))
    return (interp->raise ("type-error", "index is not an integer"));
  else if (kp_unlikely (flags & NZAP_DFL))
    return (interp->raise ("arg-error", "default argument not supported"));

  KP_VTRY (interp->growstk (argc + 2));
  *interp->stkend++ = fn;
  *interp->stkend++ = fixint (0);   // Placeholder.

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

  valref prev (interp), ref = KP_TRY (cons_ref (interp, iv, obj));
  atomic_t *ref_ptr = (atomic_t *)&xcar(*ref);

  if (flags & NZAP_NOMT)
    {
      interp->stack[stack_idx] = *prev = *ref_ptr;
      KP_VTRY (call_n (interp, argc + 1),
               nputcar (interp, *ref, interp->retval));
      interp->retval = xcar (interp->retval);
    }
  else
    while (true)
      {
        *prev = xcar (*ref);
        interp->stack[stack_idx] = *prev;

        KP_VTRY (call_n (interp, argc + 1));
        if (atomic_cas_bool (ref_ptr,
                             (atomic_t)*prev, (atomic_t)interp->retval))
          {
            KP_VTRY (gc_wbarrier (interp, *ref, interp->retval));
            break;
          }

        atomic_spin_nop ();
      }

  if (flags & NZAP_PREV)
    interp->retval = *prev;

  return (interp->retval);
}

result<object> find_L (interpreter *interp, object obj, object key,
                       object start, object end, object test)
{
  int istart = start == UNBOUND ? as_int (start) : 0;
  int iend = end == UNBOUND ? FIXINT_MAX : as_int (end);

  if (istart < 0)
    KP_VTRY (adjust_idx (interp, obj, istart, iend < 0 ? &iend : nullptr));
  else if (iend < 0)
    KP_VTRY (adjust_idx (interp, obj, iend, nullptr));

  if (istart > iend)
    kp_return (NIL);
  else if ((istart | iend) < 0)
    return (interp->raise ("index-error", "indices out of bounds"));

  cons::unsafe_iter it (obj);
  for (int i = 0; i < istart && it.valid (); ++it) ;

  if (test == UNBOUND)
    {
      valref tmp (interp);
      for (; istart < iend && it.valid (); ++it, ++istart)
        {
          bool rv = KP_TRY (equal (interp, key, *it));
          if (rv)
            kp_return (it.node ());
        }
    }
  else
    {
      KP_VTRY (interp->growstk (3));
      for (; istart < iend && it.valid (); ++it, ++istart)
        {
          *interp->stkend++ = test;
          *interp->stkend++ = key;
          *interp->stkend++ = *it;
          KP_VTRY (call_n (interp, 2));
          if (interp->retval != NIL)
            kp_return (it.node ());
        }
    }

  kp_return (NIL);
}

result<int64_t> write_L (interpreter *interp, stream *strm,
                         object obj, io_info& info)
{
  if (obj == NIL)
    return (strm->write (interp, "nil", 3));
  else if (xcar (obj) == symbol::quote &&
           xcons_p (xcdr (obj)) && xcddr (obj) == NIL)
    {
      valref prev (interp, xcadr (obj));
      int64_t ret = KP_TRY (strm->putb (interp, '\''));
      ret += KP_TRY (xwrite (interp, strm, *prev));
      return (ret);
    }

  int64_t ret = KP_TRY (strm->putb (interp, '('));
  cons::iterator it (interp, obj);

  while (true)
    {
      ret += KP_TRY (xwrite (interp, strm, *it, info));

      if ((++it).valid ())
        {
          ret += KP_TRY (strm->putb (interp, ' '));
          continue;
        }
      else if (it.circular ())
        { ret += KP_TRY (strm->write (interp, " ...", 4)); }
      else if (!xcons_p (it.node ()))
        {
          ret += KP_TRY (strm->write (interp, " . ", 3));
          ret += KP_TRY (xwrite (interp, strm, it.node (), info));
        }

      break;
    }

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

result<int64_t> pack_L (interpreter *interp, stream *strm,
                        object obj, pack_info& info)
{
  pack_info::eviction_guard eg { info, true };
  cons::iterator it (interp, obj);
  int64_t ret = KP_TRY (xpack (interp, strm, *it, info));

  for (++it; it.valid (); ++it)
    { /* Here we inline part of the packing routine to avoid
       * pathological cases of very deep recursion, which can
       * lead to a stack overflow. */
      object off = info.get (interp, it.node ());
      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));
          break;
        }

      valref tmp = KP_TRY (strm->tell (interp));
      KP_VTRY (info.add_mapping (interp, it.node (), *tmp));
      ret += KP_TRY (strm->putb (interp, typecode::CONS));
      ret += KP_TRY (xpack (interp, strm, *it, info));
    }

  if (it.node () == NIL)
    { ret += KP_TRY (strm->putb (interp, PACK_NIL)); }
  else if (!it.circular ())
    { ret += KP_TRY (xpack (interp, strm, it.node (), info)); }

  return (ret);
}

result<object> unpack_L (interpreter *interp, stream *strm,
                         pack_info& info, bool save)
{
  valref pos (interp, *info.offset), out (interp, NIL);
  while (true)
    {
      object tmp = KP_TRY (xunpack (interp, strm, info));
      *out = KP_TRY (cons::make (interp, tmp, *out));

      if (save)
        KP_VTRY (info.add_mapping (interp, *pos, *out));

      *pos = KP_TRY (strm->tell (interp));
      int tp = KP_TRY (strm->peekb (interp));
      if (tp < 0)
        return (info.error ("invalid typecode"));

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

      if (tp != typecode::CONS)
        {
          if (tp != PACK_NIL)
            {
              *pos = KP_TRY (xunpack (interp, strm, info));
              *out = KP_TRY (nrevconc (interp, *out, *pos));
            }
          else
            {
              *out = KP_TRY (nreverse_L (interp, *out));
              KP_VTRY (strm->getb (interp));
            }

          kp_return (*out);
        }

      KP_VTRY (strm->getb (interp));
    }
}

// External definitions.
static const cons C_NIL = 
{
#ifdef KP_ARCH_WIDE
  ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL,
  ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL
#else
  (object)&C_NIL | 2,
  (object)&C_NIL | 2
#endif
};

const object NIL =
#ifdef KP_ARCH_WIDE
  ((object)typecode::CONS << TYPE_SHIFT) | (object)&C_NIL;
#else
  (object)&C_NIL | 2;
#endif

static int
do_init_cons (interpreter *)
{
  ensure_mask_impl ((void *)&C_NIL);
  return (init_op::result_ok);
}

init_op init_cons (do_init_cons, "cons");

KP_DECLS_END