idobj.c

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

#define LOCALS_MAX     10
#define STACK_MAX      10

typedef unsigned char byte;

typedef struct _Vtable Vtable;
typedef struct _Object Object;
typedef struct _Closure Closure;
typedef struct _Number Number;
typedef struct _String String;
typedef struct _Array Array;
typedef struct _Bytecode Bytecode;

typedef Object *(*imp_t)(Closure *closure, Object *receiver, Object *argv[], int argc);

typedef struct {
  Vtable *vt;
  int gci;
} OHeader;

struct _Object {
  OHeader h;
};

struct _Vtable {
  OHeader h;
  Vtable *parent;
  Array *keys, *values;
};

struct _Closure {
  OHeader h;
  imp_t method;
  Object *data;
};

struct _String {
  OHeader h;
  char *chars;
};

struct _Number {
  OHeader h;
  int value;
};

struct _Array {
  OHeader h;
  int len, size;
  Object **vec;
};

struct _Bytecode {
  OHeader h;
  void **literals;
  byte  *instructions;

  Object  *stack[STACK_MAX];        // THE famous stack
  Object **sp;              // stack pointer, keeps track of current position
  Object  *locals[LOCALS_MAX];      // where we store our local variables
};

Object* object_new();
Object* object_send(Object *receiver, Object *msg, Object *argv[], int argc);
Vtable* vtable_new(Vtable *parent);
Object* vtable_get_value(Vtable* self, Object* key);
void vtable_add_method(Closure *closure, Vtable *self, Object *key, imp_t method);
Object* string_new(char *string);
Object* string_print(Closure *closure, String *self, Object *argv[], int argc);
Object* string_intern(Closure *closure, Object *self, char *string);
Object* closure_new(imp_t method, Object *data);
Object* number_new(int num);
Object* number_print(Closure *closure, Number *self, Object *argv[], int argc);
Object* array_new();
Object* array_print(Closure *closure, Array *self, Object *argv[], int argc);
static void _array_insert(Array *self, int n, Object *v);
static void _array_append(Array *self, Object *v);
static Object* _array_get(Array *self,int k);
static Object* _array_remove(Array *self, int n);

#define alloc(size) calloc(1, size);;
Object* gc_track(Object* o);
void gc_grey(Object *o);
void gc_full();

/*----------------------------------------------------------------*/
Array *white_set;
Array *grey_set;
Array *black_set;
int gc_steps = 0;
int gc_tracked = 0;

static Object *TrueObject;
static Object *FalseObject;
static Object *NilObject;
Vtable *SymbolList= 0;

Vtable *vtable_vt;
Vtable *object_vt;
Vtable *string_vt;
Vtable *closure_vt;
Vtable *number_vt = 0;
Vtable *array_vt = 0;

Object *s_new = 0;
Object *s_destroy = 0;
Object *s_follow = 0;
Object *s_length = 0;
Object *s_print = 0;
Object *s_append = 0;
Object *s_call = 0;
Object *s_plus = 0;

/*----------------------------------------------------------------*/
Object *object_new() {
  Object *object = (Object *)alloc(sizeof(String));
  object->h.vt = object_vt;
  return (Object *)object;
}

struct entry {
  Vtable  *vtable;
  Object  *selector;
  Closure *closure;
} MethodCache[8192];

static Closure *bind(Object *rcv, Object *msg) {
  Vtable  *vt = rcv->h.vt;

  struct entry *cl = MethodCache + ((((unsigned)vt << 2) ^ ((unsigned)msg >> 3)) & ((sizeof(MethodCache) / sizeof(struct entry)) - 1));
  if( cl->vtable == vt && cl->selector == msg ) return cl->closure;

  while(vt) {
    Closure *c = (Closure *) vtable_get_value(vt, msg);
    if(c) {
      *cl = (struct entry){vt, msg, c};
      return c;
    }
    vt = vt->parent;
  }

  fprintf(stderr, "lookup failed %p %s\n", rcv->h.vt, ((String *)msg)->chars);
  exit(1);
  return NULL;
}

Object* object_send(Object *receiver, Object *msg, Object *argv[], int argc) {
  Closure *c = bind(receiver, msg);
  if(!c) return NULL;
  return c->method(c, receiver, argv, argc);
}


int _object_is_true(Object *self) {
  // false and nil are == false, everything else is true.
  if(self == FalseObject || self == NilObject) return 0;
  return 1;
}

/*----------------------------------------------------------------*/
Vtable* vtable_new(Vtable *parent) {
  Vtable *child = (Vtable *)alloc(sizeof(Vtable));
  child->h.vt = parent ? parent->h.vt : 0;
  child->keys = (Array*) array_new();
  child->values = (Array*) array_new();
  child->parent = parent;
  return child;
}

Object* vtable_get_value(Vtable* self, Object* key) {
  int i;
  Array *keys = self->keys;
  Array *values = self->values;
  for( i = 0; i < keys->len;  ++i )
    if( keys->vec[i] == key ) return values->vec[i];

  return NULL;
}

Object* vtable_set_value(Closure *closure, Vtable *self, Object *key, Object* value) {
  Object *o = vtable_get_value(self, key);
  if(o) *o = *value;

  _array_append(self->keys, key);
  _array_append(self->values, value);
  return value;
}

void vtable_add_method(Closure *closure, Vtable *self, Object *key, imp_t method) {
  Closure *c = (Closure *) vtable_get_value(self, key);
  if(c) c->method = method;

  _array_append(self->keys, key);
  _array_append(self->values, closure_new(method, 0));
}

/*----------------------------------------------------------------*/
Object* string_new(char *string) {
  String *str = (String *)alloc(sizeof(String));
  str->h.vt = string_vt;
  str->chars = strdup(string);
  return (Object *)str;
}

Object* string_print(Closure *closure, String *self, Object *argv[], int argc) {
  printf("\"%s\"", self->chars);
  return NULL;
}

Object* string_intern( Closure *closure, Object *self, char *str ) {
  int i;
  Array *list = SymbolList->keys;
  for( i = 0;  i < list->len; ++i )
    if( strcmp(str, ((String *) list->vec[i])->chars) == 0 ) return list->vec[i];

  Object *symbol = string_new(str);
  vtable_add_method(0, SymbolList, symbol, 0);
  return symbol;
}
/*----------------------------------------------------------------*/
Object* closure_new(imp_t method, Object *data) {
  Closure *closure = (Closure *)alloc(sizeof(Closure));
  closure->h.vt = closure_vt;
  closure->method  = method;
  closure->data    = data;
  return (Object *)closure;
}

// === opcode ===
enum {  //                                ------- Stack -------
  // Opcode                  Operands     before         after
  /* 00 */ RETURN,        //              []             []
  /* 01 */ PUSH_NUMBER,   // index        []             [number]
  /* 02 */ PUSH_STRING,   // index        []             [string]
  /* 03 */ PUSH_SELF,     //              []             [self]
  /* 04 */ PUSH_NIL,      //              []             [nil]
  /* 05 */ PUSH_BOOL,     // 1=t, 0=f     []             [true or false]
  /* 06 */ GET_LOCAL,     // index        []             [value]
  /* 07 */ SET_LOCAL,     // index        [value]        []
  /* 08 */ JUMP_UNLESS,   // offset       [test]         []
  /* 09 */ JUMP,          // offset       []             []
  /* 10 */ CALL           // index, argc  [rcv, arg...]  [returned]
};

// Helpers to play with the stack
static void stack_push(Bytecode *s, void *o) {
  assert(s->sp - s->stack < STACK_MAX);
  *(++s->sp) = (Object*) o;
}

static Object* stack_pop(Bytecode *s) {
  return (Object *) (*s->sp--);
}

Object* closure_exec(Closure *closure, Object *self, Object *argv[], int argc) {
  Bytecode *s = (Bytecode *) closure->data;
  byte offset, *ip = s->instructions;       // instruction pointer

  Object *tmp;

  // Start processing instructions
  while (1) {
    switch (*ip) {
      case PUSH_NUMBER:
        tmp = gc_track( number_new((int)s->literals[*(++ip)]) ); // operand (literal index)
        stack_push(s, tmp);
        break;
      case PUSH_STRING:
        tmp = gc_track( string_new((char *)s->literals[*(++ip)]) ); // operand (literal index)
        stack_push(s, tmp);
        break;
      case PUSH_SELF:
        stack_push(s, self);
        break;
      case PUSH_NIL:
        stack_push(s, NilObject);
        break;
      case PUSH_BOOL:
        stack_push(s, *(++ip) == 0 ? FalseObject : TrueObject); // operand (0 = false, 1 = true)
        break;
      case CALL: {
        char *method = s->literals[ *(++ip) ]; // advance to operand (method name index in literals)
        int argc = *(++ip); // advance to operand (# of args)
        Object *argv[10];

        int i;
        for( i = argc - 1; i >= 0; i-- ) argv[i] = stack_pop(s);
        Object *msg = string_intern(0, 0, method);
        stack_push(s, object_send(stack_pop(s), msg, argv, argc));

        break;
      }
      case RETURN:
        return stack_pop(s);
      case GET_LOCAL:
        stack_push(s, s->locals[*(++ip)]); // operand (local index)
        break;
      case SET_LOCAL:
        s->locals[*(++ip)] = stack_pop(s); // (++ip) == local index
        break;
      case JUMP_UNLESS:
        offset = *(++ip); // operand (offset, # of bytes to jump forward)
        if (!_object_is_true(stack_pop(s))) ip += offset;
        break;
      case JUMP:
        offset = *(++ip); // operand (offset, # of bytes to jump forward)
        ip += offset; // ++ip operand (offset, # of bytes to jump forward)
        break;
    }
    ip++;
  }
}

/*----------------------------------------------------------------*/
Object* number_new(int num) {
  Number *clone = (Number *)alloc(sizeof(Number));
  clone->h.vt = number_vt;
  clone->value = num;
  return (Object *)clone;
}

Object* number_print(Closure *closure, Number *self, Object *argv[], int argc) {
  printf("%d", self->value);
  return NULL;
}

Object* number_add(Closure *closure, Number *self, Object *argv[], int argc) {
  Object *res =  number_new(self->value + ((Number*)argv[0])->value);
  return gc_track(res);
}
/*----------------------------------------------------------------*/
Object* array_new() {
  Array *clone = (Array *)alloc(sizeof(Array));
  clone->h.vt = array_vt;
  clone->len   = 0;
  clone->size  = 2;
  clone->vec   = (Object **)calloc(clone->size, sizeof(Object *));
  return (Object *)clone;
}

void array_destroy(Array *self){
  if(self->vec) free(self->vec);
  free(self);
}

static void _array_insert(Array *self, int n, Object *v) {
  if( self->len == self->size ) {
    self->size *= 2;
    self->vec = (Object **)realloc(self->vec, sizeof(Object*) * self->size);
  }

  if(n < self->len)
    memmove(&self->vec[n+1], &self->vec[n], sizeof(Object*) * (self->len-n));

  self->vec[n] = v;
  self->len++;
}

static void _array_append(Array *self, Object *v) {
  _array_insert(self, self->len, v);
}

static Object* _array_get(Array *self,int k) {
  if( k >= self->len ) return NULL;
  if( k < 0 ) k += self->len;
  return self->vec[k];
}

static Object* _array_remove(Array *self, int n) {
  Object *o = _array_get( self, n );
  if( n != self->len-1 ) {
    memmove( &self->vec[n], &self->vec[n+1], sizeof(Object*) * (self->len-n+1) );
  }
  self->len--;
  return o;
}

Object* array_print(Closure *closure, Array *self, Object *argv[], int argc) {
  printf("[");
  int i;
  for(i=0; i<self->len; i++) {
    object_send(self->vec[i], s_print, NULL, 0);
    if(i != self->len-1) printf(", ");
  }
  printf("]");
  return NULL;
}

/*----------------------------------------------------------------*/
#define GCMAX 32

void gc_grey(Object *o) {
  if(!o || o->h.gci == 1) return;
  o->h.gci = 1;
  _array_append(grey_set, o);
}

// these two should be refactored into methods attached to vt's
static void gc_destroy(Object *o) {
  if(!o) return;
  if(o->h.vt == string_vt){
    String *s = (String*) o;
    if(s->chars) free(s->chars);
  } else if(o->h.vt == array_vt){
    return array_destroy((Array*) o);
  } else if(o->h.vt == closure_vt){
    Closure *c = (Closure*) o;
    if(c->data) free(c->data);
  } else if(o->h.vt == vtable_vt){
    Vtable* vt = (Vtable *) o;
    gc_destroy( (Object*) vt->keys );
    gc_destroy( (Object*) vt->values );
  }
  free(o);
  gc_tracked--;
}

static void gc_follow(Object *o){
  int n;
  if(o->h.vt == array_vt){
    Array *arr = (Array*) o;
    for( n=0; n < arr->len; n++ ) gc_grey(arr->vec[n]);
  } else if(o->h.vt == closure_vt){
    gc_grey(((Closure*) o)->data);
  } else if(o->h.vt == vtable_vt){
    Vtable* vt = (Vtable *) o;
    gc_follow((Object*) vt->keys);
    gc_follow((Object*) vt->values);
  }
}

static void gc_reset() {
  int n;
  for (n=0; n<black_set->len; n++) black_set->vec[n]->h.gci = 0;
  white_set->len = 0;
  Array *tmp = white_set;
  white_set = black_set;
  black_set = tmp;
}

static void gc_collect() {
  int n;
  for( n = 0; n < white_set->len; n++ ) gc_destroy(white_set->vec[n]);
  gc_reset();
}

static void _gc_inc(int steps) {
  while( --steps >= 0 ){
    if( grey_set->len <= 0 ) return;
    Object *o = _array_remove(grey_set, grey_set->len-1);
    gc_follow(o);
    _array_append(black_set, o);
  }
}

void gc_full() {
  _gc_inc(grey_set->len);
  gc_collect();
  // gc_follow(tp,tp->root);
}

static void gc_inc() {
  gc_steps++;
  if( gc_steps < GCMAX || grey_set->len > 0) _gc_inc(2);
  if( gc_steps < GCMAX || grey_set->len > 0) return;
  gc_steps = 0;
  gc_full();
}

Object* gc_track(Object* o) {
  gc_tracked++;
  gc_inc();
  gc_grey(o);
  return o;
}

/*----------------------------------------------------------------*/
void rt_init(void) {
  vtable_vt = vtable_new(NULL);
  vtable_vt->h.vt = vtable_vt;

  object_vt = vtable_new(NULL);
  object_vt->h.vt = vtable_vt;
  vtable_vt->parent = object_vt;

  string_vt  = vtable_new(object_vt);
  closure_vt = vtable_new(object_vt);
  number_vt = vtable_new(object_vt);
  array_vt = vtable_new(object_vt);

  SymbolList = vtable_new(NULL);

  s_length = string_intern(0, 0, "length");
  s_print = string_intern(0, 0, "print");
  s_destroy = string_intern(0, 0, "destroy");
  s_follow = string_intern(0, 0, "follow");
  s_plus = string_intern(0, 0, "+");

  vtable_add_method(0, string_vt, s_print, (imp_t) string_print);
  vtable_add_method(0, number_vt, s_print, (imp_t) number_print);
  vtable_add_method(0, array_vt, s_print, (imp_t) array_print);
  vtable_add_method(0, number_vt, s_plus, (imp_t) number_add);

  white_set = (Array*) array_new();
  grey_set = (Array*) array_new();
  black_set = (Array*) array_new();

  TrueObject = object_new();
  FalseObject = object_new();
  NilObject = object_new();
}

void rt_destroy(){
  free(TrueObject);
  free(FalseObject);
  free(NilObject);

  array_destroy(white_set);
  array_destroy(grey_set);
  array_destroy(black_set);
}

void rt_doit(void) {
  Object *a = gc_track( string_new("hello world!"));
  Object *b = gc_track( number_new(42) );
  Object *c = gc_track( array_new() );

  _array_append((Array*) c, a);
  _array_append((Array*) c, a);
  _array_append((Array*) c, b);
  _array_append((Array*) c, a);
  _array_append((Array*) c, b);

  object_send(a, s_print, NULL, 0);
  printf("\n");
  object_send(b, s_print, NULL, 0);
  printf("\n");
  object_send(c, s_print, NULL, 0);
  printf("\n");
  printf("\n");

  printf("GC total: %4d black: %3d, grey: %3d, white: %3d\n", gc_tracked, black_set->len, grey_set->len, white_set->len);
  gc_full();
  gc_full();
  printf("GC total: %4d black: %3d, grey: %3d, white: %3d\n", gc_tracked, black_set->len, grey_set->len, white_set->len);
}

/*----------------------------------------------------------------*/
// === bytecode ===

void* LITERALS[] = {
    (void *) "the answer is:",
    (void *) "print",
    (void *) 30,
    (void *) 2,
    (void *) "no",
    (void *) "+",
    (void *) "life_meaning",
    (void *) 42,
};

byte INSTRUCTIONS[] = {
  2,  0,    // push_string 0
  10, 1, 0, // call (1, 1) -- print
  1,  2,    // push_number 2
  3,       // self
  10, 6, 0, // call (6, 0) -- life_meaning
  10, 5, 1, // call (5, 1) -- add
  7,  0,    // set_local 0
  5,  1,    // push_bool 0
  8,  8,    // jump_unless 8
  6,  0,    // get_local 0
  10, 1, 0, // call (1, 1) -- print
  9,  6,    // jump 6
  2,  4,    // push_string 4
  10, 1, 0, // call (1, 1) -- print
  0       // return
};

byte BC_LIFE_MEANING[] = {
  1,  7,    // push_number 3
  0       // return
};

int main() {
  rt_init();

  Bytecode s = {};
  s.literals = LITERALS;
  s.instructions = INSTRUCTIONS;
  s.sp = s.stack;

  Bytecode lm = {};
  lm.literals = LITERALS;
  lm.instructions = BC_LIFE_MEANING;
  lm.sp = lm.stack;


  Object *lobby = gc_track(object_new());
  Closure *c = (Closure *) closure_new((imp_t) closure_exec, (Object*) &s);
  vtable_set_value(0, object_vt, string_intern(0, 0, "life_meaning"), closure_new((imp_t) closure_exec, (Object*) &lm));

  printf("GC total: %4d black: %3d, grey: %3d, white: %3d\n", gc_tracked, black_set->len, grey_set->len, white_set->len);
  closure_exec(c, lobby, NULL, 0);
  gc_full();
  gc_full();
  printf("\nGC total: %4d black: %3d, grey: %3d, white: %3d\n", gc_tracked, black_set->len, grey_set->len, white_set->len);

  // rt_doit();
  rt_destroy();
  return 0;
}

sl4.c

/* A minimal Lisp interpreter
   Copyright 2004 Andru Luvisi

   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 2 of the License , or
   (at your option) any later version.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program. If not, write to the Free Software
   Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 */


#include <stdio.h>
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <ctype.h>

#define error(X) do { fprintf(stderr, "%s\n", X); exit(1); } while (0)

/*** List Structured Memory ***/
enum otype { INT, SYM, CONS, PROC, PRIMOP };
typedef struct obj {
  enum otype type;
  struct obj *p[1];
} obj;
typedef obj * (*primop)(obj *);
obj *all_symbols, *top_env, *nil, *tee, *quote, 
    *s_if, *s_lambda, *s_define, *s_setb, *s_begin;

#define cons(X, Y)            omake(CONS, 2, (X), (Y))
#define car(X)                ((X)->p[0])
#define cdr(X)                ((X)->p[1])
#define setcar(X,Y)           (((X)->p[0]) = (Y))
#define setcdr(X,Y)           (((X)->p[1]) = (Y))
#define mkint(X)              omake(INT, 1, (obj *)(X))
#define intval(X)             ((int)((X)->p[0]))
#define mksym(X)              omake(SYM, 1, (obj *)(X))
#define symname(X)            ((char *)((X)->p[0]))
#define mkprimop(X)           omake(PRIMOP, 1, (obj *)(X))
#define primopval(X)          ((primop)(X)->p[0])
#define mkproc(X,Y,Z)         omake(PROC, 3, (X), (Y), (Z))
#define procargs(X)           ((X)->p[0])
#define proccode(X)           ((X)->p[1])
#define procenv(X)            ((X)->p[2])
#define isnil(X)              ((X) == nil)

obj *omake(enum otype type, int count, ...) {
  obj *ret;
  va_list ap;
  int i;
  va_start(ap, count);
  ret = (obj *) malloc(sizeof(obj) + (count - 1)*sizeof(obj *));
  ret->type = type;
  for(i = 0; i < count; i++) ret->p[i] = va_arg(ap, obj *);
  va_end(ap);
  return ret;
}

obj *findsym(char *name) {
  obj *symlist;
  for(symlist = all_symbols; !isnil(symlist); symlist = cdr(symlist))
    if(!strcmp(name, symname(car(symlist))))
      return symlist;
  return nil;
}

obj *intern(char *name) {
  obj *op = findsym(name);
  if(!isnil(op)) return car(op);
  op = mksym(name);
  all_symbols = cons(op, all_symbols);
  return op;
}

/*** Environment ***/
#define extend(ENV, SYM, VAL) (cons(cons((SYM), (VAL)), (ENV)))

obj *multiple_extend(obj *env, obj *syms, obj *vals) {
  return isnil(syms) ? 
         env : 
         multiple_extend(extend(env, car(syms), car(vals)),
                         cdr(syms), cdr(vals));
}

obj *extend_top(obj *sym, obj *val) {
  setcdr(top_env, cons(cons(sym, val), cdr(top_env)));
  return val;
}

obj *assoc(obj *key, obj *alist) {
  if(isnil(alist)) return nil;
  if(car(car(alist)) == key) return car(alist);
  return assoc(key, cdr(alist));
}

/*** Input/Output ***/
FILE *ifp;
char *token_la;
int la_valid = 0;
#define MAXLEN 100
char buf[MAXLEN];
int bufused;

void add_to_buf(char ch) { if(bufused < MAXLEN - 1) buf[bufused++] = ch; }
char *buf2str()          { buf[bufused++] = '\0'; return strdup(buf); }
void setinput(FILE *fp)  { ifp = fp; }
void putback_token(char *token) { token_la = token; la_valid = 1; }

char *gettoken() {
  int ch;

  bufused = 0;
  if(la_valid) { la_valid = 0; return token_la; }
  do {
    if((ch = getc(ifp)) == EOF) exit(0);
  } while(isspace(ch));
  add_to_buf(ch);
  if(strchr("()\'", ch)) return buf2str();
  for(;;) {
    if((ch = getc(ifp)) == EOF) exit(0);
    if(strchr("()\'", ch) || isspace(ch)) {
      ungetc(ch, ifp);
      return buf2str();
    }
    add_to_buf(ch);
  }
}

obj *readlist();
obj *readobj() {
  char *token;

  token = gettoken();
  if(!strcmp(token, "(")) return readlist();
  if(!strcmp(token, "\'")) return cons(quote, cons(readobj(), nil));
  if(token[strspn(token, "0123456789")] == '\0') return mkint(atoi(token));
  return intern(token);
}

obj *readlist() {
  char *token = gettoken();
  obj *tmp;
  if(!strcmp(token, ")")) return nil;
  if(!strcmp(token, ".")) {
    tmp = readobj();
    if(strcmp(gettoken(), ")")) exit(1);
    return tmp;
  }
  putback_token(token);
  tmp = readobj(); /* Must force evaluation order */
  return cons(tmp, readlist());
}

void writeobj(FILE *ofp, obj *op) {
  switch(op->type) {
    case INT:  fprintf(ofp, "%d", intval(op)); break;
    case CONS: 
		fprintf(ofp, "(");
		for(;;) {
			writeobj(ofp, car(op));
			if(isnil(cdr(op))) {
				fprintf(ofp, ")");
				break;
			}
			op = cdr(op);
			if(op->type != CONS) {
				fprintf(ofp, " . ");
				writeobj(ofp, op);
				fprintf(ofp, ")");
				break;
			}
			fprintf(ofp, " ");
		}
		break;
    case SYM:
		if(isnil(op)) fprintf(ofp, "()");
		else          fprintf(ofp, "%s", symname(op));
		break;
    case PRIMOP: fprintf(ofp, "#<PRIMOP>"); break;
    case PROC:   fprintf(ofp, "#<PROC>"); break;
    default: exit(1);
  }
}

/*** Evaluator (Eval/no Apply) ***/
obj *evlis(obj *exps, obj *env);

obj *eval(obj *exp, obj *env) {
  obj *tmp, *proc, *vals;

  eval_start:
  
  if(exp == nil) return nil;

  switch(exp->type) {
    case INT:   return exp;
    case SYM:   tmp = assoc(exp, env);
                if(tmp == nil) error("Unbound symbol");
                return cdr(tmp);
    case CONS:  if(car(exp) == s_if) {
		  if(eval(car(cdr(exp)), env) != nil)
		    exp = car(cdr(cdr(exp)));
		  else
		    exp = car(cdr(cdr(cdr(exp))));
                  goto eval_start;
		}
		if(car(exp) == s_lambda)
		  return mkproc(car(cdr(exp)), cdr(cdr(exp)), env);
		if(car(exp) == quote)
		  return car(cdr(exp));
		if(car(exp) == s_define)
		  return(extend_top(car(cdr(exp)),
		                    eval(car(cdr(cdr(exp))), env)));
		if(car(exp) == s_setb) {
		  obj *pair   = assoc(car(cdr(exp)), env);
		  obj *newval = eval(car(cdr(cdr(exp))), env);
		  setcdr(pair, newval);
		  return newval;
		}
                if(car(exp) == s_begin) {
                  exp = cdr(exp);
                  if(exp == nil) return nil;
                  for(;;) {
                    if(cdr(exp) == nil) {
                      exp = car(exp);
                      goto eval_start;
                    }
                    eval(car(exp), env);
                    exp = cdr(exp);
                  }
                }
                proc = eval(car(exp), env);
                vals = evlis(cdr(exp), env);
                if(proc->type == PRIMOP)
                  return (*primopval(proc))(vals);
                if(proc->type == PROC) {
                  /* For dynamic scope, use env instead of procenv(proc) */
                  env = multiple_extend(procenv(proc), procargs(proc), vals);
                  exp = cons(s_begin, proccode(proc));
                  goto eval_start;
                }
                error("Bad PROC type");
    case PRIMOP: return exp;
    case PROC:   return exp;
  }
  /* Not reached */
  return exp; 
}

obj *evlis(obj *exps, obj *env) {
  if(exps == nil) return nil;
  return cons(eval(car(exps), env), 
              evlis(cdr(exps), env));
}

/*** Primitives ***/
obj *prim_sum(obj *args) {
  int sum;
  for(sum = 0; !isnil(args); sum += intval(car(args)), args = cdr(args));
  return mkint(sum);
}

obj *prim_sub(obj *args) {
  int sum;
  for(sum = intval(car(args)), args = cdr(args); 
      !isnil(args); 
      sum -= intval(car(args)), args = cdr(args));
  return mkint(sum);
}

obj *prim_prod(obj *args) {
  int prod = 1;
  for(prod = 1; !isnil(args); prod *= intval(car(args)), args = cdr(args));
  return mkint(prod);
}

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

obj *prim_cons(obj *args) { return cons(car(args), car(cdr(args))); }
obj *prim_car(obj *args)  { return car(car(args)); }
obj *prim_cdr(obj *args)  { return cdr(car(args)); }

/*** Initialization ***/
void init_sl3() {
  nil = mksym("nil");
  all_symbols = cons(nil, nil);
  top_env  = cons(cons(nil, nil), nil);
  tee      = intern("t");
  extend_top(tee, tee);
  quote    = intern("quote");
  s_if     = intern("if");
  s_lambda = intern("lambda");
  s_define = intern("define");
  s_setb   = intern("set!");
  s_begin  = intern("begin");
  extend_top(intern("+"), mkprimop(prim_sum));
  extend_top(intern("-"), mkprimop(prim_sub));
  extend_top(intern("*"), mkprimop(prim_prod));
  extend_top(intern("="), mkprimop(prim_numeq));
  extend_top(intern("cons"), mkprimop(prim_cons));
  extend_top(intern("car"),  mkprimop(prim_car));
  extend_top(intern("cdr"),  mkprimop(prim_cdr));
}

/*** Main Driver ***/
int main() {
  init_sl3();
  setinput(stdin);
  for(;;) {
    writeobj(stdout, eval(readobj(), top_env));
    printf("\n");
  }
  return 0;
}