/****************************************************************************
* lisp-dynamic.c
* David Boozer
* 16 June 2005
* 24 February 2006 (modified)
*****************************************************************************
* lisp interpreter (dynamic scoping)
****************************************************************************/

#include <stdio.h>
#include <string.h>

enum type_code {CONS, INT, SYM, PRIM, COMP, SPEC};

typedef struct obj {
  enum type_code type;
} obj;

typedef obj *(cfunc_type)(obj *);

typedef struct {
  enum type_code type;
  obj *car;
  obj *cdr;
} obj_cons;

typedef struct {
  enum type_code type;
  int value;
} obj_int;

typedef struct {
  enum type_code type;
  char *name;
} obj_sym;

typedef struct {
  enum type_code type;
  cfunc_type *cfunc;
} obj_prim;

typedef struct {
  enum type_code type;
  obj *code;
  obj *syms;
  obj *env;
} obj_comp;

typedef struct {
  enum type_code type;
  obj *func;
} obj_spec;

/* lists */
obj *names_head, *top_env;

/* quote */
obj *s_quote;

/* () and #t */
obj *nil, *tee;

int num_nodes = 0;
int flag_trace = 0;

#define car(X)                (((obj_cons *) (X))->car)
#define cdr(X)                (((obj_cons *) (X))->cdr)

#define second(X)             (car(cdr(X)))
#define third(X)              (car(cdr(cdr(X))))
#define fourth(X)             (car(cdr(cdr(cdr(X)))))

#define int_value(X)          (((obj_int *) (X))->value)
#define sym_name(X)           (((obj_sym *) (X))->name)
#define prim_cfunc(X)         (((obj_prim *) (X))->cfunc)
#define comp_code(X)          (((obj_comp *) (X))->code)
#define comp_syms(X)          (((obj_comp *) (X))->syms)
#define comp_env(X)           (((obj_comp *) (X))->env)
#define spec_func(X)          (((obj_spec *) (X))->func)

/* function prototypes */

void write (FILE *output, obj *op);

obj *read_sexp ();
obj *read_list ();

obj *eval_list (obj *exps, obj *env);
obj *apply (obj *proc, obj *vals, obj *env);

/* construct lisp objects */

obj *cons (obj *first, obj *second) {
  obj_cons *op;

  num_nodes++;
  op = (obj_cons *) malloc (sizeof (obj_cons));
  op->type = CONS;
  op->car = first;
  op->cdr = second;
  return (obj *) op;
}

obj *make_int (int value) {
  obj_int *ptr;

  num_nodes++;
  ptr = (obj_int *) malloc (sizeof (obj_int));
  ptr->type = INT;
  ptr->value = value;
  return (obj *) ptr;
}

obj *make_sym (char *name) {
  obj_sym *ptr;

  num_nodes++;
  ptr = (obj_sym *) malloc (sizeof (obj_sym));
  ptr->type = SYM;
  ptr->name = name;
  return (obj *) ptr;
}

obj *make_prim (cfunc_type *cfunc) {
  obj_prim *ptr;

  num_nodes++;
  ptr = (obj_prim *) malloc (sizeof (obj_prim));
  ptr->type = PRIM;
  ptr->cfunc = cfunc;
  return (obj *) ptr;
}

obj *make_comp (obj *code, obj *syms, obj *env) {
  obj_comp *ptr;

  num_nodes++;
  ptr = (obj_comp *) malloc (sizeof (obj_comp));
  ptr->type = COMP;
  ptr->code = code;
  ptr->syms = syms;
  ptr->env = env;
  return (obj *) ptr;
}

obj *make_spec (obj *func) {
  obj_spec *ptr;

  num_nodes++;
  ptr = (obj_spec *) malloc (sizeof (obj_spec));
  ptr->type = SPEC;
  ptr->func = func;
  return (obj *) ptr;
}

/* misc routines */

void error (char *message) {
  fprintf (stderr, "%s\n", message);
  exit (0);
}

void error_object (char *message, obj *sexp) {
  fprintf (stderr, "%s", message);
  write (stderr, sexp);
  fprintf (stderr, "\n", message);
  exit (0);
}

obj *lookup (char *name) {
  obj *op;

  for (op = names_head; op != nil; op = cdr(op))
    if(!strcmp (name, sym_name(car(op)))) break;

  if (op != nil)
    return car(op);
  else {
    op = make_sym (strdup(name));
    names_head = cons (op, names_head);
    return op;
  }
}

/* variable binding */

/* return an environment obtained by adding variable bindings to head of env */
obj *extend_env (obj *syms, obj *vals, obj *env) {
  if (vals == nil && syms == nil)
    return env;
  else if (vals != nil && syms == nil)
    error ("Binding error: more values than variables.");
  else if (vals == nil && syms != nil)
    error ("Binding error: more variables than values.");
  else
    return cons (cons (car(syms), car(vals)),
		 extend_env (cdr(syms), cdr(vals), env));
}

/* add sym to tail of top_env; bind sym to val */
void define (obj *sym, obj *val) {
  obj *tmp;

  for (tmp = top_env; cdr(tmp) != nil; tmp = cdr(tmp));
  cdr(tmp) = cons (cons (sym, val), nil);  
}

/* return pair in alist whose car is key, or nil if no such pair exists */
obj *assoc (obj *key, obj *alist) {
  obj *ptr;

  for (ptr = alist; ptr != nil; ptr = cdr(ptr))
    if (car(car(ptr)) == key) break;
  
  return (ptr == nil) ? nil : car(ptr);
}

/* read an s-expression */

#define ATOM 0

FILE *input_file;
obj *tokenval;

int next_token () {
  char buffer[128];
  int buffer_index;
  int ch;

  buffer_index = 0;

  do {
    ch = getc (input_file);
    if (ch == ';') {
      do ch = getc (input_file);
      while (ch != '\n' && ch != EOF);
    }
  } while(isspace (ch) && ch != EOF);

  if (ch == EOF)
    exit (0);
  else if (ch == ':')
    return getc (input_file);
  else if (strchr ("()\'", ch))
    return ch;
  else if (ch == '.') {
    ch = getc (input_file);
    if (strchr ("()\'", ch) || isspace (ch)) {
      ungetc (ch, input_file);
      return '.';
    }
    buffer[buffer_index++] = '.';
  }
  
  do {
    buffer[buffer_index++] = ch;
    ch = getc (input_file);
    if (ch == EOF)
      exit (0);
    else if (strchr ("()\'", ch) || isspace (ch)) {
      ungetc (ch, input_file);
      buffer[buffer_index++] = '\0';
      if (buffer[strspn(buffer, "0123456789")] == '\0')
	tokenval = make_int(atoi(buffer));
      else
	tokenval = lookup (buffer);
      return ATOM;
    }
  } while (1);
}

obj *read_sexp (int token) {
  if (token == '\'')
    return cons(s_quote, cons(read_sexp (next_token ()), nil));
  else if (token == '(')
    return read_list (next_token ());
  else if (token == ATOM)
    return tokenval;
  else
    error ("Syntax error in s-expression.");
}

obj *read_list (int token) {
  obj *tmp;
  
  if (token == ')')
    return nil;
  else if (token == '.') {
    tmp = read_sexp (next_token ());
    if (next_token() == ')')
      return tmp;
    else
      error ("Syntax error in improper list.");
  }
  else {
    tmp = read_sexp (token);
    return cons (tmp, read_list (next_token ()));
  }
}

obj *read () {
  int token;
  
  token = next_token ();

  switch (token) {
  case 'e':
    return cons (s_quote, cons (top_env, nil));
  case 'n':
    return cons (s_quote, cons (names_head, nil));
  case 'm':
    return make_int(num_nodes);
  case 'q':
    exit (0);
  case 't':
    flag_trace ^= 1;
    return (make_int(flag_trace));
  default:
    return read_sexp (token);
  }
}

/* print an s-expression */

void write (FILE *output, obj *op) {
  switch (op->type) {
  case CONS:
    fprintf (output, "(");
    do {
      write (output, car(op));
      op = cdr(op);
      if (op == nil) {
	fprintf (output, ")");
	break;
      }
      else if (op->type != CONS) {
	fprintf (output, " . ");
	write (output, op);
	fprintf (output, ")");
	break;
      }
      fprintf (output, " ");
    } while (1);
    break;
  case INT: 
    fprintf (output, "%d", int_value(op));
    break;
  case SYM:
    fprintf (output, "%s", sym_name(op));
    break;
  case PRIM:
    fprintf (output, "[primitive function]");
    break;
  case COMP:
    fprintf (output, "[compound function]");
    break;
  case SPEC:
    fprintf (output, "[special form]");
    break;
  default:
    error ("Cannot print object: invalid type.");
  }
}

/* evaluate an s-expression */

obj *eval (obj *sexp, obj *env) {
  obj *tmp;
  
  switch (sexp->type) {
  case CONS:
    tmp = eval (car(sexp), env);
    if (tmp->type == SPEC)
      return apply (spec_func(tmp), cons (cdr(sexp), cons (env, nil)), env);
    else
      return apply (tmp, eval_list (cdr(sexp), env), env);
  case SYM:
    tmp = assoc (sexp, env);
    if (tmp == nil) tmp = assoc (sexp, top_env);
    if (tmp == nil)
      error_object ("Unbound variable: ", sexp);
    else
      return cdr(tmp);
  case INT:
  case PRIM:
  case COMP:
  case SPEC:
    return sexp;
  default:
    error ("Cannot evaluate object: invalid type.");
  }
}

obj *eval_list (obj *lst, obj *env) {
  if (lst == nil)
    return nil;
  else
    return cons(eval (car(lst), env), eval_list (cdr(lst), env));
}

void trace_lambda (obj *func, obj *args, obj *env) {
  fprintf (stdout, "Evaluate ");
  write (stdout, comp_code(func));
  fprintf (stdout, "\n");
  fprintf (stdout, "in environment ");
  switch (comp_syms(func)->type) {
  case CONS:
    write (stdout, extend_env (comp_syms(func), args, env));
    break;
  case SYM:
    write (stdout, cons (cons (comp_syms(func), args), env));
    break;
  }
  fprintf (stdout, "\n");
}

obj *apply (obj *func, obj *args, obj *env) {
  switch (func->type) {
  case PRIM:
    return prim_cfunc(func)(args);
  case COMP:
    if (flag_trace) trace_lambda (func, args, env);
    switch (comp_syms(func)->type) {
    case CONS:
      return eval (comp_code(func),
		   extend_env (comp_syms(func), args, env));
    case SYM:
      return eval (comp_code(func),
		   cons (cons (comp_syms(func), args), env));
    default:
      error ("Error: invalid argument name(s) in lambda expression.");
    }
  default:
    error_object ("Not applicable: ", func);
  }
}

/* primitive functions used by special forms */

obj *prim_quote (obj *args) {
  obj *sexp = car(args), *env = second(args);

  return car(sexp);
}

obj *prim_lambda (obj *args) {
  obj *sexp = car(args), *env = second(args);

  return make_comp (second(sexp), car(sexp), env);
}

obj *prim_if (obj *args) {
  obj *sexp = car(args), *env = second(args);

  if (eval (car(sexp), env) != nil)
    return eval (second(sexp), env);
  else
    return eval (third(sexp), env);
}

obj *prim_define (obj *args) {
  obj *sexp = car(args), *env = second(args);
  obj *tmp;

  if (car(sexp)->type != SYM)
    error_object ("Not a symbol: ", car(sexp));
  tmp = assoc (car(sexp), top_env);
  if (tmp == nil)
    define (car(sexp), eval (second(sexp), env));
  else
    cdr(tmp) = eval (second(sexp), env);
  return car(sexp);
}

/* primitive functions */

obj *prim_sum (obj *args) {
  int sum;

  for (sum = 0; args != nil; args = cdr(args)) sum += int_value(car(args));
  return make_int(sum);
}

obj *prim_sub (obj *args) {
  int sum;

  if (args == nil) return make_int(0);
  sum = int_value(car(args));
  for (args = cdr(args); args != nil; args = cdr(args))
    sum -= int_value(car(args));
  return make_int(sum);
}

obj *prim_prod (obj *args) {
  int prod;

  for (prod = 1; args != nil; args = cdr(args)) prod *= int_value(car(args));
  return make_int(prod);
}

obj *prim_numeq (obj *args) {
  return int_value(car(args)) == int_value(second(args)) ? tee : nil;
}

obj *prim_car (obj *args) {
  return car(car(args));
}

obj *prim_cdr (obj *args) {
  return cdr(car(args));
}

obj *prim_cons (obj *args) {
  return cons(car(args), second(args));
}

obj *prim_eval (obj *args) {
  return eval (car(args), second(args));
}

obj *prim_apply (obj *args) {
  return apply (car(args), second(args), third(args));
}

obj *prim_assoc (obj *args) {
  return assoc (car(args), second(args));
}

obj *prim_eqvp (obj *args) {
  if (car(args)->type == INT && second(args)->type == INT)
    return (int_value(car(args)) == int_value(second(args))) ? tee : nil;
  else
    return (car(args) == second(args)) ? tee : nil;
}

obj *prim_type_of (obj *args) {
  return make_int(car(args)->type);
}

obj *prim_special (obj *args) {
  return make_spec (car(args));
}

/* initialization */

void initialize () {

  /* define nil, initialize environment and names list */

  nil = make_sym ("()");
  names_head = nil;
  top_env = cons (cons (nil, nil), nil);

  /* #t and #f */

  define (lookup ("#f"), nil);
  tee = lookup ("#t");
  define (tee, tee);

  /* primitive functions */

  define (lookup ("+"), make_prim (prim_sum));
  define (lookup ("-"), make_prim (prim_sub));
  define (lookup ("*"), make_prim (prim_prod));
  define (lookup ("="), make_prim (prim_numeq));
  define (lookup ("car"),  make_prim (prim_car));
  define (lookup ("cdr"),  make_prim (prim_cdr));
  define (lookup ("cons"), make_prim (prim_cons));
  define (lookup ("eval"), make_prim (prim_eval));
  define (lookup ("apply"), make_prim (prim_apply));
  define (lookup ("assoc"), make_prim (prim_assoc));
  define (lookup ("eqv?"), make_prim (prim_eqvp));
  define (lookup ("type-of"), make_prim (prim_type_of));
  define (lookup ("special"), make_prim (prim_special));

  /* special forms */

  define (lookup ("quote"), make_spec (make_prim (prim_quote)));
  define (lookup ("lambda"), make_spec (make_prim (prim_lambda)));
  define (lookup ("if"), make_spec (make_prim (prim_if)));
  define (lookup ("define"), make_spec (make_prim (prim_define)));

  s_quote   = lookup ("quote");
}

/* load pre-defined functions and special forms */
void load_predefined () {
  int ch;

  input_file = fopen ("predefined.scm", "r");
  if (input_file == NULL) {
    fprintf (stderr, "Error: cannot open predefined.scm\n");
    exit (0);
  }

  do {
    eval (read (), nil);
    do ch = getc (input_file);
    while (isspace (ch) && ch != EOF);
    ungetc (ch, input_file);    
  } while (ch != EOF);

  fclose (input_file);
}

/* read-eval-print loop */

int main () {
  initialize ();

  load_predefined ();

  input_file = stdin;

  do {
    printf ("--> ");
    write (stdout, eval (read (), nil));
    printf ("\n");
  } while (1);

  return 0;
}