proc create_extended_environment_for_function_application( Lisp_Object* unevaluated_arguments, Lisp_Object* function, bool should_evaluate) -> 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; } else { new_env = Memory::create_child_environment(function->value.function->parent_environment); arg_spec = &function->value.function->args; } if (should_evaluate) { 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` 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_parsing_error("Wrong number of arguments."); 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... 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. 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->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->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->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); // 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)); } read_in_keywords.append(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->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); 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, 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 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->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; 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 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 = copy_scl(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; call_stack.append(node); defer { --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, !lispOperator->value.cFunction->is_special_form); 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, lispOperator->value.function->type == Function_Type::Lambda); // 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 = *Memory::copy_lisp_object(result); result->sourceCodeLocation = copy_scl(result->sourceCodeLocation); // eval again because macro try result = eval_expr(result); } return result; } create_generic_error("The first element of the pair was not a function but: %s", Lisp_Object_Type_to_string(Memory::get_type(lispOperator))); return nullptr; } 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* { try Memory::init(4096 * 256); Lisp_Object* result; try result = built_in_load(Memory::create_string(file_name)); return result; } proc interprete_stdin() -> void { try_void Memory::init(4096 * 256* 100); printf("Welcome to the lispy interpreter.\n"); char* line; Lisp_Object* parsed, * evaluated; while (true) { [&] { delete_error(); fputs("> ", stdout); line = read_expression(); defer { free(line); }; try_void parsed = Parser::parse_single_expression(line); try_void evaluated = eval_expr(parsed); if (evaluated != Memory::nil) { print(evaluated); fputs("\n", stdout); } }(); } }