slime/src/io.cpp

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 {
    if (str1 == str2)
        return true;

    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) -> bool {
    if (!in)
        return true;

    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';
    if (int_err)
        return false;
    return true;
}

proc read_entire_file(char* filename) -> char* {
    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);
}

proc panic(char* message) -> void {
    log_message(Log_Level::Critical, message);
    exit(1);
}

proc print(Lisp_Object* node, bool print_repr = false, FILE* file = stdout) -> void {

    switch (Memory::get_type(node)) {
    case (Lisp_Object_Type::Nil):       fputs("()", file);                                         break;
    case (Lisp_Object_Type::T):         fputs("t",  file);                                         break;
    case (Lisp_Object_Type::Number): {
        if (abs(node->value.number - (int)node->value.number) < 0.000001f)
            fprintf(file, "%d", (int)node->value.number);
        else
            fprintf(file, "%f", node->value.number);
    } break;
    case (Lisp_Object_Type::Keyword):   fputs(":", file); // NOTE(Felix): intentionall fallthough
    case (Lisp_Object_Type::Symbol):    fprintf(file, "%s", Memory::get_c_str(node->value.symbol.identifier)); break;
    case (Lisp_Object_Type::Continuation): fputs("[continuation]", file);                               break;
    case (Lisp_Object_Type::CFunction): fputs("[C-function]", file);                               break;
    case (Lisp_Object_Type::String): {
        if (print_repr) {
            putc('\"', file);
            char* escaped = escape_string(Memory::get_c_str(node->value.string));
            fputs(escaped, file);
            putc('\"', file);
            free(escaped);
        }
        else
            fputs(Memory::get_c_str(node->value.string), file);
    } break;
    case (Lisp_Object_Type::Vector): {
        fputs("[", file);
        if (node->value.vector.length > 0)
            print(node->value.vector.data);
        for (int i = 1; i < node->value.vector.length; ++i) {
            fputs(" ", file);
            print(node->value.vector.data+i);
        }
        fputs("]", file);
    } break;
    case (Lisp_Object_Type::Function): {
        if (node->userType) {
            fprintf(file, "[%s]", Memory::get_c_str(node->userType->value.symbol.identifier));
            break;
        }
        if (node->value.function.type == Function_Type::Lambda)
            fputs("[lambda]", file);
        else if (node->value.function.type == Function_Type::Special_Lambda)
            fputs("[special-lambda]", file);
        else if (node->value.function.type == Function_Type::Macro)
            fputs("[macro]", file);
        else
            assert(false);
    } break;
    case (Lisp_Object_Type::Pair): {
        Lisp_Object* head = node;

        // 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.identifier;

            // TODO(Felix): Lisp_Node* symbol = head->value.pair.first;
            // TODO(Felix): if (symbol == Memory::get_or_create_symbol("quote"))
            if (string_equal(identifier, "quote") ||
                string_equal(identifier, "unquote"))
            {
                putc((string_equal(identifier, "quote"))
                     ? '\''
                     : ',', file);

                assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
                assert(head->value.pair.rest->value.pair.rest == Memory::nil);

                print(head->value.pair.rest->value.pair.first, print_repr, file);
                break;
            }
            else if (string_equal(identifier, "quasiquote")) {
                putc('`', file);
                assert_type(head->value.pair.rest, Lisp_Object_Type::Pair);
                print(head->value.pair.rest->value.pair.first, print_repr, file);
                break;
            }
        }

        putc('(', file);

        // NOTE(Felix): We cuold 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) {
            print(head->value.pair.first, print_repr, file);
            head = head->value.pair.rest;
            if (!head)
                return;
            if (Memory::get_type(head) != Lisp_Object_Type::Pair)
                break;
            putc(' ', file);
        }

        if (Memory::get_type(head) != Lisp_Object_Type::Nil) {
            fputs(" . ", file);
            print(head);
        }

        putc(')', file);
    } break;
    }
}

proc print_single_call(Lisp_Object* obj) -> void {
    printf(console_cyan);
    print(obj);
    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_call_stack() -> void {
    using Globals::Current_Execution::call_stack;

    printf("callstack [%d] (most recent call last):\n", call_stack.next_index);
    for (int i = 0; i < call_stack.next_index; ++i) {
        printf("%2d -> ", i);
        print_single_call(call_stack.data[i]);
        printf("\n");
    }
}

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

    fputs("  in: ", stdout);
    print_call_stack();
    puts(console_normal);

    Globals::Current_Execution::call_stack.next_index = 0;
}