esotericbot-0.0.1: c_plugins/unlambda.c
/* Unlambda interpreter */
/* Copyright 1999 Jacob L. Mandelson
* This software may be distributed and modified without charge
* for noncommercial recreational or educational purposes provided
* that this copyright and statement is included in all copies.
*/
#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
#include <time.h>
#include <termios.h>
#include <unistd.h>
#include <string.h>
/* Macros */
#define dupatom(A) (((A)->refcount++, (A)))
#define dupexpr(A) (((A)->refcount++, (A)))
#define freeatom(A) (--(A)->refcount ? 0 : Freeatom((A)))
#define freeexpr(A) (--(A)->refcount ? 0 : Freeexpr((A)))
#define NextContext() ((CurrentContext+1 == \
CurrentContinuation.contextlist+CurrentContinuation.Ncontexts \
? grow_context_list(&CurrentContinuation, &CurrentContext) \
: 0), CurrentContext+1)
/* Take care using these macros */
#define PUSHCONTEXT CurrentContext++; continue;
#define POPCONTEXT if (CurrentContext == CurrentContinuation.contextlist) \
{ free(CurrentContext); return rv; } \
else { CurrentContext--; continue; }
#define MKA(x) ((struct atom*)(x))
#define MKE(x) ((struct expr*)(x))
#define STRING(x) #x
/* Make a #define */
#define MKDF(x) "#define " #x " " STRING(x) "\n"
static char preamble [] =
"#include <stdio.h>\n"
"#include <stdlib.h>\n"
"#include <termios.h>\n"
"#include \"strtail.h\"\n"
"#define IN(x)\n"
"#define output stdout\n"
"#define atomI atom0002\n"
"#define atomV atom0003\n"
"#define zz ,\n"
MKDF(dupatom(A)) MKDF(dupexpr(A)) MKDF(freeatom(A))
MKDF(freeexpr(A)) MKDF(NextContext()) MKDF(PUSHCONTEXT)
MKDF(POPCONTEXT) MKDF(MKA(x)) MKDF(MKE(x));
#define IN(x) x /* Stuff that's only in the interpreter, not in
* the compiler output. */
#define zz , /* Protect commas from the preprocessor */
long Nmalloc, Nfree;
FILE *output;
struct char_lock * input;
void error(char []);
struct atom;
void unparseA(struct atom* a);
static void *my_malloc(size_t size)
{ void *rv = malloc(size);
Nmalloc++;
if (!rv) error("Out of memory.");
return rv;
}
static void *my_realloc(void *p, size_t size)
{ void *rv = realloc(p, size);
if (!rv) error("Out of memory.");
return rv;
}
#define malloc my_malloc
#define realloc my_realloc
#define free(x) ((Nfree++, free(x)))
#define MKSC(x) #x ; x /* Make string and code */
char progbody[] = MKSC(
/* Code common to the parser+interpreter and the
* "compiled" (*cough*) interpreter.
*/
/* Data structures. */
/* Continuation is a list of contexts. */
struct continuation {
IN(int tag;)
long Ncontexts;
struct context *contextlist;
};
/* Contexts contain the "stage" of execution, and arguments to execute.
* See comment below. */
struct context {
enum Stage { Eval1 zz Eval2 zz Eval3 zz Apply1 zz S2a zz S2b zz D1a } stage;
void *Arg1 zz *Arg2 zz *Int;
};
/* The unlambda expression.
* Expression is either an atom, or `FG where F, G are unlambda expressions.
*/
struct atom {
IN(int tag;)
long refcount;
enum atomtype { K zz K1 zz S zz S1 zz S2 zz I zz V zz C zz C1 zz D zz D1 zz
Print zz Exit zz Read zz Query zz Reprint } type;
/* Arguments: K1, S1: One atom. D1: One expression. S2: Two atoms. */
/* Print: character. C1: continuation. */
union {
char character;
struct atom* oneatom;
struct { struct atom *a1 zz *a2; } twoatom;
struct expr* expression;
struct continuation continuation;
} d;
};
struct expr {
IN(int tag;)
long refcount;
enum { ATOM zz APPLY } type;
void *arg1; /* struct atom* for ATOM, struct expr* for APPLY */
struct expr *e2; /* Not used if ATOM */
};
static int Freeexpr(struct expr *E);
void error(char []);
static void FreeContinuation(struct continuation , struct context *);
static int Freeatom(struct atom *A)
{
switch (A->type) {
case S: case K: case I: case V: case C: case D: case Print:
case Exit: case Read: case Query: case Reprint:
/* Nothing. A leaf. */ break;
case S1: case K1:
freeatom(A->d.oneatom); break;
case S2:
freeatom(A->d.twoatom.a1); freeatom(A->d.twoatom.a2); break;
case D1:
freeexpr(A->d.expression); break;
case C1:
FreeContinuation(A->d.continuation,
A->d.continuation.contextlist+A->d.continuation.Ncontexts-2);
/* Last saved context is contextlist[Ncontexts-2] because current
* context wasn't saved when the continuation was saved. */
break;
default:
error("Unknown type to free!");
}
free(A);
return 0;
}
static int Freeexpr(struct expr *E)
{
if (E->type == ATOM) freeatom(MKA(E->arg1));
else { freeexpr(MKE(E->arg1)); freeexpr(E->e2); }
free(E);
return 0;
}
void error(char msg[])
{
fprintf(stderr, "Error: %s\n", msg);
exit(-1);
}
/* Context element:
[ Stage, Arg1, Arg2, RV, Int ]
Arg{1,2} are arguments
Int is intermediate value
RV is return value from last step.
Not saved with continuatoin! Just variable for passing value "up"
the stack.
Stage is Eval1: Arg1 is e
Eval2: Arg1 is e, RV is eval(e.e1)
Eval3: Arg1 is e, Int is eval(e.e1), RV is eval(e.e2)
Eval4: Arg1 is e, RV is apply(eval(e.e1), eval(e.e2))
Short-circuited to Apply1
Apply1: Arg1 is a1, Arg2 is a2
S2a: Arg1 is a1, Arg2 is a2, RV is apply(a1.a1, a2)
S2b: Arg1 is a1, Arg2 is a2,
RV is apply(a1.a2, a2), Int is apply(a1.a1, a2)
S2c: RV is apply( apply(a1.a1, a2), apply(a1.a2, a2) )
Short-circuited to Apply1
D1a: Arg2 is a2, RV is eval(a1.e)
D1b: RV is apply( eval(a1.e), a2)
Short-circuited to Apply1
*/
static int grow_context_list(struct continuation *CC, struct context **con)
{
long cidx = *con - CC->contextlist;
CC->Ncontexts += CC->Ncontexts/2 + 128;
CC->contextlist = realloc(CC->contextlist,
CC->Ncontexts * sizeof(struct context) );
*con = CC->contextlist + cidx;
return 0;
}
IN(static int Ncontinuations;)
static int lastchar = EOF;
static struct continuation
SaveContinuation(struct continuation CC, struct context *cxt)
{
struct continuation rv;
IN(rv.tag = ++Ncontinuations;)
rv.Ncontexts = cxt - CC.contextlist + 1;
rv.contextlist = malloc(rv.Ncontexts * sizeof(*rv.contextlist));
/* Save contexts up to (but not including) current context.
* Don't save current context because it is consumed by making the
* C call, and replaced by the argument when the continuation is resumed.
*/
while (--cxt >= CC.contextlist) {
rv.contextlist[cxt - CC.contextlist] = *cxt;
switch (cxt->stage) {
case Eval3:
MKA(cxt->Int)->refcount++;
/* FALLTHROUGH */
case Eval2:
MKE(cxt->Arg1)->refcount++;
break;
case S2b:
MKA(cxt->Int)->refcount++;
MKA(cxt->Arg1)->refcount++;
break;
case S2a:
MKA(cxt->Arg1)->refcount++;
/* FALLTHROUGH */
case D1a:
MKA(cxt->Arg2)->refcount++;
break;
case Eval1: case Apply1: default:
error("Unknown stage to SaveContinuation!");
}
}
return rv;
}
/* Free continuation, and contexts in continuation from
* CC.contextlist[0] to ctx */
static void FreeContinuation(struct continuation CC, struct context *ctx)
{
for ( ; ctx >= CC.contextlist; ctx--) {
switch (ctx->stage) {
case Eval3:
freeatom(MKA(ctx->Int));
/* FALLTHROUGH */
case Eval2:
freeexpr(MKE(ctx->Arg1));
break;
case S2b:
freeatom(MKA(ctx->Int));
freeatom(MKA(ctx->Arg1));
break;
case Apply1: case S2a:
freeatom(MKA(ctx->Arg1));
/* FALLTHROUGH */
case D1a:
freeatom(MKA(ctx->Arg2));
break;
case Eval1: default:
error("Bad stage to FreeContinuation!");
}
}
free(CC.contextlist);
}
/* Resuming a continuation must copy to the Current Continuation, not
* just make a ref., because changes to the CC in the course of execution
* should not affect copys of the continuation resumed. */
void RestoreContinuation(struct continuation cont, struct continuation *CC,
struct context **cxt)
{ long i;
CC->Ncontexts = cont.Ncontexts;
CC->contextlist = malloc(cont.Ncontexts * sizeof(*CC->contextlist));
memcpy(CC->contextlist, cont.contextlist,
cont.Ncontexts * sizeof(*CC->contextlist));
for (i = 0; i < cont.Ncontexts-1; i++) {
/* Ncontexts-1 because Current Context wasn't saved with the continuation. */
switch (cont.contextlist[i].stage) {
case Eval3:
MKA(cont.contextlist[i].Int)->refcount++;
/* FALLTHROUGH */
case Eval2:
MKE(cont.contextlist[i].Arg1)->refcount++;
break;
case S2b:
MKA(cont.contextlist[i].Int)->refcount++;
MKA(cont.contextlist[i].Arg1)->refcount++;
break;
case S2a:
MKA(cont.contextlist[i].Arg1)->refcount++;
/* FALLTHROUGH */
case D1a:
MKA(cont.contextlist[i].Arg2)->refcount++;
break;
case Eval1: case Apply1: default:
error("Unknown stage to RestoreContinuation!");
}
}
*cxt = &CC->contextlist[cont.Ncontexts-1];
}
/* Forward declerations */
extern struct atom atomV;
extern struct atom atomI;
/* Evaluate an expression. */
/* Maintains an explicit call stack, because it needs to save the contexts
* of all the function calls when the continuation is saved.
* The NextContext()->Arg1 = rv stuff is just setting up the Arguments
* for the next context in the computation, a la passing arguments to
* functions in Assembly.
* For example, pasting the "function calls" together for S2 (the
* most complicated case), gives:
* rv = apply(dupatom(a1->d.twoatom.a1), dupatom(a2));
* rv = apply(rv, apply(dupatom(a1->d.twoatom.a2), a2));
* freeatom(a1); return rv;
*/
struct atom *eval(struct expr *e)
{ struct atom *rv;
struct continuation CurrentContinuation;
struct context *CurrentContext;
struct context *nc; /* Next Context */
IN(CurrentContinuation.tag = 0;)
CurrentContinuation.Ncontexts = 1024;
CurrentContext = CurrentContinuation.contextlist =
malloc(CurrentContinuation.Ncontexts * sizeof(struct context));
CurrentContext->Arg1 = e;
CurrentContext->stage = Eval1;
/* This state machine is the engine: It interprets the unlambda expression. */
for (;;) {
switch (CurrentContext->stage) {
case Eval1:
e = CurrentContext->Arg1;
if (e->type == ATOM) {
rv = e->arg1;
--e->refcount ? rv->refcount++ : free(e);
POPCONTEXT
} else /* APPLY */ {
CurrentContext->stage = Eval2;
(nc=NextContext())->stage = Eval1;
nc->Arg1 = dupexpr(MKE(e->arg1));
PUSHCONTEXT
}
case Eval2: {
struct atom *a1 = rv;
e = CurrentContext->Arg1;
if (a1->type == D) /* Delay */ {
rv = malloc(sizeof *rv);
rv->refcount = 1;
rv->type = D1;
rv->d.expression = e->e2;
if (!--e->refcount) {
freeexpr(MKE(e->arg1));
free(e);
} else {
e->e2->refcount++;
}
if (!--a1->refcount) free(a1);
POPCONTEXT
} else {
CurrentContext->stage = Eval3;
CurrentContext->Int = a1;
(nc=NextContext())->stage = Eval1;
nc->Arg1 = dupexpr(e->e2);
PUSHCONTEXT
}
}
case Eval3:
freeexpr(MKE(CurrentContext->Arg1));
CurrentContext->stage = Apply1;
CurrentContext->Arg2 = rv;
CurrentContext->Arg1 = CurrentContext->Int;
continue;
case Apply1: {
struct atom *a1 = CurrentContext->Arg1 zz
*a2 = CurrentContext->Arg2;
switch (a1->type) {
case K: rv = malloc(sizeof *rv);
rv->refcount = 1;
rv->type = K1; rv->d.oneatom = a2; break;
case K1: rv = a1->d.oneatom; freeatom(a2);
if (a1->refcount != 1) rv->refcount++;
break;
case S: rv = malloc(sizeof *rv);
rv->refcount = 1;
rv->type = S1; rv->d.oneatom = a2; break;
case S1: rv = malloc(sizeof *rv);
rv->refcount = 1;
rv->type = S2;
rv->d.twoatom.a1 = a1->d.oneatom;
rv->d.twoatom.a2 = a2;
if (a1->refcount != 1) a1->d.oneatom->refcount++;
break;
case S2: /* Can't check a1->refcount against 1, because one
* of the apply's might save the continuation, making
* a copy of a1. */
CurrentContext->stage = S2a;
(nc=NextContext())->stage = Apply1;
nc->Arg1 = dupatom(a1->d.twoatom.a1);
nc->Arg2 = dupatom(a2);
PUSHCONTEXT
case D: /* If 'd' is used as an argument to something that
* applies its argument to something (eg, 'c'),
* then 'd' will be applied without "delay".
* Fishy if you ask me, but the <``r`cd`.*`cd>
* program relies on it. */
/* Treat like I */
case I: rv = a2; break;
case V: freeatom(a2); rv = a1; POPCONTEXT
case C:
if (a2->type == V) { /* <`cv> = v, no continuation. */
rv = a2; break;
}
rv = malloc(sizeof *rv);
rv->refcount = 1;
rv->type = C1;
rv->d.continuation =
SaveContinuation(CurrentContinuation, CurrentContext);
freeatom(a1);
CurrentContext->stage = Apply1;
CurrentContext->Arg1 = a2;
CurrentContext->Arg2 = rv;
continue;
case C1: /* Current Continuation holds references to a1, a2,
* so need to dup them before we free the CC. */
rv = dupatom(a2);
a1->refcount++;
FreeContinuation(CurrentContinuation, CurrentContext);
RestoreContinuation(a1->d.continuation,
&CurrentContinuation, &CurrentContext);
/* Now we can free a1. */
freeatom(a1);
POPCONTEXT
case D1: CurrentContext->stage = D1a;
(nc=NextContext())->stage = Eval1;
nc->Arg1 = a1->d.expression;
--a1->refcount ?
a1->d.expression->refcount++ : free(a1);
PUSHCONTEXT
case Print: putc(a1->d.character, output); rv = a2; break;
case Exit: exit(0); /* Exit program */
case Read: lastchar = uncons( input );
freeatom(a1);
/* CurrentContext->stage = Apply1; */
CurrentContext->Arg1 = a2;
if (lastchar == EOF) CurrentContext->Arg2 = &atomV;
else CurrentContext->Arg2 = &atomI;
MKA(CurrentContext->Arg2)->refcount++;
continue;
case Query:
/* CurrentContext->stage = Apply1; */
CurrentContext->Arg1 = a2;
if (lastchar == a1->d.character)
CurrentContext->Arg2 = &atomI;
else CurrentContext->Arg2 = &atomV;
freeatom(a1);
MKA(CurrentContext->Arg2)->refcount++;
continue;
case Reprint:
freeatom(a1);
/* CurrentContext->stage = Apply1; */
CurrentContext->Arg1 = a2;
if (lastchar == EOF) {
CurrentContext->Arg2 = &atomV;
MKA(CurrentContext->Arg2)->refcount++;
} else {
CurrentContext->Arg2 = rv = malloc(sizeof *rv);
rv->refcount = 1;
rv->type = Print;
rv->d.character = lastchar;
}
continue;
default: error("Unexpected type to apply!");
}
if (!--a1->refcount) free(a1);
POPCONTEXT
}
case S2a:
CurrentContext->Int = rv;
CurrentContext->stage = S2b;
(nc=NextContext())->stage = Apply1;
nc->Arg1 =
dupatom(MKA(CurrentContext->Arg1)->d.twoatom.a2);
nc->Arg2 = CurrentContext->Arg2;
PUSHCONTEXT
case S2b:
freeatom(MKA(CurrentContext->Arg1));
CurrentContext->stage = Apply1;
CurrentContext->Arg1 = CurrentContext->Int;
CurrentContext->Arg2 = rv;
continue;
case D1a:
CurrentContext->stage = Apply1;
CurrentContext->Arg1 = rv;
/* CurrentContext->Arg2 = CurrentContext->Arg2; */
continue;
default:
error("Unknown stage in evaluate!");
}
}
}
)
struct atom atomK = { 0, 1, K, {0}};
struct atom atomS = { 1, 1, S, {0}};
struct atom atomI = { 2, 1, I, {0}};
struct atom atomV = { 3, 1, V, {0}};
struct atom atomC = { 4, 1, C, {0}};
struct atom atomD = { 5, 1, D, {0}};
struct atom atomR = { 6, 1, Print, {'\n'}};
struct atom atomE = { 7, 1, Exit, {0}};
struct atom atomAT = { 8, 1, Read, {0}};
struct atom atomPIPE = { 9, 1, Reprint, {0}};
struct expr exprK = { 0, 1, ATOM, &atomK };
struct expr exprS = { 1, 1, ATOM, &atomS };
struct expr exprI = { 2, 1, ATOM, &atomI };
struct expr exprV = { 3, 1, ATOM, &atomV };
struct expr exprC = { 4, 1, ATOM, &atomC };
struct expr exprD = { 5, 1, ATOM, &atomD };
struct expr exprR = { 6, 1, ATOM, &atomR };
struct expr exprE = { 7, 1, ATOM, &atomE };
struct expr exprAT = { 8, 1, ATOM, &atomAT };
struct expr exprPIPE = { 9, 1, ATOM, &atomPIPE };
struct atom *predefatomlist[] = { &atomK, &atomS, &atomI, &atomV, &atomC,
&atomD, &atomR, &atomE, &atomAT, &atomPIPE};
struct expr *predefexprlist[] = { &exprK, &exprS, &exprI, &exprV, &exprC,
&exprD, &exprR, &exprE, &exprAT, &exprPIPE};
struct atom **atomlist;
struct expr **exprlist;
int atomlistsz, exprlistsz;
#define N_PREDEF_ATOMS 10
static int Natoms = N_PREDEF_ATOMS;
static int Nexpr = N_PREDEF_ATOMS;
static void grow_exprlist()
{
exprlist = realloc(exprlist,
(exprlistsz += exprlistsz / 2) * sizeof(*exprlist));
}
static void grow_atomlist()
{
atomlist = realloc(atomlist, (atomlistsz += 100) * sizeof(*atomlist));
}
struct expr *parse(FILE *file)
{
int ch;
struct expr *rv;
for (;;) {
ch = getc(file);
if (ch == EOF) error("Unexpected EOF.");
if (isspace(ch)) continue;
if (ch == '#') {
for (;;) {
ch = getc(file);
if (ch == EOF) error("Unexpected EOF.");
if (ch == '\n') break;
}
continue;
}
break;
}
switch (tolower(ch)) {
case '`': {
struct expr E;
int i;
E.arg1 = parse(file);
E.e2 = parse(file);
rv = malloc(sizeof *rv);
rv->refcount = 0;
rv->type = APPLY;
MKE(rv->arg1 = E.arg1)->refcount++;
(rv->e2 = E.e2)->refcount++;
Nexpr++;
return rv;
}
case 'k': return &exprK;
case 's': return &exprS;
case 'i': return &exprI;
case 'v': return &exprV;
case 'c': return &exprC;
case 'd': return &exprD;
case 'r': return &exprR;
case 'e': return &exprE;
case '@': return &exprAT;
case '|': return &exprPIPE;
case '.': case '?': {
int i;
enum atomtype type = (ch == '?') ? Query : Print;
ch = getc(file);
if (ch == EOF) error("Unexpected EOF");
rv = malloc(sizeof *rv);
Nexpr++;
rv->refcount = 0;
rv->type = ATOM;
rv->arg1 = malloc(sizeof (struct atom));
Natoms++;
MKA(rv->arg1)->refcount = 1;
MKA(rv->arg1)->type = type;
MKA(rv->arg1)->d.character = ch;
return rv;
}
default: error("Unexpected character");
return 0;
}
}
int main(int argc, char *argv[])
{ FILE *file;
struct expr *toplevel;
struct atom *ret;
input = get_input( argc , argv );
file = stdin;
output = stdout;
toplevel = parse(file);
toplevel->refcount++;
ret = eval(toplevel);
freeatom(ret);
free( input );
return 0;
}