picrin/lib/proc.c

/**
 * See Copyright Notice in picrin.h
 */

#include "picrin.h"
#include "picrin/extra.h"
#include "picrin/private/object.h"
#include "picrin/private/vm.h"
#include "picrin/private/state.h"

#define MIN(x,y) ((x) < (y) ? (x) : (y))

PIC_NORETURN static void
arg_error(pic_state *pic, int actual, bool varg, int expected)
{
  const char *msg;

  msg = pic_str(pic, pic_strf_value(pic, "wrong number of arguments (%d for %s%d)", actual, (varg ? "at least " : ""), expected));

  pic_error(pic, msg, 0);
}

#define GET_OPERAND(pic,n) ((pic)->ci->fp[(n)])

/**
 * char type                    desc.
 * ---- ----                    ----
 *  o   pic_value *             object
 *  i   int *                   int
 *  I   int *, bool *           int with exactness
 *  f   double *                float
 *  F   double *, bool *        float with exactness
 *  c   char *                  char
 *  z   char **                 c string
 *  b   unsigned char *, int *  bytevector
 *  u   void **, const pic_data_type *  user data type
 *  m   pic_value *             symbol
 *  v   pic_value *             vector
 *  s   pic_value *             string
 *  l   pic_value *             lambda
 *  p   pic_value *             port
 *  d   pic_value *             dictionary
 *  r   pic_value *             record
 *
 *  +                           aliasing operator
 *  |                           optional operator
 *  *   int *, pic_value **     variable length operator
 * ---- ----                    ----
 */

int
pic_get_args(pic_state *pic, const char *format, ...)
{
  char c;
  const char *p = format;
  int paramc = 0, optc = 0;
  int i, argc = pic->ci->argc - 1;
  va_list ap;
  bool proc = 0, rest = 0, opt = 0;

  /* parse format */
  if ((c = *p) != '\0') {
    if (c == '&') {
      proc = 1;
      p++;
    }
    while ((c = *p++) != '\0') {
      if (c == '+')
        continue;
      if (c == '|') {
        opt = 1; break;
      } else if (c == '*') {
        rest = 1; break;
      }
      paramc++;
    }
    if (opt) {
      while ((c = *p++) != '\0') {
        if (c == '+')
          continue;
        if (c == '*') {
          rest = 1; break;
        }
        optc++;
      }
    }
    if (rest) c = *p++;
    assert(opt <= optc); /* at least 1 char after '|'? */
    assert(c == '\0');   /* no extra chars? */
  }

  if (argc < paramc || (paramc + optc < argc && ! rest)) {
    arg_error(pic, argc, rest, paramc);
  }

  va_start(ap, format);

  /* dispatch */
  if (proc) {
    pic_value *proc;

    proc = va_arg(ap, pic_value *);
    *proc = GET_OPERAND(pic, 0);
    format++;                   /* skip '&' */
  }
  for (i = 1; i <= MIN(paramc + optc, argc); ++i) {

    c = *format++;
    if (c == '|') {
      c = *format++;
    }

    switch (c) {
    case 'o': {
      pic_value *p;

      p = va_arg(ap, pic_value*);
      *p = GET_OPERAND(pic, i);
      break;
    }

    case 'u': {
      void **data;
      const pic_data_type *type;
      pic_value v;

      data = va_arg(ap, void **);
      type = va_arg(ap, const pic_data_type *);
      v = GET_OPERAND(pic, i);
      if (pic_data_p(pic, v, type)) {
        *data = pic_data(pic, v);
      }
      else {
        const char *msg;
        msg = pic_str(pic, pic_strf_value(pic, "pic_get_args: data type \"%s\" required", type->type_name));
        pic_error(pic, msg, 1, v);
      }
      break;
    }

    case 'b': {
      unsigned char **buf;
      int *len;
      pic_value v;

      buf = va_arg(ap, unsigned char **);
      len = va_arg(ap, int *);
      v = GET_OPERAND(pic, i);
      if (pic_blob_p(pic, v)) {
        unsigned char *tmp = pic_blob(pic, v, len);
        if (buf) *buf = tmp;
      }
      else {
        pic_error(pic, "pic_get_args: bytevector required", 1, v);
      }
      break;
    }

#define NUM_CASE(c1, c2, ctype)                                         \
      case c1: case c2: {                                               \
        ctype *n;                                                       \
        bool *e, dummy;                                                 \
        pic_value v;                                                    \
                                                                        \
        n = va_arg(ap, ctype *);                                        \
        e = (c == c2 ? va_arg(ap, bool *) : &dummy);                    \
                                                                        \
        v = GET_OPERAND(pic, i);                                        \
        switch (pic_type(pic, v)) {                                     \
        case PIC_TYPE_FLOAT:                                            \
          *n = pic_float(pic, v);                                       \
          *e = false;                                                   \
          break;                                                        \
        case PIC_TYPE_INT:                                              \
          *n = pic_int(pic, v);                                         \
          *e = true;                                                    \
          break;                                                        \
        default:                                                        \
          pic_error(pic, "pic_get_args: float or int required", 1, v);  \
        }                                                               \
        break;                                                          \
      }

    NUM_CASE('i', 'I', int)
    NUM_CASE('f', 'F', double)

#define VAL_CASE(c, type, ctype, conv)                                  \
      case c: {                                                         \
        ctype *ptr;                                                     \
        pic_value v;                                                    \
                                                                        \
        ptr = va_arg(ap, ctype *);                                      \
        v = GET_OPERAND(pic, i);                                        \
        if (pic_## type ##_p(pic, v)) {                                 \
          *ptr = conv;                                                  \
        }                                                               \
        else {                                                          \
          pic_error(pic, "pic_get_args: " #type " required", 1, v);     \
        }                                                               \
        break;                                                          \
      }

    VAL_CASE('c', char, char, pic_char(pic, v))
    VAL_CASE('z', str, const char *, pic_str(pic, v))

#define OBJ_CASE(c, type) VAL_CASE(c, type, pic_value, v)

    OBJ_CASE('m', sym)
    OBJ_CASE('s', str)
    OBJ_CASE('l', proc)
    OBJ_CASE('v', vec)
    OBJ_CASE('d', dict)
    OBJ_CASE('p', port)
    OBJ_CASE('r', rec)

    default:
      pic_error(pic, "pic_get_args: invalid argument specifier given", 1, pic_char_value(pic, c));
    }

    if (*format == '+') {
      pic_value *p;
      format++;
      p = va_arg(ap, pic_value*);
      *p = GET_OPERAND(pic, i);
    }
  }
  if (rest) {
    int *n;
    pic_value **argv;

    n = va_arg(ap, int *);
    argv = va_arg(ap, pic_value **);
    *n = argc - (i - 1);
    *argv = &GET_OPERAND(pic, i);
  }

  va_end(ap);

  return argc;
}

static pic_value
global_ref(pic_state *pic, pic_value uid)
{
  pic_value val;

  if (! pic_weak_has(pic, pic->globals, uid)) {
    pic_error(pic, "undefined variable", 1, uid);
  }
  val = pic_weak_ref(pic, pic->globals, uid);;
  if (pic_invalid_p(pic, val)) {
    pic_error(pic, "uninitialized global variable", 1, uid);
  }
  return val;
}

static void
global_set(pic_state *pic, pic_value uid, pic_value value)
{
  if (! pic_weak_has(pic, pic->globals, uid)) {
    pic_error(pic, "undefined variable", 1, uid);
  }
  pic_weak_set(pic, pic->globals, uid, value);
}

static void
vm_push_cxt(pic_state *pic)
{
  struct callinfo *ci = pic->ci;

  ci->cxt = (struct context *)pic_obj_alloc(pic, offsetof(struct context, storage) + sizeof(pic_value) * ci->regc, PIC_TYPE_CXT);
  ci->cxt->up = ci->up;
  ci->cxt->regc = ci->regc;
  ci->cxt->regs = ci->regs;
}

static void
vm_tear_off(struct callinfo *ci)
{
  struct context *cxt;
  int i;

  assert(ci->cxt != NULL);

  cxt = ci->cxt;

  if (cxt->regs == cxt->storage) {
    return;                     /* is torn off */
  }
  for (i = 0; i < cxt->regc; ++i) {
    cxt->storage[i] = cxt->regs[i];
  }
  cxt->regs = cxt->storage;
}

void
pic_vm_tear_off(pic_state *pic)
{
  struct callinfo *ci;

  for (ci = pic->ci; ci > pic->cibase; ci--) {
    if (ci->cxt != NULL) {
      vm_tear_off(ci);
    }
  }
}

#if PIC_DIRECT_THREADED_VM
# define VM_LOOP JUMP;
# define CASE(x) L_##x:
# define NEXT pic->ip++; JUMP;
# define JUMP c = *pic->ip; goto *oplabels[c.insn];
# define VM_LOOP_END
#else
# define VM_LOOP for (;;) { c = *pic->ip; switch (c.insn) {
# define CASE(x) case x:
# define NEXT pic->ip++; break
# define JUMP break
# define VM_LOOP_END } }
#endif

#define PUSH(v) (*pic->sp++ = (v))
#define POP() (*--pic->sp)

#define PUSHCI() (++pic->ci)
#define POPCI() (pic->ci--)

/* for arithmetic instructions */
pic_value pic_add(pic_state *, pic_value, pic_value);
pic_value pic_sub(pic_state *, pic_value, pic_value);
pic_value pic_mul(pic_state *, pic_value, pic_value);
pic_value pic_div(pic_state *, pic_value, pic_value);
bool pic_eq(pic_state *, pic_value, pic_value);
bool pic_lt(pic_state *, pic_value, pic_value);
bool pic_le(pic_state *, pic_value, pic_value);
bool pic_gt(pic_state *, pic_value, pic_value);
bool pic_ge(pic_state *, pic_value, pic_value);

pic_value
pic_apply(pic_state *pic, pic_value proc, int argc, pic_value *argv)
{
  struct code c;
  size_t ai = pic_enter(pic);
  struct code boot[2];
  int i;

#if PIC_DIRECT_THREADED_VM
  static const void *oplabels[] = {
    &&L_OP_NOP, &&L_OP_POP, &&L_OP_PUSHUNDEF, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE,
    &&L_OP_PUSHFALSE, &&L_OP_PUSHINT, &&L_OP_PUSHFLOAT,
    &&L_OP_PUSHCHAR, &&L_OP_PUSHEOF, &&L_OP_PUSHCONST,
    &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET,
    &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_NOT, &&L_OP_CALL, &&L_OP_TAILCALL, &&L_OP_RET,
    &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
    &&L_OP_SYMBOLP, &&L_OP_PAIRP,
    &&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV,
    &&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_GT, &&L_OP_GE, &&L_OP_STOP
  };
#endif

  PUSH(proc);

  for (i = 0; i < argc; ++i) {
    PUSH(argv[i]);
  }

  /* boot! */
  boot[0].insn = OP_CALL;
  boot[0].a = argc + 1;
  boot[1].insn = OP_STOP;
  pic->ip = boot;

  VM_LOOP {
    CASE(OP_NOP) {
      NEXT;
    }
    CASE(OP_POP) {
      (void)(POP());
      NEXT;
    }
    CASE(OP_PUSHUNDEF) {
      PUSH(pic_undef_value(pic));
      NEXT;
    }
    CASE(OP_PUSHNIL) {
      PUSH(pic_nil_value(pic));
      NEXT;
    }
    CASE(OP_PUSHTRUE) {
      PUSH(pic_true_value(pic));
      NEXT;
    }
    CASE(OP_PUSHFALSE) {
      PUSH(pic_false_value(pic));
      NEXT;
    }
    CASE(OP_PUSHINT) {
      PUSH(pic_int_value(pic, pic->ci->irep->ints[c.a]));
      NEXT;
    }
    CASE(OP_PUSHFLOAT) {
      PUSH(pic_float_value(pic, pic->ci->irep->nums[c.a]));
      NEXT;
    }
    CASE(OP_PUSHCHAR) {
      PUSH(pic_char_value(pic, pic->ci->irep->ints[c.a]));
      NEXT;
    }
    CASE(OP_PUSHEOF) {
      PUSH(pic_eof_object(pic));
      NEXT;
    }
    CASE(OP_PUSHCONST) {
      PUSH(pic_obj_value(pic->ci->irep->pool[c.a]));
      NEXT;
    }
    CASE(OP_GREF) {
      PUSH(global_ref(pic, pic_obj_value(pic->ci->irep->pool[c.a])));
      NEXT;
    }
    CASE(OP_GSET) {
      global_set(pic, pic_obj_value(pic->ci->irep->pool[c.a]), POP());
      PUSH(pic_undef_value(pic));
      NEXT;
    }
    CASE(OP_LREF) {
      struct callinfo *ci = pic->ci;
      struct irep *irep = ci->irep;

      if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) {
        if (c.a >= irep->argc + irep->localc) {
          PUSH(ci->cxt->regs[c.a - (ci->regs - ci->fp)]);
          NEXT;
        }
      }
      PUSH(pic->ci->fp[c.a]);
      NEXT;
    }
    CASE(OP_LSET) {
      struct callinfo *ci = pic->ci;
      struct irep *irep = ci->irep;

      if (ci->cxt != NULL && ci->cxt->regs == ci->cxt->storage) {
        if (c.a >= irep->argc + irep->localc) {
          ci->cxt->regs[c.a - (ci->regs - ci->fp)] = POP();
          PUSH(pic_undef_value(pic));
          NEXT;
        }
      }
      pic->ci->fp[c.a] = POP();
      PUSH(pic_undef_value(pic));
      NEXT;
    }
    CASE(OP_CREF) {
      int depth = c.a;
      struct context *cxt;

      cxt = pic->ci->up;
      while (--depth) {
	cxt = cxt->up;
      }
      PUSH(cxt->regs[c.b]);
      NEXT;
    }
    CASE(OP_CSET) {
      int depth = c.a;
      struct context *cxt;

      cxt = pic->ci->up;
      while (--depth) {
	cxt = cxt->up;
      }
      cxt->regs[c.b] = POP();
      PUSH(pic_undef_value(pic));
      NEXT;
    }
    CASE(OP_JMP) {
      pic->ip += c.a;
      JUMP;
    }
    CASE(OP_JMPIF) {
      pic_value v;

      v = POP();
      if (! pic_false_p(pic, v)) {
	pic->ip += c.a;
	JUMP;
      }
      NEXT;
    }
    CASE(OP_CALL) {
      pic_value x, v;
      struct callinfo *ci;
      struct proc *proc;

      if (c.a == -1) {
        pic->sp += pic->ci[1].retc - 1;
        c.a = pic->ci[1].retc + 1;
      }

    L_CALL:
      x = pic->sp[-c.a];
      if (! pic_proc_p(pic, x)) {
	pic_error(pic, "invalid application", 1, x);
      }
      proc = pic_proc_ptr(pic, x);

      if (pic->sp >= pic->stend) {
        pic_panic(pic, "VM stack overflow");
      }

      ci = PUSHCI();
      ci->argc = c.a;
      ci->retc = 1;
      ci->ip = pic->ip;
      ci->fp = pic->sp - c.a;
      ci->irep = NULL;
      ci->cxt = NULL;
      if (proc->tt == PIC_TYPE_FUNC) {

        /* invoke! */
        v = proc->u.f.func(pic);
        pic->sp[0] = v;
        pic->sp += pic->ci->retc;

        pic_leave(pic, ai);
        goto L_RET;
      }
      else {
        struct irep *irep = proc->u.i.irep;
	int i;
	pic_value rest;

        ci->irep = irep;
	if (ci->argc != irep->argc) {
	  if (! (irep->varg && ci->argc >= irep->argc)) {
            arg_error(pic, ci->argc - 1, irep->varg, irep->argc - 1);
	  }
	}
	/* prepare rest args */
	if (irep->varg) {
	  rest = pic_nil_value(pic);
	  for (i = 0; i < ci->argc - irep->argc; ++i) {
	    pic_protect(pic, v = POP());
	    rest = pic_cons(pic, v, rest);
	  }
	  PUSH(rest);
	}
	/* prepare local variable area */
	if (irep->localc > 0) {
	  int l = irep->localc;
	  if (irep->varg) {
	    --l;
	  }
	  for (i = 0; i < l; ++i) {
	    PUSH(pic_undef_value(pic));
	  }
	}

	/* prepare cxt */
        ci->up = proc->u.i.cxt;
        ci->regc = irep->capturec;
        ci->regs = ci->fp + irep->argc + irep->localc;

	pic->ip = irep->code;
	pic_leave(pic, ai);
	JUMP;
      }
    }
    CASE(OP_TAILCALL) {
      int i, argc;
      pic_value *argv;
      struct callinfo *ci;

      if (pic->ci->cxt != NULL) {
        vm_tear_off(pic->ci);
      }

      if (c.a == -1) {
        pic->sp += pic->ci[1].retc - 1;
        c.a = pic->ci[1].retc + 1;
      }

      argc = c.a;
      argv = pic->sp - argc;
      for (i = 0; i < argc; ++i) {
	pic->ci->fp[i] = argv[i];
      }
      ci = POPCI();
      pic->sp = ci->fp + argc;
      pic->ip = ci->ip;

      /* c is not changed */
      goto L_CALL;
    }
    CASE(OP_RET) {
      int i, retc;
      pic_value *retv;
      struct callinfo *ci;

      if (pic->ci->cxt != NULL) {
        vm_tear_off(pic->ci);
      }

      assert(pic->ci->retc == 1);

    L_RET:
      retc = pic->ci->retc;
      retv = pic->sp - retc;
      if (retc == 0) {
        pic->ci->fp[0] = retv[0]; /* copy at least once */
      }
      for (i = 0; i < retc; ++i) {
        pic->ci->fp[i] = retv[i];
      }
      ci = POPCI();
      pic->sp = ci->fp + 1;     /* advance only one! */
      pic->ip = ci->ip;

      NEXT;
    }
    CASE(OP_LAMBDA) {
      if (pic->ci->cxt == NULL) {
        vm_push_cxt(pic);
      }

      PUSH(pic_make_proc_irep(pic, pic->ci->irep->irep[c.a], pic->ci->cxt));
      pic_leave(pic, ai);
      NEXT;
    }

    CASE(OP_CONS) {
      pic_value a, b;
      pic_protect(pic, b = POP());
      pic_protect(pic, a = POP());
      PUSH(pic_cons(pic, a, b));
      pic_leave(pic, ai);
      NEXT;
    }
    CASE(OP_CAR) {
      pic_value p;
      p = POP();
      PUSH(pic_car(pic, p));
      NEXT;
    }
    CASE(OP_CDR) {
      pic_value p;
      p = POP();
      PUSH(pic_cdr(pic, p));
      NEXT;
    }
    CASE(OP_NILP) {
      pic_value p;
      p = POP();
      PUSH(pic_bool_value(pic, pic_nil_p(pic, p)));
      NEXT;
    }
    CASE(OP_SYMBOLP) {
      pic_value p;
      p = POP();
      PUSH(pic_bool_value(pic, pic_sym_p(pic, p)));
      NEXT;
    }
    CASE(OP_PAIRP) {
      pic_value p;
      p = POP();
      PUSH(pic_bool_value(pic, pic_pair_p(pic, p)));
      NEXT;
    }
    CASE(OP_NOT) {
      pic_value v;
      v = pic_false_p(pic, POP()) ? pic_true_value(pic) : pic_false_value(pic);
      PUSH(v);
      NEXT;
    }

    CASE(OP_ADD) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_add(pic, a, b));
      NEXT;
    }
    CASE(OP_SUB) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_sub(pic, a, b));
      NEXT;
    }
    CASE(OP_MUL) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_mul(pic, a, b));
      NEXT;
    }
    CASE(OP_DIV) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_div(pic, a, b));
      NEXT;
    }
    CASE(OP_EQ) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_bool_value(pic, pic_eq(pic, a, b)));
      NEXT;
    }
    CASE(OP_LE) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_bool_value(pic, pic_le(pic, a, b)));
      NEXT;
    }
    CASE(OP_LT) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_bool_value(pic, pic_lt(pic, a, b)));
      NEXT;
    }
    CASE(OP_GE) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_bool_value(pic, pic_ge(pic, a, b)));
      NEXT;
    }
    CASE(OP_GT) {
      pic_value a, b;
      b = POP();
      a = POP();
      PUSH(pic_bool_value(pic, pic_gt(pic, a, b)));
      NEXT;
    }

    CASE(OP_STOP) {
      return pic_protect(pic, POP());
    }
  } VM_LOOP_END;
}

pic_value
pic_applyk(pic_state *pic, pic_value proc, int argc, pic_value *args)
{
  static const struct code iseq[2] = { { OP_NOP, 0, 0 }, { OP_TAILCALL, -1, 0 } };
  pic_value *sp;
  struct callinfo *ci;
  int i;

  *pic->sp++ = proc;

  sp = pic->sp;
  for (i = 0; i < argc; ++i) {
    *sp++ = args[i];
  }

  ci = PUSHCI();
  ci->ip = iseq;
  ci->fp = pic->sp;
  ci->retc = (int)argc;

  if (ci->retc == 0) {
    return pic_undef_value(pic);
  } else {
    return args[0];
  }
}

pic_value
pic_call(pic_state *pic, pic_value proc, int n, ...)
{
  pic_value r;
  va_list ap;

  va_start(ap, n);
  r = pic_vcall(pic, proc, n, ap);
  va_end(ap);
  return r;
}

pic_value
pic_vcall(pic_state *pic, pic_value proc, int n, va_list ap)
{
  pic_value *args = pic_alloca(pic, sizeof(pic_value) * n);
  int i;

  for (i = 0; i < n; ++i) {
    args[i] = va_arg(ap, pic_value);
  }
  return pic_apply(pic, proc, n, args);
}

pic_value
pic_lambda(pic_state *pic, pic_func_t f, int n, ...)
{
  pic_value proc;
  va_list ap;

  va_start(ap, n);
  proc = pic_vlambda(pic, f, n, ap);
  va_end(ap);
  return proc;
}

pic_value
pic_vlambda(pic_state *pic, pic_func_t f, int n, va_list ap)
{
  pic_value *env = pic_alloca(pic, sizeof(pic_value) * n);
  int i;

  for (i = 0; i < n; ++i) {
    env[i] = va_arg(ap, pic_value);
  }
  return pic_make_proc(pic, f, n, env);
}

void
pic_defun(pic_state *pic, const char *name, pic_func_t f)
{
  pic_define(pic, pic_current_library(pic), name, pic_make_proc(pic, f, 0, NULL));
  pic_export(pic, pic_intern_cstr(pic, name));
}

void
pic_defvar(pic_state *pic, const char *name, pic_value init, pic_value conv)
{
  pic_define(pic, pic_current_library(pic), name, pic_make_var(pic, init, conv));
  pic_export(pic, pic_intern_cstr(pic, name));
}

void
pic_define(pic_state *pic, const char *lib, const char *name, pic_value val)
{
  pic_value sym, uid, env;

  sym = pic_intern_cstr(pic, name);

  env = pic_library_environment(pic, lib);

  uid = pic_find_identifier(pic, sym, env);
  if (pic_weak_has(pic, pic->globals, uid)) {
    pic_warnf(pic, "redefining variable: %s", pic_sym(pic, uid));
  }
  pic_weak_set(pic, pic->globals, uid, val);
}

pic_value
pic_ref(pic_state *pic, const char *lib, const char *name)
{
  pic_value sym, env;

  sym = pic_intern_cstr(pic, name);

  env = pic_library_environment(pic, lib);

  return global_ref(pic, pic_find_identifier(pic, sym, env));
}

void
pic_set(pic_state *pic, const char *lib, const char *name, pic_value val)
{
  pic_value sym, env;

  sym = pic_intern_cstr(pic, name);

  env = pic_library_environment(pic, lib);

  global_set(pic, pic_find_identifier(pic, sym, env), val);
}

pic_value
pic_closure_ref(pic_state *pic, int n)
{
  pic_value self = GET_OPERAND(pic, 0);

  assert(pic_func_p(pic, self));

  if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) {
    pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));
  }
  return pic_proc_ptr(pic, self)->locals[n];
}

void
pic_closure_set(pic_state *pic, int n, pic_value v)
{
  pic_value self = GET_OPERAND(pic, 0);

  assert(pic_func_p(pic, self));

  if (n < 0 || pic_proc_ptr(pic, self)->u.f.localc <= n) {
    pic_error(pic, "pic_closure_ref: index out of range", 1, pic_int_value(pic, n));
  }
  pic_proc_ptr(pic, self)->locals[n] = v;
}

pic_value
pic_funcall(pic_state *pic, const char *lib, const char *name, int n, ...)
{
  pic_value proc, r;
  va_list ap;

  proc = pic_ref(pic, lib, name);

  TYPE_CHECK(pic, proc, proc);

  va_start(ap, n);
  r = pic_vcall(pic, proc, n, ap);
  va_end(ap);

  return r;
}

void
pic_irep_incref(pic_state *PIC_UNUSED(pic), struct irep *irep)
{
  irep->refc++;
}

void
pic_irep_decref(pic_state *pic, struct irep *irep)
{
  size_t i;

  if (--irep->refc == 0) {
    pic_free(pic, irep->code);
    pic_free(pic, irep->ints);
    pic_free(pic, irep->nums);
    pic_free(pic, irep->pool);

    /* unchain before decref children ireps */
    if (irep->list.prev) {      /* && irep->list.next */
      irep->list.prev->next = irep->list.next;
      irep->list.next->prev = irep->list.prev;
    }

    for (i = 0; i < irep->nirep; ++i) {
      pic_irep_decref(pic, irep->irep[i]);
    }
    pic_free(pic, irep->irep);
    pic_free(pic, irep);
  }
}

pic_value
pic_make_proc(pic_state *pic, pic_func_t func, int n, pic_value *env)
{
  struct proc *proc;
  int i;

  proc = (struct proc *)pic_obj_alloc(pic, offsetof(struct proc, locals) + sizeof(pic_value) * n, PIC_TYPE_FUNC);
  proc->u.f.func = func;
  proc->u.f.localc = n;
  for (i = 0; i < n; ++i) {
    proc->locals[i] = env[i];
  }
  return pic_obj_value(proc);
}

pic_value
pic_make_proc_irep(pic_state *pic, struct irep *irep, struct context *cxt)
{
  struct proc *proc;

  proc = (struct proc *)pic_obj_alloc(pic, offsetof(struct proc, locals), PIC_TYPE_IREP);
  proc->u.i.irep = irep;
  proc->u.i.cxt = cxt;
  pic_irep_incref(pic, irep);
  return pic_obj_value(proc);
}

static pic_value
pic_proc_proc_p(pic_state *pic)
{
  pic_value v;

  pic_get_args(pic, "o", &v);

  return pic_bool_value(pic, pic_proc_p(pic, v));
}

static pic_value
pic_proc_apply(pic_state *pic)
{
  pic_value proc, *args, *arg_list;
  int argc, n, i;

  pic_get_args(pic, "l*", &proc, &argc, &args);

  if (argc == 0) {
    pic_error(pic, "apply: wrong number of arguments", 0);
  }

  n = argc - 1 + pic_length(pic, args[argc - 1]);

  arg_list = pic_alloca(pic, sizeof(pic_value) * n);
  for (i = 0; i < argc - 1; ++i) {
    arg_list[i] = args[i];
  }
  while (i < n) {
    arg_list[i] = pic_list_ref(pic, args[argc - 1], i - argc + 1);
    i++;
  }
  return pic_applyk(pic, proc, n, arg_list);
}

void
pic_init_proc(pic_state *pic)
{
  pic_defun(pic, "procedure?", pic_proc_proc_p);
  pic_defun(pic, "apply", pic_proc_apply);
}