proc create_extended_environment_for_function_application( Lisp_Object* unevaluated_arguments, Lisp_Object* function) -> Environment* { profile_this; bool is_c_function = Memory::get_type(function) == Lisp_Object_Type::CFunction; Environment* new_env; Lisp_Object* arguments = unevaluated_arguments; Arguments* arg_spec; // NOTE(Felix): Step 1. // - setting the parent environment // - setting the arg_spec // - potentially evaluating the arguments if (is_c_function) { new_env = Memory::create_child_environment(get_root_environment()); arg_spec = &function->value.cFunction->args; // if it is not a special form, evaluate the arguments if (!function->value.cFunction->is_special_form) { try arguments = eval_arguments(arguments); } } else { new_env = Memory::create_child_environment(function->value.function.parent_environment); arg_spec = &function->value.function.args; // if it is a lambda if (function->value.function.type == Function_Type::Lambda) { try arguments = eval_arguments(arguments); } } // NOTE(Felix): Even though we will return the environment at the // end, for defining symbols here for the parameters, it has to be // on the envi stack. push_environment(new_env); defer { pop_environment(); }; // NOTE(Felix): Step 2. // Reading the argument spec and fill in the environment // for the function call Lisp_Object* sym, *val; // used as temp storage to use `try` Lisp_Object_Array_List read_in_keywords; int obligatory_keywords_count = 0; int read_obligatory_keywords_count = 0; proc read_positional_args = [&]() -> void { for (int i = 0; i < arg_spec->positional.symbols.next_index; ++i) { if (Memory::get_type(arguments) != Lisp_Object_Type::Pair) { create_wrong_number_of_arguments_error(arg_spec->positional.symbols.next_index, i); return; } // NOTE(Felix): We have to copy all the arguments, // otherwise we change the program code. XXX(Felix): T C // functions we pass by reference... try_void sym = arg_spec->positional.symbols.data[i]; if (is_c_function) { define_symbol(sym, arguments->value.pair.first); } else { define_symbol( sym, Memory::copy_lisp_object_except_pairs(arguments->value.pair.first)); } arguments = arguments->value.pair.rest; } }; proc read_keyword_args = [&]() -> void { // keyword arguments: use all given ones and keep track of the // added ones (array list), if end of parameters in encountered or // something that is not a keyword is encountered or a keyword // that is not recognized is encoutered, jump out of the loop. read_in_keywords = create_Lisp_Object_array_list(); if (arguments == Memory::nil) return; // 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; else break; } while (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword) { // check if this one is even an accepted keyword bool accepted = false; for (int i = 0; i < arg_spec->keyword.values.next_index; ++i) { if (arguments->value.pair.first == arg_spec->keyword.keywords.data[i]) { accepted = true; break; } } if (!accepted) { // NOTE(Felix): if we are actually done with all the // necessary keywords then we have to count the rest // as :rest here, instead od always creating an error // (special case with default variables) if (read_obligatory_keywords_count == obligatory_keywords_count) return; 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.", &(arguments->value.pair.first->value.symbol.identifier->data)); return; } // check if it was already read in for (int i = 0; i < read_in_keywords.next_index; ++i) { if (arguments->value.pair.first == read_in_keywords.data[i]) { // NOTE(Felix): if we are actually done with all the // necessary keywords then we have to count the rest // as :rest here, instead od always creating an error // (special case with default variables) if (read_obligatory_keywords_count == obligatory_keywords_count) return; create_generic_error( "The function already read the keyword argument ':%s'", &(arguments->value.pair.first->value.symbol.identifier->data)); return; } } // 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 (Memory::get_type(arguments->value.pair.rest) != Lisp_Object_Type::Pair) { create_generic_error( "Attempting to set the keyword argument ':%s', but no value was supplied.", &(arguments->value.pair.first->value.symbol.identifier->data)); return; } // if not set it and then add it to the array list try_void sym = Memory::get_or_create_lisp_object_symbol(arguments->value.pair.first->value.symbol.identifier); // NOTE(Felix): It seems we do not need to evaluate the argument here... if (is_c_function) { try_void define_symbol(sym, arguments->value.pair.rest->value.pair.first); } else { try_void define_symbol( sym, Memory::copy_lisp_object_except_pairs(arguments->value.pair.rest->value.pair.first)); } append_to_array_list(&read_in_keywords, arguments->value.pair.first); ++read_obligatory_keywords_count; // overstep both for next one arguments = arguments->value.pair.rest->value.pair.rest; if (arguments == Memory::nil) { break; } } }; proc check_keyword_args = [&]() -> void { // check if all necessary keywords have been read in 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) { // TODO(Felix): Later compare the keywords, not their strings!! 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.identifier->data); return; } } 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_void sym = Memory::get_or_create_lisp_object_symbol(defined_keyword->value.symbol.identifier); if (is_c_function) { try_void val = arg_spec->keyword.values.data[i]; } else { try_void val = Memory::copy_lisp_object_except_pairs(arg_spec->keyword.values.data[i]); } define_symbol(sym, val); } } } }; proc read_rest_arg = [&]() -> void { if (arguments == Memory::nil) { if (arg_spec->rest) { define_symbol(arg_spec->rest, Memory::nil); } } else { if (arg_spec->rest) { define_symbol( arg_spec->rest, // NOTE(Felix): arguments will be a list, and I THINK // we do not need to copy it... arguments); } 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; } } }; try read_positional_args(); try read_keyword_args(); try check_keyword_args(); try read_rest_arg(); return new_env; } proc apply_arguments_to_function(Lisp_Object* arguments, Lisp_Object* function) -> Lisp_Object* { profile_this; Environment* new_env; try new_env = create_extended_environment_for_function_application(arguments, function); push_environment(new_env); defer { pop_environment(); }; Lisp_Object* result; // if c function: if (Memory::get_type(function) == Lisp_Object_Type::CFunction) try result = function->value.cFunction->body(); else // if lisp function try result = eval_expr(function->value.function.body); return result; } /** 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 */ proc create_arguments_from_lambda_list_and_inject(Lisp_Object* arguments, Lisp_Object* function) -> void { Arguments* result; if (Memory::get_type(function) == Lisp_Object_Type::CFunction) { result = &function->value.cFunction->args; } else { result = &function->value.function.args; } // first init the fields result->positional = create_positional_argument_list(16); result->keyword = create_keyword_argument_list(16); 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 append_to_positional_argument_list( &result->positional, 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; append_to_keyword_argument_list(&result->keyword, keyword, 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; 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."); } append_to_keyword_argument_list(&result->keyword, keyword, 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; 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 eval_arguments(Lisp_Object* arguments) -> Lisp_Object* { profile_this; // int my_out_arguments_length = 0; if (arguments == Memory::nil) { // *(out_arguments_length) = 0; return arguments; } Lisp_Object* evaluated_arguments; try evaluated_arguments = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); Lisp_Object* evaluated_arguments_head = evaluated_arguments; Lisp_Object* current_head = arguments; while (Memory::get_type(current_head) == Lisp_Object_Type::Pair) { try evaluated_arguments_head->value.pair.first = eval_expr(current_head->value.pair.first); evaluated_arguments_head->value.pair.first->sourceCodeLocation = current_head->value.pair.first->sourceCodeLocation; current_head = current_head->value.pair.rest; if (Memory::get_type(current_head) == Lisp_Object_Type::Pair) { try evaluated_arguments_head->value.pair.rest = Memory::create_lisp_object_pair(Memory::nil, Memory::nil); evaluated_arguments_head = evaluated_arguments_head->value.pair.rest; } else if (current_head == Memory::nil) { evaluated_arguments_head->value.pair.rest = current_head; } else { create_parsing_error("Attempting to evaluate ill formed argument list."); return nullptr; } // ++my_out_arguments_length; } // *(out_arguments_length) = my_out_arguments_length; return evaluated_arguments; } proc eval_expr(Lisp_Object* node) -> Lisp_Object* { profile_this; using namespace Globals::Current_Execution; append_to_array_list(&call_stack, node); defer { // NOTE(Felix): We only delete the current entry from the call // stack, if we did not encounter an error, otherwise we neet // to preserve the callstack to print it later. it will be // cleared in log_error(). if (!Globals::error) --call_stack.next_index; }; switch (Memory::get_type(node)) { case Lisp_Object_Type::T: case Lisp_Object_Type::Nil: case Lisp_Object_Type::Number: case Lisp_Object_Type::Keyword: case Lisp_Object_Type::String: case Lisp_Object_Type::Function: case Lisp_Object_Type::CFunction: return node; case Lisp_Object_Type::Symbol: { Lisp_Object* value; try value = lookup_symbol(node, get_current_environment()); return value; } case Lisp_Object_Type::Pair: { Lisp_Object* lispOperator; if (Memory::get_type(node->value.pair.first) != Lisp_Object_Type::CFunction && Memory::get_type(node->value.pair.first) != Lisp_Object_Type::Function) { try lispOperator = eval_expr(node->value.pair.first); } else { lispOperator = node->value.pair.first; } Lisp_Object* arguments = node->value.pair.rest; // check for c function if (Memory::get_type(lispOperator) == Lisp_Object_Type::CFunction) { Lisp_Object* result; try result = apply_arguments_to_function(arguments, lispOperator); return result; } // check for lisp function if (Memory::get_type(lispOperator) == Lisp_Object_Type::Function) { // only for lambdas we evaluate the arguments before // apllying, for the other types, special-lambda and macro // we do not need. Lisp_Object* result; try result = apply_arguments_to_function(arguments, lispOperator); // NOTE(Felix): The parser does not understnad (import ..) // so it cannot expand imported macros at read time // (because at read time, they are not imported yet, this // is done at runtime...). That is why we sometimes have // stray macros fying around, in that case, we expand them // and bake them in, so they do not have to be expanded // later again. We will call this "lazy macro expansion" if (lispOperator->value.function.type == Function_Type::Macro) { // bake in the macro expansion: *node = *result; // eval again because macro try result = eval_expr(result); } return result; } } default: { create_generic_error("%s is not a function.", Lisp_Object_Type_to_string(Memory::get_type(node))); return nullptr; } } } proc is_truthy(Lisp_Object* expression) -> bool { Lisp_Object* result; try result = eval_expr(expression); return result != Memory::nil; } proc interprete_file (char* file_name) -> Lisp_Object* { Memory::init(4096 * 256, 1024, 4096 * 256); Environment* root_env = get_root_environment(); Environment* user_env; try user_env = Memory::create_child_environment(root_env); push_environment(user_env); defer { pop_environment(); }; Lisp_Object* result = built_in_load(Memory::create_string(file_name)); if (Globals::error) { log_error(); delete_error(); return nullptr; } return result; } proc interprete_stdin() -> void { Memory::init(4096 * 256, 1024, 4096 * 256); Environment* root_env = get_root_environment(); Environment* user_env = Memory::create_child_environment(root_env); push_environment(user_env); defer { pop_environment(); }; if (Globals::error) { log_error(); delete_error(); return; } printf("Welcome to the lispy interpreter.\n"); char* line; Lisp_Object* parsed, * evaluated; while (true) { printf("> "); line = read_expression(); defer { free(line); }; parsed = Parser::parse_single_expression(line); if (Globals::error) { log_error(); delete_error(); continue; } evaluated = eval_expr(parsed); if (Globals::error) { log_error(); delete_error(); continue; } if (evaluated != Memory::nil) { print(evaluated); printf("\n"); } } }