#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_SKIP(ttype, fail) do { \ if(token.type == ttype) { \ TOKEN_NEXT(); \ break; \ } \ err("Expected token '%s', not '%s'", \ token_type_string[ttype], \ token_type_string[token.type]); \ fail; \ } while(0) #define TOKEN_MATCH(ttype, fail) do { \ TOKEN_NEXT(); \ if(token.type == ttype) break; \ \ err("Expected token '%s', not '%s'", \ token_type_string[ttype], \ token_type_string[token.type]); \ 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(void); value_t evaluate_sexp(void); value_t evaluate_id(void); value_t evaluate_lambda(void); value_t evaluate_define(void); value_t evaluate_quote(void); value_t quote_sexp(void); 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(); #ifdef FDEBUG print_value(); #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); 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); \ TOKEN_MATCH(TOKEN_RP, \ ret = VALUE_EMPTY; \ fail); \ } while(0) value_t evaluate(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 = evaluate_quote(), 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, evaluate_quote(), goto exit); goto exit; default: ERR_Z(body[argc] = evaluate(), 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) { NOT_IMPLEMENTED(); } #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 value_t ret = VALUE_EMPTY; char *key = NULL; TOKEN_SKIP(TOKEN_DEFINE, goto exit); // only in the outside environement if(env->parent != user_env) goto exit; 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 exit; } TOKEN_NEXT(); ERR_Z(ret = evaluate(), goto exit); TOKEN_MATCH(TOKEN_RP, goto exit); value_t prevval = VALUE_EMPTY; char *prevkey = NULL; ERR_NZ( hashtable_insert(user_env->table, (void *)key, (void *)ret, (void**)&prevkey, (void **)&prevval), r, { err("Couldn't insert symbol into the hashtable due to %s", strerror(r)); value_destroy(ret); free(key); return VALUE_EMPTY; }); if(prevkey) free(prevkey); value_destroy(prevval); exit: return VALUE_EMPTY; } value_t evaluate_quote(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(), 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 = evaluate_quote(), goto exit); TOKEN_NEXT(); if(token.type == TOKEN_DOT) { // Parse cons TOKEN_NEXT(); ERR_Z(right = evaluate_quote(), 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 = evaluate_quote(), 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; }