From e22ffb73547ed5a8360c1e5f8a84b93bfa7a78c1 Mon Sep 17 00:00:00 2001 From: Felix Brendel Date: Tue, 17 Mar 2020 12:06:55 +0100 Subject: [PATCH] Fixed a bug where cs was accessed out of bouds, gensyms, 'and and 'or are now macros --- bin/pre.slime | 33 +++++ src/built_ins.cpp | 42 ++----- src/env.cpp | 6 +- src/eval.cpp | 277 +++++++++++++++++------------------------- src/forward_decls.cpp | 1 + 5 files changed, 162 insertions(+), 197 deletions(-) diff --git a/bin/pre.slime b/bin/pre.slime index c56b1f3..f073d43 100644 --- a/bin/pre.slime +++ b/bin/pre.slime @@ -25,6 +25,39 @@ (define-syntax (mac a) (list + 1 1)) (define-syntax (add . args) (pair '+ args)) +(define-syntax (and . args) + ;; (and cond1 cond2 (cond3 args)) + ;; -> + ;; (if cond1 + ;; (if cond2 + ;; (let ((g (cond3 args))) + ;; (if g + ;; g + ;; ())) + ;; ()) + ;; ()) + (if args + `(,if ,(first args) + ,(apply and (rest args)) + ()) + t)) + +(define-syntax (or . args) + ;; (or cond1 cond2 (cond3 args)) + ;; -> + ;; (if cond1 + ;; t + ;; (if cond2 + ;; t + ;; (if (cond3 args) + ;; t + ;; ()))) + (if args + `(,if ,(first args) + t + ,(apply or (rest args))) + ())) + (define-syntax (when condition . body) "Special form for when multiple actions should be done if a condition is true. diff --git a/src/built_ins.cpp b/src/built_ins.cpp index cc6f6e5..61bcb7f 100644 --- a/src/built_ins.cpp +++ b/src/built_ins.cpp @@ -543,6 +543,14 @@ namespace Slime { 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); @@ -807,40 +815,10 @@ namespace Slime { expr = unquoteSomeExpressions(unquoteSomeExpressions, expr); return expr; }; - define_special((and . args), "TODO") { - profile_with_name("(and)"); - fetch(args); - bool result = true; - in_caller_env { - for_lisp_list (args) { - try result &= is_truthy(it); - if (!result) - return Memory::nil; - } - } - return Memory::t; - }; - define_special((or . args), "TODO") { - profile_with_name("(or)"); - fetch(args); - bool result = false; - in_caller_env { - for_lisp_list (args) { - try result |= is_truthy(it); - if (result) - return Memory::t; - } - } - return Memory::nil; - }; - define_special((not test), "TODO") { + define((not test), "TODO") { profile_with_name("(not)"); fetch(test); - bool truthy; - in_caller_env { - try truthy = is_truthy(test); - } - return (truthy) ? Memory::nil : Memory::t; + return is_truthy(test) ? Memory::nil : Memory::t; }; // // // defun("while", "TODO", __LINE__, cLambda { // // // try arguments_length = list_length(arguments); diff --git a/src/env.cpp b/src/env.cpp index a26c6b0..ab603f9 100644 --- a/src/env.cpp +++ b/src/env.cpp @@ -1,7 +1,11 @@ namespace Slime { proc define_symbol(Lisp_Object* symbol, Lisp_Object* value) -> void { profile_with_comment(&symbol->value.symbol->data); - Environment* env = get_current_environment(); + define_symbol(symbol, value, get_current_environment()); + } + + proc define_symbol(Lisp_Object* symbol, Lisp_Object* value, Environment* env) -> void { + profile_with_comment(&symbol->value.symbol->data); env->hm.set_object((void*)symbol, value); } diff --git a/src/eval.cpp b/src/eval.cpp index 7e630fd..6eaeddb 100644 --- a/src/eval.cpp +++ b/src/eval.cpp @@ -1,38 +1,18 @@ 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_end) -> Environment* { profile_this(); + using namespace Globals::Current_Execution; - int arg_pos = arg_start; + int index_of_next_arg = arg_start; bool is_c_function = function->value.function->is_c; - Environment* new_env = Memory::create_child_environment(function->value.function->parent_environment); + Environment* 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 { @@ -41,201 +21,173 @@ namespace Slime { int obligatory_keywords_count = 0; int read_obligatory_keywords_count = 0; - Lisp_Object* next_arg = cs->data[arg_pos]; - - proc read_positional_args = [&] { - for (int i = 0; i < arg_spec->positional.symbols.next_index; ++i) { - sym = arg_spec->positional.symbols.data[i]; - if (arg_pos == 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-arg_pos, - &sym->value.symbol->data); - return; - } - // NOTE(Felix): We have to copy all the arguments, - // otherwise we change the program code. - // XXX(Felix): To C functions we pass by reference. - // TODO(Felix): Why did we decide this?? - if (is_c_function) { - define_symbol(sym, next_arg); - } else { - define_symbol( - sym, - Memory::copy_lisp_object_except_pairs(next_arg)); - } - assert("cs access index out of range", - arg_pos+1 < cs->next_index); - next_arg = cs->data[++arg_pos]; + 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; } - }; - - 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_pos == arg_end) { - return; + // 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; - else - break; } - while (Memory::get_type(next_arg) == Lisp_Object_Type::Keyword) { + 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 (next_arg == arg_spec->keyword.keywords.data[i]) - { + if (cs.data[index_of_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 we read all we need then we are done here if (read_obligatory_keywords_count == obligatory_keywords_count) - return; + 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.", - &(next_arg->value.symbol->data)); - return; + &(cs.data[index_of_next_arg]->value.symbol->data)); + return nullptr; } - - // check if it was already read in + // This is an accepted kwarg; 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]) + if (cs.data[index_of_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 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) - return; + 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'", - &(next_arg->value.symbol->data)); - return; + &(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 (arg_pos == arg_end) { + if (index_of_next_arg+1 == arg_end) { create_generic_error( "Attempting to set the keyword argument ':%s', but no value was supplied.", - &(next_arg->value.symbol->data)); - return; + &(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 = next_arg; - try_void sym = Memory::get_symbol(key->value.symbol); - next_arg = cs->data[++arg_pos]; + Lisp_Object* key = cs.data[index_of_next_arg]; + try sym = Memory::get_symbol(key->value.symbol); + ++index_of_next_arg; - // NOTE(Felix): It seems we do not need to evaluate the argument here... if (is_c_function) { - try_void define_symbol(sym, next_arg); + try define_symbol(sym, cs.data[index_of_next_arg], env); } else { - try_void define_symbol(sym, - Memory::copy_lisp_object_except_pairs(next_arg)); + 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; - // overstep both for next one - next_arg = cs->data[++arg_pos]; + ++index_of_next_arg; - if (arg_pos == arg_end) { + if (index_of_next_arg == arg_end) { 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); - } + 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; } } - }; - - proc read_rest_arg = [&]() -> void { - if (arg_pos == arg_end) { - if (arg_spec->rest) { - define_symbol(arg_spec->rest, Memory::nil); + 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 { - if (arg_spec->rest) { - - Lisp_Object* list; - try_void list = Memory::create_list(next_arg); - Lisp_Object* head = list; - for (++arg_pos;arg_pos < arg_end; ++arg_pos) { - next_arg = cs->data[arg_pos]; - try_void head->value.pair.rest = Memory::create_list(next_arg); - head = head->value.pair.rest; + // 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(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; + define_symbol(sym, val, env); } } - }; + } - try read_positional_args(); - try read_keyword_args(); - try check_keyword_args(); - try read_rest_arg(); + // 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 new_env; + return env; } @@ -507,7 +459,7 @@ namespace Slime { Environment* extended_env; try extended_env = create_extended_environment_for_function_application_nrc( - &cs, function, am+1, cs.next_index); + function, am+1, cs.next_index); cs.next_index = am; push_environment(extended_env); if (function->value.function->is_c) { @@ -558,11 +510,8 @@ namespace Slime { return cs.data[--cs.next_index]; } - proc is_truthy(Lisp_Object* expression) -> bool { - Lisp_Object* result; - try result = eval_expr(expression); - - return result != Memory::nil; + inline proc is_truthy(Lisp_Object* expression) -> bool { + return expression != Memory::nil; } proc interprete_file (char* file_name) -> Lisp_Object* { diff --git a/src/forward_decls.cpp b/src/forward_decls.cpp index 82434c2..52b485a 100644 --- a/src/forward_decls.cpp +++ b/src/forward_decls.cpp @@ -16,6 +16,7 @@ namespace Slime { 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*);