diff options
Diffstat (limited to 'src/main.c')
| -rw-r--r-- | src/main.c | 199 |
1 files changed, 119 insertions, 80 deletions
@@ -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; |