picrin/lib/load.c

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

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

struct irep *
assemble(pic_state *pic, pic_value as)
{
  pic_value codes, reps, objs;
  int argc, varg, frame_size, repc, objc, i;
  struct irep **irep, *ir;
  pic_value *obj, r, it;
  code_t *code;
  size_t ai = pic_enter(pic);

  codes = pic_list_ref(pic, as, 0);
  reps = pic_list_ref(pic, as, 1);
  objs = pic_list_ref(pic, as, 2);
  argc = pic_int(pic, pic_car(pic, pic_list_ref(pic, as, 3)));
  varg = pic_bool(pic, pic_cdr(pic, pic_list_ref(pic, as, 3)));
  frame_size = pic_int(pic, pic_list_ref(pic, as, 4));

  repc = pic_length(pic, reps);
  objc = pic_length(pic, objs);

  assert(0 <= argc && argc < 256);
  assert(0 <= frame_size && frame_size < 256);
  assert(0 <= repc && repc < 256);
  assert(0 <= objc && objc < 256);

  irep = pic_malloc(pic, sizeof(*irep) * repc);
  i = 0;
  pic_for_each (r, reps, it) {
    irep[i++] = assemble(pic, r);
  }
  obj = pic_malloc(pic, sizeof(*obj) * objc);
  i = 0;
  pic_for_each (r, objs, it) {
    obj[i++] = r;
  }
  i = 0;
  pic_for_each (r, codes, it) {
    if (! pic_pair_p(pic, r))
      continue;
    if (pic_eq_p(pic, pic_car(pic, r), pic_intern_lit(pic, "COND"))) {
      i += 4;
      continue;
    }
    i += pic_length(pic, r);
  }
  code = pic_malloc(pic, i);
  i = 0;
  /* TODO: validate operands */
  pic_for_each (r, codes, it) {
    pic_value op;
    if (! pic_pair_p(pic, r))
      continue;
    op = pic_car(pic, r);
    if (pic_eq_p(pic, op, pic_intern_lit(pic, "HALT"))) {
      code[i++] = OP_HALT;
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "CALL"))) {
      code[i++] = OP_CALL;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "PROC"))) {
      code[i++] = OP_PROC;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOAD"))) {
      code[i++] = OP_LOAD;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LREF"))) {
      code[i++] = OP_LREF;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 3));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LSET"))) {
      code[i++] = OP_LSET;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 3));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "GREF"))) {
      code[i++] = OP_GREF;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "GSET"))) {
      code[i++] = OP_GSET;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "COND"))) {
      pic_value label = pic_list_ref(pic, r, 2);
      pic_value x, it2;
      int offset = 0;
      pic_for_each (x, it, it2) {
        if (pic_eq_p(pic, x, label))
          break;
        if (! pic_pair_p(pic, x))
          continue;
        if (pic_eq_p(pic, pic_car(pic, x), pic_intern_lit(pic, "COND"))) {
          offset += 4;
          continue;
        }
        offset += pic_length(pic, x);
      }
      code[i++] = OP_COND;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = offset % 256;
      code[i++] = offset / 256;
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADT"))) {
      code[i++] = OP_LOADT;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADF"))) {
      code[i++] = OP_LOADF;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADN"))) {
      code[i++] = OP_LOADN;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADU"))) {
      code[i++] = OP_LOADU;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
    }
    else if (pic_eq_p(pic, op, pic_intern_lit(pic, "LOADI"))) {
      code[i++] = OP_LOADI;
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 1));
      code[i++] = pic_int(pic, pic_list_ref(pic, r, 2));
    }
  }

  ir = (struct irep *)pic_obj_alloc(pic, PIC_TYPE_IREP);
  ir->argc = argc;
  ir->flags = (varg ? IREP_VARG : 0);
  ir->frame_size = frame_size;
  ir->irepc = repc;
  ir->objc = objc;
  ir->irep = irep;
  ir->obj = obj;
  ir->code = code;

  pic_leave(pic, ai);
  pic_protect(pic, obj_value(pic, ir));

  return ir;
}

static pic_value
execute(pic_state *pic, struct irep *irep)
{
  struct proc *proc;

  proc = (struct proc *)pic_obj_alloc(pic, PIC_TYPE_PROC_IREP);
  proc->u.irep = irep;
  proc->env = NULL;
  return pic_apply(pic, obj_value(pic, proc), 0, NULL);
}

pic_value
pic_load(pic_state *pic, pic_value expr)
{
  return execute(pic, assemble(pic, expr));
}

void
pic_load_native(pic_state *pic, const char *str)
{
  pic_value e, port = pic_fmemopen(pic, str, strlen(str), "r");

  pic_try {
    size_t ai = pic_enter(pic);
    pic_load(pic, pic_funcall(pic, "read", 1, port));
    pic_leave(pic, ai);
  }
  pic_catch(e) {
    pic_fclose(pic, port);
    pic_raise(pic, e);
  }
  pic_fclose(pic, port);
}

static pic_value
pic_load_load(pic_state *pic)
{
  pic_value program;

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

  return pic_load(pic, program);
}

void
pic_init_load(pic_state *pic)
{
  pic_defun(pic, "load", pic_load_load);
}