khipu/array.cpp

/* Definitions for the array 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 <cstdio>
#include "khipu.hpp"
#include "utils/raw_acc.hpp"

KP_DECLS_BEGIN

static array empty_array;

array* array::alloc_raw (uint32_t n)
{
  array *ret = (array *)alloch (sizeof (*ret) +
                                n * sizeof (object), typecode::ARRAY);
  ret->data = (object *)&ret[1];
  ret->len = n;
  return (ret);
}

result<object> alloc_array (interpreter *interp, uint32_t nelems, object fill)
{
  if (!nelems)
    kp_return (empty_array.as_obj ());

  auto eg = KP_TRY (evh_guard::make (interp));
  array *ret = array::alloc_raw (nelems);
  for (uint32_t i = 0; i < nelems; ++i)
    ret->data[i] = fill;

  interp->alval = ret->as_obj ();
  gc_register (interp, ret, sizeof (*ret) + nelems * sizeof (object));
  return (interp->alval);
}

result<object> add_aa (interpreter *interp, object a1, object a2)
{
  array *p1 = as_array (a1), *p2 = as_array (a2);

  if (!p1->len && !p2->len)
    kp_return (a1);

  object ret = KP_TRY (alloc_array (interp, p1->len + p2->len));
  copy_objs (copy_objs (as_array(ret)->data,
                        p1->data, p1->len),
             p2->data, p2->len);
  kp_return (ret);
}

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

  uint32_t nlen = 0;
  for (int i = 0; i < argc; ++i)
    {
      if (!array_p (argv[i]))
        return (interp->raise ("type-error", "arguments must be arrays"));

      nlen += len_a (argv[i]);
    }

  object obj = KP_TRY (alloc_array (interp, nlen));
  object *dstp = as_array(obj)->data;
  for (int i = 0; i < argc; ++i)
    dstp = copy_objs (dstp, &xaref(argv[i], 0), len_a (argv[i]));

  kp_return (interp->alval);
}

result<object> mul_ia (interpreter *interp, object iv, object ax)
{
  int ival = as_int (iv);
  const array *ap = as_array (ax);

  if (ival <= 0)
    kp_return (empty_array.as_obj ());

  object ret = KP_TRY (alloc_array (interp, ap->len * ival));
  object *ptr = as_array(ret)->data;

  for (int i = 0; i < ival; ++i)
    ptr = copy_objs (ptr, ap->data, ap->len);

  kp_return (ret);
}

static inline intptr_t
get_idx (const array *ap, intptr_t ix)
{
  return (ix < 0 ? ap->len + ix : ix);
}

static inline result<object*>
array_ref (interpreter *interp, object ax, object iv)
{
  int idx;
  if (!as<int> (iv, idx))
    return (interp->raise ("type-error", "index is not an integer"));

  array *ap = as_array (ax);
  idx = get_idx (ap, idx);
  if (kp_unlikely (idx < 0 || (uint32_t)idx >= ap->len))
    return (interp->raise_oob (idx, ap->len));

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

result<object> get_a (interpreter *interp,
                      object ax, object iv, object dfl)
{
  if (kp_unlikely (dfl != UNBOUND))
    return (interp->raise_nargs (2, 2, 3));

  object *p = KP_TRY (array_ref (interp, ax, iv));
  kp_return (*p);
}

result<object> nput_a (interpreter *interp,
                       object ax, object iv, object val)
{
  if (kp_unlikely (as_varobj(ax)->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());

  object *p = KP_TRY (array_ref (interp, ax, iv));
  deref (gc_wbarrier (interp, ax, *p = val));
  kp_return (val);
}

result<object> subseq_a (interpreter *interp,
                         object ax, object ix1, object ix2)
{
  const array *ap = as_array (ax);
  bool got = true;
  int i1, i2;

  if (ix2 == UNBOUND)
    i2 = (int)ap->len;
  else
    got = as<int> (ix2, i2);

  if (!got || !as<int> (ix1, i1))
    return (interp->raise ("type-error", "indices must be integers"));

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

  object ret = KP_TRY (alloc_array (interp, i2 - i1));
  copy_objs (as_array(ret)->data, ap->data + i1, i2 - i1);
  kp_return (ret);
}

result<object> copy_a (interpreter *interp, object obj, bool deep)
{
  const array *ap = as_array (obj);
  if (!deep)
    {
      object ret = KP_TRY (alloc_array (interp, ap->len));
      copy_objs (&xaref(ret, 0), ap->data, ap->len);
      kp_return (ret);
    }

  raw_acc<array> rx (ap->len);
  array *ret = rx.get ();
  valref obr (interp, ret->as_obj ()), tmp (interp);

  for (ret->len = 0; ret->len < ap->len; ++ret->len)
    {
      *tmp = ap->data[ret->len];
      ret->data[ret->len] = KP_TRY (copy (interp, *tmp, true));
    }

  rx.release ();
  interp->retval = *obr;
  gc_register (interp, ret, sizeof (*ret) + ret->len * sizeof (object));
  return (interp->retval);
}

static const uint32_t ARRAY_HASH_SEED = 1634890337;

result<uint32_t> hash_a (interpreter *interp, object obj)
{
  uint32_t ret = ARRAY_HASH_SEED;
  for (array::iterator it { interp, obj }; it.valid (); ++it)
    {
      uint32_t tmp = KP_TRY (xhash (interp, *it));
      ret = mix_hash (ret, tmp);
    }

  return (ret);
}

result<object> nreverse_a (interpreter *interp, object obj)
{
  array *ap = as_array (obj);

  if (kp_unlikely (ap->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());
  else if (ap->len == 0)
    kp_return (obj);

  for (uint32_t i = 0, j = ap->len - 1; i < j; ++i, --j)
    swap (ap->data[i], ap->data[j]);

  kp_return (obj);
}

result<object> reverse_a (interpreter *interp, object obj)
{
  const array *ap = as_array (obj);

  if (ap->len == 0)
    kp_return (obj);

  object ret = KP_TRY (alloc_array (interp, ap->len));
  for (uint32_t i = 0, j = ap->len - 1 ; ; ++i, --j)
    {
      xaref(ret, i) = ap->data[j];
      if (i >= j)
        break;
    }

  kp_return (ret);
}

result<object> nsort_a (interpreter *interp, object obj, comparator& cmp)
{
  array *ap = as_array (obj);
  
  if (kp_unlikely (ap->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());
  else if (ap->len <= 1)
    kp_return (obj);

  valref v1 (interp), v2 (interp);
  object *wp = ap->data - 1;

  for (uint32_t r = ap->len / 2; r > 0; --r)
    for (uint32_t i = r ; ; )
      {
        uint32_t j = i + i;
        if (j > ap->len)
          break;
        else if (j != ap->len)
          {
            bool rv = KP_TRY (cmp (*v1 = wp[j], *v2 = wp[j + 1]));
            if (rv)
              ++j;
          }

        bool rv = KP_TRY (cmp (*v1 = wp[i], *v2 = wp[j]));
        if (rv)
          swap (wp[i], wp[j]);

        i = j;
      }

  for (uint32_t s = ap->len - 1; s > 0; --s)
    {
      swap (*ap->data, ap->data[s]);

      for (uint32_t i = 1 ; ; )
        {
          uint32_t j = i + i;
          if (j > s)
            break;
          else if (j != s)
            {
              bool rv = KP_TRY (cmp (*v1 = wp[j], *v2 = wp[j + 1]));
              if (rv)
                ++j;
            }

          bool rv = KP_TRY (cmp (*v1 = wp[i], *v2 = wp[j]));
          if (rv)
            swap (wp[i], wp[j]);

          i = j;
        }
    }

  kp_return (obj);
}

result<bool> eq_aa (interpreter *interp, object a1, object a2)
{
  if (len_a (a1) != len_a (a2))
    return (false);

  for (array::iterator i1 { interp, a1 }, i2 { interp, a2 };
      i1.valid (); ++i1, ++i2)
    {
      bool rv = KP_TRY (equal (interp, *i1, *i2));
      if (!rv)
        return (false);
    }

  return (true);
}

result<int> cmp_aa (interpreter *interp, object a1, object a2)
{
  const array *ap1 = as_array (a1), *ap2 = as_array (a2);
  uint32_t rl = min (ap1->len, ap2->len);
  valref x (interp), y (interp);

  for (uint32_t i = 0; i < rl; ++i)
    {
      int c = KP_TRY (xcmp (interp, *x = ap1->data[i], *y = ap2->data[i]));
      if (c)
        return (c);
    }

  return (ap1->len < ap2->len ? -1 : ap2->len != ap1->len);
}

result<object> iter_a (interpreter *interp, object obj, object token, bool adv)
{
  if (token == UNBOUND)
    kp_return (len_a (obj) == 0 ? NIL : fixint (0));
  else if (!adv)
    return (get_a (interp, obj, token, UNBOUND));
  else if (!fixint_p (token))
    return (interp->raise ("type-error", "token must be an int"));

  int ix = as_int (token) + 1;
  kp_return ((uint32_t)ix >= len_a (obj) ? NIL : fixint (ix));
}

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

  if (kp_unlikely (!as<int> (key, idx)))
    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"));

  array *ap = as_array (obj);
  if (kp_unlikely (ap->flagged_p (FLAGS_CONST)))
    return (interp->raise_const ());

  idx = get_idx (ap, idx);
  if (kp_unlikely (idx < 0 || (uint32_t)idx >= ap->len))
    return (interp->raise_oob (idx, ap->len));

  sp_guard spg { interp };
  KP_VTRY (interp->growstk (argc + 1));
  *interp->stkend++ = fn;
  *interp->stkend++ = fixint (0);

  int stack_idx = interp->stklen () - 1;

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

  valref prev (interp);

  if (flags & NZAP_NOMT)
    {
      interp->stack[stack_idx] = *prev = ap->data[idx];
      ap->data[idx] = KP_TRY (call_n (interp, argc + 1));
    }
  else
    while (true)
      {
        *prev = ap->data[idx];
        interp->stack[stack_idx] = *prev;

        KP_VTRY (call_n (interp, argc + 1));
        if (atomic_cas_bool ((atomic_t *)&ap->data[idx],
                             (atomic_t)*prev, (atomic_t)interp->retval))
          break;

        atomic_spin_nop ();
      }

  deref (gc_wbarrier (interp, obj, interp->retval));
  if (flags & NZAP_PREV)
    interp->retval = *prev;
  
  return (interp->retval);
}

result<object> last_a (interpreter *interp, object obj)
{
  const array *ap = as_array (obj);
  if (!ap->len)
    return (interp->raise_oob (0, 0));

  kp_return (ap->data[ap->len - 1]);
}

result<object> find_a (interpreter *interp, object obj,
                       object key, object start, object end, object test)
{
  const array *ap = as_array (obj);
  int istart = start == UNBOUND ? 0 : get_idx (ap, as_int (start));
  int iend = end == UNBOUND ? ap->len : get_idx (ap, as_int (end));

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

  if (test == UNBOUND)
    {
      valref tmp (interp);
      for (; istart < iend; ++istart)
        {
          bool rv = KP_TRY (equal (interp, key, *tmp = ap->data[istart]));
          if (rv)
            kp_return (fixint (istart));
        }
    }
  else
    {
      KP_VTRY (interp->growstk (3));
      for (; istart < iend; ++istart)
        {
          *interp->stkend++ = test;
          *interp->stkend++ = key;
          *interp->stkend++ = ap->data[istart];
          KP_VTRY (call_n (interp, 2));
          if (interp->retval != NIL)
            kp_return (fixint (istart));
        }
    }

  kp_return (NIL);
}

result<int64_t> write_a (interpreter *interp, stream *strm,
                         object obj, io_info& info)
{
  int64_t ret = 0;
  ret += KP_TRY (strm->putb (interp, '['));

  array::iterator it { interp, obj };
  if (it.valid ())
    while (true)
      {
        ret += KP_TRY (xwrite (interp, strm, *it, info));
        if (!(++it).valid ())
          break;

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

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

result<int64_t> pack_a (interpreter *interp, stream *strm,
                        object obj, pack_info& info)
{
  const array *ap = as_array (obj);
  int64_t ret = 0;

  if (kp_likely (ap->len <= 0xff))
    { ret += KP_TRY (strm->putb (interp, (unsigned char)ap->len)); }
  else
    {
      ret += KP_TRY (strm->putb (interp, 0));
      ret += KP_TRY (strm->write (interp, &ap->len));
    }

  pack_info::eviction_guard eg { info, !ap->flagged_p (array::nonref_flag) };
  for (array::iterator it { interp, obj }; it.valid (); ++it)
    { ret += KP_TRY (xpack (interp, strm, *it, info)); }

  return (ret);
}

result<object> unpack_a (interpreter *interp, stream *strm,
                         pack_info& info, bool save)
{
  uint32_t len = KP_TRY (strm->getb (interp));
  if ((int)len < 0)
    return (info.error ("invalid array length"));
  else if (len == 0)
    {
      bool rv = KP_TRY (strm->sread (interp, &len));
      if (!rv)
        return (info.error ("invalid array length"));
    }

  raw_acc<array> ax (len);
  array *ret = ax.get ();
  valref obr (interp, ret->as_obj ());

  if (save)
    KP_VTRY (info.add_mapping (interp, *info.offset, *obr));

  for (ret->len = 0; ret->len < len; ++ret->len)
    { ret->data[ret->len] = KP_TRY (xunpack (interp, strm, info)); }

  ax.release ();
  interp->retval = *obr;
  gc_register (interp, ret, sizeof (*ret) + ret->len * sizeof (object));
  return (interp->retval);
}

static int
do_init_array (interpreter *)
{
  empty_array.vo_full = FLAGS_CONST;
  empty_array.vo_type = typecode::ARRAY;
  return (init_op::result_ok);
}

init_op init_array (do_init_array, "array");

KP_DECLS_END