khipu/custom.cpp

/* Definitions for custom, native types.

   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 <new>
#include "custom.hpp"
#include "memory.hpp"
#include "str.hpp"
#include "symbol.hpp"
#include "types.hpp"
#include "thread.hpp"

KP_DECLS_BEGIN

custom_base* custom_base::alloc_raw (size_t size)
{
  /* We cannot use 'alloch', because it allocates and initializes a varobj,
   * disregarding any adjustments that must be made by a class with virtual
   * methods. So we inline the needed part here. */
  auto ret = (custom_base *)ensure_mask_impl (xmalloc (size), TYPE_SHIFT);
  ret->vo_size = (uint32_t)size;
  return (ret);
}

static result<void>
check_custom_type (interpreter *interp, object *tp,
                   object name, custom_base *bp)
{
  if (!tp)
    return (interp->raise ("arg-error", "type descriptor must not be null"));

  object ty = *tp;
  valref parents (interp, NIL), slots (interp, NIL);

  if (ty != 0)
    {
    check:
      if (type_name (ty) != name)
        return (interp->raise ("arg-error", "different names used for "
                                            "the same custom type"));

      return (0);
    }

  bp->fill_type (interp, *parents, *slots);
  object rt = KP_TRY (type (interp, name, *parents, *slots));

  if (singlethr_p ())
    *tp = rt;
  else if (!atomic_cas_bool ((atomic_t *)tp, ty, rt))
    goto check;
  return (0);
}

result<custom_base*> custom_base::xalloc (interpreter *interp, object *tp,
                                          const char *name, custom_base *bp,
                                          constructor cfn)
{
  valref tname = KP_TRY (intern (interp, name));
  return (custom_base::xalloc (interp, tp, *tname, bp, cfn));
}

result<custom_base*> custom_base::xalloc (interpreter *interp, object *tp,
                                          const char *name, uint32_t len,
                                          custom_base *bp, constructor cfn)
{
  valref tname = KP_TRY (intern (interp, name, len));
  return (custom_base::xalloc (interp, tp, *tname, bp, cfn));
}

result<custom_base*> custom_base::xalloc (interpreter *interp, object *tp,
                                          object name, custom_base *ret,
                                          constructor cfn)
{
  if (!symbol_p (name))
    return (interp->raise ("arg-error",
                           "type name must be a string or symbol"));

  try
    {
      cfn (ret);
    }
  catch (...)
    {
      destroy (ret);
      xfree (ret);
      return (interp->raise ("runtime-error",
                             "failed to construct custom object"));
    }

  auto rv = check_custom_type (interp, tp, name, ret);
  if (rv.error_p ())
    {
      destroy (ret);
      xfree (ret);
      return (exception ());
    }

  ret->vo_full = 0;
  ret->vo_type = typecode::CUSTOM;
  ret->fini = nullptr;
  ret->type_ptr = tp;
  interp->alval = ret->as_obj ();
  gc_register (interp, ret, ret->vo_size);
  return (ret);
}

KP_DECLS_END