#include #include #include #include "lexer.h" #include "value.h" #include "env.h" #ifdef ENABLE_MEMDEBUG #define MEMDEBUG_OUT_OF_BOUNDS #define MEMDEBUG_IMPLEMENTATION #define MEMDEBUG_MAIN_VOID #define MEMDEBUG_OUTPUT_DIR "files" #endif #include "common.h" #include "builtin.h" #define LEN(arr) (sizeof(arr)/sizeof(*(arr))) // TODO: // - Think about memory leakage and on non fatal errors // like failed list creation and faild s-exp parsing // - Check for functions not wrapped in ERR_* macro // - Add more error messages #ifndef DEBUG #define TOKEN_NEXT() \ ERR_NZ(lexer_token_next(lexer, &token), r, \ die("Can't get next token")) #else #define TOKEN_NEXT() do { \ ERR_NZ(lexer_token_next(lexer, &token), r, \ die("Can't get next token")); \ print_token(&token); \ } while(0) #endif #define TOKEN_ASSERT(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(ttype, fail) do { \ TOKEN_ASSERT(ttype, fail) \ else { \ TOKEN_NEXT(); \ } \ } while(0) #define TOKEN_MATCH(ttype, fail) do { \ TOKEN_NEXT(); \ TOKEN_ASSERT(ttype, fail); \ } while(0) #define HAS_ENOUGH_ARGS(proc, type, argc, fail) \ if(argc != proc->value.type.argc) { \ err("Wrong number of arguemnts, expected %zu, but got %zu", \ proc->value.type.argc, argc); \ fail; \ } #define NOT_IMPLEMENTED() die("Not Implemented. ABORTING") static void print_token(struct token *token) { char buf[256] = {0}; ERR_Z(token_value_string(token, LEN(buf), buf), return); info("%-12s %s", token_type_string[token->type], buf); } static void print_value(value_t value) { char buf[256] = {0}; value_string(value, LEN(buf), buf); info("%-12s %s", value ? value_type_string[value->type] : "VALUE", buf); } static lexer_t lexer = LEXER_EMPTY; static env_t user_env = ENV_EMPTY; env_t env = ENV_EMPTY; struct token token; value_t apply(value_t proc, size_t argc, value_t *argv); value_t evaluate_expr(void); value_t evaluate_sexp(void); value_t evaluate_id(void); value_t evaluate_lambda(void); value_t evaluate_define(void); value_t quote_expr(void); value_t quote_sexp(void); size_t toklist_expr(struct token **toklist); static void destroy_env(char *key, value_t value) { (void)key; value_destroy(value); } static void destroy_user_env(char *key, value_t value) { free(key); value_destroy(value); } int main(void) { user_env = env_create(ENV_EMPTY, destroy_user_env); env = env_create(user_env, destroy_env); for(size_t i = 0; i < BUILTIN_PROCEDURES; i++) { value_t proc_value = value_create( VALUE_PROC_BUILTIN, (void *)&builtin_proc_descriptions[i]); hashtable_insert(env->table, (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 = lexer_create(fp); while(lexer_token_next(lexer, &token) == 0) { value_t val = evaluate_expr(); #ifdef DEBUG print_value(val); #else char buf[256] = {0}; value_string(val, LEN(buf), buf); printf("%s:%zu: %s\n", filename, lexer->line, buf); #endif value_destroy(val); } lexer_destroy(lexer); fclose(fp); env_destroy(env); // env_destroy(user_env); return 0; } 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); // create new env // evaluate body // destroy new env // switch back to the previous env NOT_IMPLEMENTED(); return VALUE_EMPTY; case VALUE_PROC_BUILTIN: HAS_ENOUGH_ARGS(proc, proc_builtin, argc, return VALUE_EMPTY); return proc->value.proc_builtin.proc(argv); default: err("Value is not a procedure"); return VALUE_EMPTY; } } #define IS_NOT_FIRST(arg, fail) \ if(arg != 0) { \ err("special forms can only be the first argument"); \ fail; \ } #define SPECIAL_FORM(ret, argc, fn, fail) do { \ IS_NOT_FIRST(argc, fail); \ ERR_Z(ret = fn, fail); \ } while(0) value_t evaluate_expr(void) { value_t ret = VALUE_EMPTY; switch(token.type) { case TOKEN_LP: ERR_Z(ret = evaluate_sexp(), goto exit); break; case TOKEN_ID: ERR_Z(ret = evaluate_id(), goto exit); break; case TOKEN_STR: case TOKEN_INT: ERR_Z(ret = value_from_token(&token), goto exit); break; case TOKEN_QUOTE: TOKEN_NEXT(); ERR_Z(ret = quote_expr(), goto exit); break; default: err("Did not exptect token '%s'", token_type_string[token.type]); break; } exit: return ret; } value_t evaluate_sexp(void) { value_t ret = VALUE_EMPTY; value_t body[256] = {VALUE_EMPTY}; size_t argc = 0; TOKEN_SKIP(TOKEN_LP, goto exit); for(argc = 0; token.type != TOKEN_RP; argc++) { if(argc >= LEN(body)) { err("Too many arguments"); goto exit; } switch(token.type) { case TOKEN_LAMBDA: SPECIAL_FORM(ret, argc, evaluate_lambda(), goto exit); goto exit; case TOKEN_DEFINE: SPECIAL_FORM(ret, argc, evaluate_define(), goto exit); goto exit; case TOKEN_QUOTE_FORM: TOKEN_NEXT(); SPECIAL_FORM(ret, argc, quote_expr(), goto exit); TOKEN_MATCH(TOKEN_RP, value_destroy(ret); ret = VALUE_EMPTY; goto exit); goto exit; default: ERR_Z(body[argc] = evaluate_expr(), goto exit); break; } TOKEN_NEXT(); } ret = apply(body[0], argc-1, &body[1]); #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("Returns"); print_value(ret); info("-----------------"); #endif exit: for(size_t i = 0; i < argc; i++) value_destroy(body[i]); return ret; } static value_t evaluate_id_env(env_t env) { if(env == ENV_EMPTY) return VALUE_EMPTY; value_t ret = VALUE_EMPTY; ERR_NZ(hashtable_query(env->table, (void *)token.value.id, (void **)&ret), _r, return evaluate_id_env(env->parent)); return value_copy(ret); } value_t evaluate_id(void) { return evaluate_id_env(env); } value_t evaluate_lambda(void) { 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(TOKEN_LAMBDA, goto fail); TOKEN_SKIP(TOKEN_LP, goto fail); while(token.type != TOKEN_RP) { if(argc >= LEN(args)) { err("Too many arguments"); goto fail; } if(token.type != TOKEN_ID) { err("Token '%s' not expected in lambda args", token_type_string[token.type]); goto fail; } ERR_Z(args[argc++] = value_from_token(&token), goto fail); TOKEN_NEXT(); } ERR_Z(body_len = toklist_expr(&body), goto fail); TOKEN_MATCH(TOKEN_RP, goto fail); arg_keys = calloc(argc, sizeof(*arg_keys)); memcpy(arg_keys, args, argc * sizeof(*arg_keys)); struct proc proc = {env_copy(env), arg_keys, argc, body, body_len}; ERR_Z(ret = value_create(VALUE_PROC, &proc), goto fail); return ret; fail: err("Procedure creation failed"); for(size_t i = 0; i < argc; i++) value_destroy(args[i]); if(body) { for(size_t i = 0; i < body_len; i++) token_dealloc(&body[i]); free(body); } if(arg_keys) free(arg_keys); return VALUE_EMPTY; } #define STR_ALLOC_COPY(dest, str) do { \ size_t len = strlen(str) + 1; \ dest = malloc(len); \ memcpy((dest), (str), len); \ } while(0) value_t evaluate_define(void) { // TODO: don't alloc when the key is the same char *key = NULL; // only in the outside environement if(env->parent != user_env) { err("define can only be called in the outermost environement"); goto fail; } TOKEN_SKIP(TOKEN_DEFINE, goto fail); switch(token.type) { case TOKEN_ID: STR_ALLOC_COPY(key, token.value.id); break; default: err("Did not exptect token '%s'", token_type_string[token.type]); goto fail; } TOKEN_NEXT(); value_t val = VALUE_EMPTY; ERR_Z(val = evaluate_expr(), goto fail); TOKEN_MATCH(TOKEN_RP, value_destroy(val); goto fail); value_t prevval = VALUE_EMPTY; char *prevkey = NULL; ERR_NZ( hashtable_insert(user_env->table, (void *)key, (void *)val, (void**)&prevkey, (void **)&prevval), r, { err("Couldn't insert symbol into the hashtable due to %s", strerror(r)); value_destroy(val); // the copy goto fail; }); if(prevkey) free(prevkey); value_destroy(prevval); return VALUE_EMPTY; fail: if(key) free(key); return VALUE_EMPTY; } value_t quote_expr(void) { value_t ret = VALUE_EMPTY; switch(token.type) { case TOKEN_ID: case TOKEN_STR: case TOKEN_INT: ERR_Z(ret = value_from_token(&token), goto exit); break; case TOKEN_QUOTE: case TOKEN_LAMBDA: case TOKEN_DEFINE: case TOKEN_QUOTE_FORM: ; char name[64] = {0}; ERR_Z(token_value_string(&token, LEN(name), name), goto exit); struct token temp = {0}; temp.type = TOKEN_ID; temp.value.id = name; ERR_Z(ret = value_from_token(&temp), goto exit); break; case TOKEN_LP: ERR_Z(ret = quote_sexp(), goto exit); break; case TOKEN_UNQUOTE: TOKEN_SKIP(TOKEN_UNQUOTE, goto exit); ERR_Z(ret = evaluate_expr(), goto exit); break; default: err("Did not exptect token '%s'", token_type_string[token.type]); break; } exit: return ret; } value_t quote_sexp(void) { value_t ret = VALUE_EMPTY; value_t left = VALUE_EMPTY; value_t right = VALUE_EMPTY; value_t nil = VALUE_EMPTY; // TODO: make global nil and copy it ERR_Z(nil = value_create(VALUE_NIL, NULL), goto exit); TOKEN_SKIP(TOKEN_LP, goto exit); // Parse NIL if(token.type == TOKEN_RP) { ret = value_copy(nil); goto exit; } ERR_Z(left = quote_expr(), goto exit); TOKEN_NEXT(); if(token.type == TOKEN_DOT) { // Parse cons TOKEN_NEXT(); ERR_Z(right = quote_expr(), return VALUE_EMPTY); TOKEN_MATCH(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.type != TOKEN_RP) { value_t new = VALUE_EMPTY; ERR_Z(new = quote_expr(), goto exit); value_t new_cons = VALUE_EMPTY; struct cons cons = {new, *rightmost}; ERR_Z(new_cons = value_create(VALUE_CONS, &cons), value_destroy(new); goto exit); *rightmost = new_cons; rightmost = &new_cons->value.cons.right; TOKEN_NEXT(); } struct cons cons = {value_copy(left), value_copy(right)}; ret = value_create(VALUE_CONS, &cons); exit: value_destroy(left); value_destroy(right); value_destroy(nil); return ret; } size_t toklist_expr(struct token **toklist) { struct token tokens[256]; size_t tokens_len = 0; size_t depth = 0; do { TOKEN_NEXT(); if(tokens_len >= LEN(tokens)) { err("Too many tokens in expr"); goto fail; } if(token.type == TOKEN_LP) depth++; else if(token.type == TOKEN_RP) depth--; token_clone(&tokens[tokens_len++], &token); } while(depth > 0); *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; }