diff --git a/lake.c b/lake.c index acf1051..0618b7e 100644 --- a/lake.c +++ b/lake.c @@ -27,143 +27,19 @@ static LakeBool _F = { { TYPE_BOOL, sizeof(LakeBool) }, FALSE }; LakeBool *T = &_T; LakeBool *F = &_F; -static LakeVal *prim_nullP(LakeList *args) +char *type_name(LakeVal *expr) { - LakeVal *val = list_shift(args); - LakeBool *is_null = IS(TYPE_LIST, val) && LIST_N(LIST(val)) == 0 ? T : F; - return VAL(is_null); + static char *type_names[9] = { "nil", "symbol", "boolean", "integer", "string", "list", + "dotted-list", "primitive", "function" + }; + + return type_names[expr->type]; } -static LakeVal *prim_pairP(LakeList *args) +void print(LakeVal *expr) { - LakeVal *val = list_shift(args); - LakeBool *is_pair = IS(TYPE_LIST, val) && LIST_N(LIST(val)) > 0 ? T : F; - return VAL(is_pair); -} - -static LakeVal *prim_not(LakeList *args) -{ - LakeVal *val = list_shift(args); - LakeBool *not = IS_FALSE(val) ? T : F; - return VAL(not); -} - -static LakeVal *prim_add(LakeList *args) -{ - int result = 0; - size_t n = LIST_N(args); - size_t i; - for (i = 0; i < n; ++i) { - LakeVal *v = LIST_VAL(args, i); - if (!IS(TYPE_INT, v)) { - ERR("argument %zu is not an integer: %s", i, repr(v)); - return NULL; - } - result += INT_VAL(INT(v)); - } - return VAL(int_from_c(result)); -} - -static LakeVal *prim_sub(LakeList *args) -{ - size_t n = LIST_N(args); - - if (n < 1) { - ERR("- requires at least one argument"); - return NULL; - } - - int result = 0; - size_t i; - for (i = 0; i < n; ++i) { - LakeVal *v = LIST_VAL(args, i); - if (!IS(TYPE_INT, v)) { - ERR("argument %zu is not an integer: %s", i, repr(v)); - return NULL; - } - result -= INT_VAL(INT(v)); - } - return VAL(int_from_c(result)); -} - -static LakeVal *prim_mul(LakeList *args) -{ - int result = 1; - size_t n = LIST_N(args); - size_t i; - for (i = 0; i < n; ++i) { - LakeVal *v = LIST_VAL(args, i); - if (!IS(TYPE_INT, v)) { - ERR("argument %zu is not an integer: %s", i, repr(v)); - return NULL; - } - result *= INT_VAL(INT(v)); - } - return VAL(int_from_c(result)); -} - -#define DIVIDE_BY_ZERO() ERR("divide by zero") - -static LakeVal *prim_div(LakeList *args) -{ - size_t n = LIST_N(args); - - if (n < 1) { - ERR("/ requires at least one argument"); - return NULL; - } - - LakeVal *v = LIST_VAL(args, 0); - if (!IS(TYPE_INT, v)) { - ERR("argument 0 is not an integer: %s", repr(v)); - return NULL; - } - int result = INT_VAL(INT(v)); - - if (n == 1) { - if (result == 0) { - DIVIDE_BY_ZERO(); - return NULL; - } - result = 1 / result; - } - else { - size_t i; - for (i = 1; i < n; ++i) { - v = LIST_VAL(args, i); - if (!IS(TYPE_INT, v)) { - ERR("argument %zu is not an integer: %s", i, repr(v)); - return NULL; - } - int val = INT_VAL(INT(v)); - if (val == 0) { - DIVIDE_BY_ZERO(); - return NULL; - } - result /= val; - } - } - return VAL(int_from_c(result)); -} - -static Env *primitive_bindings(void) -{ - #define DEFINE(name, fn, arity) env_define(env, sym_intern(name), VAL(prim_make(name, arity, fn))) - - Env *env = env_toplevel(); - DEFINE("null?", prim_nullP, 1); - DEFINE("pair?", prim_pairP, 1); - DEFINE("not", prim_not, 1); - DEFINE("+", prim_add, ARITY_VARARGS); - DEFINE("-", prim_sub, ARITY_VARARGS); - DEFINE("*", prim_mul, ARITY_VARARGS); - DEFINE("/", prim_div, ARITY_VARARGS); - return env; -} - -void print(LakeVal *val) -{ - puts(repr(val)); + /* printf("[%s]\n", type_name(expr)); */ + printf("%s\n", repr(expr)); } static LakeVal *prompt_read(char *prompt) @@ -260,6 +136,10 @@ char *repr(LakeVal *expr) s = dlist_repr(DLIST(expr)); break; + case TYPE_PRIM: + s = prim_repr(PRIM(expr)); + break; + case TYPE_FN: s = fn_repr(FN(expr)); break; @@ -276,7 +156,8 @@ int main (int argc, char const *argv[]) { if (argc == 1) { run_repl(); - } else { + } + else { run_one_then_repl(argc, argv); } return 0; diff --git a/list.c b/list.c index e061cf5..b289d56 100644 --- a/list.c +++ b/list.c @@ -80,7 +80,8 @@ LakeVal *list_set(LakeList *list, size_t i, LakeVal *val) { if (i >= 0 && i < list->n) { list->vals[i] = val; - } else { + } + else { ERR("list_set: index %zu is out of bounds (%zu)", i, list->n); } return NULL; diff --git a/parse.c b/parse.c index b9e80ff..69326b4 100644 --- a/parse.c +++ b/parse.c @@ -23,6 +23,7 @@ struct context { char *s; size_t n; size_t i; + size_t mark; }; typedef struct context Ctx; @@ -30,7 +31,7 @@ static LakeVal *_parse_expr(Ctx *ctx); LakeVal *parse_expr(char *s, size_t n) { - Ctx ctx = { s, n, 0 }; + Ctx ctx = { s, n, 0, 0 }; LakeVal *result = _parse_expr(&ctx); if (ctx.i < ctx.n) { char *trailing = ctx.s + ctx.i; @@ -70,26 +71,21 @@ static char ch(Ctx *ctx, char expected) DIE("parse error, expected '%c' got '%c'", expected, c); } -static int maybe_spaces(Ctx *ctx) +static void mark(Ctx *ctx) { - char *p; - while ((p = strchr(" \r\n\t", peek(ctx))) != NULL) { - consume1(ctx); - } - return 1; + ctx->mark = ctx->i; } -/* -static int whitespace(Ctx *ctx) + +static void backtrack(Ctx *ctx) { - int result = 0; - char *p; - while ((p = strchr(" \r\n\t", peek(ctx))) != NULL) { - consume1(ctx); - result = 1; - } - return result; + ctx->i = ctx->mark; } -*/ + +static gboolean is_space(c) +{ + return strchr(" \r\n\t", c) != NULL; +} + static gboolean is_letter(char c) { return (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'); @@ -105,6 +101,16 @@ static gboolean is_digit(char c) return c >= '0' && c <= '9'; } +static gboolean is_sym_char(char c) +{ + return is_letter(c) || is_symbol(c) || is_digit(c); +} + +static gboolean is_newline(char c) +{ + return c == '\n' || c == '\r'; +} + static char *parse_while(Ctx *ctx, gboolean (*is_valid)(char)) { size_t n = 8; @@ -126,27 +132,41 @@ static char *parse_while(Ctx *ctx, gboolean (*is_valid)(char)) return s; } +static int maybe_spaces(Ctx *ctx) +{ + while (is_space(peek(ctx))) { + consume1(ctx); + } + return 1; +} + static LakeVal *parse_int(Ctx *ctx) { + mark(ctx); int n = 0; char c = peek(ctx); char sign = c == '-' ? -1 : 1; if (c == '-' || c == '+') { consume1(ctx); + /* if not followed by a digit it's a symbol */ + if (!is_digit(peek(ctx))) { + backtrack(ctx); + return NULL; + } } while (is_digit(c = peek(ctx))) { n *= 10; n += c - '0'; consume1(ctx); } + /* if we're looking at a symbol character bail, it's not a number */ + if (is_sym_char(peek(ctx))) { + backtrack(ctx); + return NULL; + } return VAL(int_from_c(sign * n)); } -static gboolean is_sym_char(char c) -{ - return is_letter(c) || is_symbol(c) || is_digit(c); -} - static LakeVal *parse_sym(Ctx *ctx) { LakeVal *val; @@ -161,9 +181,11 @@ static LakeVal *parse_sym(Ctx *ctx) s[i] = '\0'; if (g_strcmp0(s, "#t") == 0) { val = VAL(T); - } else if (g_strcmp0(s, "#f") == 0) { + } + else if (g_strcmp0(s, "#f") == 0) { val = VAL(F); - } else { + } + else { val = VAL(sym_intern(s)); } return val; @@ -231,7 +253,7 @@ static LakeVal* parse_list(Ctx *ctx) char c; while ((c = peek(ctx)) != ')') { if (c == PARSE_EOF) { - printf("error: end of input while parsing list"); + ERR("end of input while parsing list"); list_free(list); ctx-> i = ctx->n; return NULL; @@ -263,9 +285,18 @@ static LakeVal* parse_list(Ctx *ctx) return VAL(list); } +static LakeVal *parse_quoted(Ctx *ctx) +{ + ch(ctx, '\''); + LakeList *list = list_make(); + list_append(list, VAL(sym_intern("quote"))); + list_append(list, _parse_expr(ctx)); + return VAL(list); +} + static gboolean is_not_newline(char c) { - return !(c == '\n' || c == '\r'); + return !is_newline(c); } static void parse_comment(Ctx *ctx) @@ -277,8 +308,12 @@ static LakeVal *_parse_expr(Ctx *ctx) { LakeVal *result = NULL; char c = peek(ctx); - if (c >= '0' && c <= '9') { + /* try to parse a number, if that fails parse a symbol */ + if ((c >= '0' && c <= '9') || c == '-' || c == '+') { result = VAL(parse_int(ctx)); + if (result == NULL) { + result = parse_sym(ctx); + } } else if (is_letter(c) || is_symbol(c)) { result = parse_sym(ctx); @@ -286,11 +321,9 @@ static LakeVal *_parse_expr(Ctx *ctx) else if (c == '"') { result = parse_str(ctx); } - /* TODO: quote else if (c == '\'') { result = parse_quoted(ctx); } - */ else if (c == '(') { result = parse_list(ctx); } diff --git a/primitive.c b/primitive.c index 9ea52eb..cdba491 100644 --- a/primitive.c +++ b/primitive.c @@ -7,6 +7,9 @@ * */ +#include +#include +#include "env.h" #include "lake.h" #include "primitive.h" @@ -25,4 +28,155 @@ LakePrimitive *prim_make(char *name, int arity, lake_fn fn) prim->arity = arity; prim->fn = fn; return prim; -} \ No newline at end of file +} + +char *prim_repr(LakePrimitive *prim) +{ + return g_strdup_printf("<#primitive:%s(%d)>", prim->name, prim->arity); +} + +static LakeVal *prim_nullP(LakeList *args) +{ + LakeVal *val = list_shift(args); + LakeBool *is_null = IS(TYPE_LIST, val) && LIST_N(LIST(val)) == 0 ? T : F; + return VAL(is_null); +} + +static LakeVal *prim_pairP(LakeList *args) +{ + LakeVal *val = list_shift(args); + LakeBool *is_pair = IS(TYPE_LIST, val) && LIST_N(LIST(val)) > 0 ? T : F; + return VAL(is_pair); +} + +static LakeVal *prim_not(LakeList *args) +{ + LakeVal *val = list_shift(args); + LakeBool *not = IS_FALSE(val) ? T : F; + return VAL(not); +} + +#define ENSURE_INT(x, i) do { \ + if (!IS(TYPE_INT, x)) { \ + ERR("argument %zu is not an integer: %s", i, repr(x)); \ + return NULL; \ + } \ + } while (0) + + +static LakeVal *prim_add(LakeList *args) +{ + int result = 0; + size_t n = LIST_N(args); + size_t i; + for (i = 0; i < n; ++i) { + LakeVal *v = LIST_VAL(args, i); + ENSURE_INT(v, i); + result += INT_VAL(INT(v)); + } + return VAL(int_from_c(result)); +} + +static LakeVal *prim_sub(LakeList *args) +{ + size_t n = LIST_N(args); + + if (n < 1) { + ERR("- requires at least one argument"); + return NULL; + } + + int result = 0; + size_t i; + for (i = 0; i < n; ++i) { + LakeVal *v = LIST_VAL(args, i); + ENSURE_INT(v, i); + result -= INT_VAL(INT(v)); + } + return VAL(int_from_c(result)); +} + +static LakeVal *prim_mul(LakeList *args) +{ + int result = 1; + size_t n = LIST_N(args); + size_t i; + for (i = 0; i < n; ++i) { + LakeVal *v = LIST_VAL(args, i); + ENSURE_INT(v, i); + result *= INT_VAL(INT(v)); + } + return VAL(int_from_c(result)); +} + +#define DIVIDE_BY_ZERO() ERR("divide by zero") + +static LakeVal *prim_div(LakeList *args) +{ + size_t n = LIST_N(args); + + if (n < 1) { + ERR("/ requires at least one argument"); + return NULL; + } + + LakeVal *v = LIST_VAL(args, 0); + ENSURE_INT(v, (size_t)0); + int result = INT_VAL(INT(v)); + + if (n == 1) { + if (result == 0) { + DIVIDE_BY_ZERO(); + return NULL; + } + result = 1 / result; + } + else { + size_t i; + for (i = 1; i < n; ++i) { + v = LIST_VAL(args, i); + ENSURE_INT(v, i); + int val = INT_VAL(INT(v)); + if (val == 0) { + DIVIDE_BY_ZERO(); + return NULL; + } + result /= val; + } + } + return VAL(int_from_c(result)); +} + +static LakeVal *prim_int_eq(LakeList *args) +{ + gboolean result = TRUE; + size_t n = LIST_N(args); + size_t i; + int curr, prev; + for (i = 0; i < n; ++i) { + LakeVal *v = LIST_VAL(args, i); + ENSURE_INT(v, i); + curr = INT_VAL(INT(v)); + if (i > 0) { + result = result && curr == prev; + } + prev = INT_VAL(INT(v)); + } + return VAL(bool_from_int(result)); +} + +Env *primitive_bindings(void) +{ + #define DEFINE(name, fn, arity) env_define(env, sym_intern(name), VAL(prim_make(name, arity, fn))) + + Env *env = env_toplevel(); + DEFINE("null?", prim_nullP, 1); + DEFINE("pair?", prim_pairP, 1); + DEFINE("not", prim_not, 1); + DEFINE("+", prim_add, ARITY_VARARGS); + DEFINE("-", prim_sub, ARITY_VARARGS); + DEFINE("*", prim_mul, ARITY_VARARGS); + DEFINE("/", prim_div, ARITY_VARARGS); + DEFINE("=", prim_int_eq, ARITY_VARARGS); + return env; +} diff --git a/primitive.h b/primitive.h index 690fdc4..d2aa304 100644 --- a/primitive.h +++ b/primitive.h @@ -10,6 +10,11 @@ #ifndef _LAKE_PRIMITIVE_H #define _LAKE_PRIMITIVE_H 1 +#include "env.h" +#include "lake.h" + LakePrimitive *prim_make(char *name, int arity, lake_fn fn); +char *prim_repr(LakePrimitive *prim); +Env *primitive_bindings(void); #endif