slime/src/io.cpp

namespace Slime {
    proc string_equal(const char input[], const char check[]) -> bool {
        if (input == check) return true;

        for(int i = 0; input[i] == check[i]; i++) {
            if (input[i] == '\0')
                return true;
        }

        return false;
    }

    proc string_equal(String str, const char check[]) -> bool {
        return string_equal(Memory::get_c_str(str), check);
    }

    proc string_equal(const char check[], String str) -> bool {
        return string_equal(Memory::get_c_str(str), check);
    }

    proc string_equal(String str1, String str2) -> bool {
        return string_equal(Memory::get_c_str(str1), Memory::get_c_str(str2));
    }

    proc get_nibble(char c) -> char {
        if (c >= 'A' && c <= 'F')
            return (c - 'A') + 10;
        else if (c >= 'a' && c <= 'f')
            return (c - 'a') + 10;
        return (c - '0');
    }

    proc escape_string(char* in) -> char* {
        // TODO(Felix): add more escape sequences
        int i = 0, count = 0;
        while (in[i] != '\0') {
            switch (in[i]) {
            case '\\':
            case '\n':
            case '\t':
                ++count;
            default: break;
            }
            ++i;
        }

        char* ret = (char*)malloc((i+count+1)*sizeof(char));

        // copy in
        i = 0;
        int j = 0;
        while (in[i] != '\0') {
            switch (in[i]) {
            case '\\': ret[j++] = '\\'; ret[j++] = '\\'; break;
            case '\n': ret[j++] = '\\'; ret[j++] = 'n';  break;
            case '\t': ret[j++] = '\\'; ret[j++] = 't';  break;
            default: ret[j++] = in[i];
            }
            ++i;
        }
        ret[j++] = '\0';
        return ret;
    }

    proc unescape_string(char* in) -> int {
        if (!in) return 0;

        char *out = in, *p = in;
        const char *int_err = nullptr;

        while (*p && !int_err) {
            if (*p != '\\') {
                /* normal case */
                *out++ = *p++;
            } else {
                /* escape sequence */
                switch (*++p) {
                case '0': *out++ = '\a'; ++p; break;
                case 'a': *out++ = '\a'; ++p; break;
                case 'b': *out++ = '\b'; ++p; break;
                case 'f': *out++ = '\f'; ++p; break;
                case 'n': *out++ = '\n'; ++p; break;
                case 'r': *out++ = '\r'; ++p; break;
                case 't': *out++ = '\t'; ++p; break;
                case 'v': *out++ = '\v'; ++p; break;
                case '"':
                case '\'':
                case '\\':
                    *out++ = *p++;
                case '?':
                    break;
                case 'x':
                case 'X':
                    if (!isxdigit(p[1]) || !isxdigit(p[2])) {
                        create_parsing_error(
                            "The string '%s' at %s:%d:%d could not be unescaped. "
                            "(Invalid character on hexadecimal escape at char %d)",
                            in, Parser::parser_file, Parser::parser_line, Parser::parser_col,
                            (p+1)-in);
                    } else {
                        *out++ = (char)(get_nibble(p[1]) * 0x10 + get_nibble(p[2]));
                        p += 3;
                    }
                    break;
                default:
                    create_parsing_error(
                        "The string '%s' at %s:%d:%d could not be unescaped. "
                        "(Unexpected '\\' with no escape sequence at char %d)",
                        in, Parser::parser_file, Parser::parser_line, Parser::parser_col,
                        (p+1)-in);
                }
            }
        }

        /* Set the end of string. */
        *out = '\0';
        return (int)(out - in);
    }

    proc read_entire_file(char* filename) -> char* {
        profile_with_comment(filename);
        char *fileContent = nullptr;
        FILE *fp = fopen(filename, "r");
        if (fp) {
            /* Go to the end of the file. */
            if (fseek(fp, 0L, SEEK_END) == 0) {
                /* Get the size of the file. */
                long bufsize = ftell(fp) + 1;
                if (bufsize == 0) {
                    fputs("Empty file", stderr);
                    goto closeFile;
                }

                /* Go back to the start of the file. */
                if (fseek(fp, 0L, SEEK_SET) != 0) {
                    fputs("Error reading file", stderr);
                    goto closeFile;
                }

                /* Allocate our buffer to that size. */
                fileContent = (char*)calloc(bufsize, sizeof(char));

                /* Read the entire file into memory. */
                size_t newLen = fread(fileContent, sizeof(char), bufsize, fp);

                fileContent[newLen] = '\0';
                if (ferror(fp) != 0) {
                    fputs("Error reading file", stderr);
                }
            }
          closeFile:
            fclose(fp);
        }

        return fileContent;
        /* Don't forget to call free() later! */
    }

    proc read_expression() -> char* {
        char* line = (char*)malloc(100);

        if(line == nullptr)
            return nullptr;

        char* linep = line;
        size_t lenmax = 100, len = lenmax;
        int c;

        int nesting = 0;

        while (true) {
            c = fgetc(stdin);
            if(c == EOF)
                break;

            if(--len == 0) {
                len = lenmax;
                char * linen = (char*)realloc(linep, lenmax *= 2);

                if(linen == nullptr) {
                    free(linep);
                    return nullptr;
                }
                line = linen + (line - linep);
                linep = linen;
            }

            *line = (char)c;
            if(*line == '(')
                ++nesting;
            else if(*line == ')')
                --nesting;
            else if(*line == '\n')
                if (nesting == 0)
                    break;
            line++;
        }
        (*line)--; // we dont want the \n actually
        *line = '\0';

        return linep;
    }

    proc read_line() -> char* {
        char* line = (char*)malloc(100), * linep = line;
        size_t lenmax = 100, len = lenmax;
        int c;

        int nesting = 0;

        if(line == nullptr)
            return nullptr;

        for(;;) {
            c = fgetc(stdin);
            if(c == EOF)
                break;

            if(--len == 0) {
                len = lenmax;
                char* linen = (char*)realloc(linep, lenmax *= 2);

                if(linen == nullptr) {
                    free(linep);
                    return nullptr;
                }
                line = linen + (line - linep);
                linep = linen;
            }

            *line = (char)c;
            if(*line == '(')
                ++nesting;
            else if(*line == ')')
                --nesting;
            else if(*line == '\n')
                if (nesting == 0)
                    break;
            line++;
        }
        (*line)--; // we dont want the \n actually
        *line = '\0';

        return linep;
    }

    proc log_message(Log_Level type, const char* message) -> void {
        if (type > Globals::log_level)
            return;

        const char* prefix;
        switch (type) {
        case Log_Level::Critical: prefix = "CRITICAL"; break;
        case Log_Level::Warning:  prefix = "WARNING";  break;
        case Log_Level::Info:     prefix = "INFO";     break;
        case Log_Level::Debug:    prefix = "DEBUG";    break;
        default: return;
        }
        printf("%s: %s\n",prefix, message);
    }

    char* wchar_to_char(const wchar_t* pwchar) {
        // get the number of characters in the string.
        int currentCharIndex = 0;
        char currentChar = (char)pwchar[currentCharIndex];

        while (currentChar != '\0')
        {
            currentCharIndex++;
            currentChar = (char)pwchar[currentCharIndex];
        }

        const int charCount = currentCharIndex + 1;

        // allocate a new block of memory size char (1 byte) instead of wide char (2 bytes)
        char* filePathC = (char*)malloc(sizeof(char) * charCount);

        for (int i = 0; i < charCount; i++)
        {
            // convert to char (1 byte)
            char character = (char)pwchar[i];

            *filePathC = character;

            filePathC += sizeof(char);

        }
        filePathC += '\0';

        filePathC -= (sizeof(char) * charCount);

        return filePathC;
    }

    const wchar_t* char_to_wchar(const char* c) {
        const size_t cSize = strlen(c)+1;
        wchar_t* wc = new wchar_t[cSize];
        mbstowcs (wc, c, cSize);

        return wc;
    }

    proc string_buider_to_string(Array_List<char*> string_builder) -> char* {
        size_t len = 1;
        int idx = 0;
        for (auto str : string_builder) {
            len += strlen(str);
        }

        char* res = (char*)(malloc(sizeof(char) * len));
        res[0] = '\0';

        for (auto str : string_builder) {
            strcat(res, str);
        }

        return res;
    }

    proc lisp_object_to_string(Lisp_Object* node, bool print_repr) -> char* {
        char* temp;
        Array_List<char*> string_builder;
        string_builder.alloc();
        defer {
            string_builder.dealloc();
        };

        switch (Memory::get_type(node)) {
        case (Lisp_Object_Type::Nil):          return strdup("()");
        case (Lisp_Object_Type::T):            return strdup("t");
        case (Lisp_Object_Type::Continuation): return strdup("[continuation]");
        case (Lisp_Object_Type::Pointer):      return strdup("[pointer]");
        case (Lisp_Object_Type::Number): {
            if (abs(node->value.number - (int)node->value.number) < 0.000001f)
                asprintf(&temp, "%d", (int)node->value.number);
            else
                asprintf(&temp, "%f", node->value.number);
            return temp;
        }
        case (Lisp_Object_Type::Keyword): {
            asprintf(&temp, ":%s", Memory::get_c_str(node->value.symbol));
            return temp;
        }
        case (Lisp_Object_Type::Symbol): {
            asprintf(&temp, "%s", Memory::get_c_str(node->value.symbol));
            return temp;
        }
        case (Lisp_Object_Type::HashMap): {
            for_hash_map (*(node->value.hashMap)) {
                char* k = lisp_object_to_string(key, true);
                char* v = lisp_object_to_string((Lisp_Object*)value, true);
                asprintf(&temp, " %s -> %s\n", k, v);
                string_builder.append(temp);
                free(v);
                free(k);
            }

            temp = string_buider_to_string(string_builder);
            // free all asprintfs
            for (auto str : string_builder) {
                free(str);
            }
            return temp;
        }
        case (Lisp_Object_Type::String): {
            if (print_repr) {
                char* escaped = escape_string(Memory::get_c_str(node->value.string));
                asprintf(&temp, "\"%s\"", escaped);
                free(escaped);
                return temp;
            } else
                return strdup(Memory::get_c_str(node->value.string));
        } break;
        case (Lisp_Object_Type::Vector): {

            string_builder.append(strdup("["));
            if (node->value.vector.length > 0)
                string_builder.append(lisp_object_to_string(node->value.vector.data, print_repr));
            for (int i = 1; i < node->value.vector.length; ++i) {
                string_builder.append(strdup(" "));
                string_builder.append(lisp_object_to_string(node->value.vector.data+i, print_repr));
            }
            string_builder.append(strdup("]"));
            temp = string_buider_to_string(string_builder);
            for (auto str : string_builder) {
                free(str);
            }
            return temp;
        } break;
        case (Lisp_Object_Type::Function): {
            if (node->userType) {
                asprintf(&temp, "[%s]", Memory::get_c_str(node->userType->value.symbol));
                return temp;
            }
            if (node->value.function->is_c) {
                // NOTE(Felix): try to find the symbol it is bound to
                // in global env
                Lisp_Object* name = (Lisp_Object*)(get_root_environment()->hm.search_key_to_object(node));
                if (name) {
                    switch (node->value.function->type.c_function_type) {
                    case C_Function_Type::cFunction: asprintf(&temp, "[c-function %s]",name->value.symbol.data); break;
                    case C_Function_Type::cSpecial:  asprintf(&temp, "[c-special %s]", name->value.symbol.data); break;
                    case C_Function_Type::cMacro:    asprintf(&temp, "[c-macro %s]",   name->value.symbol.data); break;
                    default:                         return strdup("[c-??]");
                    }
                } else {
                    switch (node->value.function->type.c_function_type) {
                    case C_Function_Type::cFunction: asprintf(&temp, "[c-function]"); break;
                    case C_Function_Type::cSpecial:  asprintf(&temp, "[c-special]"); break;
                    case C_Function_Type::cMacro:    asprintf(&temp, "[c-macro]"); break;
                    default:                         return strdup("[c-??]");
                    }
                }
                return temp;
            } else {
                switch (node->value.function->type.lisp_function_type) {
                case Lisp_Function_Type::Lambda: return strdup("[lambda]");
                case Lisp_Function_Type::Macro:  return strdup("[macro]");
                default:                         return strdup("[??]");
                }
            }
        } break;
        case (Lisp_Object_Type::Pair): {
            // TODO
            Lisp_Object* head = node;

            defer {
                for (auto str : string_builder) {
                    free(str);
                }
            };
            // first check if it is a quotation form, in that case we want
            // to print it prettier
            if (Memory::get_type(head->value.pair.first) == Lisp_Object_Type::Symbol) {
                String identifier = head->value.pair.first->value.symbol;


                auto symbol = head->value.pair.first;
                auto quote_sym            = Memory::get_symbol("quote");
                auto unquote_sym          = Memory::get_symbol("unquote");
                auto quasiquote_sym       = Memory::get_symbol("quasiquote");
                auto unquote_splicing_sym = Memory::get_symbol("unquote-splicing");
                if (symbol == quote_sym || symbol == unquote_sym || symbol == unquote_splicing_sym)
                {
                    if (symbol == quote_sym)
                        string_builder.append(strdup("\'"));
                    else if (symbol == unquote_sym)
                        string_builder.append(strdup(","));
                    else if (symbol == unquote_splicing_sym)
                        string_builder.append(strdup(",@"));

                    assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
                    assert("The list must end here.",
                           head->value.pair.rest->value.pair.rest == Memory::nil);

                    string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr));
                    return string_buider_to_string(string_builder);
                } else if (symbol == quasiquote_sym) {
                    string_builder.append(strdup("`"));
                    assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
                    string_builder.append(lisp_object_to_string(head->value.pair.rest->value.pair.first, print_repr));
                    return string_buider_to_string(string_builder);

                }
            }

            string_builder.append(strdup("("));

            // NOTE(Felix): We could do a while true here, however in case
            // we want to print a broken list (for logging the error) we
            // should do more checks.
            while (head) {
                string_builder.append(lisp_object_to_string(head->value.pair.first, print_repr));
                head = head->value.pair.rest;
                if (!head)                                            break;
                if (Memory::get_type(head) != Lisp_Object_Type::Pair) break;
                string_builder.append(strdup(" "));
            }

            if (head && Memory::get_type(head) != Lisp_Object_Type::Nil) {
                string_builder.append(strdup(" . "));
                string_builder.append(lisp_object_to_string(head, print_repr));
            }

            string_builder.append(strdup(")"));

            return string_buider_to_string(string_builder);
        }
        default:
            create_generic_error("A Lisp_Object of type-id %d cannot be converted to a string",
                                 (int)(Memory::get_type(node)));
            return nullptr;
        }
    }

    proc print(Lisp_Object* node, bool print_repr, FILE* file) -> void {
        char* string = nullptr;
        defer {
            free(string);
        };
        string = lisp_object_to_string(node, print_repr);
        fputs(string, file);
    }

    proc print_single_call(Lisp_Object* obj) -> void {
        printf(console_cyan);
        print(obj, true);
        printf(console_normal);
        printf("\n   at ");
        if (obj->sourceCodeLocation) {
            printf("%s (line %d, position %d)",
                   Memory::get_c_str(
                       obj->sourceCodeLocation->file),
                   obj->sourceCodeLocation->line,
                   obj->sourceCodeLocation->column);
        } else {
            fputs("no source code location avaliable", stdout);
        }
    }

    proc print_current_execution() -> void {
        using Globals::Current_Execution::cs;
        using Globals::Current_Execution::pcs;
        using Globals::Current_Execution::nass;
        using Globals::Current_Execution::ams;
        printf("cs:\n ");
        for (int i = 0; i < cs.next_index; ++i)  {
            char* t = lisp_object_to_string(cs.data[i], true);
            printf(" %d: %s\n ", i, t);
            defer {
                free(t);
            };
        }
        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::Macro_Write_Back: return "Macro_Write_Back";
                        case NasAction::And_Then_Action:  return "And_Then_Action";
                        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);
        }
    }

    proc log_error() -> void {
        fputs("\n", stdout);
        fputs(console_red,    stdout);
        fputs(Memory::get_c_str(Globals::error->message), stdout);
        puts(console_normal);

        fputs("  in: ", stdout);
        print_current_execution();
        puts(console_normal);
    }
}