sjs/lake
1
0
Fork 0
mirror of https://github.com/samsonjs/lake.git synced 2026-04-27 14:57:43 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

change indentation to 2 spaces

Browse source
This commit is contained in:
Sami Samhuri 2011-10-24 21:36:02 -07:00
parent 5a368fbc47
commit 5c615013da
14 changed files with 1068 additions and 1068 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
src/bool.c
View file

@ -14,45 +14,45 @@
bool lk_bool_val(LakeBool *b) bool lk_bool_val(LakeBool *b)
{ {
return b->val; return b->val;
} }
bool lk_is_true(LakeCtx *ctx, LakeVal *x) bool lk_is_true(LakeCtx *ctx, LakeVal *x)
{ {
return VAL(x) == VAL(ctx->T); return VAL(x) == VAL(ctx->T);
} }
bool lk_is_false(LakeCtx *ctx, LakeVal *x) bool lk_is_false(LakeCtx *ctx, LakeVal *x)
{ {
return VAL(x) == VAL(ctx->F); return VAL(x) == VAL(ctx->F);
} }
bool lk_is_truthy(LakeCtx *ctx, LakeVal *x) bool lk_is_truthy(LakeCtx *ctx, LakeVal *x)
{ {
return !lk_is_false(ctx, x); return !lk_is_false(ctx, x);
} }
bool lk_is_falsy(LakeCtx *ctx, LakeVal *x) bool lk_is_falsy(LakeCtx *ctx, LakeVal *x)
{ {
return lk_is_false(ctx, x); return lk_is_false(ctx, x);
} }
LakeBool *lk_bool_from_int(LakeCtx *ctx, int n) LakeBool *lk_bool_from_int(LakeCtx *ctx, int n)
{ {
return n ? ctx->T : ctx->F; return n ? ctx->T : ctx->F;
} }
char *lk_bool_repr(LakeBool *b) char *lk_bool_repr(LakeBool *b)
{ {
return strdup(lk_bool_val(b) ? "#t" : "#f"); return strdup(lk_bool_val(b) ? "#t" : "#f");
} }
LakeVal *lk_bool_and(LakeCtx *ctx, LakeVal *x, LakeVal *y) LakeVal *lk_bool_and(LakeCtx *ctx, LakeVal *x, LakeVal *y)
{ {
return lk_is_truthy(ctx, x) && lk_is_truthy(ctx, y) ? y : x; return lk_is_truthy(ctx, x) && lk_is_truthy(ctx, y) ? y : x;
} }
LakeVal *lk_bool_or(LakeCtx *ctx, LakeVal *x, LakeVal *y) LakeVal *lk_bool_or(LakeCtx *ctx, LakeVal *x, LakeVal *y)
{ {
return lk_is_truthy(ctx, x) ? x : y; return lk_is_truthy(ctx, x) ? x : y;
} }

14
src/dlist.c
View file

@ -29,12 +29,12 @@ LakeDottedList *dlist_make(LakeList *head, LakeVal *tail)
LakeList *dlist_head(LakeDottedList *dlist) LakeList *dlist_head(LakeDottedList *dlist)
{ {
return dlist->head; return dlist->head;
} }
LakeVal *dlist_tail(LakeDottedList *dlist) LakeVal *dlist_tail(LakeDottedList *dlist)
{ {
return dlist->tail; return dlist->tail;
} }
char *dlist_repr(LakeDottedList *dlist) char *dlist_repr(LakeDottedList *dlist)
@ -66,9 +66,9 @@ char *dlist_repr(LakeDottedList *dlist)
bool dlist_equal(LakeDottedList *a, LakeDottedList *b) bool dlist_equal(LakeDottedList *a, LakeDottedList *b)
{ {
LakeVal *headA = VAL(dlist_head(a)); LakeVal *headA = VAL(dlist_head(a));
LakeVal *tailA = dlist_tail(a); LakeVal *tailA = dlist_tail(a);
LakeVal *headB = VAL(dlist_head(b)); LakeVal *headB = VAL(dlist_head(b));
LakeVal *tailB = dlist_tail(b); LakeVal *tailB = dlist_tail(b);
return lake_equal(headA, headB) && lake_equal(tailA, tailB); return lake_equal(headA, headB) && lake_equal(tailA, tailB);
} }

40
src/env.c
View file

@ -16,44 +16,44 @@
Env *env_make(Env *parent) Env *env_make(Env *parent)
{ {
Env *env = malloc(sizeof(Env)); Env *env = malloc(sizeof(Env));
env->parent = parent; env->parent = parent;
env->bindings = lk_hash_make(); env->bindings = lk_hash_make();
return env; return env;
} }
Env *env_is_defined(Env *env, LakeSym *key) Env *env_is_defined(Env *env, LakeSym *key)
{ {
if (lk_hash_get(env->bindings, key->s) != NULL) return env; if (lk_hash_get(env->bindings, key->s) != NULL) return env;
return env->parent ? env_is_defined(env->parent, key) : NULL; return env->parent ? env_is_defined(env->parent, key) : NULL;
} }
static void env_put(Env *env, LakeSym *key, LakeVal *val) static void env_put(Env *env, LakeSym *key, LakeVal *val)
{ {
lk_hash_put(env->bindings, key->s, val); lk_hash_put(env->bindings, key->s, val);
} }
LakeVal *env_define(Env *env, LakeSym *key, LakeVal *val) LakeVal *env_define(Env *env, LakeSym *key, LakeVal *val)
{ {
env_put(env, key, val); env_put(env, key, val);
return val; return val;
} }
LakeVal *env_set(Env *env, LakeSym *key, LakeVal *val) LakeVal *env_set(Env *env, LakeSym *key, LakeVal *val)
{ {
Env *definedEnv; Env *definedEnv;
if (!(definedEnv = env_is_defined(env, key))) { if (!(definedEnv = env_is_defined(env, key))) {
return NULL; return NULL;
} }
env_put(definedEnv, key, val); env_put(definedEnv, key, val);
return val; return val;
} }
LakeVal *env_get(Env *env, LakeSym *key) LakeVal *env_get(Env *env, LakeSym *key)
{ {
LakeVal *val = lk_hash_get(env->bindings, key->s); LakeVal *val = lk_hash_get(env->bindings, key->s);
if (!val && env->parent) { if (!val && env->parent) {
val = env_get(env->parent, key); val = env_get(env->parent, key);
} }
return val; return val;
} }

4
src/env.h
View file

@ -14,8 +14,8 @@
#include "hash.h" #include "hash.h"
struct env { struct env {
struct env *parent; struct env *parent;
lk_hash_t *bindings; lk_hash_t *bindings;
}; };
typedef struct env Env; typedef struct env Env;

518
src/eval.c
View file

@ -22,371 +22,371 @@ typedef LakeVal *(*special_form_handler)(LakeCtx *ctx, Env *env, LakeList *expr)
static void invalid_special_form(LakeList *expr, char *detail) static void invalid_special_form(LakeList *expr, char *detail)
{ {
ERR("malformed special form, %s: %s", detail, lake_repr(expr)); ERR("malformed special form, %s: %s", detail, lake_repr(expr));
} }
/* expr begins with the symbol "quote" so the quoted value is the 2nd value */ /* expr begins with the symbol "quote" so the quoted value is the 2nd value */
static LakeVal *_quote(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_quote(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
if (LIST_N(expr) == 2) { if (LIST_N(expr) == 2) {
return list_pop(expr); return list_pop(expr);
} }
invalid_special_form(expr, "quote requires exactly one parameter"); invalid_special_form(expr, "quote requires exactly one parameter");
return NULL; return NULL;
} }
static LakeVal *_and(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_and(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
/* drop the "and" symbol */ /* drop the "and" symbol */
list_shift(expr); list_shift(expr);
/* (and ...) */ /* (and ...) */
LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->T); LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->T);
while (lk_is_truthy(ctx, result) && LIST_N(expr) > 0) { while (lk_is_truthy(ctx, result) && LIST_N(expr) > 0) {
result = lk_bool_and(ctx, result, eval(ctx, env, list_shift(expr))); result = lk_bool_and(ctx, result, eval(ctx, env, list_shift(expr)));
} }
return result; return result;
} }
static LakeVal *_or(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_or(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
/* drop the "or" symbol */ /* drop the "or" symbol */
list_shift(expr); list_shift(expr);
/* (or ...) */ /* (or ...) */
LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->F); LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->F);
while (lk_is_falsy(ctx, result) && LIST_N(expr) > 0) { while (lk_is_falsy(ctx, result) && LIST_N(expr) > 0) {
result = lk_bool_or(ctx, result, eval(ctx, env, list_shift(expr))); result = lk_bool_or(ctx, result, eval(ctx, env, list_shift(expr)));
} }
return result; return result;
} }
static LakeVal *_setB(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_setB(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
/* (set! x 42) */ /* (set! x 42) */
if (LIST_N(expr) == 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { if (LIST_N(expr) == 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "set!" symbol */ list_shift(expr); /* drop the "set!" symbol */
LakeSym *var = SYM(list_shift(expr)); LakeSym *var = SYM(list_shift(expr));
LakeVal *form = list_shift(expr); LakeVal *form = list_shift(expr);
if (!env_set(env, var, form)) { if (!env_set(env, var, form)) {
ERR("%s is not defined", sym_repr(var)); ERR("%s is not defined", sym_repr(var));
}
} }
else { }
invalid_special_form(expr, "set! requires exactly 2 parameters"); else {
} invalid_special_form(expr, "set! requires exactly 2 parameters");
return NULL; }
return NULL;
} }
static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
/* TODO: make these more robust, check all expected params */ /* TODO: make these more robust, check all expected params */
/* (define x 42) */ /* (define x 42) */
if (LIST_N(expr) == 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { if (LIST_N(expr) == 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */ list_shift(expr); /* drop the "define" symbol */
LakeSym *var = SYM(list_shift(expr)); LakeSym *var = SYM(list_shift(expr));
LakeVal *form = list_shift(expr); LakeVal *form = list_shift(expr);
env_define(env, var, eval(ctx, env, form)); env_define(env, var, eval(ctx, env, form));
} }
/* (define (inc x) (+ 1 x)) */ /* (define (inc x) (+ 1 x)) */
else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_LIST, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_LIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */ list_shift(expr); /* drop the "define" symbol */
LakeList *params = LIST(list_shift(expr)); LakeList *params = LIST(list_shift(expr));
LakeSym *var = SYM(list_shift(params)); LakeSym *var = SYM(list_shift(params));
LakeList *body = expr; LakeList *body = expr;
env_define(env, var, VAL(fn_make(params, NULL, body, env))); env_define(env, var, VAL(fn_make(params, NULL, body, env)));
} }
/* (define (print format . args) (...)) */ /* (define (print format . args) (...)) */
else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "define" symbol */ list_shift(expr); /* drop the "define" symbol */
LakeDottedList *def = DLIST(list_shift(expr)); LakeDottedList *def = DLIST(list_shift(expr));
LakeList *params = dlist_head(def); LakeList *params = dlist_head(def);
LakeSym *varargs = SYM(dlist_tail(def)); LakeSym *varargs = SYM(dlist_tail(def));
LakeSym *var = SYM(list_shift(params)); LakeSym *var = SYM(list_shift(params));
LakeList *body = expr; LakeList *body = expr;
env_define(env, var, VAL(fn_make(params, varargs, body, env))); env_define(env, var, VAL(fn_make(params, varargs, body, env)));
} }
else { else {
invalid_special_form(expr, "define requires at least 2 parameters"); invalid_special_form(expr, "define requires at least 2 parameters");
} }
return NULL; return NULL;
} }
static LakeVal *_lambda(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_lambda(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
/* (lambda (a b c) ...) */ /* (lambda (a b c) ...) */
if (LIST_N(expr) >= 3 && lk_is_type(TYPE_LIST, LIST_VAL(expr, 1))) { if (LIST_N(expr) >= 3 && lk_is_type(TYPE_LIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "lambda" symbol */ list_shift(expr); /* drop the "lambda" symbol */
LakeList *params = LIST(list_shift(expr)); LakeList *params = LIST(list_shift(expr));
LakeList *body = expr; LakeList *body = expr;
return VAL(fn_make(params, NULL, body, env)); return VAL(fn_make(params, NULL, body, env));
} }
else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "lambda" symbol */ list_shift(expr); /* drop the "lambda" symbol */
LakeDottedList *def = DLIST(list_shift(expr)); LakeDottedList *def = DLIST(list_shift(expr));
LakeList *params = dlist_head(def); LakeList *params = dlist_head(def);
LakeSym *varargs = SYM(dlist_tail(def)); LakeSym *varargs = SYM(dlist_tail(def));
LakeList *body = expr; LakeList *body = expr;
return VAL(fn_make(params, varargs, body, env)); return VAL(fn_make(params, varargs, body, env));
} }
else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) {
list_shift(expr); /* drop the "lambda" symbol */ list_shift(expr); /* drop the "lambda" symbol */
LakeSym *varargs = SYM(list_shift(expr)); LakeSym *varargs = SYM(list_shift(expr));
LakeList *body = expr; LakeList *body = expr;
return VAL(fn_make(list_make(), varargs, body, env)); return VAL(fn_make(list_make(), varargs, body, env));
} }
else { else {
invalid_special_form(expr, "lambda requires at least 2 parameters"); invalid_special_form(expr, "lambda requires at least 2 parameters");
return NULL; return NULL;
} }
} }
static LakeVal *_if(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_if(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
if (LIST_N(expr) != 3) { if (LIST_N(expr) != 3) {
invalid_special_form(expr, "if requires 3 parameters"); invalid_special_form(expr, "if requires 3 parameters");
return NULL; return NULL;
} }
list_shift(expr); /* "if" token */ list_shift(expr); /* "if" token */
LakeVal *cond = eval(ctx, env, list_shift(expr)); LakeVal *cond = eval(ctx, env, list_shift(expr));
if (lk_is_truthy(ctx, cond)) { if (lk_is_truthy(ctx, cond)) {
return eval(ctx, env, list_shift(expr)); return eval(ctx, env, list_shift(expr));
} }
else { else {
return eval(ctx, env, LIST_VAL(expr, 1)); return eval(ctx, env, LIST_VAL(expr, 1));
} }
} }
static LakeVal *_cond(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_cond(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
static LakeVal *ELSE = NULL; static LakeVal *ELSE = NULL;
if (!ELSE) ELSE = VAL(sym_intern(ctx, "else")); if (!ELSE) ELSE = VAL(sym_intern(ctx, "else"));
list_shift(expr); /* "cond" token */ list_shift(expr); /* "cond" token */
LakeVal *pred; LakeVal *pred;
LakeList *conseq; LakeList *conseq;
while (LIST_N(expr)) { while (LIST_N(expr)) {
if (!lk_is_type(TYPE_LIST, LIST_VAL(expr, 0))) { if (!lk_is_type(TYPE_LIST, LIST_VAL(expr, 0))) {
invalid_special_form(expr, "expected a (predicate consequence) pair"); invalid_special_form(expr, "expected a (predicate consequence) pair");
return NULL; return NULL;
}
conseq = LIST(list_shift(expr));
pred = list_shift(conseq);
if (pred == ELSE || lk_is_truthy(ctx, eval(ctx, env, pred))) {
return eval_exprs1(ctx, env, conseq);
}
} }
return NULL; conseq = LIST(list_shift(expr));
pred = list_shift(conseq);
if (pred == ELSE || lk_is_truthy(ctx, eval(ctx, env, pred))) {
return eval_exprs1(ctx, env, conseq);
}
}
return NULL;
} }
static LakeVal *_when(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_when(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
if (LIST_N(expr) < 2) { if (LIST_N(expr) < 2) {
invalid_special_form(expr, "when requires at least 2 parameters"); invalid_special_form(expr, "when requires at least 2 parameters");
return NULL; return NULL;
} }
list_shift(expr); /* "when" token */ list_shift(expr); /* "when" token */
LakeVal *cond = eval(ctx, env, list_shift(expr)); LakeVal *cond = eval(ctx, env, list_shift(expr));
return lk_is_truthy(ctx, cond) ? eval_exprs1(ctx, env, expr) : NULL; return lk_is_truthy(ctx, cond) ? eval_exprs1(ctx, env, expr) : NULL;
} }
typedef LakeVal *(*handler)(LakeCtx *, Env *, LakeList *); typedef LakeVal *(*handler)(LakeCtx *, Env *, LakeList *);
static void define_handler(LakeCtx *ctx, char *name, handler fn) static void define_handler(LakeCtx *ctx, char *name, handler fn)
{ {
lk_hash_put(ctx->special_form_handlers, name, (void *)fn); lk_hash_put(ctx->special_form_handlers, name, (void *)fn);
} }
void init_special_form_handlers(LakeCtx *ctx) void init_special_form_handlers(LakeCtx *ctx)
{ {
/* define_handler(ctx, "load", &load_special_form); */ /* define_handler(ctx, "load", &load_special_form); */
define_handler(ctx, "quote", &_quote); define_handler(ctx, "quote", &_quote);
define_handler(ctx, "and", &_and); define_handler(ctx, "and", &_and);
define_handler(ctx, "or", &_or); define_handler(ctx, "or", &_or);
define_handler(ctx, "if", &_if); define_handler(ctx, "if", &_if);
define_handler(ctx, "when", &_when); define_handler(ctx, "when", &_when);
define_handler(ctx, "cond", &_cond); define_handler(ctx, "cond", &_cond);
define_handler(ctx, "set!", &_setB); define_handler(ctx, "set!", &_setB);
define_handler(ctx, "define", &_define); define_handler(ctx, "define", &_define);
define_handler(ctx, "lambda", &_lambda); define_handler(ctx, "lambda", &_lambda);
/* define_handler(ctx, "let", &_let); */ /* define_handler(ctx, "let", &_let); */
/* define_handler(ctx, "let!", &_letB); */ /* define_handler(ctx, "let!", &_letB); */
/* define_handler(ctx, "letrec", &_letrec); */ /* define_handler(ctx, "letrec", &_letrec); */
} }
bool is_special_form(LakeCtx *ctx, LakeList *expr) bool is_special_form(LakeCtx *ctx, LakeList *expr)
{ {
LakeVal *head = LIST_VAL(expr, 0); LakeVal *head = LIST_VAL(expr, 0);
if (!lk_is_type(TYPE_SYM, head)) return FALSE; if (!lk_is_type(TYPE_SYM, head)) return FALSE;
return lk_hash_has(ctx->special_form_handlers, SYM(head)->s); return lk_hash_has(ctx->special_form_handlers, SYM(head)->s);
} }
static special_form_handler get_special_form_handler(LakeCtx *ctx, LakeSym *name) static special_form_handler get_special_form_handler(LakeCtx *ctx, LakeSym *name)
{ {
return (special_form_handler)lk_hash_get(ctx->special_form_handlers, name->s); return (special_form_handler)lk_hash_get(ctx->special_form_handlers, name->s);
} }
static LakeVal *eval_special_form(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *eval_special_form(LakeCtx *ctx, Env *env, LakeList *expr)
{ {
LakeSym *name = SYM(LIST_VAL(expr, 0)); LakeSym *name = SYM(LIST_VAL(expr, 0));
special_form_handler handler = get_special_form_handler(ctx, name); special_form_handler handler = get_special_form_handler(ctx, name);
if (handler) { if (handler) {
return handler(ctx, env, list_copy(expr)); return handler(ctx, env, list_copy(expr));
} }
ERR("unrecognized special form: %s", sym_repr(name)); ERR("unrecognized special form: %s", sym_repr(name));
return NULL; return NULL;
} }
LakeVal *eval_str(LakeCtx *ctx, Env *env, char *s) LakeVal *eval_str(LakeCtx *ctx, Env *env, char *s)
{ {
return eval(ctx, env, parse_expr(ctx, s, strlen(s))); return eval(ctx, env, parse_expr(ctx, s, strlen(s)));
} }
LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr) LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr)
{ {
LakeVal *result; LakeVal *result;
LakeList *list; LakeList *list;
switch (expr->type) { switch (expr->type) {
/* self evaluating types */ /* self evaluating types */
case TYPE_BOOL: case TYPE_BOOL:
case TYPE_INT: case TYPE_INT:
case TYPE_STR: case TYPE_STR:
result = expr; result = expr;
break; break;
case TYPE_SYM: case TYPE_SYM:
result = env_get(env, (void *)SYM(expr)); result = env_get(env, (void *)SYM(expr));
if (!result) { if (!result) {
ERR("undefined variable: %s", sym_repr(SYM(expr))); ERR("undefined variable: %s", sym_repr(SYM(expr)));
} }
break; break;
case TYPE_DLIST: case TYPE_DLIST:
ERR("malformed function call"); ERR("malformed function call");
result = NULL; result = NULL;
break; break;
case TYPE_COMM: case TYPE_COMM:
result = NULL; result = NULL;
break; break;
case TYPE_LIST: case TYPE_LIST:
list = LIST(expr); list = LIST(expr);
if (LIST_N(list) == 0) { if (LIST_N(list) == 0) {
result = expr; result = expr;
}
else {
if (is_special_form(ctx, list)) {
result = eval_special_form(ctx, env, list);
} }
else { else {
if (is_special_form(ctx, list)) { LakeVal *fn = eval(ctx, env, LIST_VAL(list, 0));
result = eval_special_form(ctx, env, list); if (!fn) {
return NULL;
}
LakeList *args = list_make_with_capacity(LIST_N(list) - 1);
int i;
LakeVal *v;
for (i = 1; i < LIST_N(list); ++i) {
v = eval(ctx, env, LIST_VAL(list, i));
if (v != NULL) {
list_append(args, v);
} }
else { else {
LakeVal *fn = eval(ctx, env, LIST_VAL(list, 0)); list_free(args);
if (!fn) { result = NULL;
return NULL; goto done;
}
LakeList *args = list_make_with_capacity(LIST_N(list) - 1);
int i;
LakeVal *v;
for (i = 1; i < LIST_N(list); ++i) {
v = eval(ctx, env, LIST_VAL(list, i));
if (v != NULL) {
list_append(args, v);
}
else {
list_free(args);
result = NULL;
goto done;
}
}
result = apply(ctx, fn, args);
} }
}
result = apply(ctx, fn, args);
} }
break; }
break;
default: default:
ERR("unrecognized value, type %d, size %zu bytes", expr->type, expr->size); ERR("unrecognized value, type %d, size %zu bytes", expr->type, expr->size);
DIE("we don't eval that around here!"); DIE("we don't eval that around here!");
} }
done: return result; done: return result;
} }
LakeList *eval_exprs(LakeCtx *ctx, Env *env, LakeList *exprs) LakeList *eval_exprs(LakeCtx *ctx, Env *env, LakeList *exprs)
{ {
LakeList *results = list_make_with_capacity(LIST_N(exprs)); LakeList *results = list_make_with_capacity(LIST_N(exprs));
int i; int i;
for (i = 0; i < LIST_N(exprs); ++i) { for (i = 0; i < LIST_N(exprs); ++i) {
list_append(results, eval(ctx, env, LIST_VAL(exprs, i))); list_append(results, eval(ctx, env, LIST_VAL(exprs, i)));
} }
return results; return results;
} }
LakeVal *eval_exprs1(LakeCtx *ctx, Env *env, LakeList *exprs) LakeVal *eval_exprs1(LakeCtx *ctx, Env *env, LakeList *exprs)
{ {
LakeList *results = eval_exprs(ctx, env, exprs); LakeList *results = eval_exprs(ctx, env, exprs);
LakeVal *result = list_pop(results); LakeVal *result = list_pop(results);
list_free(results); list_free(results);
return result; return result;
} }
LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args) LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args)
{ {
LakeVal *result = NULL; LakeVal *result = NULL;
if (lk_is_type(TYPE_PRIM, fnVal)) { if (lk_is_type(TYPE_PRIM, fnVal)) {
LakePrimitive *prim = PRIM(fnVal); LakePrimitive *prim = PRIM(fnVal);
int arity = prim->arity; int arity = prim->arity;
if (arity == ARITY_VARARGS || LIST_N(args) == arity) { if (arity == ARITY_VARARGS || LIST_N(args) == arity) {
result = prim->fn(ctx, args); result = prim->fn(ctx, args);
}
else {
ERR("%s expects %d params but got %zu", prim->name, arity, LIST_N(args));
result = NULL;
}
}
else if (lk_is_type(TYPE_FN, fnVal)) {
LakeFn *fn = FN(fnVal);
/* Check # of params */
size_t nparams = LIST_N(fn->params);
if (!fn->varargs && LIST_N(args) != nparams) {
ERR("expected %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
else if (fn->varargs && LIST_N(args) < nparams) {
ERR("expected at least %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
Env *env = env_make(fn->closure);
/* bind each (param,arg) pair in env */
size_t i;
for (i = 0; i < nparams; ++i) {
env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i));
}
/* bind varargs */
if (fn->varargs) {
LakeList *remainingArgs = list_make_with_capacity(LIST_N(args) - nparams);
for (; i < LIST_N(args); ++i) {
list_append(remainingArgs, LIST_VAL(args, i));
}
env_define(env, fn->varargs, VAL(remainingArgs));
}
/* evaluate body */
result = eval_exprs1(ctx, env, fn->body);
} }
else { else {
ERR("not a function: %s", lake_repr(fnVal)); ERR("%s expects %d params but got %zu", prim->name, arity, LIST_N(args));
result = NULL;
} }
return result; }
else if (lk_is_type(TYPE_FN, fnVal)) {
LakeFn *fn = FN(fnVal);
/* Check # of params */
size_t nparams = LIST_N(fn->params);
if (!fn->varargs && LIST_N(args) != nparams) {
ERR("expected %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
else if (fn->varargs && LIST_N(args) < nparams) {
ERR("expected at least %zu params but got %zu", nparams, LIST_N(args));
return NULL;
}
Env *env = env_make(fn->closure);
/* bind each (param,arg) pair in env */
size_t i;
for (i = 0; i < nparams; ++i) {
env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i));
}
/* bind varargs */
if (fn->varargs) {
LakeList *remainingArgs = list_make_with_capacity(LIST_N(args) - nparams);
for (; i < LIST_N(args); ++i) {
list_append(remainingArgs, LIST_VAL(args, i));
}
env_define(env, fn->varargs, VAL(remainingArgs));
}
/* evaluate body */
result = eval_exprs1(ctx, env, fn->body);
}
else {
ERR("not a function: %s", lake_repr(fnVal));
}
return result;
} }

2
src/fn.c
View file

@ -23,7 +23,7 @@ static LakeFn *fn_alloc(void)
LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env *closure) LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env *closure)
{ {
LakeFn *fn = fn_alloc(); LakeFn *fn = fn_alloc();
fn->params = params; fn->params = params;
fn->varargs = varargs; fn->varargs = varargs;
fn->body = body; fn->body = body;

184
src/lake.c
View file

@ -23,149 +23,149 @@
int lk_val_size(void *x) int lk_val_size(void *x)
{ {
return VAL(x)->size; return VAL(x)->size;
} }
int lk_is_type(LakeType t, void *x) int lk_is_type(LakeType t, void *x)
{ {
return VAL(x)->type == t; return VAL(x)->type == t;
} }
char *lake_repr(void *expr) char *lake_repr(void *expr)
{ {
if (expr == NULL) return strdup("(null)"); if (expr == NULL) return strdup("(null)");
char *s = NULL; char *s = NULL;
LakeVal *e = VAL(expr); LakeVal *e = VAL(expr);
switch (e->type) { switch (e->type) {
case TYPE_SYM: case TYPE_SYM:
s = sym_repr(SYM(e)); s = sym_repr(SYM(e));
break; break;
case TYPE_BOOL: case TYPE_BOOL:
s = lk_bool_repr(BOOL(e)); s = lk_bool_repr(BOOL(e));
break; break;
case TYPE_INT: case TYPE_INT:
s = int_repr(INT(e)); s = int_repr(INT(e));
break; break;
case TYPE_STR: { case TYPE_STR: {
size_t n = strlen(STR_S(STR(e))) + 2; size_t n = strlen(STR_S(STR(e))) + 2;
s = malloc(n); s = malloc(n);
/* TODO: quote the string */ /* TODO: quote the string */
snprintf(s, n, "\"%s\"", STR_S(STR(e))); snprintf(s, n, "\"%s\"", STR_S(STR(e)));
break; break;
} }
case TYPE_LIST: case TYPE_LIST:
s = list_repr(LIST(e)); s = list_repr(LIST(e));
break; break;
case TYPE_DLIST: case TYPE_DLIST:
s = dlist_repr(DLIST(e)); s = dlist_repr(DLIST(e));
break; break;
case TYPE_PRIM: case TYPE_PRIM:
s = prim_repr(PRIM(e)); s = prim_repr(PRIM(e));
break; break;
case TYPE_FN: case TYPE_FN:
s = fn_repr(FN(e)); s = fn_repr(FN(e));
break; break;
case TYPE_COMM: case TYPE_COMM:
s = comment_repr(COMM(e)); s = comment_repr(COMM(e));
break; break;
default: default:
// If it wasn't a LakeVal we already crashed at the beginning of the switch, // If it wasn't a LakeVal we already crashed at the beginning of the switch,
// so go ahead and print out the size too. // so go ahead and print out the size too.
fprintf(stderr, "error: unrecognized value, type %d, size %zu bytes", fprintf(stderr, "error: unrecognized value, type %d, size %zu bytes",
e->type, e->size); e->type, e->size);
s = strdup("(unknown)"); s = strdup("(unknown)");
} }
return s; return s;
} }
bool lk_is_nil(LakeVal *x) bool lk_is_nil(LakeVal *x)
{ {
return lk_is_type(TYPE_LIST, x) && LIST_N(LIST(x)) == 0; return lk_is_type(TYPE_LIST, x) && LIST_N(LIST(x)) == 0;
} }
bool lake_is(LakeVal *a, LakeVal *b) bool lake_is(LakeVal *a, LakeVal *b)
{ {
if (lk_is_type(TYPE_INT, a) && lk_is_type(TYPE_INT, b)) { if (lk_is_type(TYPE_INT, a) && lk_is_type(TYPE_INT, b)) {
return INT_VAL(INT(a)) == INT_VAL(INT(b)); return INT_VAL(INT(a)) == INT_VAL(INT(b));
} }
if (lk_is_nil(a) && lk_is_nil(b)) return TRUE; if (lk_is_nil(a) && lk_is_nil(b)) return TRUE;
return a == b; return a == b;
} }
static char *type_name(LakeVal *expr) static char *type_name(LakeVal *expr)
{ {
static char *type_names[9] = { "nil", "symbol", "boolean", "integer", "string", "list", static char *type_names[9] = { "nil", "symbol", "boolean", "integer", "string", "list",
"dotted-list", "primitive", "function" "dotted-list", "primitive", "function"
}; };
LakeType t = expr->type; LakeType t = expr->type;
return t >= 0 && t <= 8 ? type_names[t] : "(not a LakeVal)"; return t >= 0 && t <= 8 ? type_names[t] : "(not a LakeVal)";
} }
bool lake_equal(LakeVal *a, LakeVal *b) bool lake_equal(LakeVal *a, LakeVal *b)
{ {
if (a->type != b->type) return FALSE; if (a->type != b->type) return FALSE;
switch (a->type) { switch (a->type) {
/* singletons can be compared directly */ /* singletons can be compared directly */
case TYPE_SYM: case TYPE_SYM:
case TYPE_BOOL: case TYPE_BOOL:
case TYPE_PRIM: case TYPE_PRIM:
case TYPE_FN: case TYPE_FN:
return a == b; return a == b;
case TYPE_INT: case TYPE_INT:
return INT_VAL(INT(a)) == INT_VAL(INT(b)); return INT_VAL(INT(a)) == INT_VAL(INT(b));
case TYPE_STR: case TYPE_STR:
return lk_str_equal(STR(a), STR(b)); return lk_str_equal(STR(a), STR(b));
case TYPE_LIST: case TYPE_LIST:
return list_equal(LIST(a), LIST(b)); return list_equal(LIST(a), LIST(b));
case TYPE_DLIST: case TYPE_DLIST:
return dlist_equal(DLIST(a), DLIST(b)); return dlist_equal(DLIST(a), DLIST(b));
case TYPE_COMM: case TYPE_COMM:
return comment_equal(COMM(a), COMM(b)); return comment_equal(COMM(a), COMM(b));
default: default:
ERR("unknown type %d (%s)", a->type, type_name(a)); ERR("unknown type %d (%s)", a->type, type_name(a));
return FALSE; return FALSE;
} }
} }
static LakeBool *bool_make(bool val) static LakeBool *bool_make(bool val)
{ {
LakeBool *b = malloc(sizeof(LakeBool)); LakeBool *b = malloc(sizeof(LakeBool));
VAL(b)->type = TYPE_BOOL; VAL(b)->type = TYPE_BOOL;
VAL(b)->size = sizeof(LakeBool); VAL(b)->size = sizeof(LakeBool);
b->val = val; b->val = val;
return b; return b;
} }
LakeCtx *lake_init(void) LakeCtx *lake_init(void)
{ {
LakeCtx *ctx = malloc(sizeof(LakeCtx)); LakeCtx *ctx = malloc(sizeof(LakeCtx));
ctx->toplevel = env_make(NULL); ctx->toplevel = env_make(NULL);
ctx->symbols = lk_hash_make(); ctx->symbols = lk_hash_make();
ctx->special_form_handlers = lk_hash_make(); ctx->special_form_handlers = lk_hash_make();
ctx->T = bool_make(TRUE); ctx->T = bool_make(TRUE);
ctx->F = bool_make(FALSE); ctx->F = bool_make(FALSE);
bind_primitives(ctx); bind_primitives(ctx);
init_special_form_handlers(ctx); init_special_form_handlers(ctx);
return ctx; return ctx;
} }

46
src/lake.h
View file

@ -39,16 +39,16 @@ typedef int LakeType;
#define COMM(x) ((LakeComment *)x) #define COMM(x) ((LakeComment *)x)
struct lake_val { struct lake_val {
LakeType type; LakeType type;
size_t size; size_t size;
}; };
typedef struct lake_val LakeVal; typedef struct lake_val LakeVal;
struct lake_sym { struct lake_sym {
LakeVal base; LakeVal base;
size_t n; size_t n;
char *s; char *s;
unsigned long hash; unsigned long hash;
}; };
typedef struct lake_sym LakeSym; typedef struct lake_sym LakeSym;
@ -59,17 +59,17 @@ struct lake_bool {
typedef struct lake_bool LakeBool; typedef struct lake_bool LakeBool;
struct lake_int { struct lake_int {
LakeVal base; LakeVal base;
int val; int val;
}; };
typedef struct lake_int LakeInt; typedef struct lake_int LakeInt;
#define INT_VAL(x) (x->val) #define INT_VAL(x) (x->val)
struct lake_str { struct lake_str {
LakeVal base; LakeVal base;
size_t n; size_t n;
char *s; char *s;
}; };
typedef struct lake_str LakeStr; typedef struct lake_str LakeStr;
@ -77,10 +77,10 @@ typedef struct lake_str LakeStr;
#define STR_S(str) (str->s) #define STR_S(str) (str->s)
struct lake_list { struct lake_list {
LakeVal base; LakeVal base;
size_t cap; size_t cap;
size_t n; size_t n;
LakeVal **vals; LakeVal **vals;
}; };
typedef struct lake_list LakeList; typedef struct lake_list LakeList;
@ -100,11 +100,11 @@ typedef struct lake_dlist LakeDottedList;
/* Execution context */ /* Execution context */
struct lake_ctx { struct lake_ctx {
Env *toplevel; Env *toplevel;
lk_hash_t *symbols; lk_hash_t *symbols;
lk_hash_t *special_form_handlers; lk_hash_t *special_form_handlers;
LakeBool *T; LakeBool *T;
LakeBool *F; LakeBool *F;
}; };
typedef struct lake_ctx LakeCtx; typedef struct lake_ctx LakeCtx;
@ -113,7 +113,7 @@ typedef LakeVal *(*lake_prim)(LakeCtx *ctx, LakeList *args);
struct lake_primitive { struct lake_primitive {
LakeVal base; LakeVal base;
char *name; char *name;
int arity; int arity;
lake_prim fn; lake_prim fn;
}; };
typedef struct lake_primitive LakePrimitive; typedef struct lake_primitive LakePrimitive;
@ -134,8 +134,8 @@ typedef struct lake_fn LakeFn;
#define CALLABLE(x) (lk_is_type(TYPE_FN, x) || lk_is_type(TYPE_PRIM, x)) #define CALLABLE(x) (lk_is_type(TYPE_FN, x) || lk_is_type(TYPE_PRIM, x))
struct lake_comment { struct lake_comment {
LakeVal base; LakeVal base;
LakeStr *text; LakeStr *text;
}; };
typedef struct lake_comment LakeComment; typedef struct lake_comment LakeComment;

122
src/list.c
View file

@ -22,10 +22,10 @@
static LakeList *list_alloc(void) static LakeList *list_alloc(void)
{ {
LakeList *list = malloc(sizeof(LakeList)); LakeList *list = malloc(sizeof(LakeList));
VAL(list)->type = TYPE_LIST; VAL(list)->type = TYPE_LIST;
VAL(list)->size = sizeof(LakeList); VAL(list)->size = sizeof(LakeList);
return list; return list;
} }
void list_free(LakeList *list) void list_free(LakeList *list)
@ -38,84 +38,84 @@ void list_free(LakeList *list)
LakeList *list_make(void) LakeList *list_make(void)
{ {
LakeList *list = list_make_with_capacity(LIST_INIT_CAP); LakeList *list = list_make_with_capacity(LIST_INIT_CAP);
memset(list->vals, 0, list->cap); memset(list->vals, 0, list->cap);
return list; return list;
} }
LakeList *list_cons(LakeVal *car, LakeVal *cdr) LakeList *list_cons(LakeVal *car, LakeVal *cdr)
{ {
LakeList *list; LakeList *list;
if (lk_is_type(TYPE_LIST, cdr)) { if (lk_is_type(TYPE_LIST, cdr)) {
list = LIST(cdr); list = LIST(cdr);
list_unshift(list, car); list_unshift(list, car);
} }
else { else {
list = list_make_with_capacity(2); list = list_make_with_capacity(2);
list_append(list, car); list_append(list, car);
list_append(list, cdr); list_append(list, cdr);
} }
return list; return list;
} }
LakeList *list_make_with_capacity(size_t cap) LakeList *list_make_with_capacity(size_t cap)
{ {
LakeList *list = list_alloc(); LakeList *list = list_alloc();
list->cap = cap; list->cap = cap;
list->n = 0; list->n = 0;
list->vals = malloc(cap * sizeof(LakeVal *)); list->vals = malloc(cap * sizeof(LakeVal *));
return list; return list;
} }
LakeList *list_from_array(size_t n, LakeVal *vals[]) LakeList *list_from_array(size_t n, LakeVal *vals[])
{ {
LakeList *list = list_make_with_capacity(n); LakeList *list = list_make_with_capacity(n);
memcpy(list->vals, vals, n * sizeof(LakeVal *)); memcpy(list->vals, vals, n * sizeof(LakeVal *));
list->n = n; list->n = n;
return list; return list;
} }
LakeInt *list_len(LakeList *list) LakeInt *list_len(LakeList *list)
{ {
return int_from_c(list->n); return int_from_c(list->n);
} }
LakeList *list_copy(LakeList *list) LakeList *list_copy(LakeList *list)
{ {
return list_from_array(list->n, list->vals); return list_from_array(list->n, list->vals);
} }
static void list_grow(LakeList *list) static void list_grow(LakeList *list)
{ {
list->cap *= 2; list->cap *= 2;
list->vals = realloc(list->vals, list->cap * sizeof(LakeVal *)); list->vals = realloc(list->vals, list->cap * sizeof(LakeVal *));
if (!list->vals) OOM(); if (!list->vals) OOM();
} }
LakeVal *list_set(LakeList *list, size_t i, LakeVal *val) LakeVal *list_set(LakeList *list, size_t i, LakeVal *val)
{ {
if (i < list->n) { if (i < list->n) {
list->vals[i] = val; list->vals[i] = val;
} }
return NULL; return NULL;
} }
LakeVal *list_get(LakeList *list, LakeInt *li) LakeVal *list_get(LakeList *list, LakeInt *li)
{ {
int i = INT_VAL(li); int i = INT_VAL(li);
if (i >= 0 && i < list->n) { if (i >= 0 && i < list->n) {
return list->vals[i]; return list->vals[i];
} }
return NULL; return NULL;
} }
LakeVal *list_append(LakeList *list, LakeVal *val) LakeVal *list_append(LakeList *list, LakeVal *val)
{ {
if (list->n >= list->cap) { if (list->n >= list->cap) {
list_grow(list); list_grow(list);
} }
list->vals[list->n++] = val; list->vals[list->n++] = val;
return NULL; return NULL;
} }
LakeVal *list_shift(LakeList *list) LakeVal *list_shift(LakeList *list)
@ -136,17 +136,17 @@ LakeVal *list_shift(LakeList *list)
LakeVal *list_unshift(LakeList *list, LakeVal *val) LakeVal *list_unshift(LakeList *list, LakeVal *val)
{ {
if (list->n == 0) { if (list->n == 0) {
list_append(list, val); list_append(list, val);
}
else {
if (list->n >= list->cap) {
list_grow(list);
} }
else {
if (list->n >= list->cap) {
list_grow(list);
}
size_t i = list->n++; size_t i = list->n++;
do { do {
list->vals[i] = list->vals[i - 1]; list->vals[i] = list->vals[i - 1];
} while (i--); } while (i--);
list->vals[0] = val; list->vals[0] = val;
} }
return NULL; return NULL;
} }
@ -163,14 +163,14 @@ LakeVal *list_pop(LakeList *list)
bool list_equal(LakeList *a, LakeList *b) bool list_equal(LakeList *a, LakeList *b)
{ {
if (a == b) return TRUE; if (a == b) return TRUE;
size_t n = LIST_N(a); size_t n = LIST_N(a);
if (n != LIST_N(b)) return FALSE; if (n != LIST_N(b)) return FALSE;
size_t i; size_t i;
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
if (!lake_equal(LIST_VAL(a, i), LIST_VAL(b, i))) return FALSE; if (!lake_equal(LIST_VAL(a, i), LIST_VAL(b, i))) return FALSE;
} }
return TRUE; return TRUE;
} }
LakeStr *list_to_str(LakeList *list) LakeStr *list_to_str(LakeList *list)

468
src/parse.c
View file

@ -20,11 +20,11 @@
#include "sym.h" #include "sym.h"
struct context { struct context {
char *s; char *s;
size_t n; size_t n;
size_t i; size_t i;
size_t mark; size_t mark;
LakeCtx *lake_ctx; LakeCtx *lake_ctx;
}; };
typedef struct context Ctx; typedef struct context Ctx;
@ -33,197 +33,197 @@ static int maybe_spaces(Ctx *ctx);
static char peek(Ctx *ctx) static char peek(Ctx *ctx)
{ {
if (ctx->i < ctx->n) return ctx->s[ctx->i]; if (ctx->i < ctx->n) return ctx->s[ctx->i];
return PARSE_EOF; return PARSE_EOF;
} }
static void warn_trailing(Ctx *ctx) static void warn_trailing(Ctx *ctx)
{ {
maybe_spaces(ctx); maybe_spaces(ctx);
/* don't warn about trailing comments */ /* don't warn about trailing comments */
if (ctx->i < ctx->n && peek(ctx) != ';') { if (ctx->i < ctx->n && peek(ctx) != ';') {
char *trailing = ctx->s + ctx->i; char *trailing = ctx->s + ctx->i;
fprintf(stderr, "warning: ignoring %d trailing chars: %s\n", (int)(ctx->n - ctx->i), trailing); fprintf(stderr, "warning: ignoring %d trailing chars: %s\n", (int)(ctx->n - ctx->i), trailing);
} }
} }
LakeVal *parse_expr(LakeCtx *lake_ctx, char *s, size_t n) LakeVal *parse_expr(LakeCtx *lake_ctx, char *s, size_t n)
{ {
Ctx ctx = { s, n, 0, 0, lake_ctx }; Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeVal *result = _parse_expr(&ctx); LakeVal *result = _parse_expr(&ctx);
warn_trailing(&ctx); warn_trailing(&ctx);
return result; return result;
} }
LakeList *parse_exprs(LakeCtx *lake_ctx, char *s, size_t n) LakeList *parse_exprs(LakeCtx *lake_ctx, char *s, size_t n)
{ {
Ctx ctx = { s, n, 0, 0, lake_ctx }; Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeList *results = list_make(); LakeList *results = list_make();
LakeVal *result; LakeVal *result;
while (ctx.i < ctx.n) { while (ctx.i < ctx.n) {
result = _parse_expr(&ctx); result = _parse_expr(&ctx);
if (result && result != VAL(PARSE_ERR)) { if (result && result != VAL(PARSE_ERR)) {
list_append(results, result); list_append(results, result);
}
else {
list_free(results);
return NULL;
}
} }
warn_trailing(&ctx); else {
return results; list_free(results);
return NULL;
}
}
warn_trailing(&ctx);
return results;
} }
LakeList *parse_naked_list(LakeCtx *lake_ctx, char *s, size_t n) LakeList *parse_naked_list(LakeCtx *lake_ctx, char *s, size_t n)
{ {
Ctx ctx = { s, n, 0, 0, lake_ctx }; Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeList *list = list_make(); LakeList *list = list_make();
char c; char c;
maybe_spaces(&ctx); maybe_spaces(&ctx);
while ((c = peek(&ctx)) != PARSE_EOF) { while ((c = peek(&ctx)) != PARSE_EOF) {
LakeVal *val = _parse_expr(&ctx); LakeVal *val = _parse_expr(&ctx);
if (val == VAL(PARSE_ERR)) { if (val == VAL(PARSE_ERR)) {
list_free(list); list_free(list);
ctx.i = ctx.n; ctx.i = ctx.n;
return NULL; return NULL;
}
list_append(list, val);
} }
warn_trailing(&ctx); list_append(list, val);
return list; }
warn_trailing(&ctx);
return list;
} }
static void consume(Ctx *ctx, size_t n) static void consume(Ctx *ctx, size_t n)
{ {
if (ctx->i + n > ctx->n) { if (ctx->i + n > ctx->n) {
DIE("cannot consume, no more input"); DIE("cannot consume, no more input");
} }
ctx->i += n; ctx->i += n;
} }
static char consume1(Ctx *ctx) static char consume1(Ctx *ctx)
{ {
char c = peek(ctx); char c = peek(ctx);
consume(ctx, 1); consume(ctx, 1);
return c; return c;
} }
static char ch(Ctx *ctx, char expected) static char ch(Ctx *ctx, char expected)
{ {
char c = peek(ctx); char c = peek(ctx);
if (c == expected) { if (c == expected) {
consume1(ctx); consume1(ctx);
return c; return c;
} }
DIE("parse error, expected '%c' got '%c'", expected, c); DIE("parse error, expected '%c' got '%c'", expected, c);
} }
static void mark(Ctx *ctx) static void mark(Ctx *ctx)
{ {
ctx->mark = ctx->i; ctx->mark = ctx->i;
} }
static void backtrack(Ctx *ctx) static void backtrack(Ctx *ctx)
{ {
ctx->i = ctx->mark; ctx->i = ctx->mark;
} }
static bool is_space(char c) static bool is_space(char c)
{ {
return strchr(" \r\n\t", c) != NULL; return strchr(" \r\n\t", c) != NULL;
} }
static bool is_letter(char c) static bool is_letter(char c)
{ {
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'); return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z');
} }
static bool is_symbol(char c) static bool is_symbol(char c)
{ {
return strchr("!$%&|*+-/:<=>?@^_~#", c) != NULL; return strchr("!$%&|*+-/:<=>?@^_~#", c) != NULL;
} }
static bool is_digit(char c) static bool is_digit(char c)
{ {
return c >= '0' && c <= '9'; return c >= '0' && c <= '9';
} }
static bool is_sym_char(char c) static bool is_sym_char(char c)
{ {
return is_letter(c) || is_symbol(c) || is_digit(c); return is_letter(c) || is_symbol(c) || is_digit(c);
} }
static bool is_newline(char c) static bool is_newline(char c)
{ {
return c == '\n' || c == '\r'; return c == '\n' || c == '\r';
} }
static char *parse_while(Ctx *ctx, bool (*is_valid)(char)) static char *parse_while(Ctx *ctx, bool (*is_valid)(char))
{ {
size_t n = 8; size_t n = 8;
size_t i = 0; size_t i = 0;
char *s = malloc(n); char *s = malloc(n);
char c; char c;
while ((c = peek(ctx)) != PARSE_EOF && is_valid(c)) { while ((c = peek(ctx)) != PARSE_EOF && is_valid(c)) {
s[i++] = c; s[i++] = c;
consume1(ctx); consume1(ctx);
/* grow if necessary */ /* grow if necessary */
if (i >= n) { if (i >= n) {
n *= 2; n *= 2;
if (!(s = realloc(s, n))) OOM(); if (!(s = realloc(s, n))) OOM();
}
} }
s[i] = '\0'; }
return s; s[i] = '\0';
return s;
} }
static int maybe_spaces(Ctx *ctx) static int maybe_spaces(Ctx *ctx)
{ {
while (is_space(peek(ctx))) { while (is_space(peek(ctx))) {
consume1(ctx); consume1(ctx);
} }
return 1; return 1;
} }
static LakeVal *parse_int(Ctx *ctx) static LakeVal *parse_int(Ctx *ctx)
{ {
mark(ctx); mark(ctx);
int n = 0; int n = 0;
char c = peek(ctx); char c = peek(ctx);
char sign = c == '-' ? -1 : 1; char sign = c == '-' ? -1 : 1;
if (c == '-' || c == '+') { if (c == '-' || c == '+') {
consume1(ctx); consume1(ctx);
/* if not followed by a digit it's a symbol */ /* if not followed by a digit it's a symbol */
if (!is_digit(peek(ctx))) { if (!is_digit(peek(ctx))) {
backtrack(ctx); backtrack(ctx);
return NULL; return NULL;
}
} }
while (is_digit(c = peek(ctx))) { }
n *= 10; while (is_digit(c = peek(ctx))) {
n += c - '0'; n *= 10;
consume1(ctx); n += c - '0';
} consume1(ctx);
/* if we're looking at a symbol character bail, it's not a number */ }
if (is_sym_char(peek(ctx))) { /* if we're looking at a symbol character bail, it's not a number */
backtrack(ctx); if (is_sym_char(peek(ctx))) {
return NULL; backtrack(ctx);
} return NULL;
return VAL(int_from_c(sign * n)); }
return VAL(int_from_c(sign * n));
} }
static LakeVal *parse_sym(Ctx *ctx) static LakeVal *parse_sym(Ctx *ctx)
{ {
LakeVal *val; LakeVal *val;
static int size = 1024; static int size = 1024;
char s[size]; char s[size];
char c; char c;
int i = 0; int i = 0;
while (is_sym_char(c = peek(ctx)) && i < size - 1) { while (is_sym_char(c = peek(ctx)) && i < size - 1) {
s[i++] = c; s[i++] = c;
consume1(ctx); consume1(ctx);
} }
s[i] = '\0'; s[i] = '\0';
if (strcmp(s, "#t") == 0) { if (strcmp(s, "#t") == 0) {
val = VAL(ctx->lake_ctx->T); val = VAL(ctx->lake_ctx->T);
} }
@ -233,161 +233,161 @@ static LakeVal *parse_sym(Ctx *ctx)
else { else {
val = VAL(sym_intern(ctx->lake_ctx, s)); val = VAL(sym_intern(ctx->lake_ctx, s));
} }
return val; return val;
} }
static char escape_char(char c) static char escape_char(char c)
{ {
switch (c) { switch (c) {
case 'n': case 'n':
c = '\n'; c = '\n';
break; break;
case 'r': case 'r':
c = '\r'; c = '\r';
break; break;
case 't': case 't':
c = '\t'; c = '\t';
break; break;
default: default:
/* noop */ /* noop */
break; break;
} }
return c; return c;
} }
static LakeVal *parse_str(Ctx *ctx) static LakeVal *parse_str(Ctx *ctx)
{ {
size_t n = 8; size_t n = 8;
size_t i = 0; size_t i = 0;
char *s = malloc(n); char *s = malloc(n);
char c; char c;
ch(ctx, '"'); ch(ctx, '"');
while ((c = peek(ctx)) != PARSE_EOF && c != '"') { while ((c = peek(ctx)) != PARSE_EOF && c != '"') {
/* handle backslash escapes */ /* handle backslash escapes */
if (c == '\\') { if (c == '\\') {
consume1(ctx); consume1(ctx);
c = escape_char(peek(ctx)); c = escape_char(peek(ctx));
if (c == PARSE_EOF) break; if (c == PARSE_EOF) break;
}
s[i++] = c;
consume1(ctx);
/* grow if necessary */
if (i >= n) {
n *= 2;
if (!(s = realloc(s, n))) OOM();
}
} }
s[i] = '\0'; s[i++] = c;
ch(ctx, '"'); consume1(ctx);
LakeStr *str = lk_str_from_c(s); /* grow if necessary */
free(s); if (i >= n) {
return VAL(str); n *= 2;
if (!(s = realloc(s, n))) OOM();
}
}
s[i] = '\0';
ch(ctx, '"');
LakeStr *str = lk_str_from_c(s);
free(s);
return VAL(str);
} }
static LakeVal* parse_list(Ctx *ctx) static LakeVal* parse_list(Ctx *ctx)
{ {
LakeList *list = list_make(); LakeList *list = list_make();
ch(ctx, '('); ch(ctx, '(');
char c; char c;
while ((c = peek(ctx)) != ')') { while ((c = peek(ctx)) != ')') {
if (c == PARSE_EOF) { if (c == PARSE_EOF) {
ERR("end of input while parsing list"); ERR("end of input while parsing list");
list_free(list); list_free(list);
ctx-> i = ctx->n; ctx-> i = ctx->n;
return NULL; return NULL;
}
/* check for dotted lists */
if (c == '.') {
ch(ctx, '.');
maybe_spaces(ctx);
LakeVal *tail = _parse_expr(ctx);
if (tail == VAL(PARSE_ERR)) {
list_free(list);
ctx->i = ctx->n;
return NULL;
}
ch(ctx, ')');
return VAL(dlist_make(list, tail));
}
LakeVal *val = _parse_expr(ctx);
if (val == VAL(PARSE_ERR)) {
list_free(list);
ctx->i = ctx->n;
return NULL;
}
list_append(list, val);
} }
ch(ctx, ')');
return VAL(list); /* check for dotted lists */
if (c == '.') {
ch(ctx, '.');
maybe_spaces(ctx);
LakeVal *tail = _parse_expr(ctx);
if (tail == VAL(PARSE_ERR)) {
list_free(list);
ctx->i = ctx->n;
return NULL;
}
ch(ctx, ')');
return VAL(dlist_make(list, tail));
}
LakeVal *val = _parse_expr(ctx);
if (val == VAL(PARSE_ERR)) {
list_free(list);
ctx->i = ctx->n;
return NULL;
}
list_append(list, val);
}
ch(ctx, ')');
return VAL(list);
} }
static LakeVal *parse_quoted(Ctx *ctx) static LakeVal *parse_quoted(Ctx *ctx)
{ {
ch(ctx, '\''); ch(ctx, '\'');
LakeList *list = list_make(); LakeList *list = list_make();
list_append(list, VAL(sym_intern(ctx->lake_ctx, "quote"))); list_append(list, VAL(sym_intern(ctx->lake_ctx, "quote")));
list_append(list, _parse_expr(ctx)); list_append(list, _parse_expr(ctx));
return VAL(list); return VAL(list);
} }
static bool is_not_newline(char c) static bool is_not_newline(char c)
{ {
return !is_newline(c); return !is_newline(c);
} }
static LakeVal *parse_comment(Ctx *ctx) static LakeVal *parse_comment(Ctx *ctx)
{ {
char *text = parse_while(ctx, is_not_newline); char *text = parse_while(ctx, is_not_newline);
LakeComment *comment = comment_from_c(text); LakeComment *comment = comment_from_c(text);
free(text); free(text);
return VAL(comment); return VAL(comment);
} }
static LakeVal *_parse_expr(Ctx *ctx) static LakeVal *_parse_expr(Ctx *ctx)
{ {
maybe_spaces(ctx); maybe_spaces(ctx);
LakeVal *result;
char c = peek(ctx);
/* try to parse a number, if that fails parse a symbol */
if ((c >= '0' && c <= '9') || c == '-' || c == '+') {
result = VAL(parse_int(ctx));
if (result == NULL) {
result = parse_sym(ctx);
}
}
else if (is_letter(c) || is_symbol(c)) {
result = parse_sym(ctx);
}
else if (c == '"') {
result = parse_str(ctx);
}
else if (c == '\'') {
result = parse_quoted(ctx);
}
else if (c == '(') {
result = parse_list(ctx);
}
else if (c == ';') {
result = parse_comment(ctx);
}
else if (c == PARSE_EOF) {
result = NULL;
}
else {
ERR("unexpected char '%c'", c);
result = VAL(PARSE_ERR);
ctx->i = ctx->n; /* consume the rest */
result = NULL;
}
maybe_spaces(ctx);
return result; LakeVal *result;
char c = peek(ctx);
/* try to parse a number, if that fails parse a symbol */
if ((c >= '0' && c <= '9') || c == '-' || c == '+') {
result = VAL(parse_int(ctx));
if (result == NULL) {
result = parse_sym(ctx);
}
}
else if (is_letter(c) || is_symbol(c)) {
result = parse_sym(ctx);
}
else if (c == '"') {
result = parse_str(ctx);
}
else if (c == '\'') {
result = parse_quoted(ctx);
}
else if (c == '(') {
result = parse_list(ctx);
}
else if (c == ';') {
result = parse_comment(ctx);
}
else if (c == PARSE_EOF) {
result = NULL;
}
else {
ERR("unexpected char '%c'", c);
result = VAL(PARSE_ERR);
ctx->i = ctx->n; /* consume the rest */
result = NULL;
}
maybe_spaces(ctx);
return result;
} }

444
src/primitive.c
View file

@ -23,285 +23,285 @@
static LakePrimitive *prim_alloc(void) static LakePrimitive *prim_alloc(void)
{ {
LakePrimitive *prim = malloc(sizeof(LakePrimitive)); LakePrimitive *prim = malloc(sizeof(LakePrimitive));
VAL(prim)->type = TYPE_PRIM; VAL(prim)->type = TYPE_PRIM;
VAL(prim)->size = sizeof(LakePrimitive); VAL(prim)->size = sizeof(LakePrimitive);
return prim; return prim;
} }
LakePrimitive *prim_make(char *name, int arity, lake_prim fn) LakePrimitive *prim_make(char *name, int arity, lake_prim fn)
{ {
LakePrimitive *prim = prim_alloc(); LakePrimitive *prim = prim_alloc();
prim->name = strdup(name); prim->name = strdup(name);
prim->arity = arity; prim->arity = arity;
prim->fn = fn; prim->fn = fn;
return prim; return prim;
} }
char *prim_repr(LakePrimitive *prim) char *prim_repr(LakePrimitive *prim)
{ {
size_t n = 16 + strlen(prim->name) + MAX_INT_LENGTH; size_t n = 16 + strlen(prim->name) + MAX_INT_LENGTH;
char *s = malloc(n); char *s = malloc(n);
snprintf(s, n, "<#primitive:%s(%d)>", prim->name, prim->arity); snprintf(s, n, "<#primitive:%s(%d)>", prim->name, prim->arity);
return s; return s;
} }
static LakeVal *_car(LakeCtx *ctx, LakeList *args) static LakeVal *_car(LakeCtx *ctx, LakeList *args)
{ {
LakeList *list = LIST(LIST_VAL(args, 0)); LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) { if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
return LIST_VAL(list, 0); return LIST_VAL(list, 0);
} }
if (lk_is_type(TYPE_DLIST, list)) { if (lk_is_type(TYPE_DLIST, list)) {
return VAL(dlist_head(DLIST(list))); return VAL(dlist_head(DLIST(list)));
} }
ERR("not a pair: %s", lake_repr(list)); ERR("not a pair: %s", lake_repr(list));
return NULL; return NULL;
} }
static LakeVal *_cdr(LakeCtx *ctx, LakeList *args) static LakeVal *_cdr(LakeCtx *ctx, LakeList *args)
{ {
LakeList *list = LIST(LIST_VAL(args, 0)); LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) { if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
LakeList *cdr = list_copy(list); LakeList *cdr = list_copy(list);
list_shift(cdr); list_shift(cdr);
return VAL(cdr); return VAL(cdr);
} }
if (lk_is_type(TYPE_DLIST, list)) { if (lk_is_type(TYPE_DLIST, list)) {
return dlist_tail(DLIST(list)); return dlist_tail(DLIST(list));
} }
ERR("not a pair: %s", lake_repr(list)); ERR("not a pair: %s", lake_repr(list));
return NULL; return NULL;
} }
static LakeVal *_cons(LakeCtx *ctx, LakeList *args) static LakeVal *_cons(LakeCtx *ctx, LakeList *args)
{ {
LakeVal *car = LIST_VAL(args, 0); LakeVal *car = LIST_VAL(args, 0);
LakeVal *cdr = LIST_VAL(args, 1); LakeVal *cdr = LIST_VAL(args, 1);
return VAL(list_cons(car, cdr)); return VAL(list_cons(car, cdr));
} }
static LakeVal *_nullP(LakeCtx *ctx, LakeList *args) static LakeVal *_nullP(LakeCtx *ctx, LakeList *args)
{ {
LakeVal *val = list_shift(args); LakeVal *val = list_shift(args);
LakeBool *is_null = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) == 0); LakeBool *is_null = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) == 0);
return VAL(is_null); return VAL(is_null);
} }
static LakeVal *_pairP(LakeCtx *ctx, LakeList *args) static LakeVal *_pairP(LakeCtx *ctx, LakeList *args)
{ {
LakeVal *val = list_shift(args); LakeVal *val = list_shift(args);
LakeBool *is_pair = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) > 0); LakeBool *is_pair = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) > 0);
return VAL(is_pair); return VAL(is_pair);
} }
static LakeVal *_isP(LakeCtx *ctx, LakeList *args) static LakeVal *_isP(LakeCtx *ctx, LakeList *args)
{ {
LakeVal *a = LIST_VAL(args, 0); LakeVal *a = LIST_VAL(args, 0);
LakeVal *b = LIST_VAL(args, 1); LakeVal *b = LIST_VAL(args, 1);
return VAL(lk_bool_from_int(ctx, lake_is(a, b))); return VAL(lk_bool_from_int(ctx, lake_is(a, b)));
} }
static LakeVal *_equalP(LakeCtx *ctx, LakeList *args) static LakeVal *_equalP(LakeCtx *ctx, LakeList *args)
{ {
LakeVal *a = LIST_VAL(args, 0); LakeVal *a = LIST_VAL(args, 0);
LakeVal *b = LIST_VAL(args, 1); LakeVal *b = LIST_VAL(args, 1);
return VAL(lk_bool_from_int(ctx, lake_equal(a, b))); return VAL(lk_bool_from_int(ctx, lake_equal(a, b)));
} }
static LakeVal *_not(LakeCtx *ctx, LakeList *args) static LakeVal *_not(LakeCtx *ctx, LakeList *args)
{ {
LakeVal *val = list_shift(args); LakeVal *val = list_shift(args);
LakeBool *not = lk_bool_from_int(ctx, lk_is_false(ctx, val)); LakeBool *not = lk_bool_from_int(ctx, lk_is_false(ctx, val));
return VAL(not); return VAL(not);
} }
#define ENSURE_INT(x, i) do { \ #define ENSURE_INT(x, i) do { \
if (!lk_is_type(TYPE_INT, x)) { \ if (!lk_is_type(TYPE_INT, x)) { \
ERR("argument %zu is not an integer: %s", i, lake_repr(x)); \ ERR("argument %zu is not an integer: %s", i, lake_repr(x)); \
return NULL; \ return NULL; \
} \ } \
} while (0) } while (0)
static LakeVal *_add(LakeCtx *ctx, LakeList *args) static LakeVal *_add(LakeCtx *ctx, LakeList *args)
{ {
int result = 0; int result = 0;
size_t n = LIST_N(args); size_t n = LIST_N(args);
size_t i; size_t i;
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i); LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i); ENSURE_INT(v, i);
result += INT_VAL(INT(v)); result += INT_VAL(INT(v));
} }
return VAL(int_from_c(result)); return VAL(int_from_c(result));
} }
static LakeVal *_sub(LakeCtx *ctx, LakeList *args) static LakeVal *_sub(LakeCtx *ctx, LakeList *args)
{ {
size_t n = LIST_N(args); size_t n = LIST_N(args);
if (n < 1) { if (n < 1) {
ERR("- requires at least one argument"); ERR("- requires at least one argument");
return NULL; return NULL;
} }
int result = 0; int result = 0;
size_t i; size_t i;
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i); LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i); ENSURE_INT(v, i);
result -= INT_VAL(INT(v)); result -= INT_VAL(INT(v));
} }
return VAL(int_from_c(result)); return VAL(int_from_c(result));
} }
static LakeVal *_mul(LakeCtx *ctx, LakeList *args) static LakeVal *_mul(LakeCtx *ctx, LakeList *args)
{ {
int result = 1; int result = 1;
size_t n = LIST_N(args); size_t n = LIST_N(args);
size_t i; size_t i;
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i); LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i); ENSURE_INT(v, i);
result *= INT_VAL(INT(v)); result *= INT_VAL(INT(v));
} }
return VAL(int_from_c(result)); return VAL(int_from_c(result));
} }
#define DIVIDE_BY_ZERO() ERR("divide by zero") #define DIVIDE_BY_ZERO() ERR("divide by zero")
static LakeVal *_div(LakeCtx *ctx, LakeList *args) static LakeVal *_div(LakeCtx *ctx, LakeList *args)
{ {
size_t n = LIST_N(args); size_t n = LIST_N(args);
if (n < 1) {
ERR("/ requires at least one argument");
return NULL;
}
LakeVal *v = LIST_VAL(args, 0);
ENSURE_INT(v, (size_t)0);
int result = INT_VAL(INT(v));
if (n == 1) { if (n < 1) {
if (result == 0) { ERR("/ requires at least one argument");
DIVIDE_BY_ZERO(); return NULL;
return NULL; }
}
result = 1 / result; LakeVal *v = LIST_VAL(args, 0);
ENSURE_INT(v, (size_t)0);
int result = INT_VAL(INT(v));
if (n == 1) {
if (result == 0) {
DIVIDE_BY_ZERO();
return NULL;
} }
else { result = 1 / result;
size_t i; }
for (i = 1; i < n; ++i) { else {
v = LIST_VAL(args, i); size_t i;
ENSURE_INT(v, i); for (i = 1; i < n; ++i) {
int val = INT_VAL(INT(v)); v = LIST_VAL(args, i);
if (val == 0) { ENSURE_INT(v, i);
DIVIDE_BY_ZERO(); int val = INT_VAL(INT(v));
return NULL; if (val == 0) {
} DIVIDE_BY_ZERO();
result /= val; return NULL;
} }
result /= val;
} }
return VAL(int_from_c(result)); }
return VAL(int_from_c(result));
} }
static LakeVal *_int_eq(LakeCtx *ctx, LakeList *args) static LakeVal *_int_eq(LakeCtx *ctx, LakeList *args)
{ {
bool result = TRUE; bool result = TRUE;
size_t n = LIST_N(args); size_t n = LIST_N(args);
size_t i; size_t i;
int curr, prev; int curr, prev;
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i); LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i); ENSURE_INT(v, i);
curr = INT_VAL(INT(v)); curr = INT_VAL(INT(v));
if (i > 0) { if (i > 0) {
result = result && curr == prev; result = result && curr == prev;
}
prev = INT_VAL(INT(v));
} }
return VAL(lk_bool_from_int(ctx, result)); prev = INT_VAL(INT(v));
}
return VAL(lk_bool_from_int(ctx, result));
} }
static LakeVal *_int_lt(LakeCtx *ctx, LakeList *args) static LakeVal *_int_lt(LakeCtx *ctx, LakeList *args)
{ {
bool result = TRUE; bool result = TRUE;
size_t n = LIST_N(args); size_t n = LIST_N(args);
size_t i; size_t i;
int curr, prev; int curr, prev;
if (n > 1) { if (n > 1) {
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i); LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i); ENSURE_INT(v, i);
curr = INT_VAL(INT(v)); curr = INT_VAL(INT(v));
if (i > 0) { if (i > 0) {
result = result && prev < curr; result = result && prev < curr;
} }
prev = INT_VAL(INT(v)); prev = INT_VAL(INT(v));
}
} }
return VAL(lk_bool_from_int(ctx, result)); }
return VAL(lk_bool_from_int(ctx, result));
} }
static LakeVal *_int_gt(LakeCtx *ctx, LakeList *args) static LakeVal *_int_gt(LakeCtx *ctx, LakeList *args)
{ {
bool result = TRUE; bool result = TRUE;
size_t n = LIST_N(args); size_t n = LIST_N(args);
size_t i; size_t i;
int curr, prev; int curr, prev;
if (n > 1) { if (n > 1) {
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i); LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i); ENSURE_INT(v, i);
curr = INT_VAL(INT(v)); curr = INT_VAL(INT(v));
if (i > 0) { if (i > 0) {
result = result && prev > curr; result = result && prev > curr;
} }
prev = INT_VAL(INT(v)); prev = INT_VAL(INT(v));
}
} }
return VAL(lk_bool_from_int(ctx, result)); }
return VAL(lk_bool_from_int(ctx, result));
} }
static LakeVal *_set_carB(LakeCtx *ctx, LakeList *args) static LakeVal *_set_carB(LakeCtx *ctx, LakeList *args)
{ {
LakeList *list = LIST(LIST_VAL(args, 0)); LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list)) { if (lk_is_type(TYPE_LIST, list)) {
LakeVal *new_car = LIST_VAL(args, 1); LakeVal *new_car = LIST_VAL(args, 1);
if (LIST_N(list) == 0) { if (LIST_N(list) == 0) {
list_append(list, new_car); list_append(list, new_car);
}
else {
list_set(list, 0, new_car);
}
return VAL(list);
} }
ERR("not a pair: %s", lake_repr(list)); else {
return NULL; list_set(list, 0, new_car);
}
return VAL(list);
}
ERR("not a pair: %s", lake_repr(list));
return NULL;
} }
static LakeVal *_display(LakeCtx *ctx, LakeList *args) static LakeVal *_display(LakeCtx *ctx, LakeList *args)
{ {
size_t n = LIST_N(args); size_t n = LIST_N(args);
size_t i; size_t i;
int space = 0; int space = 0;
for (i = 0; i < n; ++i) { for (i = 0; i < n; ++i) {
if (space) putchar(' '); if (space) putchar(' ');
printf("%s", lake_repr(LIST_VAL(args, i))); printf("%s", lake_repr(LIST_VAL(args, i)));
space = 1; space = 1;
} }
putchar('\n'); putchar('\n');
return NULL; return NULL;
} }
#define DEFINE_PREDICATE(name, type) \ #define DEFINE_PREDICATE(name, type) \
static LakeVal *_## name ##P(LakeCtx *ctx, LakeList *args) \ static LakeVal *_## name ##P(LakeCtx *ctx, LakeList *args) \
{ \ { \
return VAL(lk_bool_from_int(ctx, lk_is_type(type, LIST_VAL(args, 0)))); \ return VAL(lk_bool_from_int(ctx, lk_is_type(type, LIST_VAL(args, 0)))); \
} }
DEFINE_PREDICATE(symbol, TYPE_SYM) DEFINE_PREDICATE(symbol, TYPE_SYM)
DEFINE_PREDICATE(list, TYPE_LIST) DEFINE_PREDICATE(list, TYPE_LIST)
@ -317,44 +317,44 @@ DEFINE_PREDICATE(primitive, TYPE_PRIM)
void bind_primitives(LakeCtx *ctx) void bind_primitives(LakeCtx *ctx)
{ {
#define DEFINE(name, fn, arity) env_define(ctx->toplevel, \ #define DEFINE(name, fn, arity) env_define(ctx->toplevel, \
sym_intern(ctx, name), \ sym_intern(ctx, name), \
VAL(prim_make(name, arity, fn))) VAL(prim_make(name, arity, fn)))
DEFINE("car", _car, 1); DEFINE("car", _car, 1);
DEFINE("cdr", _cdr, 1); DEFINE("cdr", _cdr, 1);
DEFINE("cons", _cons, 2); DEFINE("cons", _cons, 2);
DEFINE("null?", _nullP, 1); DEFINE("null?", _nullP, 1);
DEFINE("pair?", _pairP, 1); DEFINE("pair?", _pairP, 1);
DEFINE("is?", _isP, 2); DEFINE("is?", _isP, 2);
DEFINE("equal?", _equalP, 2); DEFINE("equal?", _equalP, 2);
DEFINE("not", _not, 1); DEFINE("not", _not, 1);
DEFINE("+", _add, ARITY_VARARGS); DEFINE("+", _add, ARITY_VARARGS);
DEFINE("-", _sub, ARITY_VARARGS); DEFINE("-", _sub, ARITY_VARARGS);
DEFINE("*", _mul, ARITY_VARARGS); DEFINE("*", _mul, ARITY_VARARGS);
DEFINE("/", _div, ARITY_VARARGS); DEFINE("/", _div, ARITY_VARARGS);
DEFINE("=", _int_eq, ARITY_VARARGS); DEFINE("=", _int_eq, ARITY_VARARGS);
DEFINE("<", _int_lt, ARITY_VARARGS); DEFINE("<", _int_lt, ARITY_VARARGS);
DEFINE(">", _int_gt, ARITY_VARARGS); DEFINE(">", _int_gt, ARITY_VARARGS);
DEFINE("set-car!", _set_carB, 2); DEFINE("set-car!", _set_carB, 2);
DEFINE("display", _display, ARITY_VARARGS); DEFINE("display", _display, ARITY_VARARGS);
DEFINE("symbol?", _symbolP, 1); DEFINE("symbol?", _symbolP, 1);
DEFINE("list?", _listP, 1); DEFINE("list?", _listP, 1);
DEFINE("dotted-list?", _dotted_listP, 1); DEFINE("dotted-list?", _dotted_listP, 1);
DEFINE("number?", _numberP, 1); DEFINE("number?", _numberP, 1);
DEFINE("integer?", _integerP, 1); DEFINE("integer?", _integerP, 1);
DEFINE("string?", _stringP, 1); DEFINE("string?", _stringP, 1);
DEFINE("bool?", _boolP, 1); DEFINE("bool?", _boolP, 1);
DEFINE("function?", _functionP, 1); DEFINE("function?", _functionP, 1);
DEFINE("primitive?", _primitiveP, 1); DEFINE("primitive?", _primitiveP, 1);
/* string=? */ /* string=? */
/* string< */ /* string< */
/* string> */ /* string> */
/* string-concatenate */ /* string-concatenate */
/* string-slice */ /* string-slice */
#undef DEFINE #undef DEFINE
} }

204
src/repl.c
View file

@ -24,143 +24,143 @@
void print(LakeVal *expr) void print(LakeVal *expr)
{ {
printf("%s\n", lake_repr(expr)); printf("%s\n", lake_repr(expr));
} }
static char first_char(char *s) static char first_char(char *s)
{ {
char c; char c;
while ((c = *s++) && (c == ' ' || c == '\n' || c == '\t')); while ((c = *s++) && (c == ' ' || c == '\n' || c == '\t'));
return c; return c;
} }
static LakeVal *prompt_read(LakeCtx *ctx, Env *env, char *prompt) static LakeVal *prompt_read(LakeCtx *ctx, Env *env, char *prompt)
{ {
static int n = 1024; static int n = 1024;
printf("%s", prompt); printf("%s", prompt);
char buf[n]; char buf[n];
if (!fgets(buf, n, stdin)) { if (!fgets(buf, n, stdin)) {
if (ferror(stdin)) { if (ferror(stdin)) {
fprintf(stderr, "error: cannot read from stdin"); fprintf(stderr, "error: cannot read from stdin");
}
if (feof(stdin)) {
return VAL(EOF);
}
return NULL;
} }
if (feof(stdin)) {
return VAL(EOF);
}
return NULL;
}
/* trim the newline if any */ /* trim the newline if any */
buf[strcspn(buf, "\n")] = '\0'; buf[strcspn(buf, "\n")] = '\0';
/* parse list expressions */ /* parse list expressions */
if (first_char(buf) == '(') { if (first_char(buf) == '(') {
return parse_expr(ctx, buf, strlen(buf)); return parse_expr(ctx, buf, strlen(buf));
} }
/* try to parse a naked call without parens /* try to parse a naked call without parens
(makes the repl more palatable) */ (makes the repl more palatable) */
LakeList *list = parse_naked_list(ctx, buf, strlen(buf)); LakeList *list = parse_naked_list(ctx, buf, strlen(buf));
if (!list || LIST_N(list) == 0) return NULL; if (!list || LIST_N(list) == 0) return NULL;
LakeVal *result; LakeVal *result;
/* naked call */ /* naked call */
LakeVal *head; LakeVal *head;
if (is_special_form(ctx, list) || if (is_special_form(ctx, list) ||
(LIST_N(list) > 1 && (head = eval(ctx, env, LIST_VAL(list, 0))) && CALLABLE(head))) { (LIST_N(list) > 1 && (head = eval(ctx, env, LIST_VAL(list, 0))) && CALLABLE(head))) {
result = VAL(list); result = VAL(list);
} }
/* probably not function calls, just give the first expr /* probably not function calls, just give the first expr
(maybe do an implicit progn thing here) */ (maybe do an implicit progn thing here) */
else { else {
result = LIST_VAL(list, 0); result = LIST_VAL(list, 0);
} }
return result; return result;
} }
static void run_repl(LakeCtx *ctx, Env *env) static void run_repl(LakeCtx *ctx, Env *env)
{ {
puts("Lake Scheme v" LAKE_VERSION); puts("Lake Scheme v" LAKE_VERSION);
LakeVal *expr; LakeVal *expr;
LakeVal *result; LakeVal *result;
for (;;) { for (;;) {
expr = prompt_read(ctx, env, "> "); expr = prompt_read(ctx, env, "> ");
if (expr == VAL(EOF)) break; if (expr == VAL(EOF)) break;
if (expr == VAL(PARSE_ERR)) { if (expr == VAL(PARSE_ERR)) {
ERR("parse error"); ERR("parse error");
continue; continue;
}
if (expr) {
result = eval(ctx, env, expr);
if (result) print(result);
}
} }
if (expr) {
result = eval(ctx, env, expr);
if (result) print(result);
}
}
} }
static char *read_file(char const *filename) static char *read_file(char const *filename)
{ {
FILE *fp = fopen(filename, "r"); FILE *fp = fopen(filename, "r");
if (fp) { if (fp) {
size_t size = 4096; size_t size = 4096;
char buf[size]; char buf[size];
size_t n = size; size_t n = size;
size_t i = 0; size_t i = 0;
size_t read; size_t read;
char *s = malloc(n); char *s = malloc(n);
while (!feof(fp) && !ferror(fp)) { while (!feof(fp) && !ferror(fp)) {
read = fread(buf, 1, size, fp); read = fread(buf, 1, size, fp);
if (i + read > n) { if (i + read > n) {
n += size; n += size;
if (!(s = realloc(s, n))) OOM(); if (!(s = realloc(s, n))) OOM();
} }
memcpy(s + i, buf, read); memcpy(s + i, buf, read);
i += read; i += read;
}
s[i] = '\0';
if (ferror(fp)) {
ERR("failed to read file %s: %s", filename, strerror(errno));
return NULL;
}
fclose(fp);
return s;
} }
else { s[i] = '\0';
ERR("cannot open file %s: %s", filename, strerror(errno)); if (ferror(fp)) {
return NULL; ERR("failed to read file %s: %s", filename, strerror(errno));
return NULL;
} }
fclose(fp);
return s;
}
else {
ERR("cannot open file %s: %s", filename, strerror(errno));
return NULL;
}
} }
int main (int argc, char const *argv[]) int main (int argc, char const *argv[])
{ {
/* create an execution context */ /* create an execution context */
LakeCtx *ctx = lake_init(); LakeCtx *ctx = lake_init();
/* create and bind args */ /* create and bind args */
LakeVal **argVals = malloc(argc * sizeof(LakeVal *)); LakeVal **argVals = malloc(argc * sizeof(LakeVal *));
int i; int i;
for (i = 0; i < argc; ++i) { for (i = 0; i < argc; ++i) {
argVals[i] = VAL(lk_str_from_c((char *)argv[i])); argVals[i] = VAL(lk_str_from_c((char *)argv[i]));
}
LakeList *args = list_from_array(argc, argVals);
free(argVals);
env_define(ctx->toplevel, sym_intern(ctx, "args"), VAL(args));
/* if a filename is given load the file */
if (argc > 1) {
char *text = read_file(argv[1]);
if (text) {
LakeList *exprs = parse_exprs(ctx, text, strlen(text));
if (exprs) {
eval_exprs(ctx, ctx->toplevel, exprs);
}
} }
LakeList *args = list_from_array(argc, argVals); }
free(argVals);
env_define(ctx->toplevel, sym_intern(ctx, "args"), VAL(args)); /* run the repl */
run_repl(ctx, ctx->toplevel);
/* if a filename is given load the file */
if (argc > 1) { return 0;
char *text = read_file(argv[1]);
if (text) {
LakeList *exprs = parse_exprs(ctx, text, strlen(text));
if (exprs) {
eval_exprs(ctx, ctx->toplevel, exprs);
}
}
}
/* run the repl */
run_repl(ctx, ctx->toplevel);
return 0;
} }

40
src/str.c
View file

@ -18,60 +18,60 @@
static LakeStr *lk_str_alloc(void) static LakeStr *lk_str_alloc(void)
{ {
LakeStr *str = malloc(sizeof(LakeStr)); LakeStr *str = malloc(sizeof(LakeStr));
VAL(str)->type = TYPE_STR; VAL(str)->type = TYPE_STR;
VAL(str)->size = sizeof(LakeStr); VAL(str)->size = sizeof(LakeStr);
return str; return str;
} }
void lk_str_free(LakeStr *str) void lk_str_free(LakeStr *str)
{ {
free(STR_S(str)); free(STR_S(str));
free(str); free(str);
} }
static LakeVal *lk_str_set(LakeStr *str, char *s) static LakeVal *lk_str_set(LakeStr *str, char *s)
{ {
STR_N(str) = strlen(s); STR_N(str) = strlen(s);
STR_S(str) = strndup(s, STR_N(str)); STR_S(str) = strndup(s, STR_N(str));
return NULL; return NULL;
} }
LakeStr *lk_str_from_c(char *s) LakeStr *lk_str_from_c(char *s)
{ {
LakeStr *str = lk_str_alloc(); LakeStr *str = lk_str_alloc();
lk_str_set(str, s); lk_str_set(str, s);
return str; return str;
} }
LakeStr *lk_str_make(void) LakeStr *lk_str_make(void)
{ {
return lk_str_from_c(""); return lk_str_from_c("");
} }
LakeInt *lk_str_len(LakeStr *str) LakeInt *lk_str_len(LakeStr *str)
{ {
return int_from_c(STR_N(str)); return int_from_c(STR_N(str));
} }
LakeStr *lk_str_copy(LakeStr *str) LakeStr *lk_str_copy(LakeStr *str)
{ {
return lk_str_from_c(STR_S(str)); return lk_str_from_c(STR_S(str));
} }
char *lk_str_val(LakeStr *str) char *lk_str_val(LakeStr *str)
{ {
return strndup(STR_S(str), STR_N(str)); return strndup(STR_S(str), STR_N(str));
} }
bool lk_str_equal(LakeStr *a, LakeStr *b) bool lk_str_equal(LakeStr *a, LakeStr *b)
{ {
if (STR_N(a) != STR_N(b)) return FALSE; if (STR_N(a) != STR_N(b)) return FALSE;
size_t n = MIN(STR_N(a), STR_N(b)); size_t n = MIN(STR_N(a), STR_N(b));
return strncmp(STR_S(a), STR_S(b), n) == 0; return strncmp(STR_S(a), STR_S(b), n) == 0;
} }
LakeStr *lk_str_to_str(LakeStr *str) LakeStr *lk_str_to_str(LakeStr *str)
{ {
return lk_str_copy(str); return lk_str_copy(str);
} }

32
src/sym.c
View file

@ -33,41 +33,41 @@ static uint32_t str_hash(const char *s)
static LakeSym *sym_alloc(void) static LakeSym *sym_alloc(void)
{ {
LakeSym *sym = malloc(sizeof(LakeSym)); LakeSym *sym = malloc(sizeof(LakeSym));
VAL(sym)->type = TYPE_SYM; VAL(sym)->type = TYPE_SYM;
VAL(sym)->size = sizeof(LakeSym); VAL(sym)->size = sizeof(LakeSym);
return sym; return sym;
} }
LakeSym *sym_intern(LakeCtx *ctx, char *s) LakeSym *sym_intern(LakeCtx *ctx, char *s)
{ {
LakeSym *sym = lk_hash_get(ctx->symbols, s); LakeSym *sym = lk_hash_get(ctx->symbols, s);
if (!sym) { if (!sym) {
sym = sym_alloc(); sym = sym_alloc();
sym->n = strlen(s); sym->n = strlen(s);
sym->s = strndup(s, sym->n); sym->s = strndup(s, sym->n);
sym->hash = str_hash(s); sym->hash = str_hash(s);
lk_hash_put(ctx->symbols, sym->s, sym); lk_hash_put(ctx->symbols, sym->s, sym);
} }
return sym; return sym;
} }
LakeStr *sym_to_str(LakeSym *sym) LakeStr *sym_to_str(LakeSym *sym)
{ {
return lk_str_from_c(sym->s); return lk_str_from_c(sym->s);
} }
LakeSym *sym_from_str(LakeCtx *ctx, LakeStr *str) LakeSym *sym_from_str(LakeCtx *ctx, LakeStr *str)
{ {
return sym_intern(ctx, str->s); return sym_intern(ctx, str->s);
} }
char *sym_repr(LakeSym *sym) char *sym_repr(LakeSym *sym)
{ {
return strndup(sym->s, sym->n); return strndup(sym->s, sym->n);
} }
unsigned long sym_val(LakeSym *sym) unsigned long sym_val(LakeSym *sym)
{ {
return sym->hash; return sym->hash;
} }