namespace Slime { proc create_extended_environment_for_function_application_nrc( // TODO(Felix): pass cs as value as soon as we got rid of // destructors, to prevent destroying it on scope exit Array_List* cs, Lisp_Object* function, int arg_start, int arg_count) -> Environment* { profile_this(); bool is_c_function = function->value.function->is_c; Environment* new_env = Memory::create_child_environment(function->value.function->parent_environment); Arguments* arg_spec = &function->value.function->args; // NOTE(Felix): Step 1. // - setting the parent environment // - setting the arg_spec // - potentially evaluating the 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; read_in_keywords.alloc(); defer { read_in_keywords.dealloc(); }; int obligatory_keywords_count = 0; int read_obligatory_keywords_count = 0; Lisp_Object* next_arg = cs->data[arg_start]; proc read_positional_args = [&] { for (int i = 0; i < arg_spec->positional.symbols.next_index; ++i) { if (arg_count == 0) { 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. // TODO(Felix): Why did we decide this?? sym = arg_spec->positional.symbols.data[i]; if (is_c_function) { define_symbol(sym, next_arg); } else { define_symbol( sym, Memory::copy_lisp_object_except_pairs(next_arg)); } next_arg = cs->data[++arg_start]; --arg_count; } }; proc read_keyword_args = [&] { // debug_break(); // 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 (arg_count == 0) { 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(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 (next_arg == 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.", &(next_arg->value.symbol->data)); return; } // check if it was already read in for (int i = 0; i < read_in_keywords.next_index; ++i) { if (next_arg == 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'", &(next_arg->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 (arg_count == 0) { create_generic_error( "Attempting to set the keyword argument ':%s', but no value was supplied.", &(next_arg->value.symbol->data)); return; } // if not set it and then add it to the array list Lisp_Object* key = next_arg; try_void sym = Memory::get_symbol(key->value.symbol); next_arg = cs->data[++arg_start]; --arg_count; // NOTE(Felix): It seems we do not need to evaluate the argument here... if (is_c_function) { try_void define_symbol(sym, next_arg); } else { try_void define_symbol(sym, Memory::copy_lisp_object_except_pairs(next_arg)); } read_in_keywords.append(key); ++read_obligatory_keywords_count; // overstep both for next one next_arg = cs->data[++arg_start]; --arg_count; if (arg_count == 0) { 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) { 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_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 (arg_count == 0) { if (arg_spec->rest) { define_symbol(arg_spec->rest, Memory::nil); } } else { if (arg_spec->rest) { Lisp_Object* list; try_void list = Memory::create_list(next_arg); Lisp_Object* head = list; next_arg = cs->data[++arg_start]; --arg_count; while (arg_count > 0) { try_void head->value.pair.rest = Memory::create_list(next_arg); head = head->value.pair.rest; next_arg = cs->data[++arg_start]; --arg_count; } define_symbol(arg_spec->rest, list); } 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 (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; 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 nrc_eval(Lisp_Object* expr) -> Lisp_Object* { 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 = [&] { return; // printf("%d\n", cs.next_index); printf("cs:\n "); for (auto lo : cs) { print(lo, true); printf("\n "); } 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::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); } // 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::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); nas->append(NasAction::TM); nas->append(NasAction::Eval); } break; default: { // NOTE(Felix): others are self evaluating // so do nothing } } } 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); } } else { if (pc->value.function->type.lisp_function_type == Lisp_Function_Type::Macro) { push_pc_on_cs(); nas->append(NasAction::Eval); nas->append(NasAction::Step); } else { nas->append(NasAction::Step); } } } break; default: { create_generic_error("The first element of the pair was not a function but: %s", Lisp_Object_Type_to_string(type)); 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]; assert_type(function, Lisp_Object_Type::Function); Environment* extended_env = create_extended_environment_for_function_application_nrc( &cs, function, am+1, cs.next_index-am-1); 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]; } proc eval_expr(Lisp_Object* node) -> Lisp_Object* { return nrc_eval(node); } 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(); try_void parsed = Parser::parse_single_expression(line); free(line); try_void evaluated = nrc_eval(parsed); // try_void evaluated = eval_expr(parsed); if (evaluated != Memory::nil) { print(evaluated); fputs("\n", stdout); } } } }