slime/src/eval.cpp

proc apply_arguments_to_function(Lisp_Object* arguments, Function* function) -> Lisp_Object* {
    Environment* new_env;
    try new_env = Memory::create_child_environment(function->parent_environment);
    push_environment(new_env);
    defer {
        pop_environment();
    };

    Lisp_Object* sym, *val; // used as temp storage to use `try`
    String_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 < function->positional_arguments->next_index; ++i) {
            if (Memory::get_type(arguments) != Lisp_Object_Type::Pair) {
                create_wrong_number_of_arguments_error(function->positional_arguments->next_index, i);
                return;
            }
            // TODO(Felix): here we create new lisp_object_symbols from
            // their identifiers but before we converted them to
            // strings from symbols... Wo maybe just use the symbols?

            // NOTE(Felix): We have to copy all the arguments, otherwise
            // we change the program code.
            try_void sym = function->positional_arguments->symbols[i];
            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_String_array_list();

        if (arguments == Memory::nil)
            return;

        // find out how many keyword args we /have/ to read
        for (int i = 0; i < function->keyword_arguments->next_index; ++i) {
            if (function->keyword_arguments->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 < function->keyword_arguments->next_index; ++i) {
                if (string_equal(
                        arguments->value.pair.first->value.symbol.identifier,
                        function->keyword_arguments->keywords[i]->value.symbol.identifier))
                {
                    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 (string_equal(
                        arguments->value.pair.first->value.symbol.identifier,
                        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...
            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->value.symbol.identifier);
            ++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 < function->keyword_arguments->next_index; ++i) {
            String* defined_keyword = function->keyword_arguments->keywords[i]->value.symbol.identifier;
            bool was_set = false;
            for (int j = 0; j < read_in_keywords->next_index; ++j) {
                if (string_equal(
                        read_in_keywords->data[j],
                        defined_keyword))
                {
                    was_set = true;
                    break;
                }
            }
            if (function->keyword_arguments->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->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);
                    try_void val = Memory::copy_lisp_object_except_pairs(function->keyword_arguments->values->data[i]);
                    define_symbol(sym, val);
                }
            }
        }
    };

    proc read_rest_arg = [&]() -> void {
        if (arguments == Memory::nil) {
            if (function->rest_argument) {
                try_void sym = Memory::get_or_create_lisp_object_symbol(function->rest_argument);
                define_symbol(sym, Memory::nil);
            }
        } else {
            if (function->rest_argument) {
                try_void sym = Memory::get_or_create_lisp_object_symbol(function->rest_argument);
                define_symbol(
                    sym,
                    // 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();

    Lisp_Object* result;
    try result = eval_expr(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 parse_argument_list(Lisp_Object* arguments, Function* function) -> void {
    // first init the fields
    function->positional_arguments = create_positional_argument_list(16);
    function->keyword_arguments    = create_keyword_argument_list(16);
    function->rest_argument        = nullptr;

    // okay let's try to read some positional arguments
    while (Memory::get_type(arguments) == Lisp_Object_Type::Pair) {
        if (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword) {
            if (string_equal(arguments->value.pair.first->value.symbol.identifier, "keys") ||
                string_equal(arguments->value.pair.first->value.symbol.identifier, "rest"))
                break;
            else {
                create_parsing_error("A non recognized marker was found "
                                     "in the lambda list: ':%s'",
                                     &arguments->value.pair.first->value.symbol.identifier->data);
                return;
            }
        }

        if (Memory::get_type(arguments->value.pair.first) != Lisp_Object_Type::Symbol) {
            create_parsing_error("Only symbols and keywords can be "
                                 "parsed here, but found '%s'",
                                 Lisp_Object_Type_to_string(Memory::get_type(arguments->value.pair.first)));
            return;
        }

        // okay wow we found an actual symbol
        append_to_positional_argument_list(
            function->positional_arguments,
            arguments->value.pair.first);

        arguments = arguments->value.pair.rest;
    }

    // okay we are done with positional arguments, lets check for
    // keywords,
    if (Memory::get_type(arguments) != Lisp_Object_Type::Pair) {
        if (arguments != Memory::nil)
            create_parsing_error("The lambda list must be nil terminated.");
        return;
    }

    if (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword &&
        string_equal(arguments->value.pair.first->value.symbol.identifier, "keys"))
    {
        arguments = arguments->value.pair.rest;
        if (Memory::get_type(arguments) != Lisp_Object_Type::Pair) {
            create_parsing_error("Actual keys have to follow the :keys indicator.");
        }
        // if (arguments->value.pair.first->type != Lisp_Object_Type::Symbol) {
        //     create_parsing_error(
        //         "Only symbols can be parsed here, but found '%s'.",
        //         Lisp_Object_Type_to_string(arguments->value.pair.first->type));
        //     return;
        // }

        while (Memory::get_type(arguments) == Lisp_Object_Type::Pair) {
            if (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword) {
                if (string_equal(arguments->value.pair.first->value.symbol.identifier, "rest"))
                    break;
                else {
                    create_parsing_error(
                        "Only the :rest keyword can be parsed here, but got ':%s'.",
                        &arguments->value.pair.first->value.symbol.identifier->data);
                    return;
                }
            }

            if (Memory::get_type(arguments->value.pair.first) != Lisp_Object_Type::Symbol) {
                create_parsing_error(
                    "Only symbols can be parsed here, but found '%s'.",
                    Lisp_Object_Type_to_string(Memory::get_type(arguments->value.pair.first)));
                return;
            }

            // we found a symbol (arguments->value.pair->first) for
            // the keyword args! Let's check if the next arguement is
            // :defaults-to
            Lisp_Object* next = arguments->value.pair.rest;
            if (Memory::get_type(next) == Lisp_Object_Type::Pair &&
                Memory::get_type(next->value.pair.first) == Lisp_Object_Type::Keyword &&
                string_equal(next->value.pair.first->value.symbol.identifier,
                              "defaults-to"))
            {
                // check if there is a next argument too, otherwise it
                // would be an error
                next = next->value.pair.rest;
                if (Memory::get_type(next) == Lisp_Object_Type::Pair) {
                    Lisp_Object* ret;
                    push_environment(function->parent_environment);
                    defer {
                        pop_environment();
                    };
                    try_void ret = eval_expr(next->value.pair.first);
                    append_to_keyword_argument_list(function->keyword_arguments,
                                                    arguments->value.pair.first,
                                                    ret);
                    arguments = next->value.pair.rest;
                } else {
                    create_parsing_error("Expecting a value after 'defaults-to'");
                    return;
                }
            } else {
                // No :defaults-to, so just add it to the list
                append_to_keyword_argument_list(function->keyword_arguments,
                                                arguments->value.pair.first,
                                                nullptr);
                arguments = next;
            }
        }
    }


    // 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)
            create_parsing_error("The lambda list must be nil terminated.");
        return;
    }

    if (Memory::get_type(arguments->value.pair.first) == Lisp_Object_Type::Keyword &&
        string_equal(arguments->value.pair.first->value.symbol.identifier, "rest"))
    {
        arguments = arguments->value.pair.rest;
        if (// arguments->type != Lisp_Object_Type::Pair ||
            Memory::get_type(arguments->value.pair.first) != Lisp_Object_Type::Symbol)
        {
            create_parsing_error("After the 'rest' marker there must follow a symbol.");
            return;
        }
        function->rest_argument = arguments->value.pair.first->value.symbol.identifier;
        if (arguments->value.pair.rest != Memory::nil) {
            create_parsing_error("The lambda list must end after the rest symbol");
        }
    } else {
        printf("this should not happen?");
        create_generic_error("What is happening?");
    }
}


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 extract_keyword_value(char* keyword, Parsed_Arguments* args) -> Lisp_Object* {
    // NOTE(Felix): This will be a hashmap lookup later
    for (int i = 0; i < args->keyword_keys->next_index; ++i) {
        if (string_equal(args->keyword_keys->data[i]->value.symbol.identifier, keyword))
            return args->keyword_values->data[i];
    }
    return nullptr;
}

proc eval_arguments(Lisp_Object* arguments, int *out_arguments_length) -> Lisp_Object* {
    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* {
    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;
        int arguments_length;

        // check for c function
        if (Memory::get_type(lispOperator) == Lisp_Object_Type::CFunction) {
            Lisp_Object* result;
            try result = lispOperator->value.cFunction->function(arguments);
            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.
            if (lispOperator->value.function.type == Function_Type::Lambda) {
                try arguments = eval_arguments(arguments, &arguments_length);
            }

            Lisp_Object* result;
            try result = apply_arguments_to_function(arguments, &lispOperator->value.function);

            // 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) {
                *node = *result;
                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;
    }

    Parser::environment_for_macros = user_env;

    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");
        }

    }
}