iris

small scheme interpreter
git clone git://git.2f30.org/iris
Log | Files | Refs | LICENSE

commit 7453bc38dce5d5785c979fab65d4b2a8af5a27eb
parent 8208d374717c3d77008e1a3ac2a1bdc07d818b2f
Author: sin <sin@2f30.org>
Date:   Mon, 19 May 2014 12:49:43 +0100

Initial implementation of lambda!

Diffstat:
Mparser.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;