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