From 792fcd879f5e10ecb977ed7a713fc09b7bb4afa7 Mon Sep 17 00:00:00 2001 From: Sami Samhuri Date: Sat, 11 Jun 2011 02:11:49 -0700 Subject: [PATCH] add real bools, remove macros, print circular lists --- src/Makefile | 1 + src/bool.c | 58 ++++++++++++++++++++++++ src/bool.h | 26 +++++++++++ src/comment.c | 3 +- src/comment.h | 4 +- src/common.h | 23 ++++++++++ src/dlist.c | 22 +++++++--- src/dlist.h | 6 ++- src/env.c | 1 + src/env.h | 1 + src/eval.c | 104 ++++++++++++++++++++++++-------------------- src/eval.h | 5 ++- src/fn.c | 5 ++- src/int.c | 1 + src/lake.c | 57 ++++++++++++++++-------- src/lake.h | 34 ++++----------- src/list.c | 14 ++++-- src/list.h | 3 +- src/parse.c | 17 ++++---- src/primitive.c | 41 ++++++++++------- src/repl.c | 1 + src/str.c | 3 +- src/str.h | 3 +- src/sym.c | 1 + src/symtable.c | 5 ++- src/symtable.h | 1 + test/test_comment.c | 10 ++--- test/test_dlist.c | 11 ++--- test/test_env.c | 1 + test/test_lake.c | 18 ++++---- 30 files changed, 325 insertions(+), 155 deletions(-) create mode 100644 src/bool.c create mode 100644 src/bool.h create mode 100644 src/common.h diff --git a/src/Makefile b/src/Makefile index b4a007f..6e9e8b7 100644 --- a/src/Makefile +++ b/src/Makefile @@ -3,6 +3,7 @@ CC = gcc CFLAGS := -Wall -g $(shell pkg-config --cflags glib-2.0) LFLAGS := $(shell pkg-config --libs glib-2.0) LAKE_OBJS = $(LAKE_BUILD)/comment.o \ + $(LAKE_BUILD)/bool.o \ $(LAKE_BUILD)/dlist.o \ $(LAKE_BUILD)/env.o \ $(LAKE_BUILD)/eval.o \ diff --git a/src/bool.c b/src/bool.c new file mode 100644 index 0000000..a94668f --- /dev/null +++ b/src/bool.c @@ -0,0 +1,58 @@ +/** + * bool.c + * Lake Scheme + * + * Copyright 2011 Sami Samhuri + * MIT License + * + */ + +#include +#include "bool.h" +#include "common.h" +#include "lake.h" + +bool lk_bool_val(LakeBool *b) +{ + return b->val; +} + +bool lk_is_true(LakeCtx *ctx, LakeVal *x) +{ + return VAL(x) == VAL(ctx->T); +} + +bool lk_is_false(LakeCtx *ctx, LakeVal *x) +{ + return VAL(x) == VAL(ctx->F); +} + +bool lk_is_truthy(LakeCtx *ctx, LakeVal *x) +{ + return !lk_is_false(ctx, x); +} + +bool lk_is_falsy(LakeCtx *ctx, LakeVal *x) +{ + return lk_is_false(ctx, x); +} + +LakeBool *lk_bool_from_int(LakeCtx *ctx, int n) +{ + return n ? ctx->T : ctx->F; +} + +char *lk_bool_repr(LakeBool *b) +{ + return g_strdup(lk_bool_val(b) ? "#t" : "#f"); +} + +LakeVal *lk_bool_and(LakeCtx *ctx, LakeVal *x, LakeVal *y) +{ + return lk_is_truthy(ctx, x) && lk_is_truthy(ctx, y) ? y : x; +} + +LakeVal *lk_bool_or(LakeCtx *ctx, LakeVal *x, LakeVal *y) +{ + return lk_is_truthy(ctx, x) ? x : y; +} diff --git a/src/bool.h b/src/bool.h new file mode 100644 index 0000000..d703d01 --- /dev/null +++ b/src/bool.h @@ -0,0 +1,26 @@ +/** + * bool.h + * Lake Scheme + * + * Copyright 2011 Sami Samhuri + * MIT License + * + */ + +#ifndef _LAKE_BOOL_H +#define _LAKE_BOOL_H 1 + +#include "common.h" +#include "lake.h" + +bool lk_bool_val(LakeBool *b); +bool lk_is_true(LakeCtx *ctx, LakeVal *x); +bool lk_is_false(LakeCtx *ctx, LakeVal *x); +bool lk_is_truthy(LakeCtx *ctx, LakeVal *x); +bool lk_is_falsy(LakeCtx *ctx, LakeVal *x); +LakeBool *lk_bool_from_int(LakeCtx *ctx, int n); +char *lk_bool_repr(LakeBool *b); +LakeVal *lk_bool_and(LakeCtx *ctx, LakeVal *x, LakeVal *y); +LakeVal *lk_bool_or(LakeCtx *ctx, LakeVal *x, LakeVal *y); + +#endif diff --git a/src/comment.c b/src/comment.c index 279c58f..e19559f 100644 --- a/src/comment.c +++ b/src/comment.c @@ -8,6 +8,7 @@ */ #include +#include "common.h" #include "comment.h" #include "lake.h" #include "str.h" @@ -37,7 +38,7 @@ char *comment_repr(LakeComment *comment) return g_strdup(STR_S(comment->text)); } -gboolean comment_equal(LakeComment *a, LakeComment *b) +bool comment_equal(LakeComment *a, LakeComment *b) { return str_equal(COMM_TEXT(a), COMM_TEXT(b)); } diff --git a/src/comment.h b/src/comment.h index 4824f3a..b8ff7f8 100644 --- a/src/comment.h +++ b/src/comment.h @@ -10,12 +10,12 @@ #ifndef _LAKE_COMMENT_H #define _LAKE_COMMENT_H 1 -#include +#include "common.h" #include "lake.h" LakeComment *comment_make(LakeStr *text); LakeComment *comment_from_c(char *text); char *comment_repr(LakeComment *comment); -gboolean comment_equal(LakeComment *a, LakeComment *b); +bool comment_equal(LakeComment *a, LakeComment *b); #endif diff --git a/src/common.h b/src/common.h new file mode 100644 index 0000000..f5125d9 --- /dev/null +++ b/src/common.h @@ -0,0 +1,23 @@ +/** + * common.h + * Lake Scheme + * + * Copyright 2011 Sami Samhuri + * MIT License + * + */ + +#ifndef _LAKE_COMMON_H +#define _LAKE_COMMON_H 1 + +typedef int bool; + +#ifndef TRUE +#define TRUE 1 +#endif + +#ifndef FALSE +#define FALSE 0 +#endif + +#endif diff --git a/src/dlist.c b/src/dlist.c index 5969f16..cec4b04 100644 --- a/src/dlist.c +++ b/src/dlist.c @@ -26,6 +26,16 @@ LakeDottedList *dlist_make(LakeList *head, LakeVal *tail) return dlist; } +LakeList *dlist_head(LakeDottedList *dlist) +{ + return dlist->head; +} + +LakeVal *dlist_tail(LakeDottedList *dlist) +{ + return dlist->tail; +} + char *dlist_repr(LakeDottedList *dlist) { GString *s = g_string_new("("); @@ -40,7 +50,7 @@ char *dlist_repr(LakeDottedList *dlist) } } else if (dlist->head) { - s2 = lake_repr(VAL(dlist->head)); + s2 = lake_repr(dlist->head); g_string_append(s, s2); g_free(s2); } @@ -54,11 +64,11 @@ char *dlist_repr(LakeDottedList *dlist) return repr; } -gboolean dlist_equal(LakeDottedList *a, LakeDottedList *b) +bool dlist_equal(LakeDottedList *a, LakeDottedList *b) { - LakeVal *headA = VAL(DLIST_HEAD(a)); - LakeVal *tailA = DLIST_TAIL(a); - LakeVal *headB = VAL(DLIST_HEAD(b)); - LakeVal *tailB = DLIST_TAIL(b); + LakeVal *headA = VAL(dlist_head(a)); + LakeVal *tailA = dlist_tail(a); + LakeVal *headB = VAL(dlist_head(b)); + LakeVal *tailB = dlist_tail(b); return lake_equal(headA, headB) && lake_equal(tailA, tailB); } diff --git a/src/dlist.h b/src/dlist.h index df767e6..b11456b 100644 --- a/src/dlist.h +++ b/src/dlist.h @@ -10,11 +10,13 @@ #ifndef _LAKE_DLIST_H #define _LAKE_DLIST_H 1 -#include +#include "common.h" #include "lake.h" LakeDottedList *dlist_make(LakeList *head, LakeVal *tail); +LakeList *dlist_head(LakeDottedList *dlist); +LakeVal *dlist_tail(LakeDottedList *dlist); char *dlist_repr(LakeDottedList *dlist); -gboolean dlist_equal(LakeDottedList *a, LakeDottedList *b); +bool dlist_equal(LakeDottedList *a, LakeDottedList *b); #endif diff --git a/src/env.c b/src/env.c index 055d07c..4e37032 100644 --- a/src/env.c +++ b/src/env.c @@ -10,6 +10,7 @@ #include #include #include +#include "common.h" #include "lake.h" #include "env.h" #include "symtable.h" diff --git a/src/env.h b/src/env.h index fca5c37..009934a 100644 --- a/src/env.h +++ b/src/env.h @@ -11,6 +11,7 @@ #define _LAKE_ENV_H 1 #include +#include "common.h" struct env { struct env *parent; diff --git a/src/eval.c b/src/eval.c index 6968fac..416f148 100644 --- a/src/eval.c +++ b/src/eval.c @@ -10,16 +10,20 @@ #include #include #include +#include +#include "bool.h" +#include "common.h" #include "env.h" #include "eval.h" #include "fn.h" #include "lake.h" +#include "parse.h" typedef LakeVal *(*special_form_handler)(LakeCtx *ctx, Env *env, LakeList *expr); static void invalid_special_form(LakeList *expr, char *detail) { - ERR("malformed special form, %s: %s", detail, lake_repr(VAL(expr))); + ERR("malformed special form, %s: %s", detail, lake_repr(expr)); } /* expr begins with the symbol "quote" so the quoted value is the 2nd value */ @@ -39,8 +43,8 @@ static LakeVal *_and(LakeCtx *ctx, Env *env, LakeList *expr) /* (and ...) */ LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->T); - while (IS_TRUTHY(ctx, result) && LIST_N(expr) > 0) { - result = BOOL_AND(ctx, result, eval(ctx, env, list_shift(expr))); + while (lk_is_truthy(ctx, result) && LIST_N(expr) > 0) { + result = lk_bool_and(ctx, result, eval(ctx, env, list_shift(expr))); } return result; } @@ -52,8 +56,8 @@ static LakeVal *_or(LakeCtx *ctx, Env *env, LakeList *expr) /* (or ...) */ LakeVal *result = LIST_N(expr) ? eval(ctx, env, list_shift(expr)) : VAL(ctx->F); - while (IS_FALSY(ctx, result) && LIST_N(expr) > 0) { - result = BOOL_OR(ctx, result, eval(ctx, env, list_shift(expr))); + while (lk_is_falsy(ctx, result) && LIST_N(expr) > 0) { + result = lk_bool_or(ctx, result, eval(ctx, env, list_shift(expr))); } return result; } @@ -61,12 +65,12 @@ static LakeVal *_or(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_setB(LakeCtx *ctx, Env *env, LakeList *expr) { /* (set! x 42) */ - if (LIST_N(expr) == 3 && IS(TYPE_SYM, LIST_VAL(expr, 1))) { + if (LIST_N(expr) == 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { list_shift(expr); /* drop the "set!" symbol */ LakeSym *var = SYM(list_shift(expr)); LakeVal *form = list_shift(expr); if (!env_set(env, var, form)) { - ERR("%s is not defined", SYM_S(var)); + ERR("%s is not defined", sym_repr(var)); } } else { @@ -80,7 +84,7 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr) /* TODO: make these more robust, check all expected params */ /* (define x 42) */ - if (LIST_N(expr) == 3 && IS(TYPE_SYM, LIST_VAL(expr, 1))) { + if (LIST_N(expr) == 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { list_shift(expr); /* drop the "define" symbol */ LakeSym *var = SYM(list_shift(expr)); LakeVal *form = list_shift(expr); @@ -88,7 +92,7 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr) } /* (define (inc x) (+ 1 x)) */ - else if (LIST_N(expr) >= 3 && IS(TYPE_LIST, LIST_VAL(expr, 1))) { + else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_LIST, LIST_VAL(expr, 1))) { list_shift(expr); /* drop the "define" symbol */ LakeList *params = LIST(list_shift(expr)); LakeSym *var = SYM(list_shift(params)); @@ -97,11 +101,11 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr) } /* (define (print format . args) (...)) */ - else if (LIST_N(expr) >= 3 && IS(TYPE_DLIST, LIST_VAL(expr, 1))) { + else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) { list_shift(expr); /* drop the "define" symbol */ LakeDottedList *def = DLIST(list_shift(expr)); - LakeList *params = DLIST_HEAD(def); - LakeSym *varargs = SYM(DLIST_TAIL(def)); + LakeList *params = dlist_head(def); + LakeSym *varargs = SYM(dlist_tail(def)); LakeSym *var = SYM(list_shift(params)); LakeList *body = expr; env_define(env, var, VAL(fn_make(params, varargs, body, env))); @@ -117,21 +121,21 @@ static LakeVal *_define(LakeCtx *ctx, Env *env, LakeList *expr) static LakeVal *_lambda(LakeCtx *ctx, Env *env, LakeList *expr) { /* (lambda (a b c) ...) */ - if (LIST_N(expr) >= 3 && IS(TYPE_LIST, LIST_VAL(expr, 1))) { + if (LIST_N(expr) >= 3 && lk_is_type(TYPE_LIST, LIST_VAL(expr, 1))) { list_shift(expr); /* drop the "lambda" symbol */ LakeList *params = LIST(list_shift(expr)); LakeList *body = expr; return VAL(fn_make(params, NULL, body, env)); } - else if (LIST_N(expr) >= 3 && IS(TYPE_DLIST, LIST_VAL(expr, 1))) { + else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_DLIST, LIST_VAL(expr, 1))) { list_shift(expr); /* drop the "lambda" symbol */ LakeDottedList *def = DLIST(list_shift(expr)); - LakeList *params = DLIST_HEAD(def); - LakeSym *varargs = SYM(DLIST_TAIL(def)); + LakeList *params = dlist_head(def); + LakeSym *varargs = SYM(dlist_tail(def)); LakeList *body = expr; return VAL(fn_make(params, varargs, body, env)); } - else if (LIST_N(expr) >= 3 && IS(TYPE_SYM, LIST_VAL(expr, 1))) { + else if (LIST_N(expr) >= 3 && lk_is_type(TYPE_SYM, LIST_VAL(expr, 1))) { list_shift(expr); /* drop the "lambda" symbol */ LakeSym *varargs = SYM(list_shift(expr)); LakeList *body = expr; @@ -151,7 +155,7 @@ static LakeVal *_if(LakeCtx *ctx, Env *env, LakeList *expr) } list_shift(expr); /* "if" token */ LakeVal *cond = eval(ctx, env, list_shift(expr)); - if (IS_TRUTHY(ctx, cond)) { + if (lk_is_truthy(ctx, cond)) { return eval(ctx, env, list_shift(expr)); } else { @@ -168,13 +172,13 @@ static LakeVal *_cond(LakeCtx *ctx, Env *env, LakeList *expr) LakeVal *pred; LakeList *conseq; while (LIST_N(expr)) { - if (!IS(TYPE_LIST, LIST_VAL(expr, 0))) { + if (!lk_is_type(TYPE_LIST, LIST_VAL(expr, 0))) { invalid_special_form(expr, "expected a (predicate consequence) pair"); return NULL; } conseq = LIST(list_shift(expr)); pred = list_shift(conseq); - if (pred == ELSE || IS_TRUTHY(ctx, eval(ctx, env, pred))) { + if (pred == ELSE || lk_is_truthy(ctx, eval(ctx, env, pred))) { return eval_exprs1(ctx, env, conseq); } } @@ -189,36 +193,37 @@ static LakeVal *_when(LakeCtx *ctx, Env *env, LakeList *expr) } list_shift(expr); /* "when" token */ LakeVal *cond = eval(ctx, env, list_shift(expr)); - return IS_TRUTHY(ctx, cond) ? eval_exprs1(ctx, env, expr) : NULL; + return lk_is_truthy(ctx, cond) ? eval_exprs1(ctx, env, expr) : NULL; +} + +typedef LakeVal *(*handler)(LakeCtx *, Env *, LakeList *); + +static void define_handler(LakeCtx *ctx, char *name, handler fn) +{ + g_hash_table_insert(ctx->special_form_handlers, sym_intern(ctx, name), (void *)fn); } void init_special_form_handlers(LakeCtx *ctx) { - #define HANDLER(name, fn) g_hash_table_insert(ctx->special_form_handlers, \ - sym_intern(ctx, name), \ - (gpointer)fn) - - /* HANDLER("load", &load_special_form); */ - HANDLER("quote", &_quote); - HANDLER("and", &_and); - HANDLER("or", &_or); - HANDLER("if", &_if); - HANDLER("when", &_when); - HANDLER("cond", &_cond); - HANDLER("set!", &_setB); - HANDLER("define", &_define); - HANDLER("lambda", &_lambda); - /* HANDLER("let", &_let); */ - /* HANDLER("let!", &_letB); */ - /* HANDLER("letrec", &_letrec); */ - - #undef HANDLER + /* define_handler(ctx, "load", &load_special_form); */ + define_handler(ctx, "quote", &_quote); + define_handler(ctx, "and", &_and); + define_handler(ctx, "or", &_or); + define_handler(ctx, "if", &_if); + define_handler(ctx, "when", &_when); + define_handler(ctx, "cond", &_cond); + define_handler(ctx, "set!", &_setB); + define_handler(ctx, "define", &_define); + define_handler(ctx, "lambda", &_lambda); + /* define_handler(ctx, "let", &_let); */ + /* define_handler(ctx, "let!", &_letB); */ + /* define_handler(ctx, "letrec", &_letrec); */ } -gboolean is_special_form(LakeCtx *ctx, LakeList *expr) +bool is_special_form(LakeCtx *ctx, LakeList *expr) { LakeVal *head = LIST_VAL(expr, 0); - if (!IS(TYPE_SYM, head)) return FALSE; + if (!lk_is_type(TYPE_SYM, head)) return FALSE; GList *special_form_names = g_hash_table_get_keys(ctx->special_form_handlers); return !!g_list_find(special_form_names, SYM(head)); } @@ -235,10 +240,15 @@ static LakeVal *eval_special_form(LakeCtx *ctx, Env *env, LakeList *expr) if (handler) { return handler(ctx, env, list_copy(expr)); } - ERR("unrecognized special form: %s", SYM_S(name)); + ERR("unrecognized special form: %s", sym_repr(name)); return NULL; } +LakeVal *eval_str(LakeCtx *ctx, Env *env, char *s) +{ + return eval(ctx, env, parse_expr(ctx, s, strlen(s))); +} + LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr) { LakeVal *result; @@ -254,9 +264,9 @@ LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr) break; case TYPE_SYM: - result = env_get(env, (gpointer)SYM(expr)); + result = env_get(env, (void *)SYM(expr)); if (!result) { - ERR("undefined variable: %s", SYM_S(SYM(expr))); + ERR("undefined variable: %s", sym_repr(SYM(expr))); } break; @@ -332,7 +342,7 @@ LakeVal *eval_exprs1(LakeCtx *ctx, Env *env, LakeList *exprs) LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args) { LakeVal *result = NULL; - if (IS(TYPE_PRIM, fnVal)) { + if (lk_is_type(TYPE_PRIM, fnVal)) { LakePrimitive *prim = PRIM(fnVal); int arity = prim->arity; if (arity == ARITY_VARARGS || LIST_N(args) == arity) { @@ -343,7 +353,7 @@ LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args) result = NULL; } } - else if (IS(TYPE_FN, fnVal)) { + else if (lk_is_type(TYPE_FN, fnVal)) { LakeFn *fn = FN(fnVal); /* Check # of params */ diff --git a/src/eval.h b/src/eval.h index ebfc247..2632d77 100644 --- a/src/eval.h +++ b/src/eval.h @@ -13,11 +13,12 @@ #include "env.h" #include "lake.h" +LakeVal *eval_str(LakeCtx *ctx, Env *env, char *s); LakeVal *eval(LakeCtx *ctx, Env *env, LakeVal *expr); LakeList *eval_exprs(LakeCtx *ctx, Env *env, LakeList *exprs); LakeVal *eval_exprs1(LakeCtx *ctx, Env *env, LakeList *exprs); LakeVal *apply(LakeCtx *ctx, LakeVal *fnVal, LakeList *args); -gboolean is_special_form(LakeCtx *ctx, LakeList *expr); +bool is_special_form(LakeCtx *ctx, LakeList *expr); void init_special_form_handlers(LakeCtx *ctx); -#endif \ No newline at end of file +#endif diff --git a/src/fn.c b/src/fn.c index 9dd584d..41fb954 100644 --- a/src/fn.c +++ b/src/fn.c @@ -9,6 +9,7 @@ #include #include +#include "common.h" #include "env.h" #include "fn.h" #include "lake.h" @@ -42,12 +43,12 @@ char *fn_repr(LakeFn *fn) free(s2); } else if (fn->varargs) { - s2 = lake_repr(VAL(fn->varargs)); + s2 = lake_repr(fn->varargs); g_string_append(s, s2); free(s2); } else { - s2 = lake_repr(VAL(fn->params)); + s2 = lake_repr(fn->params); g_string_append(s, s2); free(s2); } diff --git a/src/int.c b/src/int.c index 51c5e50..e959e7b 100644 --- a/src/int.c +++ b/src/int.c @@ -8,6 +8,7 @@ */ #include +#include "common.h" #include "int.h" #include "lake.h" #include "str.h" diff --git a/src/lake.c b/src/lake.c index 9d07cfc..7a1106e 100644 --- a/src/lake.c +++ b/src/lake.c @@ -11,7 +11,9 @@ */ #include +#include "bool.h" #include "comment.h" +#include "common.h" #include "env.h" #include "eval.h" #include "lake.h" @@ -20,64 +22,83 @@ #include "str.h" #include "symtable.h" -char *lake_repr(LakeVal *expr) +int lk_val_size(void *x) +{ + return VAL(x)->size; +} + +int lk_is_type(LakeType t, void *x) +{ + return VAL(x)->type == t; +} + +char *lake_repr(void *expr) { if (expr == NULL) return g_strdup("(null)"); char *s = NULL; - switch (expr->type) { + LakeVal *e = VAL(expr); + switch (e->type) { case TYPE_SYM: - s = sym_repr(SYM(expr)); + s = sym_repr(SYM(e)); break; case TYPE_BOOL: - s = BOOL_REPR(BOOL(expr)); + s = lk_bool_repr(BOOL(e)); break; case TYPE_INT: - s = int_repr(INT(expr)); + s = int_repr(INT(e)); break; case TYPE_STR: - s = g_strdup_printf("\"%s\"", STR_S(STR(expr))); + s = g_strdup_printf("\"%s\"", STR_S(STR(e))); break; case TYPE_LIST: - s = list_repr(LIST(expr)); + s = list_repr(LIST(e)); break; case TYPE_DLIST: - s = dlist_repr(DLIST(expr)); + s = dlist_repr(DLIST(e)); break; case TYPE_PRIM: - s = prim_repr(PRIM(expr)); + s = prim_repr(PRIM(e)); break; case TYPE_FN: - s = fn_repr(FN(expr)); + s = fn_repr(FN(e)); break; case TYPE_COMM: - s = comment_repr(COMM(expr)); + s = comment_repr(COMM(e)); break; default: - fprintf(stderr, "error: unrecognized value, type %d, size %zu bytes", expr->type, expr->size); - s = g_strdup(""); + // If it wasn't a LakeVal we already crashed at the beginning of the switch, + // so go ahead and print out the size too. + fprintf(stderr, "error: unrecognized value, type %d, size %zu bytes", + e->type, e->size); + s = g_strdup("(unknown)"); } return s; } -gboolean lake_is(LakeVal *a, LakeVal *b) +bool lk_is_nil(LakeVal *x) { - if (IS(TYPE_INT, a) && IS(TYPE_INT, b)) { + return lk_is_type(TYPE_LIST, x) && LIST_N(LIST(x)) == 0; +} + +bool lake_is(LakeVal *a, LakeVal *b) +{ + if (lk_is_type(TYPE_INT, a) && lk_is_type(TYPE_INT, b)) { return INT_VAL(INT(a)) == INT_VAL(INT(b)); } - if (IS_NIL(a) && IS_NIL(b)) return TRUE; + if (lk_is_nil(a) && lk_is_nil(b)) return TRUE; return a == b; } @@ -91,7 +112,7 @@ static char *type_name(LakeVal *expr) return t >= 0 && t <= 8 ? type_names[t] : "(not a LakeVal)"; } -gboolean lake_equal(LakeVal *a, LakeVal *b) +bool lake_equal(LakeVal *a, LakeVal *b) { if (a->type != b->type) return FALSE; switch (a->type) { @@ -124,7 +145,7 @@ gboolean lake_equal(LakeVal *a, LakeVal *b) } } -static LakeBool *bool_make(gboolean val) +static LakeBool *bool_make(bool val) { LakeBool *b = g_malloc(sizeof(LakeBool)); VAL(b)->type = TYPE_BOOL; diff --git a/src/lake.h b/src/lake.h index b35b1ee..2687004 100644 --- a/src/lake.h +++ b/src/lake.h @@ -12,6 +12,7 @@ #include #include +#include "common.h" #define LAKE_VERSION "0.1" @@ -44,10 +45,6 @@ struct lake_val { }; typedef struct lake_val LakeVal; -#define VAL_SIZE(x) (VAL(x)->size) -#define IS(t, x) (VAL(x)->type == t) -#define IS_NIL(x) (IS(TYPE_LIST, x) && LIST_N(LIST(x)) == 0) - struct lake_sym { LakeVal base; size_t n; @@ -56,25 +53,12 @@ struct lake_sym { }; typedef struct lake_sym LakeSym; -#define SYM_S(x) (x->s) -#define SYM_HASH(x) (x->hash) - struct lake_bool { LakeVal base; - gboolean val; + bool val; }; typedef struct lake_bool LakeBool; -#define BOOL_VAL(x) (x->val) -#define IS_TRUE(ctx, x) (VAL(x) == VAL(ctx->T)) -#define IS_FALSE(ctx, x) (VAL(x) == VAL(ctx->F)) -#define IS_TRUTHY(ctx, x) (!IS_FALSE(ctx, x)) -#define IS_FALSY(ctx, x) (IS_FALSE(ctx, x)) -#define BOOL_FROM_INT(ctx, n) (n ? ctx->T : ctx->F) -#define BOOL_REPR(b) (g_strdup(BOOL_VAL(b) ? "#t" : "#f")) -#define BOOL_AND(ctx, a, b) (IS_TRUTHY(ctx, a) && IS_TRUTHY(ctx, b) ? b : a) -#define BOOL_OR(ctx, a, b) (IS_TRUTHY(ctx, a) ? a : b) - struct lake_int { LakeVal base; int val; @@ -112,9 +96,6 @@ struct lake_dlist { }; typedef struct lake_dlist LakeDottedList; -#define DLIST_HEAD(x) (x->head) -#define DLIST_TAIL(x) (x->tail) - #include "env.h" /* Execution context */ @@ -150,7 +131,7 @@ struct lake_fn { }; typedef struct lake_fn LakeFn; -#define CALLABLE(x) (IS(TYPE_FN, x) || IS(TYPE_PRIM, x)) +#define CALLABLE(x) (lk_is_type(TYPE_FN, x) || lk_is_type(TYPE_PRIM, x)) struct lake_comment { LakeVal base; @@ -161,9 +142,12 @@ typedef struct lake_comment LakeComment; #define COMM_TEXT(x) (x->text) LakeCtx *lake_init(void); -gboolean lake_is(LakeVal *a, LakeVal *b); -gboolean lake_equal(LakeVal *a, LakeVal *b); -char *lake_repr(LakeVal *val); +int lk_val_size(void *x); +int lk_is_type(LakeType t, void *x); +bool lk_is_nil(LakeVal *x); +bool lake_is(LakeVal *a, LakeVal *b); +bool lake_equal(LakeVal *a, LakeVal *b); +char *lake_repr(void *val); #include diff --git a/src/list.c b/src/list.c index ebe9306..ba40152 100644 --- a/src/list.c +++ b/src/list.c @@ -11,6 +11,7 @@ #include #include #include +#include "common.h" #include "int.h" #include "lake.h" #include "list.h" @@ -46,7 +47,7 @@ LakeList *list_make(void) LakeList *list_cons(LakeVal *car, LakeVal *cdr) { LakeList *list; - if (IS(TYPE_LIST, cdr)) { + if (lk_is_type(TYPE_LIST, cdr)) { list = LIST(cdr); list_unshift(list, car); } @@ -161,7 +162,7 @@ LakeVal *list_pop(LakeList *list) return tail; } -gboolean list_equal(LakeList *a, LakeList *b) +bool list_equal(LakeList *a, LakeList *b) { if (a == b) return TRUE; size_t n = LIST_N(a); @@ -186,8 +187,15 @@ char *list_repr(LakeList *list) GString *s = g_string_new("("); int i; char *s2; + LakeVal *val; for (i = 0; i < LIST_N(list); ++i) { - s2 = lake_repr(LIST_VAL(list, i)); + val = LIST_VAL(list, i); + if (val == VAL(list)) { + s2 = g_strdup("[Circular]"); + } + else { + s2 = lake_repr(val); + } g_string_append(s, s2); g_free(s2); if (i != LIST_N(list) - 1) g_string_append(s, " "); diff --git a/src/list.h b/src/list.h index 01742bd..a192b9d 100644 --- a/src/list.h +++ b/src/list.h @@ -12,6 +12,7 @@ #include #include +#include "common.h" #include "lake.h" #include "str.h" @@ -28,7 +29,7 @@ LakeInt *list_len(LakeList *list); LakeVal *list_pop(LakeList *list); LakeVal *list_shift(LakeList *list); LakeVal *list_unshift(LakeList *list, LakeVal *val); -gboolean list_equal(LakeList *a, LakeList *b); +bool list_equal(LakeList *a, LakeList *b); LakeStr *list_to_str(LakeList *list); char *list_repr(LakeList *list); diff --git a/src/parse.c b/src/parse.c index 31f22c0..2f28d6c 100644 --- a/src/parse.c +++ b/src/parse.c @@ -11,6 +11,7 @@ #include #include #include +#include "common.h" #include "dlist.h" #include "int.h" #include "lake.h" @@ -128,37 +129,37 @@ static void backtrack(Ctx *ctx) ctx->i = ctx->mark; } -static gboolean is_space(char c) +static bool is_space(char c) { return strchr(" \r\n\t", c) != NULL; } -static gboolean is_letter(char c) +static bool is_letter(char c) { return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'); } -static gboolean is_symbol(char c) +static bool is_symbol(char c) { return strchr("!$%&|*+-/:<=>?@^_~#", c) != NULL; } -static gboolean is_digit(char c) +static bool is_digit(char c) { return c >= '0' && c <= '9'; } -static gboolean is_sym_char(char c) +static bool is_sym_char(char c) { return is_letter(c) || is_symbol(c) || is_digit(c); } -static gboolean is_newline(char c) +static bool is_newline(char c) { return c == '\n' || c == '\r'; } -static char *parse_while(Ctx *ctx, gboolean (*is_valid)(char)) +static char *parse_while(Ctx *ctx, bool (*is_valid)(char)) { size_t n = 8; size_t i = 0; @@ -337,7 +338,7 @@ static LakeVal *parse_quoted(Ctx *ctx) return VAL(list); } -static gboolean is_not_newline(char c) +static bool is_not_newline(char c) { return !is_newline(c); } diff --git a/src/primitive.c b/src/primitive.c index ca26d6e..22cc3a6 100644 --- a/src/primitive.c +++ b/src/primitive.c @@ -9,7 +9,10 @@ #include #include +#include "bool.h" +#include "common.h" #include "comment.h" +#include "dlist.h" #include "env.h" #include "int.h" #include "dlist.h" @@ -44,22 +47,28 @@ char *prim_repr(LakePrimitive *prim) static LakeVal *_car(LakeCtx *ctx, LakeList *args) { LakeList *list = LIST(LIST_VAL(args, 0)); - if (IS(TYPE_LIST, list) && LIST_N(list) > 0) { + if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) { return LIST_VAL(list, 0); } - ERR("not a pair: %s", list_repr(list)); + if (lk_is_type(TYPE_DLIST, list)) { + return VAL(dlist_head(DLIST(list))); + } + ERR("not a pair: %s", lake_repr(list)); return NULL; } static LakeVal *_cdr(LakeCtx *ctx, LakeList *args) { LakeList *list = LIST(LIST_VAL(args, 0)); - if (IS(TYPE_LIST, list) && LIST_N(list) > 0) { + if (lk_is_type(TYPE_LIST, list) && LIST_N(list) > 0) { LakeList *cdr = list_copy(list); list_shift(cdr); return VAL(cdr); } - ERR("not a pair: %s", list_repr(list)); + if (lk_is_type(TYPE_DLIST, list)) { + return dlist_tail(DLIST(list)); + } + ERR("not a pair: %s", lake_repr(list)); return NULL; } @@ -73,14 +82,14 @@ static LakeVal *_cons(LakeCtx *ctx, LakeList *args) static LakeVal *_nullP(LakeCtx *ctx, LakeList *args) { LakeVal *val = list_shift(args); - LakeBool *is_null = BOOL_FROM_INT(ctx, IS(TYPE_LIST, val) && LIST_N(LIST(val)) == 0); + LakeBool *is_null = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) == 0); return VAL(is_null); } static LakeVal *_pairP(LakeCtx *ctx, LakeList *args) { LakeVal *val = list_shift(args); - LakeBool *is_pair = BOOL_FROM_INT(ctx, IS(TYPE_LIST, val) && LIST_N(LIST(val)) > 0); + LakeBool *is_pair = lk_bool_from_int(ctx, lk_is_type(TYPE_LIST, val) && LIST_N(LIST(val)) > 0); return VAL(is_pair); } @@ -88,25 +97,25 @@ static LakeVal *_isP(LakeCtx *ctx, LakeList *args) { LakeVal *a = LIST_VAL(args, 0); LakeVal *b = LIST_VAL(args, 1); - return VAL(BOOL_FROM_INT(ctx, lake_is(a, b))); + return VAL(lk_bool_from_int(ctx, lake_is(a, b))); } static LakeVal *_equalP(LakeCtx *ctx, LakeList *args) { LakeVal *a = LIST_VAL(args, 0); LakeVal *b = LIST_VAL(args, 1); - return VAL(BOOL_FROM_INT(ctx, lake_equal(a, b))); + return VAL(lk_bool_from_int(ctx, lake_equal(a, b))); } static LakeVal *_not(LakeCtx *ctx, LakeList *args) { LakeVal *val = list_shift(args); - LakeBool *not = BOOL_FROM_INT(ctx, IS_FALSE(ctx, val)); + LakeBool *not = lk_bool_from_int(ctx, lk_is_false(ctx, val)); return VAL(not); } #define ENSURE_INT(x, i) do { \ - if (!IS(TYPE_INT, x)) { \ + if (!lk_is_type(TYPE_INT, x)) { \ ERR("argument %zu is not an integer: %s", i, lake_repr(x)); \ return NULL; \ } \ @@ -197,7 +206,7 @@ static LakeVal *_div(LakeCtx *ctx, LakeList *args) static LakeVal *_int_eq(LakeCtx *ctx, LakeList *args) { - gboolean result = TRUE; + bool result = TRUE; size_t n = LIST_N(args); size_t i; int curr, prev; @@ -210,12 +219,12 @@ static LakeVal *_int_eq(LakeCtx *ctx, LakeList *args) } prev = INT_VAL(INT(v)); } - return VAL(BOOL_FROM_INT(ctx, result)); + return VAL(lk_bool_from_int(ctx, result)); } static LakeVal *_int_lt(LakeCtx *ctx, LakeList *args) { - gboolean result = TRUE; + bool result = TRUE; size_t n = LIST_N(args); size_t i; int curr, prev; @@ -231,12 +240,12 @@ static LakeVal *_int_lt(LakeCtx *ctx, LakeList *args) prev = INT_VAL(INT(v)); } } - return VAL(BOOL_FROM_INT(ctx, result)); + return VAL(lk_bool_from_int(ctx, result)); } static LakeVal *_int_gt(LakeCtx *ctx, LakeList *args) { - gboolean result = TRUE; + bool result = TRUE; size_t n = LIST_N(args); size_t i; int curr, prev; @@ -252,7 +261,7 @@ static LakeVal *_int_gt(LakeCtx *ctx, LakeList *args) prev = INT_VAL(INT(v)); } } - return VAL(BOOL_FROM_INT(ctx, result)); + return VAL(lk_bool_from_int(ctx, result)); } void bind_primitives(LakeCtx *ctx) diff --git a/src/repl.c b/src/repl.c index c8bfb60..19a97ba 100644 --- a/src/repl.c +++ b/src/repl.c @@ -15,6 +15,7 @@ #include #include #include +#include "common.h" #include "env.h" #include "eval.h" #include "lake.h" diff --git a/src/str.c b/src/str.c index d3a5165..7b0501f 100644 --- a/src/str.c +++ b/src/str.c @@ -10,6 +10,7 @@ #include #include #include +#include "common.h" #include "int.h" #include "lake.h" #include "str.h" @@ -62,7 +63,7 @@ char *str_val(LakeStr *str) return g_strdup(str->s); } -gboolean str_equal(LakeStr *a, LakeStr *b) +bool str_equal(LakeStr *a, LakeStr *b) { size_t n = STR_N(a); if (n != STR_N(b)) return FALSE; diff --git a/src/str.h b/src/str.h index 21da131..15e1adb 100644 --- a/src/str.h +++ b/src/str.h @@ -11,6 +11,7 @@ #define _LAKE_STRING_H 1 #include +#include "common.h" #include "lake.h" LakeStr *str_make(void); @@ -19,7 +20,7 @@ LakeStr *str_copy(LakeStr *str); LakeStr *str_from_c(char *s); char *str_val(LakeStr *str); LakeInt *str_len(LakeStr *str); -gboolean str_equal(LakeStr *a, LakeStr *b); +bool str_equal(LakeStr *a, LakeStr *b); LakeStr *str_to_str(LakeStr *str); #endif \ No newline at end of file diff --git a/src/sym.c b/src/sym.c index f8804f7..6f319a2 100644 --- a/src/sym.c +++ b/src/sym.c @@ -11,6 +11,7 @@ #include #include #include +#include "common.h" #include "env.h" #include "lake.h" #include "str.h" diff --git a/src/symtable.c b/src/symtable.c index 1917f22..c1e9c10 100644 --- a/src/symtable.c +++ b/src/symtable.c @@ -8,15 +8,16 @@ */ #include +#include "common.h" #include "lake.h" #include "symtable.h" static guint _sym_hash(gconstpointer key) { - return SYM_HASH(SYM(key)); + return sym_val(SYM(key)); } -static gboolean _sym_eq(gconstpointer a, gconstpointer b) +static bool _sym_eq(gconstpointer a, gconstpointer b) { return a == b; } diff --git a/src/symtable.h b/src/symtable.h index d520132..b7728ae 100644 --- a/src/symtable.h +++ b/src/symtable.h @@ -11,6 +11,7 @@ #define _LAKE_SYMTABLE_H 1 #include +#include "common.h" GHashTable *symtable_make(void); diff --git a/test/test_comment.c b/test/test_comment.c index b9d5b8e..62211cd 100644 --- a/test/test_comment.c +++ b/test/test_comment.c @@ -21,8 +21,8 @@ static LakeStr *text = NULL; static char *test_comment_make(void) { LakeComment *comment = comment_make(text); - lt_assert("type is not TYPE_COMM", IS(TYPE_COMM, comment)); - lt_assert("value size is incorrect", VAL_SIZE(comment) == sizeof(LakeComment)); + lt_assert("type is not TYPE_COMM", lk_is_type(TYPE_COMM, comment)); + lt_assert("value size is incorrect", lk_val_size(comment) == sizeof(LakeComment)); lt_assert("comment text is incorrect", str_equal(text, COMM_TEXT(comment))); return 0; } @@ -31,8 +31,8 @@ static char *test_comment_make(void) static char *test_comment_from_c(void) { LakeComment *comment = comment_from_c(TEXT); - lt_assert("type is not TYPE_COMM", IS(TYPE_COMM, comment)); - lt_assert("value size is incorrect", VAL_SIZE(comment) == sizeof(LakeComment)); + lt_assert("type is not TYPE_COMM", lk_is_type(TYPE_COMM, comment)); + lt_assert("value size is incorrect", lk_val_size(comment) == sizeof(LakeComment)); lt_assert("comment text is incorrect", str_equal(text, COMM_TEXT(comment))); return 0; } @@ -45,7 +45,7 @@ static char *test_comment_repr(void) return 0; } -/* gboolean comment_equal(LakeComment *a, LakeComment *b) */ +/* bool comment_equal(LakeComment *a, LakeComment *b) */ static char *test_comment_equal(void) { LakeComment *a = comment_make(text); diff --git a/test/test_dlist.c b/test/test_dlist.c index 4fb8159..e6f323c 100644 --- a/test/test_dlist.c +++ b/test/test_dlist.c @@ -9,6 +9,7 @@ #include #include +#include "common.h" #include "laketest.h" #include "lake.h" #include "list.h" @@ -21,11 +22,11 @@ static char *REPR = "(() . ())"; /* LakeDottedList *dlist_make(LakeList *head, LakeVal *tail) */ static char *test_dlist_make(void) { - lt_assert("type is not TYPE_DLIST", IS(TYPE_DLIST, dlist)); - lt_assert("value size is incorrect", VAL_SIZE(dlist) == sizeof(LakeDottedList)); + lt_assert("type is not TYPE_DLIST", lk_is_type(TYPE_DLIST, dlist)); + lt_assert("value size is incorrect", lk_val_size(dlist) == sizeof(LakeDottedList)); lt_assert("head value is incorrect", - lake_equal(VAL(head), VAL(DLIST_HEAD(dlist)))); - lt_assert("tail value is incorrect", lake_equal(tail, DLIST_TAIL(dlist))); + lake_equal(VAL(head), VAL(dlist_head(dlist)))); + lt_assert("tail value is incorrect", lake_equal(tail, dlist_tail(dlist))); return 0; } @@ -51,7 +52,7 @@ static char *test_dlist_repr(void) return 0; } -/* gboolean dlist_equal(LakeDottedList *a, LakeDottedList *b) */ +/* bool dlist_equal(LakeDottedList *a, LakeDottedList *b) */ static char *test_dlist_equal(void) { LakeDottedList *a = dlist; diff --git a/test/test_env.c b/test/test_env.c index 512997e..7e1a110 100644 --- a/test/test_env.c +++ b/test/test_env.c @@ -8,6 +8,7 @@ */ #include +#include "common.h" #include "laketest.h" #include "env.h" #include "lake.h" diff --git a/test/test_lake.c b/test/test_lake.c index bb73141..6ba2b72 100644 --- a/test/test_lake.c +++ b/test/test_lake.c @@ -7,7 +7,9 @@ * */ +#include #include "laketest.h" +#include "bool.h" #include "int.h" #include "lake.h" #include "str.h" @@ -32,19 +34,19 @@ static char *test_lake_init(void) NULL != lake->special_form_handlers); lt_assert("T is null", NULL != lake->T); lt_assert("F is null", NULL != lake->F); - lt_assert("T is not a boolean", IS(TYPE_BOOL, lake->T)); - lt_assert("F is not a boolean", IS(TYPE_BOOL, lake->F)); - lt_assert("value of T is zero", BOOL_VAL(lake->T)); - lt_assert("value of F is non-zero", !BOOL_VAL(lake->F)); + lt_assert("T is not a boolean", lk_is_type(TYPE_BOOL, lake->T)); + lt_assert("F is not a boolean", lk_is_type(TYPE_BOOL, lake->F)); + lt_assert("value of T is zero", lk_bool_val(lake->T)); + lt_assert("value of F is non-zero", !lk_bool_val(lake->F)); return 0; } -static gboolean _is(void *a, void *b) +static bool _is(void *a, void *b) { return lake_is(VAL(a), VAL(b)); } -/* gboolean lake_is(LakeVal *a, LakeVal *b) */ +/* bool lake_is(LakeVal *a, LakeVal *b) */ static char *test_lake_is(void) { LakeInt *i = int_from_c(42); @@ -66,12 +68,12 @@ static char *test_lake_is(void) return 0; } -static gboolean _equal(void *a, void *b) +static bool _equal(void *a, void *b) { return lake_equal(VAL(a), VAL(b)); } -/* gboolean lake_equal(LakeVal *a, LakeVal *b) */ +/* bool lake_equal(LakeVal *a, LakeVal *b) */ static char *test_lake_equal(void) { LakeInt *i = int_from_c(42);