sjs/lake
1
0
Fork 0
mirror of https://github.com/samsonjs/lake.git synced 2026-03-25 08:55:49 +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)
{
return b->val;
return b->val;
}
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)
{
return VAL(x) == VAL(ctx->F);
return VAL(x) == VAL(ctx->F);
}
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)
{
return lk_is_false(ctx, x);
return lk_is_false(ctx, x);
}
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)
{
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)
{
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)
{
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)
{
return dlist->head;
return dlist->head;
}
LakeVal *dlist_tail(LakeDottedList *dlist)
{
return dlist->tail;
return dlist->tail;
}
char *dlist_repr(LakeDottedList *dlist)
@ -66,9 +66,9 @@ char *dlist_repr(LakeDottedList *dlist)
bool dlist_equal(LakeDottedList *a, LakeDottedList *b)
{
LakeVal *headA = VAL(dlist_head(a));
LakeVal *tailA = dlist_tail(a);
LakeVal *headB = VAL(dlist_head(b));
LakeVal *tailB = dlist_tail(b);
return lake_equal(headA, headB) && lake_equal(tailA, tailB);
LakeVal *headA = VAL(dlist_head(a));
LakeVal *tailA = dlist_tail(a);
LakeVal *headB = VAL(dlist_head(b));
LakeVal *tailB = dlist_tail(b);
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 = malloc(sizeof(Env));
env->parent = parent;
env->bindings = lk_hash_make();
return env;
Env *env = malloc(sizeof(Env));
env->parent = parent;
env->bindings = lk_hash_make();
return env;
}
Env *env_is_defined(Env *env, LakeSym *key)
{
if (lk_hash_get(env->bindings, key->s) != NULL) return env;
return env->parent ? env_is_defined(env->parent, key) : NULL;
if (lk_hash_get(env->bindings, key->s) != NULL) return env;
return env->parent ? env_is_defined(env->parent, key) : NULL;
}
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)
{
env_put(env, key, val);
return val;
env_put(env, key, val);
return val;
}
LakeVal *env_set(Env *env, LakeSym *key, LakeVal *val)
{
Env *definedEnv;
if (!(definedEnv = env_is_defined(env, key))) {
return NULL;
}
env_put(definedEnv, key, val);
return val;
Env *definedEnv;
if (!(definedEnv = env_is_defined(env, key))) {
return NULL;
}
env_put(definedEnv, key, val);
return val;
}
LakeVal *env_get(Env *env, LakeSym *key)
{
LakeVal *val = lk_hash_get(env->bindings, key->s);
if (!val && env->parent) {
val = env_get(env->parent, key);
}
return val;
LakeVal *val = lk_hash_get(env->bindings, key->s);
if (!val && env->parent) {
val = env_get(env->parent, key);
}
return val;
}

4
src/env.h
View file

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

184
src/lake.c
View file

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

46
src/lake.h
View file

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

122
src/list.c
View file

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

468
src/parse.c
View file

@ -20,11 +20,11 @@
#include "sym.h"
struct context {
char *s;
size_t n;
size_t i;
size_t mark;
LakeCtx *lake_ctx;
char *s;
size_t n;
size_t i;
size_t mark;
LakeCtx *lake_ctx;
};
typedef struct context Ctx;
@ -33,197 +33,197 @@ static int maybe_spaces(Ctx *ctx);
static char peek(Ctx *ctx)
{
if (ctx->i < ctx->n) return ctx->s[ctx->i];
return PARSE_EOF;
if (ctx->i < ctx->n) return ctx->s[ctx->i];
return PARSE_EOF;
}
static void warn_trailing(Ctx *ctx)
{
maybe_spaces(ctx);
/* don't warn about trailing comments */
if (ctx->i < ctx->n && peek(ctx) != ';') {
char *trailing = ctx->s + ctx->i;
fprintf(stderr, "warning: ignoring %d trailing chars: %s\n", (int)(ctx->n - ctx->i), trailing);
}
maybe_spaces(ctx);
/* don't warn about trailing comments */
if (ctx->i < ctx->n && peek(ctx) != ';') {
char *trailing = ctx->s + ctx->i;
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)
{
Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeVal *result = _parse_expr(&ctx);
warn_trailing(&ctx);
return result;
Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeVal *result = _parse_expr(&ctx);
warn_trailing(&ctx);
return result;
}
LakeList *parse_exprs(LakeCtx *lake_ctx, char *s, size_t n)
{
Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeList *results = list_make();
LakeVal *result;
while (ctx.i < ctx.n) {
result = _parse_expr(&ctx);
if (result && result != VAL(PARSE_ERR)) {
list_append(results, result);
}
else {
list_free(results);
return NULL;
}
Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeList *results = list_make();
LakeVal *result;
while (ctx.i < ctx.n) {
result = _parse_expr(&ctx);
if (result && result != VAL(PARSE_ERR)) {
list_append(results, result);
}
warn_trailing(&ctx);
return results;
else {
list_free(results);
return NULL;
}
}
warn_trailing(&ctx);
return results;
}
LakeList *parse_naked_list(LakeCtx *lake_ctx, char *s, size_t n)
{
Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeList *list = list_make();
char c;
maybe_spaces(&ctx);
while ((c = peek(&ctx)) != PARSE_EOF) {
LakeVal *val = _parse_expr(&ctx);
if (val == VAL(PARSE_ERR)) {
list_free(list);
ctx.i = ctx.n;
return NULL;
}
list_append(list, val);
Ctx ctx = { s, n, 0, 0, lake_ctx };
LakeList *list = list_make();
char c;
maybe_spaces(&ctx);
while ((c = peek(&ctx)) != PARSE_EOF) {
LakeVal *val = _parse_expr(&ctx);
if (val == VAL(PARSE_ERR)) {
list_free(list);
ctx.i = ctx.n;
return NULL;
}
warn_trailing(&ctx);
return list;
list_append(list, val);
}
warn_trailing(&ctx);
return list;
}
static void consume(Ctx *ctx, size_t n)
{
if (ctx->i + n > ctx->n) {
DIE("cannot consume, no more input");
}
ctx->i += n;
if (ctx->i + n > ctx->n) {
DIE("cannot consume, no more input");
}
ctx->i += n;
}
static char consume1(Ctx *ctx)
{
char c = peek(ctx);
consume(ctx, 1);
return c;
char c = peek(ctx);
consume(ctx, 1);
return c;
}
static char ch(Ctx *ctx, char expected)
{
char c = peek(ctx);
if (c == expected) {
consume1(ctx);
return c;
}
DIE("parse error, expected '%c' got '%c'", expected, c);
char c = peek(ctx);
if (c == expected) {
consume1(ctx);
return c;
}
DIE("parse error, expected '%c' got '%c'", expected, c);
}
static void mark(Ctx *ctx)
{
ctx->mark = ctx->i;
ctx->mark = ctx->i;
}
static void backtrack(Ctx *ctx)
{
ctx->i = ctx->mark;
ctx->i = ctx->mark;
}
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)
{
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z');
return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z');
}
static bool is_symbol(char c)
{
return strchr("!$%&|*+-/:<=>?@^_~#", c) != NULL;
return strchr("!$%&|*+-/:<=>?@^_~#", c) != NULL;
}
static bool is_digit(char c)
{
return c >= '0' && c <= '9';
return c >= '0' && c <= '9';
}
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)
{
return c == '\n' || c == '\r';
return c == '\n' || c == '\r';
}
static char *parse_while(Ctx *ctx, bool (*is_valid)(char))
{
size_t n = 8;
size_t i = 0;
char *s = malloc(n);
char c;
while ((c = peek(ctx)) != PARSE_EOF && is_valid(c)) {
s[i++] = c;
consume1(ctx);
/* grow if necessary */
if (i >= n) {
n *= 2;
if (!(s = realloc(s, n))) OOM();
}
size_t n = 8;
size_t i = 0;
char *s = malloc(n);
char c;
while ((c = peek(ctx)) != PARSE_EOF && is_valid(c)) {
s[i++] = c;
consume1(ctx);
/* grow if necessary */
if (i >= n) {
n *= 2;
if (!(s = realloc(s, n))) OOM();
}
s[i] = '\0';
return s;
}
s[i] = '\0';
return s;
}
static int maybe_spaces(Ctx *ctx)
{
while (is_space(peek(ctx))) {
consume1(ctx);
}
return 1;
while (is_space(peek(ctx))) {
consume1(ctx);
}
return 1;
}
static LakeVal *parse_int(Ctx *ctx)
{
mark(ctx);
int n = 0;
char c = peek(ctx);
char sign = c == '-' ? -1 : 1;
if (c == '-' || c == '+') {
consume1(ctx);
/* if not followed by a digit it's a symbol */
if (!is_digit(peek(ctx))) {
backtrack(ctx);
return NULL;
}
mark(ctx);
int n = 0;
char c = peek(ctx);
char sign = c == '-' ? -1 : 1;
if (c == '-' || c == '+') {
consume1(ctx);
/* if not followed by a digit it's a symbol */
if (!is_digit(peek(ctx))) {
backtrack(ctx);
return NULL;
}
while (is_digit(c = peek(ctx))) {
n *= 10;
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))) {
backtrack(ctx);
return NULL;
}
return VAL(int_from_c(sign * n));
}
while (is_digit(c = peek(ctx))) {
n *= 10;
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))) {
backtrack(ctx);
return NULL;
}
return VAL(int_from_c(sign * n));
}
static LakeVal *parse_sym(Ctx *ctx)
{
LakeVal *val;
static int size = 1024;
char s[size];
char c;
int i = 0;
while (is_sym_char(c = peek(ctx)) && i < size - 1) {
s[i++] = c;
consume1(ctx);
}
s[i] = '\0';
static int size = 1024;
char s[size];
char c;
int i = 0;
while (is_sym_char(c = peek(ctx)) && i < size - 1) {
s[i++] = c;
consume1(ctx);
}
s[i] = '\0';
if (strcmp(s, "#t") == 0) {
val = VAL(ctx->lake_ctx->T);
}
@ -233,161 +233,161 @@ static LakeVal *parse_sym(Ctx *ctx)
else {
val = VAL(sym_intern(ctx->lake_ctx, s));
}
return val;
return val;
}
static char escape_char(char c)
{
switch (c) {
switch (c) {
case 'n':
c = '\n';
break;
c = '\n';
break;
case 'r':
c = '\r';
break;
c = '\r';
break;
case 't':
c = '\t';
break;
c = '\t';
break;
default:
/* noop */
break;
}
return c;
/* noop */
break;
}
return c;
}
static LakeVal *parse_str(Ctx *ctx)
{
size_t n = 8;
size_t i = 0;
char *s = malloc(n);
char c;
ch(ctx, '"');
while ((c = peek(ctx)) != PARSE_EOF && c != '"') {
/* handle backslash escapes */
if (c == '\\') {
consume1(ctx);
c = escape_char(peek(ctx));
if (c == PARSE_EOF) break;
}
s[i++] = c;
consume1(ctx);
/* grow if necessary */
if (i >= n) {
n *= 2;
if (!(s = realloc(s, n))) OOM();
}
size_t n = 8;
size_t i = 0;
char *s = malloc(n);
char c;
ch(ctx, '"');
while ((c = peek(ctx)) != PARSE_EOF && c != '"') {
/* handle backslash escapes */
if (c == '\\') {
consume1(ctx);
c = escape_char(peek(ctx));
if (c == PARSE_EOF) break;
}
s[i] = '\0';
ch(ctx, '"');
LakeStr *str = lk_str_from_c(s);
free(s);
return VAL(str);
s[i++] = c;
consume1(ctx);
/* grow if necessary */
if (i >= n) {
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)
{
LakeList *list = list_make();
ch(ctx, '(');
char c;
while ((c = peek(ctx)) != ')') {
if (c == PARSE_EOF) {
ERR("end of input while parsing list");
list_free(list);
ctx-> i = ctx->n;
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);
LakeList *list = list_make();
ch(ctx, '(');
char c;
while ((c = peek(ctx)) != ')') {
if (c == PARSE_EOF) {
ERR("end of input while parsing list");
list_free(list);
ctx-> i = ctx->n;
return NULL;
}
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)
{
ch(ctx, '\'');
LakeList *list = list_make();
list_append(list, VAL(sym_intern(ctx->lake_ctx, "quote")));
list_append(list, _parse_expr(ctx));
return VAL(list);
ch(ctx, '\'');
LakeList *list = list_make();
list_append(list, VAL(sym_intern(ctx->lake_ctx, "quote")));
list_append(list, _parse_expr(ctx));
return VAL(list);
}
static bool is_not_newline(char c)
{
return !is_newline(c);
return !is_newline(c);
}
static LakeVal *parse_comment(Ctx *ctx)
{
char *text = parse_while(ctx, is_not_newline);
LakeComment *comment = comment_from_c(text);
free(text);
return VAL(comment);
char *text = parse_while(ctx, is_not_newline);
LakeComment *comment = comment_from_c(text);
free(text);
return VAL(comment);
}
static LakeVal *_parse_expr(Ctx *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);
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)
{
LakePrimitive *prim = malloc(sizeof(LakePrimitive));
VAL(prim)->type = TYPE_PRIM;
VAL(prim)->size = sizeof(LakePrimitive);
return prim;
LakePrimitive *prim = malloc(sizeof(LakePrimitive));
VAL(prim)->type = TYPE_PRIM;
VAL(prim)->size = sizeof(LakePrimitive);
return prim;
}
LakePrimitive *prim_make(char *name, int arity, lake_prim fn)
{
LakePrimitive *prim = prim_alloc();
prim->name = strdup(name);
prim->arity = arity;
prim->fn = fn;
return prim;
LakePrimitive *prim = prim_alloc();
prim->name = strdup(name);
prim->arity = arity;
prim->fn = fn;
return prim;
}
char *prim_repr(LakePrimitive *prim)
{
size_t n = 16 + strlen(prim->name) + MAX_INT_LENGTH;
char *s = malloc(n);
snprintf(s, n, "<#primitive:%s(%d)>", prim->name, prim->arity);
return s;
size_t n = 16 + strlen(prim->name) + MAX_INT_LENGTH;
char *s = malloc(n);
snprintf(s, n, "<#primitive:%s(%d)>", prim->name, prim->arity);
return s;
}
static LakeVal *_car(LakeCtx *ctx, LakeList *args)
{
LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
return LIST_VAL(list, 0);
}
if (lk_is_type(TYPE_DLIST, list)) {
return VAL(dlist_head(DLIST(list)));
}
ERR("not a pair: %s", lake_repr(list));
return NULL;
LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
return LIST_VAL(list, 0);
}
if (lk_is_type(TYPE_DLIST, list)) {
return VAL(dlist_head(DLIST(list)));
}
ERR("not a pair: %s", lake_repr(list));
return NULL;
}
static LakeVal *_cdr(LakeCtx *ctx, LakeList *args)
{
LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
LakeList *cdr = list_copy(list);
list_shift(cdr);
return VAL(cdr);
}
if (lk_is_type(TYPE_DLIST, list)) {
return dlist_tail(DLIST(list));
}
ERR("not a pair: %s", lake_repr(list));
return NULL;
LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) {
LakeList *cdr = list_copy(list);
list_shift(cdr);
return VAL(cdr);
}
if (lk_is_type(TYPE_DLIST, list)) {
return dlist_tail(DLIST(list));
}
ERR("not a pair: %s", lake_repr(list));
return NULL;
}
static LakeVal *_cons(LakeCtx *ctx, LakeList *args)
{
LakeVal *car = LIST_VAL(args, 0);
LakeVal *cdr = LIST_VAL(args, 1);
return VAL(list_cons(car, cdr));
LakeVal *car = LIST_VAL(args, 0);
LakeVal *cdr = LIST_VAL(args, 1);
return VAL(list_cons(car, cdr));
}
static LakeVal *_nullP(LakeCtx *ctx, LakeList *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);
return VAL(is_null);
LakeVal *val = list_shift(args);
LakeBool *is_null = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) == 0);
return VAL(is_null);
}
static LakeVal *_pairP(LakeCtx *ctx, LakeList *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);
return VAL(is_pair);
LakeVal *val = list_shift(args);
LakeBool *is_pair = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) > 0);
return VAL(is_pair);
}
static LakeVal *_isP(LakeCtx *ctx, LakeList *args)
{
LakeVal *a = LIST_VAL(args, 0);
LakeVal *b = LIST_VAL(args, 1);
return VAL(lk_bool_from_int(ctx, lake_is(a, b)));
LakeVal *a = LIST_VAL(args, 0);
LakeVal *b = LIST_VAL(args, 1);
return VAL(lk_bool_from_int(ctx, lake_is(a, b)));
}
static LakeVal *_equalP(LakeCtx *ctx, LakeList *args)
{
LakeVal *a = LIST_VAL(args, 0);
LakeVal *b = LIST_VAL(args, 1);
return VAL(lk_bool_from_int(ctx, lake_equal(a, b)));
LakeVal *a = LIST_VAL(args, 0);
LakeVal *b = LIST_VAL(args, 1);
return VAL(lk_bool_from_int(ctx, lake_equal(a, b)));
}
static LakeVal *_not(LakeCtx *ctx, LakeList *args)
{
LakeVal *val = list_shift(args);
LakeBool *not = lk_bool_from_int(ctx, lk_is_false(ctx, val));
return VAL(not);
LakeVal *val = list_shift(args);
LakeBool *not = lk_bool_from_int(ctx, lk_is_false(ctx, val));
return VAL(not);
}
#define ENSURE_INT(x, i) do { \
if (!lk_is_type(TYPE_INT, x)) { \
ERR("argument %zu is not an integer: %s", i, lake_repr(x)); \
return NULL; \
} \
} while (0)
if (!lk_is_type(TYPE_INT, x)) { \
ERR("argument %zu is not an integer: %s", i, lake_repr(x)); \
return NULL; \
} \
} while (0)
static LakeVal *_add(LakeCtx *ctx, LakeList *args)
{
int result = 0;
size_t n = LIST_N(args);
size_t i;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
result += INT_VAL(INT(v));
}
return VAL(int_from_c(result));
int result = 0;
size_t n = LIST_N(args);
size_t i;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
result += INT_VAL(INT(v));
}
return VAL(int_from_c(result));
}
static LakeVal *_sub(LakeCtx *ctx, LakeList *args)
{
size_t n = LIST_N(args);
if (n < 1) {
ERR("- requires at least one argument");
return NULL;
}
int result = 0;
size_t i;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
result -= INT_VAL(INT(v));
}
return VAL(int_from_c(result));
size_t n = LIST_N(args);
if (n < 1) {
ERR("- requires at least one argument");
return NULL;
}
int result = 0;
size_t i;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
result -= INT_VAL(INT(v));
}
return VAL(int_from_c(result));
}
static LakeVal *_mul(LakeCtx *ctx, LakeList *args)
{
int result = 1;
size_t n = LIST_N(args);
size_t i;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
result *= INT_VAL(INT(v));
}
return VAL(int_from_c(result));
int result = 1;
size_t n = LIST_N(args);
size_t i;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
result *= INT_VAL(INT(v));
}
return VAL(int_from_c(result));
}
#define DIVIDE_BY_ZERO() ERR("divide by zero")
static LakeVal *_div(LakeCtx *ctx, LakeList *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));
size_t n = LIST_N(args);
if (n == 1) {
if (result == 0) {
DIVIDE_BY_ZERO();
return NULL;
}
result = 1 / result;
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 (result == 0) {
DIVIDE_BY_ZERO();
return NULL;
}
else {
size_t i;
for (i = 1; i < n; ++i) {
v = LIST_VAL(args, i);
ENSURE_INT(v, i);
int val = INT_VAL(INT(v));
if (val == 0) {
DIVIDE_BY_ZERO();
return NULL;
}
result /= val;
}
result = 1 / result;
}
else {
size_t i;
for (i = 1; i < n; ++i) {
v = LIST_VAL(args, i);
ENSURE_INT(v, i);
int val = INT_VAL(INT(v));
if (val == 0) {
DIVIDE_BY_ZERO();
return NULL;
}
result /= val;
}
return VAL(int_from_c(result));
}
return VAL(int_from_c(result));
}
static LakeVal *_int_eq(LakeCtx *ctx, LakeList *args)
{
bool result = TRUE;
size_t n = LIST_N(args);
size_t i;
int curr, prev;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
curr = INT_VAL(INT(v));
if (i > 0) {
result = result && curr == prev;
}
prev = INT_VAL(INT(v));
bool result = TRUE;
size_t n = LIST_N(args);
size_t i;
int curr, prev;
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
curr = INT_VAL(INT(v));
if (i > 0) {
result = result && curr == prev;
}
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)
{
bool result = TRUE;
size_t n = LIST_N(args);
size_t i;
int curr, prev;
bool result = TRUE;
size_t n = LIST_N(args);
size_t i;
int curr, prev;
if (n > 1) {
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
curr = INT_VAL(INT(v));
if (i > 0) {
result = result && prev < curr;
}
prev = INT_VAL(INT(v));
}
if (n > 1) {
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
curr = INT_VAL(INT(v));
if (i > 0) {
result = result && prev < curr;
}
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)
{
bool result = TRUE;
size_t n = LIST_N(args);
size_t i;
int curr, prev;
bool result = TRUE;
size_t n = LIST_N(args);
size_t i;
int curr, prev;
if (n > 1) {
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
curr = INT_VAL(INT(v));
if (i > 0) {
result = result && prev > curr;
}
prev = INT_VAL(INT(v));
}
if (n > 1) {
for (i = 0; i < n; ++i) {
LakeVal *v = LIST_VAL(args, i);
ENSURE_INT(v, i);
curr = INT_VAL(INT(v));
if (i > 0) {
result = result && prev > curr;
}
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)
{
LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list)) {
LakeVal *new_car = LIST_VAL(args, 1);
if (LIST_N(list) == 0) {
list_append(list, new_car);
}
else {
list_set(list, 0, new_car);
}
return VAL(list);
LakeList *list = LIST(LIST_VAL(args, 0));
if (lk_is_type(TYPE_LIST, list)) {
LakeVal *new_car = LIST_VAL(args, 1);
if (LIST_N(list) == 0) {
list_append(list, new_car);
}
ERR("not a pair: %s", lake_repr(list));
return NULL;
else {
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)
{
size_t n = LIST_N(args);
size_t i;
int space = 0;
for (i = 0; i < n; ++i) {
if (space) putchar(' ');
printf("%s", lake_repr(LIST_VAL(args, i)));
space = 1;
}
putchar('\n');
return NULL;
size_t n = LIST_N(args);
size_t i;
int space = 0;
for (i = 0; i < n; ++i) {
if (space) putchar(' ');
printf("%s", lake_repr(LIST_VAL(args, i)));
space = 1;
}
putchar('\n');
return NULL;
}
#define DEFINE_PREDICATE(name, type) \
static LakeVal *_## name ##P(LakeCtx *ctx, LakeList *args) \
{ \
return VAL(lk_bool_from_int(ctx, lk_is_type(type, LIST_VAL(args, 0)))); \
}
static LakeVal *_## name ##P(LakeCtx *ctx, LakeList *args) \
{ \
return VAL(lk_bool_from_int(ctx, lk_is_type(type, LIST_VAL(args, 0)))); \
}
DEFINE_PREDICATE(symbol, TYPE_SYM)
DEFINE_PREDICATE(list, TYPE_LIST)
@ -317,44 +317,44 @@ DEFINE_PREDICATE(primitive, TYPE_PRIM)
void bind_primitives(LakeCtx *ctx)
{
#define DEFINE(name, fn, arity) env_define(ctx->toplevel, \
sym_intern(ctx, name), \
VAL(prim_make(name, arity, fn)))
#define DEFINE(name, fn, arity) env_define(ctx->toplevel, \
sym_intern(ctx, name), \
VAL(prim_make(name, arity, fn)))
DEFINE("car", _car, 1);
DEFINE("cdr", _cdr, 1);
DEFINE("cons", _cons, 2);
DEFINE("null?", _nullP, 1);
DEFINE("pair?", _pairP, 1);
DEFINE("is?", _isP, 2);
DEFINE("equal?", _equalP, 2);
DEFINE("not", _not, 1);
DEFINE("+", _add, ARITY_VARARGS);
DEFINE("-", _sub, ARITY_VARARGS);
DEFINE("*", _mul, ARITY_VARARGS);
DEFINE("/", _div, ARITY_VARARGS);
DEFINE("=", _int_eq, ARITY_VARARGS);
DEFINE("<", _int_lt, ARITY_VARARGS);
DEFINE(">", _int_gt, ARITY_VARARGS);
DEFINE("set-car!", _set_carB, 2);
DEFINE("car", _car, 1);
DEFINE("cdr", _cdr, 1);
DEFINE("cons", _cons, 2);
DEFINE("null?", _nullP, 1);
DEFINE("pair?", _pairP, 1);
DEFINE("is?", _isP, 2);
DEFINE("equal?", _equalP, 2);
DEFINE("not", _not, 1);
DEFINE("+", _add, ARITY_VARARGS);
DEFINE("-", _sub, ARITY_VARARGS);
DEFINE("*", _mul, ARITY_VARARGS);
DEFINE("/", _div, ARITY_VARARGS);
DEFINE("=", _int_eq, ARITY_VARARGS);
DEFINE("<", _int_lt, ARITY_VARARGS);
DEFINE(">", _int_gt, ARITY_VARARGS);
DEFINE("set-car!", _set_carB, 2);
DEFINE("display", _display, ARITY_VARARGS);
DEFINE("display", _display, ARITY_VARARGS);
DEFINE("symbol?", _symbolP, 1);
DEFINE("list?", _listP, 1);
DEFINE("dotted-list?", _dotted_listP, 1);
DEFINE("number?", _numberP, 1);
DEFINE("integer?", _integerP, 1);
DEFINE("string?", _stringP, 1);
DEFINE("bool?", _boolP, 1);
DEFINE("function?", _functionP, 1);
DEFINE("primitive?", _primitiveP, 1);
DEFINE("symbol?", _symbolP, 1);
DEFINE("list?", _listP, 1);
DEFINE("dotted-list?", _dotted_listP, 1);
DEFINE("number?", _numberP, 1);
DEFINE("integer?", _integerP, 1);
DEFINE("string?", _stringP, 1);
DEFINE("bool?", _boolP, 1);
DEFINE("function?", _functionP, 1);
DEFINE("primitive?", _primitiveP, 1);
/* string=? */
/* string< */
/* string> */
/* string-concatenate */
/* string-slice */
/* string=? */
/* string< */
/* string> */
/* string-concatenate */
/* string-slice */
#undef DEFINE
#undef DEFINE
}

204
src/repl.c
View file

@ -24,143 +24,143 @@
void print(LakeVal *expr)
{
printf("%s\n", lake_repr(expr));
printf("%s\n", lake_repr(expr));
}
static char first_char(char *s)
{
char c;
while ((c = *s++) && (c == ' ' || c == '\n' || c == '\t'));
return c;
char c;
while ((c = *s++) && (c == ' ' || c == '\n' || c == '\t'));
return c;
}
static LakeVal *prompt_read(LakeCtx *ctx, Env *env, char *prompt)
{
static int n = 1024;
printf("%s", prompt);
char buf[n];
if (!fgets(buf, n, stdin)) {
if (ferror(stdin)) {
fprintf(stderr, "error: cannot read from stdin");
}
if (feof(stdin)) {
return VAL(EOF);
}
return NULL;
static int n = 1024;
printf("%s", prompt);
char buf[n];
if (!fgets(buf, n, stdin)) {
if (ferror(stdin)) {
fprintf(stderr, "error: cannot read from stdin");
}
if (feof(stdin)) {
return VAL(EOF);
}
return NULL;
}
/* trim the newline if any */
buf[strcspn(buf, "\n")] = '\0';
/* parse list expressions */
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
(makes the repl more palatable) */
/* try to parse a naked call without parens
(makes the repl more palatable) */
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 */
LakeVal *head;
if (is_special_form(ctx, list) ||
(LIST_N(list) > 1 && (head = eval(ctx, env, LIST_VAL(list, 0))) && CALLABLE(head))) {
result = VAL(list);
}
/* naked call */
LakeVal *head;
if (is_special_form(ctx, list) ||
(LIST_N(list) > 1 && (head = eval(ctx, env, LIST_VAL(list, 0))) && CALLABLE(head))) {
result = VAL(list);
}
/* probably not function calls, just give the first expr
(maybe do an implicit progn thing here) */
else {
result = LIST_VAL(list, 0);
}
/* probably not function calls, just give the first expr
(maybe do an implicit progn thing here) */
else {
result = LIST_VAL(list, 0);
}
return result;
return result;
}
static void run_repl(LakeCtx *ctx, Env *env)
{
puts("Lake Scheme v" LAKE_VERSION);
LakeVal *expr;
LakeVal *result;
for (;;) {
expr = prompt_read(ctx, env, "> ");
if (expr == VAL(EOF)) break;
if (expr == VAL(PARSE_ERR)) {
ERR("parse error");
continue;
}
if (expr) {
result = eval(ctx, env, expr);
if (result) print(result);
}
puts("Lake Scheme v" LAKE_VERSION);
LakeVal *expr;
LakeVal *result;
for (;;) {
expr = prompt_read(ctx, env, "> ");
if (expr == VAL(EOF)) break;
if (expr == VAL(PARSE_ERR)) {
ERR("parse error");
continue;
}
if (expr) {
result = eval(ctx, env, expr);
if (result) print(result);
}
}
}
static char *read_file(char const *filename)
{
FILE *fp = fopen(filename, "r");
if (fp) {
size_t size = 4096;
char buf[size];
size_t n = size;
size_t i = 0;
size_t read;
char *s = malloc(n);
while (!feof(fp) && !ferror(fp)) {
read = fread(buf, 1, size, fp);
if (i + read > n) {
n += size;
if (!(s = realloc(s, n))) OOM();
}
memcpy(s + i, buf, 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;
FILE *fp = fopen(filename, "r");
if (fp) {
size_t size = 4096;
char buf[size];
size_t n = size;
size_t i = 0;
size_t read;
char *s = malloc(n);
while (!feof(fp) && !ferror(fp)) {
read = fread(buf, 1, size, fp);
if (i + read > n) {
n += size;
if (!(s = realloc(s, n))) OOM();
}
memcpy(s + i, buf, read);
i += read;
}
else {
ERR("cannot open file %s: %s", filename, strerror(errno));
return NULL;
s[i] = '\0';
if (ferror(fp)) {
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[])
{
/* create an execution context */
LakeCtx *ctx = lake_init();
/* create an execution context */
LakeCtx *ctx = lake_init();
/* create and bind args */
LakeVal **argVals = malloc(argc * sizeof(LakeVal *));
int i;
for (i = 0; i < argc; ++i) {
argVals[i] = VAL(lk_str_from_c((char *)argv[i]));
/* create and bind args */
LakeVal **argVals = malloc(argc * sizeof(LakeVal *));
int i;
for (i = 0; i < argc; ++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));
/* 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);
}
}
}
/* run the repl */
run_repl(ctx, ctx->toplevel);
return 0;
}
/* 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)
{
LakeStr *str = malloc(sizeof(LakeStr));
VAL(str)->type = TYPE_STR;
VAL(str)->size = sizeof(LakeStr);
return str;
LakeStr *str = malloc(sizeof(LakeStr));
VAL(str)->type = TYPE_STR;
VAL(str)->size = sizeof(LakeStr);
return str;
}
void lk_str_free(LakeStr *str)
{
free(STR_S(str));
free(str);
free(STR_S(str));
free(str);
}
static LakeVal *lk_str_set(LakeStr *str, char *s)
{
STR_N(str) = strlen(s);
STR_S(str) = strndup(s, STR_N(str));
return NULL;
STR_N(str) = strlen(s);
STR_S(str) = strndup(s, STR_N(str));
return NULL;
}
LakeStr *lk_str_from_c(char *s)
{
LakeStr *str = lk_str_alloc();
lk_str_set(str, s);
return str;
LakeStr *str = lk_str_alloc();
lk_str_set(str, s);
return str;
}
LakeStr *lk_str_make(void)
{
return lk_str_from_c("");
return lk_str_from_c("");
}
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)
{
return lk_str_from_c(STR_S(str));
return lk_str_from_c(STR_S(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)
{
if (STR_N(a) != STR_N(b)) return FALSE;
size_t n = MIN(STR_N(a), STR_N(b));
return strncmp(STR_S(a), STR_S(b), n) == 0;
if (STR_N(a) != STR_N(b)) return FALSE;
size_t n = MIN(STR_N(a), STR_N(b));
return strncmp(STR_S(a), STR_S(b), n) == 0;
}
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)
{
LakeSym *sym = malloc(sizeof(LakeSym));
VAL(sym)->type = TYPE_SYM;
VAL(sym)->size = sizeof(LakeSym);
return sym;
LakeSym *sym = malloc(sizeof(LakeSym));
VAL(sym)->type = TYPE_SYM;
VAL(sym)->size = sizeof(LakeSym);
return sym;
}
LakeSym *sym_intern(LakeCtx *ctx, char *s)
{
LakeSym *sym = lk_hash_get(ctx->symbols, s);
if (!sym) {
sym = sym_alloc();
sym->n = strlen(s);
sym->s = strndup(s, sym->n);
sym->hash = str_hash(s);
lk_hash_put(ctx->symbols, sym->s, sym);
LakeSym *sym = lk_hash_get(ctx->symbols, s);
if (!sym) {
sym = sym_alloc();
sym->n = strlen(s);
sym->s = strndup(s, sym->n);
sym->hash = str_hash(s);
lk_hash_put(ctx->symbols, sym->s, sym);
}
return sym;
return 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)
{
return sym_intern(ctx, str->s);
return sym_intern(ctx, str->s);
}
char *sym_repr(LakeSym *sym)
{
return strndup(sym->s, sym->n);
return strndup(sym->s, sym->n);
}
unsigned long sym_val(LakeSym *sym)
{
return sym->hash;
return sym->hash;
}