slime/src/eval.cpp

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<Lisp_Object*>* 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<Lisp_Object*> 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<NasAction>* 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: {
                /* |  <cond>  |
                   |  <then>  |
                   |  <else>  |
                   |   ....   | */
                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: {
                /* |  <thing>   |
                   |  <symbol>  |
                   |    ....    | */
                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);
            }
        }
    }
}