slime/src/eval.cpp

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