/* -*- Mode: C; tab-width: 4 -*- */

#include <stdio.h>
#include "machine.h"

/* the global symbol table */
static symbol_table * globals = NULL;

/*
 * ===========================================================================
 *                  variable lookup and assignment
 * ===========================================================================
 */

static INLINE
void *
lookup_lexical_variable (
  lexical_environment * lex_env,
  int depth,
  int index
  )
{
  value_list * val;
  while (depth--) {
    lex_env = lex_env->next;
  }
  val = lex_env->values;
  while (index--) {
    val = val->next;
  }
  return val->value;
}
  
static INLINE
void
assign_lexical_variable (
  lexical_environment * lex_env,
  int depth,
  int index,
  void * value
  )
{
  value_list * val;
  while (depth--) {
    lex_env = lex_env->next;
  }
  val = lex_env->values;
  while (index--) {
    val = val->next;
  }
  val->value = value;
}

static INLINE
int
lookup_dynamic_variable (unsigned char * name, void ** result)
{
  symbol_table * searching = globals;
  while (searching) {
    if (strcmp (searching->symbol, name) == 0) {
      *result = searching->value;
      return 1;
      break;
    } else {
      searching = searching->next;
    }
  }
  return 0;
}
                         
static INLINE
int
assign_dynamic_variable (unsigned char * name, void * value)
{
  symbol_table * searching = globals;
  while (searching) {
    if (strcmp (searching->symbol, name) == 0) {
      searching->value = value;
      return 1;
      break;
    } else {
      searching = searching->next;
    }
  }
  return 0;
}

void
define_dynamic_variable (char * name, void * value)
{
  symbol_table * search = globals;
  /* create a new symbol table entry */
  symbol_table * new_entry = (symbol_table *) GC_MALLOC (sizeof (symbol_table));
  /* copy the symbol name */
  new_entry->symbol = (char *) GC_MALLOC_ATOMIC (strlen (name));
  strcpy (new_entry->symbol, name);
  new_entry->value = value;
  /* link in the new entry */
  new_entry->next = globals;
  globals = new_entry;
}

/*
 * ===========================================================================
 *                        builtin primitives
 * ===========================================================================
 */

void print_list (list * l);
void print_vector (vector * l);
void * builtin_print (value_list *);

print_object (void * value)
{
  if (IS_INTEGER (value)) {
    fprintf (stdout, "%d", GET_INTEGER(value));
  } else if (IS_STRING (value)) {
    fputc ('"', stdout);
    fwrite (STRING_DATA(value), 1, ((string *)(value))->size, stdout);
    fputc ('"', stdout);
  } else if (IS_LIST (value)) {
    print_list ((list *)value);
  } else if (IS_CLOSURE (value)) {
    fprintf (stdout, "<closure at %p>", value);
  } else if (IS_BUILTIN (value)) {
    fprintf (stdout, "<builtin procedure at %p>", value);
  } else if (IS_VECTOR (value)) {
    print_vector ((vector *)value);
  } else if (!value) {
    fputs ("<nil>", stdout);
  } else {
    fprintf (stdout, "<unknown object %p>", value);
  }
}

void *
builtin_print (value_list * args)
{
  while (args) {
    print_object (args->value);
    if (args->next) {
      fputc (' ', stdout);
    }
    args = args->next;
  }
  return NULL;
}

void
print_list (list * l)
{
  fputc ('(', stdout);
  while (l) {
    print_object (l->car);
    l = l->cdr;
    if (l) {
      fputc (' ', stdout);
    }
  }
  fputc (')', stdout);
}


void *
builtin_list (value_list * args)
{
  if (args) {
    /* build a list, backwards */
    list * root = NULL;
    list * cell = NULL;
    do {
      list * temp = cell;
      cell = (list *) GC_MALLOC (sizeof (list));
      cell->tag = LIST_TAG;
      cell->car = args->value;
      cell->cdr = NULL;
      if (temp) {
        temp->cdr = cell;
      } else if (!root) {
        root = cell;
      }
    } while (args = args->next);
    return (void *)root;
  } else {
    return NULL;
  }
}

void *
builtin_is_list (value_list * args)
{
  int result = IS_LIST (args->value);
  TAG_INTEGER (result);
  return (void *) result;
}

void *
builtin_cons (value_list * args)
{
  void * data = args->value;
  list * new_cell = (list *) GC_MALLOC (sizeof (list));
  new_cell->tag = LIST_TAG;
  new_cell->car = data;
  new_cell->cdr = (list *) args->next->value;
  return (void *)new_cell;
}

void *
builtin_car (value_list * args)
{
  return (((list *) args->value)->car);
}

void *
builtin_cdr (value_list * args)
{
  return (void *)(((list *) args->value)->cdr);
}

void *
builtin_null (value_list * args)
{
  int result = (((list *) args->value) == NULL);
  TAG_INTEGER (result);
  return (void *) result;
}

void *
builtin_pair (value_list * args)
{
  int result = 0;
  if (!IS_INTEGER(args->value)) {
    int result = (((list *) args->value)->tag == LIST_TAG);
  }
  TAG_INTEGER (result);
  return (void *) result;
}

void *
builtin_print_string (value_list * args)
{
  fputc ('"', stdout);
  fputs (args->value, stdout);
  fputc ('"', stdout);
}

void * builtin_terpri (value_list * args) { fputc ('\n', stdout); }

/* VECTORS */

void * builtin_make_vector (value_list * args)
{
  /* one argument, the size */
  int size = GET_INTEGER (args->value);
  int bytes = sizeof (vector) + ((sizeof (void *)) * size);
  vector * v = (vector *) GC_MALLOC (bytes);
  fprintf (stderr, "allocated %d bytes for vector\n", bytes);
  v->tag = VECTOR_TAG;
  v->size = size;
  return (void *) v;
}

void
print_vector (vector * v)
{
  void ** data = VECTOR_DATA (v);
  int i;
  fputc ('[', stdout);
  for (i = 0; i < v->size; i++) {
    print_object (data[i]);
    if (i < (v->size - 1)) {
      fputc (' ', stdout);
    }
  }
  fputc (']', stdout);
}

void *
builtin_vector_length (value_list * args)
{
  int size = ((vector *) args->value)->size;
  TAG_INTEGER (size);
  return (void *) size;
}

void *
builtin_vector_ref (value_list * args)
{
  vector * v = (vector *) args->value;
  void ** data = VECTOR_DATA (v);
  return data[GET_INTEGER (args->next->value)];
}

void *
builtin_vector_set (value_list * args)
{
  vector * v = (vector *) args->value;
  int index = GET_INTEGER (args->next->value);
  void * value = args->next->next->value;
  void ** data = VECTOR_DATA (v);
  if ((index >= 0) && (index < v->size)) {
    data[index] = value;
  } else {
    fprintf (stderr, "index out of range\n");
  }
  return NULL;
}

void *
builtin_getc (value_list * args)
{
  int result = (int) fgetc (stdin);
  TAG_INTEGER (result);
  return (void *) result;
}

void *
builtin_putc (value_list * args)
{
  fputc (
    (GET_INTEGER (args->value) % 0xff),
    stdout
  );
  return NULL;
}

void *
builtin_not (value_list * args)
{
  int result = GET_INTEGER (args->value);
  result = !result;
  TAG_INTEGER (result);
  return (void *) result;
}

static struct {
  char * name;
  builtin_procedure function;
} builtins[] = {
  { "print",            builtin_print },
  { "terpri",           builtin_terpri },
  { "list",             builtin_list },
  { "is_list",          builtin_pair },
  { "cons",             builtin_cons },
  { "car",              builtin_car },
  { "cdr",              builtin_cdr },
  { "null",             builtin_null },
  { "pair",             builtin_pair },
  { "make_vector",      builtin_make_vector },
  { "vector_ref",       builtin_vector_ref },
  { "vector_set",       builtin_vector_set },
  { "vector_length",    builtin_vector_length },
  { "getc",             builtin_getc },
  { "putc",             builtin_putc },
  { "not",              builtin_not },
  { NULL,               NULL }
};


void
initialize_builtins (symbol_table * symbols)
{
  int i;
  /* add call/cc */
  procedure * callcc = (procedure *) GC_MALLOC (sizeof (procedure));
  callcc->kind = PROC_CLOSURE;
  (callcc->p).closure.code = "^v++I"; /* pushcc, varref (0, 0), invoke */
  (callcc->p).closure.lex_env = NULL; /* no environment */
  define_dynamic_variable ("callcc", callcc);

  /* add the C builtins */
  for (i = 0; builtins[i].name; i++) {
    procedure * proc = (procedure *) GC_MALLOC (sizeof (procedure));
    proc->kind = PROC_BUILTIN;
    (proc->p).builtin = builtins[i].function;
    define_dynamic_variable (builtins[i].name, proc);
  }


}

/*
 * ===========================================================================
 *                      byte-code interpreter
 * ===========================================================================
 */

int
machine (unsigned char * code, int debug)
{
  register void * acc = NULL; /* accumulator */
  register value_list * val = NULL;
  register lexical_environment * lex_env    = NULL;
  continuation halting_continuation = {"H" /* OP_HALT */, NULL, NULL, NULL};
  register continuation * k = & halting_continuation;
  int insn_count = 0;

  while (1) {
    
    char opcode = (*code++);
    insn_count++;
    
    if (debug) {
      fprintf (stdout, "%04d op: %c\t", insn_count, opcode);
      print_object (acc);
      fputc ('\n', stdout);
    }

    switch (opcode) {

    case OP_LIT:
      UNPACK_INTEGER (code, ((int)acc));
      TAG_INTEGER (acc);
      break;

    case OP_STRING: {
      int string_length;
      string * new_string;
      UNPACK_INTEGER (code, string_length);

      /* should be a macro */
      new_string = (string *) GC_MALLOC_ATOMIC (sizeof(string) + string_length);
      memcpy (
        new_string+sizeof(string),
        code,
        string_length
      );
      new_string->size = string_length;
      new_string->tag = STRING_TAG;

      acc = new_string;
      code += string_length;
    }
    break;

    case OP_TEST: {
      int delta;
      UNPACK_INTEGER (code, delta);
      if (!(GET_INTEGER(acc))) {
        code += delta;
      }
    }
    break;

    case OP_PRIMOP: {
      char primop = *(code++);
      int arg1 = GET_INTEGER (val->value);
      int arg2 = GET_INTEGER (val->next->value);
      switch (primop) {
      case PRIM_ADD:
        (int)acc = arg1 + arg2;
        break;
      case PRIM_SUB:
        (int)acc = arg1 - arg2;
        break;
      case PRIM_MUL:
        (int)acc = arg1 * arg2;
        break;
      case PRIM_DIV:
        (int)acc = arg1 / arg2;
        break;
      case PRIM_MOD: 
        (int)acc = arg1 % arg2;
        break;
      case PRIM_EQ:
        (int)acc = arg1 == arg2;
        break;
      case PRIM_GT:
        (int)acc = arg1 > arg2;
        break;
      case PRIM_LT:
        (int)acc = arg1 < arg2;
        break;
      case PRIM_AND:
        (int)acc = arg1 && arg2;
        break;
      case PRIM_OR:
        (int)acc = arg1 || arg2;
        break;
      case PRIM_GE:
        (int)acc = arg1 >= arg2;
        break;
      case PRIM_LE:
        (int)acc = arg1 <= arg2;
        break;
      }
      TAG_INTEGER (acc);
      /* perform a RESTORE */
      code = k->code;
      val = k->val;
      lex_env = k->lex_env;
      k = k->next;
    }
    break;

    case OP_DYNREF: {
      int symbol_length;
      void * temp;
      UNPACK_INTEGER (code, symbol_length);
      if (!lookup_dynamic_variable (code, &temp)) {
        fprintf (stderr, "undefined symbol: %s\n", code);
        return -1;
      } else {
        acc = temp;
      }
      code += symbol_length;
    }
    break;

    case OP_DYNASSIGN: {
      int symbol_length;
      UNPACK_INTEGER (code, symbol_length);
      if (!assign_dynamic_variable (code, acc)) {
        fprintf (stderr, "undefined symbol: %s\n", code);
        return -1;
      }
      code += symbol_length;
    }
    break;

    case OP_DEFINE: {
      int symbol_length;
      UNPACK_INTEGER (code, symbol_length);
      define_dynamic_variable ((char *)code, acc);
      /* advance the instruction pointer */
      code += symbol_length;
    }
    break;

    case OP_VARREF: {
      int depth, index;
      UNPACK_INTEGER (code, depth);
      UNPACK_INTEGER (code, index);
      acc = lookup_lexical_variable (lex_env, depth, index);
    }
    break;

    case OP_ASSIGN: {
      int depth, index;
      UNPACK_INTEGER (code, depth);
      UNPACK_INTEGER (code, index);
      assign_lexical_variable (lex_env, depth, index, acc);
    }
    break;


    case OP_PUSH: {
      value_list * new_val = (value_list *) GC_MALLOC (sizeof (value_list));
      new_val->next = val;
      new_val->value = acc;
      val = new_val;
    }
    break;

    case OP_HALT:
      fputs ("=> ", stdout);
      print_object (acc);
      fputc ('\n', stdout);
      fprintf (stdout, "(%d insns)\n", insn_count);
      fflush (stdout);
      return (int)acc;

    case OP_PROC: {
      procedure * proc = (procedure *) GC_MALLOC (sizeof (procedure));
      int proc_length;
      UNPACK_INTEGER (code, proc_length);
      proc->kind = PROC_CLOSURE;
      (proc->p).closure.code = code;
      (proc->p).closure.lex_env = lex_env;
      acc = (void *) proc;
      /* skip over procedure code */
      code += proc_length;
    }
    break;

    case OP_SAVE: {
      int save_length;
      /* build a new continuation */
      continuation * k2 = (continuation *) GC_MALLOC (sizeof (continuation));
      UNPACK_INTEGER (code, save_length);
      /* k = code2, val, lex_env, k */
      k2->code = code + save_length;
      k2->val = val;
      k2->lex_env = lex_env;
      k2->next = k;
      k = k2;
      acc = NULL;
      val = NULL;
    }
    break;

    case OP_RESTORE: {
      code = k->code;
      val  = k->val;
      lex_env = k->lex_env;
      k = k->next;
    }
    break;

    case OP_INVOKE: {
      procedure * proc = (procedure *) acc;
      if (proc->kind == PROC_CLOSURE) {
        /* -------------------- closure -------------------- */
        lexical_environment * arguments = (lexical_environment *) GC_MALLOC (sizeof (lexical_environment));
        code = (proc->p).closure.code;
        lex_env = (proc->p).closure.lex_env;

        /* extend the procedure's lexical environment with the argument list in <val> */
        arguments->values = val;
        arguments->next = lex_env;
        lex_env = arguments;
        val = NULL;
      } else if (proc->kind == PROC_BUILTIN) {
        /* -------------------- builtin -------------------- */
        acc = (*((proc->p).builtin)) (val);
        /* perform a RESTORE */
        code = k->code;
        val = k->val;
        lex_env = k->lex_env;
        k = k->next;
      }
    }
    break;

    case OP_PUSHCC: {
      /* val = [(<code>, [[k]]))] */

      value_list * vl = (value_list *) GC_MALLOC (sizeof (value_list));
      procedure * proc = (procedure *) GC_MALLOC (sizeof (procedure));
      lexical_environment * le = (lexical_environment *) GC_MALLOC (sizeof (lexical_environment));
      value_list * kv = (value_list *) GC_MALLOC (sizeof (value_list));
      
      /* prepare [[k]] */
      kv->value = (void *) k;
      kv->next = NULL;
      le->values = kv;
      le->next = NULL;

      /* prepare <code> */
      proc->kind = PROC_CLOSURE;
      (proc->p).closure.code = "vB++!"; /* varref (1, 0), loadcc */
      (proc->p).closure.lex_env = le;

      vl->value = proc;
      vl->next = NULL;
      val = vl;
    }
    break;

    case OP_LOADCC: {
      continuation * kk = (continuation *) acc;
      void * temp = lex_env->values->value; /* lex_env[0][0] */
      code = kk->code;
      val = kk->val;
      lex_env = kk->lex_env;
      k = kk->next;
      acc = temp;
    }
    break;

    default:
      fprintf (stderr, "unknown opcode: %c/%d\n", opcode, opcode);
      return -1;
      break;

    }
  }
}

int
main (int argc, char *argv[])
{
  unsigned char * code;
  int code_length = 0;
  int debug = 0;
  FILE * code_file = stdin;
  int i;

  for (i=1; i < argc; i++) {
    if (strcmp (argv[i], "-d") == 0) {
      debug = 1;
    } else {
      code_file = fopen (argv[i], "rb");
    }
  }

  initialize_builtins (globals);

  while (fscanf (code_file, "%d", &code_length) == 1) {
    /* skip over space after number */
    fgetc (code_file);
    code = (unsigned char *) GC_MALLOC (code_length);
    if (fread (code, (size_t) 1, (size_t) code_length, code_file) != code_length) {
      fprintf (stderr, "error reading code\n");
    } else {
      machine (code, debug);
    }
  }
  return 1;
}