khipu/function.hpp

/* Declarations for the function 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/>.  */

#ifndef __KP_FUNCTION__
#define __KP_FUNCTION__   1

#include "interp.hpp"

KP_DECLS_BEGIN

struct function_base : public varobj
{
  static const int native_flag = 1 << 16;
  static const int artificial_flag = 1 << 17;
  static const int kwargs_flag = 1 << 18;
  static const int genericfn_flag = 1 << 19;

  static const int code = typecode::FCT;

  int min_argc;
  int max_argc;
  object name;

  result<bool> test_nargs (interpreter *interp, uint32_t n,
                           bool raise = true) const
    {
      if (n >= (uint32_t)this->min_argc && n <= (uint32_t)this->max_argc)
        return (true);
      else if (!raise)
        return (false);

      return (interp->raise_nargs (this->name, this->min_argc,
                                   this->max_argc, n));
    }

  void local_init ()
    {
      this->vo_full = 0;
      this->vo_type = typecode::FCT;
    }
};

struct native_function : public function_base
{
  typedef result<object> (*fn_type) (interpreter *, object *, int);

  fn_type fct;

  result<object> call (interpreter *interp, object *argv, int argc)
    {
      return (this->fct (interp, argv, argc));
    }

  result<object> call (interpreter *interp, int argc)
    {
      call_guard g (interp, argc + 1);
      KP_VTRY (interp->push_frame (NIL, argc, 0),
               this->test_nargs (interp, argc));
      return (this->fct (interp, interp->stkend - argc -
                         interpreter::frame_size, argc));
    }
};

struct function : public function_base
{
  int max_sp;
  object bcode;
  object vals;
  object env;

  int max_stack () const;

  void copy_into (function *fp)
    {
      fp->vo_full |= this->vo_full;
      fp->max_sp = this->max_sp;
      fp->min_argc = this->min_argc;
      fp->max_argc = this->max_argc;
      fp->bcode = this->bcode;
      fp->vals = this->vals;
      fp->env = this->env;
    }
};

inline function* as_fct (object obj)
{
  return ((function *)unmask (obj));
}

#ifdef KP_ARCH_WIDE

inline constexpr bool fct_p (object obj)
{
  return (itype (obj) == typecode::FCT);
}

#else

inline bool fct_p (object obj)
{
  return (varobj_p (obj) && as_varobj(obj)->vo_type == typecode::FCT);
}

#endif

inline object& fct_bcode (object obj)
{
  return (as_fct(obj)->bcode);
}

inline object& fct_vals (object obj)
{
  return (as_fct(obj)->vals);
}

inline object& fct_env (object obj)
{
  return (as_fct(obj)->env);
}

inline native_function* as_native_fct (object obj)
{
  return ((native_function *)unmask (obj));
}

inline bool native_fct_p (object obj)
{
  return (fct_p (obj) &&
          as_fct(obj)->flagged_p (function_base::native_flag));
}

inline object& fct_name (object obj)
{
  return (((function_base *)unmask (obj))->name);
}

// Get the name of FCT as a C-string.
KP_EXPORT const char* fct_sname (object fct);

// Allocate a function with flags FLAGS.
KP_EXPORT result<object> alloc_fct (interpreter *interp, uint32_t flags = 0);

// Test for function equality.
KP_EXPORT bool eq_xx (interpreter *interp, object x, object y);

// Compile the expression EXPR and return a thunk.
KP_EXPORT result<object> compile_expr (interpreter *interp, object expr);

// Evaluate the expression EXPR.
KP_EXPORT result<object> eval (interpreter *interp, object expr);

// Return the single macro-expansion of EXPR in environment ENV.
KP_EXPORT result<object> macroexp_1 (interpreter *interp,
                                     object expr, object env = NIL);

// Return the full macro-expansion of EXPR in environment ENV.
KP_EXPORT result<object> macroexp (interpreter *interp,
                                   object expr, object env = NIL);

// Call function after having pushed it and its N arguments on the stack.
KP_EXPORT result<object> call_n (interpreter *interp, uint32_t n);

// Compute the needed stack size for function FCT.
KP_EXPORT int fct_stacksize (object fct);

// Write a function to a stream.
KP_EXPORT result<int64_t> write_x (interpreter *interp,
                                   stream *strm, object obj, io_info& info);

// Serialize a function in a stream.
KP_EXPORT result<int64_t> pack_x (interpreter *interp,
                                  stream *strm, object obj, pack_info& info);

// Deserialize a function in a stream.
KP_EXPORT result<object> unpack_x (interpreter *interp,
                                   stream *strm, pack_info& info, bool save);

// Disassemble the function FN and write the instructions to OUT.
KP_EXPORT result<void> disasm (interpreter *interp, object fn, object out);

// Get the builtin index for function named NAME.
KP_EXPORT int builtin_idx (interpreter *interp, const char *name);

// Return the builtin function for NAME.
KP_EXPORT object builtin_fct (interpreter *interp, const char *name);

// Return the builtin function with index IDX.
KP_EXPORT object builtin_fct (interpreter *interp, int idx);

// Helper for the implementation of multimethods.
KP_EXPORT result<object> p_meth_ctl (interpreter *interp,
                                     object *argv, int argc);

// Try to call method with ARGC arguments on the stack.
KP_EXPORT result<bool> method_call (interpreter *interp, uint32_t argc);

// Helpers for the KP_CALL macro.

inline int push_all_helper (interpreter *)
{
  return (0);
}

template <typename A1, typename ...Args>
inline result<void> push_all_helper (interpreter *interp, A1 a1, Args... args)
{
  object tmp = KP_TRY (a1 ());
  *interp->stkend++ = tmp;
  KP_VTRY (push_all_helper (interp, args...));
  return (0);
}

template <typename ...Args>
result<void> push_all (interpreter *interp, Args... args)
{
  KP_VTRY (interp->growstk (sizeof... (args)));
  return (push_all_helper (interp, args...));
}

template <typename ...Args>
result<object> call_helper (interpreter *interp, object fn, Args... args)
{
  uint32_t sp = interp->stklen ();
  KP_VTRY (interp->growstk (1 + sizeof... (args)));
  *interp->stkend++ = fn;
  KP_VTRY (push_all_helper (interp, args...));
  return (call_n (interp, interp->stklen () - sp - 1));
}

template <typename ...Args>
result<object> call_helper (interpreter *interp, native_function::fn_type fn,
                            Args... args)
{
  sp_guard sg { interp };
  uint32_t sp = interp->stklen ();
  KP_VTRY (push_all (interp, args...));
  return (fn (interp, interp->stack + sp, interp->stklen () - sp));
}

#define KP_CALL0(Interp, Base, Fn)   \
  Base ((Interp), (Fn))

#define KP_CALL1(Interp, Base, Fn, A1)   \
  Base ((Interp), (Fn), [&] () { return (A1); })

#define KP_CALL2(Interp, Base, Fn, A1, A2)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); })

#define KP_CALL3(Interp, Base, Fn, A1, A2, A3)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); },   \
        [&] () { return (A3); })

#define KP_CALL4(Interp, Base, Fn, A1, A2, A3, A4)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); },   \
        [&] () { return (A3); },   \
        [&] () { return (A4); })

#define KP_CALL5(Interp, Base, Fn, A1, A2, A3, A4, A5)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); },   \
        [&] () { return (A3); },   \
        [&] () { return (A4); },   \
        [&] () { return (A5); })

#define KP_CALL6(Interp, Base, Fn, A1, A2, A3, A4, A5, A6)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); },   \
        [&] () { return (A3); },   \
        [&] () { return (A4); },   \
        [&] () { return (A5); },   \
        [&] () { return (A6); })

#define KP_CALL7(Interp, Base, Fn, A1, A2, A3, A4, A5, A6, A7)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); },   \
        [&] () { return (A3); },   \
        [&] () { return (A4); },   \
        [&] () { return (A5); },   \
        [&] () { return (A6); },   \
        [&] () { return (A7); })

#define KP_CALL8(Interp, Base, Fn, A1, A2, A3, A4, A5, A6, A8)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); },   \
        [&] () { return (A3); },   \
        [&] () { return (A4); },   \
        [&] () { return (A5); },   \
        [&] () { return (A6); },   \
        [&] () { return (A7); },   \
        [&] () { return (A8); })

#define KP_CALL9(Interp, Base, Fn, A1, A2, A3, A4, A5, A6, A8, A9)   \
  Base ((Interp), (Fn),   \
        [&] () { return (A1); },   \
        [&] () { return (A2); },   \
        [&] () { return (A3); },   \
        [&] () { return (A4); },   \
        [&] () { return (A5); },   \
        [&] () { return (A6); },   \
        [&] () { return (A7); },   \
        [&] () { return (A8); },   \
        [&] () { return (A9); })

#define KP_CALL(Interp, Fn, ...)   \
  KP_CALL_DISP (KP_CALL, (Interp), call_helper, (Fn), ##__VA_ARGS__)

#define KP_PUSH_ALL(Interp, Expr, ...)   \
  KP_VTRY (KP_CALL_DISP (KP_CALL, (Interp), push_all,   \
                         [&] () { return (Expr); }, ##__VA_ARGS__))

struct kwpair
{
  union
    {
      const char *name;
      object *obj;
    };
  bool is_name;

  kwpair (const char *cs) : name (cs), is_name (true)
    {
    }

  kwpair (object *ptr) : obj (ptr), is_name (false)
    {
    }
};

KP_EXPORT result<void> kwargs_parse_pairs (interpreter *interp, object *argv,
                                           int argc, kwpair *pairs, int npairs);

template <typename ...Args>
result<void> kwargs_parse (interpreter *interp, object *argv,
                           int argc, Args... args)
{
  kwpair pairs[] = { args... };
  return (kwargs_parse_pairs (interp, argv, argc, pairs, KP_NELEM (pairs)));
}

KP_DECLS_END

#endif