Closures/Value capture/C

Very quickly hacked up dynamically typed environment, with no garbage collection, and abort for error handling.

<lang c>#include <stdio.h>

1. include <stdarg.h>
2. include <stdlib.h>
3. include <assert.h>
4. include <string.h>

struct function; struct number; struct symbol; struct string; struct cons;

enum type_tag {

 FUN, NUM, SYM, STR, CON

};

typedef struct obj *val;

1. define nil ((val) 0)
2. define nao ((val) 1) /* "not an object" */

struct number {

 int n;

};

struct string {

 const char *s;
 int dynamic;

};

struct symbol {

 val name;

};

struct cons {

 val car, cdr;

};

struct function {

 val nargs;
 val has_env;
 val env;
 union {
   /* First arg is environment */
   val (*f0)(val);
   val (*f1)(val, val);
   val (*f2)(val, val, val);
   /* No environment */
   val (*n0)(void);
   val (*n1)(val);
   val (*n2)(val, val);
 } u;

};

struct obj {

 enum type_tag tt;
 union {
   struct function fun;
   struct number num;
   struct string str;
   struct symbol sym;
   struct cons cons;
 } u;

};

val t, x; val sym_list = nil;

val mkobj(enum type_tag tt) {

 val v = malloc(sizeof *v);
 if (!v)
   abort();
 v->tt = tt;
 return v;

}

val cons(val car, val cdr) {

 val c = mkobj(CON);
 c->u.cons.car = car;
 c->u.cons.cdr = cdr;
 return c;

}

val car(val cons) {

 if (cons == nil)
   return nil;
 assert (cons->tt == CON);
 return cons->u.cons.car;

}

val cdr(val cons) {

 if (cons == nil)
   return nil;
 assert (cons->tt == CON);
 return cons->u.cons.cdr;

}

val num(int n) {

 val vn = mkobj(NUM);
 vn->u.num.n = n;
 return vn;

}

int cnum(val vn) {

 assert (vn->tt == NUM);
 return vn->u.num.n;

}

val str(const char *s) {

 size_t size = strlen(s) + 1;
 val sv = mkobj(STR);
 char *sd = malloc(size);

 if (!sv || !sd)
   abort();

 memcpy(sd, s, size);
 sv->u.str.s = sd;
 sv->u.str.dynamic = 1;
 return sv;

}

val lit(const char *s) {

 val sv = mkobj(STR);

 if (!sv)
   abort();

 sv->u.str.s = s;
 sv->u.str.dynamic = 0;
 return sv;

}

const char *cstr(val vs) {

 assert (vs->tt == STR);
 return vs->u.str.s;

}

val equal(val left, val right) {

 if (left == right) /* same object */
   return t;

 if (left == nil || right == nil) /* nil only equal to itself */
   return nil;

 if (left->tt != right->tt) /* different types are not equal */
   return nil;

 switch (left->tt) {
 case FUN: /* identity equivalence */
 case SYM: /* ditto, of course */
   /* left and right are different objects, so ... */
   break;
 case NUM: /* numeric equivalence */
   if (left->u.num.n == right->u.num.n)
     return t;
   break;
 case STR: /* case sensitive equality */
   if (strcmp(left->u.str.s, right->u.str.s) == 0)
     return t;
   break;
 case CON: /* similar structure and equal atoms! */
   if (equal(car(left), car(right)) && equal(cdr(left), cdr(right)))
     return t;
   break;
 }

 return nil;

}

val assoc(val list, val key) {

 for (; list != nil; list = cdr(list)) {
   val item = car(list);
   if (equal(key, car(item)))
     return item;
 }
 return nil;

}

val intern(val name) {

 val exist = assoc(sym_list, name);

 if (exist) {
   return cdr(exist);
 } else {
   val sym = mkobj(SYM);

   sym->u.sym.name = name;
   sym_list = cons(cons(name, sym), sym_list);
   return sym;
 }

}

/*

* Hoist C functions into environment-carrying closures.
*/

val func_f0(val env, val (*cfun)(val)) {

 val f = mkobj(FUN);
 f->u.fun.nargs = num(0);
 f->u.fun.has_env = t;
 f->u.fun.env = env;
 f->u.fun.u.f0 = cfun;
 return f;

}

val func_f1(val env, val (*cfun)(val, val)) {

 val f = mkobj(FUN);
 f->u.fun.nargs = num(1);
 f->u.fun.has_env = t;
 f->u.fun.env = env;
 f->u.fun.u.f1 = cfun;
 return f;

}

val func_f2(val env, val (*cfun)(val, val, val)) {

 val f = mkobj(FUN);
 f->u.fun.nargs = num(2);
 f->u.fun.has_env = t;
 f->u.fun.env = env;
 f->u.fun.u.f2 = cfun;
 return f;

}

/*

* Hoist C functions into environment-free functions
*/

val func_n0(val (*cfun)(void)) {

 val f = mkobj(FUN);
 f->u.fun.nargs = num(0);
 f->u.fun.has_env = nil;
 f->u.fun.env = nil;
 f->u.fun.u.n0 = cfun;
 return f;

}

val func_n1(val (*cfun)(val)) {

 val f = mkobj(FUN);
 f->u.fun.nargs = num(1);
 f->u.fun.has_env = nil;
 f->u.fun.env = nil;
 f->u.fun.u.n1 = cfun;
 return f;

}

val func_n2(val (*cfun)(val, val)) {

 val f = mkobj(FUN);
 f->u.fun.nargs = num(2);
 f->u.fun.has_env = nil;
 f->u.fun.env = nil;
 f->u.fun.u.n2 = cfun;
 return f;

}

val funcall(val f, ...) {

 va_list vl;
 int argc;
 val arg[5];

 assert (f->tt == FUN);

 va_start (vl, f);

 for (argc = 0; argc < 5; argc++) {
   val v = va_arg (vl, val);
   if (v == nao)
     break;
   arg[argc] = v;
 }

 if (argc != cnum(f->u.fun.nargs))
   abort();

 if (f->u.fun.has_env) {
   switch (cnum(f->u.fun.nargs)) {
   case 0:
     return f->u.fun.u.f0(f->u.fun.env);
   case 1:
     return f->u.fun.u.f1(f->u.fun.env, arg[0]);
   case 2:
     return f->u.fun.u.f2(f->u.fun.env, arg[0], arg[1]);
   }
 } else {
   switch (cnum(f->u.fun.nargs)) {
   case 0:
     return f->u.fun.u.n0();
   case 1:
     return f->u.fun.u.n1(arg[0]);
   case 2:
     return f->u.fun.u.n2(arg[0], arg[1]);
   }
 }

 abort();

}

void init(void) {

 t = intern(lit("t"));
 x = intern(lit("x"));

}

val square(val env) {

 val xbind = assoc(env, x); /* look up binding of variable x in env */
 val xval = cdr(xbind);     /* value is the cdr of the binding cell */
 return num(cnum(xval) * cnum(xval));

}

int main(void) {

 int i;
 val funlist = nil, iter;

 init();

 for (i = 0; i < 10; i++) {
   val closure_env = cons(cons(x, num(i)), nil);
   funlist = cons(func_f0(closure_env, square), funlist);
 }

 for (iter = funlist; iter != nil; iter = cdr(iter)) {
   val fun = car(iter);
   val square = funcall(fun, nao);

   printf("%d\n", cnum(square));
 }
 return 0;

}</lang>