набросок, припадок четвертый, ч. 2

void *new_symbol_table();
void delete_symbol_table(void *table);
uint32_t new_symbol(void *table, const char *name, int len);
uint32_t num_symbols(void *table);

struct symbol_table {
  uint32_t next;
  tr1::unordered_map<string, uint32_t> table;
};
uint32_t new_symbol(void *table, const char *name, int len) {
  string str = sym_name(name, len);
  symbol_table *st = (symbol_table *)table;
  if (st->table.find(str) != st->table.end()) return st->table[str];
  st->table[str] = st->next++;
  return st->next-1;
}

uint32_t make_vector(uint32_t size, int zero_it) {
  uint32_t len = (size+1)/2;  /* num of extra cells required */
  CHECK_CELLS(len+1);
  uint32_t index = next_cell;
  uint64_t value = T_VECT | (uint64_t)len << 16 | (uint64_t)(size) << 32;
  cells[next_cell++] = value;
  if (zero_it) memset(VECTOR_START(index), 0, size*sizeof(uint32_t));
  next_cell += len;
  return index;
}

uint32_t make_env(uint32_t size, uint32_t prev) {
  uint32_t env = make_vector(size+1, 1);
  *VECTOR_START(env) = prev;
  return env;
}

#define T_VAR    9  /* reference to a lexical variable */
#define VAR_FRAME(i) (uint32_t)((cells[i] >> 32) & 0xFFFF)
#define VAR_SLOT(i) (uint32_t)((cells[i] >> 32) >> 16)

uint32_t store_var(uint32_t slot, uint32_t frame) {
  uint64_t value = T_VAR;
  CHECK_CELLS(1);
  uint32_t index = next_cell;
  cells[next_cell++] = value | ((uint64_t)frame << 32) |
                         (uint64_t)slot << 48;
  return index;
}
....in dump_value()...
    case T_VAR:
      printf("#<var:%u,%u>", VAR_SLOT(index), VAR_FRAME(index));
      break;

uint32_t prepare(uint32_t index) {
  switch(TYPE(index)) {
    case T_SYM:
      break;
    case T_PAIR:
      break;
    default:
      break;
  }
  return index;
}

... in main() ...
    int can_read = read_value(&str, &index, 0);
    if (can_read) {
      uint32_t prepared = prepare(index);
      if (prepared) { 
        uint32_t res = eval(prepared);
        if (res) {
          dump_value(res, 0); printf("\n");
        } else printf("eval failed.\n");
      } else printf("prepare failed.\n");
    } else printf("failed reading at: %s\n", str);

int find_symbol(const char *name, int len, uint32_t *slot, uint32_t *frame);
void add_symbol(const char *name, int len, uint32_t *slot, uint32_t *frame);
void add_symbol_table();
void delete_symbol_table();
uint32_t latest_table_size();

struct symbol_table {
  uint32_t next;
  tr1::unordered_map<string, uint32_t> table;
};

list<symbol_table> tables;

int find_symbol(const char *name, int len, uint32_t *slot, uint32_t *frame) {
  string str = sym_name(name, len);
  int pos = 0;
  for (list<symbol_table>::iterator it = tables.begin();
       it != tables.end(); ++it, ++pos) {
    if (it->table.find(str) != it->table.end()) {
      *slot = it->table[str];
      *frame = pos;
      return 1;
    }
  }
  return 0;
}

  switch(TYPE(index)) {
    case T_SYM:
      res = find_symbol(STR_START(index), STR_LEN(index), &slot, &frame);
      if (res) {
        uint32_t var = store_var(slot, frame);
        return var;
      } else {
        printf("Undefined variable: "); dump_value(index, 0);
        return 0;
      }
      break;

(lambda (a b)
  (define x (+ y a))
  (define y 4)
  (...)
)

    case T_PAIR:
      func = CAR(index);
      args = CDR(index);
      if (!LIST_LIKE(args)) {
        printf("A dot pair but not a list in prepare()\n");
        return 0;
      };
      if (TYPE(func) == T_SYM) {
        if (IS_SYMBOL(func, "quote")) return index;

        if (IS_SYMBOL(func, "define")) {
          if (!check_list(args, 2, 1)) die("bad define/set! syntax");
          sym = CAR(args);
          if (TYPE(sym) != T_SYM) die("bad define syntax in prepare");
          add_symbol(STR_START(sym), STR_LEN(sym), &slot, &frame);
          uint32_t var = store_var(slot, frame);
          /* replace the symbol with the variable */
          SET_CAR(args, var);
          if (deferred_define) {
            *deferred_define = CDR(args);  /* (val) not val, deliberately. */
            return 1;
          } else {
            if (prepare_list(CDR(args)) == 0) return 0;
            else return index;
          }
        }

        if (IS_SYMBOL(func, "lambda")) {
          /* Easier to add/delete symbol tables here than chase exit points
             in prepare_lambda(). */
          add_symbol_table();
          uint32_t res = prepare_lambda(args);
          delete_symbol_table();
          return res;
        }
      }
      /* The usual case: resolve the list recursively. */
      return prepare_list(index);
      break;

uint32_t prepare_lambda(uint32_t args) {
  ...
  /* Basic argument correctness. */
  ...
  /* Walk the argument list and create slots. TODO: check uniqueness */
  int args_number = length_list(args_list);
  while(args_list != C_EMPTY) {
    uint32_t sym = CAR(args_list);
    if (TYPE(sym) != T_SYM) die ("not a symbol in lambda arg list");
    add_symbol(STR_START(sym), STR_LEN(sym), &slot, &frame);
    args_list = CDR(args_list);
  }

  /* Go over the body and walk it recursively, deferring defines. */
  uint32_t body = CDR(args);
  while (body != C_EMPTY) {
    uint32_t statement = CAR(body);
    defines[defines_curr] = 0;
    uint32_t res = prepare(statement, &defines[defines_curr]);
    ...
  }

  /* Go over deferred define bodies, if any. */
  ...

  /* Create a T_FUNC, record the number of slots. */
  CHECK_CELLS(2);
  uint32_t index = next_cell;
  uint64_t value = T_FUNC;
  uint32_t count_vars = latest_table_size();
  value |= (uint64_t)count_vars << 32;
  value |= (uint64_t)args_number << 48;
  cells[next_cell++] = value;

  // Higher 32-bit will be an env pointer in closures. */
  cells[next_cell++] = (uint64_t)CDR(args);
  return index;
}

> sketch
59 cells> (define top-level 6)
prepared: (define #<var:28,0> 6)
72 cells> (lambda () 5)
prepared: *func:0 vars, 0 args, body:(5)*
83 cells> (lambda (arg1) arg1)
prepared: *func:1 vars, 1 args, body:(#<var:1,0>)*
100 cells> (lambda (arg1 arg2) (define in-func 15))
prepared: *func:3 vars, 2 args, body:((define #<var:3,0> 15))*
130 cells> (lambda (arg1 arg2) (define in-func 15) '(arg1 in-func))
prepared: *func:3 vars, 2 args, body:((define #<var:3,0> 15) (quote (arg1 in-func)))*
176 cells> (lambda (arg1 arg2) (define in-func 15) (list arg1 in-func))
prepared: *func:3 vars, 2 args, body:((define #<var:3,0> 15)
   (#<var:15,1> #<var:1,0> #<var:3,0>))*

        /* Special forms that don't exist in the symbol table. TODO: simplify. */
        if (IS_SYMBOL(func, "set!") || IS_SYMBOL(func, "if")) {
          /* only walk the args */
          uint32_t res = prepare_list(args);
          if (res == 0) return 0;
          return index;
        }

...in common.h....
extern uint32_t toplevel_env;

...in sketch.c...
uint32_t toplevel_env = 0;

void store_env(uint32_t env, uint32_t slot, uint32_t value) {
  if (slot > VECTOR_LEN(env)) {
    /* TODO: do something smart for the toplevel environment */
    die("environment out of range");
  }
  VECTOR_START(env)[slot] = value;
}

... in main()...
  toplevel_env = make_env(10000, 1);

... in builtins.c, register_builtin()....

  set_symbol(name, strlen(name), index);

  uint32_t slot, frame;
  add_symbol(name, strlen(name), &slot, &frame);
  store_env(toplevel_env, slot, index);

    case T_SYM:
      printf("eval: should not get a naked symbol");
      return 0;
    case T_VAR:
      slot = VAR_SLOT(index);
      frame = VAR_FRAME(index);
      while (frame > 0) {
        if (env == 0) die("bad frame or env in eval");
        env = VECTOR_START(env)[0]; frame--;
      }
      if (env == 0) die("bad frame or env in eval");
      return VECTOR_START(env)[slot];

   case T_FUNC:
      /* Executing a lambda form. */
      ... some error-checking...

      /* Copy the T_FUNC and set its environment. */
      CHECK_CELLS(2);
      uint32_t new_index = next_cell;
      cells[next_cell++] = cells[index];
      cells[next_cell++] = cells[index+1];
      SET_CAR(new_index, env);
      return new_index;

     /* evaluate arguments and call the function */
      uint32_t num_args;
      if (!eval_args(args, env, arg_array, &num_args)) return 0;
      if (cells[val] & BLTIN_MASK) {   /* builtin function */
         ... skipped ...
      } else {  /* lambda function */
        uint32_t body = FUNC_BODY(val);
        if (num_args != FUNC_ARGCOUNT(val)) {
          printf("eval: number of args mismatch.\n");
          return 0;
        }
        /* Create a new environment, tied to the one stored in T_FUNC. */
        /* If we did our job right, zero_it in the call to make_env() is
           not necessary. */
        uint32_t new_env = make_env(FUNC_VARCOUNT(val), 0);
        VECTOR_START(new_env)[0] = FUNC_ENV(val);
        for (uint32_t i = 0; i < num_args; i++) {
          store_env(new_env, i+1, arg_array[i]);
        }
        uint32_t retval = C_UNSPEC;
        while (body != C_EMPTY) {
          retval = eval(CAR(body), new_env);
          if (retval == 0) return 0;
          body = CDR(body);
        }
        return retval;
      }

/* 1 if we seem to be inside a list, based on parens parity */
int in_flight(char *str) {
  int paren_level = 0;
  int in_string = 0;
  while (*str) {
    if (*str == '(' && !in_string) paren_level++;
    if (*str == ')' && !in_string) {
      if (paren_level == 0) return 0;
      else paren_level --;
    }
    if (*str == '#' && *(str+1) == '\\' && !in_string) str+=2;
    if (*str == '\\' && in_string) str++;
    if (*str == '"') in_string = !in_string;
    str++;
  }
  return (paren_level > 0 || in_string);
}

$ ./sketch 
5061 cells> (define fact (lambda (n)
... (define prev (fact (+ n -1)))
... (* prev n)
... ))

5136 cells> (fact 3)
Segmentation fault

5421 cells> (define fact (lambda (n)
... (define prev (if (eqv? n 1) 1 (fact (+ n -1))))
... (* n prev)
... ))

5520 cells> (fact 3)
6
5574 cells> (fact 10)
3628800

5138 cells> (define count-maker (lambda ()
... ((lambda(n)
... (lambda () (set! n (+ n 1)) n)) 0)
... ))
5234 cells> (define c1 (count-maker))
5259 cells> (c1)
1
5271 cells> (c1)
2
5283 cells> (c1)
3
5295 cells> (define c2 (count-maker))
5320 cells> (c2)
1
5332 cells> (c1)
4
5344 cells> (c2)
2