commit 7453bc38dce5d5785c979fab65d4b2a8af5a27eb
parent 8208d374717c3d77008e1a3ac2a1bdc07d818b2f
Author: sin <sin@2f30.org>
Date: Mon, 19 May 2014 12:49:43 +0100
Initial implementation of lambda!
Diffstat:
| M | parser.c | | | 167 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------------------- |
1 file changed, 122 insertions(+), 45 deletions(-)
diff --git a/parser.c b/parser.c
@@ -19,6 +19,7 @@ enum objtype {
OEmptylist,
OPair,
OPrimitiveproc,
+ OCompoundproc,
};
struct object {
@@ -59,15 +60,20 @@ struct object {
} pair;
/* proc */
struct {
- char *name;
struct object *(*fn)(struct object *);
} pproc;
+ /* compound procedures */
+ struct {
+ struct object *params;
+ struct object *body;
+ } cproc;
} d;
};
/* builtins */
static struct object *evaldefine(struct object *);
static struct object *evalif(struct object *);
+static struct object *evallambda(struct object *);
static struct object *evalok(struct object *);
static struct object *evalquote(struct object *);
static struct object *evalset(struct object *);
@@ -92,6 +98,7 @@ struct {
} builtins[] = {
{ .name = "define", .fn = evaldefine },
{ .name = "if", .fn = evalif },
+ { .name = "lambda", .fn = evallambda },
{ .name = "ok", .fn = evalok },
{ .name = "quote", .fn = evalquote },
{ .name = "set", .fn = evalset },
@@ -245,17 +252,28 @@ pair(FILE *in)
}
static struct object *
-proc(char *s, struct object *(*fn)(struct object *))
+pproc(struct object *(*fn)(struct object *))
{
struct object *o;
o = newobject();
o->type = OPrimitiveproc;
- o->d.pproc.name = estrdup(s);
o->d.pproc.fn = fn;
return o;
}
+static struct object *
+cproc(struct object *params, struct object *body)
+{
+ struct object *o;
+
+ o = newobject();
+ o->type = OCompoundproc;
+ o->d.cproc.params = params;
+ o->d.cproc.body = body;
+ return o;
+}
+
struct object *
sexpression(FILE *in)
{
@@ -341,11 +359,8 @@ evaldefine(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "define") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
- if (cadddr(o))
- return error("multiple arguments");
var = cadr(o);
if (var->type != OIdentifier)
return error("expected identifier");
@@ -354,6 +369,8 @@ evaldefine(struct object *o)
val = eval(caddr(o));
if (val->type == OError)
return val;
+ if (cadddr(o))
+ return error("multiple arguments");
addsym(var->d.i.name, val);
return lookupsym("ok");
}
@@ -365,8 +382,7 @@ evalif(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "if") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
predicate = eval(cadr(o));
if (predicate->type == OError)
@@ -378,12 +394,25 @@ evalif(struct object *o)
}
static struct object *
+evallambda(struct object *o)
+{
+ struct object *params, *body;
+
+ if (o->type != OPair)
+ return NULL;
+ if (car(o)->type != OIdentifier)
+ return NULL;
+ params = cadr(o);
+ body = caddr(o);
+ return cproc(params, body);
+}
+
+static struct object *
evalok(struct object *o)
{
- if (o->type == OIdentifier)
- if (strcmp(o->d.i.name, "ok") == 0)
- return o;
- return NULL;
+ if (o->type != OIdentifier)
+ return NULL;
+ return o;
}
static struct object *
@@ -391,8 +420,7 @@ evalquote(struct object *o)
{
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "quote") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (caddr(o))
return error("multiple arguments");
@@ -406,11 +434,8 @@ evalset(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "set") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
- if (cadddr(o))
- return error("multiple arguments");
var = cadr(o);
if (var->type != OIdentifier)
return error("expected identifier");
@@ -421,6 +446,8 @@ evalset(struct object *o)
val = eval(caddr(o));
if (val->type == OError)
return val;
+ if (cadddr(o))
+ return error("multiple arguments");
addsym(var->d.i.name, val);
return lookupsym("ok");
}
@@ -432,8 +459,7 @@ evalboolean(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "boolean") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (caddr(o))
return error("multiple arguments");
@@ -452,8 +478,7 @@ evalcar(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "car") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (caddr(o))
return error("multiple arguments");
@@ -472,8 +497,7 @@ evalcdr(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "cdr") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (caddr(o))
return error("multiple arguments");
@@ -490,8 +514,7 @@ evalcons(struct object *o)
{
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "cons") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (cadddr(o))
return error("multiple arguments");
@@ -521,8 +544,7 @@ evaldiff(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "diff") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
n = eval(cadr(o));
if (n->type == OError)
@@ -545,8 +567,7 @@ evaleq(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "eq") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (cadddr(o))
return error("multiple arguments");
@@ -572,8 +593,7 @@ evalgt(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "gt") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (cadddr(o))
return error("multiple arguments");
@@ -599,8 +619,7 @@ evalinteger(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "integer") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (caddr(o))
return error("multiple arguments");
@@ -619,8 +638,7 @@ evallt(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "lt") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (cadddr(o))
return error("multiple arguments");
@@ -646,8 +664,7 @@ evalnull(struct object *o)
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "null") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
if (caddr(o))
return error("multiple arguments");
@@ -680,12 +697,62 @@ evalplus(struct object *o)
{
if (o->type != OPair)
return NULL;
- if (car(o)->type != OIdentifier ||
- strcmp(car(o)->d.i.name, "plus") != 0)
+ if (car(o)->type != OIdentifier)
return NULL;
return doplus(cdr(o), integer(0));
}
+static struct object *
+evalparams(struct object *o)
+{
+ struct object *params, *pcar, *pcdr;
+ struct object *args, *acar, *acdr;
+ struct object *tmp;
+
+ params = car(lookupsym(car(o)->d.i.name));
+ args = cdr(o);
+ pcdr = params;
+ acdr = args;
+ do {
+ pcar = car(pcdr);
+ acar = car(acdr);
+ if (!pcar && !acar)
+ break;
+ if (pcar && !acar)
+ return error("not enough arguments");
+ if (!pcar && acar)
+ return error("too many arguments");
+ pcdr = cdr(pcdr);
+ acdr = cdr(acdr);
+ if (pcar->type != OIdentifier)
+ return error("expected udentifier");
+ tmp = eval(acar);
+ addsym(pcar->d.i.name, tmp);
+ } while (1);
+ return lookupsym("ok");
+}
+
+static struct object *
+evalbody(struct object *o)
+{
+ return eval(cdr(lookupsym(car(o)->d.i.name)));
+}
+
+static struct object *
+evalcproc(struct object *o)
+{
+ struct object *err, *body;
+
+ if (o->type != OPair)
+ return NULL;
+
+ err = evalparams(o);
+ if (err->type == OError)
+ return err;
+ body = evalbody(o);
+ return body;
+}
+
struct object *
eval(struct object *o)
{
@@ -712,12 +779,19 @@ eval(struct object *o)
tmp = lookupsym(car(o)->d.i.name);
if (!tmp)
return error("unbound identifier");
- if (tmp->type == OIdentifier) {
+ switch (tmp->type) {
+ case OIdentifier:
for (i = 0; i < LEN(builtins); i++)
if (strcmp(tmp->d.i.name, builtins[i].name) == 0)
return builtins[i].fn(o);
- } else if (tmp->type == OPrimitiveproc) {
+ break;
+ case OPrimitiveproc:
return tmp->d.pproc.fn(o);
+ case OCompoundproc:
+ pushenv();
+ tmp = evalcproc(o);
+ popenv();
+ return tmp;
}
break;
}
@@ -776,7 +850,10 @@ print(struct object *o)
putchar(')');
break;
case OPrimitiveproc:
- printf("#<primitive procedure %s>", o->d.pproc.name);
+ printf("#<primitive procedure>");
+ break;
+ case OCompoundproc:
+ printf("#<compound procedure>");
break;
}
}
@@ -794,7 +871,7 @@ init(void)
}
/* add primitive procedures */
for (i = 0; i < LEN(procs); i++) {
- procs[i].o = proc(procs[i].name, procs[i].fn);
+ procs[i].o = pproc(procs[i].fn);
addsym(procs[i].name, procs[i].o);
}
return 0;
