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

Use clang-format to enforce code style

Browse source
This commit is contained in:
Sami Samhuri 2022-02-21 19:29:17 -08:00
parent f0bd86b61c
commit 001478f7e8
No known key found for this signature in database
GPG key ID: 4B4195422742FC16
49 changed files with 2320 additions and 2167 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
.clang-format Normal file
View file

@ -0,0 +1,13 @@
{
BasedOnStyle: LLVM,
UseTab: Never,
IndentWidth: 4,
TabWidth: 4,
BreakBeforeBraces: Allman,
AllowShortIfStatementsOnASingleLine: true,
IndentCaseLabels: false,
ColumnLimit: 80,
AccessModifierOffset: -4,
NamespaceIndentation: All,
FixNamespaceComments: false,
}

5
Makefile
View file

@ -18,4 +18,7 @@ test:
test_clean: test_clean:
cd test && make clean cd test && make clean
.PHONY: all clean test test_clean format:
script/clang-format
.PHONY: all clean test test_clean format

7
script/clang-format Executable file
View file

@ -0,0 +1,7 @@
#!/usr/bin/env zsh
set -euo pipefail
for file in src/**/*.[ch] test/**/*.[ch]; do
clang-format -i "$file"
done

27
src/bool.c
View file

@ -7,35 +7,20 @@
* *
*/ */
#include <string.h>
#include "bool.h" #include "bool.h"
#include "common.h" #include "common.h"
#include "lake.h" #include "lake.h"
#include <string.h>
bool lake_bool_val(LakeBool *b) bool lake_bool_val(LakeBool *b) { return b->val; }
{
return b->val;
}
bool lake_is_true(LakeCtx *ctx, LakeVal *x) bool lake_is_true(LakeCtx *ctx, LakeVal *x) { return VAL(x) == VAL(ctx->T); }
{
return VAL(x) == VAL(ctx->T);
}
bool lake_is_false(LakeCtx *ctx, LakeVal *x) bool lake_is_false(LakeCtx *ctx, LakeVal *x) { return VAL(x) == VAL(ctx->F); }
{
return VAL(x) == VAL(ctx->F);
}
bool lake_is_truthy(LakeCtx *ctx, LakeVal *x) bool lake_is_truthy(LakeCtx *ctx, LakeVal *x) { return !lake_is_false(ctx, x); }
{
return !lake_is_false(ctx, x);
}
bool lake_is_falsy(LakeCtx *ctx, LakeVal *x) bool lake_is_falsy(LakeCtx *ctx, LakeVal *x) { return lake_is_false(ctx, x); }
{
return lake_is_false(ctx, x);
}
LakeBool *lake_bool_from_int(LakeCtx *ctx, int n) LakeBool *lake_bool_from_int(LakeCtx *ctx, int n)
{ {

4
src/comment.c
View file

@ -7,11 +7,11 @@
* *
*/ */
#include <string.h>
#include "common.h"
#include "comment.h" #include "comment.h"
#include "common.h"
#include "lake.h" #include "lake.h"
#include "str.h" #include "str.h"
#include <string.h>
static LakeComment *comment_alloc(void) static LakeComment *comment_alloc(void)
{ {

4
src/common.c
View file

@ -8,9 +8,9 @@
*/ */
#include <stddef.h> #include <stddef.h>
#include <string.h>
#include <stdlib.h>
#include <stdio.h> #include <stdio.h>
#include <stdlib.h>
#include <string.h>
char *lake_str_append(char *s1, char *s2) char *lake_str_append(char *s1, char *s2)
{ {

19
src/dlist.c
View file

@ -27,15 +27,9 @@ LakeDottedList *dlist_make(LakeList *head, LakeVal *tail)
return dlist; return dlist;
} }
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)
{ {
@ -44,15 +38,18 @@ char *dlist_repr(LakeDottedList *dlist)
s[1] = '\0'; s[1] = '\0';
int i; int i;
char *s2; char *s2;
if (dlist->head && LIST_N(dlist->head)) { if (dlist->head && LIST_N(dlist->head))
for (i = 0; i < LIST_N(dlist->head); ++i) { {
for (i = 0; i < LIST_N(dlist->head); ++i)
{
s2 = lake_repr(LIST_VAL(dlist->head, i)); s2 = lake_repr(LIST_VAL(dlist->head, i));
s = lake_str_append(s, s2); s = lake_str_append(s, s2);
free(s2); free(s2);
if (i != LIST_N(dlist->head) - 1) s = lake_str_append(s, " "); if (i != LIST_N(dlist->head) - 1) s = lake_str_append(s, " ");
} }
} }
else if (dlist->head) { else if (dlist->head)
{
s2 = lake_repr(dlist->head); s2 = lake_repr(dlist->head);
s = lake_str_append(s, s2); s = lake_str_append(s, s2);
free(s2); free(s2);

12
src/env.c
View file

@ -7,12 +7,12 @@
* *
*/ */
#include <stdio.h> #include "env.h"
#include <stdlib.h>
#include "common.h" #include "common.h"
#include "hash.h" #include "hash.h"
#include "lake.h" #include "lake.h"
#include "env.h" #include <stdio.h>
#include <stdlib.h>
Env *env_make(Env *parent) Env *env_make(Env *parent)
{ {
@ -42,7 +42,8 @@ LakeVal *env_define(Env *env, LakeSym *key, LakeVal *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);
@ -52,7 +53,8 @@ LakeVal *env_set(Env *env, LakeSym *key, LakeVal *val)
LakeVal *env_get(Env *env, LakeSym *key) LakeVal *env_get(Env *env, LakeSym *key)
{ {
LakeVal *val = lake_hash_get(env->bindings, key->s); LakeVal *val = lake_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;

3
src/env.h
View file

@ -13,7 +13,8 @@
#include "common.h" #include "common.h"
#include "hash.h" #include "hash.h"
struct env { struct env
{
struct env *parent; struct env *parent;
lake_hash_t *bindings; lake_hash_t *bindings;
}; };

170
src/eval.c
View file

@ -7,18 +7,19 @@
* *
*/ */
#include <stdlib.h> #include "eval.h"
#include <stdio.h>
#include <string.h>
#include "bool.h" #include "bool.h"
#include "common.h" #include "common.h"
#include "env.h" #include "env.h"
#include "eval.h"
#include "fn.h" #include "fn.h"
#include "lake.h" #include "lake.h"
#include "parse.h" #include "parse.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
typedef LakeVal *(*special_form_handler)(LakeCtx *ctx, Env *env, LakeList *expr); 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)
{ {
@ -28,7 +29,8 @@ static void invalid_special_form(LakeList *expr, char *detail)
/* 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");
@ -41,8 +43,10 @@ static LakeVal *_and(LakeCtx *ctx, Env *env, LakeList *expr)
list_shift(expr); list_shift(expr);
/* (and ...) */ /* (and ...) */
LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->T); LakeVal *result =
while (lake_is_truthy(ctx, result) && LIST_N(expr) > 0) { LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->T);
while (lake_is_truthy(ctx, result) && LIST_N(expr) > 0)
{
result = lake_bool_and(ctx, result, eval(ctx, env, list_shift(expr))); result = lake_bool_and(ctx, result, eval(ctx, env, list_shift(expr)));
} }
return result; return result;
@ -54,8 +58,10 @@ static LakeVal *_or(LakeCtx *ctx, Env *env, LakeList *expr)
list_shift(expr); list_shift(expr);
/* (or ...) */ /* (or ...) */
LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->F); LakeVal *result =
while (lake_is_falsy(ctx, result) && LIST_N(expr) > 0) { LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->F);
while (lake_is_falsy(ctx, result) && LIST_N(expr) > 0)
{
result = lake_bool_or(ctx, result, eval(ctx, env, list_shift(expr))); result = lake_bool_or(ctx, result, eval(ctx, env, list_shift(expr)));
} }
return result; return result;
@ -64,15 +70,18 @@ static LakeVal *_or(LakeCtx *ctx, Env *env, LakeList *expr)
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 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { if (LIST_N(expr) == 3 && lake_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 { else
{
invalid_special_form(expr, "set! requires exactly 2 parameters"); invalid_special_form(expr, "set! requires exactly 2 parameters");
} }
return NULL; return NULL;
@ -83,7 +92,8 @@ 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 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { if (LIST_N(expr) == 3 && lake_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);
@ -91,7 +101,8 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr)
} }
/* (define (inc x) (+ 1 x)) */ /* (define (inc x) (+ 1 x)) */
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lake_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));
@ -100,7 +111,8 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr)
} }
/* (define (print format . args) (...)) */ /* (define (print format . args) (...)) */
else if (LIST_N(expr) >= 3 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lake_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);
@ -110,7 +122,8 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *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");
} }
@ -120,13 +133,15 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr)
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 && lake_is_type(TYPE_LIST, LIST_VAL(expr, 1))) { if (LIST_N(expr) >= 3 && lake_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 && lake_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lake_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);
@ -134,13 +149,15 @@ static LakeVal *_lambda(LakeCtx *ctx, Env *env, LakeList *expr)
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 && lake_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { else if (LIST_N(expr) >= 3 && lake_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;
} }
@ -148,16 +165,19 @@ static LakeVal *_lambda(LakeCtx *ctx, Env *env, LakeList *expr)
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 (lake_is_truthy(ctx, cond)) { if (lake_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));
} }
} }
@ -170,14 +190,18 @@ static LakeVal *_cond(LakeCtx *ctx, Env *env, LakeList *expr)
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 (!lake_is_type(TYPE_LIST, LIST_VAL(expr, 0))) { {
invalid_special_form(expr, "expected a (predicate consequence) pair"); if (!lake_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)); conseq = LIST(list_shift(expr));
pred = list_shift(conseq); pred = list_shift(conseq);
if (pred == ELSE || lake_is_truthy(ctx, eval(ctx, env, pred))) { if (pred == ELSE || lake_is_truthy(ctx, eval(ctx, env, pred)))
{
return eval_exprs1(ctx, env, conseq); return eval_exprs1(ctx, env, conseq);
} }
} }
@ -186,7 +210,8 @@ static LakeVal *_cond(LakeCtx *ctx, Env *env, LakeList *expr)
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;
} }
@ -226,16 +251,19 @@ bool is_special_form(LakeCtx *ctx, LakeList *expr)
return lake_hash_has(ctx->special_form_handlers, SYM(head)->s); return lake_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)lake_hash_get(ctx->special_form_handlers, name->s); return (special_form_handler)lake_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));
@ -252,7 +280,8 @@ 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:
@ -263,7 +292,8 @@ LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr)
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;
@ -280,27 +310,35 @@ LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr)
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 { else
if (is_special_form(ctx, list)) { {
if (is_special_form(ctx, list))
{
result = eval_special_form(ctx, env, list); result = eval_special_form(ctx, env, list);
} }
else { else
{
LakeVal *fn = eval(ctx, env, LIST_VAL(list, 0)); LakeVal *fn = eval(ctx, env, LIST_VAL(list, 0));
if (!fn) { if (!fn)
{
return NULL; return NULL;
} }
LakeList *args = list_make_with_capacity(LIST_N(list) - 1); LakeList *args = list_make_with_capacity(LIST_N(list) - 1);
int i; int i;
LakeVal *v; LakeVal *v;
for (i = 1; i < LIST_N(list); ++i) { for (i = 1; i < LIST_N(list); ++i)
{
v = eval(ctx, env, LIST_VAL(list, i)); v = eval(ctx, env, LIST_VAL(list, i));
if (v != NULL) { if (v != NULL)
{
list_append(args, v); list_append(args, v);
} }
else { else
{
list_free(args); list_free(args);
result = NULL; result = NULL;
goto done; goto done;
@ -312,18 +350,21 @@ LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr)
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;
@ -340,28 +381,36 @@ LakeVal *eval_exprs1(LakeCtx *ctx, Env *env, LakeList *exprs)
LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args) LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args)
{ {
LakeVal *result = NULL; LakeVal *result = NULL;
if (lake_is_type(TYPE_PRIM, fnVal)) { if (lake_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 { else
ERR("%s expects %d params but got %zu", prim->name, arity, LIST_N(args)); {
ERR("%s expects %d params but got %zu", prim->name, arity,
LIST_N(args));
result = NULL; result = NULL;
} }
} }
else if (lake_is_type(TYPE_FN, fnVal)) { else if (lake_is_type(TYPE_FN, fnVal))
{
LakeFn *fn = FN(fnVal); LakeFn *fn = FN(fnVal);
/* Check # of params */ /* Check # of params */
size_t nparams = LIST_N(fn->params); size_t nparams = LIST_N(fn->params);
if (!fn->varargs && LIST_N(args) != nparams) { if (!fn->varargs && LIST_N(args) != nparams)
{
ERR("expected %zu params but got %zu", nparams, LIST_N(args)); ERR("expected %zu params but got %zu", nparams, LIST_N(args));
return NULL; return NULL;
} }
else if (fn->varargs && LIST_N(args) < nparams) { else if (fn->varargs && LIST_N(args) < nparams)
ERR("expected at least %zu params but got %zu", nparams, LIST_N(args)); {
ERR("expected at least %zu params but got %zu", nparams,
LIST_N(args));
return NULL; return NULL;
} }
@ -369,14 +418,18 @@ LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args)
/* bind each (param,arg) pair in env */ /* bind each (param,arg) pair in env */
size_t i; size_t i;
for (i = 0; i < nparams; ++i) { for (i = 0; i < nparams; ++i)
{
env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i)); env_define(env, SYM(LIST_VAL(fn->params, i)), LIST_VAL(args, i));
} }
/* bind varargs */ /* bind varargs */
if (fn->varargs) { if (fn->varargs)
LakeList *remainingArgs = list_make_with_capacity(LIST_N(args) - nparams); {
for (; i < LIST_N(args); ++i) { LakeList *remainingArgs =
list_make_with_capacity(LIST_N(args) - nparams);
for (; i < LIST_N(args); ++i)
{
list_append(remainingArgs, LIST_VAL(args, i)); list_append(remainingArgs, LIST_VAL(args, i));
} }
env_define(env, fn->varargs, VAL(remainingArgs)); env_define(env, fn->varargs, VAL(remainingArgs));
@ -385,7 +438,8 @@ LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args)
/* evaluate body */ /* evaluate body */
result = eval_exprs1(ctx, env, fn->body); result = eval_exprs1(ctx, env, fn->body);
} }
else { else
{
ERR("not a function: %s", lake_repr(fnVal)); ERR("not a function: %s", lake_repr(fnVal));
} }
return result; return result;

19
src/fn.c
View file

@ -7,11 +7,11 @@
* *
*/ */
#include <stdlib.h> #include "fn.h"
#include "common.h" #include "common.h"
#include "env.h" #include "env.h"
#include "fn.h"
#include "lake.h" #include "lake.h"
#include <stdlib.h>
static LakeFn *fn_alloc(void) static LakeFn *fn_alloc(void)
{ {
@ -21,7 +21,8 @@ static LakeFn *fn_alloc(void)
return fn; return fn;
} }
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;
@ -37,25 +38,29 @@ char *fn_repr(LakeFn *fn)
s[0] = '\0'; s[0] = '\0';
s = lake_str_append(s, "(lambda "); s = lake_str_append(s, "(lambda ");
char *s2; char *s2;
if (LIST_N(fn->params) && fn->varargs) { if (LIST_N(fn->params) && fn->varargs)
{
LakeDottedList *params = dlist_make(fn->params, VAL(fn->varargs)); LakeDottedList *params = dlist_make(fn->params, VAL(fn->varargs));
s2 = dlist_repr(params); s2 = dlist_repr(params);
s = lake_str_append(s, s2); s = lake_str_append(s, s2);
free(s2); free(s2);
} }
else if (fn->varargs) { else if (fn->varargs)
{
s2 = lake_repr(fn->varargs); s2 = lake_repr(fn->varargs);
s = lake_str_append(s, s2); s = lake_str_append(s, s2);
free(s2); free(s2);
} }
else { else
{
s2 = lake_repr(fn->params); s2 = lake_repr(fn->params);
s = lake_str_append(s, s2); s = lake_str_append(s, s2);
free(s2); free(s2);
} }
s = lake_str_append(s, " "); s = lake_str_append(s, " ");
int i; int i;
for (i = 0; i < LIST_N(fn->body); ++i) { for (i = 0; i < LIST_N(fn->body); ++i)
{
s2 = lake_repr(LIST_VAL(fn->body, i)); s2 = lake_repr(LIST_VAL(fn->body, i));
s = lake_str_append(s, s2); s = lake_str_append(s, s2);
free(s2); free(s2);

3
src/fn.h
View file

@ -13,7 +13,8 @@
#include "env.h" #include "env.h"
#include "lake.h" #include "lake.h"
LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env *closure); LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body,
Env *closure);
char *fn_repr(LakeFn *fn); char *fn_repr(LakeFn *fn);
#endif #endif

9
src/hash.c
View file

@ -12,18 +12,21 @@
#include "hash.h" #include "hash.h"
void lake_hash_put(khash_t(value) *h, char *key, void *val) { void lake_hash_put(khash_t(value) * h, char *key, void *val)
{
int ret; int ret;
khiter_t k = kh_put(value, h, key, &ret); khiter_t k = kh_put(value, h, key, &ret);
kh_value(h, k) = val; kh_value(h, k) = val;
} }
void *lake_hash_get(khash_t(value) *h, char *key) { void *lake_hash_get(khash_t(value) * h, char *key)
{
khiter_t k = kh_get(value, h, key); khiter_t k = kh_get(value, h, key);
return k == kh_end(h) ? NULL : kh_value(h, k); return k == kh_end(h) ? NULL : kh_value(h, k);
} }
bool lake_hash_has(khash_t(value) *h, char *key) { bool lake_hash_has(khash_t(value) * h, char *key)
{
khiter_t k = kh_get(value, h, key); khiter_t k = kh_get(value, h, key);
return kh_exist(h, k); return kh_exist(h, k);
} }

8
src/hash.h
View file

@ -13,8 +13,8 @@
#ifndef _LAKE_HASH_H #ifndef _LAKE_HASH_H
#define _LAKE_HASH_H #define _LAKE_HASH_H
#include "khash.h"
#include "common.h" #include "common.h"
#include "khash.h"
KHASH_MAP_INIT_STR(value, void *); KHASH_MAP_INIT_STR(value, void *);
@ -23,8 +23,8 @@ typedef khash_t(value) lake_hash_t;
#define lake_hash_make() kh_init(value) #define lake_hash_make() kh_init(value)
#define lake_hash_free(h) kh_destroy(value, h) #define lake_hash_free(h) kh_destroy(value, h)
bool lake_hash_has(khash_t(value) *h, char *key); bool lake_hash_has(khash_t(value) * h, char *key);
void lake_hash_put(khash_t(value) *h, char *key, void *val); void lake_hash_put(khash_t(value) * h, char *key, void *val);
void *lake_hash_get(khash_t(value) *h, char *key); void *lake_hash_get(khash_t(value) * h, char *key);
#endif #endif

9
src/int.c
View file

@ -7,11 +7,11 @@
* *
*/ */
#include <stdlib.h>
#include "common.h"
#include "int.h" #include "int.h"
#include "common.h"
#include "lake.h" #include "lake.h"
#include "str.h" #include "str.h"
#include <stdlib.h>
static LakeInt *int_alloc(void) static LakeInt *int_alloc(void)
{ {
@ -21,10 +21,7 @@ static LakeInt *int_alloc(void)
return i; return i;
} }
LakeInt *int_make(void) LakeInt *int_make(void) { return int_from_c(0); }
{
return int_from_c(0);
}
LakeInt *int_from_c(int n) LakeInt *int_from_c(int n)
{ {

234
src/khash.h
View file

@ -97,7 +97,6 @@ int main() {
* Added destructor * Added destructor
*/ */
#ifndef __AC_KHASH_H #ifndef __AC_KHASH_H
#define __AC_KHASH_H #define __AC_KHASH_H
@ -109,9 +108,9 @@ int main() {
#define AC_VERSION_KHASH_H "0.2.6" #define AC_VERSION_KHASH_H "0.2.6"
#include <limits.h>
#include <stdlib.h> #include <stdlib.h>
#include <string.h> #include <string.h>
#include <limits.h>
/* compipler specific configuration */ /* compipler specific configuration */
@ -134,30 +133,36 @@ typedef unsigned long long khint64_t;
typedef khint32_t khint_t; typedef khint32_t khint_t;
typedef khint_t khiter_t; typedef khint_t khiter_t;
#define __ac_isempty(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&2) #define __ac_isempty(flag, i) ((flag[i >> 4] >> ((i & 0xfU) << 1)) & 2)
#define __ac_isdel(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&1) #define __ac_isdel(flag, i) ((flag[i >> 4] >> ((i & 0xfU) << 1)) & 1)
#define __ac_iseither(flag, i) ((flag[i>>4]>>((i&0xfU)<<1))&3) #define __ac_iseither(flag, i) ((flag[i >> 4] >> ((i & 0xfU) << 1)) & 3)
#define __ac_set_isdel_false(flag, i) (flag[i>>4]&=~(1ul<<((i&0xfU)<<1))) #define __ac_set_isdel_false(flag, i) \
#define __ac_set_isempty_false(flag, i) (flag[i>>4]&=~(2ul<<((i&0xfU)<<1))) (flag[i >> 4] &= ~(1ul << ((i & 0xfU) << 1)))
#define __ac_set_isboth_false(flag, i) (flag[i>>4]&=~(3ul<<((i&0xfU)<<1))) #define __ac_set_isempty_false(flag, i) \
#define __ac_set_isdel_true(flag, i) (flag[i>>4]|=1ul<<((i&0xfU)<<1)) (flag[i >> 4] &= ~(2ul << ((i & 0xfU) << 1)))
#define __ac_set_isboth_false(flag, i) \
(flag[i >> 4] &= ~(3ul << ((i & 0xfU) << 1)))
#define __ac_set_isdel_true(flag, i) (flag[i >> 4] |= 1ul << ((i & 0xfU) << 1))
#ifdef KHASH_LINEAR #ifdef KHASH_LINEAR
#define __ac_inc(k, m) 1 #define __ac_inc(k, m) 1
#else #else
#define __ac_inc(k, m) (((k)>>3 ^ (k)<<3) | 1) & (m) #define __ac_inc(k, m) (((k) >> 3 ^ (k) << 3) | 1) & (m)
#endif #endif
#define __ac_fsize(m) ((m) < 16? 1 : (m)>>4) #define __ac_fsize(m) ((m) < 16 ? 1 : (m) >> 4)
#ifndef kroundup32 #ifndef kroundup32
#define kroundup32(x) (--(x), (x)|=(x)>>1, (x)|=(x)>>2, (x)|=(x)>>4, (x)|=(x)>>8, (x)|=(x)>>16, ++(x)) #define kroundup32(x) \
(--(x), (x) |= (x) >> 1, (x) |= (x) >> 2, (x) |= (x) >> 4, \
(x) |= (x) >> 8, (x) |= (x) >> 16, ++(x))
#endif #endif
static const double __ac_HASH_UPPER = 0.77; static const double __ac_HASH_UPPER = 0.77;
#define KHASH_DECLARE(name, khkey_t, khval_t) \ #define KHASH_DECLARE(name, khkey_t, khval_t) \
typedef struct { \ typedef struct \
{ \
khint_t n_buckets, size, n_occupied, upper_bound; \ khint_t n_buckets, size, n_occupied, upper_bound; \
khint32_t *flags; \ khint32_t *flags; \
khkey_t *keys; \ khkey_t *keys; \
@ -171,83 +176,127 @@ static const double __ac_HASH_UPPER = 0.77;
extern khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret); \ extern khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret); \
extern void kh_del_##name(kh_##name##_t *h, khint_t x); extern void kh_del_##name(kh_##name##_t *h, khint_t x);
#define KHASH_INIT2(name, SCOPE, khkey_t, khval_t, kh_is_map, __hash_func, __hash_equal) \ #define KHASH_INIT2(name, SCOPE, khkey_t, khval_t, kh_is_map, __hash_func, \
typedef struct { \ __hash_equal) \
typedef struct \
{ \
khint_t n_buckets, size, n_occupied, upper_bound; \ khint_t n_buckets, size, n_occupied, upper_bound; \
khint32_t *flags; \ khint32_t *flags; \
khkey_t *keys; \ khkey_t *keys; \
khval_t *vals; \ khval_t *vals; \
} kh_##name##_t; \ } kh_##name##_t; \
SCOPE kh_##name##_t *kh_init_##name() { \ SCOPE kh_##name##_t *kh_init_##name() \
return (kh_##name##_t*)calloc(1, sizeof(kh_##name##_t)); \ { \
return (kh_##name##_t *)calloc(1, sizeof(kh_##name##_t)); \
} \ } \
SCOPE void kh_destroy_##name(kh_##name##_t *h) \ SCOPE void kh_destroy_##name(kh_##name##_t *h) \
{ \ { \
if (h) { \ if (h) \
free(h->keys); free(h->flags); \ { \
free(h->keys); \
free(h->flags); \
free(h->vals); \ free(h->vals); \
free(h); \ free(h); \
} \ } \
} \ } \
SCOPE void kh_clear_##name(kh_##name##_t *h) \ SCOPE void kh_clear_##name(kh_##name##_t *h) \
{ \ { \
if (h && h->flags) { \ if (h && h->flags) \
memset(h->flags, 0xaa, __ac_fsize(h->n_buckets) * sizeof(khint32_t)); \ { \
memset(h->flags, 0xaa, \
__ac_fsize(h->n_buckets) * sizeof(khint32_t)); \
h->size = h->n_occupied = 0; \ h->size = h->n_occupied = 0; \
} \ } \
} \ } \
SCOPE khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key) \ SCOPE khint_t kh_get_##name(const kh_##name##_t *h, khkey_t key) \
{ \ { \
if (h->n_buckets) { \ if (h->n_buckets) \
{ \
khint_t inc, k, i, last, mask; \ khint_t inc, k, i, last, mask; \
mask = h->n_buckets - 1; \ mask = h->n_buckets - 1; \
k = __hash_func(key); i = k & mask; \ k = __hash_func(key); \
inc = __ac_inc(k, mask); last = i; /* inc==1 for linear probing */ \ i = k & mask; \
while (!__ac_isempty(h->flags, i) && (__ac_isdel(h->flags, i) || !__hash_equal(h->keys[i], key))) { \ inc = __ac_inc(k, mask); \
last = i; /* inc==1 for linear probing */ \
while ( \
!__ac_isempty(h->flags, i) && \
(__ac_isdel(h->flags, i) || !__hash_equal(h->keys[i], key))) \
{ \
i = (i + inc) & mask; \ i = (i + inc) & mask; \
if (i == last) return h->n_buckets; \ if (i == last) return h->n_buckets; \
} \ } \
return __ac_iseither(h->flags, i)? h->n_buckets : i; \ return __ac_iseither(h->flags, i) ? h->n_buckets : i; \
} else return 0; \ } \
else \
return 0; \
} \ } \
SCOPE void kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets) \ SCOPE void kh_resize_##name(kh_##name##_t *h, khint_t new_n_buckets) \
{ /* This function uses 0.25*n_bucktes bytes of working space instead of [sizeof(key_t+val_t)+.25]*n_buckets. */ \ { /* This function uses 0.25*n_bucktes bytes of working space instead of \
[sizeof(key_t+val_t)+.25]*n_buckets. */ \
khint32_t *new_flags = 0; \ khint32_t *new_flags = 0; \
khint_t j = 1; \ khint_t j = 1; \
{ \ { \
kroundup32(new_n_buckets); \ kroundup32(new_n_buckets); \
if (new_n_buckets < 4) new_n_buckets = 4; \ if (new_n_buckets < 4) new_n_buckets = 4; \
if (h->size >= (khint_t)(new_n_buckets * __ac_HASH_UPPER + 0.5)) j = 0; /* requested size is too small */ \ if (h->size >= (khint_t)(new_n_buckets * __ac_HASH_UPPER + 0.5)) \
else { /* hash table size to be changed (shrink or expand); rehash */ \ j = 0; /* requested size is too small */ \
new_flags = (khint32_t*)malloc(__ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ else \
memset(new_flags, 0xaa, __ac_fsize(new_n_buckets) * sizeof(khint32_t)); \ { /* hash table size to be changed (shrink or expand); rehash */ \
if (h->n_buckets < new_n_buckets) { /* expand */ \ new_flags = (khint32_t *)malloc(__ac_fsize(new_n_buckets) * \
h->keys = (khkey_t*)realloc(h->keys, new_n_buckets * sizeof(khkey_t)); \ sizeof(khint32_t)); \
if (kh_is_map) h->vals = (khval_t*)realloc(h->vals, new_n_buckets * sizeof(khval_t)); \ memset(new_flags, 0xaa, \
__ac_fsize(new_n_buckets) * sizeof(khint32_t)); \
if (h->n_buckets < new_n_buckets) \
{ /* expand */ \
h->keys = (khkey_t *)realloc( \
h->keys, new_n_buckets * sizeof(khkey_t)); \
if (kh_is_map) \
h->vals = (khval_t *)realloc( \
h->vals, new_n_buckets * sizeof(khval_t)); \
} /* otherwise shrink */ \ } /* otherwise shrink */ \
} \ } \
} \ } \
if (j) { /* rehashing is needed */ \ if (j) \
for (j = 0; j != h->n_buckets; ++j) { \ { /* rehashing is needed */ \
if (__ac_iseither(h->flags, j) == 0) { \ for (j = 0; j != h->n_buckets; ++j) \
{ \
if (__ac_iseither(h->flags, j) == 0) \
{ \
khkey_t key = h->keys[j]; \ khkey_t key = h->keys[j]; \
khval_t val; \ khval_t val; \
khint_t new_mask; \ khint_t new_mask; \
new_mask = new_n_buckets - 1; \ new_mask = new_n_buckets - 1; \
if (kh_is_map) val = h->vals[j]; \ if (kh_is_map) val = h->vals[j]; \
__ac_set_isdel_true(h->flags, j); \ __ac_set_isdel_true(h->flags, j); \
while (1) { /* kick-out process; sort of like in Cuckoo hashing */ \ while (1) \
{ /* kick-out process; sort of like in Cuckoo hashing */ \
khint_t inc, k, i; \ khint_t inc, k, i; \
k = __hash_func(key); \ k = __hash_func(key); \
i = k & new_mask; \ i = k & new_mask; \
inc = __ac_inc(k, new_mask); \ inc = __ac_inc(k, new_mask); \
while (!__ac_isempty(new_flags, i)) i = (i + inc) & new_mask; \ while (!__ac_isempty(new_flags, i)) \
i = (i + inc) & new_mask; \
__ac_set_isempty_false(new_flags, i); \ __ac_set_isempty_false(new_flags, i); \
if (i < h->n_buckets && __ac_iseither(h->flags, i) == 0) { /* kick out the existing element */ \ if (i < h->n_buckets && \
{ khkey_t tmp = h->keys[i]; h->keys[i] = key; key = tmp; } \ __ac_iseither(h->flags, i) == 0) \
if (kh_is_map) { khval_t tmp = h->vals[i]; h->vals[i] = val; val = tmp; } \ { /* kick out the existing element */ \
__ac_set_isdel_true(h->flags, i); /* mark it as deleted in the old hash table */ \ { \
} else { /* write the element and jump out of the loop */ \ khkey_t tmp = h->keys[i]; \
h->keys[i] = key; \
key = tmp; \
} \
if (kh_is_map) \
{ \
khval_t tmp = h->vals[i]; \
h->vals[i] = val; \
val = tmp; \
} \
__ac_set_isdel_true(h->flags, \
i); /* mark it as deleted in \
the old hash table */ \
} \
else \
{ /* write the element and jump out of the loop */ \
h->keys[i] = key; \ h->keys[i] = key; \
if (kh_is_map) h->vals[i] = val; \ if (kh_is_map) h->vals[i] = val; \
break; \ break; \
@ -255,9 +304,13 @@ static const double __ac_HASH_UPPER = 0.77;
} \ } \
} \ } \
} \ } \
if (h->n_buckets > new_n_buckets) { /* shrink the hash table */ \ if (h->n_buckets > new_n_buckets) \
h->keys = (khkey_t*)realloc(h->keys, new_n_buckets * sizeof(khkey_t)); \ { /* shrink the hash table */ \
if (kh_is_map) h->vals = (khval_t*)realloc(h->vals, new_n_buckets * sizeof(khval_t)); \ h->keys = (khkey_t *)realloc(h->keys, \
new_n_buckets * sizeof(khkey_t)); \
if (kh_is_map) \
h->vals = (khval_t *)realloc( \
h->vals, new_n_buckets * sizeof(khval_t)); \
} \ } \
free(h->flags); /* free the working space */ \ free(h->flags); /* free the working space */ \
h->flags = new_flags; \ h->flags = new_flags; \
@ -269,50 +322,80 @@ static const double __ac_HASH_UPPER = 0.77;
SCOPE khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret) \ SCOPE khint_t kh_put_##name(kh_##name##_t *h, khkey_t key, int *ret) \
{ \ { \
khint_t x; \ khint_t x; \
if (h->n_occupied >= h->upper_bound) { /* update the hash table */ \ if (h->n_occupied >= h->upper_bound) \
if (h->n_buckets > (h->size<<1)) kh_resize_##name(h, h->n_buckets - 1); /* clear "deleted" elements */ \ { /* update the hash table */ \
else kh_resize_##name(h, h->n_buckets + 1); /* expand the hash table */ \ if (h->n_buckets > (h->size << 1)) \
} /* TODO: to implement automatically shrinking; resize() already support shrinking */ \ kh_resize_##name(h, h->n_buckets - \
1); /* clear "deleted" elements */ \
else \
kh_resize_##name(h, h->n_buckets + \
1); /* expand the hash table */ \
} /* TODO: to implement automatically shrinking; resize() already \
support shrinking */ \
{ \ { \
khint_t inc, k, i, site, last, mask = h->n_buckets - 1; \ khint_t inc, k, i, site, last, mask = h->n_buckets - 1; \
x = site = h->n_buckets; k = __hash_func(key); i = k & mask; \ x = site = h->n_buckets; \
if (__ac_isempty(h->flags, i)) x = i; /* for speed up */ \ k = __hash_func(key); \
else { \ i = k & mask; \
inc = __ac_inc(k, mask); last = i; \ if (__ac_isempty(h->flags, i)) \
while (!__ac_isempty(h->flags, i) && (__ac_isdel(h->flags, i) || !__hash_equal(h->keys[i], key))) { \ x = i; /* for speed up */ \
else \
{ \
inc = __ac_inc(k, mask); \
last = i; \
while (!__ac_isempty(h->flags, i) && \
(__ac_isdel(h->flags, i) || \
!__hash_equal(h->keys[i], key))) \
{ \
if (__ac_isdel(h->flags, i)) site = i; \ if (__ac_isdel(h->flags, i)) site = i; \
i = (i + inc) & mask; \ i = (i + inc) & mask; \
if (i == last) { x = site; break; } \ if (i == last) \
{ \
x = site; \
break; \
} \ } \
if (x == h->n_buckets) { \ } \
if (__ac_isempty(h->flags, i) && site != h->n_buckets) x = site; \ if (x == h->n_buckets) \
else x = i; \ { \
if (__ac_isempty(h->flags, i) && site != h->n_buckets) \
x = site; \
else \
x = i; \
} \ } \
} \ } \
} \ } \
if (__ac_isempty(h->flags, x)) { /* not present at all */ \ if (__ac_isempty(h->flags, x)) \
{ /* not present at all */ \
h->keys[x] = key; \ h->keys[x] = key; \
__ac_set_isboth_false(h->flags, x); \ __ac_set_isboth_false(h->flags, x); \
++h->size; ++h->n_occupied; \ ++h->size; \
++h->n_occupied; \
*ret = 1; \ *ret = 1; \
} else if (__ac_isdel(h->flags, x)) { /* deleted */ \ } \
else if (__ac_isdel(h->flags, x)) \
{ /* deleted */ \
h->keys[x] = key; \ h->keys[x] = key; \
__ac_set_isboth_false(h->flags, x); \ __ac_set_isboth_false(h->flags, x); \
++h->size; \ ++h->size; \
*ret = 2; \ *ret = 2; \
} else *ret = 0; /* Don't touch h->keys[x] if present and not deleted */ \ } \
else \
*ret = 0; /* Don't touch h->keys[x] if present and not deleted */ \
return x; \ return x; \
} \ } \
SCOPE void kh_del_##name(kh_##name##_t *h, khint_t x) \ SCOPE void kh_del_##name(kh_##name##_t *h, khint_t x) \
{ \ { \
if (x != h->n_buckets && !__ac_iseither(h->flags, x)) { \ if (x != h->n_buckets && !__ac_iseither(h->flags, x)) \
{ \
__ac_set_isdel_true(h->flags, x); \ __ac_set_isdel_true(h->flags, x); \
--h->size; \ --h->size; \
} \ } \
} }
#define KHASH_INIT(name, khkey_t, khval_t, kh_is_map, __hash_func, __hash_equal) \ #define KHASH_INIT(name, khkey_t, khval_t, kh_is_map, __hash_func, \
KHASH_INIT2(name, static inline, khkey_t, khval_t, kh_is_map, __hash_func, __hash_equal) __hash_equal) \
KHASH_INIT2(name, static inline, khkey_t, khval_t, kh_is_map, __hash_func, \
__hash_equal)
/* --- BEGIN OF HASH FUNCTIONS --- */ /* --- BEGIN OF HASH FUNCTIONS --- */
@ -331,7 +414,7 @@ static const double __ac_HASH_UPPER = 0.77;
@param key The integer [khint64_t] @param key The integer [khint64_t]
@return The hash value [khint_t] @return The hash value [khint_t]
*/ */
#define kh_int64_hash_func(key) (khint32_t)((key)>>33^(key)^(key)<<11) #define kh_int64_hash_func(key) (khint32_t)((key) >> 33 ^ (key) ^ (key) << 11)
/*! @function /*! @function
@abstract 64-bit integer comparison function @abstract 64-bit integer comparison function
*/ */
@ -344,7 +427,9 @@ static const double __ac_HASH_UPPER = 0.77;
static inline khint_t __ac_X31_hash_string(const char *s) static inline khint_t __ac_X31_hash_string(const char *s)
{ {
khint_t h = *s; khint_t h = *s;
if (h) for (++s ; *s; ++s) h = (h << 5) - h + *s; if (h)
for (++s; *s; ++s)
h = (h << 5) - h + *s;
return h; return h;
} }
/*! @function /*! @function
@ -426,7 +511,8 @@ static inline khint_t __ac_Wang_hash(khint_t key)
@param name Name of the hash table [symbol] @param name Name of the hash table [symbol]
@param h Pointer to the hash table [khash_t(name)*] @param h Pointer to the hash table [khash_t(name)*]
@param k Key [type of keys] @param k Key [type of keys]
@return Iterator to the found element, or kh_end(h) is the element is absent [khint_t] @return Iterator to the found element, or kh_end(h) is the element is
absent [khint_t]
*/ */
#define kh_get(name, h, k) kh_get_##name(h, k) #define kh_get(name, h, k) kh_get_##name(h, k)
@ -518,7 +604,8 @@ static inline khint_t __ac_Wang_hash(khint_t key)
@param name Name of the hash table [symbol] @param name Name of the hash table [symbol]
*/ */
#define KHASH_SET_INIT_INT64(name) \ #define KHASH_SET_INIT_INT64(name) \
KHASH_INIT(name, khint64_t, char, 0, kh_int64_hash_func, kh_int64_hash_equal) KHASH_INIT(name, khint64_t, char, 0, kh_int64_hash_func, \
kh_int64_hash_equal)
/*! @function /*! @function
@abstract Instantiate a hash map containing 64-bit integer keys @abstract Instantiate a hash map containing 64-bit integer keys
@ -526,7 +613,8 @@ static inline khint_t __ac_Wang_hash(khint_t key)
@param khval_t Type of values [type] @param khval_t Type of values [type]
*/ */
#define KHASH_MAP_INIT_INT64(name, khval_t) \ #define KHASH_MAP_INIT_INT64(name, khval_t) \
KHASH_INIT(name, khint64_t, khval_t, 1, kh_int64_hash_func, kh_int64_hash_equal) KHASH_INIT(name, khint64_t, khval_t, 1, kh_int64_hash_func, \
kh_int64_hash_equal)
typedef const char *kh_cstr_t; typedef const char *kh_cstr_t;
/*! @function /*! @function

36
src/lake.c
View file

@ -10,26 +10,20 @@
* *
*/ */
#include "lake.h"
#include "bool.h" #include "bool.h"
#include "comment.h" #include "comment.h"
#include "common.h" #include "common.h"
#include "hash.h"
#include "env.h" #include "env.h"
#include "eval.h" #include "eval.h"
#include "lake.h" #include "hash.h"
#include "list.h" #include "list.h"
#include "primitive.h" #include "primitive.h"
#include "str.h" #include "str.h"
int lake_val_size(void *x) int lake_val_size(void *x) { return VAL(x)->size; }
{
return VAL(x)->size;
}
int lake_is_type(LakeType t, void *x) int lake_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)
{ {
@ -38,7 +32,8 @@ char *lake_repr(void *expr)
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));
@ -52,7 +47,8 @@ char *lake_repr(void *expr)
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 */
@ -81,8 +77,8 @@ char *lake_repr(void *expr)
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
// so go ahead and print out the size too. // switch, 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)");
@ -98,7 +94,8 @@ bool lake_is_nil(LakeVal *x)
bool lake_is(LakeVal *a, LakeVal *b) bool lake_is(LakeVal *a, LakeVal *b)
{ {
if (lake_is_type(TYPE_INT, a) && lake_is_type(TYPE_INT, b)) { if (lake_is_type(TYPE_INT, a) && lake_is_type(TYPE_INT, b))
{
return INT_VAL(INT(a)) == INT_VAL(INT(b)); return INT_VAL(INT(a)) == INT_VAL(INT(b));
} }
if (lake_is_nil(a) && lake_is_nil(b)) return TRUE; if (lake_is_nil(a) && lake_is_nil(b)) return TRUE;
@ -107,9 +104,9 @@ bool lake_is(LakeVal *a, LakeVal *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",
"dotted-list", "primitive", "function" "integer", "string", "list",
}; "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)";
@ -118,7 +115,8 @@ static char *type_name(LakeVal *expr)
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:

59
src/lake.h
View file

@ -10,8 +10,8 @@
#ifndef _LAKE_LAKE_H #ifndef _LAKE_LAKE_H
#define _LAKE_LAKE_H #define _LAKE_LAKE_H
#include <stdlib.h>
#include "common.h" #include "common.h"
#include <stdlib.h>
#define LAKE_VERSION "0.1" #define LAKE_VERSION "0.1"
@ -38,13 +38,15 @@ typedef int LakeType;
#define FN(x) ((LakeFn *)x) #define FN(x) ((LakeFn *)x)
#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;
@ -52,13 +54,15 @@ struct lake_sym {
}; };
typedef struct lake_sym LakeSym; typedef struct lake_sym LakeSym;
struct lake_bool { struct lake_bool
{
LakeVal base; LakeVal base;
bool val; bool val;
}; };
typedef struct lake_bool LakeBool; typedef struct lake_bool LakeBool;
struct lake_int { struct lake_int
{
LakeVal base; LakeVal base;
int val; int val;
}; };
@ -66,7 +70,8 @@ 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;
@ -76,7 +81,8 @@ typedef struct lake_str LakeStr;
#define STR_N(str) (str->n) #define STR_N(str) (str->n)
#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;
@ -88,18 +94,20 @@ typedef struct lake_list LakeList;
#define LIST_VALS(list) (list->vals) #define LIST_VALS(list) (list->vals)
#define LIST_VAL(list, i) (i >= 0 && i < list->n ? list->vals[i] : NULL) #define LIST_VAL(list, i) (i >= 0 && i < list->n ? list->vals[i] : NULL)
struct lake_dlist { struct lake_dlist
{
LakeVal base; LakeVal base;
LakeList *head; LakeList *head;
LakeVal *tail; LakeVal *tail;
}; };
typedef struct lake_dlist LakeDottedList; typedef struct lake_dlist LakeDottedList;
#include "hash.h"
#include "env.h" #include "env.h"
#include "hash.h"
/* Execution context */ /* Execution context */
struct lake_ctx { struct lake_ctx
{
Env *toplevel; Env *toplevel;
lake_hash_t *symbols; lake_hash_t *symbols;
lake_hash_t *special_form_handlers; lake_hash_t *special_form_handlers;
@ -110,7 +118,8 @@ typedef struct lake_ctx LakeCtx;
typedef LakeVal *(*lake_prim)(LakeCtx *ctx, LakeList *args); 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;
@ -121,8 +130,8 @@ typedef struct lake_primitive LakePrimitive;
#define PRIM_ARITY(x) (x->arity) #define PRIM_ARITY(x) (x->arity)
#define ARITY_VARARGS -1 #define ARITY_VARARGS -1
struct lake_fn
struct lake_fn { {
LakeVal base; LakeVal base;
LakeList *params; LakeList *params;
LakeSym *varargs; LakeSym *varargs;
@ -133,7 +142,8 @@ typedef struct lake_fn LakeFn;
#define CALLABLE(x) (lake_is_type(TYPE_FN, x) || lake_is_type(TYPE_PRIM, x)) #define CALLABLE(x) (lake_is_type(TYPE_FN, x) || lake_is_type(TYPE_PRIM, x))
struct lake_comment { struct lake_comment
{
LakeVal base; LakeVal base;
LakeStr *text; LakeStr *text;
}; };
@ -151,23 +161,30 @@ char *lake_repr(void *val);
#include <stdio.h> #include <stdio.h>
#define ERR(...) do { \ #define ERR(...) \
do \
{ \
fprintf(stderr, "error: "); \ fprintf(stderr, "error: "); \
fprintf(stderr, __VA_ARGS__); \ fprintf(stderr, __VA_ARGS__); \
fprintf(stderr, "\n"); \ fprintf(stderr, "\n"); \
} while (0) } while (0)
#define DIE(...) do { ERR(__VA_ARGS__); exit(1); } while(0) #define DIE(...) \
do \
{ \
ERR(__VA_ARGS__); \
exit(1); \
} while (0)
#define OOM() DIE("%s:%d out of memory", __FILE__, __LINE__) #define OOM() DIE("%s:%d out of memory", __FILE__, __LINE__)
#include "bool.h" #include "bool.h"
#include "sym.h" #include "comment.h"
#include "int.h"
#include "str.h"
#include "list.h"
#include "dlist.h" #include "dlist.h"
#include "fn.h" #include "fn.h"
#include "comment.h" #include "int.h"
#include "list.h"
#include "primitive.h" #include "primitive.h"
#include "str.h"
#include "sym.h"
#endif #endif

64
src/list.c
View file

@ -7,14 +7,14 @@
* *
*/ */
#include <stdlib.h> #include "list.h"
#include <stdio.h>
#include <string.h>
#include "common.h" #include "common.h"
#include "int.h" #include "int.h"
#include "lake.h" #include "lake.h"
#include "list.h"
#include "str.h" #include "str.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/* TODO: use a linked list instead of this cheesy structure */ /* TODO: use a linked list instead of this cheesy structure */
@ -31,7 +31,8 @@ static LakeList *list_alloc(void)
void list_free(LakeList *list) void list_free(LakeList *list)
{ {
/* TODO: proper memory management ... refcounting? */ /* TODO: proper memory management ... refcounting? */
if (list) { if (list)
{
free(list); free(list);
} }
} }
@ -46,11 +47,13 @@ LakeList *list_make(void)
LakeList *list_cons(LakeVal *car, LakeVal *cdr) LakeList *list_cons(LakeVal *car, LakeVal *cdr)
{ {
LakeList *list; LakeList *list;
if (lake_is_type(TYPE_LIST, cdr)) { if (lake_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);
@ -75,10 +78,7 @@ LakeList *list_from_array(size_t n, LakeVal *vals[])
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)
{ {
@ -94,7 +94,8 @@ static void list_grow(LakeList *list)
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;
@ -103,7 +104,8 @@ LakeVal *list_set(LakeList *list, size_t i, LakeVal *val)
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;
@ -111,7 +113,8 @@ LakeVal *list_get(LakeList *list, LakeInt *li)
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;
@ -121,11 +124,13 @@ LakeVal *list_append(LakeList *list, LakeVal *val)
LakeVal *list_shift(LakeList *list) LakeVal *list_shift(LakeList *list)
{ {
LakeVal *head = NULL; LakeVal *head = NULL;
if (list->n > 0) { if (list->n > 0)
{
head = list->vals[0]; head = list->vals[0];
size_t i; size_t i;
size_t n = list->n; size_t n = list->n;
for (i = 1; i < n; ++i) { for (i = 1; i < n; ++i)
{
list->vals[i - 1] = list->vals[i]; list->vals[i - 1] = list->vals[i];
} }
list->n--; list->n--;
@ -135,15 +140,19 @@ 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 { else
if (list->n >= list->cap) { {
if (list->n >= list->cap)
{
list_grow(list); 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;
@ -154,7 +163,8 @@ LakeVal *list_unshift(LakeList *list, LakeVal *val)
LakeVal *list_pop(LakeList *list) LakeVal *list_pop(LakeList *list)
{ {
LakeVal *tail = NULL; LakeVal *tail = NULL;
if (list->n > 0) { if (list->n > 0)
{
tail = list->vals[list->n - 1]; tail = list->vals[list->n - 1];
list->n--; list->n--;
} }
@ -167,7 +177,8 @@ bool list_equal(LakeList *a, LakeList *b)
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;
@ -189,12 +200,15 @@ char *list_repr(LakeList *list)
int i; int i;
char *s2; char *s2;
LakeVal *val; LakeVal *val;
for (i = 0; i < LIST_N(list); ++i) { for (i = 0; i < LIST_N(list); ++i)
{
val = LIST_VAL(list, i); val = LIST_VAL(list, i);
if (val == VAL(list)) { if (val == VAL(list))
{
s2 = strdup("[Circular]"); s2 = strdup("[Circular]");
} }
else { else
{
s2 = lake_repr(val); s2 = lake_repr(val);
} }
s = lake_str_append(s, s2); s = lake_str_append(s, s2);

2
src/list.h
View file

@ -10,10 +10,10 @@
#ifndef _LAKE_LIST_H #ifndef _LAKE_LIST_H
#define _LAKE_LIST_H #define _LAKE_LIST_H
#include <stdlib.h>
#include "common.h" #include "common.h"
#include "lake.h" #include "lake.h"
#include "str.h" #include "str.h"
#include <stdlib.h>
LakeList *list_make(void); LakeList *list_make(void);
LakeList *list_cons(LakeVal *car, LakeVal *cdr); LakeList *list_cons(LakeVal *car, LakeVal *cdr);

166
src/parse.c
View file

@ -7,19 +7,20 @@
* *
*/ */
#include <stdio.h> #include "parse.h"
#include <stdlib.h>
#include <string.h>
#include "common.h" #include "common.h"
#include "dlist.h" #include "dlist.h"
#include "int.h" #include "int.h"
#include "lake.h" #include "lake.h"
#include "list.h" #include "list.h"
#include "parse.h"
#include "str.h" #include "str.h"
#include "sym.h" #include "sym.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
struct context { struct context
{
char *s; char *s;
size_t n; size_t n;
size_t i; size_t i;
@ -41,15 +42,17 @@ 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;
@ -57,15 +60,18 @@ LakeVal *parse_expr(LakeCtx *lake_ctx, char *s, size_t n)
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 { else
{
list_free(results); list_free(results);
return NULL; return NULL;
} }
@ -76,13 +82,15 @@ LakeList *parse_exprs(LakeCtx *lake_ctx, char *s, size_t n)
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;
@ -95,7 +103,8 @@ LakeList *parse_naked_list(LakeCtx *lake_ctx, char *s, size_t n)
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;
@ -111,27 +120,19 @@ static char consume1(Ctx *ctx)
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)
{ {
@ -143,20 +144,14 @@ 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))
{ {
@ -164,11 +159,13 @@ static char *parse_while(Ctx *ctx, bool (*is_valid)(char))
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();
} }
@ -179,7 +176,8 @@ static char *parse_while(Ctx *ctx, bool (*is_valid)(char))
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;
@ -191,21 +189,25 @@ static LakeVal *parse_int(Ctx *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))) { while (is_digit(c = peek(ctx)))
{
n *= 10; n *= 10;
n += c - '0'; n += c - '0';
consume1(ctx); consume1(ctx);
} }
/* if we're looking at a symbol character bail, it's not a number */ /* if we're looking at a symbol character bail, it's not a number */
if (is_sym_char(peek(ctx))) { if (is_sym_char(peek(ctx)))
{
backtrack(ctx); backtrack(ctx);
return NULL; return NULL;
} }
@ -219,18 +221,22 @@ static LakeVal *parse_sym(Ctx *ctx)
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);
} }
else if (strcmp(s, "#f") == 0) { else if (strcmp(s, "#f") == 0)
{
val = VAL(ctx->lake_ctx->F); val = VAL(ctx->lake_ctx->F);
} }
else { else
{
val = VAL(sym_intern(ctx->lake_ctx, s)); val = VAL(sym_intern(ctx->lake_ctx, s));
} }
return val; return val;
@ -238,7 +244,8 @@ static LakeVal *parse_sym(Ctx *ctx)
static char escape_char(char c) static char escape_char(char c)
{ {
switch (c) { switch (c)
{
case 'n': case 'n':
c = '\n'; c = '\n';
@ -255,7 +262,6 @@ static char escape_char(char c)
default: default:
/* noop */ /* noop */
break; break;
} }
return c; return c;
} }
@ -267,9 +273,11 @@ static LakeVal *parse_str(Ctx *ctx)
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;
@ -277,7 +285,8 @@ static LakeVal *parse_str(Ctx *ctx)
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();
} }
@ -289,25 +298,29 @@ static LakeVal *parse_str(Ctx *ctx)
return VAL(str); 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 */ /* check for dotted lists */
if (c == '.') { if (c == '.')
{
ch(ctx, '.'); ch(ctx, '.');
maybe_spaces(ctx); maybe_spaces(ctx);
LakeVal *tail = _parse_expr(ctx); LakeVal *tail = _parse_expr(ctx);
if (tail == VAL(PARSE_ERR)) { if (tail == VAL(PARSE_ERR))
{
list_free(list); list_free(list);
ctx->i = ctx->n; ctx->i = ctx->n;
return NULL; return NULL;
@ -317,7 +330,8 @@ static LakeVal* parse_list(Ctx *ctx)
} }
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;
@ -337,10 +351,7 @@ static LakeVal *parse_quoted(Ctx *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)
{ {
@ -357,31 +368,40 @@ static LakeVal *_parse_expr(Ctx *ctx)
LakeVal *result; LakeVal *result;
char c = peek(ctx); char c = peek(ctx);
/* try to parse a number, if that fails parse a symbol */ /* try to parse a number, if that fails parse a symbol */
if ((c >= '0' && c <= '9') || c == '-' || c == '+') { if ((c >= '0' && c <= '9') || c == '-' || c == '+')
{
result = VAL(parse_int(ctx)); result = VAL(parse_int(ctx));
if (result == NULL) { if (result == NULL)
{
result = parse_sym(ctx); result = parse_sym(ctx);
} }
} }
else if (is_letter(c) || is_symbol(c)) { else if (is_letter(c) || is_symbol(c))
{
result = parse_sym(ctx); result = parse_sym(ctx);
} }
else if (c == '"') { else if (c == '"')
{
result = parse_str(ctx); result = parse_str(ctx);
} }
else if (c == '\'') { else if (c == '\'')
{
result = parse_quoted(ctx); result = parse_quoted(ctx);
} }
else if (c == '(') { else if (c == '(')
{
result = parse_list(ctx); result = parse_list(ctx);
} }
else if (c == ';') { else if (c == ';')
{
result = parse_comment(ctx); result = parse_comment(ctx);
} }
else if (c == PARSE_EOF) { else if (c == PARSE_EOF)
{
result = NULL; result = NULL;
} }
else { else
{
ERR("unexpected char '%c'", c); ERR("unexpected char '%c'", c);
result = VAL(PARSE_ERR); result = VAL(PARSE_ERR);
ctx->i = ctx->n; /* consume the rest */ ctx->i = ctx->n; /* consume the rest */

2
src/parse.h
View file

@ -10,8 +10,8 @@
#ifndef _LAKE_PARSE_H #ifndef _LAKE_PARSE_H
#define _LAKE_PARSE_H #define _LAKE_PARSE_H
#include <stdlib.h>
#include "lake.h" #include "lake.h"
#include <stdlib.h>
#define PARSE_EOF -1 #define PARSE_EOF -1
#define PARSE_ERR -2 #define PARSE_ERR -2

121
src/primitive.c
View file

@ -7,19 +7,18 @@
* *
*/ */
#include <stdlib.h> #include "primitive.h"
#include "bool.h" #include "bool.h"
#include "common.h"
#include "comment.h" #include "comment.h"
#include "common.h"
#include "dlist.h" #include "dlist.h"
#include "env.h" #include "env.h"
#include "int.h"
#include "dlist.h"
#include "fn.h" #include "fn.h"
#include "list.h" #include "int.h"
#include "lake.h" #include "lake.h"
#include "primitive.h" #include "list.h"
#include "str.h" #include "str.h"
#include <stdlib.h>
static LakePrimitive *prim_alloc(void) static LakePrimitive *prim_alloc(void)
{ {
@ -49,10 +48,12 @@ char *prim_repr(LakePrimitive *prim)
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 (lake_is_type(TYPE_LIST, list) && LIST_N(list) > 0) { if (lake_is_type(TYPE_LIST, list) && LIST_N(list) > 0)
{
return LIST_VAL(list, 0); return LIST_VAL(list, 0);
} }
if (lake_is_type(TYPE_DLIST, list)) { if (lake_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));
@ -62,12 +63,14 @@ static LakeVal *_car(LakeCtx *ctx, LakeList *args)
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 (lake_is_type(TYPE_LIST, list) && LIST_N(list) > 0) { if (lake_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 (lake_is_type(TYPE_DLIST, list)) { if (lake_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));
@ -84,14 +87,16 @@ static LakeVal *_cons(LakeCtx *ctx, LakeList *args)
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 = lake_bool_from_int(ctx, lake_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) == 0); LakeBool *is_null = lake_bool_from_int(ctx, lake_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 = lake_bool_from_int(ctx, lake_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) > 0); LakeBool *is_pair = lake_bool_from_int(ctx, lake_is_type(TYPE_LIST, val) &&
LIST_N(LIST(val)) > 0);
return VAL(is_pair); return VAL(is_pair);
} }
@ -113,22 +118,26 @@ static LakeVal *_not(LakeCtx *ctx, LakeList *args)
{ {
LakeVal *val = list_shift(args); LakeVal *val = list_shift(args);
LakeBool *not = lake_bool_from_int(ctx, lake_is_false(ctx, val)); LakeBool *not = lake_bool_from_int(ctx, lake_is_false(ctx, val));
return VAL(not); return VAL(not );
} }
#define ENSURE_INT(x, i) do { \ #define ENSURE_INT(x, i) \
if (!lake_is_type(TYPE_INT, x)) { \ do \
{ \
if (!lake_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));
@ -140,14 +149,16 @@ 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));
@ -160,7 +171,8 @@ 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));
@ -174,7 +186,8 @@ static LakeVal *_div(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;
} }
@ -183,20 +196,25 @@ static LakeVal *_div(LakeCtx *ctx, LakeList *args)
ENSURE_INT(v, (size_t)0); ENSURE_INT(v, (size_t)0);
int result = INT_VAL(INT(v)); int result = INT_VAL(INT(v));
if (n == 1) { if (n == 1)
if (result == 0) { {
if (result == 0)
{
DIVIDE_BY_ZERO(); DIVIDE_BY_ZERO();
return NULL; return NULL;
} }
result = 1 / result; result = 1 / result;
} }
else { else
{
size_t i; size_t i;
for (i = 1; i < n; ++i) { for (i = 1; i < n; ++i)
{
v = LIST_VAL(args, i); v = LIST_VAL(args, i);
ENSURE_INT(v, i); ENSURE_INT(v, i);
int val = INT_VAL(INT(v)); int val = INT_VAL(INT(v));
if (val == 0) { if (val == 0)
{
DIVIDE_BY_ZERO(); DIVIDE_BY_ZERO();
return NULL; return NULL;
} }
@ -212,11 +230,13 @@ static LakeVal *_int_eq(LakeCtx *ctx, LakeList *args)
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)); prev = INT_VAL(INT(v));
@ -231,12 +251,15 @@ static LakeVal *_int_lt(LakeCtx *ctx, LakeList *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));
@ -252,12 +275,15 @@ static LakeVal *_int_gt(LakeCtx *ctx, LakeList *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));
@ -269,12 +295,15 @@ static LakeVal *_int_gt(LakeCtx *ctx, LakeList *args)
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 (lake_is_type(TYPE_LIST, list)) { if (lake_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 { else
{
list_set(list, 0, new_car); list_set(list, 0, new_car);
} }
return VAL(list); return VAL(list);
@ -288,7 +317,8 @@ 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;
@ -298,10 +328,11 @@ static LakeVal *_display(LakeCtx *ctx, LakeList *args)
} }
#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(lake_bool_from_int(ctx, lake_is_type(type, LIST_VAL(args, 0)))); \ return VAL( \
} lake_bool_from_int(ctx, lake_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,8 +348,8 @@ 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) \
sym_intern(ctx, name), \ env_define(ctx->toplevel, sym_intern(ctx, name), \
VAL(prim_make(name, arity, fn))) VAL(prim_make(name, arity, fn)))
DEFINE("car", _car, 1); DEFINE("car", _car, 1);
@ -356,5 +387,5 @@ void bind_primitives(LakeCtx *ctx)
/* string-concatenate */ /* string-concatenate */
/* string-slice */ /* string-slice */
#undef DEFINE #undef DEFINE
} }

73
src/repl.c
View file

@ -10,10 +10,6 @@
* *
*/ */
#include <errno.h>
#include <stdio.h>
#include <string.h>
#include <sys/select.h>
#include "common.h" #include "common.h"
#include "env.h" #include "env.h"
#include "eval.h" #include "eval.h"
@ -21,16 +17,18 @@
#include "list.h" #include "list.h"
#include "parse.h" #include "parse.h"
#include "str.h" #include "str.h"
#include <errno.h>
#include <stdio.h>
#include <string.h>
#include <sys/select.h>
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;
} }
@ -39,11 +37,14 @@ 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)) { if (feof(stdin))
{
return VAL(EOF); return VAL(EOF);
} }
return NULL; return NULL;
@ -52,7 +53,8 @@ static LakeVal *prompt_read(LakeCtx *ctx, Env *env, char *prompt)
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));
} }
@ -66,13 +68,16 @@ static LakeVal *prompt_read(LakeCtx *ctx, Env *env, char *prompt)
/* 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);
} }
@ -84,14 +89,17 @@ 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) { if (expr)
{
result = eval(ctx, env, expr); result = eval(ctx, env, expr);
if (result) print(result); if (result) print(result);
} }
@ -101,7 +109,8 @@ static void run_repl(LakeCtx *ctx, Env *env)
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;
@ -109,9 +118,11 @@ static char *read_file(char const *filename)
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();
} }
@ -119,7 +130,8 @@ static char *read_file(char const *filename)
i += read; i += read;
} }
s[i] = '\0'; s[i] = '\0';
if (ferror(fp)) { if (ferror(fp))
{
ERR("failed to read file %s: %s", filename, strerror(errno)); ERR("failed to read file %s: %s", filename, strerror(errno));
return NULL; return NULL;
} }
@ -127,13 +139,14 @@ static char *read_file(char const *filename)
return s; return s;
} }
else { else
{
ERR("cannot open file %s: %s", filename, strerror(errno)); ERR("cannot open file %s: %s", filename, strerror(errno));
return NULL; 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();
@ -141,7 +154,8 @@ int main (int argc, char const *argv[])
/* 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(lake_str_from_c((char *)argv[i])); argVals[i] = VAL(lake_str_from_c((char *)argv[i]));
} }
LakeList *args = list_from_array(argc, argVals); LakeList *args = list_from_array(argc, argVals);
@ -149,11 +163,14 @@ int main (int argc, char const *argv[])
env_define(ctx->toplevel, sym_intern(ctx, "args"), VAL(args)); env_define(ctx->toplevel, sym_intern(ctx, "args"), VAL(args));
/* if a filename is given load the file */ /* if a filename is given load the file */
if (argc > 1) { if (argc > 1)
{
char *text = read_file(argv[1]); char *text = read_file(argv[1]);
if (text) { if (text)
{
LakeList *exprs = parse_exprs(ctx, text, strlen(text)); LakeList *exprs = parse_exprs(ctx, text, strlen(text));
if (exprs) { if (exprs)
{
eval_exprs(ctx, ctx->toplevel, exprs); eval_exprs(ctx, ctx->toplevel, exprs);
} }
} }

31
src/str.c
View file

@ -7,12 +7,12 @@
* *
*/ */
#include <stdlib.h> #include "str.h"
#include <string.h>
#include "common.h" #include "common.h"
#include "int.h" #include "int.h"
#include "lake.h" #include "lake.h"
#include "str.h" #include <stdlib.h>
#include <string.h>
#define MIN(a, b) ((a) < (b) ? (a) : (b)) #define MIN(a, b) ((a) < (b) ? (a) : (b))
@ -44,25 +44,13 @@ LakeStr *lake_str_from_c(char *s)
return str; return str;
} }
LakeStr *lake_str_make(void) LakeStr *lake_str_make(void) { return lake_str_from_c(""); }
{
return lake_str_from_c("");
}
LakeInt *lake_str_len(LakeStr *str) LakeInt *lake_str_len(LakeStr *str) { return int_from_c(STR_N(str)); }
{
return int_from_c(STR_N(str));
}
LakeStr *lake_str_copy(LakeStr *str) LakeStr *lake_str_copy(LakeStr *str) { return lake_str_from_c(STR_S(str)); }
{
return lake_str_from_c(STR_S(str));
}
char *lake_str_val(LakeStr *str) char *lake_str_val(LakeStr *str) { return strndup(STR_S(str), STR_N(str)); }
{
return strndup(STR_S(str), STR_N(str));
}
bool lake_str_equal(LakeStr *a, LakeStr *b) bool lake_str_equal(LakeStr *a, LakeStr *b)
{ {
@ -71,7 +59,4 @@ bool lake_str_equal(LakeStr *a, LakeStr *b)
return strncmp(STR_S(a), STR_S(b), n) == 0; return strncmp(STR_S(a), STR_S(b), n) == 0;
} }
LakeStr *lake_str_to_str(LakeStr *str) LakeStr *lake_str_to_str(LakeStr *str) { return lake_str_copy(str); }
{
return lake_str_copy(str);
}

28
src/sym.c
View file

@ -7,15 +7,15 @@
* *
*/ */
#include <stdint.h> #include "sym.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "common.h" #include "common.h"
#include "env.h" #include "env.h"
#include "lake.h" #include "lake.h"
#include "str.h" #include "str.h"
#include "sym.h" #include <stdint.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
/* djb's hash /* djb's hash
* http://www.cse.yorku.ca/~oz/hash.html * http://www.cse.yorku.ca/~oz/hash.html
@ -42,7 +42,8 @@ static LakeSym *sym_alloc(void)
LakeSym *sym_intern(LakeCtx *ctx, char *s) LakeSym *sym_intern(LakeCtx *ctx, char *s)
{ {
LakeSym *sym = lake_hash_get(ctx->symbols, s); LakeSym *sym = lake_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);
@ -52,22 +53,13 @@ LakeSym *sym_intern(LakeCtx *ctx, char *s)
return sym; return sym;
} }
LakeStr *sym_to_str(LakeSym *sym) LakeStr *sym_to_str(LakeSym *sym) { return lake_str_from_c(sym->s); }
{
return lake_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;
}

17
test/laketest.c
View file

@ -9,14 +9,14 @@
* *
*/ */
#include "lake.h"
#include "eval.h"
#include "laketest.h"
#include "parse.h"
#include <fcntl.h> #include <fcntl.h>
#include <stdio.h> #include <stdio.h>
#include <string.h> #include <string.h>
#include <unistd.h> #include <unistd.h>
#include "eval.h"
#include "lake.h"
#include "laketest.h"
#include "parse.h"
static int captured = 0; static int captured = 0;
@ -54,16 +54,19 @@ int lt_run_tests(char *title, test_fn *tests)
test_fn test; test_fn test;
printf("-- %s --\n", title); printf("-- %s --\n", title);
capture_output(); capture_output();
while ((test = *(tests++))) { while ((test = *(tests++)))
{
if ((message = test())) break; if ((message = test())) break;
n_tests++; n_tests++;
} }
restore_output(); restore_output();
pass = message == 0; pass = message == 0;
if (pass) { if (pass)
{
fprintf(stderr, "PASS: %d test%s\n", n_tests, n_tests == 1 ? "" : "s"); fprintf(stderr, "PASS: %d test%s\n", n_tests, n_tests == 1 ? "" : "s");
} }
else { else
{
fprintf(stderr, "FAIL: %s\n", message); fprintf(stderr, "FAIL: %s\n", message);
} }
return pass; return pass;

13
test/laketest.h
View file

@ -9,16 +9,19 @@
* *
*/ */
#include <stdio.h>
#include "lake.h" #include "lake.h"
#include <stdio.h>
void restore_output(void); void restore_output(void);
#define lt_assert(message, test) do { \ #define lt_assert(message, test) \
if (!(test)) { \ do \
{ \
if (!(test)) \
{ \
restore_output(); \ restore_output(); \
fprintf(stderr, "%s:%d assertion failed: " #test "\n", \ fprintf(stderr, "%s:%d assertion failed: " #test "\n", __FILE__, \
__FILE__, __LINE__); \ __LINE__); \
return message; \ return message; \
} \ } \
} while (0) } while (0)

37
test/test_comment.c
View file

@ -7,11 +7,11 @@
* *
*/ */
#include <string.h>
#include "laketest.h"
#include "comment.h" #include "comment.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
#include "str.h" #include "str.h"
#include <string.h>
#define TEXT "you are not expected to understand this" #define TEXT "you are not expected to understand this"
@ -26,27 +26,22 @@ static LakeStr *text = NULL;
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
setup(); setup();
return !lt_run_tests("Comments", (test_fn[]){ return !lt_run_tests(
test_comment_make, "Comments", (test_fn[]){test_comment_make, test_comment_from_c,
test_comment_from_c, test_comment_repr, test_comment_equal, NULL});
test_comment_repr,
test_comment_equal,
NULL
});
} }
void setup(void) void setup(void) { text = lake_str_from_c(TEXT); }
{
text = lake_str_from_c(TEXT);
}
/* LakeComment *comment_make(LakeStr *text) */ /* LakeComment *comment_make(LakeStr *text) */
static char *test_comment_make(void) static char *test_comment_make(void)
{ {
LakeComment *comment = comment_make(text); LakeComment *comment = comment_make(text);
lt_assert("type is not TYPE_COMM", lake_is_type(TYPE_COMM, comment)); lt_assert("type is not TYPE_COMM", lake_is_type(TYPE_COMM, comment));
lt_assert("value size is incorrect", lake_val_size(comment) == sizeof(LakeComment)); lt_assert("value size is incorrect",
lt_assert("comment text is incorrect", lake_str_equal(text, COMM_TEXT(comment))); lake_val_size(comment) == sizeof(LakeComment));
lt_assert("comment text is incorrect",
lake_str_equal(text, COMM_TEXT(comment)));
return 0; return 0;
} }
@ -55,8 +50,10 @@ static char *test_comment_from_c(void)
{ {
LakeComment *comment = comment_from_c(TEXT); LakeComment *comment = comment_from_c(TEXT);
lt_assert("type is not TYPE_COMM", lake_is_type(TYPE_COMM, comment)); lt_assert("type is not TYPE_COMM", lake_is_type(TYPE_COMM, comment));
lt_assert("value size is incorrect", lake_val_size(comment) == sizeof(LakeComment)); lt_assert("value size is incorrect",
lt_assert("comment text is incorrect", lake_str_equal(text, COMM_TEXT(comment))); lake_val_size(comment) == sizeof(LakeComment));
lt_assert("comment text is incorrect",
lake_str_equal(text, COMM_TEXT(comment)));
return 0; return 0;
} }
@ -64,7 +61,8 @@ static char *test_comment_from_c(void)
static char *test_comment_repr(void) static char *test_comment_repr(void)
{ {
LakeComment *comment = comment_make(text); LakeComment *comment = comment_make(text);
lt_assert("comment_repr is incorrect", strncmp(comment_repr(comment), TEXT, strlen(TEXT)) == 0); lt_assert("comment_repr is incorrect",
strncmp(comment_repr(comment), TEXT, strlen(TEXT)) == 0);
return 0; return 0;
} }
@ -73,7 +71,8 @@ static char *test_comment_equal(void)
{ {
LakeComment *a = comment_make(text); LakeComment *a = comment_make(text);
LakeComment *b = comment_from_c(TEXT); LakeComment *b = comment_from_c(TEXT);
LakeComment *c = comment_from_c("and now for something completely different"); LakeComment *c =
comment_from_c("and now for something completely different");
lt_assert("comment a != a", comment_equal(a, a)); lt_assert("comment a != a", comment_equal(a, a));
lt_assert("comment a != b", comment_equal(a, b)); lt_assert("comment a != b", comment_equal(a, b));
lt_assert("comment a == c", !comment_equal(a, c)); lt_assert("comment a == c", !comment_equal(a, c));

19
test/test_dlist.c
View file

@ -7,11 +7,11 @@
* *
*/ */
#include <string.h>
#include "common.h" #include "common.h"
#include "laketest.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
#include "list.h" #include "list.h"
#include <string.h>
void setup(void); void setup(void);
static char *test_dlist_make(void); static char *test_dlist_make(void);
@ -26,12 +26,9 @@ static char *REPR = "(() . ())";
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
setup(); setup();
return !lt_run_tests("Dotted Lists", (test_fn[]){ return !lt_run_tests(
test_dlist_make, "Dotted Lists",
test_dlist_repr, (test_fn[]){test_dlist_make, test_dlist_repr, test_dlist_equal, NULL});
test_dlist_equal,
NULL
});
} }
void setup(void) void setup(void)
@ -45,7 +42,8 @@ void setup(void)
static char *test_dlist_make(void) static char *test_dlist_make(void)
{ {
lt_assert("type is not TYPE_DLIST", lake_is_type(TYPE_DLIST, dlist)); lt_assert("type is not TYPE_DLIST", lake_is_type(TYPE_DLIST, dlist));
lt_assert("value size is incorrect", lake_val_size(dlist) == sizeof(LakeDottedList)); lt_assert("value size is incorrect",
lake_val_size(dlist) == sizeof(LakeDottedList));
lt_assert("head value is incorrect", lt_assert("head value is incorrect",
lake_equal(VAL(head), VAL(dlist_head(dlist)))); lake_equal(VAL(head), VAL(dlist_head(dlist))));
lt_assert("tail value is incorrect", lake_equal(tail, dlist_tail(dlist))); lt_assert("tail value is incorrect", lake_equal(tail, dlist_tail(dlist)));
@ -55,7 +53,8 @@ static char *test_dlist_make(void)
/* char *dlist_repr(LakeDottedList *dlist) */ /* char *dlist_repr(LakeDottedList *dlist) */
static char *test_dlist_repr(void) static char *test_dlist_repr(void)
{ {
lt_assert("dlist_repr is incorrect", strncmp(dlist_repr(dlist), REPR, strlen(REPR)) == 0); lt_assert("dlist_repr is incorrect",
strncmp(dlist_repr(dlist), REPR, strlen(REPR)) == 0);
char *REPR2 = "(spam eggs bacon spam eggs . spam)"; char *REPR2 = "(spam eggs bacon spam eggs . spam)";
LakeCtx *lake = lake_init(); LakeCtx *lake = lake_init();

16
test/test_env.c
View file

@ -8,9 +8,9 @@
*/ */
#include "common.h" #include "common.h"
#include "laketest.h"
#include "env.h" #include "env.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
void setup(void); void setup(void);
static char *test_env_make(void); static char *test_env_make(void);
@ -31,14 +31,9 @@ static LakeSym *s_undef;
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
setup(); setup();
return !lt_run_tests("Environment", (test_fn[]){ return !lt_run_tests(
test_env_make, "Environment", (test_fn[]){test_env_make, test_env_define, test_env_set,
test_env_define, test_env_get, test_env_is_defined, NULL});
test_env_set,
test_env_get,
test_env_is_defined,
NULL
});
} }
void setup(void) void setup(void)
@ -59,7 +54,8 @@ static char *test_env_make(void)
lt_assert("toplevel->bindings is NULL", toplevel->bindings != NULL); lt_assert("toplevel->bindings is NULL", toplevel->bindings != NULL);
lt_assert("firstlevel is NULL", firstlevel != NULL); lt_assert("firstlevel is NULL", firstlevel != NULL);
lt_assert("firstlevel->parent is not toplevel", firstlevel->parent == toplevel); lt_assert("firstlevel->parent is not toplevel",
firstlevel->parent == toplevel);
return 0; return 0;
} }

29
test/test_eval.c
View file

@ -7,10 +7,10 @@
* *
*/ */
#include "laketest.h"
#include "env.h" #include "env.h"
#include "eval.h" #include "eval.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
#include "parse.h" #include "parse.h"
void setup(void); void setup(void);
@ -31,13 +31,9 @@ static LakePrimitive *p_cdr;
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
setup(); setup();
return !lt_run_tests("Eval & Apply", (test_fn[]){ return !lt_run_tests("Eval & Apply",
test_eval, (test_fn[]){test_eval, test_eval_exprs,
test_eval_exprs, test_eval_exprs1, test_apply, NULL});
test_eval_exprs1,
test_apply,
NULL
});
} }
void setup(void) void setup(void)
@ -125,10 +121,12 @@ static char *test_eval(void)
LakeSym *l_bound_sym = isP; LakeSym *l_bound_sym = isP;
LakeSym *l_unbound_sym = sym_intern(lake, "sex"); LakeSym *l_unbound_sym = sym_intern(lake, "sex");
lt_assert("bound symbol is? evaluated to null", NULL != EVAL(l_bound_sym)); lt_assert("bound symbol is? evaluated to null", NULL != EVAL(l_bound_sym));
lt_assert("unbound symbol evaluated to non-null", NULL == EVAL(l_unbound_sym)); lt_assert("unbound symbol evaluated to non-null",
NULL == EVAL(l_unbound_sym));
LakeList *l_call = list_make(); LakeList *l_call = list_make();
lt_assert("empty list (nil) did not self evaluate", VAL(l_call) == EVAL(l_call)); lt_assert("empty list (nil) did not self evaluate",
VAL(l_call) == EVAL(l_call));
LakeDottedList *l_dlist = dlist_make(list_make(), VAL(l_int)); LakeDottedList *l_dlist = dlist_make(list_make(), VAL(l_int));
lt_assert("dotted-list evaluated to non-null", NULL == EVAL(l_dlist)); lt_assert("dotted-list evaluated to non-null", NULL == EVAL(l_dlist));
@ -137,7 +135,8 @@ static char *test_eval(void)
LakeSym *s_x = sym_intern(lake, "x"); LakeSym *s_x = sym_intern(lake, "x");
list_append(l_call, VAL(s_x)); list_append(l_call, VAL(s_x));
list_append(l_call, VAL(l_int)); list_append(l_call, VAL(l_int));
lt_assert("define special form evaluated to non-null", NULL == EVAL(l_call)); lt_assert("define special form evaluated to non-null",
NULL == EVAL(l_call));
lt_assert("define bound an incorrect value", VAL(l_int) == EVAL(s_x)); lt_assert("define bound an incorrect value", VAL(l_int) == EVAL(s_x));
list_free(l_call); list_free(l_call);
@ -145,7 +144,8 @@ static char *test_eval(void)
list_append(l_call, VAL(isP)); list_append(l_call, VAL(isP));
list_append(l_call, VAL(s_x)); list_append(l_call, VAL(s_x));
list_append(l_call, VAL(l_int)); list_append(l_call, VAL(l_int));
lt_assert("primitive evaluated incorrectly", lake_is_true(lake, EVAL(l_call))); lt_assert("primitive evaluated incorrectly",
lake_is_true(lake, EVAL(l_call)));
list_free(l_call); list_free(l_call);
return 0; return 0;
@ -175,7 +175,6 @@ static char *test_apply(void)
NULL == apply(lake, fnVal, args)); NULL == apply(lake, fnVal, args));
list_free(args); list_free(args);
/* var args primitive */ /* var args primitive */
fnVal = EVAL(sym_intern(lake, "+")); fnVal = EVAL(sym_intern(lake, "+"));
args = list_make(); args = list_make();
@ -192,7 +191,6 @@ static char *test_apply(void)
6 == INT_VAL(INT(apply(lake, fnVal, args)))); 6 == INT_VAL(INT(apply(lake, fnVal, args))));
list_free(args); list_free(args);
/* set up a scheme function with fixed args */ /* set up a scheme function with fixed args */
eval(lake, lake->toplevel, eval(lake, lake->toplevel,
parse_expr(lake, "(define zero? (lambda (x) (= x 0)))", 35)); parse_expr(lake, "(define zero? (lambda (x) (= x 0)))", 35));
@ -212,7 +210,6 @@ static char *test_apply(void)
lt_assert("function applied incorrectly", NULL == apply(lake, fnVal, args)); lt_assert("function applied incorrectly", NULL == apply(lake, fnVal, args));
list_free(args); list_free(args);
/* set up a scheme function with only var args */ /* set up a scheme function with only var args */
eval(lake, lake->toplevel, eval(lake, lake->toplevel,
parse_expr(lake, "(define list (lambda rest rest))", 32)); parse_expr(lake, "(define list (lambda rest rest))", 32));
@ -234,7 +231,6 @@ static char *test_apply(void)
NULL != apply(lake, fnVal, args)); NULL != apply(lake, fnVal, args));
list_free(args); list_free(args);
/* set up a scheme function with fixed and var args */ /* set up a scheme function with fixed and var args */
eval(lake, lake->toplevel, eval(lake, lake->toplevel,
parse_expr(lake, "(define frob (lambda (a b . rest) b))", 37)); parse_expr(lake, "(define frob (lambda (a b . rest) b))", 37));
@ -262,7 +258,6 @@ static char *test_apply(void)
NULL != apply(lake, fnVal, args)); NULL != apply(lake, fnVal, args));
list_free(args); list_free(args);
/* non-function in head position */ /* non-function in head position */
lt_assert("apply with non-function returned non-null", lt_assert("apply with non-function returned non-null",
NULL == apply(lake, VAL(sym), list_make())); NULL == apply(lake, VAL(sym), list_make()));

14
test/test_fn.c
View file

@ -7,26 +7,24 @@
* *
*/ */
#include <string.h>
#include "laketest.h"
#include "env.h" #include "env.h"
#include "eval.h" #include "eval.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
#include "parse.h" #include "parse.h"
#include <string.h>
static char *test_fn_make(void); static char *test_fn_make(void);
static char *test_fn_repr(void); static char *test_fn_repr(void);
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
return !lt_run_tests("Functions", (test_fn[]){ return !lt_run_tests("Functions",
test_fn_make, (test_fn[]){test_fn_make, test_fn_repr, NULL});
test_fn_repr,
NULL
});
} }
/* LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env *closure) */ /* LakeFn *fn_make(LakeList *params, LakeSym *varargs, LakeList *body, Env
* *closure) */
static char *test_fn_make(void) static char *test_fn_make(void)
{ {
LakeList *params = list_make(); LakeList *params = list_make();

12
test/test_int.c
View file

@ -7,10 +7,10 @@
* *
*/ */
#include <string.h>
#include "int.h" #include "int.h"
#include "laketest.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
#include <string.h>
static char *test_int_make(void); static char *test_int_make(void);
static char *test_int_from_c(void); static char *test_int_from_c(void);
@ -18,12 +18,8 @@ static char *test_int_repr(void);
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
return !lt_run_tests("Integers", (test_fn[]){ return !lt_run_tests("Integers", (test_fn[]){test_int_make, test_int_from_c,
test_int_make, test_int_repr, NULL});
test_int_from_c,
test_int_repr,
NULL
});
} }
/* LakeInt *int_make(void) */ /* LakeInt *int_make(void) */

52
test/test_lake.c
View file

@ -7,15 +7,15 @@
* *
*/ */
#include <string.h>
#include "laketest.h"
#include "bool.h" #include "bool.h"
#include "eval.h"
#include "int.h" #include "int.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
#include "parse.h"
#include "str.h" #include "str.h"
#include "sym.h" #include "sym.h"
#include "eval.h" #include <string.h>
#include "parse.h"
void setup(void); void setup(void);
static char *test_lake_version(void); static char *test_lake_version(void);
@ -29,20 +29,12 @@ static LakeCtx *lake;
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
setup(); setup();
return !lt_run_tests("Lake", (test_fn[]){ return !lt_run_tests("Lake", (test_fn[]){test_lake_version, test_lake_init,
test_lake_version, test_lake_is, test_lake_equal,
test_lake_init, test_lake_repr, NULL});
test_lake_is,
test_lake_equal,
test_lake_repr,
NULL
});
} }
void setup(void) void setup(void) { lake = lake_init(); }
{
lake = lake_init();
}
/* #define LAKE_VERSION "0.1" */ /* #define LAKE_VERSION "0.1" */
static char *test_lake_version(void) static char *test_lake_version(void)
@ -68,10 +60,7 @@ static char *test_lake_init(void)
return 0; return 0;
} }
static bool _is(void *a, void *b) static bool _is(void *a, void *b) { return lake_is(VAL(a), VAL(b)); }
{
return lake_is(VAL(a), VAL(b));
}
/* bool lake_is(LakeVal *a, LakeVal *b) */ /* bool lake_is(LakeVal *a, LakeVal *b) */
static char *test_lake_is(void) static char *test_lake_is(void)
@ -79,7 +68,8 @@ static char *test_lake_is(void)
LakeInt *i = int_from_c(42); LakeInt *i = int_from_c(42);
// ints are compared by value // ints are compared by value
lt_assert("ints with equal values are not the same", _is(i, int_from_c(42))); lt_assert("ints with equal values are not the same",
_is(i, int_from_c(42)));
// nil is compared by value // nil is compared by value
lt_assert("null values are not the same", _is(list_make(), list_make())); lt_assert("null values are not the same", _is(list_make(), list_make()));
@ -95,10 +85,7 @@ static char *test_lake_is(void)
return 0; return 0;
} }
static bool _equal(void *a, void *b) static bool _equal(void *a, void *b) { return lake_equal(VAL(a), VAL(b)); }
{
return lake_equal(VAL(a), VAL(b));
}
/* bool lake_equal(LakeVal *a, LakeVal *b) */ /* bool lake_equal(LakeVal *a, LakeVal *b) */
static char *test_lake_equal(void) static char *test_lake_equal(void)
@ -128,7 +115,8 @@ static char *test_lake_equal(void)
LakePrimitive *pair = PRIM(lt_eval(lake, "pair?")); LakePrimitive *pair = PRIM(lt_eval(lake, "pair?"));
lt_assert("primitive is not equal to itself", _equal(null, null)); lt_assert("primitive is not equal to itself", _equal(null, null));
lt_assert("primitive is not equal to itself", _equal(null, null2)); lt_assert("primitive is not equal to itself", _equal(null, null2));
lt_assert("different primitives are equal to each other", !_equal(null, pair)); lt_assert("different primitives are equal to each other",
!_equal(null, pair));
// functions are compared by reference // functions are compared by reference
LakeFn *inc = FN(lt_eval(lake, "(lambda (x) (+ x 1))")); LakeFn *inc = FN(lt_eval(lake, "(lambda (x) (+ x 1))"));
@ -147,8 +135,8 @@ static char *test_lake_equal(void)
lt_assert("string is not equal to itself", _equal(arthur, arthur2)); lt_assert("string is not equal to itself", _equal(arthur, arthur2));
lt_assert("different strings are equal", !_equal(arthur, zaphod)); lt_assert("different strings are equal", !_equal(arthur, zaphod));
// lists are compared by value // lists are compared by value
#define S(s) VAL(lake_str_from_c(s)) #define S(s) VAL(lake_str_from_c(s))
LakeList *fruits = list_make(); LakeList *fruits = list_make();
list_append(fruits, S("mango")); list_append(fruits, S("mango"));
list_append(fruits, S("pear")); list_append(fruits, S("pear"));
@ -164,8 +152,9 @@ static char *test_lake_equal(void)
lt_assert("different lists are equal", !_equal(fruits, ninjas)); lt_assert("different lists are equal", !_equal(fruits, ninjas));
LakeList *fruits_copy = list_copy(fruits); LakeList *fruits_copy = list_copy(fruits);
lt_assert("copy of list is not equal to original", _equal(fruits, fruits_copy)); lt_assert("copy of list is not equal to original",
#undef S _equal(fruits, fruits_copy));
#undef S
// dotted lists are compared by value // dotted lists are compared by value
LakeDottedList *destruction = dlist_make(fruits, VAL(ninjas)); LakeDottedList *destruction = dlist_make(fruits, VAL(ninjas));
@ -208,7 +197,8 @@ static char *test_lake_repr(void)
list_append(vals, VAL(vals)); list_append(vals, VAL(vals));
list_append(vals, VAL(dlist_make(vals, VAL(int_from_c(4919))))); list_append(vals, VAL(dlist_make(vals, VAL(int_from_c(4919)))));
list_append(vals, eval(lake, lake->toplevel, parse_expr(lake, "null?", 5))); list_append(vals, eval(lake, lake->toplevel, parse_expr(lake, "null?", 5)));
list_append(vals, eval(lake, lake->toplevel, parse_expr(lake, "(lambda xs xs)", 14))); list_append(vals, eval(lake, lake->toplevel,
parse_expr(lake, "(lambda xs xs)", 14)));
list_append(vals, VAL(comment_from_c("this is a comment"))); list_append(vals, VAL(comment_from_c("this is a comment")));
return 0; return 0;

104
test/test_list.c
View file

@ -7,10 +7,10 @@
* *
*/ */
#include <string.h>
#include "laketest.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
#include "list.h" #include "list.h"
#include <string.h>
void setup(void); void setup(void);
static char *test_list_make(void); static char *test_list_make(void);
@ -32,24 +32,13 @@ static char *test_list_repr(void);
int main(int argc, char const *argv[]) int main(int argc, char const *argv[])
{ {
setup(); setup();
return !lt_run_tests("List", (test_fn[]){ return !lt_run_tests(
test_list_make, "List", (test_fn[]){test_list_make, test_list_cons,
test_list_cons, test_list_make_with_capacity, test_list_from_array,
test_list_make_with_capacity, test_list_copy, test_list_set, test_list_append,
test_list_from_array, test_list_get, test_list_len, test_list_pop,
test_list_copy, test_list_shift, test_list_unshift, test_list_equal,
test_list_set, test_list_to_str, test_list_repr, NULL});
test_list_append,
test_list_get,
test_list_len,
test_list_pop,
test_list_shift,
test_list_unshift,
test_list_equal,
test_list_to_str,
test_list_repr,
NULL
});
} }
void setup(void) void setup(void)
@ -58,91 +47,46 @@ void setup(void)
} }
/* LakeList *list_make(void) */ /* LakeList *list_make(void) */
static char *test_list_make(void) static char *test_list_make(void) { return 0; }
{
return 0;
}
/* LakeList *list_cons(LakeVal *car, LakeVal *cdr) */ /* LakeList *list_cons(LakeVal *car, LakeVal *cdr) */
static char *test_list_cons(void) static char *test_list_cons(void) { return 0; }
{
return 0;
}
/* LakeList *list_make_with_capacity(size_t cap) */ /* LakeList *list_make_with_capacity(size_t cap) */
static char *test_list_make_with_capacity(void) static char *test_list_make_with_capacity(void) { return 0; }
{
return 0;
}
/* LakeList *list_from_array(size_t n, LakeVal *vals[]) */ /* LakeList *list_from_array(size_t n, LakeVal *vals[]) */
static char *test_list_from_array(void) static char *test_list_from_array(void) { return 0; }
{
return 0;
}
/* LakeList *list_copy(LakeList *list) */ /* LakeList *list_copy(LakeList *list) */
static char *test_list_copy(void) static char *test_list_copy(void) { return 0; }
{
return 0;
}
/* LakeVal *list_set(LakeList *list, size_t i, LakeVal *val) */ /* LakeVal *list_set(LakeList *list, size_t i, LakeVal *val) */
static char *test_list_set(void) static char *test_list_set(void) { return 0; }
{
return 0;
}
/* LakeVal *list_append(LakeList *list, LakeVal *val) */ /* LakeVal *list_append(LakeList *list, LakeVal *val) */
static char *test_list_append(void) static char *test_list_append(void) { return 0; }
{
return 0;
}
/* LakeVal *list_get(LakeList *list, LakeInt *li) */ /* LakeVal *list_get(LakeList *list, LakeInt *li) */
static char *test_list_get(void) static char *test_list_get(void) { return 0; }
{
return 0;
}
/* LakeInt *list_len(LakeList *list) */ /* LakeInt *list_len(LakeList *list) */
static char *test_list_len(void) static char *test_list_len(void) { return 0; }
{
return 0;
}
/* LakeVal *list_pop(LakeList *list) */ /* LakeVal *list_pop(LakeList *list) */
static char *test_list_pop(void) static char *test_list_pop(void) { return 0; }
{
return 0;
}
/* LakeVal *list_shift(LakeList *list) */ /* LakeVal *list_shift(LakeList *list) */
static char *test_list_shift(void) static char *test_list_shift(void) { return 0; }
{
return 0;
}
/* LakeVal *list_unshift(LakeList *list, LakeVal *val) */ /* LakeVal *list_unshift(LakeList *list, LakeVal *val) */
static char *test_list_unshift(void) static char *test_list_unshift(void) { return 0; }
{
return 0;
}
/* int list_equal(LakeList *a, LakeList *b) */ /* int list_equal(LakeList *a, LakeList *b) */
static char *test_list_equal(void) static char *test_list_equal(void) { return 0; }
{
return 0;
}
/* LakeStr *list_to_str(LakeList *list) */ /* LakeStr *list_to_str(LakeList *list) */
static char *test_list_to_str(void) static char *test_list_to_str(void) { return 0; }
{
return 0;
}
/* char *list_repr(LakeList *list) */ /* char *list_repr(LakeList *list) */
static char *test_list_repr(void) static char *test_list_repr(void) { return 0; }
{
return 0;
}

2
test/test_parse.c
View file

@ -12,8 +12,8 @@
#ifndef _LAKE_PARSE_H #ifndef _LAKE_PARSE_H
#define _LAKE_PARSE_H #define _LAKE_PARSE_H
#include <stdlib.h>
#include "lake.h" #include "lake.h"
#include <stdlib.h>
#define PARSE_EOF -1 #define PARSE_EOF -1
#define PARSE_ERR -2 #define PARSE_ERR -2

2
test/test_str.c
View file

@ -8,8 +8,8 @@
*/ */
#include "common.h" #include "common.h"
#include "laketest.h"
#include "lake.h" #include "lake.h"
#include "laketest.h"
/* LakeStr *lake_str_make(void) */ /* LakeStr *lake_str_make(void) */
/* void lake_str_free(LakeStr *str) */ /* void lake_str_free(LakeStr *str) */