diff options
| -rw-r--r-- | README.md | 1 | ||||
| -rw-r--r-- | files/test-cons.l (renamed from files/test1.l) | 1 | ||||
| -rw-r--r-- | files/test-lambda.l | 23 | ||||
| -rw-r--r-- | files/test.l | 5 | ||||
| -rw-r--r-- | src/builtin.h | 43 | ||||
| -rw-r--r-- | src/lexer.c | 4 | ||||
| -rw-r--r-- | src/lexer.h | 1 | ||||
| -rw-r--r-- | src/main.c | 199 |
8 files changed, 189 insertions, 88 deletions
@@ -4,5 +4,6 @@ A simple lisp/scheme interpreter #### TODO +* improve errors * macros * FFI diff --git a/files/test1.l b/files/test-cons.l index b7e4749..7a4de7d 100644 --- a/files/test1.l +++ b/files/test-cons.l @@ -1,3 +1,4 @@ +(define a 3) '(sn ,(+ a 1)) '(1 2 (lol . test) 3 4 ,(+ 1 2) test) diff --git a/files/test-lambda.l b/files/test-lambda.l new file mode 100644 index 0000000..e088ad6 --- /dev/null +++ b/files/test-lambda.l @@ -0,0 +1,23 @@ +(define make-add (lambda (a) (lambda (b) (+ a b)))) +(define add4 (make-add 4)) +(add4 5) + +'(a b ,((lambda (a) '(test . ,a)) 69) c d) + +(define fib (lambda (c) (fib-rec 0 1 0 c))) +(define fib-rec (lambda (a b n c) + (if (= n c) + b + (fib-rec b (+ a b) (+ n 1) c)))) + +(define do (lambda (c f) (do-rec f 0 0 c))) + +(define do-rec (lambda (f r n c) + (if (= n c) r + (do-rec f (f n) (+ n 1) c)))) + +;; comment +;; another comment +;; fib(13) +(do 10 (lambda (n) (display (fib n)))) ; comment + diff --git a/files/test.l b/files/test.l deleted file mode 100644 index d9e9acc..0000000 --- a/files/test.l +++ /dev/null @@ -1,5 +0,0 @@ -(define make-add (lambda (a) (lambda (b) (+ a b)))) -(define add4 (make-add 4)) -(add4 5) - -'(a b ,((lambda (a) '(test . ,a)) 69) c d) diff --git a/src/builtin.h b/src/builtin.h index 144ed4c..43d7ee2 100644 --- a/src/builtin.h +++ b/src/builtin.h @@ -3,10 +3,12 @@ #define PROCEDURES(X) \ /* X(symbol, name, argc) */ \ X(plus, "+", 2) \ + X(equal, "=", 2) \ X(minus, "-", 2) \ X(cons, "cons", 2) \ - X(car, "car", 1) \ - X(cdr, "cdr", 1) \ + X(car, "car", 1) \ + X(cdr, "cdr", 1) \ + X(display,"display", 1) \ // Number of builtin procedures #define PLUS_ONE(_symbol, _name, _argc) 1 + @@ -69,6 +71,27 @@ DECLARE_PROCEDURE(P) } #undef P +#define P equal +DECLARE_PROCEDURE(P) +{ + int f = 0; + int t = 1; + + if(args[0]->type != args[1]->type) goto l_false; + + switch(args[0]->type) { + case VALUE_INT: + if(args[0]->value.num == args[1]->value.num) goto l_true; + default: break; + } + +l_false: + return value_create(VALUE_INT, &f); +l_true: + return value_create(VALUE_INT, &t); +} +#undef P + #define P cons DECLARE_PROCEDURE(P) { @@ -96,3 +119,19 @@ DECLARE_PROCEDURE(P) return right; } #undef P + +#define P display +DECLARE_PROCEDURE(P) +{ + char buf[256]; + value_string(args[0], (sizeof(buf)/sizeof(*buf)), buf); + + #ifdef DEBUG + info("%s", buf); + #else + printf("%s\n", buf); + #endif + + return value_copy(args[0]); +} +#undef P diff --git a/src/lexer.c b/src/lexer.c index 77407a9..b546fda 100644 --- a/src/lexer.c +++ b/src/lexer.c @@ -7,6 +7,7 @@ #define CH(lexer) (lexer)->str[(lexer)->str_idx] #define TOKEN_SEPARATOR_TABLE(X, l) \ + X((';' == CH(l)), CH(l) = '\0') \ X(('(' == CH(l)), on_separator(l, TOKEN_LP)) \ X((')' == CH(l)), on_separator(l, TOKEN_RP)) \ X(('\''== CH(l)), on_separator(l, TOKEN_QUOTE)) \ @@ -29,7 +30,8 @@ X(TOKEN_DOT, ".") \ X(TOKEN_LAMBDA, "lambda") \ X(TOKEN_DEFINE, "define") \ - X(TOKEN_QUOTE_FORM, "quote") + X(TOKEN_QUOTE_FORM, "quote") \ + X(TOKEN_IF, "if") #define TOKEN_VALUE_STRING_TABLE(X, tvalue) \ X(TOKEN_LP, "(") \ diff --git a/src/lexer.h b/src/lexer.h index c2e4637..b47f800 100644 --- a/src/lexer.h +++ b/src/lexer.h @@ -15,6 +15,7 @@ X(TOKEN_LAMBDA) \ X(TOKEN_DEFINE) \ X(TOKEN_QUOTE_FORM) \ + X(TOKEN_IF) \ X(TOKEN_NONE) #define TO_ENUM(type) type, @@ -29,19 +29,19 @@ #define TOKEN_NEXT(tctx) \ ERR_Z(next_token(tctx), die("Can't get next token")) -#define TOKEN_ASSERT(token, ttype, fail) \ - if(token->type != ttype) { \ - err("Expected token '%s', not '%s'", \ - token_type_string[ttype], \ - token_type_string[token->type]); \ - fail; \ +#define TOKEN_ASSERT(token, ttype, fail) \ + if(token->type != ttype) { \ + err("Expected token '%s', not '%s'", \ + token_type_string[ttype], \ + token_type_string[token->type]); \ + fail; \ } -#define TOKEN_SKIP(tctx, ttype, fail) do { \ - TOKEN_ASSERT(TOKEN(tctx), ttype, fail) \ - else { \ - TOKEN_NEXT(tctx); \ - } \ +#define TOKEN_SKIP(tctx, ttype, fail) do { \ + TOKEN_ASSERT(TOKEN(tctx), ttype, fail) \ + else { \ + TOKEN_NEXT(tctx); \ + } \ } while(0) #define TOKEN_MATCH(tctx, ttype, fail) do { \ @@ -67,7 +67,6 @@ static void print_value(value_t value) value_type_string[value->type] : "VALUE", buf); } -// token context struct tctx { enum tctx_type { TCTX_LEXER, @@ -81,7 +80,7 @@ struct tctx { lexer_t lexer; struct token token; } lex_ctx; - + struct tok_ctx { struct token *list; size_t len; @@ -122,7 +121,7 @@ static struct token *next_token(struct tctx *tctx) } #ifdef DEBUG - print_token(tctx->token); + // print_token(tctx->token); #endif return tctx->token; @@ -140,6 +139,7 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx); value_t evaluate_id (env_t env, struct tctx *tctx); value_t evaluate_lambda(env_t env, struct tctx *tctx); value_t evaluate_define(env_t env, struct tctx *tctx); +value_t evaluate_if (env_t env, struct tctx *tctx); value_t quote_expr(env_t env, struct tctx *tctx); value_t quote_sexp(env_t env, struct tctx *tctx); @@ -162,9 +162,20 @@ static void destroy_global_env(char *key, value_t value) int main(void) { + + char *filename = "files/test-lambda.l"; + + FILE *fp = fopen(filename, "r"); + if(!fp) { + die("fopen: %s", strerror(errno)); + } + + lexer_t lexer = lexer_create(fp); + env_t builtin_env = env_create(ENV_EMPTY, destroy_env); global_env = env_create(builtin_env, destroy_global_env); + // add builtins for(size_t i = 0; i < BUILTIN_PROCEDURES; i++) { value_t proc_value = value_create( VALUE_PROC_BUILTIN, @@ -173,15 +184,6 @@ int main(void) (void *)builtin_proc_name_list[i], (void *)proc_value, NULL, NULL); } - - char *filename = "files/test.l"; - - FILE *fp = fopen(filename, "r"); - if(!fp) { - die("fopen: %s", strerror(errno)); - } - - lexer_t lexer = lexer_create(fp); struct tctx tctx = {0}; tctx_init_lexer(&tctx, lexer); @@ -197,15 +199,14 @@ int main(void) char buf[256] = {0}; value_string(val, LEN(buf), buf); printf("%s:%zu: %s\n", filename, lexer->line, buf); - #endif - + #endif + value_destroy(val); } lexer_destroy(lexer); fclose(fp); - env_destroy(global_env); return 0; } @@ -222,7 +223,7 @@ static value_t apply_lambda(struct proc *proc, value_t *args) value_t ret = VALUE_EMPTY; env_t env = ENV_EMPTY; struct tctx tctx = {0}; - + ERR_Z(env = env_create(env_copy(proc->parent_env), destroy_env), goto exit); tctx_init_toklist(&tctx, proc->body, proc->body_len); @@ -231,10 +232,10 @@ static value_t apply_lambda(struct proc *proc, value_t *args) (void*)proc->arg_keys[i]->value.atom, (void*)value_copy(args[i]), NULL, NULL), _r, goto exit); } - + TOKEN_NEXT(&tctx); ret = evaluate_expr(env, &tctx); - + exit: env_destroy(env); return ret; @@ -244,7 +245,7 @@ value_t apply(value_t proc, size_t argc, value_t *argv) { // TODO: make a global nil and copy it if(proc == VALUE_EMPTY) return value_create(VALUE_NIL, NULL); - + switch(proc->type) { case VALUE_PROC: HAS_ENOUGH_ARGS(proc, proc, argc, return VALUE_EMPTY); @@ -261,7 +262,7 @@ value_t apply(value_t proc, size_t argc, value_t *argv) value_t evaluate_expr(env_t env, struct tctx *tctx) { value_t ret = VALUE_EMPTY; - + switch(TOKEN(tctx)->type) { case TOKEN_LP: ERR_Z(ret = evaluate_sexp(env, tctx), goto exit); @@ -303,14 +304,14 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx) size_t argc = 0; TOKEN_SKIP(tctx, TOKEN_LP, goto exit); - + for(argc = 0; TOKEN(tctx)->type != TOKEN_RP; argc++) { if(argc >= LEN(body)) { err("Too many arguments"); goto exit; } - + switch(TOKEN(tctx)->type) { case TOKEN_LAMBDA: SPECIAL_FORM(ret, argc, evaluate_lambda(env, tctx), goto exit); @@ -326,6 +327,9 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx) ret = VALUE_EMPTY; goto exit); goto exit; + case TOKEN_IF: + SPECIAL_FORM(ret, argc, evaluate_if(env, tctx), goto exit); + goto exit; default: ERR_Z(body[argc] = evaluate_expr(env, tctx), goto exit); break; @@ -335,20 +339,20 @@ value_t evaluate_sexp(env_t env, struct tctx *tctx) } #ifdef DEBUG - info("------------------"); - info("Applying procedure"); - print_value(body[0]); - info("With Arguemnts"); - if(argc > 0) - for(size_t i = 0; i < argc-1; i++) print_value(body[i+1]); + // info("------------------"); + // info("Applying procedure"); + // print_value(body[0]); + // info("With Arguemnts"); + // if(argc > 0) + // for(size_t i = 0; i < argc-1; i++) print_value(body[i+1]); #endif - + ret = apply(body[0], argc-1, &body[1]); #ifdef DEBUG - info("Returns"); - print_value(ret); - info("-----------------"); + // info("Returns"); + // print_value(ret); + // info("-----------------"); #endif exit: @@ -362,14 +366,14 @@ value_t evaluate_id(env_t env, struct tctx *tctx) if(env == ENV_EMPTY) { return evaluate_id(global_env, tctx); } - + value_t ret = VALUE_EMPTY; ERR_NZ(hashtable_query(env->table, (void *)TOKEN(tctx)->value.id, (void **)&ret), _r, goto fail); return value_copy(ret); fail: - if(env == global_env->parent) { + if(env == global_env->parent) { err("Symbol %s is unbound", TOKEN(tctx)->value.id); return VALUE_EMPTY; } @@ -379,14 +383,14 @@ fail: value_t evaluate_lambda(env_t env, struct tctx *tctx) { value_t ret = VALUE_EMPTY; - + value_t args[32] = {VALUE_EMPTY}; size_t argc = 0; value_t *arg_keys = NULL; - + struct token *body = NULL; size_t body_len = 0; - + TOKEN_SKIP(tctx, TOKEN_LAMBDA, goto fail); TOKEN_SKIP(tctx, TOKEN_LP, goto fail); @@ -396,21 +400,21 @@ value_t evaluate_lambda(env_t env, struct tctx *tctx) err("Too many arguments"); goto fail; } - + if(TOKEN(tctx)->type != TOKEN_ID) { err("Token '%s' not expected in lambda args", token_type_string[TOKEN(tctx)->type]); goto fail; } ERR_Z(args[argc++] = value_from_token(TOKEN(tctx)), goto fail); - + TOKEN_NEXT(tctx); } - + ERR_Z(body_len = toklist_expr(tctx, &body), goto fail); - + TOKEN_MATCH(tctx, TOKEN_RP, goto fail); - + arg_keys = calloc(argc, sizeof(*arg_keys)); memcpy(arg_keys, args, argc * sizeof(*arg_keys)); @@ -418,9 +422,9 @@ value_t evaluate_lambda(env_t env, struct tctx *tctx) ERR_Z(ret = value_create(VALUE_PROC, &proc), env_destroy(env); // remove the copy goto fail); - + return ret; - + fail: err("Procedure creation failed"); for(size_t i = 0; i < argc; i++) value_destroy(args[i]); @@ -441,14 +445,14 @@ fail: value_t evaluate_define(env_t env, struct tctx *tctx) { // TODO: don't alloc when the key is the same - char *key = NULL; + char *key = NULL; // only in the outside environement if(env != ENV_EMPTY) { err("define can only be called in the outermost environement"); goto fail; } - + TOKEN_SKIP(tctx, TOKEN_DEFINE, goto fail); switch(TOKEN(tctx)->type) @@ -462,17 +466,17 @@ value_t evaluate_define(env_t env, struct tctx *tctx) } TOKEN_NEXT(tctx); - + value_t val = VALUE_EMPTY; ERR_Z(val = evaluate_expr(env, tctx), goto fail); - + TOKEN_MATCH(tctx, TOKEN_RP, value_destroy(val); goto fail); value_t prevval = VALUE_EMPTY; char *prevkey = NULL; - + ERR_NZ( hashtable_insert(global_env->table, (void *)key, (void *)val, (void**)&prevkey, (void **)&prevval), @@ -485,12 +489,44 @@ value_t evaluate_define(env_t env, struct tctx *tctx) if(prevkey) free(prevkey); value_destroy(prevval); return VALUE_EMPTY; - + fail: if(key) free(key); return VALUE_EMPTY; } +value_t evaluate_if(env_t env, struct tctx *tctx) +{ + value_t ret = VALUE_EMPTY; + value_t cond = VALUE_EMPTY; + + TOKEN_SKIP(tctx, TOKEN_IF, goto exit); + + ERR_Z(cond = evaluate_expr(env, tctx), goto exit); + + ERR_Z(cond->type == VALUE_INT, + err("expected condition to evaluate to VALUE_INT"); + goto exit); + + if(cond->value.num) { + TOKEN_NEXT(tctx); + ret = evaluate_expr(env, tctx); + + toklist_expr(tctx, NULL); // skip one expression + } else { + toklist_expr(tctx, NULL); // skip one expression + + TOKEN_NEXT(tctx); + ret = evaluate_expr(env, tctx); + } + + TOKEN_MATCH(tctx, TOKEN_RP, goto exit); + +exit: + value_destroy(cond); + return ret; +} + value_t quote_expr(env_t env, struct tctx *tctx) { value_t ret = VALUE_EMPTY; @@ -504,7 +540,8 @@ value_t quote_expr(env_t env, struct tctx *tctx) case TOKEN_QUOTE: case TOKEN_LAMBDA: case TOKEN_DEFINE: - case TOKEN_QUOTE_FORM: ; + case TOKEN_QUOTE_FORM: + case TOKEN_IF: ; char name[64] = {0}; ERR_Z(token_value_string(TOKEN(tctx), LEN(name), name), goto exit); struct token temp = {0}; temp.type = TOKEN_ID; temp.value.id = name; @@ -534,7 +571,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx) // TODO: make global nil and copy it ERR_Z(nil = value_create(VALUE_NIL, NULL), goto exit); - + TOKEN_SKIP(tctx, TOKEN_LP, goto exit); // Parse NIL @@ -542,7 +579,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx) ret = value_copy(nil); goto exit; } - + ERR_Z(left = quote_expr(env, tctx), goto exit); TOKEN_NEXT(tctx); @@ -552,36 +589,36 @@ value_t quote_sexp(env_t env, struct tctx *tctx) TOKEN_NEXT(tctx); ERR_Z(right = quote_expr(env, tctx), return VALUE_EMPTY); TOKEN_MATCH(tctx, TOKEN_RP, return VALUE_EMPTY); - + struct cons cons = {value_copy(left), value_copy(right)}; ret = value_create(VALUE_CONS, &cons); goto exit; } - + // Parse list right = value_copy(nil); value_t *rightmost = &right; // the final nil while(TOKEN(tctx)->type != TOKEN_RP) { value_t new = VALUE_EMPTY; - + if(TOKEN(tctx)->type == TOKEN_DOT) { TOKEN_NEXT(tctx); - + ERR_Z(new = quote_expr(env, tctx), goto exit); TOKEN_MATCH(tctx, TOKEN_RP, value_destroy(new); goto exit); - - value_destroy(*rightmost); + + value_destroy(*rightmost); // destroy the copied nil *rightmost = new; break; - } - + } + ERR_Z(new = quote_expr(env, tctx), goto exit); - + value_t new_cons = VALUE_EMPTY; struct cons cons = {new, *rightmost}; ERR_Z(new_cons = value_create(VALUE_CONS, &cons), @@ -590,7 +627,7 @@ value_t quote_sexp(env_t env, struct tctx *tctx) *rightmost = new_cons; rightmost = &new_cons->value.cons.right; - + TOKEN_NEXT(tctx); } @@ -609,28 +646,30 @@ size_t toklist_expr(struct tctx *tctx, struct token **toklist) { struct token tokens[256]; size_t tokens_len = 0; - + size_t depth = 0; do { TOKEN_NEXT(tctx); - + if(tokens_len >= LEN(tokens)) { err("Too many tokens in expr"); goto fail; - } - + } + if(TOKEN(tctx)->type == TOKEN_LP) depth++; else if(TOKEN(tctx)->type == TOKEN_RP) depth--; token_clone(&tokens[tokens_len++], TOKEN(tctx)); - + } while(depth > 0 || IS_OP(TOKEN(tctx))); + if(!toklist) goto fail; + *toklist = calloc(tokens_len, sizeof(*tokens)); memcpy(*toklist, tokens, tokens_len * sizeof(*tokens)); return tokens_len; - + fail: for(size_t i = 0; i < tokens_len; i++) token_dealloc(&tokens[i]); return 0; |