#include <stdlib.h>

typedef char* ID;
typedef long* VAL;

typedef enum {
  RET = 0,
  LIT = 1,
  APP,
  LOOK,
  PUSH,
  POP,
  BIND
} CODE;

typedef enum {
  ENV = 0,
  INT = 1,
  SEL = 2,
  CLO = 3
} TYPE;

typedef enum {
  BYTE = 0,
  PRIM
} CLO_TYPE;

char
type(void* obj)
{
  return ((long) obj & 3);
}

inline void*
untype(void* obj)
{
  return (void*) ((long) obj & ~3);
}

inline VAL
type_as(void *obj, TYPE type)
{
  return (VAL) ((long) obj | type);
}

struct binding {
  ID name;
  VAL value;
};

struct env {
  struct env *parent;
  unsigned char size;
  unsigned char alloc;
  struct binding *binds;
};

struct clo {
  struct env *env;
  CODE *code;
};

struct vm {
  VAL *stack;
  CODE *ip;
  struct env *env;
};

typedef void (* PRIMITIVE)(struct vm *);

struct env *
new_env(struct env *parent)
{
  struct env *env = calloc (1, sizeof (struct env));

  env->parent = parent;
  env->size = 0;
  env->binds = calloc (8, sizeof (struct binding));
  env->alloc = 8;

  return env;
}

struct env *
bind(struct env *env, ID name, VAL value)
{
  env->binds[env->size].name = name;
  env->binds[env->size].value = value;
  env->size++;

  return env;
}

VAL
look(struct env *env, ID name)
{
  unsigned char i;

  for (i = 0; i < env->size; i++)
    if (env->binds[i].name == name)
      return env->binds[i].value;

  if (env->parent)
    return look(env->parent, name);

  return 0;
}

VAL
new_clo(struct env *env, CODE *code)
{
  struct clo *clo = calloc (1, sizeof (struct clo));
  
  clo->env = env;
  clo->code = code;

  return type_as(clo, CLO);
}

VAL
new_prim(struct env *env, PRIMITIVE prim)
{
  struct clo *clo = calloc (1, sizeof (struct clo));
  
  clo->env = env;
  clo->code = (CODE*)((long)prim & 1);

  return type_as(clo, CLO);
}

ID
intern (char *id)
{
  return type_as(strdup(id), SEL);
}

VAL
apply(VAL arg1, VAL arg2)
{
  switch (type(arg1))
    {
    case ENV:
      {
        VAL app = look ((struct env*) arg1, intern ("apply"));
        // XXX check for app, else merge
        return apply (app, arg2);
      }
    case SEL:
      return look ((struct env*) arg2, (ID) untype (arg1));
    }
  
  return 0;
}

void
run(struct vm* vm)
{
  struct env **envs = calloc(255, sizeof (struct env *));
  CODE **ips = calloc(255, sizeof (CODE *));

  register struct env *env;
  register VAL *stack = vm->stack;
  register CODE *ip;

  *++envs = vm->env;
  *++ips = vm->ip;

  while (*ips)
    {
      env = *envs--;
      ip = *ips--;

      while (*ip)
        switch (*ip++)
          {
          case PUSH:
            env = new_env(env);
            break;
          case POP:
            env = env->parent;
            break;
          case BIND:
            bind(vm->env, (ID) untype(stack[0]), stack[-1]);
            stack -= 2;
            break;
          case LOOK:
            *stack = look(vm->env, (ID) untype(stack[0]));
            if (!*stack)
              {
                printf ("undefined name\n");
                abort ();
              }
            break;
          case LIT:
            stack++;
            *stack = (VAL)((ip[0] << 24) | (ip[1] << 16) | (ip[2] << 8) | ip[3]);
            ip += 4;
            break;
          case APP:
            switch (type(*stack)) {
            case ENV:
            case INT:
              stack--;
              *stack = apply(stack[0], stack[1]);
              break;
            case CLO:
              {
                struct clo *clo = untype(*stack);

                if ((long) clo->code & 1) /* primitive */
                  {
                    vm->ip = ip;
                    vm->env = env;
                    vm->stack = stack;
                    ((PRIMITIVE)((long) clo->code & ~1))(vm);
                  }
                else
                  {
                    if (clo->env == 0)    /* lambda */
                      *stack = new_clo(new_env(vm->env), clo->code);
                    *++ips = ip;
                    *++envs = env;
                    ip = clo->code;
                    env = clo->env;
                    stack--;
                  }
              }
              break;
            }
            break;
          case RET:
            break;
          }
    }
}

#define L(v) (unsigned char) ((long)(v)>>24),                   \
                              (unsigned char) ((long)(v)>>16),  \
                              (unsigned char) ((long)(v)>>8),   \
             (unsigned char) ((long)(v))