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::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::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 cold do a while true here, however in case // we want to print a broken list (for logging the error) we // should do mo 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_error_location() -> void { if (Globals::current_source_code) { printf("%s (line %d, position %d) code:" console_red "\n ", Memory::get_c_str( Globals::current_source_code->sourceCodeLocation->file), Globals::current_source_code->sourceCodeLocation->line, Globals::current_source_code->sourceCodeLocation->column); print(Globals::current_source_code); } else { fputs("no source code location avaliable", stdout); } } proc log_error() -> void { fputs(console_red, stdout); fputs(Memory::get_c_str(Globals::error->message), stdout); puts(console_normal); fputs(" in: " console_cyan, stdout); print_error_location(); puts(console_normal); } proc exe_dir() -> char* { if_linux { size_t size = 512, i, n; char *path, *temp; while (1) { size_t used; path = (char*)malloc(size); if (!path) { errno = ENOMEM; return NULL; } used = readlink("/proc/self/exe", path, size); if (used == -1) { const int saved_errno = errno; free(path); errno = saved_errno; return NULL; } else if (used < 1) { free(path); errno = EIO; return NULL; } if ((size_t)used >= size) { free(path); size = (size | 2047) + 2049; continue; } size = (size_t)used; break; } /* Find final slash. */ n = 0; for (i = 0; i < size; i++) if (path[i] == '/') n = i; /* Optimize allocated size, ensuring there is room for a final slash and a string-terminating '\0', */ temp = path; path = (char*)realloc(temp, n + 2); if (!path) { free(temp); errno = ENOMEM; return NULL; } /* and properly trim and terminate the path string. */ path[n+0] = '/'; path[n+1] = '\0'; return path; } if_windows { DWORD last_error; DWORD result; DWORD path_size = 1024; char* path = (char*)malloc(1024); while (true) { memset(path, 0, path_size); result = GetModuleFileName(0, path, path_size - 1); last_error = GetLastError(); if (0 == result) { free(path); path = 0; break; } else if (result == path_size - 1) { free(path); /* May need to also check for ERROR_SUCCESS here if XP/2K */ if (ERROR_INSUFFICIENT_BUFFER != last_error) { path = 0; break; } path_size = path_size * 2; path = (char*)malloc(path_size); } else break; } if (!path) { fprintf(stderr, "Failure: %d\n", last_error); return ""; } else return path; } }