From 4f0fef064e8d88a0c486baeb6a0095b2113984c3 Mon Sep 17 00:00:00 2001 From: Felix Brendel Date: Thu, 19 Mar 2020 01:02:06 +0100 Subject: [PATCH] Docs is stored external to the lisp objects in a hashmap now --- build.sh | 2 +- src/assert.hpp | 126 +- src/built_ins.cpp | 2538 +++++++++++++++++++++-------------------- src/define_macros.hpp | 318 +++--- src/docgeneration.cpp | 288 ++--- src/eval.cpp | 1090 +++++++++--------- src/forward_decls.cpp | 177 ++- src/gc.cpp | 192 ++-- src/globals.cpp | 81 +- src/io.cpp | 1156 +++++++++---------- src/libslime.cpp | 242 ++-- src/lisp_object.cpp | 64 +- src/main.cpp | 61 +- src/memory.cpp | 1041 ++++++++--------- src/structs.cpp | 28 +- src/testing.cpp | 1320 ++++++++++----------- 16 files changed, 4336 insertions(+), 4388 deletions(-) diff --git a/build.sh b/build.sh index 89d2a42..2e8158f 100755 --- a/build.sh +++ b/build.sh @@ -52,7 +52,7 @@ echo "" echo "----------------------" echo " running profile " echo "----------------------" -time ./slime_p --run-tests || exit 1 +time ./slime_p --run-tests > /dev/null || exit 1 echo "" echo "------------------------" diff --git a/src/assert.hpp b/src/assert.hpp index 527e643..7998d0e 100644 --- a/src/assert.hpp +++ b/src/assert.hpp @@ -1,63 +1,63 @@ -/** - Usage of the create_error_macros: -*/ -#define __create_error(keyword, ...) \ - create_error( \ - __FUNCTION__, __FILE__, __LINE__, \ - Memory::get_keyword(keyword), \ - __VA_ARGS__) - -#define create_out_of_memory_error(...) \ - __create_error("out-of-memory", __VA_ARGS__) - -#define create_generic_error(...) \ - __create_error("generic", __VA_ARGS__) - -#define create_not_yet_implemented_error() \ - __create_error("not-yet-implemented", "This feature has not yet been implemented.") - -#define create_parsing_error(...) \ - __create_error("parsing-error", __VA_ARGS__) - -#define create_symbol_undefined_error(...) \ - __create_error("symbol-undefined", __VA_ARGS__) - -#define create_type_missmatch_error(expected, actual, exp) \ - __create_error("type-missmatch", \ - "Type missmatch: expected %s, got %s in %s", \ - expected, actual, exp) - -#ifdef _DEBUG - -#define assert_type(_node, _type) \ - do { \ - if (Memory::get_type(_node) != _type) { \ - char* t = lisp_object_to_string(_node); \ - defer { free(t); }; \ - create_type_missmatch_error( \ - lisp_object_type_to_string(_type), \ - lisp_object_type_to_string(Memory::get_type(_node)), \ - t); \ - } \ - } while(0) - -#define assert_list_length(_node, _len) assert("List length assertion", list_length(_node) == _len) - -#define assert(message, condition) \ - do { \ - if (!(condition)) { \ - create_generic_error("Assertion-error: %s\n" \ - " for: %s\n" \ - " in: %s:%d", \ - message, #condition, __FILE__, __LINE__); \ - } \ - } while(0) - -#else -# define assert_arguments_length(expected, actual) do {} while (0) -# define assert_arguments_length_less_equal(expected, actual) do {} while (0) -# define assert_arguments_length_greater_equal(expected, actual) do {} while (0) -# define assert_type(_node, _type) do {} while (0) -# define assert_list_length(_node, _len) do {} while (0) -# define assert(message, condition) do {} while (0) -#endif +/** + Usage of the create_error_macros: +*/ +#define __create_error(keyword, ...) \ + create_error( \ + __FUNCTION__, __FILE__, __LINE__, \ + Memory::get_keyword(keyword), \ + __VA_ARGS__) + +#define create_out_of_memory_error(...) \ + __create_error("out-of-memory", __VA_ARGS__) + +#define create_generic_error(...) \ + __create_error("generic", __VA_ARGS__) + +#define create_not_yet_implemented_error() \ + __create_error("not-yet-implemented", "This feature has not yet been implemented.") + +#define create_parsing_error(...) \ + __create_error("parsing-error", __VA_ARGS__) + +#define create_symbol_undefined_error(...) \ + __create_error("symbol-undefined", __VA_ARGS__) + +#define create_type_missmatch_error(expected, actual, exp) \ + __create_error("type-missmatch", \ + "Type missmatch: expected %s, got %s in %s", \ + expected, actual, exp) + +#ifdef _DEBUG + +#define assert_type(_node, _type) \ + do { \ + if (_node->type != _type) { \ + char* t = lisp_object_to_string(_node); \ + defer { free(t); }; \ + create_type_missmatch_error( \ + lisp_object_type_to_string(_type), \ + lisp_object_type_to_string(_node->type), \ + t); \ + } \ + } while(0) + +#define assert_list_length(_node, _len) assert("List length assertion", list_length(_node) == _len) + +#define assert(message, condition) \ + do { \ + if (!(condition)) { \ + create_generic_error("Assertion-error: %s\n" \ + " for: %s\n" \ + " in: %s:%d", \ + message, #condition, __FILE__, __LINE__); \ + } \ + } while(0) + +#else +# define assert_arguments_length(expected, actual) do {} while (0) +# define assert_arguments_length_less_equal(expected, actual) do {} while (0) +# define assert_arguments_length_greater_equal(expected, actual) do {} while (0) +# define assert_type(_node, _type) do {} while (0) +# define assert_list_length(_node, _len) do {} while (0) +# define assert(message, condition) do {} while (0) +#endif diff --git a/src/built_ins.cpp b/src/built_ins.cpp index 3d57cc0..055d294 100644 --- a/src/built_ins.cpp +++ b/src/built_ins.cpp @@ -1,1267 +1,1271 @@ -namespace Slime { - proc lisp_object_equal(Lisp_Object* n1, Lisp_Object* n2) -> bool { - if (n1 == n2) - return true; - if (Memory::get_type(n1) != Memory::get_type(n2)) - return false; - - switch (Memory::get_type(n1)) { - - case Lisp_Object_Type::T: - case Lisp_Object_Type::Nil: - case Lisp_Object_Type::Symbol: - case Lisp_Object_Type::Keyword: - case Lisp_Object_Type::Function: - // TODO(Felix): should a pointer - // object compare the pointer? - case Lisp_Object_Type::Pointer: - case Lisp_Object_Type::Continuation: return false; - case Lisp_Object_Type::Number: return n1->value.number == n2->value.number; - case Lisp_Object_Type::String: return string_equal(n1->value.string, n2->value.string); - case Lisp_Object_Type::Pair: { - return lisp_object_equal(n1->value.pair.first, n2->value.pair.first) && - lisp_object_equal(n1->value.pair.rest, n2->value.pair.rest); - } break; - case Lisp_Object_Type::HashMap: { - auto n1_keys = n1->value.hashMap->get_all_keys(); - auto n2_keys = n2->value.hashMap->get_all_keys(); - defer { - n1_keys.dealloc(); - n2_keys.dealloc(); - }; - - if (n1_keys.next_index != n2_keys.next_index) - return false; - - n1_keys.sort(); - n2_keys.sort(); - - for (int i = 0; i < n1_keys.next_index; ++i) { - if (!lisp_object_equal(n1_keys[i], n2_keys[i])) - return false; - if (!lisp_object_equal(n1->value.hashMap->get_object(n1_keys[i]), - n2->value.hashMap->get_object(n2_keys[i]))) - return false; - } - return true; - - } - case Lisp_Object_Type::Vector: { - if (n1->value.vector.length != n2->value.vector.length ) - return false; - for (int i = 0; i < n1->value.vector.length; ++i) { - if (!lisp_object_equal(n1->value.vector.data+i, n2->value.vector.data+i)) - return false; - } - return true; - } break; - default: create_not_yet_implemented_error(); - } - - // we should never reach here - return false; - } - - proc add_to_load_path(const char* path) -> void { - using Globals::load_path; - - load_path.append((void*)path); - } - - proc built_in_load(String file_name) -> Lisp_Object* { - profile_with_comment(file_name.data); - char* file_content; - char fullpath[4096]; - sprintf(fullpath, "%s", Memory::get_c_str(file_name)); - file_content = read_entire_file(Memory::get_c_str(file_name)); - - if (!file_content) { - for (auto it: Globals::load_path) { - fullpath[0] = '\0'; - sprintf(fullpath, "%s%s", (char*)it, Memory::get_c_str(file_name)); - file_content = read_entire_file(fullpath); - if (file_content) - break; - } - if (!file_content) { - printf("Load path:\n"); - for (auto it : Globals::load_path) { - printf(" - %s\n", (char*) it); - } - create_generic_error("The file to load '%s' was not found in the load path.", - Memory::get_c_str(file_name)); - return nullptr; - } - - } - - - Lisp_Object* result = Memory::nil; - Array_List* program; - String spath = Memory::create_string(fullpath); - defer { - free(spath.data); - }; - try program = Parser::parse_program(spath, file_content); - - // NOTE(Felix): deferred so even if the eval failes, it will - // run - defer { - program->dealloc(); - free(program); - free(file_content); - }; - for (auto expr : *program) { - try result = eval_expr(expr); - } - - return result; - } - - proc built_in_import(String file_name) -> Lisp_Object* { - profile_this(); - Environment* new_env; - - new_env = Memory::file_to_env_map.get_object(Memory::get_c_str(file_name)); - - if (!new_env) { - // create new empty environment - try new_env = Memory::create_child_environment(get_root_environment()); - // TODO(Felix): check absoulute paths in the map, not just - // relative ones - Memory::file_to_env_map.set_object(Memory::get_c_str(file_name), new_env); - push_environment(new_env); - defer { - pop_environment(); - }; - - Lisp_Object* res; - try res = built_in_load(file_name); - } - - get_current_environment()->parents.append(new_env); - - return Memory::nil; - } - - proc load_built_ins_into_environment() -> void* { - profile_this(); - String file_name_built_ins = Memory::create_string(__FILE__); - defer { - free(file_name_built_ins.data); - }; - define((remove_when_double_free_is_fixed (:k1 ()) (:k2 ()) . rest), "") { - return Memory::nil; - }; - define((remove_when_double_free_is_fixed_2 (:k1 ()) (:k2 ()) . rest), "") { - return Memory::nil; - }; - define_macro((apply fun fun_args), "TODO") { - // NOTE(Felix): is has to be a macro because apply by - // itself cannot return the result, we have to invoke eval - // and to prevent recursion, apply is a macro - - profile_with_name("(apply)"); - using namespace Globals::Current_Execution; - - --cs.next_index; - --ams.next_index; - Lisp_Object* args = pcs[--pcs.next_index]; - try_void assert_list_length(args, 2); - - Lisp_Object* fun = args->value.pair.first; - Lisp_Object* fun_args = args->value.pair.rest->value.pair.first; - - // 3. push args on the stack and apply - ats.append([] { - Lisp_Object* args_as_list = cs[--cs.next_index]; - for_lisp_list (args_as_list) { - cs.append(it); - } - pcs.append(Memory::nil); - (nass.end()-1)->append(NasAction::Step); - }); - (nass.end()-1)->append(NasAction::And_Then_Action); - - // 2. Eval fun_args and keep them on the stack - ats.append([] { - // NOTE(Felix): Flip the top 2 elements on cs because - // top is now the evaluated function, and below is the unevaluated args - Lisp_Object* tmp = cs[cs.next_index-1]; - cs[cs.next_index-1] = cs[cs.next_index-2]; - cs[cs.next_index-2] = tmp; - (nass.end()-1)->append(NasAction::Eval); - }); - (nass.end()-1)->append(NasAction::And_Then_Action); - - - // 1. Eval function and keep it on the stack, below it - // store the unevaluated argument list - ams.append(cs.next_index); - cs.append(fun_args); - cs.append(fun); - (nass.end()-1)->append(NasAction::Eval); - - }; - define((get-counter), - "When called returns a procedure that represents\n" - "a counter. Each time it is called it returns the\n" - "next whole number.") - { - define_symbol( - Memory::get_symbol("c"), - Memory::create_lisp_object((double)0)); - String file_name_built_ins = Memory::create_string(__FILE__); - define((lambda), "") { - fetch(c); - c->value.number++; - return c; - }; - fetch(lambda); - return lambda; - }; - define_macro((eval expr), - "Takes one argument, and evaluates it two times.") - { - profile_with_name("(eval)"); - using namespace Globals::Current_Execution; - cs.data[cs.next_index-1] = pcs[--pcs.next_index]->value.pair.first; - (nass.end()-1)->append(NasAction::Eval); - (nass.end()-1)->append(NasAction::Eval); - - }; - define_macro((begin . rest), - "Takes any number of forms. Evaluates them in order, " - "and returns the last result.") - { - profile_with_name("(begin)"); - using namespace Globals::Current_Execution; - --cs.next_index; - --ams.next_index; - Lisp_Object* args = pcs[--pcs.next_index]; - int length = list_length(args); - cs.reserve(length); - for_lisp_list(args) { - cs.data[cs.next_index - 1 + (length - it_index)] = it; - (nass.end()-1)->append(NasAction::Eval); - (nass.end()-1)->append(NasAction::Pop); - } - - --(nass.end()-1)->next_index; - cs.next_index += length; - }; - define_macro((if test then_part else_part), - "Takes 3 arguments. If the first arguments evaluates to a truthy " - "value, the if expression evaluates the second argument, else " - "it will evaluete the third one and return them respectively.") - { - profile_with_name("(if)"); - using namespace Globals::Current_Execution; - /* | | | | - | | -> | | - | | | | - | .... | | ...... | */ - --ams.next_index; - Lisp_Object* args = pcs.data[--pcs.next_index]; - Lisp_Object* test = args->value.pair.first; - args = args->value.pair.rest; - try_void assert_type(args, Lisp_Object_Type::Pair); - Lisp_Object* consequence = args->value.pair.first; - args = args->value.pair.rest; - try_void assert_type(args, Lisp_Object_Type::Pair); - Lisp_Object* alternative = args->value.pair.first; - args = args->value.pair.rest; - try_void assert_type(args, Lisp_Object_Type::Nil); - --cs.next_index; - cs.append(alternative); - cs.append(consequence); - cs.append(test); - - (nass.end()-1)->append(NasAction::Eval); - (nass.end()-1)->append(NasAction::If); - (nass.end()-1)->append(NasAction::Eval); - - }; - define_macro((define definee . args), "") { - // NOTE(Felix): define has to be a macro, because we need - // to evaluate the value for definee in case it is a - // simple variable (not a function). So ebcause we don't - // want to recursivly evaluate the value, we use a macro - // and a NasAction. - profile_with_name("(define)"); - using namespace Globals::Current_Execution; - --cs.next_index; - --ams.next_index; - Lisp_Object* form = pcs.data[--pcs.next_index]; - Lisp_Object* definee = form->value.pair.first; - form = form->value.pair.rest; - try_void assert_type(form, Lisp_Object_Type::Pair); - Lisp_Object* thing = form->value.pair.first; - Lisp_Object* thing_cons = form; - form = form->value.pair.rest; - Lisp_Object_Type type = Memory::get_type(definee); - switch (type) { - case Lisp_Object_Type::Symbol: { - if (form != Memory::nil) { - Lisp_Object* doc = thing; - try_void assert_type(doc, Lisp_Object_Type::String); - try_void assert_type(form, Lisp_Object_Type::Pair); - thing = form->value.pair.first; - try_void assert("list must end here.", form->value.pair.rest == Memory::nil); - // TODO docs (maybe with hooks) we have to attach - // the docs to the result of evaluating - } - cs.append(definee); - cs.append(thing); - (nass.end()-1)->append(NasAction::Define_Var); - (nass.end()-1)->append(NasAction::Eval); - } break; - case Lisp_Object_Type::Pair: { - try_void assert_type(definee->value.pair.first, Lisp_Object_Type::Symbol); - Lisp_Object* func; - try_void func = Memory::create_lisp_object_function(Lisp_Function_Type::Lambda); - func->value.function->parent_environment = get_current_environment(); - create_arguments_from_lambda_list_and_inject(definee->value.pair.rest, func); - if (Memory::get_type(thing_cons->value.pair.first) == Lisp_Object_Type::String && - thing_cons->value.pair.rest != Memory::nil) - { - // extract docs - //TODO(Felix): make docs as HM lookup - // func->docstring = thing_cons->value.pair.first->value.string; - thing_cons = thing_cons->value.pair.rest; - } - func->value.function->body.lisp_body = maybe_wrap_body_in_begin(thing_cons); - define_symbol(definee->value.pair.first, func); - cs.append(Memory::t); - } break; - default: { - create_generic_error("you can only define symbols"); - return; - } - } - }; - define((helper), "") { - profile_with_name("(helper)"); - return Memory::create_lisp_object(101.0); - }; - define((enable-debug-log), "") { - profile_with_name("(enable-debug-log)"); - Globals::debug_log = true; - return Memory::t; - }; - define((disable-debug-log), "") { - profile_with_name("(disable-debug-log)"); - Globals::debug_log = false; - return Memory::t; - }; - define_special((with-debug-log . rest), "") { - profile_with_name("(enable-debug-log)"); - fetch(rest); - Lisp_Object* result; - Globals::debug_log = true; - in_caller_env { - for_lisp_list(rest) { - // TODO(Felix): hooky would be really nice to - // have. Then this would be a macro and we would - // reset the debug log - try result = eval_expr(it); - } - } - Globals::debug_log = false; - return result; - }; - define((test (:k (helper))), "") { - profile_with_name("(test)"); - fetch(k); - return k; - }; - define((= . args), - "Takes 0 or more arguments and returns =t= if all arguments are equal " - "and =()= otherwise.") - { - profile_with_name("(=)"); - fetch(args); - - if (args == Memory::nil) - return Memory::t; - - Lisp_Object* first = args->value.pair.first; - - for_lisp_list (args) { - if (!lisp_object_equal(it, first)) - return Memory::nil; - } - - return Memory::t; - }; - define((> . args), "TODO") { - profile_with_name("(>)"); - fetch(args); - double last_number = strtod("Inf", NULL); - - for_lisp_list (args) { - try assert_type(it, Lisp_Object_Type::Number); - if (it->value.number >= last_number) - return Memory::nil; - last_number = it->value.number; - } - - return Memory::t; - }; - define((>= . args), "TODO") - { - profile_with_name("(>=)"); - fetch(args); - double last_number = strtod("Inf", NULL); - - for_lisp_list (args) { - try assert_type(it, Lisp_Object_Type::Number); - if (it->value.number > last_number) - return Memory::nil; - last_number = it->value.number; - } - - return Memory::t; - }; - define((< . args), "TODO") - { - profile_with_name("(<)"); - fetch(args); - double last_number = strtod("-Inf", NULL); - - for_lisp_list (args) { - try assert_type(it, Lisp_Object_Type::Number); - if (it->value.number <= last_number) - return Memory::nil; - last_number = it->value.number; - } - - return Memory::t; - }; - define((<= . args), "TODO") - { - profile_with_name("(<=)"); - fetch(args); - double last_number = strtod("-Inf", NULL); - - for_lisp_list (args) { - try assert_type(it, Lisp_Object_Type::Number); - if (it->value.number < last_number) - return Memory::nil; - last_number = it->value.number; - } - - return Memory::t; - }; - define((+ . args), "TODO") - { - profile_with_name("(+)"); - fetch(args); - - double sum = 0; - - for_lisp_list (args) { - try assert_type(it, Lisp_Object_Type::Number); - sum += it->value.number; - } - - return Memory::create_lisp_object(sum); - }; - define((- . args), "TODO") - { - profile_with_name("(-)"); - fetch(args); - if (args == Memory::nil) - return Memory::create_lisp_object(0.0); - - - try assert_type(args->value.pair.first, Lisp_Object_Type::Number); - double difference = args->value.pair.first->value.number; - - if (args->value.pair.rest == Memory::nil) { - return Memory::create_lisp_object(-difference); - } - - for_lisp_list (args->value.pair.rest) { - try assert_type(it, Lisp_Object_Type::Number); - difference -= it->value.number; - } - - return Memory::create_lisp_object(difference); - }; - define((* . args), "TODO") - { - profile_with_name("(*)"); - fetch(args); - if (args == Memory::nil) { - return Memory::create_lisp_object(1); - } - - double product = 1; - - for_lisp_list (args) { - try assert_type(it, Lisp_Object_Type::Number); - product *= it->value.number; - } - - return Memory::create_lisp_object(product); - }; - define((/ . args), "TODO") - { - profile_with_name("(/)"); - fetch(args); - - if (args == Memory::nil) { - return Memory::create_lisp_object(1); - } - - try assert_type(args->value.pair.first, Lisp_Object_Type::Number); - - double quotient = args->value.pair.first->value.number; - - for_lisp_list (args->value.pair.rest) { - try assert_type(it, Lisp_Object_Type::Number); - quotient /= it->value.number; - } - - return Memory::create_lisp_object(quotient); - }; - define((** a b), "TODO") { - profile_with_name("(**)"); - fetch(a, b); - try assert_type(a, Lisp_Object_Type::Number); - try assert_type(b, Lisp_Object_Type::Number); - return Memory::create_lisp_object(pow(a->value.number, - b->value.number)); - }; - define((% a b), "TODO") { - profile_with_name("(%)"); - fetch(a, b); - try assert_type(a, Lisp_Object_Type::Number); - try assert_type(b, Lisp_Object_Type::Number); - return Memory::create_lisp_object((int)a->value.number % - (int)b->value.number); - }; - define((get-random-between a b), "TODO") { - profile_with_name("(get-random-between)"); - fetch(a, b); - try assert_type(a, Lisp_Object_Type::Number); - try assert_type(b, Lisp_Object_Type::Number); - - double fa = a->value.number; - double fb = b->value.number; - double x = (double)rand()/(double)(RAND_MAX); - x *= (fb - fa); - x += fa; - - return Memory::create_lisp_object(x); - }; - define((gensym), "TODO") { - profile_with_name("(gensym)"); - Lisp_Object* node; - try node = Memory::create_lisp_object(); - Memory::set_type(node, Lisp_Object_Type::Symbol); - node->value.symbol = Memory::create_string("gensym"); - return node; - }; - define_special((bound? var), "TODO") { - profile_with_name("(bound?)"); - fetch(var); - try assert_type(var, Lisp_Object_Type::Symbol); - - Lisp_Object* res; - in_caller_env { - res = try_lookup_symbol(var, get_current_environment()); - } - if (res) - return Memory::t; - return Memory::nil; - }; - define_special((assert test), "TODO") { - profile_with_name("(assert)"); - fetch(test); - - in_caller_env { - Lisp_Object* res; - try res = eval_expr(test); - if (is_truthy(res)) - return Memory::t; - } - - char* string = lisp_object_to_string(test, true); - create_generic_error("Userland assertion. (%s)", string); - free(string); - return nullptr; - }; - define_special((define-syntax form . body), "TODO") { - profile_with_name("(define-syntax)"); - fetch(form, body); - // TODO(Felix): Macros cannot have docs now - - if (Memory::get_type(form) != Lisp_Object_Type::Pair) { - create_parsing_error("You can only create function macros."); - return nullptr; - } - - Lisp_Object* symbol = form->value.pair.first; - Lisp_Object* lambdalist = form->value.pair.rest; - - // creating new lisp object and setting type - Lisp_Object* func; - try func = Memory::create_lisp_object_function(Lisp_Function_Type::Macro); - in_caller_env { - // setting parent env - func->value.function->parent_environment = get_current_environment(); - create_arguments_from_lambda_list_and_inject(lambdalist, func); - func->value.function->body.lisp_body = maybe_wrap_body_in_begin(body); - define_symbol(symbol, func); - } - return Memory::nil; - }; - define((mutate target source), "TODO") { - profile_with_name("(mutate)"); - fetch(target, source); - - if (target == Memory::nil || - target == Memory::t || - Memory::get_type(target) == Lisp_Object_Type::Keyword || - Memory::get_type(target) == Lisp_Object_Type::Symbol) - { - create_generic_error("You cannot mutate to nil, t, keywords or symbols because they have to be unique"); - } - - if (source == Memory::nil || - source == Memory::t || - Memory::get_type(source) == Lisp_Object_Type::Keyword || - Memory::get_type(source) == Lisp_Object_Type::Symbol) - { - create_generic_error("You cannot mutate nil, t, keywords or symbols"); - } - - *target = *source; - return target; - }; - define((vector-length v), "TODO") { - profile_with_name("(vector-length)"); - fetch(v); - try assert_type(v, Lisp_Object_Type::Vector); - return Memory::create_lisp_object((double)v->value.vector.length); - }; - define((vector-ref vec idx), "TODO") { - profile_with_name("(vector-ref)"); - fetch(vec, idx); - - try assert_type(vec, Lisp_Object_Type::Vector); - try assert_type(idx, Lisp_Object_Type::Number); - - int int_idx = ((int)idx->value.number); - - try assert("vector access index must be >= 0", int_idx >= 0); - try assert("vector access index must be < length", int_idx < vec->value.vector.length); - - return vec->value.vector.data+int_idx; - }; - define((vector-set! vec idx val), "TODO") { - profile_with_name("(vector-set!)"); - fetch(vec, idx, val); - - try assert_type(vec, Lisp_Object_Type::Vector); - try assert_type(idx, Lisp_Object_Type::Number); - - int int_idx = ((int)idx->value.number); - - try assert("vector access index must be >= 0", int_idx >= 0); - try assert("vector access index must be < length", int_idx < vec->value.vector.length); - - vec->value.vector.data[int_idx] = *val; - - return val; - }; - define_special((set! sym val), "TODO") { - profile_with_name("(set!)"); - fetch(sym, val); - - try assert_type(sym, Lisp_Object_Type::Symbol); - Environment* target_env; - in_caller_env { - val = eval_expr(val); - target_env = find_binding_environment(sym, get_current_environment()); - if (!target_env) - target_env = get_root_environment(); - } - - - push_environment(target_env); - define_symbol(sym, val); - pop_environment(); - - return val; - }; - define((set-car! target source), "TODO") { - profile_with_name("(set-car!)"); - fetch(target, source); - - try assert_type(target, Lisp_Object_Type::Pair); - - *target->value.pair.first = *source; - return source; - }; - define((set-cdr! target source), "TODO") { - profile_with_name("(set-cdr!)"); - fetch(target, source); - - try assert_type(target, Lisp_Object_Type::Pair); - - *target->value.pair.rest = *source; - return source; - }; - define_special((quote datum), "TODO") { - profile_with_name("(quote)"); - fetch(datum); - return datum; - }; - define_special((quasiquote expr), "TODO") { - profile_with_name("(quasiquote)"); - fetch(expr); - Lisp_Object* quasiquote_sym = Memory::get_symbol("quasiquote"); - Lisp_Object* unquote_sym = Memory::get_symbol("unquote"); - Lisp_Object* unquote_splicing_sym = Memory::get_symbol("unquote-splicing"); - // NOTE(Felix): first we have to initialize the variable - // with a garbage lambda, so that we can then overwrite it - // a recursive lambda - const auto unquoteSomeExpressions = [&] (const auto & self, Lisp_Object* expr) -> Lisp_Object* { - // if it is an atom, return it - if (Memory::get_type(expr) != Lisp_Object_Type::Pair) - return Memory::copy_lisp_object(expr); - - // it is a pair! - Lisp_Object* originalPair = expr->value.pair.first; - - // if we find quasiquote, uhu - if (originalPair == quasiquote_sym) - return expr; - - if (originalPair == unquote_sym || originalPair == unquote_splicing_sym) - { - // eval replace the stuff - - Lisp_Object* ret; - in_caller_env { - try ret = eval_expr(expr->value.pair.rest->value.pair.first); - } - - return ret; - } - - // it is a list but not starting with the symbol - // unquote, so search in there for stuff to unquote. - // While copying the list - - //NOTE(Felix): Of fucking course we have to copy the - // list. The quasiquote will be part of the body of a - // funciton, we can't just modify it because otherwise - // we modify the body of the function and would bake - // in the result... - Lisp_Object* newPair = Memory::nil; - Lisp_Object* newPairHead = newPair; - Lisp_Object* head = expr; - - while (Memory::get_type(head) == Lisp_Object_Type::Pair) { - // if it is ,@ we have to actually do more work - // and inline the result - if (Memory::get_type(head->value.pair.first) == Lisp_Object_Type::Pair && - head->value.pair.first->value.pair.first == unquote_splicing_sym) - { - Lisp_Object* spliced = self(self, head->value.pair.first); - - if (spliced == Memory::nil) { - head = head->value.pair.rest; - continue; - } - - try assert_type(spliced, Lisp_Object_Type::Pair); - if (newPair == Memory::nil) { - try newPair = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); - newPairHead = newPair; - } else { - try newPairHead->value.pair.rest = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); - newPairHead = newPairHead->value.pair.rest; - newPairHead->value.pair.first = spliced->value.pair.first; - newPairHead->value.pair.rest = spliced->value.pair.rest; - - // now skip to the end - while (newPairHead->value.pair.rest != Memory::nil) { - newPairHead = newPairHead->value.pair.rest; - } - } - - } else { - if (newPair == Memory::nil) { - try newPair = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); - newPairHead = newPair; - } else { - try newPairHead->value.pair.rest = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); - newPairHead = newPairHead->value.pair.rest; - } - newPairHead->value.pair.first = self(self, head->value.pair.first); - } - - // if (Memory::get_type(head->value.pair.rest) != Lisp_Object_Type::Pair) { - // break; - // } - - head = head->value.pair.rest; - - } - newPairHead->value.pair.rest = Memory::nil; - - return newPair; - }; - - expr = unquoteSomeExpressions(unquoteSomeExpressions, expr); - return expr; - }; - define((not test), "TODO") { - profile_with_name("(not)"); - fetch(test); - return is_truthy(test) ? Memory::nil : Memory::t; - }; - // // // defun("while", "TODO", __LINE__, cLambda { - // // // try arguments_length = list_length(arguments); - // // // try assert(arguments_length >= 2); - - // // // Lisp_Object* condition_part = arguments->value.pair.first; - // // // Lisp_Object* condition; - // // // Lisp_Object* then_part = arguments->value.pair.rest; - // // // Lisp_Object* wrapped_then_part; - - // // // try wrapped_then_part = Memory::create_lisp_object_pair( - // // // Memory::get_symbol("begin"), - // // // then_part); - - // // // Lisp_Object* result = Memory::nil; - - // // // while (true) { - // // // try condition = eval_expr(condition_part); - - // // // if (condition == Memory::nil) - // // // break; - - // // // try result = eval_expr(wrapped_then_part); - // // // } - // // // return result; - - // // // }); - define_special((lambda args . body), "TODO") { - profile_with_name("(lambda)"); - fetch(args, body); - - // creating new lisp object and setting type - Lisp_Object* func; - try func = Memory::create_lisp_object_function(Lisp_Function_Type::Lambda); - - in_caller_env { - func->value.function->parent_environment = get_current_environment(); - } - - try create_arguments_from_lambda_list_and_inject(args, func); - func->value.function->body.lisp_body = maybe_wrap_body_in_begin(body); - return func; - }; - define((list . args), "TODO") { - profile_with_name("(list)"); - fetch(args); - return args; - }; - define((hash-map . args), "TODO") { - profile_with_name("(hash-map)"); - fetch(args); - Lisp_Object* ret; - try ret = Memory::create_lisp_object_hash_map(); - for_lisp_list (args) { - try assert_type(head->value.pair.rest, Lisp_Object_Type::Pair); - head = head->value.pair.rest; - ret->value.hashMap->set_object(it, head->value.pair.first); - } - - return ret; - }; - define((hash-map-get hm key), "TODO") { - profile_with_name("(hash-map-get)"); - fetch(hm, key); - try assert_type(hm, Lisp_Object_Type::HashMap); - - Lisp_Object* ret = (Lisp_Object*)hm->value.hashMap->get_object(key); - if (!ret) - create_symbol_undefined_error("The key was not set in the hashmap"); - - return ret; - }; - define((hash-map-set! hm key value), "TODO") { - profile_with_name("(hash-map-set!)"); - fetch(hm, key, value); - try assert_type(hm, Lisp_Object_Type::HashMap); - hm->value.hashMap->set_object(key, value); - return Memory::nil; - }; - define((hash-map-delete! hm key), "TODO") { - profile_with_name("(hash-map-delete!)"); - fetch(hm, key); - try assert_type(hm, Lisp_Object_Type::HashMap); - hm->value.hashMap->delete_object(key); - return Memory::nil; - }; - define((vector . args), "TODO") { - profile_with_name("(vector)"); - fetch(args); - Lisp_Object* ret; - int length = list_length(args); - try ret = Memory::create_lisp_object_vector(length, args); - return ret; - }; - define((pair car cdr), "TODO") { - profile_with_name("(pair)"); - fetch(car, cdr); - - Lisp_Object* ret; - try ret = Memory::create_lisp_object_pair(car, cdr); - return ret; - }; - define((first seq), "TODO") { - profile_with_name("(first)"); - fetch(seq); - if (seq == Memory::nil) - return Memory::nil; - try assert_type(seq, Lisp_Object_Type::Pair); - return seq->value.pair.first; - }; - define((rest seq), "TODO") { - profile_with_name("(rest)"); - fetch(seq); - if (seq == Memory::nil) - return Memory::nil; - try assert_type(seq, Lisp_Object_Type::Pair); - return seq->value.pair.rest; - }; - define((set-type! node new_type), "TODO") { - profile_with_name("(set-type!)"); - fetch(node, new_type); - try assert_type(new_type, Lisp_Object_Type::Keyword); - node->userType = new_type; - return node; - }; - define((delete-type! n), "TODO") { - profile_with_name("(delete-type!)"); - fetch(n); - n->userType = nullptr; - return Memory::t; - }; - define((type n), "TODO") { - profile_with_name("(type)"); - fetch(n); - - if (n->userType) { - return n->userType; - } - - Lisp_Object_Type type = Memory::get_type(n); - - switch (type) { - case Lisp_Object_Type::Continuation: return Memory::get_keyword("continuation"); - case Lisp_Object_Type::Function: { - Function* fun = n->value.function; - if (fun->is_c) { - switch (fun->type.c_function_type) { - case C_Function_Type::cMacro: return Memory::get_keyword("cMacro"); - case C_Function_Type::cFunction: return Memory::get_keyword("cFunction"); - case C_Function_Type::cSpecial: return Memory::get_keyword("cSpecial"); - default: return Memory::get_keyword("c??"); - } - } else { - switch (fun->type.lisp_function_type) { - case Lisp_Function_Type::Lambda: return Memory::get_keyword("lambda"); - case Lisp_Function_Type::Macro: return Memory::get_keyword("macro"); - default: return Memory::get_keyword("??"); - } - } - } - case Lisp_Object_Type::HashMap: return Memory::get_keyword("hashmap"); - case Lisp_Object_Type::Keyword: return Memory::get_keyword("keyword"); - case Lisp_Object_Type::Nil: return Memory::get_keyword("nil"); - case Lisp_Object_Type::Number: return Memory::get_keyword("number"); - case Lisp_Object_Type::Pair: return Memory::get_keyword("pair"); - case Lisp_Object_Type::Pointer: return Memory::get_keyword("pointer"); - case Lisp_Object_Type::String: return Memory::get_keyword("string"); - case Lisp_Object_Type::Symbol: return Memory::get_keyword("symbol"); - case Lisp_Object_Type::T: return Memory::get_keyword("t"); - case Lisp_Object_Type::Vector: return Memory::get_keyword("vector"); - } - return Memory::get_keyword("unknown"); - }; - // define((mem-reset), "TODO") { - // profile_with_name("(mem-reset)"); - // Memory::reset(); - // return Memory::nil; - // }; - define_special((info n), "TODO") - { - // NOTE(Felix): we need to define_special because the docstring is - // attached to the symbol. Because some object are singletons - // (symbols, keyowrds, nil, t) we dont want to store docs on the - // object. Otherwise (define k :doc "hallo" :keyword) would modify - // // the global keyword - profile_with_name("(info)"); - fetch(n); - print(n); - - Lisp_Object* type; - Lisp_Object* val; - in_caller_env { - try type = eval_expr(Memory::create_list(Memory::get_symbol("type"), n)); - try val = eval_expr(n); - } - - printf(" is of type "); - print(type); - printf(" (internal: %s)", lisp_object_type_to_string(Memory::get_type(val))); - printf("\nand is printed as: "); - print(val); - printf("\n\ndocs:\n=====\n %s\n\n", - // TODO(felix): Doc HM lookup - // (val->docstring) - // ? Memory::get_c_str(val->docstring) - // : - "No docs avaliable"); - - if (Memory::get_type(val) == Lisp_Object_Type::Function) - { - Arguments* args = &val->value.function->args; - - - printf("Arguments:\n==========\n"); - printf("Postitional: {"); - if (args->positional.symbols.next_index != 0) { - printf("%s", - Memory::get_c_str(args->positional.symbols.data[0]->value.symbol)); - for (int i = 1; i < args->positional.symbols.next_index; ++i) { - printf(", %s", - Memory::get_c_str(args->positional.symbols.data[i]->value.symbol)); - } - } - printf("}\n"); - printf("Keyword: {"); - if (args->keyword.values.next_index != 0) { - printf("%s", - Memory::get_c_str(args->keyword.keywords.data[0]->value.symbol)); - if (args->keyword.values.data[0]) { - printf(" ("); - print(args->keyword.values.data[0], true); - printf(")"); - } - for (int i = 1; i < args->keyword.values.next_index; ++i) { - printf(", %s", - Memory::get_c_str(args->keyword.keywords.data[i]->value.symbol)); - if (args->keyword.values.data[i]) { - printf(" ("); - print(args->keyword.values.data[i], true); - printf(")"); - } - } - } - printf("}\n"); - printf("Rest: {"); - if (args->rest) - printf("%s", - Memory::get_c_str(args->rest->value.symbol)); - printf("}\n"); - - } - return Memory::nil; - }; - define((show n), "TODO") { - profile_with_name("(show)"); - fetch(n); - try assert_type(n, Lisp_Object_Type::Function); - try assert("c-functoins cannot be shown", !n->value.function->is_c); - puts("body:\n"); - print(n->value.function->body.lisp_body); - puts("\n"); - printf("parent_env: %p\n", - n->value.function->parent_environment); - - return Memory::nil; - }; - define((addr-of var), "TODO") { - profile_with_name("(addr-of-var)"); - fetch(var); - return Memory::create_lisp_object( - (float)((u64)&(var))); - }; - define((generate-docs file_name), "TODO") { - profile_with_name("(generate-docs)"); - fetch(file_name); - try assert_type(file_name, Lisp_Object_Type::String); - in_caller_env { - try generate_docs(file_name->value.string); - } - return Memory::t; - }; - define((print (:sep " ") (:end "\n") (:repr ()) . things), "TODO") { - profile_with_name("(print)"); - fetch(sep, end, repr, things); - - if (things != Memory::nil) { - bool print_repr = repr != Memory::nil; - print(things->value.pair.first, repr); - - for_lisp_list(things->value.pair.rest) { - print(sep); - print(it, repr); - } - } - - print(end); - return Memory::nil; - }; - define((read (:prompt ">")), "TODO") { - profile_with_name("(read)"); - fetch(prompt); - print(prompt); - - // TODO(Felix): make read_line return a String* - char* line = read_line(); - defer { - free(line); - }; - String strLine = Memory::create_string(line); - return Memory::create_lisp_object(strLine); - }; - define((exit (:code 0)), "TODO") { - profile_with_name("(exit)"); - fetch(code); - try assert_type(code, Lisp_Object_Type::Number); - exit((int)code->value.number); - }; - define((break), "TODO") { - profile_with_name("(break)"); - in_caller_env { - print_environment(get_current_environment()); - } - return Memory::nil; - }; - define((memstat), "TODO") { - profile_with_name("(memstat)"); - Memory::print_status(); - return Memory::nil; - }; - define_special((mytry try_part catch_part), "TODO") { - profile_with_name("(mytry)"); - fetch(try_part, catch_part); - - Lisp_Object* result; - - in_caller_env { - ignore_logging { - dont_break_on_errors { - result = eval_expr(try_part); - if (Globals::error) { - delete_error(); - try result = eval_expr(catch_part); - } - } - } - } - return result; - }; - define((load file), "TODO") { - profile_with_name("(load)"); - fetch(file); - try assert_type(file, Lisp_Object_Type::String); - - Lisp_Object* result; - in_caller_env { - try result = built_in_load(file->value.string); - } - return result; - }; - define((import f), "TODO") { - profile_with_name("(import)"); - fetch(f); - try assert_type(f, Lisp_Object_Type::String); - - Lisp_Object *result; - in_caller_env { - try result = built_in_import(f->value.string); - } - - return Memory::t; - }; - define((copy obj), "TODO") { - profile_with_name("(copy)"); - fetch(obj); - // TODO(Felix): if we are copying string nodes, then - // shouldn't the string itself also get copied?? - return Memory::copy_lisp_object(obj); - }; - define((error type message), "TODO") { - profile_with_name("(error)"); - fetch(type, message); - // TODO(Felix): make the error function useful - try assert_type(type, Lisp_Object_Type::Keyword); - try assert_type(message, Lisp_Object_Type::String); - - using Globals::error; - error = new(Error); - error->type = type; - error->message = message->value.string; - - create_generic_error("Userlanderror"); - return nullptr; - }; - define((symbol->keyword sym), "TODO") { - profile_with_name("(symbol->keyword)"); - fetch(sym); - try assert_type(sym, Lisp_Object_Type::Symbol); - return Memory::get_keyword(sym->value.symbol); - }; - define((string->symbol str), "TODO") { - profile_with_name("(string->symbol)"); - fetch(str); - // TODO(Felix): do some sanity checks on the string. For - // example, numbers are not valid symbols. - - try assert_type(str, Lisp_Object_Type::String); - return Memory::get_symbol(Memory::duplicate_string(str->value.string)); - }; - define((symbol->string sym), "TODO") { - profile_with_name("(symbol->string)"); - fetch(sym); - - try assert_type(sym, Lisp_Object_Type::Symbol); - return Memory::create_lisp_object( - Memory::duplicate_string(sym->value.symbol)); - }; - define((concat-strings . strings), "TODO") { - profile_with_name("(concat-strings)"); - fetch(strings); - - int resulting_string_len = 0; - for_lisp_list (strings) { - try assert_type(it, Lisp_Object_Type::String); - resulting_string_len += it->value.string.length; - } - - String resulting_string = Memory::create_string("", resulting_string_len); - int index_in_string = 0; - - for_lisp_list (strings) { - strcpy(resulting_string.data+index_in_string, - Memory::get_c_str(it->value.string)); - index_in_string += it->value.string.length; - } - - return Memory::create_lisp_object(resulting_string); - }; - return nullptr; - } -} +namespace Slime { + proc lisp_object_equal(Lisp_Object* n1, Lisp_Object* n2) -> bool { + if (n1 == n2) + return true; + if (n1->type != n2->type) + return false; + + switch (n1->type) { + + case Lisp_Object_Type::T: + case Lisp_Object_Type::Nil: + case Lisp_Object_Type::Symbol: + case Lisp_Object_Type::Keyword: + case Lisp_Object_Type::Function: + // TODO(Felix): should a pointer + // object compare the pointer? + case Lisp_Object_Type::Pointer: + case Lisp_Object_Type::Continuation: return false; + case Lisp_Object_Type::Number: return n1->value.number == n2->value.number; + case Lisp_Object_Type::String: return string_equal(n1->value.string, n2->value.string); + case Lisp_Object_Type::Pair: { + return lisp_object_equal(n1->value.pair.first, n2->value.pair.first) && + lisp_object_equal(n1->value.pair.rest, n2->value.pair.rest); + } break; + case Lisp_Object_Type::HashMap: { + auto n1_keys = n1->value.hashMap->get_all_keys(); + auto n2_keys = n2->value.hashMap->get_all_keys(); + defer { + n1_keys.dealloc(); + n2_keys.dealloc(); + }; + + if (n1_keys.next_index != n2_keys.next_index) + return false; + + n1_keys.sort(); + n2_keys.sort(); + + for (int i = 0; i < n1_keys.next_index; ++i) { + if (!lisp_object_equal(n1_keys[i], n2_keys[i])) + return false; + if (!lisp_object_equal(n1->value.hashMap->get_object(n1_keys[i]), + n2->value.hashMap->get_object(n2_keys[i]))) + return false; + } + return true; + + } + case Lisp_Object_Type::Vector: { + if (n1->value.vector.length != n2->value.vector.length ) + return false; + for (int i = 0; i < n1->value.vector.length; ++i) { + if (!lisp_object_equal(n1->value.vector.data+i, n2->value.vector.data+i)) + return false; + } + return true; + } break; + default: create_not_yet_implemented_error(); + } + + // we should never reach here + return false; + } + + proc add_to_load_path(const char* path) -> void { + using Globals::load_path; + + load_path.append((void*)path); + } + + proc built_in_load(String file_name) -> Lisp_Object* { + profile_with_comment(file_name.data); + char* file_content; + char fullpath[4096]; + sprintf(fullpath, "%s", Memory::get_c_str(file_name)); + file_content = read_entire_file(Memory::get_c_str(file_name)); + + if (!file_content) { + for (auto it: Globals::load_path) { + fullpath[0] = '\0'; + sprintf(fullpath, "%s%s", (char*)it, Memory::get_c_str(file_name)); + file_content = read_entire_file(fullpath); + if (file_content) + break; + } + if (!file_content) { + printf("Load path:\n"); + for (auto it : Globals::load_path) { + printf(" - %s\n", (char*) it); + } + create_generic_error("The file to load '%s' was not found in the load path.", + Memory::get_c_str(file_name)); + return nullptr; + } + + } + + + Lisp_Object* result = Memory::nil; + Array_List* program; + String spath = Memory::create_string(fullpath); + defer { + free(spath.data); + }; + try program = Parser::parse_program(spath, file_content); + + // NOTE(Felix): deferred so even if the eval failes, it will + // run + defer { + program->dealloc(); + free(program); + free(file_content); + }; + for (auto expr : *program) { + try result = eval_expr(expr); + } + + return result; + } + + proc built_in_import(String file_name) -> Lisp_Object* { + profile_this(); + Environment* new_env; + + new_env = Memory::file_to_env_map.get_object(Memory::get_c_str(file_name)); + + if (!new_env) { + // create new empty environment + try new_env = Memory::create_child_environment(get_root_environment()); + // TODO(Felix): check absoulute paths in the map, not just + // relative ones + Memory::file_to_env_map.set_object(Memory::get_c_str(file_name), new_env); + push_environment(new_env); + defer { + pop_environment(); + }; + + Lisp_Object* res; + try res = built_in_load(file_name); + } + + get_current_environment()->parents.append(new_env); + + return Memory::nil; + } + + proc load_built_ins_into_environment() -> void* { + profile_this(); + String file_name_built_ins = Memory::create_string(__FILE__); + defer { + free(file_name_built_ins.data); + }; + define((remove_when_double_free_is_fixed (:k1 ()) (:k2 ()) . rest), "") { + return Memory::nil; + }; + define((remove_when_double_free_is_fixed_2 (:k1 ()) (:k2 ()) . rest), "") { + return Memory::nil; + }; + define_macro((apply fun fun_args), "TODO") { + // NOTE(Felix): is has to be a macro because apply by + // itself cannot return the result, we have to invoke eval + // and to prevent recursion, apply is a macro + + profile_with_name("(apply)"); + using namespace Globals::Current_Execution; + + --cs.next_index; + --ams.next_index; + Lisp_Object* args = pcs[--pcs.next_index]; + try_void assert_list_length(args, 2); + + Lisp_Object* fun = args->value.pair.first; + Lisp_Object* fun_args = args->value.pair.rest->value.pair.first; + + // 3. push args on the stack and apply + ats.append([] { + Lisp_Object* args_as_list = cs[--cs.next_index]; + for_lisp_list (args_as_list) { + cs.append(it); + } + pcs.append(Memory::nil); + (nass.end()-1)->append(NasAction::Step); + }); + (nass.end()-1)->append(NasAction::And_Then_Action); + + // 2. Eval fun_args and keep them on the stack + ats.append([] { + // NOTE(Felix): Flip the top 2 elements on cs because + // top is now the evaluated function, and below is the unevaluated args + Lisp_Object* tmp = cs[cs.next_index-1]; + cs[cs.next_index-1] = cs[cs.next_index-2]; + cs[cs.next_index-2] = tmp; + (nass.end()-1)->append(NasAction::Eval); + }); + (nass.end()-1)->append(NasAction::And_Then_Action); + + + // 1. Eval function and keep it on the stack, below it + // store the unevaluated argument list + ams.append(cs.next_index); + cs.append(fun_args); + cs.append(fun); + (nass.end()-1)->append(NasAction::Eval); + + }; + define((get-counter), + "When called returns a procedure that represents\n" + "a counter. Each time it is called it returns the\n" + "next whole number.") + { + define_symbol( + Memory::get_symbol("c"), + Memory::create_lisp_object((double)0)); + String file_name_built_ins = Memory::create_string(__FILE__); + define((lambda), "") { + fetch(c); + c->value.number++; + return c; + }; + fetch(lambda); + return lambda; + }; + define_macro((eval expr), + "Takes one argument, and evaluates it two times.") + { + profile_with_name("(eval)"); + using namespace Globals::Current_Execution; + cs.data[cs.next_index-1] = pcs[--pcs.next_index]->value.pair.first; + (nass.end()-1)->append(NasAction::Eval); + (nass.end()-1)->append(NasAction::Eval); + + }; + define_macro((begin . rest), + "Takes any number of forms. Evaluates them in order, " + "and returns the last result.") + { + profile_with_name("(begin)"); + using namespace Globals::Current_Execution; + --cs.next_index; + --ams.next_index; + Lisp_Object* args = pcs[--pcs.next_index]; + int length = list_length(args); + cs.reserve(length); + for_lisp_list(args) { + cs.data[cs.next_index - 1 + (length - it_index)] = it; + (nass.end()-1)->append(NasAction::Eval); + (nass.end()-1)->append(NasAction::Pop); + } + + --(nass.end()-1)->next_index; + cs.next_index += length; + }; + define_macro((if test then_part else_part), + "Takes 3 arguments. If the first arguments evaluates to a truthy " + "value, the if expression evaluates the second argument, else " + "it will evaluete the third one and return them respectively.") + { + profile_with_name("(if)"); + using namespace Globals::Current_Execution; + /* | | | | + | | -> | | + | | | | + | .... | | ...... | */ + --ams.next_index; + Lisp_Object* args = pcs.data[--pcs.next_index]; + Lisp_Object* test = args->value.pair.first; + args = args->value.pair.rest; + try_void assert_type(args, Lisp_Object_Type::Pair); + Lisp_Object* consequence = args->value.pair.first; + args = args->value.pair.rest; + try_void assert_type(args, Lisp_Object_Type::Pair); + Lisp_Object* alternative = args->value.pair.first; + args = args->value.pair.rest; + try_void assert_type(args, Lisp_Object_Type::Nil); + --cs.next_index; + cs.append(alternative); + cs.append(consequence); + cs.append(test); + + (nass.end()-1)->append(NasAction::Eval); + (nass.end()-1)->append(NasAction::If); + (nass.end()-1)->append(NasAction::Eval); + + }; + define_macro((define definee . args), "") { + // NOTE(Felix): define has to be a macro, because we need + // to evaluate the value for definee in case it is a + // simple variable (not a function). So ebcause we don't + // want to recursivly evaluate the value, we use a macro + // and a NasAction. + profile_with_name("(define)"); + using namespace Globals::Current_Execution; + --cs.next_index; + --ams.next_index; + Lisp_Object* form = pcs.data[--pcs.next_index]; + Lisp_Object* definee = form->value.pair.first; + form = form->value.pair.rest; + try_void assert_type(form, Lisp_Object_Type::Pair); + Lisp_Object* thing = form->value.pair.first; + Lisp_Object* thing_cons = form; + form = form->value.pair.rest; + Lisp_Object_Type type = definee->type; + switch (type) { + case Lisp_Object_Type::Symbol: { + if (form != Memory::nil) { + Lisp_Object* doc = thing; + try_void assert_type(doc, Lisp_Object_Type::String); + try_void assert_type(form, Lisp_Object_Type::Pair); + thing = form->value.pair.first; + try_void assert("list must end here.", form->value.pair.rest == Memory::nil); + // TODO docs (maybe with hooks) we have to attach + // the docs to the result of evaluating + } + cs.append(definee); + cs.append(thing); + (nass.end()-1)->append(NasAction::Define_Var); + (nass.end()-1)->append(NasAction::Eval); + } break; + case Lisp_Object_Type::Pair: { + try_void assert_type(definee->value.pair.first, Lisp_Object_Type::Symbol); + Lisp_Object* func; + try_void func = Memory::create_lisp_object_function(Lisp_Function_Type::Lambda); + func->value.function->parent_environment = get_current_environment(); + create_arguments_from_lambda_list_and_inject(definee->value.pair.rest, func); + if (thing_cons->value.pair.first->type == Lisp_Object_Type::String && + thing_cons->value.pair.rest != Memory::nil) + { + // extract docs + Globals::docs.set_object( + func, + Memory::duplicate_string( + thing_cons->value.pair.first->value.string).data); + thing_cons = thing_cons->value.pair.rest; + } + func->value.function->body.lisp_body = maybe_wrap_body_in_begin(thing_cons); + define_symbol(definee->value.pair.first, func); + cs.append(Memory::t); + } break; + default: { + create_generic_error("you can only define symbols"); + return; + } + } + }; + define((helper), "") { + profile_with_name("(helper)"); + return Memory::create_lisp_object(101.0); + }; + define((enable-debug-log), "") { + profile_with_name("(enable-debug-log)"); + Globals::debug_log = true; + return Memory::t; + }; + define((disable-debug-log), "") { + profile_with_name("(disable-debug-log)"); + Globals::debug_log = false; + return Memory::t; + }; + define_special((with-debug-log . rest), "") { + profile_with_name("(enable-debug-log)"); + fetch(rest); + Lisp_Object* result; + Globals::debug_log = true; + in_caller_env { + for_lisp_list(rest) { + // TODO(Felix): hooky would be really nice to + // have. Then this would be a macro and we would + // reset the debug log + try result = eval_expr(it); + } + } + Globals::debug_log = false; + return result; + }; + define((test (:k (helper))), "") { + profile_with_name("(test)"); + fetch(k); + return k; + }; + define((= . args), + "Takes 0 or more arguments and returns =t= if all arguments are equal " + "and =()= otherwise.") + { + profile_with_name("(=)"); + fetch(args); + + if (args == Memory::nil) + return Memory::t; + + Lisp_Object* first = args->value.pair.first; + + for_lisp_list (args) { + if (!lisp_object_equal(it, first)) + return Memory::nil; + } + + return Memory::t; + }; + define((> . args), "TODO") { + profile_with_name("(>)"); + fetch(args); + double last_number = strtod("Inf", NULL); + + for_lisp_list (args) { + try assert_type(it, Lisp_Object_Type::Number); + if (it->value.number >= last_number) + return Memory::nil; + last_number = it->value.number; + } + + return Memory::t; + }; + define((>= . args), "TODO") + { + profile_with_name("(>=)"); + fetch(args); + double last_number = strtod("Inf", NULL); + + for_lisp_list (args) { + try assert_type(it, Lisp_Object_Type::Number); + if (it->value.number > last_number) + return Memory::nil; + last_number = it->value.number; + } + + return Memory::t; + }; + define((< . args), "TODO") + { + profile_with_name("(<)"); + fetch(args); + double last_number = strtod("-Inf", NULL); + + for_lisp_list (args) { + try assert_type(it, Lisp_Object_Type::Number); + if (it->value.number <= last_number) + return Memory::nil; + last_number = it->value.number; + } + + return Memory::t; + }; + define((<= . args), "TODO") + { + profile_with_name("(<=)"); + fetch(args); + double last_number = strtod("-Inf", NULL); + + for_lisp_list (args) { + try assert_type(it, Lisp_Object_Type::Number); + if (it->value.number < last_number) + return Memory::nil; + last_number = it->value.number; + } + + return Memory::t; + }; + define((+ . args), "TODO") + { + profile_with_name("(+)"); + fetch(args); + + double sum = 0; + + for_lisp_list (args) { + try assert_type(it, Lisp_Object_Type::Number); + sum += it->value.number; + } + + return Memory::create_lisp_object(sum); + }; + define((- . args), "TODO") + { + profile_with_name("(-)"); + fetch(args); + if (args == Memory::nil) + return Memory::create_lisp_object(0.0); + + + try assert_type(args->value.pair.first, Lisp_Object_Type::Number); + double difference = args->value.pair.first->value.number; + + if (args->value.pair.rest == Memory::nil) { + return Memory::create_lisp_object(-difference); + } + + for_lisp_list (args->value.pair.rest) { + try assert_type(it, Lisp_Object_Type::Number); + difference -= it->value.number; + } + + return Memory::create_lisp_object(difference); + }; + define((* . args), "TODO") + { + profile_with_name("(*)"); + fetch(args); + if (args == Memory::nil) { + return Memory::create_lisp_object(1); + } + + double product = 1; + + for_lisp_list (args) { + try assert_type(it, Lisp_Object_Type::Number); + product *= it->value.number; + } + + return Memory::create_lisp_object(product); + }; + define((/ . args), "TODO") + { + profile_with_name("(/)"); + fetch(args); + + if (args == Memory::nil) { + return Memory::create_lisp_object(1); + } + + try assert_type(args->value.pair.first, Lisp_Object_Type::Number); + + double quotient = args->value.pair.first->value.number; + + for_lisp_list (args->value.pair.rest) { + try assert_type(it, Lisp_Object_Type::Number); + quotient /= it->value.number; + } + + return Memory::create_lisp_object(quotient); + }; + define((** a b), "TODO") { + profile_with_name("(**)"); + fetch(a, b); + try assert_type(a, Lisp_Object_Type::Number); + try assert_type(b, Lisp_Object_Type::Number); + return Memory::create_lisp_object(pow(a->value.number, + b->value.number)); + }; + define((% a b), "TODO") { + profile_with_name("(%)"); + fetch(a, b); + try assert_type(a, Lisp_Object_Type::Number); + try assert_type(b, Lisp_Object_Type::Number); + return Memory::create_lisp_object((int)a->value.number % + (int)b->value.number); + }; + define((get-random-between a b), "TODO") { + profile_with_name("(get-random-between)"); + fetch(a, b); + try assert_type(a, Lisp_Object_Type::Number); + try assert_type(b, Lisp_Object_Type::Number); + + double fa = a->value.number; + double fb = b->value.number; + double x = (double)rand()/(double)(RAND_MAX); + x *= (fb - fa); + x += fa; + + return Memory::create_lisp_object(x); + }; + define((gensym), "TODO") { + profile_with_name("(gensym)"); + Lisp_Object* node; + try node = Memory::create_lisp_object(); + node->type = Lisp_Object_Type::Symbol; + node->value.symbol = Memory::create_string("gensym"); + return node; + }; + define_special((bound? var), "TODO") { + profile_with_name("(bound?)"); + fetch(var); + try assert_type(var, Lisp_Object_Type::Symbol); + + Lisp_Object* res; + in_caller_env { + res = try_lookup_symbol(var, get_current_environment()); + } + if (res) + return Memory::t; + return Memory::nil; + }; + define_special((assert test), "TODO") { + profile_with_name("(assert)"); + fetch(test); + + in_caller_env { + Lisp_Object* res; + try res = eval_expr(test); + if (is_truthy(res)) + return Memory::t; + } + + char* string = lisp_object_to_string(test, true); + create_generic_error("Userland assertion. (%s)", string); + free(string); + return nullptr; + }; + define_special((define-syntax form . body), "TODO") { + profile_with_name("(define-syntax)"); + fetch(form, body); + // TODO(Felix): Macros cannot have docs now + + if (form->type != Lisp_Object_Type::Pair) { + create_parsing_error("You can only create function macros."); + return nullptr; + } + + Lisp_Object* symbol = form->value.pair.first; + Lisp_Object* lambdalist = form->value.pair.rest; + + // creating new lisp object and setting type + Lisp_Object* func; + try func = Memory::create_lisp_object_function(Lisp_Function_Type::Macro); + in_caller_env { + // setting parent env + func->value.function->parent_environment = get_current_environment(); + create_arguments_from_lambda_list_and_inject(lambdalist, func); + func->value.function->body.lisp_body = maybe_wrap_body_in_begin(body); + define_symbol(symbol, func); + } + return Memory::nil; + }; + define((mutate target source), "TODO") { + profile_with_name("(mutate)"); + fetch(target, source); + + if (target == Memory::nil || + target == Memory::t || + target->type == Lisp_Object_Type::Keyword || + target->type == Lisp_Object_Type::Symbol) + { + create_generic_error("You cannot mutate to nil, t, keywords or symbols because they have to be unique"); + } + + if (source == Memory::nil || + source == Memory::t || + source->type == Lisp_Object_Type::Keyword || + source->type == Lisp_Object_Type::Symbol) + { + create_generic_error("You cannot mutate nil, t, keywords or symbols"); + } + + *target = *source; + return target; + }; + define((vector-length v), "TODO") { + profile_with_name("(vector-length)"); + fetch(v); + try assert_type(v, Lisp_Object_Type::Vector); + return Memory::create_lisp_object((double)v->value.vector.length); + }; + define((vector-ref vec idx), "TODO") { + profile_with_name("(vector-ref)"); + fetch(vec, idx); + + try assert_type(vec, Lisp_Object_Type::Vector); + try assert_type(idx, Lisp_Object_Type::Number); + + int int_idx = ((int)idx->value.number); + + try assert("vector access index must be >= 0", int_idx >= 0); + try assert("vector access index must be < length", int_idx < vec->value.vector.length); + + return vec->value.vector.data+int_idx; + }; + define((vector-set! vec idx val), "TODO") { + profile_with_name("(vector-set!)"); + fetch(vec, idx, val); + + try assert_type(vec, Lisp_Object_Type::Vector); + try assert_type(idx, Lisp_Object_Type::Number); + + int int_idx = ((int)idx->value.number); + + try assert("vector access index must be >= 0", int_idx >= 0); + try assert("vector access index must be < length", int_idx < vec->value.vector.length); + + vec->value.vector.data[int_idx] = *val; + + return val; + }; + define_special((set! sym val), "TODO") { + profile_with_name("(set!)"); + fetch(sym, val); + + try assert_type(sym, Lisp_Object_Type::Symbol); + Environment* target_env; + in_caller_env { + val = eval_expr(val); + target_env = find_binding_environment(sym, get_current_environment()); + if (!target_env) + target_env = get_root_environment(); + } + + + push_environment(target_env); + define_symbol(sym, val); + pop_environment(); + + return val; + }; + define((set-car! target source), "TODO") { + profile_with_name("(set-car!)"); + fetch(target, source); + + try assert_type(target, Lisp_Object_Type::Pair); + + *target->value.pair.first = *source; + return source; + }; + define((set-cdr! target source), "TODO") { + profile_with_name("(set-cdr!)"); + fetch(target, source); + + try assert_type(target, Lisp_Object_Type::Pair); + + *target->value.pair.rest = *source; + return source; + }; + define_special((quote datum), "TODO") { + profile_with_name("(quote)"); + fetch(datum); + return datum; + }; + define_special((quasiquote expr), "TODO") { + profile_with_name("(quasiquote)"); + fetch(expr); + Lisp_Object* quasiquote_sym = Memory::get_symbol("quasiquote"); + Lisp_Object* unquote_sym = Memory::get_symbol("unquote"); + Lisp_Object* unquote_splicing_sym = Memory::get_symbol("unquote-splicing"); + // NOTE(Felix): first we have to initialize the variable + // with a garbage lambda, so that we can then overwrite it + // a recursive lambda + const auto unquoteSomeExpressions = [&] (const auto & self, Lisp_Object* expr) -> Lisp_Object* { + // if it is an atom, return it + if (expr->type != Lisp_Object_Type::Pair) + return Memory::copy_lisp_object(expr); + + // it is a pair! + Lisp_Object* originalPair = expr->value.pair.first; + + // if we find quasiquote, uhu + if (originalPair == quasiquote_sym) + return expr; + + if (originalPair == unquote_sym || originalPair == unquote_splicing_sym) + { + // eval replace the stuff + + Lisp_Object* ret; + in_caller_env { + try ret = eval_expr(expr->value.pair.rest->value.pair.first); + } + + return ret; + } + + // it is a list but not starting with the symbol + // unquote, so search in there for stuff to unquote. + // While copying the list + + //NOTE(Felix): Of fucking course we have to copy the + // list. The quasiquote will be part of the body of a + // funciton, we can't just modify it because otherwise + // we modify the body of the function and would bake + // in the result... + Lisp_Object* newPair = Memory::nil; + Lisp_Object* newPairHead = newPair; + Lisp_Object* head = expr; + + while (head->type == Lisp_Object_Type::Pair) { + // if it is ,@ we have to actually do more work + // and inline the result + if (head->value.pair.first->type == Lisp_Object_Type::Pair && + head->value.pair.first->value.pair.first == unquote_splicing_sym) + { + Lisp_Object* spliced = self(self, head->value.pair.first); + + if (spliced == Memory::nil) { + head = head->value.pair.rest; + continue; + } + + try assert_type(spliced, Lisp_Object_Type::Pair); + if (newPair == Memory::nil) { + try newPair = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); + newPairHead = newPair; + } else { + try newPairHead->value.pair.rest = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); + newPairHead = newPairHead->value.pair.rest; + newPairHead->value.pair.first = spliced->value.pair.first; + newPairHead->value.pair.rest = spliced->value.pair.rest; + + // now skip to the end + while (newPairHead->value.pair.rest != Memory::nil) { + newPairHead = newPairHead->value.pair.rest; + } + } + + } else { + if (newPair == Memory::nil) { + try newPair = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); + newPairHead = newPair; + } else { + try newPairHead->value.pair.rest = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); + newPairHead = newPairHead->value.pair.rest; + } + newPairHead->value.pair.first = self(self, head->value.pair.first); + } + + // if (Memory::get_type(head->value.pair.rest) != Lisp_Object_Type::Pair) { + // break; + // } + + head = head->value.pair.rest; + + } + newPairHead->value.pair.rest = Memory::nil; + + return newPair; + }; + + expr = unquoteSomeExpressions(unquoteSomeExpressions, expr); + return expr; + }; + define((not test), "TODO") { + profile_with_name("(not)"); + fetch(test); + return is_truthy(test) ? Memory::nil : Memory::t; + }; + // // // defun("while", "TODO", __LINE__, cLambda { + // // // try arguments_length = list_length(arguments); + // // // try assert(arguments_length >= 2); + + // // // Lisp_Object* condition_part = arguments->value.pair.first; + // // // Lisp_Object* condition; + // // // Lisp_Object* then_part = arguments->value.pair.rest; + // // // Lisp_Object* wrapped_then_part; + + // // // try wrapped_then_part = Memory::create_lisp_object_pair( + // // // Memory::get_symbol("begin"), + // // // then_part); + + // // // Lisp_Object* result = Memory::nil; + + // // // while (true) { + // // // try condition = eval_expr(condition_part); + + // // // if (condition == Memory::nil) + // // // break; + + // // // try result = eval_expr(wrapped_then_part); + // // // } + // // // return result; + + // // // }); + define_special((lambda args . body), "TODO") { + profile_with_name("(lambda)"); + fetch(args, body); + + // creating new lisp object and setting type + Lisp_Object* func; + try func = Memory::create_lisp_object_function(Lisp_Function_Type::Lambda); + + in_caller_env { + func->value.function->parent_environment = get_current_environment(); + } + + try create_arguments_from_lambda_list_and_inject(args, func); + func->value.function->body.lisp_body = maybe_wrap_body_in_begin(body); + return func; + }; + define((list . args), "TODO") { + profile_with_name("(list)"); + fetch(args); + return args; + }; + define((hash-map . args), "TODO") { + profile_with_name("(hash-map)"); + fetch(args); + Lisp_Object* ret; + try ret = Memory::create_lisp_object_hash_map(); + for_lisp_list (args) { + try assert_type(head->value.pair.rest, Lisp_Object_Type::Pair); + head = head->value.pair.rest; + ret->value.hashMap->set_object(it, head->value.pair.first); + } + + return ret; + }; + define((hash-map-get hm key), "TODO") { + profile_with_name("(hash-map-get)"); + fetch(hm, key); + try assert_type(hm, Lisp_Object_Type::HashMap); + + Lisp_Object* ret = (Lisp_Object*)hm->value.hashMap->get_object(key); + if (!ret) + create_symbol_undefined_error("The key was not set in the hashmap"); + + return ret; + }; + define((hash-map-set! hm key value), "TODO") { + profile_with_name("(hash-map-set!)"); + fetch(hm, key, value); + try assert_type(hm, Lisp_Object_Type::HashMap); + hm->value.hashMap->set_object(key, value); + return Memory::nil; + }; + define((hash-map-delete! hm key), "TODO") { + profile_with_name("(hash-map-delete!)"); + fetch(hm, key); + try assert_type(hm, Lisp_Object_Type::HashMap); + hm->value.hashMap->delete_object(key); + return Memory::nil; + }; + define((vector . args), "TODO") { + profile_with_name("(vector)"); + fetch(args); + Lisp_Object* ret; + int length = list_length(args); + try ret = Memory::create_lisp_object_vector(length, args); + return ret; + }; + define((pair car cdr), "TODO") { + profile_with_name("(pair)"); + fetch(car, cdr); + + Lisp_Object* ret; + try ret = Memory::create_lisp_object_pair(car, cdr); + return ret; + }; + define((first seq), "TODO") { + profile_with_name("(first)"); + fetch(seq); + if (seq == Memory::nil) + return Memory::nil; + try assert_type(seq, Lisp_Object_Type::Pair); + return seq->value.pair.first; + }; + define((rest seq), "TODO") { + profile_with_name("(rest)"); + fetch(seq); + if (seq == Memory::nil) + return Memory::nil; + try assert_type(seq, Lisp_Object_Type::Pair); + return seq->value.pair.rest; + }; + define((set-type! node new_type), "TODO") { + profile_with_name("(set-type!)"); + fetch(node, new_type); + try assert_type(new_type, Lisp_Object_Type::Keyword); + // TODO(Felix): Enable again when we have user types again: + // node->userType = new_type; + return node; + }; + define((delete-type! n), "TODO") { + profile_with_name("(delete-type!)"); + fetch(n); + // TODO(Felix): Enable again when we have user types again: + // n->userType = nullptr; + return Memory::t; + }; + define((type n), "TODO") { + profile_with_name("(type)"); + fetch(n); + + // TODO(Felix): Enable again when we have user types again: + // if (n->userType) { + // return n->userType; + // } + + Lisp_Object_Type type = n->type; + + switch (type) { + case Lisp_Object_Type::Continuation: return Memory::get_keyword("continuation"); + case Lisp_Object_Type::Function: { + Function* fun = n->value.function; + if (fun->is_c) { + switch (fun->type.c_function_type) { + case C_Function_Type::cMacro: return Memory::get_keyword("cMacro"); + case C_Function_Type::cFunction: return Memory::get_keyword("cFunction"); + case C_Function_Type::cSpecial: return Memory::get_keyword("cSpecial"); + default: return Memory::get_keyword("c??"); + } + } else { + switch (fun->type.lisp_function_type) { + case Lisp_Function_Type::Lambda: return Memory::get_keyword("lambda"); + case Lisp_Function_Type::Macro: return Memory::get_keyword("macro"); + default: return Memory::get_keyword("??"); + } + } + } + case Lisp_Object_Type::HashMap: return Memory::get_keyword("hashmap"); + case Lisp_Object_Type::Keyword: return Memory::get_keyword("keyword"); + case Lisp_Object_Type::Nil: return Memory::get_keyword("nil"); + case Lisp_Object_Type::Number: return Memory::get_keyword("number"); + case Lisp_Object_Type::Pair: return Memory::get_keyword("pair"); + case Lisp_Object_Type::Pointer: return Memory::get_keyword("pointer"); + case Lisp_Object_Type::String: return Memory::get_keyword("string"); + case Lisp_Object_Type::Symbol: return Memory::get_keyword("symbol"); + case Lisp_Object_Type::T: return Memory::get_keyword("t"); + case Lisp_Object_Type::Vector: return Memory::get_keyword("vector"); + case(Lisp_Object_Type::Invalid_Garbage_Collected): return Memory::get_keyword("Invalid: Garbage Collected"); + case(Lisp_Object_Type::Invalid_Under_Construction): return Memory::get_keyword("Invalid: Under Construction"); + } + return Memory::get_keyword("unknown"); + }; + // define((mem-reset), "TODO") { + // profile_with_name("(mem-reset)"); + // Memory::reset(); + // return Memory::nil; + // }; + define_special((info n), "TODO") + { + // NOTE(Felix): we need to define_special because the docstring is + // attached to the symbol. Because some object are singletons + // (symbols, keyowrds, nil, t) we dont want to store docs on the + // object. Otherwise (define k :doc "hallo" :keyword) would modify + // // the global keyword + profile_with_name("(info)"); + fetch(n); + print(n); + + Lisp_Object* type; + Lisp_Object* val; + in_caller_env { + try type = eval_expr(Memory::create_list(Memory::get_symbol("type"), n)); + try val = eval_expr(n); + } + + printf(" is of type "); + print(type); + printf(" (internal: %s)", lisp_object_type_to_string(val->type)); + printf("\nand is printed as: "); + print(val); + printf("\n\ndocs:\n=====\n %s\n\n", + (Globals::docs.get_object(val)) + ? Globals::docs.get_object(val) + : "No docs avaliable"); + + if (val->type == Lisp_Object_Type::Function) + { + Arguments* args = &val->value.function->args; + + + printf("Arguments:\n==========\n"); + printf("Postitional: {"); + if (args->positional.symbols.next_index != 0) { + printf("%s", + Memory::get_c_str(args->positional.symbols.data[0]->value.symbol)); + for (int i = 1; i < args->positional.symbols.next_index; ++i) { + printf(", %s", + Memory::get_c_str(args->positional.symbols.data[i]->value.symbol)); + } + } + printf("}\n"); + printf("Keyword: {"); + if (args->keyword.values.next_index != 0) { + printf("%s", + Memory::get_c_str(args->keyword.keywords.data[0]->value.symbol)); + if (args->keyword.values.data[0]) { + printf(" ("); + print(args->keyword.values.data[0], true); + printf(")"); + } + for (int i = 1; i < args->keyword.values.next_index; ++i) { + printf(", %s", + Memory::get_c_str(args->keyword.keywords.data[i]->value.symbol)); + if (args->keyword.values.data[i]) { + printf(" ("); + print(args->keyword.values.data[i], true); + printf(")"); + } + } + } + printf("}\n"); + printf("Rest: {"); + if (args->rest) + printf("%s", + Memory::get_c_str(args->rest->value.symbol)); + printf("}\n"); + + } + return Memory::nil; + }; + define((show n), "TODO") { + profile_with_name("(show)"); + fetch(n); + try assert_type(n, Lisp_Object_Type::Function); + try assert("c-functoins cannot be shown", !n->value.function->is_c); + puts("body:\n"); + print(n->value.function->body.lisp_body); + puts("\n"); + printf("parent_env: %p\n", + n->value.function->parent_environment); + + return Memory::nil; + }; + define((addr-of var), "TODO") { + profile_with_name("(addr-of-var)"); + fetch(var); + return Memory::create_lisp_object(&var); + }; + define((generate-docs file_name), "TODO") { + profile_with_name("(generate-docs)"); + fetch(file_name); + try assert_type(file_name, Lisp_Object_Type::String); + in_caller_env { + try generate_docs(file_name->value.string); + } + return Memory::t; + }; + define((print (:sep " ") (:end "\n") (:repr ()) . things), "TODO") { + profile_with_name("(print)"); + fetch(sep, end, repr, things); + + if (things != Memory::nil) { + bool print_repr = repr != Memory::nil; + print(things->value.pair.first, repr); + + for_lisp_list(things->value.pair.rest) { + print(sep); + print(it, repr); + } + } + + print(end); + return Memory::nil; + }; + define((read (:prompt ">")), "TODO") { + profile_with_name("(read)"); + fetch(prompt); + print(prompt); + + // TODO(Felix): make read_line return a String* + char* line = read_line(); + defer { + free(line); + }; + String strLine = Memory::create_string(line); + return Memory::create_lisp_object(strLine); + }; + define((exit (:code 0)), "TODO") { + profile_with_name("(exit)"); + fetch(code); + try assert_type(code, Lisp_Object_Type::Number); + exit((int)code->value.number); + }; + define((break), "TODO") { + profile_with_name("(break)"); + in_caller_env { + print_environment(get_current_environment()); + } + return Memory::nil; + }; + define((memstat), "TODO") { + profile_with_name("(memstat)"); + Memory::print_status(); + return Memory::nil; + }; + define_special((mytry try_part catch_part), "TODO") { + profile_with_name("(mytry)"); + fetch(try_part, catch_part); + + Lisp_Object* result; + + in_caller_env { + ignore_logging { + dont_break_on_errors { + result = eval_expr(try_part); + if (Globals::error) { + delete_error(); + try result = eval_expr(catch_part); + } + } + } + } + return result; + }; + define((load file), "TODO") { + profile_with_name("(load)"); + fetch(file); + try assert_type(file, Lisp_Object_Type::String); + + Lisp_Object* result; + in_caller_env { + try result = built_in_load(file->value.string); + } + return result; + }; + define((import f), "TODO") { + profile_with_name("(import)"); + fetch(f); + try assert_type(f, Lisp_Object_Type::String); + + Lisp_Object *result; + in_caller_env { + try result = built_in_import(f->value.string); + } + + return Memory::t; + }; + define((copy obj), "TODO") { + profile_with_name("(copy)"); + fetch(obj); + // TODO(Felix): if we are copying string nodes, then + // shouldn't the string itself also get copied?? + return Memory::copy_lisp_object(obj); + }; + define((error type message), "TODO") { + profile_with_name("(error)"); + fetch(type, message); + // TODO(Felix): make the error function useful + try assert_type(type, Lisp_Object_Type::Keyword); + try assert_type(message, Lisp_Object_Type::String); + + using Globals::error; + error = new(Error); + error->type = type; + error->message = message->value.string; + + create_generic_error("Userlanderror"); + return nullptr; + }; + define((symbol->keyword sym), "TODO") { + profile_with_name("(symbol->keyword)"); + fetch(sym); + try assert_type(sym, Lisp_Object_Type::Symbol); + return Memory::get_keyword(sym->value.symbol); + }; + define((string->symbol str), "TODO") { + profile_with_name("(string->symbol)"); + fetch(str); + // TODO(Felix): do some sanity checks on the string. For + // example, numbers are not valid symbols. + + try assert_type(str, Lisp_Object_Type::String); + return Memory::get_symbol(Memory::duplicate_string(str->value.string)); + }; + define((symbol->string sym), "TODO") { + profile_with_name("(symbol->string)"); + fetch(sym); + + try assert_type(sym, Lisp_Object_Type::Symbol); + return Memory::create_lisp_object( + Memory::duplicate_string(sym->value.symbol)); + }; + define((concat-strings . strings), "TODO") { + profile_with_name("(concat-strings)"); + fetch(strings); + + int resulting_string_len = 0; + for_lisp_list (strings) { + try assert_type(it, Lisp_Object_Type::String); + resulting_string_len += it->value.string.length; + } + + String resulting_string = Memory::create_string("", resulting_string_len); + int index_in_string = 0; + + for_lisp_list (strings) { + strcpy(resulting_string.data+index_in_string, + Memory::get_c_str(it->value.string)); + index_in_string += it->value.string.length; + } + + return Memory::create_lisp_object(resulting_string); + }; + return nullptr; + } +} diff --git a/src/define_macros.hpp b/src/define_macros.hpp index 046fb9f..91295c2 100644 --- a/src/define_macros.hpp +++ b/src/define_macros.hpp @@ -1,159 +1,159 @@ -#define concat_( a, b) a##b -#define label(prefix, lnum) concat_(prefix,lnum) - -#define log_location() \ - do { \ - if (Globals::log_level == Log_Level::Debug) { \ - printf("in"); \ - int spacing = 30-((int)strlen(__FILE__) + (int)log10(__LINE__));\ - if (spacing < 1) spacing = 1; \ - for (int i = 0; i < spacing;++i) \ - printf(" "); \ - printf("%s (%d) ", __FILE__, __LINE__); \ - printf("-> %s\n",__FUNCTION__); \ - } \ - } while(0) - -#define if_error_log_location_and_return(val) \ - do { \ - if (Globals::error) { \ - log_location(); \ - return val; \ - } \ - } while(0) - -#ifdef _DEBUG -#define try_or_else_return(val) \ - if (1) \ - goto label(body,__LINE__); \ - else \ - while (1) \ - if (1) { \ - if (Globals::error) { \ - log_location(); \ - return val; \ - } \ - break; \ - } \ - else label(body,__LINE__): - ; -#else -#define try_or_else_return(val) -#endif - -#define try_struct try_or_else_return({}) -#define try_void try_or_else_return(;) -#define try try_or_else_return(0) - -#define dont_break_on_errors fluid_let(Globals::breaking_on_errors, false) -#define ignore_logging fluid_let(Globals::log_level, Log_Level::None) - -#define fetch1(var) \ - Lisp_Object* var##_symbol = Memory::get_symbol(#var); \ - Lisp_Object* var = lookup_symbol(var##_symbol, get_current_environment()); \ - if_error_log_location_and_return(nullptr) - -#define fetch2(var1, var2) fetch1(var1); fetch1(var2) -#define fetch3(var1, var2, var3) fetch2(var1, var2); fetch1(var3) -#define fetch4(var1, var2, var3, var4) fetch3(var1, var2, var3); fetch1(var4) -#define fetch5(var1, var2, var3, var4, var5) fetch4(var1, var2, var3, var4); fetch1(var5) -#define fetch6(var1, var2, var3, var4, var5, var6) fetch5(var1, var2, var3, var4, var5); fetch1(var6) -#define fetch7(var1, var2, var3, var4, var5, var6, var7) fetch6(var1, var2, var3, var4, var5, var6); fetch1(var7) -#define fetch8(var1, var2, var3, var4, var5, var6, var7, var8) fetch7(var1, var2, var3, var4, var5, var6, var7); fetch1(var8) -#define fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9) fetch8(var1, var2, var3, var4, var5, var6, var7, var8); fetch1(var9) -#define fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10) fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9); fetch1(var10) -#define fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11) fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10); fetch1(var11) -#define fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12) fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11); fetch1(var12) -#define fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13) fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12); fetch1(var13) -#define fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14) fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13); fetch1(var14) -#define fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15) fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14); fetch1(var15) -#define fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16) fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15); fetch1(var16) -#define fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17) fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16); fetch1(var17) -#define fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18) fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17); fetch1(var18) -#define fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19) fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18); fetch1(var19) -#define fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20) fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19); fetch1(var20) -#define fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21) fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20); fetch1(var21) -#define fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22) fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21); fetch1(var22) -#define fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23) fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22); fetch1(var23) -#define fetch24(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23, var24) fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23); fetch1(var24) - -#define GET_MACRO( \ - _1, _2, _3, _4, _5, _6, \ - _7, _8, _9, _10, _11, _12, \ - _13, _14, _15, _16, _17, _18, \ - _19, _20, _21, _22, _23, _24, \ - NAME, ...) NAME -#ifdef _MSC_VER -#define EXPAND( x ) x -#define fetch(...) EXPAND( \ - GET_MACRO( \ - __VA_ARGS__, \ - fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \ - fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \ - fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \ - fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \ - )(__VA_ARGS__)) -#else -#define fetch(...) \ - GET_MACRO( \ - __VA_ARGS__, \ - fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \ - fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \ - fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \ - fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \ - )(__VA_ARGS__) -#endif - -// NOTE(Felix): we have to copy the string because we need it to be -// mutable for the parser to work, (#def gives us a const char) -// because the parser relys on being able to temporaily put in markers -// in the code and also it will fill out the source code location -#define _define_helper(def, docs, type, ending) \ - Parser::parser_file = file_name_built_ins; \ - Parser::parser_line = __LINE__; \ - Parser::parser_col = 0; \ - auto label(params,__LINE__) = Parser::parse_single_expression(#def); \ - if_error_log_location_and_return(nullptr); \ - assert_type(label(params,__LINE__), Lisp_Object_Type::Pair); \ - assert_type(label(params,__LINE__)->value.pair.first, Lisp_Object_Type::Symbol); \ - auto label(sym,__LINE__) = label(params,__LINE__)->value.pair.first; \ - auto label(sfun,__LINE__) = Memory::create_lisp_object_cfunction(type); \ - create_arguments_from_lambda_list_and_inject(label(params,__LINE__)->value.pair.rest, label(sfun,__LINE__)); \ - if_error_log_location_and_return(nullptr); \ - /* TODO(Felix): label(sfun,__LINE__)->docstring = Memory::create_string(docs); */ \ - label(sfun,__LINE__)->value.function->parent_environment = get_current_environment(); \ - define_symbol(label(sym,__LINE__), label(sfun,__LINE__)); \ - label(sfun,__LINE__)->value.function->body. ending - -#define define(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cFunction, c_body = []() -> Lisp_Object*) -#define define_special(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cSpecial, c_body = []() -> Lisp_Object*) -#define define_macro(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cMacro, c_macro_body = []() -> void) - -#define in_caller_env fluid_let( \ - Globals::Current_Execution::envi_stack.next_index, \ - Globals::Current_Execution::envi_stack.next_index-1) - - -/* - * iterate over lisp vectors - */ -#define for_lisp_vector(v) \ - if (!v); else \ - if (int it_index = 0); else \ - for (auto it = v->value.vector.data; \ - it_index < v->value.vector.length; \ - it=v->value.vector.data+(++it_index)) - -/* - * iterate over lisp lists - */ -#define for_lisp_list(l) \ - if (!l); else \ - if (int it_index = 0); else \ - for (Lisp_Object* head = l, *it; \ - Memory::get_type(head) == Lisp_Object_Type::Pair && (it = head->value.pair.first); \ - head = head->value.pair.rest, ++it_index) - - -#define dbg(thing, format) \ - printf("%s = " format "\n", #thing, thing) +#define concat_( a, b) a##b +#define label(prefix, lnum) concat_(prefix,lnum) + +#define log_location() \ + do { \ + if (Globals::log_level == Log_Level::Debug) { \ + printf("in"); \ + int spacing = 30-((int)strlen(__FILE__) + (int)log10(__LINE__));\ + if (spacing < 1) spacing = 1; \ + for (int i = 0; i < spacing;++i) \ + printf(" "); \ + printf("%s (%d) ", __FILE__, __LINE__); \ + printf("-> %s\n",__FUNCTION__); \ + } \ + } while(0) + +#define if_error_log_location_and_return(val) \ + do { \ + if (Globals::error) { \ + log_location(); \ + return val; \ + } \ + } while(0) + +#ifdef _DEBUG +#define try_or_else_return(val) \ + if (1) \ + goto label(body,__LINE__); \ + else \ + while (1) \ + if (1) { \ + if (Globals::error) { \ + log_location(); \ + return val; \ + } \ + break; \ + } \ + else label(body,__LINE__): + ; +#else +#define try_or_else_return(val) +#endif + +#define try_struct try_or_else_return({}) +#define try_void try_or_else_return(;) +#define try try_or_else_return(0) + +#define dont_break_on_errors fluid_let(Globals::breaking_on_errors, false) +#define ignore_logging fluid_let(Globals::log_level, Log_Level::None) + +#define fetch1(var) \ + Lisp_Object* var##_symbol = Memory::get_symbol(#var); \ + Lisp_Object* var = lookup_symbol(var##_symbol, get_current_environment()); \ + if_error_log_location_and_return(nullptr) + +#define fetch2(var1, var2) fetch1(var1); fetch1(var2) +#define fetch3(var1, var2, var3) fetch2(var1, var2); fetch1(var3) +#define fetch4(var1, var2, var3, var4) fetch3(var1, var2, var3); fetch1(var4) +#define fetch5(var1, var2, var3, var4, var5) fetch4(var1, var2, var3, var4); fetch1(var5) +#define fetch6(var1, var2, var3, var4, var5, var6) fetch5(var1, var2, var3, var4, var5); fetch1(var6) +#define fetch7(var1, var2, var3, var4, var5, var6, var7) fetch6(var1, var2, var3, var4, var5, var6); fetch1(var7) +#define fetch8(var1, var2, var3, var4, var5, var6, var7, var8) fetch7(var1, var2, var3, var4, var5, var6, var7); fetch1(var8) +#define fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9) fetch8(var1, var2, var3, var4, var5, var6, var7, var8); fetch1(var9) +#define fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10) fetch9(var1, var2, var3, var4, var5, var6, var7, var8, var9); fetch1(var10) +#define fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11) fetch10(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10); fetch1(var11) +#define fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12) fetch11(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11); fetch1(var12) +#define fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13) fetch12(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12); fetch1(var13) +#define fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14) fetch13(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13); fetch1(var14) +#define fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15) fetch14(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14); fetch1(var15) +#define fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16) fetch15(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15); fetch1(var16) +#define fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17) fetch16(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16); fetch1(var17) +#define fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18) fetch17(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17); fetch1(var18) +#define fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19) fetch18(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18); fetch1(var19) +#define fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20) fetch19(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19); fetch1(var20) +#define fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21) fetch20(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20); fetch1(var21) +#define fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22) fetch21(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21); fetch1(var22) +#define fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23) fetch22(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22); fetch1(var23) +#define fetch24(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23, var24) fetch23(var1, var2, var3, var4, var5, var6, var7, var8, var9, var10, var11, var12, var13, var14, var15, var16, var17, var18, var19, var20, var21, var22, var23); fetch1(var24) + +#define GET_MACRO( \ + _1, _2, _3, _4, _5, _6, \ + _7, _8, _9, _10, _11, _12, \ + _13, _14, _15, _16, _17, _18, \ + _19, _20, _21, _22, _23, _24, \ + NAME, ...) NAME +#ifdef _MSC_VER +#define EXPAND( x ) x +#define fetch(...) EXPAND( \ + GET_MACRO( \ + __VA_ARGS__, \ + fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \ + fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \ + fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \ + fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \ + )(__VA_ARGS__)) +#else +#define fetch(...) \ + GET_MACRO( \ + __VA_ARGS__, \ + fetch24, fetch23, fetch22, fetch21, fetch20, fetch19, \ + fetch18, fetch17, fetch16, fetch15, fetch14, fetch13, \ + fetch12, fetch11, fetch10, fetch9, fetch8, fetch7, \ + fetch6, fetch5, fetch4, fetch3, fetch2, fetch1 \ + )(__VA_ARGS__) +#endif + +// NOTE(Felix): we have to copy the string because we need it to be +// mutable for the parser to work, (#def gives us a const char) +// because the parser relys on being able to temporaily put in markers +// in the code and also it will fill out the source code location +#define _define_helper(def, docstring, type, ending) \ + Parser::parser_file = file_name_built_ins; \ + Parser::parser_line = __LINE__; \ + Parser::parser_col = 0; \ + auto label(params,__LINE__) = Parser::parse_single_expression(#def); \ + if_error_log_location_and_return(nullptr); \ + assert_type(label(params,__LINE__), Lisp_Object_Type::Pair); \ + assert_type(label(params,__LINE__)->value.pair.first, Lisp_Object_Type::Symbol); \ + auto label(sym,__LINE__) = label(params,__LINE__)->value.pair.first; \ + auto label(sfun,__LINE__) = Memory::create_lisp_object_cfunction(type); \ + Globals::docs.set_object(label(sfun,__LINE__), Memory::create_string(docstring).data); \ + create_arguments_from_lambda_list_and_inject(label(params,__LINE__)->value.pair.rest, label(sfun,__LINE__)); \ + if_error_log_location_and_return(nullptr); \ + label(sfun,__LINE__)->value.function->parent_environment = get_current_environment(); \ + define_symbol(label(sym,__LINE__), label(sfun,__LINE__)); \ + label(sfun,__LINE__)->value.function->body. ending + +#define define(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cFunction, c_body = []() -> Lisp_Object*) +#define define_special(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cSpecial, c_body = []() -> Lisp_Object*) +#define define_macro(def, docs) _define_helper(def, docs, Slime::C_Function_Type::cMacro, c_macro_body = []() -> void) + +#define in_caller_env fluid_let( \ + Globals::Current_Execution::envi_stack.next_index, \ + Globals::Current_Execution::envi_stack.next_index-1) + + +/* + * iterate over lisp vectors + */ +#define for_lisp_vector(v) \ + if (!v); else \ + if (int it_index = 0); else \ + for (auto it = v->value.vector.data; \ + it_index < v->value.vector.length; \ + it=v->value.vector.data+(++it_index)) + +/* + * iterate over lisp lists + */ +#define for_lisp_list(l) \ + if (!l); else \ + if (int it_index = 0); else \ + for (Lisp_Object* head = l, *it; \ + head->type == Lisp_Object_Type::Pair && (it = head->value.pair.first); \ + head = head->value.pair.rest, ++it_index) + + +#define dbg(thing, format) \ + printf("%s = " format "\n", #thing, thing) diff --git a/src/docgeneration.cpp b/src/docgeneration.cpp index e038006..5100737 100644 --- a/src/docgeneration.cpp +++ b/src/docgeneration.cpp @@ -1,143 +1,145 @@ -namespace Slime { - proc generate_docs(String path) -> void { - FILE *f = fopen(Memory::get_c_str(path), "w"); - if (!f) { - create_generic_error("The file for writing the documentation (%s) " - "could not be opened for writing.", Memory::get_c_str(path)); - return; - } - defer { - fclose(f); - }; - - Array_List visited; - - const auto print_this_env = [&](const auto& rec, Environment* env, char* prefix) -> void { - bool we_already_printed = false; - // TODO(Felix): Make a generic array_list_contains function - for(auto it : visited) { - if (it == env) { - we_already_printed = true; - break; - } - } - if (!we_already_printed) { - // printf("Working on env::::"); - // print_environment(env); - // printf("\n--------------------------------\n"); - visited.append(env); - - push_environment(env); - defer { - pop_environment(); - }; - - for_hash_map(env->hm) { - try_void fprintf(f, - "#+latex: \\hrule\n" - "#+html:
\n" - "* =%s%s= \n" - " :PROPERTIES:\n" - " :UNNUMBERED: t\n" - " :END:" - ,prefix, Memory::get_c_str(((Lisp_Object*)key)->value.symbol)); - /* - * sourcecodeLocation - */ - if (value->sourceCodeLocation) { - try_void fprintf(f, "\n - defined in :: =%s:%d:%d=", - Memory::get_c_str(value->sourceCodeLocation->file), - value->sourceCodeLocation->line, - value->sourceCodeLocation->column); - } - /* - * type - */ - Lisp_Object_Type type = Memory::get_type(value); - Lisp_Object* LOtype; - Lisp_Object* type_expr = Memory::create_list(Memory::get_symbol("type"), value); - try_void LOtype = eval_expr(type_expr); - - fprintf(f, "\n - type :: ="); - print(LOtype, true, f); - fprintf(f, "="); - - - /* - * if printable value -> print it - */ - switch (type) { - case(Lisp_Object_Type::Nil): - case(Lisp_Object_Type::T): - case(Lisp_Object_Type::Number): - case(Lisp_Object_Type::String): - case(Lisp_Object_Type::Pair): - case(Lisp_Object_Type::Symbol): - case(Lisp_Object_Type::Keyword): { - fprintf(f, "\n - value :: ="); - print(value, true, f); - fprintf(f, "="); - } break; - default: break; - } - /* - * if function then print arguments - */ - if (type == Lisp_Object_Type::Function) - { - Arguments* args = &value->value.function->args; - fprintf(f, "\n - arguments :: "); - // if no args at all - if (args->positional.symbols.next_index == 0 && - args->keyword.values.next_index == 0 && - !args->rest) - { - fprintf(f, "none."); - } else { - if (args->positional.symbols.next_index != 0) { - fprintf(f, "\n - postitional :: "); - fprintf(f, "=%s=", Memory::get_c_str(args->positional.symbols.data[0]->value.symbol)); - for (int i = 1; i < args->positional.symbols.next_index; ++i) { - fprintf(f, ", =%s=", Memory::get_c_str(args->positional.symbols.data[i]->value.symbol)); - } - } - if (args->keyword.values.next_index != 0) { - fprintf(f, "\n - keyword :: "); - fprintf(f, "=%s=", Memory::get_c_str(args->keyword.keywords.data[0]->value.symbol)); - if (args->keyword.values.data[0]) { - fprintf(f, " =("); - print(args->keyword.values.data[0], true, f); - fprintf(f, ")="); - } - for (int i = 1; i < args->keyword.values.next_index; ++i) { - fprintf(f, ", =%s=", Memory::get_c_str(args->keyword.keywords.data[i]->value.symbol)); - if (args->keyword.values.data[i]) { - fprintf(f, " =("); - print(args->keyword.values.data[i], true, f); - fprintf(f, ")="); - } - } - } - if (args->rest) { - fprintf(f, "\n - rest :: =%s=", Memory::get_c_str(args->rest->value.symbol)); - } - } - } - fprintf(f, "\n - docu :: "); - // TODO(Felix): make docsting a hashmap lookup - // if (value->docstring) - // fprintf(f, "\n #+BEGIN:\n%s\n #+END:\n", - // Memory::get_c_str(value->docstring)); - // else - fprintf(f, "none\n"); - } - } - - for (int i = 0; i < env->parents.next_index; ++i) { - try_void rec(rec, env->parents.data[i], prefix); - } - }; - - print_this_env(print_this_env, get_current_environment(), (char*)""); - } -} +namespace Slime { + proc generate_docs(String path) -> void { + FILE *f = fopen(Memory::get_c_str(path), "w"); + if (!f) { + create_generic_error("The file for writing the documentation (%s) " + "could not be opened for writing.", Memory::get_c_str(path)); + return; + } + defer { + fclose(f); + }; + + Array_List visited; + + const auto print_this_env = [&](const auto& rec, Environment* env, char* prefix) -> void { + bool we_already_printed = false; + // TODO(Felix): Make a generic array_list_contains function + for(auto it : visited) { + if (it == env) { + we_already_printed = true; + break; + } + } + if (!we_already_printed) { + // printf("Working on env::::"); + // print_environment(env); + // printf("\n--------------------------------\n"); + visited.append(env); + + push_environment(env); + defer { + pop_environment(); + }; + + for_hash_map(env->hm) { + try_void fprintf(f, + "#+latex: \\hrule\n" + "#+html:
\n" + "* =%s%s= \n" + " :PROPERTIES:\n" + " :UNNUMBERED: t\n" + " :END:" + ,prefix, Memory::get_c_str(((Lisp_Object*)key)->value.symbol)); + /* + * sourcecodeLocation + */ + // TODO(Felix): Enable again when we have SCL again: + + // if (value->sourceCodeLocation) { + // try_void fprintf(f, "\n - defined in :: =%s:%d:%d=", + // Memory::get_c_str(value->sourceCodeLocation->file), + // value->sourceCodeLocation->line, + // value->sourceCodeLocation->column); + // } + /* + * type + */ + Lisp_Object_Type type = value->type; + Lisp_Object* LOtype; + Lisp_Object* type_expr = Memory::create_list(Memory::get_symbol("type"), value); + try_void LOtype = eval_expr(type_expr); + + fprintf(f, "\n - type :: ="); + print(LOtype, true, f); + fprintf(f, "="); + + + /* + * if printable value -> print it + */ + switch (type) { + case(Lisp_Object_Type::Nil): + case(Lisp_Object_Type::T): + case(Lisp_Object_Type::Number): + case(Lisp_Object_Type::String): + case(Lisp_Object_Type::Pair): + case(Lisp_Object_Type::Symbol): + case(Lisp_Object_Type::Keyword): { + fprintf(f, "\n - value :: ="); + print(value, true, f); + fprintf(f, "="); + } break; + default: break; + } + /* + * if function then print arguments + */ + if (type == Lisp_Object_Type::Function) + { + Arguments* args = &value->value.function->args; + fprintf(f, "\n - arguments :: "); + // if no args at all + if (args->positional.symbols.next_index == 0 && + args->keyword.values.next_index == 0 && + !args->rest) + { + fprintf(f, "none."); + } else { + if (args->positional.symbols.next_index != 0) { + fprintf(f, "\n - postitional :: "); + fprintf(f, "=%s=", Memory::get_c_str(args->positional.symbols.data[0]->value.symbol)); + for (int i = 1; i < args->positional.symbols.next_index; ++i) { + fprintf(f, ", =%s=", Memory::get_c_str(args->positional.symbols.data[i]->value.symbol)); + } + } + if (args->keyword.values.next_index != 0) { + fprintf(f, "\n - keyword :: "); + fprintf(f, "=%s=", Memory::get_c_str(args->keyword.keywords.data[0]->value.symbol)); + if (args->keyword.values.data[0]) { + fprintf(f, " =("); + print(args->keyword.values.data[0], true, f); + fprintf(f, ")="); + } + for (int i = 1; i < args->keyword.values.next_index; ++i) { + fprintf(f, ", =%s=", Memory::get_c_str(args->keyword.keywords.data[i]->value.symbol)); + if (args->keyword.values.data[i]) { + fprintf(f, " =("); + print(args->keyword.values.data[i], true, f); + fprintf(f, ")="); + } + } + } + if (args->rest) { + fprintf(f, "\n - rest :: =%s=", Memory::get_c_str(args->rest->value.symbol)); + } + } + } + fprintf(f, "\n - docu :: "); + // TODO(Felix): make docsting a hashmap lookup + // if (value->docstring) + // fprintf(f, "\n #+BEGIN:\n%s\n #+END:\n", + // Memory::get_c_str(value->docstring)); + // else + fprintf(f, "none\n"); + } + } + + for (int i = 0; i < env->parents.next_index; ++i) { + try_void rec(rec, env->parents.data[i], prefix); + } + }; + + print_this_env(print_this_env, get_current_environment(), (char*)""); + } +} diff --git a/src/eval.cpp b/src/eval.cpp index 9bde9c0..b7c7972 100644 --- a/src/eval.cpp +++ b/src/eval.cpp @@ -1,557 +1,533 @@ -namespace Slime { - - proc create_extended_environment_for_function_application_nrc( - Lisp_Object* function, - int arg_start, - int arg_end) -> Environment* - { - profile_this(); - using namespace Globals::Current_Execution; - - int index_of_next_arg = arg_start; - bool is_c_function = function->value.function->is_c; - Environment* env = Memory::create_child_environment(function->value.function->parent_environment); - Arguments* arg_spec = &function->value.function->args; - - Array_List read_in_keywords; - read_in_keywords.alloc(); - defer { - read_in_keywords.dealloc(); - }; - int obligatory_keywords_count = 0; - int read_obligatory_keywords_count = 0; - - Lisp_Object* sym; - Lisp_Object* val; - - // read positionals - for (int i = 0; i < arg_spec->positional.symbols.next_index; ++i) { - if (index_of_next_arg == arg_end) { - create_parsing_error( - "Not enough positional args supplied. Needed: %d suppied, %d.\n" - "Next missing arg is '%s'", - arg_spec->positional.symbols.next_index, arg_end-index_of_next_arg, - arg_spec->positional.symbols.data[i]->value.symbol.data); - return nullptr; - } - // NOTE(Felix): We have to copy all the arguments, - // otherwise we change the program code. To C functions we - // pass by reference for better performance and trust them - // to not mutate the arguments because we expect c - // programmers to know what they are doing. Bold claim I - // know. - if (is_c_function) { - define_symbol(arg_spec->positional.symbols.data[i], cs.data[index_of_next_arg], env); - } else { - define_symbol(arg_spec->positional.symbols.data[i], Memory::copy_lisp_object_except_pairs(cs.data[index_of_next_arg]), env); - } - ++index_of_next_arg; - } - - // if there are some left read keywords and rest - if (index_of_next_arg != arg_end) { - // find out how many keyword args we /have/ to read - for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) { - if (arg_spec->keyword.values.data[i] == nullptr) - ++obligatory_keywords_count; - } - - while (Memory::get_type(cs.data[index_of_next_arg]) == Lisp_Object_Type::Keyword) { - // check if this one is even an accepted keyword - bool accepted = false; - for (int i = 0; i < arg_spec->keyword.keywords.next_index; ++i) { - if (cs.data[index_of_next_arg] == arg_spec->keyword.keywords.data[i]) { - accepted = true; - break; - } - } - if (!accepted) { - // if we read all we need then we are done here - if (read_obligatory_keywords_count == obligatory_keywords_count) - break; - // otherwise we would have to read more but there - // was a not accepted kwarg, so signal the error - create_generic_error( - "The function does not take the keyword argument ':%s'\n" - "and not all required keyword arguments have been read\n" - "in to potentially count it as the rest argument.", - cs.data[index_of_next_arg]->value.symbol.data); - return nullptr; - } - // This is an accepted kwarg; check if it was already - // read in - for (int i = 0; i < read_in_keywords.next_index; ++i) { - if (cs.data[index_of_next_arg] == read_in_keywords.data[i]) - { - // if we already read it in but also finished - // all other kwargs, then count it as rest and - // be done here - if (read_obligatory_keywords_count == obligatory_keywords_count) - goto kw_done; - // If there are some kwargs left to be read - // in, it is an error - create_generic_error( - "The function already read the keyword argument ':%s'", - cs.data[index_of_next_arg]->value.symbol.data); - return nullptr; - } - } - // okay so we found a keyword that has to be read in and was - // not already read in, is there a next element to actually - // set it to? - if (index_of_next_arg+1 == arg_end) { - create_generic_error( - "Attempting to set the keyword argument ':%s', but no value was supplied.", - cs.data[index_of_next_arg]->value.symbol.data); - return nullptr; - } - - // if not set it and then add it to the array list - Lisp_Object* key = cs.data[index_of_next_arg]; - try sym = Memory::get_symbol(key->value.symbol); - ++index_of_next_arg; - - if (is_c_function) { - try define_symbol(sym, cs.data[index_of_next_arg], env); - } else { - try define_symbol(sym, Memory::copy_lisp_object_except_pairs(cs.data[index_of_next_arg]), env); - } - - read_in_keywords.append(key); - ++read_obligatory_keywords_count; - - ++index_of_next_arg; - - if (index_of_next_arg == arg_end) { - break; - } - } - } - - kw_done: - // check keywords for completeness - for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) { - auto defined_keyword = arg_spec->keyword.keywords.data[i]; - bool was_set = false; - for (int j = 0; j < read_in_keywords.next_index; ++j) { - if (read_in_keywords.data[j] == defined_keyword) { - was_set = true; - break; - } - } - if (arg_spec->keyword.values.data[i] == nullptr) { - // if this one does not have a default value - if (!was_set) { - create_generic_error( - "There was no value supplied for the required " - "keyword argument ':%s'.", - defined_keyword->value.symbol.data); - return nullptr; - } - } else { - // this one does have a default value, lets see if we have - // to use it or if the user supplied his own - if (!was_set) { - try sym = Memory::get_symbol(defined_keyword->value.symbol); - if (is_c_function) { - try val = arg_spec->keyword.values.data[i]; - } else { - try val = Memory::copy_lisp_object_except_pairs(arg_spec->keyword.values.data[i]); - } - define_symbol(sym, val, env); - } - } - } - - // read in rest arg - if (index_of_next_arg == arg_end) { - if (arg_spec->rest) { - define_symbol(arg_spec->rest, Memory::nil, env); - } - } else { - if (arg_spec->rest) { - Lisp_Object* list; - try list = Memory::create_list(cs.data[index_of_next_arg]); - Lisp_Object* head = list; - for (++index_of_next_arg;index_of_next_arg < arg_end; ++index_of_next_arg) { - try head->value.pair.rest = Memory::create_list(cs.data[index_of_next_arg]); - head = head->value.pair.rest; - } - define_symbol(arg_spec->rest, list, env); - } else { - // rest was not declared but additional arguments were found - create_generic_error( - "A rest argument was not declared " - "but the function was called with additional arguments."); - return nullptr; - } - } - - return env; - } - - - proc apply_arguments_to_function(Lisp_Object* arguments, Lisp_Object* function, bool should_evaluate_args) -> Lisp_Object* { - // profile_this(); - // Environment* new_env; - // Lisp_Object* result; - - // try new_env = create_extended_environment_for_function_application(arguments, function, should_evaluate_args); - // push_environment(new_env); - // defer { - // pop_environment(); - // }; - - - // if (Memory::get_type(function) == Lisp_Object_Type::CFunction) - // // if c function: - // try result = function->value.cFunction->body(); - // else - // // if lisp function - // try result = eval_expr(function->value.function->body); - - // return result; - return nullptr; - } - - proc create_arguments_from_lambda_list_and_inject(Lisp_Object* arguments, Lisp_Object* function) -> void { - /* NOTE This parses the argument specification of funcitons - * into their Function struct. It does this by allocating new - * positional_arguments, keyword_arguments and rest_argument - * and filling it in - */ - Arguments* result = &function->value.function->args;; - - // first init the fields - result->rest = nullptr; - - // okay let's try to read some positional arguments - while (Memory::get_type(arguments) == Lisp_Object_Type::Pair) { - // if we encounter a keyword or a list (for keywords with - // defualt args), the positionals are done - if (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword || - Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Pair) { - break; - } - - // if we encounter something that is neither a symbol nor a - // keyword arg, it's an error - if (Memory::get_type(arguments->value.pair.first) != Lisp_Object_Type::Symbol) { - create_parsing_error("Only symbols and keywords " - "(with or without default args) " - "can be parsed here, but found '%s'", - lisp_object_type_to_string(Memory::get_type(arguments->value.pair.first))); - return; - } - - // okay we found an actual symbol - result->positional.symbols.append(arguments->value.pair.first); - - arguments = arguments->value.pair.rest; - } - - // if we reach here, we are on a keyword or a pair wher a keyword - // should be in first - while (Memory::get_type(arguments) == Lisp_Object_Type::Pair) { - if (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword) { - // if we are on a actual keyword (with no default arg) - auto keyword = arguments->value.pair.first; - result->keyword.keywords.append(keyword); - result->keyword.values.append(nullptr); - } else if (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Pair) { - // if we are on a keyword with a default value - - auto keyword = arguments->value.pair.first->value.pair.first; - if (Memory::get_type(keyword) != Lisp_Object_Type::Keyword) { - create_parsing_error("Default args must be keywords"); - } - if (Memory::get_type(arguments->value.pair.first->value.pair.rest) - != Lisp_Object_Type::Pair) - { - create_parsing_error("Default args must be a list of 2."); - } - auto value = arguments->value.pair.first->value.pair.rest->value.pair.first; - try_void value = eval_expr(value); - if (arguments->value.pair.first->value.pair.rest->value.pair.rest != Memory::nil) { - create_parsing_error("Default args must be a list of 2."); - } - - result->keyword.keywords.append(keyword); - result->keyword.values.append(value); - } - arguments = arguments->value.pair.rest; - } - - // Now we are also done with keyword arguments, lets check for - // if there is a rest argument - if (Memory::get_type(arguments) != Lisp_Object_Type::Pair) { - if (arguments == Memory::nil) - return; - if (Memory::get_type(arguments) == Lisp_Object_Type::Symbol) - result->rest = arguments; - else - create_parsing_error("The rest argument must be a symbol."); - } - } - - - proc list_length(Lisp_Object* node) -> int { - if (node == Memory::nil) - return 0; - - try assert_type(node, Lisp_Object_Type::Pair); - - int len = 0; - - while (Memory::get_type(node) == Lisp_Object_Type::Pair) { - ++len; - node = node->value.pair.rest; - if (node == Memory::nil) - return len; - } - - create_parsing_error("Can't calculate length of ill formed list."); - return 0; - } - - proc copy_scl(Source_Code_Location*) -> Source_Code_Location* { - // TODO(Felix): - return nullptr; - } - - proc pause() { - printf("\n-----------------------\n" - "Press ENTER to continue\n"); - getchar(); - } - - inline proc maybe_wrap_body_in_begin(Lisp_Object* body) -> Lisp_Object* { - Lisp_Object* begin_symbol = Memory::get_symbol("begin"); - if (body->value.pair.rest == Memory::nil) - return body->value.pair.first; - else - return Memory::create_lisp_object_pair(begin_symbol, body); - } - - proc eval_expr(Lisp_Object* expr) -> Lisp_Object* { - profile_this(); - using namespace Globals::Current_Execution; - - nass.reserve(1); - Array_List* nas = nass.data+(nass.next_index++); - nas->alloc(); - defer { - --nass.next_index; - nas->dealloc(); - }; - - proc debug_step = [&] { - if (!Globals::debug_log) - return; - printf("\n-------------------\n"); - print_current_execution(); - // pause(); - }; - - proc push_pc_on_cs = [&] { - for_lisp_list (pcs.data[pcs.next_index-1]) { - cs.append(it); - } - pcs.data[pcs.next_index-1] = Memory::nil; - }; - - cs.append(expr); - nas->append(NasAction::Eval); - - NasAction current_action; - Lisp_Object* pc; - - while (nas->next_index > 0) { - debug_step(); - - current_action = nas->data[--nas->next_index]; - switch (current_action) { - case NasAction::Pop: { - --cs.next_index; - } break; - case NasAction::And_Then_Action: { - ats.data[--ats.next_index](); - } break; - case NasAction::Pop_Environment: { - pop_environment(); - } break; - case NasAction::Eval: { - pc = cs.data[cs.next_index-1]; - Lisp_Object_Type type = Memory::get_type(pc); - switch (type) { - case Lisp_Object_Type::Symbol: { - cs.data[cs.next_index-1] = lookup_symbol(pc, get_current_environment()); - } break; - case Lisp_Object_Type::Pair: { - cs.data[cs.next_index-1] = pc->value.pair.first; - ams.append(cs.next_index-1); - pcs.append(pc->value.pair.rest); - mes.append(pc); - nas->append(NasAction::TM); - nas->append(NasAction::Eval); - } break; - default: { - // NOTE(Felix): others are self evaluating - // so do nothing - } - } - } break; - case NasAction::Macro_Write_Back: { - *mes.data[--mes.next_index] = *cs[cs.next_index-1]; - } break; - case NasAction::TM: { - pc = cs.data[cs.next_index-1]; - - Lisp_Object_Type type = Memory::get_type(pc); - switch (type) { - case Lisp_Object_Type::Function: { - if(pc->value.function->is_c) { - if (pc->value.function->type.c_function_type == C_Function_Type::cMacro) { - try pc->value.function->body.c_macro_body(); - } else if (pc->value.function->type.c_function_type == C_Function_Type::cSpecial) - { - // TODO(Felix): Why not call the function - // right away, and instead push step, so - // that step calls it? - push_pc_on_cs(); - nas->append(NasAction::Step); - } else { - nas->append(NasAction::Step); - } - --mes.next_index; - } else { - if (pc->value.function->type.lisp_function_type == - Lisp_Function_Type::Macro) - { - push_pc_on_cs(); - nas->append(NasAction::Eval); - nas->append(NasAction::Macro_Write_Back); - nas->append(NasAction::Step); - } else { - --mes.next_index; - nas->append(NasAction::Step); - } - } - } break; - default: { - char* t = lisp_object_to_string(pc); - defer { - free(t); - }; - create_generic_error("The first element of the pair was not a function but: %s in %s", - lisp_object_type_to_string(type), t); - return nullptr; - } - } - - } break; - case NasAction::Step: { - if (pcs.data[pcs.next_index-1] == Memory::nil) { - --pcs.next_index; - int am = ams.data[--ams.next_index]; - Lisp_Object* function = cs.data[am]; - try assert_type(function, Lisp_Object_Type::Function); - - Environment* extended_env; - try extended_env = create_extended_environment_for_function_application_nrc( - function, am+1, cs.next_index); - cs.next_index = am; - push_environment(extended_env); - if (function->value.function->is_c) { - if (function->value.function->type.c_function_type == C_Function_Type::cMacro) - try function->value.function->body.c_macro_body(); - else - try cs.append(function->value.function->body.c_body()); - pop_environment(); - } else { - nas->append(NasAction::Pop_Environment); - nas->append(NasAction::Eval); - cs.append(function->value.function->body.lisp_body); - } - } else { - cs.append(pcs.data[pcs.next_index-1]->value.pair.first); - pcs.data[pcs.next_index-1] = pcs.data[pcs.next_index-1]->value.pair.rest; - nas->append(NasAction::Step); - nas->append(NasAction::Eval); - } - } break; - case NasAction::If: { - /* | | - | | - | | - | .... | */ - cs.next_index -= 2; - // NOTE(Felix): for false it is sufficent to pop 2 for - // true we have to copy the then part to the new top - // of the stack - if (cs.data[cs.next_index+1] != Memory::nil) { - cs.data[cs.next_index-1] = cs.data[cs.next_index]; - } - } break; - case NasAction::Define_Var: { - /* | | - | | - | .... | */ - cs.next_index -= 1; - try assert_type(cs.data[cs.next_index-1], Lisp_Object_Type::Symbol); - try define_symbol(cs.data[cs.next_index-1], cs.data[cs.next_index]); - cs.data[cs.next_index-1] = Memory::t; - } - } - - } - // debug_step(); - - return cs.data[--cs.next_index]; - } - - inline proc is_truthy(Lisp_Object* expression) -> bool { - return expression != Memory::nil; - } - - proc interprete_file (char* file_name) -> Lisp_Object* { - try Memory::init(); - - Lisp_Object* result; - - try result = built_in_load(Memory::create_string(file_name)); - - return result; - } - - proc interprete_stdin() -> void { - try_void Memory::init(); - - printf("Welcome to the lispy interpreter.\n%s\n", version_string); - - char* line; - - Lisp_Object* parsed, * evaluated; - while (true) { - if (Globals::error) { - log_error(); - delete_error(); - } - fputs("> ", stdout); - line = read_expression(); - parsed = Parser::parse_single_expression(line); - if (Globals::error) { - continue; - } - free(line); - evaluated = eval_expr(parsed); - if (Globals::error) { - continue; - } - if (evaluated && evaluated != Memory::nil) { - print(evaluated); - } - fputs("\n", stdout); - } - } -} +namespace Slime { + + proc create_extended_environment_for_function_application_nrc( + Lisp_Object* function, + int arg_start, + int arg_end) -> Environment* + { + profile_this(); + using namespace Globals::Current_Execution; + + int index_of_next_arg = arg_start; + bool is_c_function = function->value.function->is_c; + Environment* env = Memory::create_child_environment(function->value.function->parent_environment); + Arguments* arg_spec = &function->value.function->args; + + Array_List read_in_keywords; + read_in_keywords.alloc(); + defer { + read_in_keywords.dealloc(); + }; + int obligatory_keywords_count = 0; + int read_obligatory_keywords_count = 0; + + Lisp_Object* sym; + Lisp_Object* val; + + // read positionals + for (int i = 0; i < arg_spec->positional.symbols.next_index; ++i) { + if (index_of_next_arg == arg_end) { + create_parsing_error( + "Not enough positional args supplied. Needed: %d suppied, %d.\n" + "Next missing arg is '%s'", + arg_spec->positional.symbols.next_index, arg_end-index_of_next_arg, + arg_spec->positional.symbols.data[i]->value.symbol.data); + return nullptr; + } + // NOTE(Felix): We have to copy all the arguments, + // otherwise we change the program code. To C functions we + // pass by reference for better performance and trust them + // to not mutate the arguments because we expect c + // programmers to know what they are doing. Bold claim I + // know. + if (is_c_function) { + define_symbol(arg_spec->positional.symbols.data[i], cs.data[index_of_next_arg], env); + } else { + define_symbol(arg_spec->positional.symbols.data[i], Memory::copy_lisp_object_except_pairs(cs.data[index_of_next_arg]), env); + } + ++index_of_next_arg; + } + + // if there are some left read keywords and rest + if (index_of_next_arg != arg_end) { + // find out how many keyword args we /have/ to read + for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) { + if (arg_spec->keyword.values.data[i] == nullptr) + ++obligatory_keywords_count; + } + + while (cs.data[index_of_next_arg]->type == Lisp_Object_Type::Keyword) { + // check if this one is even an accepted keyword + bool accepted = false; + for (int i = 0; i < arg_spec->keyword.keywords.next_index; ++i) { + if (cs.data[index_of_next_arg] == arg_spec->keyword.keywords.data[i]) { + accepted = true; + break; + } + } + if (!accepted) { + // if we read all we need then we are done here + if (read_obligatory_keywords_count == obligatory_keywords_count) + break; + // otherwise we would have to read more but there + // was a not accepted kwarg, so signal the error + create_generic_error( + "The function does not take the keyword argument ':%s'\n" + "and not all required keyword arguments have been read\n" + "in to potentially count it as the rest argument.", + cs.data[index_of_next_arg]->value.symbol.data); + return nullptr; + } + // This is an accepted kwarg; check if it was already + // read in + for (int i = 0; i < read_in_keywords.next_index; ++i) { + if (cs.data[index_of_next_arg] == read_in_keywords.data[i]) + { + // if we already read it in but also finished + // all other kwargs, then count it as rest and + // be done here + if (read_obligatory_keywords_count == obligatory_keywords_count) + goto kw_done; + // If there are some kwargs left to be read + // in, it is an error + create_generic_error( + "The function already read the keyword argument ':%s'", + cs.data[index_of_next_arg]->value.symbol.data); + return nullptr; + } + } + // okay so we found a keyword that has to be read in and was + // not already read in, is there a next element to actually + // set it to? + if (index_of_next_arg+1 == arg_end) { + create_generic_error( + "Attempting to set the keyword argument ':%s', but no value was supplied.", + cs.data[index_of_next_arg]->value.symbol.data); + return nullptr; + } + + // if not set it and then add it to the array list + Lisp_Object* key = cs.data[index_of_next_arg]; + try sym = Memory::get_symbol(key->value.symbol); + ++index_of_next_arg; + + if (is_c_function) { + try define_symbol(sym, cs.data[index_of_next_arg], env); + } else { + try define_symbol(sym, Memory::copy_lisp_object_except_pairs(cs.data[index_of_next_arg]), env); + } + + read_in_keywords.append(key); + ++read_obligatory_keywords_count; + + ++index_of_next_arg; + + if (index_of_next_arg == arg_end) { + break; + } + } + } + + kw_done: + // check keywords for completeness + for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) { + auto defined_keyword = arg_spec->keyword.keywords.data[i]; + bool was_set = false; + for (int j = 0; j < read_in_keywords.next_index; ++j) { + if (read_in_keywords.data[j] == defined_keyword) { + was_set = true; + break; + } + } + if (arg_spec->keyword.values.data[i] == nullptr) { + // if this one does not have a default value + if (!was_set) { + create_generic_error( + "There was no value supplied for the required " + "keyword argument ':%s'.", + defined_keyword->value.symbol.data); + return nullptr; + } + } else { + // this one does have a default value, lets see if we have + // to use it or if the user supplied his own + if (!was_set) { + try sym = Memory::get_symbol(defined_keyword->value.symbol); + if (is_c_function) { + try val = arg_spec->keyword.values.data[i]; + } else { + try val = Memory::copy_lisp_object_except_pairs(arg_spec->keyword.values.data[i]); + } + define_symbol(sym, val, env); + } + } + } + + // read in rest arg + if (index_of_next_arg == arg_end) { + if (arg_spec->rest) { + define_symbol(arg_spec->rest, Memory::nil, env); + } + } else { + if (arg_spec->rest) { + Lisp_Object* list; + try list = Memory::create_list(cs.data[index_of_next_arg]); + Lisp_Object* head = list; + for (++index_of_next_arg;index_of_next_arg < arg_end; ++index_of_next_arg) { + try head->value.pair.rest = Memory::create_list(cs.data[index_of_next_arg]); + head = head->value.pair.rest; + } + define_symbol(arg_spec->rest, list, env); + } else { + // rest was not declared but additional arguments were found + create_generic_error( + "A rest argument was not declared " + "but the function was called with additional arguments."); + return nullptr; + } + } + + return env; + } + + proc create_arguments_from_lambda_list_and_inject(Lisp_Object* arguments, Lisp_Object* function) -> void { + /* NOTE This parses the argument specification of funcitons + * into their Function struct. It does this by allocating new + * positional_arguments, keyword_arguments and rest_argument + * and filling it in + */ + Arguments* result = &function->value.function->args;; + + // first init the fields + result->rest = nullptr; + + // okay let's try to read some positional arguments + while (arguments->type == Lisp_Object_Type::Pair) { + // if we encounter a keyword or a list (for keywords with + // defualt args), the positionals are done + if (arguments->value.pair.first->type == Lisp_Object_Type::Keyword || + arguments->value.pair.first->type == Lisp_Object_Type::Pair) { + break; + } + + // if we encounter something that is neither a symbol nor a + // keyword arg, it's an error + if (arguments->value.pair.first->type != Lisp_Object_Type::Symbol) { + create_parsing_error("Only symbols and keywords " + "(with or without default args) " + "can be parsed here, but found '%s'", + lisp_object_type_to_string(arguments->value.pair.first->type)); + return; + } + + // okay we found an actual symbol + result->positional.symbols.append(arguments->value.pair.first); + + arguments = arguments->value.pair.rest; + } + + // if we reach here, we are on a keyword or a pair wher a keyword + // should be in first + while ((arguments->type) == Lisp_Object_Type::Pair) { + if ((arguments->value.pair.first->type) == Lisp_Object_Type::Keyword) { + // if we are on a actual keyword (with no default arg) + auto keyword = arguments->value.pair.first; + result->keyword.keywords.append(keyword); + result->keyword.values.append(nullptr); + } else if ((arguments->value.pair.first->type) == Lisp_Object_Type::Pair) { + // if we are on a keyword with a default value + + auto keyword = arguments->value.pair.first->value.pair.first; + if ((keyword->type) != Lisp_Object_Type::Keyword) { + create_parsing_error("Default args must be keywords"); + } + if ((arguments->value.pair.first->value.pair.rest->type) + != Lisp_Object_Type::Pair) + { + create_parsing_error("Default args must be a list of 2."); + } + auto value = arguments->value.pair.first->value.pair.rest->value.pair.first; + try_void value = eval_expr(value); + if (arguments->value.pair.first->value.pair.rest->value.pair.rest != Memory::nil) { + create_parsing_error("Default args must be a list of 2."); + } + + result->keyword.keywords.append(keyword); + result->keyword.values.append(value); + } + arguments = arguments->value.pair.rest; + } + + // Now we are also done with keyword arguments, lets check for + // if there is a rest argument + if (arguments->type != Lisp_Object_Type::Pair) { + if (arguments == Memory::nil) + return; + if (arguments->type == Lisp_Object_Type::Symbol) + result->rest = arguments; + else + create_parsing_error("The rest argument must be a symbol."); + } + } + + + proc list_length(Lisp_Object* node) -> int { + if (node == Memory::nil) + return 0; + + try assert_type(node, Lisp_Object_Type::Pair); + + int len = 0; + + while (node->type == Lisp_Object_Type::Pair) { + ++len; + node = node->value.pair.rest; + if (node == Memory::nil) + return len; + } + + create_parsing_error("Can't calculate length of ill formed list."); + return 0; + } + + proc copy_scl(Source_Code_Location*) -> Source_Code_Location* { + // TODO(Felix): + return nullptr; + } + + proc pause() { + printf("\n-----------------------\n" + "Press ENTER to continue\n"); + getchar(); + } + + inline proc maybe_wrap_body_in_begin(Lisp_Object* body) -> Lisp_Object* { + Lisp_Object* begin_symbol = Memory::get_symbol("begin"); + if (body->value.pair.rest == Memory::nil) + return body->value.pair.first; + else + return Memory::create_lisp_object_pair(begin_symbol, body); + } + + proc eval_expr(Lisp_Object* expr) -> Lisp_Object* { + profile_this(); + using namespace Globals::Current_Execution; + + nass.reserve(1); + Array_List* nas = nass.data+(nass.next_index++); + nas->alloc(); + defer { + --nass.next_index; + nas->dealloc(); + }; + + proc debug_step = [&] { + if (!Globals::debug_log) + return; + printf("\n-------------------\n"); + print_current_execution(); + // pause(); + }; + + proc push_pc_on_cs = [&] { + for_lisp_list (pcs.data[pcs.next_index-1]) { + cs.append(it); + } + pcs.data[pcs.next_index-1] = Memory::nil; + }; + + cs.append(expr); + nas->append(NasAction::Eval); + + NasAction current_action; + Lisp_Object* pc; + + while (nas->next_index > 0) { + debug_step(); + + current_action = nas->data[--nas->next_index]; + switch (current_action) { + case NasAction::Pop: { + --cs.next_index; + } break; + case NasAction::And_Then_Action: { + ats.data[--ats.next_index](); + } break; + case NasAction::Pop_Environment: { + pop_environment(); + } break; + case NasAction::Eval: { + pc = cs.data[cs.next_index-1]; + Lisp_Object_Type type = pc->type; + switch (type) { + case Lisp_Object_Type::Symbol: { + cs.data[cs.next_index-1] = lookup_symbol(pc, get_current_environment()); + } break; + case Lisp_Object_Type::Pair: { + cs.data[cs.next_index-1] = pc->value.pair.first; + ams.append(cs.next_index-1); + pcs.append(pc->value.pair.rest); + mes.append(pc); + nas->append(NasAction::TM); + nas->append(NasAction::Eval); + } break; + default: { + // NOTE(Felix): others are self evaluating + // so do nothing + } + } + } break; + case NasAction::Macro_Write_Back: { + *mes.data[--mes.next_index] = *cs[cs.next_index-1]; + } break; + case NasAction::TM: { + pc = cs.data[cs.next_index-1]; + + Lisp_Object_Type type = pc->type; + switch (type) { + case Lisp_Object_Type::Function: { + if(pc->value.function->is_c) { + if (pc->value.function->type.c_function_type == C_Function_Type::cMacro) { + try pc->value.function->body.c_macro_body(); + } else if (pc->value.function->type.c_function_type == C_Function_Type::cSpecial) + { + // TODO(Felix): Why not call the function + // right away, and instead push step, so + // that step calls it? + push_pc_on_cs(); + nas->append(NasAction::Step); + } else { + nas->append(NasAction::Step); + } + --mes.next_index; + } else { + if (pc->value.function->type.lisp_function_type == + Lisp_Function_Type::Macro) + { + push_pc_on_cs(); + nas->append(NasAction::Eval); + nas->append(NasAction::Macro_Write_Back); + nas->append(NasAction::Step); + } else { + --mes.next_index; + nas->append(NasAction::Step); + } + } + } break; + default: { + char* t = lisp_object_to_string(pc); + defer { + free(t); + }; + create_generic_error("The first element of the pair was not a function but: %s in %s", + lisp_object_type_to_string(type), t); + return nullptr; + } + } + + } break; + case NasAction::Step: { + if (pcs.data[pcs.next_index-1] == Memory::nil) { + --pcs.next_index; + int am = ams.data[--ams.next_index]; + Lisp_Object* function = cs.data[am]; + try assert_type(function, Lisp_Object_Type::Function); + + Environment* extended_env; + try extended_env = create_extended_environment_for_function_application_nrc( + function, am+1, cs.next_index); + cs.next_index = am; + push_environment(extended_env); + if (function->value.function->is_c) { + if (function->value.function->type.c_function_type == C_Function_Type::cMacro) + try function->value.function->body.c_macro_body(); + else + try cs.append(function->value.function->body.c_body()); + pop_environment(); + } else { + nas->append(NasAction::Pop_Environment); + nas->append(NasAction::Eval); + cs.append(function->value.function->body.lisp_body); + } + } else { + cs.append(pcs.data[pcs.next_index-1]->value.pair.first); + pcs.data[pcs.next_index-1] = pcs.data[pcs.next_index-1]->value.pair.rest; + nas->append(NasAction::Step); + nas->append(NasAction::Eval); + } + } break; + case NasAction::If: { + /* | | + | | + | | + | .... | */ + cs.next_index -= 2; + // NOTE(Felix): for false it is sufficent to pop 2 for + // true we have to copy the then part to the new top + // of the stack + if (cs.data[cs.next_index+1] != Memory::nil) { + cs.data[cs.next_index-1] = cs.data[cs.next_index]; + } + } break; + case NasAction::Define_Var: { + /* | | + | | + | .... | */ + cs.next_index -= 1; + try assert_type(cs.data[cs.next_index-1], Lisp_Object_Type::Symbol); + try define_symbol(cs.data[cs.next_index-1], cs.data[cs.next_index]); + cs.data[cs.next_index-1] = Memory::t; + } + } + + } + // debug_step(); + + return cs.data[--cs.next_index]; + } + + inline proc is_truthy(Lisp_Object* expression) -> bool { + return expression != Memory::nil; + } + + proc interprete_file (char* file_name) -> Lisp_Object* { + try Memory::init(); + + Lisp_Object* result; + + try result = built_in_load(Memory::create_string(file_name)); + + return result; + } + + proc interprete_stdin() -> void { + try_void Memory::init(); + + printf("Welcome to the lispy interpreter.\n%s\n", version_string); + + char* line; + + Lisp_Object* parsed, * evaluated; + while (true) { + if (Globals::error) { + log_error(); + delete_error(); + } + fputs("> ", stdout); + line = read_expression(); + parsed = Parser::parse_single_expression(line); + if (Globals::error) { + continue; + } + free(line); + evaluated = eval_expr(parsed); + if (Globals::error) { + continue; + } + if (evaluated && evaluated != Memory::nil) { + print(evaluated); + } + fputs("\n", stdout); + } + } +} diff --git a/src/forward_decls.cpp b/src/forward_decls.cpp index 0b8bd90..0ae77d9 100644 --- a/src/forward_decls.cpp +++ b/src/forward_decls.cpp @@ -1,89 +1,88 @@ -namespace Slime { - void add_to_load_path(const char*); - bool lisp_object_equal(Lisp_Object*,Lisp_Object*); - Lisp_Object* built_in_load(String); - Lisp_Object* built_in_import(String); - void delete_error(); - void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, const char* format, ...); - void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, String message); - void create_error(Lisp_Object* type, const char* message, const char* c_file_name, int c_file_line); - Lisp_Object* eval_arguments(Lisp_Object*); - Lisp_Object* eval_expr(Lisp_Object*); - bool is_truthy (Lisp_Object*); - int list_length(Lisp_Object*); - void* load_built_ins_into_environment(); - void create_arguments_from_lambda_list_and_inject(Lisp_Object* formal_arguments, Lisp_Object* function); - - Lisp_Object* lookup_symbol(Lisp_Object* symbol, Environment*); - void define_symbol(Lisp_Object* symbol, Lisp_Object* value); - void define_symbol(Lisp_Object* symbol, Lisp_Object* value, Environment* env); - char* lisp_object_to_string(Lisp_Object* node, bool print_repr = true); - void print(Lisp_Object* node, bool print_repr = false, FILE* file = stdout); - void print_environment(Environment*); - - bool run_all_tests(); - - inline Environment* get_root_environment(); - inline Environment* get_current_environment(); - inline void push_environment(Environment*); - inline void pop_environment(); - - const char* lisp_object_type_to_string(Lisp_Object_Type type); - - void visualize_lisp_machine(); - void generate_docs(String path); - void log_error(); - - namespace Memory { - Environment* create_built_ins_environment(); - Lisp_Object* create_lisp_object_cfunction(bool is_special); - inline Lisp_Object_Type get_type(Lisp_Object* node); - void init(); - char* get_c_str(String); - void free_everything(); - String create_string(const char*); - Lisp_Object* get_symbol(String identifier); - Lisp_Object* get_symbol(const char*); - Lisp_Object* get_keyword(String identifier); - Lisp_Object* get_keyword(const char*); - Lisp_Object* create_lisp_object(double); - Lisp_Object* create_lisp_object(const char*); - Lisp_Object* create_lisp_object_vector(Lisp_Object*); - Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*); - Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*, Lisp_Object*); - Lisp_Object* create_lisp_object_vector(int, Lisp_Object*); - inline Lisp_Object* create_list(Lisp_Object*); - inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*); - inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*); - inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*); - inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*); - inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*); - } - - namespace Parser { - // extern Environment* environment_for_macros; - - extern String standard_in; - extern String parser_file; - extern int parser_line; - extern int parser_col; - - Lisp_Object* parse_expression(char* text, int* index_in_text); - Lisp_Object* parse_single_expression(const char* text); - Lisp_Object* parse_single_expression(char* text); - Lisp_Object* parse_single_expression(wchar_t* text); - } - - namespace Globals { - extern bool debug_log; - extern char* bin_path; - extern Log_Level log_level; - extern Array_List load_path; - namespace Current_Execution { - extern Array_List call_stack; - extern Array_List envi_stack; - } - extern Error* error; - extern bool breaking_on_errors; - } -} +namespace Slime { + void add_to_load_path(const char*); + bool lisp_object_equal(Lisp_Object*,Lisp_Object*); + Lisp_Object* built_in_load(String); + Lisp_Object* built_in_import(String); + void delete_error(); + void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, const char* format, ...); + void create_error(const char* c_func_name, const char* c_file_name, int c_file_line, Lisp_Object* type, String message); + void create_error(Lisp_Object* type, const char* message, const char* c_file_name, int c_file_line); + Lisp_Object* eval_arguments(Lisp_Object*); + Lisp_Object* eval_expr(Lisp_Object*); + bool is_truthy (Lisp_Object*); + int list_length(Lisp_Object*); + void* load_built_ins_into_environment(); + void create_arguments_from_lambda_list_and_inject(Lisp_Object* formal_arguments, Lisp_Object* function); + + Lisp_Object* lookup_symbol(Lisp_Object* symbol, Environment*); + void define_symbol(Lisp_Object* symbol, Lisp_Object* value); + void define_symbol(Lisp_Object* symbol, Lisp_Object* value, Environment* env); + char* lisp_object_to_string(Lisp_Object* node, bool print_repr = true); + void print(Lisp_Object* node, bool print_repr = false, FILE* file = stdout); + void print_environment(Environment*); + + bool run_all_tests(); + + inline Environment* get_root_environment(); + inline Environment* get_current_environment(); + inline void push_environment(Environment*); + inline void pop_environment(); + + const char* lisp_object_type_to_string(Lisp_Object_Type type); + + void visualize_lisp_machine(); + void generate_docs(String path); + void log_error(); + + namespace Memory { + Environment* create_built_ins_environment(); + Lisp_Object* create_lisp_object_cfunction(bool is_special); + void init(); + char* get_c_str(String); + void free_everything(); + String create_string(const char*); + Lisp_Object* get_symbol(String identifier); + Lisp_Object* get_symbol(const char*); + Lisp_Object* get_keyword(String identifier); + Lisp_Object* get_keyword(const char*); + Lisp_Object* create_lisp_object(double); + Lisp_Object* create_lisp_object(const char*); + Lisp_Object* create_lisp_object_vector(Lisp_Object*); + Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*); + Lisp_Object* create_lisp_object_vector(Lisp_Object*, Lisp_Object*, Lisp_Object*); + Lisp_Object* create_lisp_object_vector(int, Lisp_Object*); + inline Lisp_Object* create_list(Lisp_Object*); + inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*); + inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*); + inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*); + inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*); + inline Lisp_Object* create_list(Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*,Lisp_Object*); + } + + namespace Parser { + // extern Environment* environment_for_macros; + + extern String standard_in; + extern String parser_file; + extern int parser_line; + extern int parser_col; + + Lisp_Object* parse_expression(char* text, int* index_in_text); + Lisp_Object* parse_single_expression(const char* text); + Lisp_Object* parse_single_expression(char* text); + Lisp_Object* parse_single_expression(wchar_t* text); + } + + namespace Globals { + extern bool debug_log; + extern char* bin_path; + extern Log_Level log_level; + extern Array_List load_path; + namespace Current_Execution { + extern Array_List call_stack; + extern Array_List envi_stack; + } + extern Error* error; + extern bool breaking_on_errors; + } +} diff --git a/src/gc.cpp b/src/gc.cpp index f08b841..0537ce7 100644 --- a/src/gc.cpp +++ b/src/gc.cpp @@ -1,96 +1,96 @@ -namespace Slime::GC { - proc maybe_mark(Environment* env) -> void; - - int current_mark; - - Array_List marked_objects; - Array_List marked_strings; - Array_List marked_environments; - Array_List protected_environments; - - proc marked(Lisp_Object* node) -> bool { - return false; - } - - proc marked(Environment* env) -> bool { - return false; - } - - proc maybe_mark(Lisp_Object* node) -> void { - if (marked(node)) - return; - - // mark object itself - marked_objects.append(node); - - // mark docstring - // TODO(Felix): - // if (node->docstring) - // marked_strings.append(node->docstring); - - // mark type specific data - switch (Memory::get_type(node)) { - case Lisp_Object_Type::Pair: { - for_lisp_list (node) { - maybe_mark(it); - } - } break; - case Lisp_Object_Type::Vector: { - for_lisp_vector (node) { - maybe_mark(it); - } - } break; - case Lisp_Object_Type::String: { - marked_strings.append(node->value.string); - } break; - case Lisp_Object_Type::Function: { - // NOTE(Felix): We dont have to mark the symbols, keywords - // for parameter names, as symbols and keywords are never - // garbage collected - maybe_mark(node->value.function->parent_environment); - if (!node->value.function->is_c) { - maybe_mark(node->value.function->body.lisp_body); - } - // mark the default arguemnt values: - for (auto it : node->value.function->args.keyword.values) { - if (it) - maybe_mark(it); - } - } break; - default: break; - } - - } - - proc maybe_mark(Environment* env) -> void { - if (marked(env)) - return; - - marked_environments.append(env); - - for (auto p : env->parents) { - maybe_mark(p); - } - - // Lisp_Object* it = env->values[0]; - // for (int i = 0; i < env->next_index; it = env->values[++i]) { - // maybe_mark(it); - // } - } - - proc garbage_collect() -> void { - profile_this(); - ++current_mark; - - for (auto it : protected_environments) maybe_mark(it); - for (auto it : Globals::Current_Execution::envi_stack) maybe_mark(it); - } - - proc gc_init_and_go() -> void { - current_mark = 0; - - while (1) { - garbage_collect(); - } - } -} +namespace Slime::GC { + proc maybe_mark(Environment* env) -> void; + + int current_mark; + + Array_List marked_objects; + Array_List marked_strings; + Array_List marked_environments; + Array_List protected_environments; + + proc marked(Lisp_Object* node) -> bool { + return false; + } + + proc marked(Environment* env) -> bool { + return false; + } + + proc maybe_mark(Lisp_Object* node) -> void { + if (marked(node)) + return; + + // mark object itself + marked_objects.append(node); + + // mark docstring + // TODO(Felix): + // if (node->docstring) + // marked_strings.append(node->docstring); + + // mark type specific data + switch (node->type) { + case Lisp_Object_Type::Pair: { + for_lisp_list (node) { + maybe_mark(it); + } + } break; + case Lisp_Object_Type::Vector: { + for_lisp_vector (node) { + maybe_mark(it); + } + } break; + case Lisp_Object_Type::String: { + marked_strings.append(node->value.string); + } break; + case Lisp_Object_Type::Function: { + // NOTE(Felix): We dont have to mark the symbols, keywords + // for parameter names, as symbols and keywords are never + // garbage collected + maybe_mark(node->value.function->parent_environment); + if (!node->value.function->is_c) { + maybe_mark(node->value.function->body.lisp_body); + } + // mark the default arguemnt values: + for (auto it : node->value.function->args.keyword.values) { + if (it) + maybe_mark(it); + } + } break; + default: break; + } + + } + + proc maybe_mark(Environment* env) -> void { + if (marked(env)) + return; + + marked_environments.append(env); + + for (auto p : env->parents) { + maybe_mark(p); + } + + // Lisp_Object* it = env->values[0]; + // for (int i = 0; i < env->next_index; it = env->values[++i]) { + // maybe_mark(it); + // } + } + + proc garbage_collect() -> void { + profile_this(); + ++current_mark; + + for (auto it : protected_environments) maybe_mark(it); + for (auto it : Globals::Current_Execution::envi_stack) maybe_mark(it); + } + + proc gc_init_and_go() -> void { + current_mark = 0; + + while (1) { + garbage_collect(); + } + } +} diff --git a/src/globals.cpp b/src/globals.cpp index e511e18..bf1d1ff 100644 --- a/src/globals.cpp +++ b/src/globals.cpp @@ -1,38 +1,43 @@ -namespace Slime { -#define v_major 0 -#define v_minor 1 -#define STRINGIZE2(s) #s -#define STRINGIZE(s) STRINGIZE2(s) -#define VERSION_STRING "v" STRINGIZE(v_major) "." STRINGIZE(v_minor) " - built on " __DATE__ " " __TIME__ - const char* version_string = VERSION_STRING; - const int major_version = v_major; - const int minor_version = v_minor; -#undef v_major -#undef v_minor -#undef STRINGIZE2 -#undef STRINGIZE -#undef VERSION_STRING -} - -namespace Slime::Globals { - char* bin_path = nullptr; - Log_Level log_level = Log_Level::Debug; - bool debug_log = false; - Array_List load_path; - namespace Current_Execution { - Array_List cs; // call stack - Array_List pcs; // program counter stack - Array_List ams; // apply marker stack - Array_List> nass; // next action stack stack - Array_List> ats; // and then stack - Array_List mes; // macro expansion stack - Array_List envi_stack; - } - - Error* error = nullptr; -#ifdef _DONT_BREAK_ON_ERRORS - bool breaking_on_errors = false; -#else - bool breaking_on_errors = true; -#endif -} +namespace Slime { +#define v_major 0 +#define v_minor 1 +#define STRINGIZE2(s) #s +#define STRINGIZE(s) STRINGIZE2(s) +#define VERSION_STRING "v" STRINGIZE(v_major) "." STRINGIZE(v_minor) " - built on " __DATE__ " " __TIME__ + const char* version_string = VERSION_STRING; + const int major_version = v_major; + const int minor_version = v_minor; +#undef v_major +#undef v_minor +#undef STRINGIZE2 +#undef STRINGIZE +#undef VERSION_STRING +} + +namespace Slime::Globals { + char* bin_path = nullptr; + Log_Level log_level = Log_Level::Debug; + bool debug_log = false; + Array_List load_path; + + Hash_Map docs; + Hash_Map source_code_locations; + Hash_Map user_types; + + namespace Current_Execution { + Array_List cs; // call stack + Array_List pcs; // program counter stack + Array_List ams; // apply marker stack + Array_List> nass; // next action stack stack + Array_List> ats; // and then stack + Array_List mes; // macro expansion stack + Array_List envi_stack; + } + + Error* error = nullptr; +#ifdef _DONT_BREAK_ON_ERRORS + bool breaking_on_errors = false; +#else + bool breaking_on_errors = true; +#endif +} diff --git a/src/io.cpp b/src/io.cpp index 3cd90ff..80643d0 100644 --- a/src/io.cpp +++ b/src/io.cpp @@ -1,576 +1,580 @@ -namespace Slime { - proc string_equal(const char input[], const char check[]) -> bool { - if (input == check) return true; - - for(int i = 0; input[i] == check[i]; i++) { - if (input[i] == '\0') - return true; - } - - return false; - } - - proc string_equal(String str, const char check[]) -> bool { - return string_equal(Memory::get_c_str(str), check); - } - - proc string_equal(const char check[], String str) -> bool { - return string_equal(Memory::get_c_str(str), check); - } - - proc string_equal(String str1, String str2) -> bool { - return string_equal(Memory::get_c_str(str1), Memory::get_c_str(str2)); - } - - proc get_nibble(char c) -> char { - if (c >= 'A' && c <= 'F') - return (c - 'A') + 10; - else if (c >= 'a' && c <= 'f') - return (c - 'a') + 10; - return (c - '0'); - } - - proc escape_string(char* in) -> char* { - // TODO(Felix): add more escape sequences - int i = 0, count = 0; - while (in[i] != '\0') { - switch (in[i]) { - case '\\': - case '\n': - case '\t': - ++count; - default: break; - } - ++i; - } - - char* ret = (char*)malloc((i+count+1)*sizeof(char)); - - // copy in - i = 0; - int j = 0; - while (in[i] != '\0') { - switch (in[i]) { - case '\\': ret[j++] = '\\'; ret[j++] = '\\'; break; - case '\n': ret[j++] = '\\'; ret[j++] = 'n'; break; - case '\t': ret[j++] = '\\'; ret[j++] = 't'; break; - default: ret[j++] = in[i]; - } - ++i; - } - ret[j++] = '\0'; - return ret; - } - - proc unescape_string(char* in) -> int { - if (!in) return 0; - - char *out = in, *p = in; - const char *int_err = nullptr; - - while (*p && !int_err) { - if (*p != '\\') { - /* normal case */ - *out++ = *p++; - } else { - /* escape sequence */ - switch (*++p) { - case '0': *out++ = '\a'; ++p; break; - case 'a': *out++ = '\a'; ++p; break; - case 'b': *out++ = '\b'; ++p; break; - case 'f': *out++ = '\f'; ++p; break; - case 'n': *out++ = '\n'; ++p; break; - case 'r': *out++ = '\r'; ++p; break; - case 't': *out++ = '\t'; ++p; break; - case 'v': *out++ = '\v'; ++p; break; - case '"': - case '\'': - case '\\': - *out++ = *p++; - case '?': - break; - case 'x': - case 'X': - if (!isxdigit(p[1]) || !isxdigit(p[2])) { - create_parsing_error( - "The string '%s' at %s:%d:%d could not be unescaped. " - "(Invalid character on hexadecimal escape at char %d)", - in, Parser::parser_file, Parser::parser_line, Parser::parser_col, - (p+1)-in); - } else { - *out++ = (char)(get_nibble(p[1]) * 0x10 + get_nibble(p[2])); - p += 3; - } - break; - default: - create_parsing_error( - "The string '%s' at %s:%d:%d could not be unescaped. " - "(Unexpected '\\' with no escape sequence at char %d)", - in, Parser::parser_file, Parser::parser_line, Parser::parser_col, - (p+1)-in); - } - } - } - - /* Set the end of string. */ - *out = '\0'; - return (int)(out - in); - } - - proc read_entire_file(char* filename) -> char* { - profile_with_comment(filename); - char *fileContent = nullptr; - FILE *fp = fopen(filename, "r"); - if (fp) { - /* Go to the end of the file. */ - if (fseek(fp, 0L, SEEK_END) == 0) { - /* Get the size of the file. */ - long bufsize = ftell(fp) + 1; - if (bufsize == 0) { - fputs("Empty file", stderr); - goto closeFile; - } - - /* Go back to the start of the file. */ - if (fseek(fp, 0L, SEEK_SET) != 0) { - fputs("Error reading file", stderr); - goto closeFile; - } - - /* Allocate our buffer to that size. */ - fileContent = (char*)calloc(bufsize, sizeof(char)); - - /* Read the entire file into memory. */ - size_t newLen = fread(fileContent, sizeof(char), bufsize, fp); - - fileContent[newLen] = '\0'; - if (ferror(fp) != 0) { - fputs("Error reading file", stderr); - } - } - closeFile: - fclose(fp); - } - - return fileContent; - /* Don't forget to call free() later! */ - } - - proc read_expression() -> char* { - char* line = (char*)malloc(100); - - if(line == nullptr) - return nullptr; - - char* linep = line; - size_t lenmax = 100, len = lenmax; - int c; - - int nesting = 0; - - while (true) { - c = fgetc(stdin); - if(c == EOF) - break; - - if(--len == 0) { - len = lenmax; - char * linen = (char*)realloc(linep, lenmax *= 2); - - if(linen == nullptr) { - free(linep); - return nullptr; - } - line = linen + (line - linep); - linep = linen; - } - - *line = (char)c; - if(*line == '(') - ++nesting; - else if(*line == ')') - --nesting; - else if(*line == '\n') - if (nesting == 0) - break; - line++; - } - (*line)--; // we dont want the \n actually - *line = '\0'; - - return linep; - } - - proc read_line() -> char* { - char* line = (char*)malloc(100), * linep = line; - size_t lenmax = 100, len = lenmax; - int c; - - int nesting = 0; - - if(line == nullptr) - return nullptr; - - for(;;) { - c = fgetc(stdin); - if(c == EOF) - break; - - if(--len == 0) { - len = lenmax; - char* linen = (char*)realloc(linep, lenmax *= 2); - - if(linen == nullptr) { - free(linep); - return nullptr; - } - line = linen + (line - linep); - linep = linen; - } - - *line = (char)c; - if(*line == '(') - ++nesting; - else if(*line == ')') - --nesting; - else if(*line == '\n') - if (nesting == 0) - break; - line++; - } - (*line)--; // we dont want the \n actually - *line = '\0'; - - return linep; - } - - proc log_message(Log_Level type, const char* message) -> void { - if (type > Globals::log_level) - return; - - const char* prefix; - switch (type) { - case Log_Level::Critical: prefix = "CRITICAL"; break; - case Log_Level::Warning: prefix = "WARNING"; break; - case Log_Level::Info: prefix = "INFO"; break; - case Log_Level::Debug: prefix = "DEBUG"; break; - default: return; - } - printf("%s: %s\n",prefix, message); - } - - char* wchar_to_char(const wchar_t* pwchar) { - // get the number of characters in the string. - int currentCharIndex = 0; - char currentChar = (char)pwchar[currentCharIndex]; - - while (currentChar != '\0') - { - currentCharIndex++; - currentChar = (char)pwchar[currentCharIndex]; - } - - const int charCount = currentCharIndex + 1; - - // allocate a new block of memory size char (1 byte) instead of wide char (2 bytes) - char* filePathC = (char*)malloc(sizeof(char) * charCount); - - for (int i = 0; i < charCount; i++) - { - // convert to char (1 byte) - char character = (char)pwchar[i]; - - *filePathC = character; - - filePathC += sizeof(char); - - } - filePathC += '\0'; - - filePathC -= (sizeof(char) * charCount); - - return filePathC; - } - - const wchar_t* char_to_wchar(const char* c) { - const size_t cSize = strlen(c)+1; - wchar_t* wc = new wchar_t[cSize]; - mbstowcs (wc, c, cSize); - - return wc; - } - - proc string_buider_to_string(Array_List string_builder) -> char* { - size_t len = 1; - int idx = 0; - for (auto str : string_builder) { - len += strlen(str); - } - - char* res = (char*)(malloc(sizeof(char) * len)); - res[0] = '\0'; - - for (auto str : string_builder) { - strcat(res, str); - } - - return res; - } - - proc lisp_object_to_string(Lisp_Object* node, bool print_repr) -> char* { - char* temp; - Array_List string_builder; - string_builder.alloc(); - defer { - string_builder.dealloc(); - }; - - switch (Memory::get_type(node)) { - case (Lisp_Object_Type::Nil): return strdup("()"); - case (Lisp_Object_Type::T): return strdup("t"); - case (Lisp_Object_Type::Continuation): return strdup("[continuation]"); - case (Lisp_Object_Type::Pointer): return strdup("[pointer]"); - case (Lisp_Object_Type::Number): { - if (abs(node->value.number - (int)node->value.number) < 0.000001f) - asprintf(&temp, "%d", (int)node->value.number); - else - asprintf(&temp, "%f", node->value.number); - return temp; - } - case (Lisp_Object_Type::Keyword): { - asprintf(&temp, ":%s", Memory::get_c_str(node->value.symbol)); - return temp; - } - case (Lisp_Object_Type::Symbol): { - asprintf(&temp, "%s", Memory::get_c_str(node->value.symbol)); - return temp; - } - case (Lisp_Object_Type::HashMap): { - for_hash_map (*(node->value.hashMap)) { - char* k = lisp_object_to_string(key, true); - char* v = lisp_object_to_string((Lisp_Object*)value, true); - asprintf(&temp, " %s -> %s\n", k, v); - string_builder.append(temp); - free(v); - free(k); - } - - temp = string_buider_to_string(string_builder); - // free all asprintfs - for (auto str : string_builder) { - free(str); - } - return temp; - } - case (Lisp_Object_Type::String): { - if (print_repr) { - char* escaped = escape_string(Memory::get_c_str(node->value.string)); - asprintf(&temp, "\"%s\"", escaped); - free(escaped); - return temp; - } else - return strdup(Memory::get_c_str(node->value.string)); - } break; - case (Lisp_Object_Type::Vector): { - - string_builder.append(strdup("[")); - if (node->value.vector.length > 0) - string_builder.append(lisp_object_to_string(node->value.vector.data, print_repr)); - for (int i = 1; i < node->value.vector.length; ++i) { - string_builder.append(strdup(" ")); - string_builder.append(lisp_object_to_string(node->value.vector.data+i, print_repr)); - } - string_builder.append(strdup("]")); - temp = string_buider_to_string(string_builder); - for (auto str : string_builder) { - free(str); - } - return temp; - } break; - case (Lisp_Object_Type::Function): { - if (node->userType) { - asprintf(&temp, "[%s]", Memory::get_c_str(node->userType->value.symbol)); - return temp; - } - if (node->value.function->is_c) { - // NOTE(Felix): try to find the symbol it is bound to - // in global env - Lisp_Object* name = (Lisp_Object*)(get_root_environment()->hm.search_key_to_object(node)); - if (name) { - switch (node->value.function->type.c_function_type) { - case C_Function_Type::cFunction: asprintf(&temp, "[c-function %s]",name->value.symbol.data); break; - case C_Function_Type::cSpecial: asprintf(&temp, "[c-special %s]", name->value.symbol.data); break; - case C_Function_Type::cMacro: asprintf(&temp, "[c-macro %s]", name->value.symbol.data); break; - default: return strdup("[c-??]"); - } - } else { - switch (node->value.function->type.c_function_type) { - case C_Function_Type::cFunction: asprintf(&temp, "[c-function]"); break; - case C_Function_Type::cSpecial: asprintf(&temp, "[c-special]"); break; - case C_Function_Type::cMacro: asprintf(&temp, "[c-macro]"); break; - default: return strdup("[c-??]"); - } - } - return temp; - } else { - switch (node->value.function->type.lisp_function_type) { - case Lisp_Function_Type::Lambda: return strdup("[lambda]"); - case Lisp_Function_Type::Macro: return strdup("[macro]"); - default: return strdup("[??]"); - } - } - } break; - case (Lisp_Object_Type::Pair): { - // TODO - Lisp_Object* head = node; - - defer { - for (auto str : string_builder) { - free(str); - } - }; - // first check if it is a quotation form, in that case we want - // to print it prettier - if (Memory::get_type(head->value.pair.first) == Lisp_Object_Type::Symbol) { - String identifier = head->value.pair.first->value.symbol; - - - auto symbol = head->value.pair.first; - auto quote_sym = Memory::get_symbol("quote"); - auto unquote_sym = Memory::get_symbol("unquote"); - auto quasiquote_sym = Memory::get_symbol("quasiquote"); - auto unquote_splicing_sym = Memory::get_symbol("unquote-splicing"); - if (symbol == quote_sym || symbol == unquote_sym || symbol == unquote_splicing_sym) - { - if (symbol == quote_sym) - string_builder.append(strdup("\'")); - else if (symbol == unquote_sym) - string_builder.append(strdup(",")); - else if (symbol == unquote_splicing_sym) - string_builder.append(strdup(",@")); - - assert_type(head->value.pair.rest, Lisp_Object_Type::Pair); - assert("The list must end here.", - head->value.pair.rest->value.pair.rest == Memory::nil); - - string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr)); - return string_buider_to_string(string_builder); - } else if (symbol == quasiquote_sym) { - string_builder.append(strdup("`")); - assert_type(head->value.pair.rest, Lisp_Object_Type::Pair); - string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr)); - return string_buider_to_string(string_builder); - - } - } - - string_builder.append(strdup("(")); - - // NOTE(Felix): We could do a while true here, however in case - // we want to print a broken list (for logging the error) we - // should do more checks. - while (head) { - string_builder.append(lisp_object_to_string(head->value.pair.first, print_repr)); - head = head->value.pair.rest; - if (!head) break; - if (Memory::get_type(head) != Lisp_Object_Type::Pair) break; - string_builder.append(strdup(" ")); - } - - if (head && Memory::get_type(head) != Lisp_Object_Type::Nil) { - string_builder.append(strdup(" . ")); - string_builder.append(lisp_object_to_string(head, print_repr)); - } - - string_builder.append(strdup(")")); - - return string_buider_to_string(string_builder); - } - default: - create_generic_error("A Lisp_Object of type-id %d cannot be converted to a string", - (int)(Memory::get_type(node))); - return nullptr; - } - } - - proc print(Lisp_Object* node, bool print_repr, FILE* file) -> void { - char* string = nullptr; - defer { - free(string); - }; - string = lisp_object_to_string(node, print_repr); - fputs(string, file); - } - - proc print_single_call(Lisp_Object* obj) -> void { - printf(console_cyan); - print(obj, true); - printf(console_normal); - printf("\n at "); - if (obj->sourceCodeLocation) { - printf("%s (line %d, position %d)", - Memory::get_c_str( - obj->sourceCodeLocation->file), - obj->sourceCodeLocation->line, - obj->sourceCodeLocation->column); - } else { - fputs("no source code location avaliable", stdout); - } - } - - proc print_current_execution() -> void { - using Globals::Current_Execution::cs; - using Globals::Current_Execution::pcs; - using Globals::Current_Execution::nass; - using Globals::Current_Execution::ams; - printf("cs:\n "); - for (int i = 0; i < cs.next_index; ++i) { - char* t = lisp_object_to_string(cs.data[i], true); - printf(" %d: %s\n ", i, t); - defer { - free(t); - }; - } - printf("\npcs:\n "); - for (auto lo : pcs) { - print(lo, true); - printf("\n "); - } - printf("\nnnas:\n "); - for (auto nas: nass) { - printf("nas:\n "); - for (auto na : nas) { - printf(" - %s\n ", [&] - { - switch(na) { - case NasAction::Macro_Write_Back: return "Macro_Write_Back"; - case NasAction::And_Then_Action: return "And_Then_Action"; - case NasAction::Pop_Environment: return "Pop_Environment"; - case NasAction::Define_Var: return "Define_Var"; - case NasAction::Eval: return "Eval"; - case NasAction::Step: return "Step"; - case NasAction::TM: return "TM"; - case NasAction::Pop: return "Pop"; - case NasAction::If: return "If"; - } - return "??"; - }()); - } - } - printf("\nams:\n "); - for (auto am : ams) { - printf("%d\n ", am); - } - } - - proc log_error() -> void { - fputs("\n", stdout); - fputs(console_red, stdout); - fputs(Memory::get_c_str(Globals::error->message), stdout); - puts(console_normal); - - fputs(" in: ", stdout); - print_current_execution(); - puts(console_normal); - } -} +namespace Slime { + proc string_equal(const char input[], const char check[]) -> bool { + if (input == check) return true; + + for(int i = 0; input[i] == check[i]; i++) { + if (input[i] == '\0') + return true; + } + + return false; + } + + proc string_equal(String str, const char check[]) -> bool { + return string_equal(Memory::get_c_str(str), check); + } + + proc string_equal(const char check[], String str) -> bool { + return string_equal(Memory::get_c_str(str), check); + } + + proc string_equal(String str1, String str2) -> bool { + return string_equal(Memory::get_c_str(str1), Memory::get_c_str(str2)); + } + + proc get_nibble(char c) -> char { + if (c >= 'A' && c <= 'F') + return (c - 'A') + 10; + else if (c >= 'a' && c <= 'f') + return (c - 'a') + 10; + return (c - '0'); + } + + proc escape_string(char* in) -> char* { + // TODO(Felix): add more escape sequences + int i = 0, count = 0; + while (in[i] != '\0') { + switch (in[i]) { + case '\\': + case '\n': + case '\t': + ++count; + default: break; + } + ++i; + } + + char* ret = (char*)malloc((i+count+1)*sizeof(char)); + + // copy in + i = 0; + int j = 0; + while (in[i] != '\0') { + switch (in[i]) { + case '\\': ret[j++] = '\\'; ret[j++] = '\\'; break; + case '\n': ret[j++] = '\\'; ret[j++] = 'n'; break; + case '\t': ret[j++] = '\\'; ret[j++] = 't'; break; + default: ret[j++] = in[i]; + } + ++i; + } + ret[j++] = '\0'; + return ret; + } + + proc unescape_string(char* in) -> int { + if (!in) return 0; + + char *out = in, *p = in; + const char *int_err = nullptr; + + while (*p && !int_err) { + if (*p != '\\') { + /* normal case */ + *out++ = *p++; + } else { + /* escape sequence */ + switch (*++p) { + case '0': *out++ = '\a'; ++p; break; + case 'a': *out++ = '\a'; ++p; break; + case 'b': *out++ = '\b'; ++p; break; + case 'f': *out++ = '\f'; ++p; break; + case 'n': *out++ = '\n'; ++p; break; + case 'r': *out++ = '\r'; ++p; break; + case 't': *out++ = '\t'; ++p; break; + case 'v': *out++ = '\v'; ++p; break; + case '"': + case '\'': + case '\\': + *out++ = *p++; + case '?': + break; + case 'x': + case 'X': + if (!isxdigit(p[1]) || !isxdigit(p[2])) { + create_parsing_error( + "The string '%s' at %s:%d:%d could not be unescaped. " + "(Invalid character on hexadecimal escape at char %d)", + in, Parser::parser_file, Parser::parser_line, Parser::parser_col, + (p+1)-in); + } else { + *out++ = (char)(get_nibble(p[1]) * 0x10 + get_nibble(p[2])); + p += 3; + } + break; + default: + create_parsing_error( + "The string '%s' at %s:%d:%d could not be unescaped. " + "(Unexpected '\\' with no escape sequence at char %d)", + in, Parser::parser_file, Parser::parser_line, Parser::parser_col, + (p+1)-in); + } + } + } + + /* Set the end of string. */ + *out = '\0'; + return (int)(out - in); + } + + proc read_entire_file(char* filename) -> char* { + profile_with_comment(filename); + char *fileContent = nullptr; + FILE *fp = fopen(filename, "r"); + if (fp) { + /* Go to the end of the file. */ + if (fseek(fp, 0L, SEEK_END) == 0) { + /* Get the size of the file. */ + long bufsize = ftell(fp) + 1; + if (bufsize == 0) { + fputs("Empty file", stderr); + goto closeFile; + } + + /* Go back to the start of the file. */ + if (fseek(fp, 0L, SEEK_SET) != 0) { + fputs("Error reading file", stderr); + goto closeFile; + } + + /* Allocate our buffer to that size. */ + fileContent = (char*)calloc(bufsize, sizeof(char)); + + /* Read the entire file into memory. */ + size_t newLen = fread(fileContent, sizeof(char), bufsize, fp); + + fileContent[newLen] = '\0'; + if (ferror(fp) != 0) { + fputs("Error reading file", stderr); + } + } + closeFile: + fclose(fp); + } + + return fileContent; + /* Don't forget to call free() later! */ + } + + proc read_expression() -> char* { + char* line = (char*)malloc(100); + + if(line == nullptr) + return nullptr; + + char* linep = line; + size_t lenmax = 100, len = lenmax; + int c; + + int nesting = 0; + + while (true) { + c = fgetc(stdin); + if(c == EOF) + break; + + if(--len == 0) { + len = lenmax; + char * linen = (char*)realloc(linep, lenmax *= 2); + + if(linen == nullptr) { + free(linep); + return nullptr; + } + line = linen + (line - linep); + linep = linen; + } + + *line = (char)c; + if(*line == '(') + ++nesting; + else if(*line == ')') + --nesting; + else if(*line == '\n') + if (nesting == 0) + break; + line++; + } + (*line)--; // we dont want the \n actually + *line = '\0'; + + return linep; + } + + proc read_line() -> char* { + char* line = (char*)malloc(100), * linep = line; + size_t lenmax = 100, len = lenmax; + int c; + + int nesting = 0; + + if(line == nullptr) + return nullptr; + + for(;;) { + c = fgetc(stdin); + if(c == EOF) + break; + + if(--len == 0) { + len = lenmax; + char* linen = (char*)realloc(linep, lenmax *= 2); + + if(linen == nullptr) { + free(linep); + return nullptr; + } + line = linen + (line - linep); + linep = linen; + } + + *line = (char)c; + if(*line == '(') + ++nesting; + else if(*line == ')') + --nesting; + else if(*line == '\n') + if (nesting == 0) + break; + line++; + } + (*line)--; // we dont want the \n actually + *line = '\0'; + + return linep; + } + + proc log_message(Log_Level type, const char* message) -> void { + if (type > Globals::log_level) + return; + + const char* prefix; + switch (type) { + case Log_Level::Critical: prefix = "CRITICAL"; break; + case Log_Level::Warning: prefix = "WARNING"; break; + case Log_Level::Info: prefix = "INFO"; break; + case Log_Level::Debug: prefix = "DEBUG"; break; + default: return; + } + printf("%s: %s\n",prefix, message); + } + + char* wchar_to_char(const wchar_t* pwchar) { + // get the number of characters in the string. + int currentCharIndex = 0; + char currentChar = (char)pwchar[currentCharIndex]; + + while (currentChar != '\0') + { + currentCharIndex++; + currentChar = (char)pwchar[currentCharIndex]; + } + + const int charCount = currentCharIndex + 1; + + // allocate a new block of memory size char (1 byte) instead of wide char (2 bytes) + char* filePathC = (char*)malloc(sizeof(char) * charCount); + + for (int i = 0; i < charCount; i++) + { + // convert to char (1 byte) + char character = (char)pwchar[i]; + + *filePathC = character; + + filePathC += sizeof(char); + + } + filePathC += '\0'; + + filePathC -= (sizeof(char) * charCount); + + return filePathC; + } + + const wchar_t* char_to_wchar(const char* c) { + const size_t cSize = strlen(c)+1; + wchar_t* wc = new wchar_t[cSize]; + mbstowcs (wc, c, cSize); + + return wc; + } + + proc string_buider_to_string(Array_List string_builder) -> char* { + size_t len = 1; + int idx = 0; + for (auto str : string_builder) { + len += strlen(str); + } + + char* res = (char*)(malloc(sizeof(char) * len)); + res[0] = '\0'; + + for (auto str : string_builder) { + strcat(res, str); + } + + return res; + } + + proc lisp_object_to_string(Lisp_Object* node, bool print_repr) -> char* { + char* temp; + Array_List string_builder; + string_builder.alloc(); + defer { + string_builder.dealloc(); + }; + + switch (node->type) { + case (Lisp_Object_Type::Nil): return strdup("()"); + case (Lisp_Object_Type::T): return strdup("t"); + case (Lisp_Object_Type::Continuation): return strdup("[continuation]"); + case (Lisp_Object_Type::Pointer): return strdup("[pointer]"); + case (Lisp_Object_Type::Number): { + if (abs(node->value.number - (int)node->value.number) < 0.000001f) + asprintf(&temp, "%d", (int)node->value.number); + else + asprintf(&temp, "%f", node->value.number); + return temp; + } + case (Lisp_Object_Type::Keyword): { + asprintf(&temp, ":%s", Memory::get_c_str(node->value.symbol)); + return temp; + } + case (Lisp_Object_Type::Symbol): { + asprintf(&temp, "%s", Memory::get_c_str(node->value.symbol)); + return temp; + } + case (Lisp_Object_Type::HashMap): { + for_hash_map (*(node->value.hashMap)) { + char* k = lisp_object_to_string(key, true); + char* v = lisp_object_to_string((Lisp_Object*)value, true); + asprintf(&temp, " %s -> %s\n", k, v); + string_builder.append(temp); + free(v); + free(k); + } + + temp = string_buider_to_string(string_builder); + // free all asprintfs + for (auto str : string_builder) { + free(str); + } + return temp; + } + case (Lisp_Object_Type::String): { + if (print_repr) { + char* escaped = escape_string(Memory::get_c_str(node->value.string)); + asprintf(&temp, "\"%s\"", escaped); + free(escaped); + return temp; + } else + return strdup(Memory::get_c_str(node->value.string)); + } break; + case (Lisp_Object_Type::Vector): { + + string_builder.append(strdup("[")); + if (node->value.vector.length > 0) + string_builder.append(lisp_object_to_string(node->value.vector.data, print_repr)); + for (int i = 1; i < node->value.vector.length; ++i) { + string_builder.append(strdup(" ")); + string_builder.append(lisp_object_to_string(node->value.vector.data+i, print_repr)); + } + string_builder.append(strdup("]")); + temp = string_buider_to_string(string_builder); + for (auto str : string_builder) { + free(str); + } + return temp; + } break; + case (Lisp_Object_Type::Function): { + // TODO(Felix): Enable again when we have user types again: + // if (node->userType) { + // asprintf(&temp, "[%s]", Memory::get_c_str(node->userType->value.symbol)); + // return temp; + // } + if (node->value.function->is_c) { + // NOTE(Felix): try to find the symbol it is bound to + // in global env + Lisp_Object* name = (Lisp_Object*)(get_root_environment()->hm.search_key_to_object(node)); + if (name) { + switch (node->value.function->type.c_function_type) { + case C_Function_Type::cFunction: asprintf(&temp, "[c-function %s]",name->value.symbol.data); break; + case C_Function_Type::cSpecial: asprintf(&temp, "[c-special %s]", name->value.symbol.data); break; + case C_Function_Type::cMacro: asprintf(&temp, "[c-macro %s]", name->value.symbol.data); break; + default: return strdup("[c-??]"); + } + } else { + switch (node->value.function->type.c_function_type) { + case C_Function_Type::cFunction: asprintf(&temp, "[c-function]"); break; + case C_Function_Type::cSpecial: asprintf(&temp, "[c-special]"); break; + case C_Function_Type::cMacro: asprintf(&temp, "[c-macro]"); break; + default: return strdup("[c-??]"); + } + } + return temp; + } else { + switch (node->value.function->type.lisp_function_type) { + case Lisp_Function_Type::Lambda: return strdup("[lambda]"); + case Lisp_Function_Type::Macro: return strdup("[macro]"); + default: return strdup("[??]"); + } + } + } break; + case (Lisp_Object_Type::Pair): { + // TODO + Lisp_Object* head = node; + + defer { + for (auto str : string_builder) { + free(str); + } + }; + // first check if it is a quotation form, in that case we want + // to print it prettier + if (head->value.pair.first->type == Lisp_Object_Type::Symbol) { + String identifier = head->value.pair.first->value.symbol; + + + auto symbol = head->value.pair.first; + auto quote_sym = Memory::get_symbol("quote"); + auto unquote_sym = Memory::get_symbol("unquote"); + auto quasiquote_sym = Memory::get_symbol("quasiquote"); + auto unquote_splicing_sym = Memory::get_symbol("unquote-splicing"); + if (symbol == quote_sym || symbol == unquote_sym || symbol == unquote_splicing_sym) + { + if (symbol == quote_sym) + string_builder.append(strdup("\'")); + else if (symbol == unquote_sym) + string_builder.append(strdup(",")); + else if (symbol == unquote_splicing_sym) + string_builder.append(strdup(",@")); + + assert_type(head->value.pair.rest, Lisp_Object_Type::Pair); + assert("The list must end here.", + head->value.pair.rest->value.pair.rest == Memory::nil); + + string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr)); + return string_buider_to_string(string_builder); + } else if (symbol == quasiquote_sym) { + string_builder.append(strdup("`")); + assert_type(head->value.pair.rest, Lisp_Object_Type::Pair); + string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr)); + return string_buider_to_string(string_builder); + + } + } + + string_builder.append(strdup("(")); + + // NOTE(Felix): We could do a while true here, however in case + // we want to print a broken list (for logging the error) we + // should do more checks. + while (head) { + string_builder.append(lisp_object_to_string(head->value.pair.first, print_repr)); + head = head->value.pair.rest; + if (!head) break; + if (head->type != Lisp_Object_Type::Pair) break; + string_builder.append(strdup(" ")); + } + + if (head && head != Memory::nil) { + string_builder.append(strdup(" . ")); + string_builder.append(lisp_object_to_string(head, print_repr)); + } + + string_builder.append(strdup(")")); + + return string_buider_to_string(string_builder); + } + default: + create_generic_error("A Lisp_Object of type-id %d cannot be converted to a string", + (int)(node->type)); + return nullptr; + } + } + + proc print(Lisp_Object* node, bool print_repr, FILE* file) -> void { + char* string = nullptr; + defer { + free(string); + }; + string = lisp_object_to_string(node, print_repr); + fputs(string, file); + } + + proc print_single_call(Lisp_Object* obj) -> void { + printf(console_cyan); + print(obj, true); + printf(console_normal); + printf("\n at "); + // TODO(Felix): Enable again when we have a source code + // location again + + // if (obj->sourceCodeLocation) { + // printf("%s (line %d, position %d)", + // Memory::get_c_str( + // obj->sourceCodeLocation->file), + // obj->sourceCodeLocation->line, + // obj->sourceCodeLocation->column); + // } else { + fputs("no source code location avaliable", stdout); + // } + } + + proc print_current_execution() -> void { + using Globals::Current_Execution::cs; + using Globals::Current_Execution::pcs; + using Globals::Current_Execution::nass; + using Globals::Current_Execution::ams; + printf("cs:\n "); + for (int i = 0; i < cs.next_index; ++i) { + char* t = lisp_object_to_string(cs.data[i], true); + printf(" %d: %s\n ", i, t); + defer { + free(t); + }; + } + printf("\npcs:\n "); + for (auto lo : pcs) { + print(lo, true); + printf("\n "); + } + printf("\nnnas:\n "); + for (auto nas: nass) { + printf("nas:\n "); + for (auto na : nas) { + printf(" - %s\n ", [&] + { + switch(na) { + case NasAction::Macro_Write_Back: return "Macro_Write_Back"; + case NasAction::And_Then_Action: return "And_Then_Action"; + case NasAction::Pop_Environment: return "Pop_Environment"; + case NasAction::Define_Var: return "Define_Var"; + case NasAction::Eval: return "Eval"; + case NasAction::Step: return "Step"; + case NasAction::TM: return "TM"; + case NasAction::Pop: return "Pop"; + case NasAction::If: return "If"; + } + return "??"; + }()); + } + } + printf("\nams:\n "); + for (auto am : ams) { + printf("%d\n ", am); + } + } + + proc log_error() -> void { + fputs("\n", stdout); + fputs(console_red, stdout); + fputs(Memory::get_c_str(Globals::error->message), stdout); + puts(console_normal); + + fputs(" in: ", stdout); + print_current_execution(); + puts(console_normal); + } +} diff --git a/src/libslime.cpp b/src/libslime.cpp index 3bd2d8d..ed1f30f 100644 --- a/src/libslime.cpp +++ b/src/libslime.cpp @@ -1,121 +1,121 @@ -#define _CRT_SECURE_NO_WARNINGS -#define _CRT_SECURE_NO_DEPRECATE - -#include - -#include -#include -#include -#include -#include -#include -#include -#include - -#ifdef _MSC_VER -# include -# include -#else -# include -# include -#endif - -/* - Forward declare the hash functions for the hashmap (needed at least - for clang++) -*/ -namespace Slime {struct Lisp_Object;} -bool hm_objects_match(char* a, char* b); -bool hm_objects_match(void* a, void* b); -bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b); -unsigned int hm_hash(char* str); -unsigned int hm_hash(void* ptr); -unsigned int hm_hash(Slime::Lisp_Object* obj); -#include "ftb/hashmap.hpp" -#include "ftb/types.hpp" -#include "ftb/arraylist.hpp" -#include "ftb/bucket_allocator.hpp" -#include "ftb/macros.hpp" -#include "ftb/profiler.hpp" -#include "ftb/hooks.hpp" - -# include "defines.cpp" -# include "assert.hpp" -# include "define_macros.hpp" -# include "platform.cpp" -# include "structs.cpp" -# include "forward_decls.cpp" - - -inline bool hm_objects_match(char* a, char* b) { - return strcmp(a, b) == 0; -} - -inline bool hm_objects_match(void* a, void* b) { - return a == b; -} - -inline bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b) { - return Slime::lisp_object_equal(a, b); -} - -unsigned int hm_hash(char* str) { - unsigned int value = str[0] << 7; - int i = 0; - while (str[i]) { - value = (10000003 * value) ^ str[i++]; - } - return value ^ i; -} - -unsigned int hm_hash(void* ptr) { - return ((unsigned long long)ptr * 2654435761) % 4294967296; -} - -unsigned int hm_hash(Slime::Lisp_Object* obj) { - using namespace Slime; - switch (Memory::get_type(obj)) { - // hash from adress: if two objects of these types have - // different addresses, they are different - case Lisp_Object_Type::Function: - case Lisp_Object_Type::Symbol: - case Lisp_Object_Type::Keyword: - case Lisp_Object_Type::Continuation: - case Lisp_Object_Type::Nil: - case Lisp_Object_Type::T: - return hm_hash((void*) obj); - // hash from contents: even if objects are themselved - // different, they cauld be equivalent: - case Lisp_Object_Type::Pointer: return hm_hash((void*) obj->value.pointer); - case Lisp_Object_Type::Number: return hm_hash((void*) (unsigned long long)obj->value.number); // HACK(Felix): yes - case Lisp_Object_Type::String: return hm_hash((char*) obj->value.string.data); - case Lisp_Object_Type::Pair: { - u32 hash = 1; - for_lisp_list (obj) { - hash <<= 1; - hash += hm_hash(it); - } - return hash; - } break; - case Lisp_Object_Type::Vector: - case Lisp_Object_Type::HashMap: - default: - create_not_yet_implemented_error(); - return 0; - } -} - -# include "globals.cpp" -# include "memory.cpp" -# include "gc.cpp" -# include "lisp_object.cpp" -# include "error.cpp" -# include "io.cpp" -# include "env.cpp" -# include "parse.cpp" -# include "eval.cpp" -# include "visualization.cpp" -# include "docgeneration.cpp" -# include "built_ins.cpp" -# include "testing.cpp" -// # include "undefines.cpp" +#define _CRT_SECURE_NO_WARNINGS +#define _CRT_SECURE_NO_DEPRECATE + +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef _MSC_VER +# include +# include +#else +# include +# include +#endif + +/* + Forward declare the hash functions for the hashmap (needed at least + for clang++) +*/ +namespace Slime {struct Lisp_Object;} +bool hm_objects_match(char* a, char* b); +bool hm_objects_match(void* a, void* b); +bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b); +unsigned int hm_hash(char* str); +unsigned int hm_hash(void* ptr); +unsigned int hm_hash(Slime::Lisp_Object* obj); +#include "ftb/hashmap.hpp" +#include "ftb/types.hpp" +#include "ftb/arraylist.hpp" +#include "ftb/bucket_allocator.hpp" +#include "ftb/macros.hpp" +#include "ftb/profiler.hpp" +#include "ftb/hooks.hpp" + +# include "defines.cpp" +# include "assert.hpp" +# include "define_macros.hpp" +# include "platform.cpp" +# include "structs.cpp" +# include "forward_decls.cpp" + + +inline bool hm_objects_match(char* a, char* b) { + return strcmp(a, b) == 0; +} + +inline bool hm_objects_match(void* a, void* b) { + return a == b; +} + +inline bool hm_objects_match(Slime::Lisp_Object* a, Slime::Lisp_Object* b) { + return Slime::lisp_object_equal(a, b); +} + +unsigned int hm_hash(char* str) { + unsigned int value = str[0] << 7; + int i = 0; + while (str[i]) { + value = (10000003 * value) ^ str[i++]; + } + return value ^ i; +} + +unsigned int hm_hash(void* ptr) { + return ((unsigned long long)ptr * 2654435761) % 4294967296; +} + +unsigned int hm_hash(Slime::Lisp_Object* obj) { + using namespace Slime; + switch (obj->type) { + // hash from adress: if two objects of these types have + // different addresses, they are different + case Lisp_Object_Type::Function: + case Lisp_Object_Type::Symbol: + case Lisp_Object_Type::Keyword: + case Lisp_Object_Type::Continuation: + case Lisp_Object_Type::Nil: + case Lisp_Object_Type::T: + return hm_hash((void*) obj); + // hash from contents: even if objects are themselved + // different, they cauld be equivalent: + case Lisp_Object_Type::Pointer: return hm_hash((void*) obj->value.pointer); + case Lisp_Object_Type::Number: return hm_hash((void*) (unsigned long long)obj->value.number); // HACK(Felix): yes + case Lisp_Object_Type::String: return hm_hash((char*) obj->value.string.data); + case Lisp_Object_Type::Pair: { + u32 hash = 1; + for_lisp_list (obj) { + hash <<= 1; + hash += hm_hash(it); + } + return hash; + } break; + case Lisp_Object_Type::Vector: + case Lisp_Object_Type::HashMap: + default: + create_not_yet_implemented_error(); + return 0; + } +} + +# include "globals.cpp" +# include "memory.cpp" +# include "gc.cpp" +# include "lisp_object.cpp" +# include "error.cpp" +# include "io.cpp" +# include "env.cpp" +# include "parse.cpp" +# include "eval.cpp" +# include "visualization.cpp" +# include "docgeneration.cpp" +# include "built_ins.cpp" +# include "testing.cpp" +// # include "undefines.cpp" diff --git a/src/lisp_object.cpp b/src/lisp_object.cpp index 3164dbd..7932bdc 100644 --- a/src/lisp_object.cpp +++ b/src/lisp_object.cpp @@ -1,31 +1,33 @@ -namespace Slime { - proc create_source_code_location(String file, int line, int col) -> Source_Code_Location* { - if (!file.data) - return nullptr; - - Source_Code_Location* ret = (Source_Code_Location*)malloc(sizeof(Source_Code_Location)); - ret->file = file; - ret->line = line; - ret->column = col; - return ret; - } - - proc lisp_object_type_to_string(Lisp_Object_Type type) -> const char* { - switch (type) { - case(Lisp_Object_Type::Nil): return "nil"; - case(Lisp_Object_Type::T): return "t"; - case(Lisp_Object_Type::Number): return "number"; - case(Lisp_Object_Type::String): return "string"; - case(Lisp_Object_Type::Symbol): return "symbol"; - case(Lisp_Object_Type::Keyword): return "keyword"; - case(Lisp_Object_Type::Function): return "function"; - case(Lisp_Object_Type::Continuation): return "continuation"; - case(Lisp_Object_Type::Pair): return "pair"; - case(Lisp_Object_Type::Vector): return "vector"; - case(Lisp_Object_Type::Pointer): return "pointer"; - case(Lisp_Object_Type::HashMap): return "hashmap"; - } - return "unknown"; - } - -} +namespace Slime { + proc create_source_code_location(String file, int line, int col) -> Source_Code_Location* { + if (!file.data) + return nullptr; + + Source_Code_Location* ret = (Source_Code_Location*)malloc(sizeof(Source_Code_Location)); + ret->file = file; + ret->line = line; + ret->column = col; + return ret; + } + + proc lisp_object_type_to_string(Lisp_Object_Type type) -> const char* { + switch (type) { + case(Lisp_Object_Type::Nil): return "nil"; + case(Lisp_Object_Type::T): return "t"; + case(Lisp_Object_Type::Number): return "number"; + case(Lisp_Object_Type::String): return "string"; + case(Lisp_Object_Type::Symbol): return "symbol"; + case(Lisp_Object_Type::Keyword): return "keyword"; + case(Lisp_Object_Type::Function): return "function"; + case(Lisp_Object_Type::Continuation): return "continuation"; + case(Lisp_Object_Type::Pair): return "pair"; + case(Lisp_Object_Type::Vector): return "vector"; + case(Lisp_Object_Type::Pointer): return "pointer"; + case(Lisp_Object_Type::HashMap): return "hashmap"; + case(Lisp_Object_Type::Invalid_Garbage_Collected): return "Invalid: Garbage Collected"; + case(Lisp_Object_Type::Invalid_Under_Construction): return "Invalid: Under Construction"; + } + return "unknown"; + } + +} diff --git a/src/main.cpp b/src/main.cpp index 84c99de..e70b2dc 100644 --- a/src/main.cpp +++ b/src/main.cpp @@ -1,31 +1,30 @@ -#include "libslime.cpp" - -int main(int argc, char* argv[]) { - -#ifdef _MSC_VER - // enable colored terminal output for windows - HANDLE hOut = GetStdHandle(STD_OUTPUT_HANDLE); - DWORD dwMode = 0; - GetConsoleMode(hOut, &dwMode); - dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING; - SetConsoleMode(hOut, dwMode); -#endif - - if (argc > 1) { - if (Slime::string_equal(argv[1], "--run-tests")) { - int res = Slime::run_all_tests(); - return res ? 0 : 1; - } else if (Slime::string_equal(argv[1], "--generate-docs")) { - Slime::Memory::init(); - if (Slime::Globals::error) return 1; - Slime::built_in_load(Slime::Memory::create_string("generate-docs.slime")); - } else { - Slime::interprete_file(argv[1]); - } - } else { - Slime::interprete_stdin(); - return 0; - } - - if (Slime::Globals::error) return 1; -} +#include "libslime.cpp" + +int main(int argc, char* argv[]) { +#ifdef _MSC_VER + // enable colored terminal output for windows + HANDLE hOut = GetStdHandle(STD_OUTPUT_HANDLE); + DWORD dwMode = 0; + GetConsoleMode(hOut, &dwMode); + dwMode |= ENABLE_VIRTUAL_TERMINAL_PROCESSING; + SetConsoleMode(hOut, dwMode); +#endif + + if (argc > 1) { + if (Slime::string_equal(argv[1], "--run-tests")) { + int res = Slime::run_all_tests(); + return res ? 0 : 1; + } else if (Slime::string_equal(argv[1], "--generate-docs")) { + Slime::Memory::init(); + if (Slime::Globals::error) return 1; + Slime::built_in_load(Slime::Memory::create_string("generate-docs.slime")); + } else { + Slime::interprete_file(argv[1]); + } + } else { + Slime::interprete_stdin(); + return 0; + } + + if (Slime::Globals::error) return 1; +} diff --git a/src/memory.cpp b/src/memory.cpp index b543bb4..0d22de8 100644 --- a/src/memory.cpp +++ b/src/memory.cpp @@ -1,539 +1,502 @@ -namespace Slime::Memory { - - // ------------------ - // global symbol / keyword table - // ------------------ - Hash_Map global_symbol_table; - Hash_Map global_keyword_table; - - - Hash_Map file_to_env_map; - // ------------------ - // lisp_objects - // ------------------ - Bucket_Allocator object_memory; - - // ------------------ - // environments - // ------------------ - Bucket_Allocator environment_memory; - - // NOTE(Felix): we are doing hashmaps separately so we don't have - // to malloc them every time, and if two lisp objects have the - // same hashmap, it will not cause double free problems when - // freeing all at the end. It also plays nice with garbage - // collection - // ------------------ - // Hashmaps - // ------------------ - Bucket_Allocator> hashmap_memory; - - // ------------------ - // immutables - // ------------------ - Lisp_Object* nil = nullptr; - Lisp_Object* t = nullptr; - - - proc print_status() { - // printf("Memory Status:\n" - // " - %f%% of the object_memory is used\n" - // " - %d of %d total Lisp_Objects are in use\n" - // " - %d holes in used memory (fragmentation)\n", - // (1.0*next_index_in_object_memory - free_spots_in_object_memory.next_index)/object_memory_size, - // next_index_in_object_memory - free_spots_in_object_memory.next_index, object_memory_size, - // free_spots_in_object_memory.next_index); - - // printf("Memory Status:\n" - // " - %f%% of the string_memory is used\n" - // " - %d holes in used memory (fragmentation)\n", - // (1.0*(size_t)next_free_spot_in_string_memory - (size_t)string_memory)/string_memory_size, - // free_spots_in_string_memory.next_index); - } - - inline proc get_c_str(String str) -> char* { - return str.data; - } - - inline proc get_c_str(Lisp_Object* str) -> char* { - assert_type(str, Lisp_Object_Type::String); - return get_c_str(str->value.string); - } - - inline proc get_type(Lisp_Object* node) -> Lisp_Object_Type { - // the type is in the bits 0 to 5 (including) - return (Lisp_Object_Type) ((u64)node->flags & (u64)0b11111); - } - - - inline proc set_type(Lisp_Object* node, Lisp_Object_Type type) { - // the type is in the bits 0 to 5 (including) - u64 bitmask = (u64)-1; - bitmask -= 0b11111; - bitmask += (u64) type; - node->flags = (u64)(node->flags) | bitmask; - } - - proc hash(String str) -> u64 { - // TODO(Felix): When parsing symbols or keywords, compute the - // hash while reading them in. - u64 value = str.data[0] << 7; - for (int i = 1; i < str.length; ++i) { - char c = str.data[i]; - value = (1000003 * value) ^ c; - } - value ^= str.length; - - return value; - - } - - proc create_string(const char* str, int len) -> String { - String s = { - len, - (char*)malloc(sizeof(char) * len + 1) - }; - strcpy(s.data, str); - return s; - } - - proc create_string (const char* str) -> String { - return create_string(str, (int)strlen(str)); - } - - proc duplicate_string(String str) -> String { - return create_string(str.data, str.length); - } - - proc create_lisp_object() -> Lisp_Object* { - Lisp_Object* object = object_memory.allocate(); - object->flags = 0; - object->sourceCodeLocation = nullptr; - object->userType = nullptr; - return object; - } - - proc free_everything() -> void { - object_memory.for_each([](Lisp_Object* lo){ - free(lo->sourceCodeLocation); - lo->sourceCodeLocation = 0; - - switch (Memory::get_type(lo)) { - case Lisp_Object_Type::Function: { - lo->value.function->args.positional.symbols.dealloc(); - lo->value.function->args.keyword.keywords.dealloc(); - lo->value.function->args.keyword.values.dealloc(); - free(lo->value.function); - } break; - case Lisp_Object_Type::Symbol: - case Lisp_Object_Type::Keyword: - case Lisp_Object_Type::String: { - free(lo->value.string.data); - } break; - default: break; - } - }); - environment_memory.for_each([](Environment* env){ - env->parents.dealloc(); - env->hm.dealloc(); - }); - hashmap_memory.for_each([](Hash_Map* hm){ - hm->dealloc(); - }); - - // free the exe dir: - free(Globals::load_path.data[0]); - Globals::load_path.dealloc(); - Globals::Current_Execution::envi_stack.dealloc(); - Globals::Current_Execution::cs.dealloc(); - Globals::Current_Execution::ams.dealloc(); - Globals::Current_Execution::pcs.dealloc(); - Globals::Current_Execution::nass.dealloc(); - Globals::Current_Execution::ats.dealloc(); - Globals::Current_Execution::mes.dealloc(); - - free(Parser::standard_in.data); - - object_memory.dealloc(); - environment_memory.dealloc(); - hashmap_memory.dealloc(); - - global_symbol_table.dealloc(); - global_keyword_table.dealloc(); - file_to_env_map.dealloc(); - } - - - proc create_child_environment(Environment* parent) -> Environment* { - - Environment* env = environment_memory.allocate(); - - // inject a new array list; - env->parents.alloc(); - env->hm.alloc(); - if (parent) - env->parents.append(parent); - - new(&env->hm) Hash_Map; - - return env; - } - - proc create_empty_environment() -> Environment* { - Environment* ret; - try ret = create_child_environment(nullptr); - return ret; - } - - proc init() -> void { - profile_this(); - - object_memory.alloc(1024, 8); - environment_memory.alloc(1024, 8); - hashmap_memory.alloc(256, 8); - - system_shutdown_hook << [&] { - if_debug { - Slime::Memory::free_everything(); - } - }; - char* exe_path = get_exe_dir(); - - - global_symbol_table.alloc(); - global_keyword_table.alloc(); - file_to_env_map.alloc(); - - Globals::Current_Execution::envi_stack.alloc(); - Globals::Current_Execution::cs.alloc(); - Globals::Current_Execution::nass.alloc(); - Globals::Current_Execution::pcs.alloc(); - Globals::Current_Execution::ams.alloc(); - Globals::Current_Execution::ats.alloc(); - Globals::Current_Execution::mes.alloc(); - - Globals::load_path.alloc(); - add_to_load_path(exe_path); - add_to_load_path("../bin/"); - - - // init nil - try_void nil = create_lisp_object(); - set_type(nil, Lisp_Object_Type::Nil); - - // init t - try_void t = create_lisp_object(); - set_type(t, Lisp_Object_Type::T); - - try_void Parser::standard_in = create_string("stdin"); - - Globals::Current_Execution::envi_stack.next_index = 0; - Environment* env; - try_void env = create_built_ins_environment(); - push_environment(env); - - Environment* user_env; - try_void user_env = Memory::create_child_environment(env); - push_environment(user_env); - } - - - proc create_lisp_object(void* ptr) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Pointer); - node->value.pointer = ptr; - return node; - } - - proc create_lisp_object_hash_map() -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::HashMap); - node->value.hashMap = hashmap_memory.allocate(); - node->value.hashMap->alloc(); - return node; - } - - proc create_lisp_object(double number) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Number); - node->value.number = number; - return node; - } - - proc create_lisp_object(String str) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::String); - node->value.string = str; - return node; - } - - proc create_lisp_object(const char* str) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::String); - node->value.string = create_string(str); - return node; - } - - proc allocate_vector(int size) -> Lisp_Object* { - Lisp_Object* ret = object_memory.allocate(size); - if (!ret) { - create_out_of_memory_error("The vector is too big to fit in a memory bucket."); - return nullptr; - } - return ret; - } - - proc create_lisp_object_vector(int length, Lisp_Object* element_list) -> Lisp_Object* { - try assert_type(element_list, Lisp_Object_Type::Pair); - - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Vector); - - node->value.vector.length = length; - try node->value.vector.data = allocate_vector(length); - - Lisp_Object* head = element_list; - - int i = 0; - while (head != Memory::nil) { - node->value.vector.data[i] = *head->value.pair.first; - head = head->value.pair.rest; - ++i; - } - - return node; - } - - proc create_lisp_object_vector(Lisp_Object* e1) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Vector); - - node->value.vector.length = 1; - try node->value.vector.data = allocate_vector(1); - - node->value.vector.data[0] = *e1; - - return node; - } - - proc create_lisp_object_vector(Lisp_Object* e1, Lisp_Object* e2) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Vector); - - node->value.vector.length = 2; - try node->value.vector.data = allocate_vector(2); - - node->value.vector.data[0] = *e1; - node->value.vector.data[1] = *e2; - - return node; - } - - proc create_lisp_object_vector(Lisp_Object* e1, Lisp_Object* e2, Lisp_Object* e3) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Vector); - - node->value.vector.length = 3; - try node->value.vector.data = allocate_vector(3); - - node->value.vector.data[0] = *e1; - node->value.vector.data[1] = *e2; - node->value.vector.data[2] = *e3; - - return node; - } - - inline proc _create_symbol(char* identifier) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Symbol); - node->value.symbol = create_string(identifier); - global_symbol_table.set_object((char*)node->value.symbol.data, node); - return node; - } - - inline proc get_symbol(String identifier) -> Lisp_Object* { - return get_symbol(identifier.data); - } - - inline proc get_symbol(const char* identifier) -> Lisp_Object* { - if (Lisp_Object* ret = global_symbol_table.get_object((char*)identifier)) - return (Lisp_Object*)ret; - return _create_symbol((char*)identifier); - } - - inline proc _create_keyword(char* identifier) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Keyword); - node->value.symbol = create_string(identifier); - global_keyword_table.set_object((char*)node->value.symbol.data, node); - return node; - } - - inline proc get_keyword(String identifier) -> Lisp_Object* { - return get_keyword(identifier.data); - } - - inline proc get_keyword(const char* identifier) -> Lisp_Object* { - if (Lisp_Object* ret = global_keyword_table.get_object((char*)identifier)) - return ret; - return _create_keyword((char*)identifier); - } - - - // proc get_keyword(String keyword) -> Lisp_Object* { - // Lisp_Object* node = global_keyword_table.get_object(get_c_str(keyword)); - // if (node) - // return (Lisp_Object*)node; - - // try node = create_lisp_object(); - // set_type(node, Lisp_Object_Type::Keyword); - // node->value.symbol = duplicate_string(keyword); - // global_keyword_table.set_object(get_c_str(keyword), node); - // return node; - // } - - - // proc get_keyword(const char* keyword) -> Lisp_Object* { - // if (auto ret = global_keyword_table.get_object((char*)keyword)) - // return (Lisp_Object*)ret; - // else { - // String str; - // try str = Memory::create_string(keyword); - // return get_keyword(str); - // } - // } - - proc create_lisp_object_cfunction(C_Function_Type type) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Function); - node->value.function = (Function*)malloc(sizeof(Function)); - node->value.function->type.c_function_type = type; - node->value.function->args.keyword.keywords.alloc(); - node->value.function->args.keyword.values.alloc(); - node->value.function->args.positional.symbols.alloc(); - node->value.function->is_c = true; - return node; - } - - proc create_lisp_object_function(Lisp_Function_Type ft) -> Lisp_Object* { - Lisp_Object* func; - try func = Memory::create_lisp_object(); - Memory::set_type(func, Lisp_Object_Type::Function); - func->value.function = (Function*)malloc(sizeof(Function)); - func->value.function->args.keyword.keywords.alloc(); - func->value.function->args.keyword.values.alloc(); - func->value.function->args.positional.symbols.alloc(); - func->value.function->type.lisp_function_type = ft; - func->value.function->is_c = false; - return func; - } - - proc create_lisp_object_pair(Lisp_Object* first, Lisp_Object* rest) -> Lisp_Object* { - Lisp_Object* node; - try node = create_lisp_object(); - set_type(node, Lisp_Object_Type::Pair); - // node->value.pair = new(Pair); - node->value.pair.first = first; - node->value.pair.rest = rest; - return node; - } - - proc copy_lisp_object(Lisp_Object* n) -> Lisp_Object* { - // TODO(Felix): If argument is a list (pair), do a FULL copy, - - // we don't copy singleton objects - if (n == Memory::nil || n == Memory::t) { - return n; - } else { - Lisp_Object_Type type = Memory::get_type(n); - if (type == Lisp_Object_Type::Symbol || - type == Lisp_Object_Type::Keyword || - type == Lisp_Object_Type::Function) - { - return n; - } else if (type == Lisp_Object_Type::String) { - Lisp_Object* target; - try target = create_lisp_object(); - *target = *n; - target->value.string = create_string(target->value.string.data); - return target; - } else { - Lisp_Object* target; - try target = create_lisp_object(); - *target = *n; - - return target; - } - } - } - - proc copy_lisp_object_except_pairs(Lisp_Object* n) -> Lisp_Object* { - if (get_type(n) == Lisp_Object_Type::Pair) - return n; - return copy_lisp_object(n); - } - - proc create_built_ins_environment() -> Environment* { - Environment* ret; - try ret = create_empty_environment(); - push_environment(ret); - defer { - pop_environment(); - }; - - try load_built_ins_into_environment(); - String file_name = Memory::create_string("pre.slime"); - try built_in_load(file_name); - free(file_name.data); - return ret; - } - - - inline proc create_list(Lisp_Object* o1) -> Lisp_Object* { - Lisp_Object* ret; - try ret = create_lisp_object_pair(o1, nil); - return ret; - } - - inline proc create_list(Lisp_Object* o1, Lisp_Object* o2) -> Lisp_Object* { - Lisp_Object* ret; - try ret = create_lisp_object_pair(o1, create_list(o2)); - return ret; - } - - inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3) -> Lisp_Object* { - Lisp_Object* ret; - try ret = create_lisp_object_pair(o1, create_list(o2, o3)); - return ret; - } - - inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4) -> Lisp_Object* { - Lisp_Object* ret; - try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4)); - return ret; - } - - inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4, Lisp_Object* o5) -> Lisp_Object* { - Lisp_Object* ret; - try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4, o5)); - return ret; - } - - inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4, Lisp_Object* o5, Lisp_Object* o6) -> Lisp_Object* { - Lisp_Object* ret; - try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4, o5, o6)); - return ret; - } -} +namespace Slime::Memory { + + // ------------------ + // global symbol / keyword table + // ------------------ + Hash_Map global_symbol_table; + Hash_Map global_keyword_table; + + + Hash_Map file_to_env_map; + // ------------------ + // lisp_objects + // ------------------ + Bucket_Allocator object_memory; + + // ------------------ + // environments + // ------------------ + Bucket_Allocator environment_memory; + + // NOTE(Felix): we are doing hashmaps separately so we don't have + // to malloc them every time, and if two lisp objects have the + // same hashmap, it will not cause double free problems when + // freeing all at the end. It also plays nice with garbage + // collection + // ------------------ + // Hashmaps + // ------------------ + Bucket_Allocator> hashmap_memory; + + // ------------------ + // immutables + // ------------------ + Lisp_Object* nil = nullptr; + Lisp_Object* t = nullptr; + + + proc print_status() { + // printf("Memory Status:\n" + // " - %f%% of the object_memory is used\n" + // " - %d of %d total Lisp_Objects are in use\n" + // " - %d holes in used memory (fragmentation)\n", + // (1.0*next_index_in_object_memory - free_spots_in_object_memory.next_index)/object_memory_size, + // next_index_in_object_memory - free_spots_in_object_memory.next_index, object_memory_size, + // free_spots_in_object_memory.next_index); + + // printf("Memory Status:\n" + // " - %f%% of the string_memory is used\n" + // " - %d holes in used memory (fragmentation)\n", + // (1.0*(size_t)next_free_spot_in_string_memory - (size_t)string_memory)/string_memory_size, + // free_spots_in_string_memory.next_index); + } + + inline proc get_c_str(String str) -> char* { + return str.data; + } + + inline proc get_c_str(Lisp_Object* str) -> char* { + assert_type(str, Lisp_Object_Type::String); + return get_c_str(str->value.string); + } + + proc hash(String str) -> u64 { + // TODO(Felix): When parsing symbols or keywords, compute the + // hash while reading them in. + u64 value = str.data[0] << 7; + for (int i = 1; i < str.length; ++i) { + char c = str.data[i]; + value = (1000003 * value) ^ c; + } + value ^= str.length; + + return value; + + } + + proc create_string(const char* str, int len) -> String { + String s = { + len, + (char*)malloc(sizeof(char) * len + 1) + }; + strcpy(s.data, str); + return s; + } + + proc create_string (const char* str) -> String { + return create_string(str, (int)strlen(str)); + } + + proc duplicate_string(String str) -> String { + return create_string(str.data, str.length); + } + + proc create_lisp_object() -> Lisp_Object* { + Lisp_Object* object = object_memory.allocate(); + object->type = Lisp_Object_Type::Invalid_Under_Construction; + return object; + } + + proc free_everything() -> void { + object_memory.for_each([](Lisp_Object* lo){ + switch (lo->type) { + case Lisp_Object_Type::Function: { + lo->value.function->args.positional.symbols.dealloc(); + lo->value.function->args.keyword.keywords.dealloc(); + lo->value.function->args.keyword.values.dealloc(); + free(lo->value.function); + } break; + case Lisp_Object_Type::Symbol: + case Lisp_Object_Type::Keyword: + case Lisp_Object_Type::String: { + free(lo->value.string.data); + } break; + default: break; + } + }); + environment_memory.for_each([](Environment* env){ + env->parents.dealloc(); + env->hm.dealloc(); + }); + hashmap_memory.for_each([](Hash_Map* hm){ + hm->dealloc(); + }); + + for_hash_map(Globals::docs) { + free(value); + } + + // free the exe dir: + free(Globals::load_path.data[0]); + Globals::load_path.dealloc(); + Globals::docs.dealloc(); + Globals::Current_Execution::envi_stack.dealloc(); + Globals::Current_Execution::cs.dealloc(); + Globals::Current_Execution::ams.dealloc(); + Globals::Current_Execution::pcs.dealloc(); + Globals::Current_Execution::nass.dealloc(); + Globals::Current_Execution::ats.dealloc(); + Globals::Current_Execution::mes.dealloc(); + + free(Parser::standard_in.data); + + object_memory.dealloc(); + environment_memory.dealloc(); + hashmap_memory.dealloc(); + + global_symbol_table.dealloc(); + global_keyword_table.dealloc(); + file_to_env_map.dealloc(); + } + + + proc create_child_environment(Environment* parent) -> Environment* { + + Environment* env = environment_memory.allocate(); + + // inject a new array list; + env->parents.alloc(); + env->hm.alloc(); + if (parent) + env->parents.append(parent); + + new(&env->hm) Hash_Map; + + return env; + } + + proc create_empty_environment() -> Environment* { + Environment* ret; + try ret = create_child_environment(nullptr); + return ret; + } + + proc init() -> void { + profile_this(); + + object_memory.alloc(1024, 8); + environment_memory.alloc(1024, 8); + hashmap_memory.alloc(256, 8); + + system_shutdown_hook << [&] { + if_debug { + Slime::Memory::free_everything(); + } + }; + char* exe_path = get_exe_dir(); + + + global_symbol_table.alloc(); + global_keyword_table.alloc(); + file_to_env_map.alloc(); + + Globals::Current_Execution::envi_stack.alloc(); + Globals::Current_Execution::cs.alloc(); + Globals::Current_Execution::nass.alloc(); + Globals::Current_Execution::pcs.alloc(); + Globals::Current_Execution::ams.alloc(); + Globals::Current_Execution::ats.alloc(); + Globals::Current_Execution::mes.alloc(); + + Globals::docs.alloc(); + Globals::load_path.alloc(); + add_to_load_path(exe_path); + add_to_load_path("../bin/"); + + + // init nil + try_void nil = create_lisp_object(); + nil->type = Lisp_Object_Type::Nil; + + // init t + try_void t = create_lisp_object(); + t->type = Lisp_Object_Type::T; + + try_void Parser::standard_in = create_string("stdin"); + + Globals::Current_Execution::envi_stack.next_index = 0; + Environment* env; + try_void env = create_built_ins_environment(); + push_environment(env); + + Environment* user_env; + try_void user_env = Memory::create_child_environment(env); + push_environment(user_env); + } + + + proc create_lisp_object(void* ptr) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Pointer; + node->value.pointer = ptr; + return node; + } + + proc create_lisp_object_hash_map() -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::HashMap; + node->value.hashMap = hashmap_memory.allocate(); + node->value.hashMap->alloc(); + return node; + } + + proc create_lisp_object(double number) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Number; + node->value.number = number; + return node; + } + + proc create_lisp_object(String str) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::String; + node->value.string = str; + return node; + } + + proc create_lisp_object(const char* str) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::String; + node->value.string = create_string(str); + return node; + } + + proc allocate_vector(int size) -> Lisp_Object* { + Lisp_Object* ret = object_memory.allocate(size); + if (!ret) { + create_out_of_memory_error("The vector is too big to fit in a memory bucket."); + return nullptr; + } + return ret; + } + + proc create_lisp_object_vector(int length, Lisp_Object* element_list) -> Lisp_Object* { + try assert_type(element_list, Lisp_Object_Type::Pair); + + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Vector; + + node->value.vector.length = length; + try node->value.vector.data = allocate_vector(length); + + Lisp_Object* head = element_list; + + int i = 0; + while (head != Memory::nil) { + node->value.vector.data[i] = *head->value.pair.first; + head = head->value.pair.rest; + ++i; + } + + return node; + } + + proc create_lisp_object_vector(Lisp_Object* e1) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Vector; + + node->value.vector.length = 1; + try node->value.vector.data = allocate_vector(1); + + node->value.vector.data[0] = *e1; + + return node; + } + + proc create_lisp_object_vector(Lisp_Object* e1, Lisp_Object* e2) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Vector; + + node->value.vector.length = 2; + try node->value.vector.data = allocate_vector(2); + + node->value.vector.data[0] = *e1; + node->value.vector.data[1] = *e2; + + return node; + } + + proc create_lisp_object_vector(Lisp_Object* e1, Lisp_Object* e2, Lisp_Object* e3) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Vector; + + node->value.vector.length = 3; + try node->value.vector.data = allocate_vector(3); + + node->value.vector.data[0] = *e1; + node->value.vector.data[1] = *e2; + node->value.vector.data[2] = *e3; + + return node; + } + + inline proc _create_symbol(char* identifier) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Symbol; + node->value.symbol = create_string(identifier); + global_symbol_table.set_object((char*)node->value.symbol.data, node); + return node; + } + + inline proc get_symbol(String identifier) -> Lisp_Object* { + return get_symbol(identifier.data); + } + + inline proc get_symbol(const char* identifier) -> Lisp_Object* { + if (Lisp_Object* ret = global_symbol_table.get_object((char*)identifier)) + return (Lisp_Object*)ret; + return _create_symbol((char*)identifier); + } + + inline proc _create_keyword(char* identifier) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Keyword; + node->value.symbol = create_string(identifier); + global_keyword_table.set_object((char*)node->value.symbol.data, node); + return node; + } + + inline proc get_keyword(String identifier) -> Lisp_Object* { + return get_keyword(identifier.data); + } + + inline proc get_keyword(const char* identifier) -> Lisp_Object* { + if (Lisp_Object* ret = global_keyword_table.get_object((char*)identifier)) + return ret; + return _create_keyword((char*)identifier); + } + + proc create_lisp_object_cfunction(C_Function_Type type) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Function; + node->value.function = (Function*)malloc(sizeof(Function)); + node->value.function->type.c_function_type = type; + node->value.function->args.keyword.keywords.alloc(); + node->value.function->args.keyword.values.alloc(); + node->value.function->args.positional.symbols.alloc(); + node->value.function->is_c = true; + return node; + } + + proc create_lisp_object_function(Lisp_Function_Type ft) -> Lisp_Object* { + Lisp_Object* func; + try func = Memory::create_lisp_object(); + func->type = Lisp_Object_Type::Function; + func->value.function = (Function*)malloc(sizeof(Function)); + func->value.function->args.keyword.keywords.alloc(); + func->value.function->args.keyword.values.alloc(); + func->value.function->args.positional.symbols.alloc(); + func->value.function->type.lisp_function_type = ft; + func->value.function->is_c = false; + return func; + } + + proc create_lisp_object_pair(Lisp_Object* first, Lisp_Object* rest) -> Lisp_Object* { + Lisp_Object* node; + try node = create_lisp_object(); + node->type = Lisp_Object_Type::Pair; + // node->value.pair = new(Pair); + node->value.pair.first = first; + node->value.pair.rest = rest; + return node; + } + + proc copy_lisp_object(Lisp_Object* n) -> Lisp_Object* { + // TODO(Felix): If argument is a list (pair), do a FULL copy, + + // we don't copy singleton objects + if (n == Memory::nil || n == Memory::t) { + return n; + } else { + Lisp_Object_Type type = n->type; + if (type == Lisp_Object_Type::Symbol || + type == Lisp_Object_Type::Keyword || + type == Lisp_Object_Type::Function) + { + return n; + } else if (type == Lisp_Object_Type::String) { + Lisp_Object* target; + try target = create_lisp_object(); + *target = *n; + target->value.string = create_string(target->value.string.data); + return target; + } else { + Lisp_Object* target; + try target = create_lisp_object(); + *target = *n; + + return target; + } + } + } + + proc copy_lisp_object_except_pairs(Lisp_Object* n) -> Lisp_Object* { + if (n->type == Lisp_Object_Type::Pair) + return n; + return copy_lisp_object(n); + } + + proc create_built_ins_environment() -> Environment* { + Environment* ret; + try ret = create_empty_environment(); + push_environment(ret); + defer { + pop_environment(); + }; + + try load_built_ins_into_environment(); + String file_name = Memory::create_string("pre.slime"); + try built_in_load(file_name); + free(file_name.data); + return ret; + } + + + inline proc create_list(Lisp_Object* o1) -> Lisp_Object* { + Lisp_Object* ret; + try ret = create_lisp_object_pair(o1, nil); + return ret; + } + + inline proc create_list(Lisp_Object* o1, Lisp_Object* o2) -> Lisp_Object* { + Lisp_Object* ret; + try ret = create_lisp_object_pair(o1, create_list(o2)); + return ret; + } + + inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3) -> Lisp_Object* { + Lisp_Object* ret; + try ret = create_lisp_object_pair(o1, create_list(o2, o3)); + return ret; + } + + inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4) -> Lisp_Object* { + Lisp_Object* ret; + try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4)); + return ret; + } + + inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4, Lisp_Object* o5) -> Lisp_Object* { + Lisp_Object* ret; + try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4, o5)); + return ret; + } + + inline proc create_list(Lisp_Object* o1, Lisp_Object* o2, Lisp_Object* o3, Lisp_Object* o4, Lisp_Object* o5, Lisp_Object* o6) -> Lisp_Object* { + Lisp_Object* ret; + try ret = create_lisp_object_pair(o1, create_list(o2, o3, o4, o5, o6)); + return ret; + } +} diff --git a/src/structs.cpp b/src/structs.cpp index 060856a..ccff108 100644 --- a/src/structs.cpp +++ b/src/structs.cpp @@ -3,12 +3,12 @@ namespace Slime { struct String; struct Environment; - enum struct Thread_Type { + enum struct Thread_Type : u8 { Main, GarbageCollection }; - enum struct Lisp_Object_Type { + enum struct Lisp_Object_Type : u8 { Nil, T, Symbol, @@ -22,16 +22,11 @@ namespace Slime { HashMap, // OwningPointer, Function, + Invalid_Garbage_Collected, + Invalid_Under_Construction }; - enum class Lisp_Object_Flags - { - // bits 1 to 5 (including) will be reserved for the type - Already_Garbage_Collected = 1 << 5, - Under_Construction = 1 << 6, - }; - - enum struct NasAction { + enum struct NasAction : u8 { And_Then_Action, Macro_Write_Back, Eval, @@ -43,13 +38,13 @@ namespace Slime { Pop_Environment }; - enum struct Lisp_Function_Type { + enum struct Lisp_Function_Type : u8 { Lambda, // normal evaluation order Macro // args are not evaluated, a new programm is returned // that will be executed again }; - enum struct C_Function_Type { + enum struct C_Function_Type : u8 { cFunction, // normal evaluation order cSpecial, // args are not evaluated, but result is returned // as you would expect @@ -57,7 +52,7 @@ namespace Slime { // modified }; - enum struct Log_Level { + enum struct Log_Level : u8 { None, Critical, Warning, @@ -131,10 +126,9 @@ namespace Slime { } body; }; +#pragma pack(1) struct Lisp_Object { - Source_Code_Location* sourceCodeLocation; - u64 flags; - Lisp_Object* userType; // keyword + Lisp_Object_Type type; union value { String symbol; // used for symbols and keywords double number; @@ -145,9 +139,9 @@ namespace Slime { void* pointer; Continuation* continuation; Hash_Map* hashMap; - ~value() {} } value; }; +#pragma options align=reset struct Error { Lisp_Object* position; diff --git a/src/testing.cpp b/src/testing.cpp index ae69763..45d2515 100644 --- a/src/testing.cpp +++ b/src/testing.cpp @@ -1,660 +1,660 @@ -namespace Slime { - -#define epsilon 2.2204460492503131E-16 - -#define testresult int -#define pass 1 -#define fail 0 - -#define print_assert_equal_fail(variable, value, type, format) \ - printf("\n%s:%d: Assertion failed\n\tfor '" #variable "'" \ - "\n\texpected: " format \ - "\n\tgot: " format "\n", \ - __FILE__, __LINE__, (type)value, (type)variable) - -#define print_assert_not_equal_fail(variable, value, type, format) \ - printf("\n%s:%d: Assertion failed\n\tfor '" #variable "'" \ - "\n\texpected not: " format \ - "\n\tgot anyways: " format "\n", \ - __FILE__, __LINE__, (type)value, (type)variable) - -#define assert_equal_int(variable, value) \ - if (variable != value) { \ - print_assert_equal_fail(variable, value, size_t, "%zd"); \ - return fail; \ - } - -#define assert_not_equal_int(variable, value) \ - if (variable == value) { \ - print_assert_not_equal_fail(variable, value, size_t, "%zd"); \ - return fail; \ - } - -#define assert_no_error() \ - if (Globals::error) { \ - print_assert_equal_fail(Globals::error, 0, size_t, "%zd"); \ - printf("\nExpected no error to occur," \ - " but an error occured anyways:\n"); \ - return fail; \ - } \ - -#define assert_error() \ - if (!Globals::error) { \ - print_assert_not_equal_fail(Globals::error, 0, size_t, "%zd"); \ - printf("\nExpected an error to occur," \ - " but no error occured:\n"); \ - return fail; \ - } \ - -#define assert_equal_double(variable, value) \ - if (fabs((double)variable - (double)value) > epsilon) { \ - print_assert_equal_fail(variable, value, double, "%f"); \ - return fail; \ - } - -#define assert_not_equal_double(variable, value) \ - if (fabs((double)variable - (double)value) <= epsilon) { \ - print_assert_not_equal_fail(variable, value, double, "%f"); \ - return fail; \ - } - -#define assert_equal_string(variable, value) \ - if (!string_equal(variable, value)) { \ - print_assert_equal_fail(variable.data, value, char*, "%s"); \ - return fail; \ - } - -#define assert_equal_type(node, _type) \ - if (Memory::get_type(node) != _type) { \ - print_assert_equal_fail( \ - lisp_object_type_to_string(Memory::get_type(node)), \ - lisp_object_type_to_string(_type), char*, "%s"); \ - return fail; \ - } \ - -#define assert_null(variable) \ - assert_equal_int(variable, nullptr) - -#define assert_not_null(variable) \ - assert_not_equal_int(variable, nullptr) - -#define invoke_test(name) \ - fputs("" #name ":", stdout); \ - if (name() == pass) { \ - for(size_t i = strlen(#name); i < 70; ++i) \ - fputs((i%3==1)? "." : " ", stdout); \ - fputs(console_green "passed\n" console_normal, stdout); \ - } \ - else { \ - result = false; \ - for(int i = -1; i < 70; ++i) \ - fputs((i%3==1)? "." : " ", stdout); \ - fputs(console_red "failed\n" console_normal, stdout); \ - if(Globals::error) { \ - free(Globals::error); \ - Globals::error = nullptr; \ - } \ - } \ - -#define invoke_test_script(name) \ - fputs("" name ":", stdout); \ - if (test_file("tests/" name ".slime") == pass) { \ - for(size_t i = strlen(name); i < 70; ++i) \ - fputs((i%3==1)? "." : " ", stdout); \ - fputs(console_green "passed\n" console_normal, stdout); \ - } \ - else { \ - result = false; \ - for(int i = -1; i < 70; ++i) \ - fputs((i%3==1)? "." : " ", stdout); \ - fputs(console_red "failed\n" console_normal, stdout); \ - if(Globals::error) { \ - free(Globals::error); \ - Globals::error = nullptr; \ - } \ - } - - proc test_array_lists_adding_and_removing() -> testresult { - // test adding and removing - Array_List list; - list.alloc(); - defer { - list.dealloc(); - }; - list.append(1); - list.append(2); - list.append(3); - list.append(4); - - assert_equal_int(list.next_index, 4); - - list.remove_index(0); - - assert_equal_int(list.next_index, 3); - assert_equal_int(list[0], 4); - assert_equal_int(list[1], 2); - assert_equal_int(list[2], 3); - - list.remove_index(2); - - assert_equal_int(list.next_index, 2); - assert_equal_int(list[0], 4); - assert_equal_int(list[1], 2); - - return pass; - } - - proc test_array_lists_sorting() -> testresult { - // test adding and removing - Array_List list; - list.alloc(); - defer { - list.dealloc(); - }; - - list.append(1); - list.append(2); - list.append(3); - list.append(4); - - list.sort(); - - assert_equal_int(list.next_index, 4); - - assert_equal_int(list[0], 1); - assert_equal_int(list[1], 2); - assert_equal_int(list[2], 3); - assert_equal_int(list[3], 4); - - list.append(0); - list.append(5); - - assert_equal_int(list.next_index, 6); - - list.sort(); - - assert_equal_int(list[0], 0); - assert_equal_int(list[1], 1); - assert_equal_int(list[2], 2); - assert_equal_int(list[3], 3); - assert_equal_int(list[4], 4); - assert_equal_int(list[5], 5); - - return pass; - } - - proc test_array_lists_searching() -> testresult { - Array_List list; - list.alloc(); - defer { - list.dealloc(); - }; - - list.append(1); - list.append(2); - list.append(3); - list.append(4); - - int index = list.sorted_find(3); - assert_equal_int(index, 2); - - index = list.sorted_find(1); - assert_equal_int(index, 0); - - index = list.sorted_find(5); - assert_equal_int(index, -1); - - return pass; - } - - proc test_parse_atom() -> testresult { - int index_in_text = 0; - char string[] = - "123 -1.23e-2 " // numbers - "\"asd\" " // strings - ":key1 :key:2 " // keywords - "sym +"; // symbols - - // test numbers - Lisp_Object* result = Parser::parse_atom(string, &index_in_text); - - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, 123); - - ++index_in_text; - - result = Parser::parse_atom(string, &index_in_text); - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, -1.23e-2); - - // test strings - ++index_in_text; - - result = Parser::parse_atom(string, &index_in_text); - assert_equal_type(result, Lisp_Object_Type::String); - assert_equal_string(result->value.string, "asd"); - - // test keywords - ++index_in_text; - - result = Parser::parse_atom(string, &index_in_text); - assert_equal_type(result, Lisp_Object_Type::Keyword); - assert_equal_string(result->value.symbol, "key1"); - - ++index_in_text; - - result = Parser::parse_atom(string, &index_in_text); - assert_equal_type(result, Lisp_Object_Type::Keyword); - assert_equal_string(result->value.symbol, "key:2"); - - // test symbols - ++index_in_text; - - result = Parser::parse_atom(string, &index_in_text); - assert_equal_type(result, Lisp_Object_Type::Symbol); - assert_equal_string(result->value.symbol, "sym"); - - ++index_in_text; - - result = Parser::parse_atom(string, &index_in_text); - assert_equal_type(result, Lisp_Object_Type::Symbol); - assert_equal_string(result->value.symbol, "+"); - - return pass; - } - - proc test_parse_expression() -> testresult { - int index_in_text = 0; - char string[] = "(fun + 12)"; - - Lisp_Object* result = Parser::parse_expression(string, &index_in_text); - assert_no_error(); - - assert_equal_type(result, Lisp_Object_Type::Pair); - assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); - assert_equal_string(result->value.pair.first->value.symbol, "fun"); - - result = result->value.pair.rest; - - assert_equal_type(result, Lisp_Object_Type::Pair); - assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); - assert_equal_string(result->value.pair.first->value.symbol, "+"); - - result = result->value.pair.rest; - - assert_equal_type(result, Lisp_Object_Type::Pair); - assert_equal_type(result->value.pair.first, Lisp_Object_Type::Number); - assert_equal_double(result->value.pair.first->value.number, 12); - - result = result->value.pair.rest; - - assert_equal_type(result, Lisp_Object_Type::Nil); - - char string2[] = "(define fun (lambda (x) (+ 5 (* x x ))))"; - index_in_text = 0; - - result = Parser::parse_expression(string2, &index_in_text); - assert_no_error(); - - assert_equal_type(result, Lisp_Object_Type::Pair); - assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); - assert_equal_string(result->value.pair.first->value.symbol, "define"); - - result = result->value.pair.rest; - - assert_equal_type(result, Lisp_Object_Type::Pair); - assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); - assert_equal_string(result->value.pair.first->value.symbol, "fun"); - - result = result->value.pair.rest; - - assert_equal_type(result, Lisp_Object_Type::Pair); - assert_equal_type(result->value.pair.first, Lisp_Object_Type::Pair); - assert_equal_type(result->value.pair.first->value.pair.first, Lisp_Object_Type::Symbol); - assert_equal_string(result->value.pair.first->value.pair.first->value.symbol, "lambda"); - - result = result->value.pair.rest; - - return pass; - } - - proc test_built_in_add() -> testresult { - char exp_string[] = "(+ 10 4)"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string); - Lisp_Object* result; - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, 14); - - return pass; - } - - proc test_built_in_substract() -> testresult { - char exp_string[] = "(- 10 4)"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string); - Lisp_Object* result; - - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, 6); - - return pass; - } - - - proc test_built_in_multiply() -> testresult { - char exp_string[] = "(* 10 4)"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string); - Lisp_Object* result; - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, 40); - - return pass; - } - - - proc test_built_in_divide() -> testresult { - char exp_string[] = "(/ 20 4)"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string); - Lisp_Object* result; - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, 5); - - return pass; - } - - - proc test_built_in_if() -> testresult { - char exp_string1[] = "(if 1 4 5)"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string1); - Lisp_Object* result; - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, 4); - - char exp_string2[] = "(if () 4 5)"; - expression = Parser::parse_single_expression(exp_string2); - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Number); - assert_equal_double(result->value.number, 5); - - return pass; - } - - proc test_built_in_and() -> testresult { - char exp_string1[] = "(and 1 \"asd\" 4)"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string1); - Lisp_Object* result; - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::T); - - // a false case - char exp_string2[] = "(and () \"asd\" 4)"; - expression = Parser::parse_single_expression(exp_string2); - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Nil); - - return pass; - } - - proc test_built_in_or() -> testresult { - char exp_string1[] = "(or \"asd\" nil)"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string1); - Lisp_Object* result; - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::T); - - // a false case - char exp_string2[] = "(or () ())"; - expression = Parser::parse_single_expression(exp_string2); - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Nil); - - return pass; - } - - - proc test_built_in_not() -> testresult { - char exp_string1[] = "(not ())"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string1); - Lisp_Object* result; - try result = eval_expr(expression); - - // a true case - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::T); - - // a false case - char exp_string2[] = "(not \"asd xD\")"; - expression = Parser::parse_single_expression(exp_string2); - try result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Nil); - - return pass; - } - - proc test_built_in_type() -> testresult { - // Environment* env; - // try env = get_root_environment(); - - // normal type testing - char exp_string1[] = "(begin (define a 10)(type a))"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string1); - Lisp_Object* result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Keyword); - assert_equal_string(result->value.symbol, "number"); - - // setting user type - char exp_string2[] = "(begin (set-type! a :my-type)(type a))"; - expression = Parser::parse_single_expression(exp_string2); - result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Keyword); - assert_equal_string(result->value.symbol, "my-type"); - - // // trying to set invalid user type - // char exp_string3[] = "(begin (set-type! a \"wrong tpye\")(type a))"; - // expression = Parser::parse_single_expression(exp_string3); - // assert_no_error(); - - // ignore_logging { - // dont_break_on_errors { - // result = eval_expr(expression); - // } - // } - - // assert_error(); - // delete_error(); - - // deleting user type - char exp_string4[] = "(begin (delete-type! a)(type a))"; - expression = Parser::parse_single_expression(exp_string4); - result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Keyword); - assert_equal_string(result->value.symbol, "number"); - - return pass; - } - - proc test_singular_t_and_nil() -> testresult { - // nil testing - char exp_string1[] = "()"; - char exp_string2[] = "nil"; - Lisp_Object* expression = Parser::parse_single_expression(exp_string1); - Lisp_Object* result = eval_expr(expression); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Nil); - assert_equal_int(expression, result); - - Lisp_Object* expression2 = Parser::parse_single_expression(exp_string2); - Lisp_Object* result2 = eval_expr(expression2); - - assert_no_error(); - assert_not_null(result); - assert_equal_type(result, Lisp_Object_Type::Nil); - assert_equal_int(result, result2); - assert_equal_int(expression, Memory::nil); - - // t testing - char exp_string3[] = "t"; - Lisp_Object* expression3 = Parser::parse_single_expression(exp_string3); - Lisp_Object* result3 = eval_expr(expression3); - - assert_no_error(); - assert_not_null(result3); - - return pass; - } - - proc test_singular_symbols() -> testresult { - auto cc_s_aa = Memory::get_symbol("aa"); - auto cc_s_aa2 = Memory::get_symbol("aa2"); - - String s1 = Memory::create_string("aa"); - String s2 = Memory::create_string("aa2"); - - auto s_s_aa = Memory::get_symbol(s1); - auto s_s_aa2 = Memory::get_symbol(s2); - - free(s1.data); - free(s2.data); - - assert_equal_int(cc_s_aa, s_s_aa); - assert_equal_int(cc_s_aa2, s_s_aa2); - assert_not_equal_int(cc_s_aa, cc_s_aa2); - - return pass; - } - - proc test_file(const char* file) -> testresult { - profile_with_name(file); - // Memory::reset(); - // assert_no_error(); - - push_environment(Memory::create_child_environment(get_current_environment())); - String name = Memory::create_string(file); - built_in_load(name); - free(name.data); - assert_no_error(); - pop_environment(); - - return pass; - } - - proc run_all_tests() -> bool { - profile_this(); - - bool result = true; - try Memory::init(); - - push_environment(Memory::create_child_environment( - get_current_environment())); - printf("-- Util --\n"); - invoke_test(test_array_lists_adding_and_removing); - invoke_test(test_array_lists_sorting); - invoke_test(test_array_lists_searching); - - printf("\n -- Parsing --\n"); - invoke_test(test_parse_atom); - invoke_test(test_parse_expression); - - printf("\n-- Built ins --\n"); - invoke_test(test_built_in_add); - invoke_test(test_built_in_substract); - invoke_test(test_built_in_multiply); - invoke_test(test_built_in_divide); - invoke_test(test_built_in_if); - invoke_test(test_built_in_and); - invoke_test(test_built_in_or); - invoke_test(test_built_in_not); - invoke_test(test_built_in_type); - - printf("\n-- Memory management --\n"); - invoke_test(test_singular_t_and_nil); - invoke_test(test_singular_symbols); - - pop_environment(); - printf("\n-- Test Files --\n"); - - invoke_test_script("evaluation_of_default_args"); - invoke_test_script("case_and_cond"); - invoke_test_script("lexical_scope"); - invoke_test_script("singular_imports"); - invoke_test_script("hashmaps"); - invoke_test_script("import_and_load"); - invoke_test_script("macro_expand"); - invoke_test_script("sicp"); - invoke_test_script("simple_built_ins"); - // invoke_test_script("modules"); - // invoke_test_script("class_macro"); - // invoke_test_script("automata"); - // invoke_test_script("alists"); - - return result; - } - -#undef epsilon -#undef testresult -#undef pass -#undef fail - -#undef print_assert_equal_fail -#undef print_assert_not_equal_fail -#undef assert_no_error -#undef assert_equal_int -#undef assert_not_equal_int -#undef assert_equal_double -#undef assert_not_equal_double -#undef assert_equal_string -#undef assert_equal_type -#undef assert_null -#undef assert_not_null -#undef invoke_test -#undef invoke_test_script -} +namespace Slime { + +#define epsilon 2.2204460492503131E-16 + +#define testresult int +#define pass 1 +#define fail 0 + +#define print_assert_equal_fail(variable, value, type, format) \ + printf("\n%s:%d: Assertion failed\n\tfor '" #variable "'" \ + "\n\texpected: " format \ + "\n\tgot: " format "\n", \ + __FILE__, __LINE__, (type)value, (type)variable) + +#define print_assert_not_equal_fail(variable, value, type, format) \ + printf("\n%s:%d: Assertion failed\n\tfor '" #variable "'" \ + "\n\texpected not: " format \ + "\n\tgot anyways: " format "\n", \ + __FILE__, __LINE__, (type)value, (type)variable) + +#define assert_equal_int(variable, value) \ + if (variable != value) { \ + print_assert_equal_fail(variable, value, size_t, "%zd"); \ + return fail; \ + } + +#define assert_not_equal_int(variable, value) \ + if (variable == value) { \ + print_assert_not_equal_fail(variable, value, size_t, "%zd"); \ + return fail; \ + } + +#define assert_no_error() \ + if (Globals::error) { \ + print_assert_equal_fail(Globals::error, 0, size_t, "%zd"); \ + printf("\nExpected no error to occur," \ + " but an error occured anyways:\n"); \ + return fail; \ + } \ + +#define assert_error() \ + if (!Globals::error) { \ + print_assert_not_equal_fail(Globals::error, 0, size_t, "%zd"); \ + printf("\nExpected an error to occur," \ + " but no error occured:\n"); \ + return fail; \ + } \ + +#define assert_equal_double(variable, value) \ + if (fabs((double)variable - (double)value) > epsilon) { \ + print_assert_equal_fail(variable, value, double, "%f"); \ + return fail; \ + } + +#define assert_not_equal_double(variable, value) \ + if (fabs((double)variable - (double)value) <= epsilon) { \ + print_assert_not_equal_fail(variable, value, double, "%f"); \ + return fail; \ + } + +#define assert_equal_string(variable, value) \ + if (!string_equal(variable, value)) { \ + print_assert_equal_fail(variable.data, value, char*, "%s"); \ + return fail; \ + } + +#define assert_equal_type(node, _type) \ + if (node->type != _type) { \ + print_assert_equal_fail( \ + lisp_object_type_to_string(node->type), \ + lisp_object_type_to_string(_type), char*, "%s"); \ + return fail; \ + } \ + +#define assert_null(variable) \ + assert_equal_int(variable, nullptr) + +#define assert_not_null(variable) \ + assert_not_equal_int(variable, nullptr) + +#define invoke_test(name) \ + fputs("" #name ":", stdout); \ + if (name() == pass) { \ + for(size_t i = strlen(#name); i < 70; ++i) \ + fputs((i%3==1)? "." : " ", stdout); \ + fputs(console_green "passed\n" console_normal, stdout); \ + } \ + else { \ + result = false; \ + for(int i = -1; i < 70; ++i) \ + fputs((i%3==1)? "." : " ", stdout); \ + fputs(console_red "failed\n" console_normal, stdout); \ + if(Globals::error) { \ + free(Globals::error); \ + Globals::error = nullptr; \ + } \ + } \ + +#define invoke_test_script(name) \ + fputs("" name ":", stdout); \ + if (test_file("tests/" name ".slime") == pass) { \ + for(size_t i = strlen(name); i < 70; ++i) \ + fputs((i%3==1)? "." : " ", stdout); \ + fputs(console_green "passed\n" console_normal, stdout); \ + } \ + else { \ + result = false; \ + for(int i = -1; i < 70; ++i) \ + fputs((i%3==1)? "." : " ", stdout); \ + fputs(console_red "failed\n" console_normal, stdout); \ + if(Globals::error) { \ + free(Globals::error); \ + Globals::error = nullptr; \ + } \ + } + + proc test_array_lists_adding_and_removing() -> testresult { + // test adding and removing + Array_List list; + list.alloc(); + defer { + list.dealloc(); + }; + list.append(1); + list.append(2); + list.append(3); + list.append(4); + + assert_equal_int(list.next_index, 4); + + list.remove_index(0); + + assert_equal_int(list.next_index, 3); + assert_equal_int(list[0], 4); + assert_equal_int(list[1], 2); + assert_equal_int(list[2], 3); + + list.remove_index(2); + + assert_equal_int(list.next_index, 2); + assert_equal_int(list[0], 4); + assert_equal_int(list[1], 2); + + return pass; + } + + proc test_array_lists_sorting() -> testresult { + // test adding and removing + Array_List list; + list.alloc(); + defer { + list.dealloc(); + }; + + list.append(1); + list.append(2); + list.append(3); + list.append(4); + + list.sort(); + + assert_equal_int(list.next_index, 4); + + assert_equal_int(list[0], 1); + assert_equal_int(list[1], 2); + assert_equal_int(list[2], 3); + assert_equal_int(list[3], 4); + + list.append(0); + list.append(5); + + assert_equal_int(list.next_index, 6); + + list.sort(); + + assert_equal_int(list[0], 0); + assert_equal_int(list[1], 1); + assert_equal_int(list[2], 2); + assert_equal_int(list[3], 3); + assert_equal_int(list[4], 4); + assert_equal_int(list[5], 5); + + return pass; + } + + proc test_array_lists_searching() -> testresult { + Array_List list; + list.alloc(); + defer { + list.dealloc(); + }; + + list.append(1); + list.append(2); + list.append(3); + list.append(4); + + int index = list.sorted_find(3); + assert_equal_int(index, 2); + + index = list.sorted_find(1); + assert_equal_int(index, 0); + + index = list.sorted_find(5); + assert_equal_int(index, -1); + + return pass; + } + + proc test_parse_atom() -> testresult { + int index_in_text = 0; + char string[] = + "123 -1.23e-2 " // numbers + "\"asd\" " // strings + ":key1 :key:2 " // keywords + "sym +"; // symbols + + // test numbers + Lisp_Object* result = Parser::parse_atom(string, &index_in_text); + + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, 123); + + ++index_in_text; + + result = Parser::parse_atom(string, &index_in_text); + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, -1.23e-2); + + // test strings + ++index_in_text; + + result = Parser::parse_atom(string, &index_in_text); + assert_equal_type(result, Lisp_Object_Type::String); + assert_equal_string(result->value.string, "asd"); + + // test keywords + ++index_in_text; + + result = Parser::parse_atom(string, &index_in_text); + assert_equal_type(result, Lisp_Object_Type::Keyword); + assert_equal_string(result->value.symbol, "key1"); + + ++index_in_text; + + result = Parser::parse_atom(string, &index_in_text); + assert_equal_type(result, Lisp_Object_Type::Keyword); + assert_equal_string(result->value.symbol, "key:2"); + + // test symbols + ++index_in_text; + + result = Parser::parse_atom(string, &index_in_text); + assert_equal_type(result, Lisp_Object_Type::Symbol); + assert_equal_string(result->value.symbol, "sym"); + + ++index_in_text; + + result = Parser::parse_atom(string, &index_in_text); + assert_equal_type(result, Lisp_Object_Type::Symbol); + assert_equal_string(result->value.symbol, "+"); + + return pass; + } + + proc test_parse_expression() -> testresult { + int index_in_text = 0; + char string[] = "(fun + 12)"; + + Lisp_Object* result = Parser::parse_expression(string, &index_in_text); + assert_no_error(); + + assert_equal_type(result, Lisp_Object_Type::Pair); + assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); + assert_equal_string(result->value.pair.first->value.symbol, "fun"); + + result = result->value.pair.rest; + + assert_equal_type(result, Lisp_Object_Type::Pair); + assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); + assert_equal_string(result->value.pair.first->value.symbol, "+"); + + result = result->value.pair.rest; + + assert_equal_type(result, Lisp_Object_Type::Pair); + assert_equal_type(result->value.pair.first, Lisp_Object_Type::Number); + assert_equal_double(result->value.pair.first->value.number, 12); + + result = result->value.pair.rest; + + assert_equal_type(result, Lisp_Object_Type::Nil); + + char string2[] = "(define fun (lambda (x) (+ 5 (* x x ))))"; + index_in_text = 0; + + result = Parser::parse_expression(string2, &index_in_text); + assert_no_error(); + + assert_equal_type(result, Lisp_Object_Type::Pair); + assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); + assert_equal_string(result->value.pair.first->value.symbol, "define"); + + result = result->value.pair.rest; + + assert_equal_type(result, Lisp_Object_Type::Pair); + assert_equal_type(result->value.pair.first, Lisp_Object_Type::Symbol); + assert_equal_string(result->value.pair.first->value.symbol, "fun"); + + result = result->value.pair.rest; + + assert_equal_type(result, Lisp_Object_Type::Pair); + assert_equal_type(result->value.pair.first, Lisp_Object_Type::Pair); + assert_equal_type(result->value.pair.first->value.pair.first, Lisp_Object_Type::Symbol); + assert_equal_string(result->value.pair.first->value.pair.first->value.symbol, "lambda"); + + result = result->value.pair.rest; + + return pass; + } + + proc test_built_in_add() -> testresult { + char exp_string[] = "(+ 10 4)"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string); + Lisp_Object* result; + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, 14); + + return pass; + } + + proc test_built_in_substract() -> testresult { + char exp_string[] = "(- 10 4)"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string); + Lisp_Object* result; + + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, 6); + + return pass; + } + + + proc test_built_in_multiply() -> testresult { + char exp_string[] = "(* 10 4)"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string); + Lisp_Object* result; + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, 40); + + return pass; + } + + + proc test_built_in_divide() -> testresult { + char exp_string[] = "(/ 20 4)"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string); + Lisp_Object* result; + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, 5); + + return pass; + } + + + proc test_built_in_if() -> testresult { + char exp_string1[] = "(if 1 4 5)"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string1); + Lisp_Object* result; + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, 4); + + char exp_string2[] = "(if () 4 5)"; + expression = Parser::parse_single_expression(exp_string2); + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Number); + assert_equal_double(result->value.number, 5); + + return pass; + } + + proc test_built_in_and() -> testresult { + char exp_string1[] = "(and 1 \"asd\" 4)"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string1); + Lisp_Object* result; + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::T); + + // a false case + char exp_string2[] = "(and () \"asd\" 4)"; + expression = Parser::parse_single_expression(exp_string2); + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Nil); + + return pass; + } + + proc test_built_in_or() -> testresult { + char exp_string1[] = "(or \"asd\" nil)"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string1); + Lisp_Object* result; + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::T); + + // a false case + char exp_string2[] = "(or () ())"; + expression = Parser::parse_single_expression(exp_string2); + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Nil); + + return pass; + } + + + proc test_built_in_not() -> testresult { + char exp_string1[] = "(not ())"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string1); + Lisp_Object* result; + try result = eval_expr(expression); + + // a true case + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::T); + + // a false case + char exp_string2[] = "(not \"asd xD\")"; + expression = Parser::parse_single_expression(exp_string2); + try result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Nil); + + return pass; + } + + proc test_built_in_type() -> testresult { + // Environment* env; + // try env = get_root_environment(); + + // normal type testing + char exp_string1[] = "(begin (define a 10)(type a))"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string1); + Lisp_Object* result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Keyword); + assert_equal_string(result->value.symbol, "number"); + + // setting user type + char exp_string2[] = "(begin (set-type! a :my-type)(type a))"; + expression = Parser::parse_single_expression(exp_string2); + result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Keyword); + assert_equal_string(result->value.symbol, "my-type"); + + // // trying to set invalid user type + // char exp_string3[] = "(begin (set-type! a \"wrong tpye\")(type a))"; + // expression = Parser::parse_single_expression(exp_string3); + // assert_no_error(); + + // ignore_logging { + // dont_break_on_errors { + // result = eval_expr(expression); + // } + // } + + // assert_error(); + // delete_error(); + + // deleting user type + char exp_string4[] = "(begin (delete-type! a)(type a))"; + expression = Parser::parse_single_expression(exp_string4); + result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Keyword); + assert_equal_string(result->value.symbol, "number"); + + return pass; + } + + proc test_singular_t_and_nil() -> testresult { + // nil testing + char exp_string1[] = "()"; + char exp_string2[] = "nil"; + Lisp_Object* expression = Parser::parse_single_expression(exp_string1); + Lisp_Object* result = eval_expr(expression); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Nil); + assert_equal_int(expression, result); + + Lisp_Object* expression2 = Parser::parse_single_expression(exp_string2); + Lisp_Object* result2 = eval_expr(expression2); + + assert_no_error(); + assert_not_null(result); + assert_equal_type(result, Lisp_Object_Type::Nil); + assert_equal_int(result, result2); + assert_equal_int(expression, Memory::nil); + + // t testing + char exp_string3[] = "t"; + Lisp_Object* expression3 = Parser::parse_single_expression(exp_string3); + Lisp_Object* result3 = eval_expr(expression3); + + assert_no_error(); + assert_not_null(result3); + + return pass; + } + + proc test_singular_symbols() -> testresult { + auto cc_s_aa = Memory::get_symbol("aa"); + auto cc_s_aa2 = Memory::get_symbol("aa2"); + + String s1 = Memory::create_string("aa"); + String s2 = Memory::create_string("aa2"); + + auto s_s_aa = Memory::get_symbol(s1); + auto s_s_aa2 = Memory::get_symbol(s2); + + free(s1.data); + free(s2.data); + + assert_equal_int(cc_s_aa, s_s_aa); + assert_equal_int(cc_s_aa2, s_s_aa2); + assert_not_equal_int(cc_s_aa, cc_s_aa2); + + return pass; + } + + proc test_file(const char* file) -> testresult { + profile_with_name(file); + // Memory::reset(); + // assert_no_error(); + + push_environment(Memory::create_child_environment(get_current_environment())); + String name = Memory::create_string(file); + built_in_load(name); + free(name.data); + assert_no_error(); + pop_environment(); + + return pass; + } + + proc run_all_tests() -> bool { + profile_this(); + + bool result = true; + try Memory::init(); + + push_environment(Memory::create_child_environment( + get_current_environment())); + printf("-- Util --\n"); + invoke_test(test_array_lists_adding_and_removing); + invoke_test(test_array_lists_sorting); + invoke_test(test_array_lists_searching); + + printf("\n -- Parsing --\n"); + invoke_test(test_parse_atom); + invoke_test(test_parse_expression); + + printf("\n-- Built ins --\n"); + invoke_test(test_built_in_add); + invoke_test(test_built_in_substract); + invoke_test(test_built_in_multiply); + invoke_test(test_built_in_divide); + invoke_test(test_built_in_if); + invoke_test(test_built_in_and); + invoke_test(test_built_in_or); + invoke_test(test_built_in_not); + // invoke_test(test_built_in_type); + + printf("\n-- Memory management --\n"); + invoke_test(test_singular_t_and_nil); + invoke_test(test_singular_symbols); + + pop_environment(); + printf("\n-- Test Files --\n"); + + invoke_test_script("evaluation_of_default_args"); + invoke_test_script("case_and_cond"); + invoke_test_script("lexical_scope"); + invoke_test_script("singular_imports"); + invoke_test_script("hashmaps"); + invoke_test_script("import_and_load"); + invoke_test_script("macro_expand"); + invoke_test_script("sicp"); + invoke_test_script("simple_built_ins"); + // invoke_test_script("modules"); + // invoke_test_script("class_macro"); + // invoke_test_script("automata"); + // invoke_test_script("alists"); + + return result; + } + +#undef epsilon +#undef testresult +#undef pass +#undef fail + +#undef print_assert_equal_fail +#undef print_assert_not_equal_fail +#undef assert_no_error +#undef assert_equal_int +#undef assert_not_equal_int +#undef assert_equal_double +#undef assert_not_equal_double +#undef assert_equal_string +#undef assert_equal_type +#undef assert_null +#undef assert_not_null +#undef invoke_test +#undef invoke_test_script +}