From 550a6131e1a224c7eddcc692381dfe36a666c451 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Mon, 23 Sep 2024 04:39:35 -0700 Subject: [PATCH] Completely rewrite basically the whole thing --- CMakeLists.txt | 10 +- bootstrap/ast.c | 931 ++++++++++++++++++++++++++ bootstrap/ast.h | 108 +++ bootstrap/main.c | 29 + {src => bootstrap}/parse.c | 105 ++- {src => bootstrap}/parse.h | 15 +- bootstrap/test.sl | 1 + src/lisp.c | 1293 ------------------------------------ src/lisp.h | 333 ---------- src/main.c | 58 -- 10 files changed, 1167 insertions(+), 1716 deletions(-) create mode 100644 bootstrap/ast.c create mode 100644 bootstrap/ast.h create mode 100644 bootstrap/main.c rename {src => bootstrap}/parse.c (80%) rename {src => bootstrap}/parse.h (81%) create mode 100644 bootstrap/test.sl delete mode 100644 src/lisp.c delete mode 100644 src/lisp.h delete mode 100644 src/main.c diff --git a/CMakeLists.txt b/CMakeLists.txt index b53e2d8..a852a57 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -5,10 +5,12 @@ set(CMAKE_EXPORT_COMPILE_COMMANDS YES) project(simple-lisp) -set(SOURCE_FILES main.c parse.c lisp.c) +set(BOOTSTRAP_FILES main.c parse.c ast.c) -foreach(FILE IN LISTS SOURCE_FILES) - list(APPEND REAL_SOURCE_FILES "src/${FILE}") +foreach(FILE IN LISTS BOOTSTRAP_FILES) + list(APPEND REAL_BOOTSTRAP_FILES "bootstrap/${FILE}") endforeach() -add_executable(simple-lisp ${REAL_SOURCE_FILES}) +add_executable(bootstrap-slc ${REAL_BOOTSTRAP_FILES}) + +target_link_libraries(bootstrap-slc m) diff --git a/bootstrap/ast.c b/bootstrap/ast.c new file mode 100644 index 0000000..293cf8b --- /dev/null +++ b/bootstrap/ast.c @@ -0,0 +1,931 @@ +#include "ast.h" + +#include +#include +#include +#include +#include +#include +#include + +static bool next_token(TokenStream *stream, Token *out, AstErrorList **err); +static AstNode *process_token(Token *token, TokenStream *stream, + AstQuoteType in_quote, AstErrorList **err); +static AstNode *ast_next_toplevel_internal(TokenStream *stream, + AstQuoteType in_quote, + AstErrorList **err); +static void dump_node_list(AstNode **list, size_t count, char sdelim, + char edelim, int padding, FILE *stream); + +static const char *DECIMAL_NUM_PAT = + "^([+-])?([0-9]*)\\.?([0-9]*)(e([+-]?)([0-9]*)\\.?([0-9]*))?$"; +static regex_t DECIMAL_NUM_REGEX; + +static const char *NON_DECIMAL_NUM_PAT = + "^(2|8|10|16)#([+-])?([0-9a-f]+)$"; +static regex_t NON_DECIMAL_NUM_REGEX; +static size_t REGEX_NMATCH; + +void ast_init_parser() { + bool had_error = false; + int code; + if ((code = regcomp(&DECIMAL_NUM_REGEX, DECIMAL_NUM_PAT, REG_EXTENDED))) { + fprintf(stderr, "Failed to compile decimal number regex:\n%s\n", + DECIMAL_NUM_PAT); + char msg[1024]; + regerror(code, &DECIMAL_NUM_REGEX, msg, sizeof(msg)); + fprintf(stderr, " %s\n", msg); + had_error = true; + } + if (regcomp(&NON_DECIMAL_NUM_REGEX, NON_DECIMAL_NUM_PAT, REG_EXTENDED)) { + if (had_error) { + fputc('\n', stderr); + } + fprintf(stderr, "Failed to compile non-decimal number regex:\n%s\n", + NON_DECIMAL_NUM_PAT); + char msg[1024]; + regerror(code, &NON_DECIMAL_NUM_REGEX, msg, sizeof(msg)); + fprintf(stderr, " %s\n", msg); + had_error = true; + } + if (had_error) { + exit(1); + } + REGEX_NMATCH = (DECIMAL_NUM_REGEX.re_nsub > NON_DECIMAL_NUM_REGEX.re_nsub ? + DECIMAL_NUM_REGEX.re_nsub : NON_DECIMAL_NUM_REGEX.re_nsub) + + 1; +} + +void ast_deinit_parser() { + regfree(&DECIMAL_NUM_REGEX); + regfree(&NON_DECIMAL_NUM_REGEX); +} + +// vasprintf is nonstandard, open_memstream is POSIX 2008 +char *compat_vasprintf(const char *fmt, va_list args) { + va_list args2; + va_copy(args2, args); + size_t size = vsnprintf(NULL, 0, fmt, args) + 1; + char *buf = malloc(size); + vsnprintf(buf, size, fmt, args2); + va_end(args2); + return buf; +} + +static void push_error_list_end(AstErrorList **list, AstErrorList *err) { + err->next = NULL; + if (!*list) { + *list = err; + } else { + AstErrorList *cur = *list; + while (cur->next) { + cur = cur->next; + } + cur->next = err; + } +} + +__attribute__((format(printf, 4, 5))) +static void push_build_error(AstErrorList **list, Token *token, size_t off, + const char *fmt, ...) { + if (list) { + AstErrorList *n = malloc(sizeof(AstErrorList)); + n->type = AST_ERROR_BUILD; + n->build.off = off; + n->build.token = *token; + token->text = NULL; + token->buf_len = 0; + va_list args; + va_start(args, fmt); + n->build.msg = compat_vasprintf(fmt, args); + va_end(args); + push_error_list_end(list, n); + } +} + +static void push_parse_error(AstErrorList **list, ParseError *err) { + if (list) { + AstErrorList *n = malloc(sizeof(AstErrorList)); + n->type = AST_ERROR_PARSE; + n->parse = err; + push_error_list_end(list, n); + } +} + +static void *make_ast_node(size_t size, AstType type, size_t line, + size_t col) { + AstNode *node = malloc(size); + node->type = type; + node->line = line; + node->col = col; + return node; +} + +static int compat_strcasecmp(const char *str1, const char *str2) { + while (*str1 && *str2) { + if (tolower(*str1) != tolower(*str2)) { + return tolower(*str1) - tolower(*str2); + } + ++str1; + ++str2; + } + return tolower(*str1) - tolower(*str2); +} + +// number of chars converted on success, 0 on failure +static int convert_numeric_char_escape(const char *escape, wchar_t *out, + bool allow_trailing) { + size_t len = strlen(escape) - 1; + size_t expected_len; + int base; + if (tolower(escape[0]) == 'x') { + expected_len = 4; + base = 16; + } else if (tolower(escape[0]) == 'o') { + expected_len = 6; + base = 8; + } else if (tolower(escape[0]) == 'd') { + expected_len = 5; + base = 10; + } + if (len < expected_len || (!allow_trailing && len > expected_len)) { + return 0; + } + char *endptr; + char numbuf[expected_len + 1]; + memcpy(numbuf, escape + 1, expected_len); + numbuf[expected_len] = '\0'; + uintmax_t num = strtoumax(numbuf, &endptr, base); + if (*endptr) { + return 0; + } + *out = num; + return expected_len + 1; +} + +static const struct { + char escape; + char value; +} C_STYLE_ESCAPE_MAP[] = { + {'n', '\n'}, + {'t', '\t'}, + {'r', '\r'}, + {'v', '\v'}, + {'f', '\f'}, + {'b', '\b'}, + {'a', '\a'}, + {'0', '\0'}, + {'\\', '\\'}, +}; +const size_t C_STYLE_ESCAPE_COUNT = sizeof(C_STYLE_ESCAPE_MAP) / + sizeof(C_STYLE_ESCAPE_MAP[0]); + +// true on success, false on failure +static bool convert_c_style_char_escape(const char *escape, wchar_t *out) { + for (size_t i = 0; i < C_STYLE_ESCAPE_COUNT; ++i) { + if (tolower(escape[0]) == C_STYLE_ESCAPE_MAP[i].escape) { + *out = C_STYLE_ESCAPE_MAP[i].value; + return true; + } + } + return false; +} + +// null byte on failure +static char escape_for_char(char to_escape) { + for (size_t i = 0; i < C_STYLE_ESCAPE_COUNT; ++i) { + if (to_escape == C_STYLE_ESCAPE_MAP[i].value) { + return C_STYLE_ESCAPE_MAP[i].escape; + } + } + return '\0'; +} + +static char *escape_string(const char *input, size_t input_len, size_t *out_len) { + size_t out_size = input_len + 1; + char *out = malloc(out_size); + *out_len = 0; + for (size_t i = 0; i < input_len; ++i) { + char escape = escape_for_char(input[i]); + if (escape) { + out = realloc(out, ++out_size); + out[(*out_len)++] = '\\'; + out[(*out_len)++] = escape; + } else if (input[i] == '"') { + out = realloc(out, ++out_size); + out[(*out_len)++] = '\\'; + out[(*out_len)++] = '"'; + } else { + out[(*out_len)++] = input[i]; + } + } + out[(*out_len)] = '\0'; + return out; +} + +static const struct { + const char *escape; + char value; +} NAMED_CHAR_ESCAPE_MAP[] = { + {"newline", '\n'}, + {"tab", '\t'}, + {"return", '\r'}, + {"vtab", '\v'}, + {"page_break", '\f'}, + {"backspace", '\b'}, + {"alert", '\a'}, + {"null", '\0'}, + {"backslash", '\\'}, +}; +static const size_t NAMED_CHAR_COUNT = sizeof(NAMED_CHAR_ESCAPE_MAP) / + sizeof(NAMED_CHAR_ESCAPE_MAP[0]); + +// true on success, false on failure +static bool convert_named_char_escape(const char *escape, wchar_t *out) { + for (size_t i = 0; i < NAMED_CHAR_COUNT; ++i) { + if (compat_strcasecmp(NAMED_CHAR_ESCAPE_MAP[i].escape, escape) == 0) { + *out = NAMED_CHAR_ESCAPE_MAP[i].value; + return true; + } + } + return false; +} + +static AstIntNode *process_char_token(Token *token, AstErrorList **err) { + AstIntNode *node = make_ast_node(sizeof(AstIntNode), AST_TYPE_INT, + token->line, token->col); + // remove the # sign + char *sym = token->text + 1; + // special character + if (sym[0] == '\\') { + // account for '#' in token->len + if (token->len < 3) { + push_build_error(err, token, 1, "expected escape sequence"); + free(node); + return NULL; + } + wchar_t c; + if (!convert_named_char_escape(sym + 1, &c) && + !convert_c_style_char_escape(sym + 1, &c) && + !convert_numeric_char_escape(sym + 1, &c, false)) { + free(token->text); + free(node); + push_build_error(err, token, 0, + "invalid escape sequence in character literal"); + return NULL; + } + node->value = c; + } else { + node->value = sym[0]; + } + return node; +} + +static char *process_string_escapes(Token *token, size_t *out_len, + AstErrorList **err) { + const char *text = token->text; + size_t out_size = token->len + 1; + char *out = malloc(out_size); + *out_len = 0; + bool backslash = 0; + for (size_t i = 1; i < token->len - 1; ++i) { + if (!backslash && text[i] == '\\') { + backslash = true; + continue; + } else if (backslash && text[i] == '\n') { + // backslash can escape a newline + } else if (backslash) { + size_t count = 1; + wchar_t c; + if (!convert_c_style_char_escape(&text[i], &c) && + !(count = convert_numeric_char_escape(&text[i], &c, true))) { + push_build_error(err, token, i, "invalid escape sequence"); + return NULL; + } + if (out_size - *out_len - 1 < MB_CUR_MAX) { + out_size = out_size + MB_CUR_MAX - (out_size - *out_len - 1); + out = realloc(out, out_size); + } + *out_len += wctomb(out + *out_len, c); + i += count - 1; + } else { + if (*out_len >= out_size) { + out = realloc(out, out_size + token->len - i + 1); + } + out[(*out_len)++] = text[i]; + } + backslash = false; + } + out = realloc(out, *out_len + 1); + out[*out_len] = '\0'; + return out; +} + +static AstStringNode *process_string_token(Token *token, AstErrorList **err) { + AstStringNode *node = make_ast_node(sizeof(AstStringNode), AST_TYPE_STRING, + token->line, token->col); + node->value = process_string_escapes(token, &node->length, err); + if (!node->value) { + free(node); + node = NULL; + } + return node; +} + +static AstNode *make_null_node(size_t line, size_t col) { + return make_ast_node(sizeof(AstNode), AST_TYPE_NULL, line, col); +} + +static AstNode *process_symbol_token(Token *token) { + if (strcmp(token->text, "nil") == 0) { + return (AstNode *) make_null_node(token->line, token->col); + } + AstSymbolNode *node = make_ast_node(sizeof(AstSymbolNode), AST_TYPE_SYMBOL, + token->line, token->col); + node->name = token->text; + node->name_length = token->len; + node->is_property = token->text[0] == ':'; + node->skip_free = false; + token->text = NULL; + token->buf_len = 0; + return (AstNode *) node; +} + +static int sign_for_match(Token *token, regmatch_t *match) { + if (match->rm_so != match->rm_eo && + token->text[match->rm_so] == '-') { + return -1; + } else { + return 1; + } +} + +static void break_number_for_matches(Token *token, regmatch_t *matches, + int main, int dec, uintmax_t *main_out, + uintmax_t *dec_out) { + const char *text = token->text; + regmatch_t *mm = &matches[main]; + regmatch_t *dm = &matches[dec]; + *main_out = 0; + // main number has at least 1 char + if (mm->rm_eo - mm->rm_so) { + *main_out = strtoumax(text + mm->rm_so, NULL, 10); + } + *dec_out = 0; + // decimal number has at least 1 char + if (dm->rm_eo - dm->rm_so) { + *dec_out = strtoumax(text + dm->rm_so, NULL, 10); + } +} + +static AstNode *process_decimal_matches(Token *token, regmatch_t *matches) { + int main_sign = sign_for_match(token, &matches[1]); + int exp_sign = sign_for_match(token, &matches[5]); + uintmax_t main_main, main_dec; + break_number_for_matches(token, matches, 2, 3, &main_main, &main_dec); + uintmax_t exp_main, exp_dec; + break_number_for_matches(token, matches, 6, 7, &exp_main, &exp_dec); + if (main_dec == 0 && exp_dec == 0 && exp_sign == 1) { + // return an integer + AstIntNode *node = make_ast_node(sizeof(AstIntNode), AST_TYPE_INT, + token->line, token->col); + node->value = main_sign * main_main * pow(10, exp_main); + return (AstNode *) node; + } else { + // return a float + AstFloatNode *node = make_ast_node(sizeof(AstFloatNode), AST_TYPE_FLOAT, + token->line, token->col); + int main_dec_len = floor(log10(main_dec) + 1); + int exp_dec_len = floor(log10(exp_dec) + 1); + double main_dec_f = main_dec * pow(10, -main_dec_len); + double exp_dec_f = exp_dec * pow(10, -exp_dec_len); + node->value = main_sign * ((double) main_main + main_dec_f) * + pow(10, exp_sign * ((double) exp_main + exp_dec_f)); + return (AstNode *) node; + } +} + +static AstNode *process_non_decimal_matches(Token *token, regmatch_t *matches, + AstErrorList **err) { + // get the base + int base; + if (token->text[0] == '2' || token->text[0] == '8') { + base = token->text[0] - '0'; + } else { + base = 10 + token->text[1] - '0'; + } + int sign = sign_for_match(token, &matches[2]); + char *endptr; + uintmax_t num = strtoumax(&token->text[matches[3].rm_so], &endptr, base); + // num is the abs of our target, so only check against positive max + if (*endptr || num > INT64_MAX) { + push_build_error(err, token, 0, "invalid numeric literal"); + return NULL; + } + AstIntNode *node = make_ast_node(sizeof(AstIntNode), AST_TYPE_INT, + token->line, token->col); + node->value = sign * (intmax_t) num; + return (AstNode *) node; +} + +static AstNode *parse_number_token(Token *token, AstErrorList **err) { + regmatch_t matches[REGEX_NMATCH]; + const char *text = token->text; + if (regexec(&DECIMAL_NUM_REGEX, text, REGEX_NMATCH, matches, 0) == 0) { + return process_decimal_matches(token, matches); + } else if (regexec(&NON_DECIMAL_NUM_REGEX, text, REGEX_NMATCH, + matches, 0) == 0) { + return process_non_decimal_matches(token, matches, err); + } + push_build_error(err, token, 0, "invalid numeric literal"); + return NULL; +} + +static bool is_node_symbol_t(AstNode *node) { + return node->type == AST_TYPE_SYMBOL && + strcmp("t", ((AstSymbolNode *) node)->name) == 0; +} + +static AstNode *simplify_quote_node(AstQuoteNode *node) { + AstNode *cur = (AstNode *) node; + while (cur->type == AST_TYPE_QUOTE) { + cur = ((AstQuoteNode *) cur)->form; + } + if (cur->type == AST_TYPE_NULL + || cur->type == AST_TYPE_VECTOR + || is_node_symbol_t(cur)) { + AstNode *inner = node->form; + node->form = NULL; + destroy_ast_node(node); + return inner; + } + return (AstNode *) node; +} + +static AstNode *quote_ast_form(AstQuoteType type, + AstNode *form, size_t line, size_t col, + AstQuoteType in_quote) { + AstQuoteNode *node = make_ast_node(sizeof(AstQuoteNode), AST_TYPE_QUOTE, + line, col); + node->type = type; + node->form = form; + if (!in_quote) { + return simplify_quote_node(node); + } + return (AstNode *) node; +} + +static AstNode *quote_next_toplevel(Token *token, TokenStream *stream, + AstQuoteType in_quote, AstErrorList **err) { + AstQuoteType my_type; + switch (token->type) { + case TOKEN_TYPE_QUOTE: + my_type = AST_QUOTE_NORM; + break; + case TOKEN_TYPE_BACKQUOTE: + my_type = AST_QUOTE_BACK; + break; + case TOKEN_TYPE_COMMA: + my_type = AST_QUOTE_COMMA; + break; + case TOKEN_TYPE_SPLICE: + my_type = AST_QUOTE_SPLICE; + break; + default: + // shouldn't happen + abort(); + break; + } + if (in_quote != AST_QUOTE_BACK && + (my_type == AST_QUOTE_COMMA || my_type == AST_QUOTE_SPLICE)) { + push_build_error(err, token, 0, "comma or splice not inside a backquote"); + return NULL; + } + if (my_type > in_quote) { + in_quote = my_type; + } + AstNode *internal = ast_next_toplevel_internal(stream, in_quote, err); + if (!internal) { + // error already reported + return NULL; + } + return quote_ast_form(my_type, internal, token->line, token->col, in_quote); +} + +static bool is_close_delim(Token *token) { + return (token->type == TOKEN_TYPE_PAREN || token->type == TOKEN_TYPE_BRACKET) + && (token->text[0] == ')' || token->text[0] == ']'); +} + +static bool is_close_delim_for(Token *token, Token *child) { + if (token->type == child->type) { + switch (token->type) { + case TOKEN_TYPE_PAREN: + return child->text[0] == ')'; + case TOKEN_TYPE_BRACKET: + return child->text[0] == ']'; + default: + // fall-through + break; + } + } + return false; +} + + +static AstNode *process_next_list_or_vector(Token *token, TokenStream *stream, + size_t size, AstType type, + off_t child_arr_off, + off_t child_count_off, + AstQuoteType in_quote, + AstErrorList **err) { + if (is_close_delim(token)) { + push_build_error(err, token, 0, "unmatched closing delimiter"); + return NULL; + } + AstNode *node = make_ast_node(size, type, token->line, token->col); + AstNode ***child_arr_ptr = (void *) node + child_arr_off; + size_t *child_count_ptr = (void *) node + child_count_off; + *child_arr_ptr = NULL; + *child_count_ptr = 0; + bool error = false; + Token ctok; + ctok.text = NULL; + ctok.buf_len = 0; + while (true) { + if (!next_token(stream, &ctok, err)) { + // node MUST be valid for this to work + destroy_ast_node(node); + node = NULL; + break; + } + if (is_close_delim_for(token, &ctok)) { + break; + } + AstNode *cnode = process_token(&ctok, stream, in_quote, err); + if (!cnode) { + error = true; + if (token_stream_is_eof(stream)) { + push_build_error(err, token, 0, "unmatched opening delimiter"); + break; + } + } + *child_arr_ptr = realloc(*child_arr_ptr, sizeof(AstNode *) * + ++(*child_count_ptr)); + (*child_arr_ptr)[(*child_count_ptr) - 1] = cnode; + } + free(ctok.text); + if (error) { + destroy_ast_node(node); + return NULL; + } + return node; +} + +static bool is_quote_symbol_node(AstNode *node) { + return node->type == AST_TYPE_SYMBOL && + strcmp(((AstSymbolNode *) node)->name, "quote") == 0; +} + +static AstNode *process_next_list(Token *token, TokenStream *stream, + AstQuoteType in_quote, AstErrorList **err) { + AstListNode *node = (AstListNode *) + process_next_list_or_vector(token, stream, sizeof(AstListNode), + AST_TYPE_LIST, offsetof(AstListNode, children), + offsetof(AstListNode, nchildren), in_quote, err); + if (!node) { + return NULL; + } else if (node->nchildren == 0) { + destroy_ast_node(node); + return (AstNode *) make_null_node(token->line, token->col); + } + bool is_quote = is_quote_symbol_node(node->children[0]); + if (is_quote && node->nchildren != 2) { + push_build_error(err, token, 0, "quote expects one argument, got %zu", + node->nchildren); + destroy_ast_node(node); + return NULL; + } else if (is_quote) { + AstNode *internal = node->children[1]; + node->nchildren = 1; + destroy_ast_node(node); + return (AstNode *)quote_ast_form(AST_QUOTE_NORM, internal, + token->line, token->col, + in_quote); + } + return (AstNode *) node; +} + +// true on success, false on error +static bool next_token(TokenStream *stream, Token *out, AstErrorList **err) { + out->text = NULL; + out->buf_len = 0; + do { + token_stream_next(stream, out); + ParseError *parse_err; + bool had_error = false; + while ((parse_err = token_stream_error(stream))) { + push_parse_error(err, parse_err); + had_error = true; + } + if (had_error) { + free(out->text); + out->text = NULL; + out->buf_len = 0; + return false; + } + } while (out->type == TOKEN_TYPE_COMMENT); + return true; +} + +static AstNode *process_token(Token *token, TokenStream *stream, + AstQuoteType in_quote, AstErrorList **err) { + AstNode *retval = NULL; + switch (token->type) { + case TOKEN_TYPE_CHAR: + retval = (AstNode *) process_char_token(token, err); + break; + case TOKEN_TYPE_NUMBER: + retval = parse_number_token(token, err); + break; + case TOKEN_TYPE_STRING: + retval = (AstNode *) process_string_token(token, err); + break; + case TOKEN_TYPE_SYMBOL: + case TOKEN_TYPE_PROPERTY: + retval = (AstNode *) process_symbol_token(token); + break; + case TOKEN_TYPE_BACKQUOTE: + case TOKEN_TYPE_COMMA: + case TOKEN_TYPE_SPLICE: + case TOKEN_TYPE_QUOTE: + retval = (AstNode *) quote_next_toplevel(token, stream, in_quote, err); + break; + case TOKEN_TYPE_PAREN: + retval = process_next_list(token, stream, in_quote, err); + break; + case TOKEN_TYPE_BRACKET: + retval = process_next_list_or_vector(token, stream, sizeof(AstVectorNode), + AST_TYPE_VECTOR, + offsetof(AstVectorNode, children), + offsetof(AstVectorNode, nchildren), + AST_QUOTE_NORM, err); + break; + case TOKEN_TYPE_UNKNOWN: + push_build_error(err, token, 0, "unknown token"); + break; + case TOKEN_TYPE_EOF: + // do nothing + break; + case TOKEN_TYPE_COMMENT: + // shouldn't happen + abort(); + break; + } + return retval; +} + +static AstNode *ast_next_toplevel_internal(TokenStream *stream, + AstQuoteType in_quote, + AstErrorList **err) { + Token token; + token.text = NULL; + token.buf_len = 0; + if (!next_token(stream, &token, err)) { + return NULL; + } + return process_token(&token, stream, in_quote, err); +} + +AstNode *ast_next_toplevel(TokenStream *stream, AstErrorList **err) { + return ast_next_toplevel_internal(stream, AST_QUOTE_NONE, err); +} + +void destroy_ast_node(void *node) { + if (!node) { + return; + } + switch (((AstNode *)node)->type) { + case AST_TYPE_LIST: + for (size_t i = 0; i < ((AstListNode *) node)->nchildren; ++i) { + destroy_ast_node(((AstListNode *) node)->children[i]); + } + free(((AstListNode *) node)->children); + break; + case AST_TYPE_VECTOR: + for (size_t i = 0; i < ((AstVectorNode *) node)->nchildren; ++i) { + destroy_ast_node(((AstVectorNode *) node)->children[i]); + } + free(((AstVectorNode *) node)->children); + break; + case AST_TYPE_STRING: + free(((AstStringNode *) node)->value); + break; + case AST_TYPE_SYMBOL: + if (!((AstSymbolNode *)node)->skip_free) { + free(((AstSymbolNode *) node)->name); + } + break; + case AST_TYPE_QUOTE: + destroy_ast_node(((AstQuoteNode *) node)->form); + break; + case AST_TYPE_INT: + case AST_TYPE_FLOAT: + case AST_TYPE_NULL: + break; + } + free(node); +} + +static const char *str_for_ast_quote_type(AstQuoteType type) { + switch (type) { + case AST_QUOTE_NONE: + return ""; + case AST_QUOTE_NORM: + return "'"; + case AST_QUOTE_BACK: + return "`"; + case AST_QUOTE_COMMA: + return ","; + case AST_QUOTE_SPLICE: + return ",@"; + } +} + +static void ast_prin1_node_internal(AstNode *node, FILE *stream, int padding, + bool skip_print_pad) { + if (!skip_print_pad) { + for (int i = 0; i < padding; ++i) { + fputc(' ', stream); + } + } + switch (node->type) { + case AST_TYPE_INT: { + int64_t value = ((AstIntNode *) node)->value; + fprintf(stream, "%" PRId64 " (", value); + char escape; + if ((escape = escape_for_char((char) value))) { + fprintf(stream, "#\\%c, ", escape); + } else if (isprint(value)) { + fprintf(stream, "#%c, ", (char) value); + } + if (value < 0) { + fputc('-', stream); + value *= -1; + } + fprintf(stream, "0x%" PRIx64 ")", value); + } + break; + case AST_TYPE_STRING: { + size_t escaped_len; + char *escaped_string = escape_string(((AstStringNode *)node)->value, + ((AstStringNode *)node)->length, + &escaped_len); + fputc('"', stream); + fwrite(escaped_string, 1, escaped_len, stream); + fputc('"', stream); + } + break; + case AST_TYPE_SYMBOL: + fwrite(((AstSymbolNode *) node)->name, 1, + ((AstSymbolNode *) node)->name_length, stream); + break; + case AST_TYPE_FLOAT: + fprintf(stream, "%g", ((AstFloatNode *) node)->value); + break; + case AST_TYPE_LIST: { + dump_node_list(((AstListNode *) node)->children, + ((AstListNode *) node)->nchildren, + '(', ')', padding, stream); + } + break; + case AST_TYPE_VECTOR: + dump_node_list(((AstVectorNode *) node)->children, + ((AstVectorNode *) node)->nchildren, + '[', ']', padding, stream); + break; + case AST_TYPE_QUOTE: { + const char *quote_str = str_for_ast_quote_type(((AstQuoteNode *) node)->type); + fprintf(stream, "%s", quote_str); + padding += strlen(quote_str); + ast_prin1_node_internal(((AstQuoteNode *) node)->form, stream, + padding, true); + + } + break; + case AST_TYPE_NULL: + fwrite("nil", 1, 3, stream); + break; + } +} + +static void dump_node_list(AstNode **list, size_t count, char sdelim, + char edelim, int padding, FILE *stream) { + fputc(sdelim, stream); + if (count) { + ast_prin1_node_internal(list[0], stream, padding + 1, true); + } + for (size_t i = 1; i < count; ++i) { + fputc('\n', stream); + ast_prin1_node_internal(list[i], stream, padding + 1, false); + } + fputc(edelim, stream); +} + +void ast_prin1_node(AstNode *node, FILE *stream) { + ast_prin1_node_internal(node, stream, 0, false); + fputc('\n', stream); +} + +AstErrorList *ast_error_list_pop(AstErrorList **list) { + AstErrorList *top = *list; + if (*list) { + *list = (*list)->next; + } + return top; +} + +void ast_error_list_free_one(AstErrorList *list) { + if (list) { + switch (list->type) { + case AST_ERROR_PARSE: + parse_error_free(list->parse); + break; + case AST_ERROR_BUILD: + free(list->build.msg); + token_free(&list->build.token); + break; + } + free(list); + } +} + +void ast_error_list_free_all(AstErrorList *list) { + while (list) { + AstErrorList *next = list->next; + ast_error_list_free_one(list); + list = next; + } +} + +static const char *start_of_last_line(const char *str, size_t len, + size_t *line_len, size_t *num_passed) { + *num_passed = 0; + *line_len = 0; + const char *retval = str; + size_t i; + for (i = len; i > 0; --i) { + if (str[i - 1] == '\n' && *line_len) { + retval = &str[i]; + break; + } else if (str[i - 1] != '\n') { + ++(*line_len); + } + } + for (; i > 0; --i) { + if (str[i - 1] == '\n') { + ++*num_passed; + } + } + return retval; +} + +void ast_format_error(AstErrorList *err, const char *file_name, FILE *stream) { + if (!err) { + return; + } + fprintf(stream, "error: "); + if (file_name) { + fprintf(stream, "%s: ", file_name); + } + switch (err->type) { + case AST_ERROR_PARSE: { + size_t line_len; + size_t num_passed; + const char *last_line = start_of_last_line(err->parse->context, + strlen(err->parse->context), + &line_len, &num_passed); + fprintf(stream, "%zu:%zu: %s\n ", err->parse->line + num_passed, + err->parse->at_end ? err->parse->col + line_len - 1 : + err->parse->col, err->parse->desc); + fwrite(last_line, 1, line_len, stream); + fwrite("\n ", 1, 3, stream); + if (err->parse->at_end) { + for (size_t i = 1; i < line_len; ++i) { + fputc(' ', stream); + } + } + fwrite("^\n", 1, 2, stream); + } + break; + case AST_ERROR_BUILD: + fprintf(stream, "%zu:%zu: %s\n %s\n ", err->build.token.line, + err->build.token.col + err->build.off, + err->build.msg, err->build.token.text); + for (size_t i = 1; i <= err->build.off; ++i) { + fputc(' ', stream); + } + fwrite("^\n", 1, 2, stream); + break; + } +} diff --git a/bootstrap/ast.h b/bootstrap/ast.h new file mode 100644 index 0000000..bc495d1 --- /dev/null +++ b/bootstrap/ast.h @@ -0,0 +1,108 @@ +#ifndef INCLUDED_AST_H +#define INCLUDED_AST_H + +#include "parse.h" + +#include +#include + +typedef enum { + AST_TYPE_LIST, + AST_TYPE_SYMBOL, + AST_TYPE_VECTOR, + AST_TYPE_INT, + AST_TYPE_FLOAT, + AST_TYPE_STRING, + AST_TYPE_QUOTE, + AST_TYPE_NULL, +} AstType; + +typedef struct { + AstType type; + size_t line; + size_t col; +} AstNode; + +typedef struct { + AstNode parent; + size_t nchildren; + AstNode **children; +} AstListNode; + +typedef struct { + AstNode parent; + size_t nchildren; + AstNode **children; +} AstVectorNode; + +typedef struct { + AstNode parent; + int64_t value; +} AstIntNode; + +typedef struct { + AstNode parent; + double value; +} AstFloatNode; + +typedef struct { + AstNode parent; + char *value; + size_t length; +} AstStringNode; + +typedef struct { + AstNode parent; + bool is_property; + char *name; + size_t name_length; + bool skip_free; +} AstSymbolNode; + +typedef enum { + AST_QUOTE_NONE = 0, + AST_QUOTE_COMMA, + AST_QUOTE_SPLICE, + AST_QUOTE_NORM, + AST_QUOTE_BACK, +} AstQuoteType; + +typedef struct { + AstNode parent; + AstQuoteType type; + AstNode *form; +} AstQuoteNode; + +typedef enum { + AST_ERROR_PARSE, + AST_ERROR_BUILD +} AstErrorType; + +typedef struct _AstErrorList { + struct _AstErrorList *next; + AstErrorType type; + union { + ParseError *parse; + struct { + Token token; + size_t off; // from start of token + char *msg; + } build; + }; +} AstErrorList; + +void ast_init_parser(void); +void ast_deinit_parser(void); + +AstNode *ast_next_toplevel(TokenStream *stream, AstErrorList **err); + +void destroy_ast_node(void *node); + +AstErrorList *ast_error_list_pop(AstErrorList **list); +void ast_error_list_free_one(AstErrorList *list); +void ast_error_list_free_all(AstErrorList *list); + +void ast_prin1_node(AstNode *node, FILE *stream); +void ast_format_error(AstErrorList *err, const char *file_name, FILE *stream); + +#endif diff --git a/bootstrap/main.c b/bootstrap/main.c new file mode 100644 index 0000000..debff72 --- /dev/null +++ b/bootstrap/main.c @@ -0,0 +1,29 @@ +#include + +#include "parse.h" +#include "ast.h" + +int main(int argc, const char **argv) { + ast_init_parser(); + FILE *file = fopen("bootstrap/test.sl", "r"); + if (!file) { + perror("fopen"); + } + TokenStream *stream = make_token_stream(file); + AstErrorList *errs; + while (!token_stream_is_eof(stream)) { + AstNode *node = ast_next_toplevel(stream, &errs); + if (node) { + ast_prin1_node(node, stdout); + } + while (errs) { + AstErrorList *err = ast_error_list_pop(&errs); + ast_format_error(err, "bootstrap/test.sl", stderr); + ast_error_list_free_one(err); + } + destroy_ast_node(node); + } + destroy_token_stream(stream); + ast_deinit_parser(); + return 0; +} diff --git a/src/parse.c b/bootstrap/parse.c similarity index 80% rename from src/parse.c rename to bootstrap/parse.c index 84cc829..bcf8ce4 100644 --- a/src/parse.c +++ b/bootstrap/parse.c @@ -4,6 +4,39 @@ #include #include +const char *token_type_to_str(TokenType type) { + switch (type) { + case TOKEN_TYPE_EOF: + return "EOF"; + case TOKEN_TYPE_COMMENT: + return "COMMENT"; + case TOKEN_TYPE_PAREN: + return "PAREN"; + case TOKEN_TYPE_BRACKET: + return "BRACKET"; + case TOKEN_TYPE_SYMBOL: + return "SYMBOL"; + case TOKEN_TYPE_PROPERTY: + return "PROPERTY"; + case TOKEN_TYPE_QUOTE: + return "QUOTE"; + case TOKEN_TYPE_NUMBER: + return "NUMBER"; + case TOKEN_TYPE_CHAR: + return "CHAR"; + case TOKEN_TYPE_STRING: + return "STRING"; + case TOKEN_TYPE_COMMA: + return "COMMA"; + case TOKEN_TYPE_BACKQUOTE: + return "BACKQUOTE"; + case TOKEN_TYPE_SPLICE: + return "SPLICE"; + case TOKEN_TYPE_UNKNOWN: + return "UNKNOWN"; + } +} + static void append_char(Token *token, char new_char) { if (token->len >= token->buf_len) { token->buf_len = token->len + 1; @@ -31,18 +64,20 @@ static void copy_to_buffer(Token *token, const char *src, size_t src_len) { } static int issymbolend(int c) { - return isspace(c) || c == ')' || c == ']'; + return isspace(c) || c == ')' || c == ']' || c == '(' || + c == '[' || c == ','; } // takes the string arguments static void token_stream_push_error(TokenStream *stream, Token *token, - char *desc) { + char *desc, bool at_end) { ParseError *err = malloc(sizeof(ParseError)); err->next = NULL; err->col = token->col; err->line = token->line; err->desc = desc; err->context = malloc(token->len + 1); + err->at_end = at_end; memcpy(err->context, token->text, token->len); err->context[token->len] = '\0'; if (stream->error_tail) { @@ -120,6 +155,9 @@ static void next_string(TokenStream *stream, Token *token) { if (c == '\\' && !backslash) { backslash = true; } else { + if (backslash && c != '"') { + append_char(token, '\\'); + } backslash = false; append_char(token, c); if (c == '\n') { @@ -131,11 +169,13 @@ static void next_string(TokenStream *stream, Token *token) { } } ++stream->col; - append_char(token, '"'); - append_null_byte(token); if (feof(stream->src)) { - token_stream_push_error(stream, token, - strdup("expected '\"', got EOF")); + token_stream_push_error(stream, token, strdup("expected '\"', got EOF"), + true); + append_null_byte(token); + } else { + append_char(token, '"'); + append_null_byte(token); } } @@ -163,21 +203,28 @@ static void next_char_literal(TokenStream *stream, Token *token) { stream->col += 2; if (c == EOF) { token_stream_push_error(stream, token, - strdup("expected character literal, got EOF")); + strdup("expected character literal, got EOF"), + true); token->len = 0; token->type = TOKEN_TYPE_UNKNOWN; + c = fgetc(stream->src); } else if (c == '\\') { - // named character literal, like "#\newline" - while ((c = fgetc(stream->src)) != EOF && isalpha(c)) { + // named character literal, like "#\n" + while ((c = fgetc(stream->src)) != EOF && + (isalpha(c) || isdigit(c) || c == '\\')) { append_char(token, c); ++stream->col; } + } else { + c = fgetc(stream->src); } append_null_byte(token); - c = fgetc(stream->src); + // the ifs above do this + // c = fgetc(stream->src); if (c != EOF && !issymbolend(c)) { token_stream_push_error(stream, token, - strdup("character literal too long")); + strdup("character literal too long"), + false); skip_while(stream, &issymbolend, true); } else { ungetc(c, stream->src); @@ -281,7 +328,7 @@ static void next_number_or_symbol(TokenStream *stream, Token *token, char first_ allow_plus_minus = true; append_char(token, c); continue; - } else if (c == 'e') { + } else if (base == 10 && c == 'e') { if (has_exp) { token->type = TOKEN_TYPE_SYMBOL; ungetc(c, stream->src); @@ -338,13 +385,30 @@ size_t token_stream_next(TokenStream *stream, Token *token) { } else if (nc == '\'') { token->type = TOKEN_TYPE_QUOTE; next_char(stream, token); + } else if (nc == '`') { + token->type = TOKEN_TYPE_BACKQUOTE; + next_char(stream, token); + } else if (nc == ',') { + // look at character after the m + char chars[2]; + chars[0] = fgetc(stream->src); + chars[1] = fgetc(stream->src); + if (chars[1] == '@') { + token->type = TOKEN_TYPE_SPLICE; + copy_to_buffer(token, chars, 2); + } else { + ungetc(chars[1], stream->src); + token->type = TOKEN_TYPE_COMMA; + copy_to_buffer(token, chars, 1); + } } else if (nc == '"') { token->type = TOKEN_TYPE_STRING; - next_string(stream, token); + next_string(stream, token); } else if (nc == '.') { // look at character after the . char chars[2]; - fread(chars, 1, 2, stream->src); + chars[0] = fgetc(stream->src); + chars[1] = fgetc(stream->src); ungetc(chars[1], stream->src); if (isspace(chars[1])) { ++stream->col; @@ -352,7 +416,7 @@ size_t token_stream_next(TokenStream *stream, Token *token) { copy_to_buffer(token, ".", 1); } else { // the . is part of something bigger - next_number_or_symbol(stream, token, chars[1]); + next_number_or_symbol(stream, token, chars[0]); } } else if (nc == '#') { token->type = TOKEN_TYPE_CHAR; @@ -393,13 +457,6 @@ void parse_error_free(ParseError *error) { } } -void read_native(FILE *src, LispObject ***result, size_t *result_len, - ParseError *errors, size_t *error_count) { - TokenStream *stream = make_token_stream(src); - errors = stream->error_head; - stream->error_head = NULL; - stream->error_tail = NULL; - stream->error_count = 0; - *error_count = stream->error_count; - destroy_token_stream(stream); +bool token_stream_is_eof(TokenStream *stream) { + return feof(stream->src); } diff --git a/src/parse.h b/bootstrap/parse.h similarity index 81% rename from src/parse.h rename to bootstrap/parse.h index 7bffbf2..712a199 100644 --- a/src/parse.h +++ b/bootstrap/parse.h @@ -1,13 +1,15 @@ +#ifndef INCLUDED_PARSE_H +#define INCLUDED_PARSE_H + #include #include -#include "lisp.h" - typedef struct { size_t line; size_t col; char *context; char *desc; + bool at_end; void *next; } ParseError; @@ -32,6 +34,9 @@ typedef enum { TOKEN_TYPE_SYMBOL, TOKEN_TYPE_PROPERTY, TOKEN_TYPE_QUOTE, + TOKEN_TYPE_BACKQUOTE, + TOKEN_TYPE_SPLICE, + TOKEN_TYPE_COMMA, TOKEN_TYPE_CHAR, TOKEN_TYPE_NUMBER, TOKEN_TYPE_STRING, @@ -46,6 +51,8 @@ typedef struct { size_t col; } Token; +const char *token_type_to_str(TokenType type) __attribute__((unused)); + // src is taken by this function TokenStream *make_token_stream(FILE *src); void destroy_token_stream(TokenStream *stream); @@ -55,6 +62,6 @@ void token_free(Token *token); // return the number of errors left ParseError *token_stream_error(TokenStream *stream); void parse_error_free(ParseError *error); +bool token_stream_is_eof(TokenStream *stream); -void read_native(FILE *src, LispObject ***result, size_t *result_len, - ParseError *errors, size_t *error_count); +#endif diff --git a/bootstrap/test.sl b/bootstrap/test.sl new file mode 100644 index 0000000..757c416 --- /dev/null +++ b/bootstrap/test.sl @@ -0,0 +1 @@ +'('a `(,a '(,a))) \ No newline at end of file diff --git a/src/lisp.c b/src/lisp.c deleted file mode 100644 index 549485d..0000000 --- a/src/lisp.c +++ /dev/null @@ -1,1293 +0,0 @@ -#include "lisp.h" - -#include -#include -#include -#include - -void *Vnil; -LISP_DEFVAR(t); -LISP_DEFVAR(module); -LISP_DEFVAR(all_functions); -LISP_DEFVAR(globals); -LISP_DEFVAR(classes); - -#ifndef NDEBUG -static size_t _lost_allocs = 0; - -static void *lisp_realloc(void *old_ptr, size_t n) { - if (!old_ptr) { - ++_lost_allocs; - } - void *ptr = realloc(old_ptr, n); - if (n && !ptr) { - abort(); - } - return ptr; -} - -// not implemented with realloc to make stack traces more obvious -static void *lisp_malloc(size_t n) { - void *ptr = malloc(n); - ++_lost_allocs; - if (n && !ptr) { - abort(); - } - return ptr; -} - -static void *lisp_calloc(size_t nmemb, size_t size) { - ++_lost_allocs; - void *ptr = calloc(nmemb, size); - if (size && nmemb && !ptr) { - abort(); - } - return ptr; -} - -static void lisp_free(void *ptr) { - --_lost_allocs; - free(ptr); -} - -#define malloc lisp_malloc -#define calloc lisp_calloc -#define free lisp_free -#define realloc lisp_realloc -#endif - -LispObject *native_type_symbols[LISP_N_NATIVE_TYPES]; -LispSymbol *system_module; -LispInstance *current_error; -StackFrame *call_stack; -size_t call_stack_size; - -// Error classes -LispClass *error_class; -LispClass *type_error_class; -LispClass *argument_error_class; -LispClass *function_not_found_error_class; -LispClass *class_slot_error_class; - -#define _NATIVE_TYPE_SYMBOL(NAME, name) \ - native_type_symbols[LISP_TYPE_ ## NAME] = ref_lisp_object( \ - INTERN_LITERAL(# name)) -static void fill_native_type_symbol_table() { - _NATIVE_TYPE_SYMBOL(NIL, nil); - _NATIVE_TYPE_SYMBOL(SYMBOL, symbol); - _NATIVE_TYPE_SYMBOL(CONS, cons); - _NATIVE_TYPE_SYMBOL(STRING, string); - _NATIVE_TYPE_SYMBOL(ARRAY, array); - _NATIVE_TYPE_SYMBOL(INT, int); - _NATIVE_TYPE_SYMBOL(FLOAT, float); - _NATIVE_TYPE_SYMBOL(FUNCTION, function); - _NATIVE_TYPE_SYMBOL(CLASS, class); - _NATIVE_TYPE_SYMBOL(HASH_TABLE, hash_table); - _NATIVE_TYPE_SYMBOL(INSTANCE, instance); - _NATIVE_TYPE_SYMBOL(POINTER, pointer); -} -#undef _NATIVE_TYPE_SYMBOL - -void *ref_lisp_object(void *obj) { - if (obj && !AS_OBJECT(obj)->persist) { - ++AS_OBJECT(obj)->ref_count; - } - return obj; -} - -void *unref_lisp_object(void *obj) { - if (obj && !AS_OBJECT(obj)->persist && AS_OBJECT(obj)->ref_count <= 1) { - switch (AS_OBJECT(obj)->type) { - case LISP_TYPE_SYMBOL: - unref_lisp_object(((LispSymbol *) obj)->name); - break; - case LISP_TYPE_CONS: - unref_lisp_object(((LispCons *) obj)->car); - unref_lisp_object(((LispCons *) obj)->cdr); - break; - case LISP_TYPE_STRING: - if (!((LispString *) obj)->skip_free) { - free(((LispString *) obj)->text); - } - break; - case LISP_TYPE_ARRAY: - for (size_t i = 0; i < ((LispArray *) obj)->length; ++i) { - unref_lisp_object(((LispArray *) obj)->data[i]); - } - free(((LispArray *) obj)->data); - break; - case LISP_TYPE_FUNCTION: - if (!((LispFunction *) obj)->nativep) { - unref_lisp_object(((LispFunction *) obj)->lisp.form); - unref_lisp_object(((LispFunction *) obj)->lisp.pargs); - unref_lisp_object(((LispFunction *) obj)->lisp.oargs); - unref_lisp_object(((LispFunction *) obj)->lisp.rarg); - } - unref_lisp_object(((LispFunction *) obj)->doc); - break; - case LISP_TYPE_HASH_TABLE: - for (size_t i = 0; i < ((LispHashTable *) obj)->size; ++i) { - struct LispHashTableBucket *p = ((LispHashTable *) obj)->data[i]; - while (p) { - unref_lisp_object(p->key); - unref_lisp_object(p->value); - struct LispHashTableBucket *next = p->next; - free(p); - p = next; - } - } - free(((LispHashTable *) obj)->data); - unref_lisp_object(((LispHashTable *) obj)->hash_func); - unref_lisp_object(((LispHashTable *) obj)->eq_func); - break; - case LISP_TYPE_CLASS: - unref_lisp_object(((LispClass *) obj)->name); - unref_lisp_object(((LispClass *) obj)->module); - unref_lisp_object(((LispClass *) obj)->slots); - unref_lisp_object(((LispClass *) obj)->constructor); - unref_lisp_object(((LispClass *) obj)->methods); - unref_lisp_object(((LispClass *) obj)->superclass); - break; - case LISP_TYPE_INSTANCE: - unref_lisp_object(((LispInstance *) obj)->class); - unref_lisp_object(((LispInstance *) obj)->slots); - break; - case LISP_TYPE_POINTER: - if (((LispPointer *) obj)->free_func) { - ((LispPointer *) obj)->free_func(((LispPointer *) obj)->data); - } - break; - case LISP_TYPE_NIL: - case LISP_TYPE_INT: - case LISP_TYPE_FLOAT: - // these don't need any extra steps - break; - case LISP_N_NATIVE_TYPES: - abort(); - } - free(obj); - return Vnil; - } else { - --AS_OBJECT(obj)->ref_count; - return obj; - } -} - -void *lisp_check_type(LispType type, void *obj) { - if (TYPE_OF(obj) != type) { - ERROR(type_error_class, - "expected", - ((LispSymbol *) native_type_symbols[type])->name, - "got", TYPE_STR(obj)); - } - return obj; -} - -LispObject *call_native(LispObject *(*func)(size_t argc, LispObject **argv), - size_t argc, ...) { - LispObject *arr[argc]; - va_list args; - va_start(args, argc); - for (size_t i = 0; i < argc; ++i) { - arr[i] = va_arg(args, LispObject *); - } - va_end(args); - LispObject *retval = func(argc, arr); - return retval; -} - -LispString *make_lisp_string(const char *text, size_t length, bool skip_free) { - LispString *obj = malloc(sizeof(LispString)); - obj->parent.type = LISP_TYPE_STRING; - obj->parent.ref_count = 0; - obj->parent.persist = false; - obj->length = length; - if (skip_free) { - obj->text = (char *) text; - } else { - obj->text = malloc(length + 1); - memcpy(obj->text, text, length); - obj->text[length] = '\0'; - } - obj->skip_free = skip_free; - return obj; -} - -LispInt *make_lisp_int(int64_t value) { - LispInt *obj = malloc(sizeof(LispInt)); - obj->parent.type = LISP_TYPE_INT; - obj->parent.ref_count = 0; - obj->parent.persist = false; - obj->value = value; - return obj; -} - -LispFloat *make_lisp_float(double value) { - LispFloat *obj = malloc(sizeof(LispFloat)); - obj->parent.type = LISP_TYPE_INT; - obj->parent.ref_count = 0; - obj->parent.persist = false; - obj->value = value; - return obj; -} - -LispSymbol *make_lisp_symbol(const char *text, size_t length, bool skip_free) { - LispSymbol *obj = malloc(sizeof(LispSymbol)); - obj->parent.type = LISP_TYPE_SYMBOL; - obj->parent.ref_count = 0; - obj->parent.persist = false; - obj->name = ref_lisp_object(make_lisp_string(text, length, skip_free)); - return obj; -} - -LispFunction *make_native_function(bool macrop, size_t nparg, size_t noarg, bool rargp, - LispObject *(*action)(size_t argc, - LispObject **argv)) { - LispFunction *obj = malloc(sizeof(LispFunction)); - obj->parent.type = LISP_TYPE_FUNCTION; - obj->parent.ref_count = 0; - obj->parent.persist = false; - obj->doc = Vnil; - obj->nativep = true; - obj->macrop = macrop; - obj->native.action = action; - obj->native.nparg = nparg; - obj->native.noarg = noarg; - obj->native.rargp = rargp; - return obj; -} - -void register_in_module(LispHashTable *table, LispSymbol *module, - LispSymbol *name, LispObject *thing) { - LispHashTable *module_table = (void *) call_native(Fgethash, 2, table, module); - if (NILP(module_table)) { - module_table = (LispHashTable *) call_native(Fmake_hash_table, 2, Vnil, Vnil); - call_native(Fputhash, 3, table, module, module_table); - } - call_native(Fputhash, 3, module_table, name, thing); -} - -LispObject *lookup_in_module(LispHashTable *table, LispSymbol *module, - LispSymbol *name, bool include_system) { - LispHashTable *module_table = (void *) call_native(Fgethash, 2, table, module); - if (NILP(module_table)) { - if (include_system) { - return lookup_in_module(table, system_module, name, false); - } - return Vnil; - } - LispObject *result = call_native(Fgethash, 2, module_table, name); - if (NILP(result) && include_system) { - result = lookup_in_module(table, system_module, name, false); - } - return result; -} - -#define register_function(module, name, func) \ - register_in_module((void *) Vall_functions, module, name, (void *) func) -#define lookup_function(module, name) \ - ((LispFunction *) lookup_in_module((void *) Vall_functions, module, name, true)) -#define register_class(class) \ - register_in_module((void *) Vclasses, (class)->module, (class)->name, (void *) class) - -LispClass *make_lisp_class(LispSymbol *name, LispSymbol *module, - LispClass *superclass, LispFunction *constructor, - LispCons *slots) { - LispHashTable *slot_table = (void *) call_native(Fmake_hash_table, 2, Vnil, Vnil); - size_t super_high_slot = NILP(superclass) ? 0 : superclass->high_slot; - size_t i = 0; - DOLIST(slot, slots, { - call_native(Fputhash, 3, slot_table, slot, - make_lisp_int(super_high_slot + i)); - ++i; - }) - LispClass *obj = malloc(sizeof(LispClass)); - obj->parent.type = LISP_TYPE_CLASS; - obj->parent.ref_count = 0; - obj->parent.persist = false; - obj->name = ref_lisp_object(name); - obj->module = ref_lisp_object(module); - obj->constructor = ref_lisp_object(constructor); - obj->superclass = ref_lisp_object(superclass); - obj->high_slot = super_high_slot + slot_table->count; - obj->slots = ref_lisp_object(slot_table); - obj->methods = ref_lisp_object(call_native(Fmake_hash_table, 2, Vnil, Vnil)); - return obj; -} - -// init_data can be NULL (not nil, actually NULL) -LispArray *make_lisp_array(size_t size, LispObject **init_data) { - LispArray *obj = malloc(sizeof(LispArray)); - obj->parent.type = LISP_TYPE_ARRAY; - obj->parent.persist = false; - obj->parent.ref_count = 0; - obj->length = size; - obj->data = calloc(size, sizeof(LispObject *)); - if (init_data) { - for (size_t i = 0; i < size; ++i) { - obj->data[i] = ref_lisp_object(init_data[i]); - } - } else { - for (size_t i = 0; i < size; ++i) { - obj->data[i] = Vnil; - } - } - return obj; -} -#define LISP_ARRAY(array) (make_lisp_array(sizeof(array) / sizeof(LispObject *), \ - array)) - -static int64_t lookup_class_slot(LispClass *class, LispSymbol *slot) { - LispObject *slot_index = Vnil; - while (NILP(slot_index)) { - if (NILP(class)) { - return -1; - } - slot_index = call_native(Fgethash, 2, class->slots, slot); - class = class->superclass; - } - return ((LispInt *) slot_index)->value; -} - -static void call_constructors(LispClass *class, LispInstance *inst) { - if (!NILP(class)) { - call_constructors(class->superclass, inst); - if (!NILP(class->constructor)) { - call_native(Ffuncall, 2, class->constructor, inst); - } - } -} - -LispInstance *make_lisp_instance(LispClass *class, LispHashTable *slots) { - LispInstance *obj = malloc(sizeof(LispInstance)); - obj->parent.type = LISP_TYPE_INSTANCE; - obj->parent.persist = false; - obj->parent.ref_count = 0; - obj->class = ref_lisp_object(class); - obj->slots = ref_lisp_object(make_lisp_array(class->high_slot, NULL)); - DOHASH(key, value, slots, { - int64_t index = lookup_class_slot(class, (LispSymbol *) key); - if (index < 0) { - // TODO error - break; - } - obj->slots->data[index] = ref_lisp_object(value); - }) - call_constructors(class, obj); - return obj; -} - -LispPointer *make_lisp_pointer(void *data, void(*free_func)(void *)) { - LispPointer *obj = malloc(sizeof(LispPointer)); - obj->parent.type = LISP_TYPE_POINTER; - obj->parent.persist = false; - obj->parent.ref_count = 0; - obj->data = data; - obj->free_func = free_func; - return obj; -} - -bool instanceof(LispInstance *instance, LispClass *class) { - LispClass *icls = instance->class; - while (!NILP(icls)) { - if (!NILP(call_native(Feq, 2, icls, class))) { - return true; - } - icls = icls->superclass; - } - return false; -} - -size_t list_length(LispCons *list) { - size_t len = 0; - DOLIST(elem, list, { - ++len; - }) - return len; -} - -void push_stack(LispSymbol *block_name, StackFramePlace *place, jmp_buf *jmp, - LispHashTable *handlers) { - StackFrame *frame = malloc(sizeof(StackFrame)); - frame->up = call_stack; - frame->block_name = ref_lisp_object(block_name); - frame->jmp = jmp; - frame->handlers = ref_lisp_object(call_native(Fmake_hash_table, 2, - INTERN_LITERAL("hash-as-zero"), - INTERN_LITERAL("subclassp"))); - if (!NILP(handlers)) { - DOHASH(key, val, handlers, { - call_native(Fputhash, 3, frame->handlers, key, val); - }) - } - if (place) { - frame->has_place = true; - frame->place = *place; - ref_lisp_object(frame->place.file); - } else { - frame->has_place= false; - } - frame->locals = ref_lisp_object(call_native(Fmake_hash_table, 2, Vnil, Vnil)); - frame->extras = EMPTY_LIST; - frame->cleanup = EMPTY_LIST; - ++call_stack_size; - call_stack = frame; -} - -void pop_stack() { - unref_lisp_object(current_error); - current_error = Vnil; - StackFrame *frame = call_stack; - DOLIST(form, frame->cleanup, { - call_native(Feval, 1, form); - }) - unref_lisp_object(frame->block_name); - unref_lisp_object(frame->handlers); - unref_lisp_object(frame->locals); - unref_lisp_object(frame->extras); - unref_lisp_object(frame->cleanup); - if (frame->has_place) { - unref_lisp_object(frame->place.file); - } - --call_stack_size; - call_stack = frame->up; - free(frame); -} - -void add_auto_unref(void *obj) { - call_stack->extras = CONS(obj, call_stack->extras); - unref_lisp_object(obj); // because cons refs its arguments -} - -void dump_stack(LispInstance *error) { - LispObject *trace_sym = INTERN_LITERAL("-stack-trace"); - LispCons *trace_list = (void *) call_native(Fslot, 2, error, trace_sym); - DOLIST(trace_obj, trace_list, { - LispObject *file_sym = INTERN_LITERAL("file"); - LispObject *block_sym = INTERN_LITERAL("block"); - LispObject *line_sym = INTERN_LITERAL("line"); - LispObject *column_sym = INTERN_LITERAL("column"); - LispString *file = AS_STRING(call_native(Fslot, 2, trace_obj, file_sym)); - LispSymbol *block = AS_SYMBOL(call_native(Fslot, 2, trace_obj, block_sym)); - LispInt *line = AS_INT(call_native(Fslot, 2, trace_obj, line_sym)); - LispInt *column = AS_INT(call_native(Fslot, 2, trace_obj, column_sym)); - // TODO use some lisp printing functions - fprintf(stderr, " %*s ", (int) block->name->length, block->name->text); - fprintf(stderr, "(%*s:%zu:%zu)\n", (int) file->length, file->text, - (size_t) line->value, (size_t) column->value); - unref_lisp_object(file_sym); - unref_lisp_object(block_sym); - unref_lisp_object(line_sym); - unref_lisp_object(column_sym); - }) - unref_lisp_object(trace_sym); -} - -void throw_error(LispInstance *error) { - if (!instanceof(error, error_class)) { - TYPE_ERROR("error (or a subclass thereof)", TYPE_STR(error)); - } - StackFrame *current_frame = call_stack; - while (current_frame) { - LispInt *handler = (void *) call_native(Fgethash, 2, - current_frame->handlers, - error->class); - int64_t err_index = NILP(handler) ? 0 : handler->value; - jmp_buf *jmp = call_stack->jmp; - if (err_index != 0) { - while (call_stack != current_frame) { - pop_stack(); - } - current_error = ref_lisp_object(error); - longjmp(*jmp, err_index); - } - current_frame = current_frame->up; - } - // The error has propagated to the top of the call stack, so we exit... - // TODO use lisp printing functions - LispSymbol *message_slot = ref_lisp_object(INTERN_LITERAL("message")); - LispString *message = (void *) call_native(Fslot, 2, error, message_slot); - if (STRINGP(message)) { - fprintf(stderr, "Uncaught %*s: %*s\n", - (int) error->class->name->name->length, - error->class->name->name->text, - (int) message->length, message->text); - } else { - fprintf(stderr, "Uncaught %*s: nil\n", - (int) error->class->name->name->length, - error->class->name->name->text); - } - dump_stack(error); - exit(1); -} - -// Easy interface to create objects and classes -LispClass *new_class(LispClass *superclass, LispSymbol *module, - const char *name, bool skip_free, LispFunction *constructor, - ...) { - LispSymbol *name_sym = make_lisp_symbol(name, strlen(name), skip_free); - LispCons *slot_list = EMPTY_LIST; - va_list args; - va_start(args, constructor); - const char *slot_name = va_arg(args, const char *); - while (slot_name) { - slot_list = CONS(make_lisp_symbol(slot_name, strlen(slot_name), true), - slot_list); - slot_name = va_arg(args, const char *); - } - va_end(args); - LispClass *class = make_lisp_class(name_sym, module, superclass, - constructor, slot_list); - unref_lisp_object(slot_list); - return class; -} - -LispInstance *new_instance(LispClass *class, ...) { - va_list args; - va_start(args, class); - const char *slot_name = va_arg(args, const char *); - LispHashTable *slots = (void *) call_native(Fmake_hash_table, 2, Vnil, Vnil); - while (slot_name) { - size_t len = strlen(slot_name); - LispSymbol *slot_sym = make_lisp_symbol(slot_name, len, true); - LispObject *slot_value = va_arg(args, LispObject *); - call_native(Fputhash, 3, slots, slot_sym, slot_value); - slot_name = va_arg(args, const char *); - } - LispInstance *obj = make_lisp_instance(class, slots); - unref_lisp_object(slots); - va_end(args); - return obj; -} - -#define _REGISTER_NATIVE(lisp_name, name, macrop, nparg, noarg, rargp) \ - register_function(system_module, (void *) INTERN_LITERAL(# lisp_name), \ - make_native_function(macrop, nparg, noarg, rargp, F ## name)) -static void register_native_functions() { - _REGISTER_NATIVE(symbolp, symbolp, false, 1, 0, false); - _REGISTER_NATIVE(stringp, stringp, false, 1, 0, false); - _REGISTER_NATIVE(consp, consp, false, 1, 0, false); - _REGISTER_NATIVE(arrayp, arrayp, false, 1, 0, false); - _REGISTER_NATIVE(intp, intp, false, 1, 0, false); - _REGISTER_NATIVE(floatp, floatp, false, 1, 0, false); - _REGISTER_NATIVE(functionp, functionp, false, 1, 0, false); - _REGISTER_NATIVE(hash-table-p, hash_table_p, false, 1, 0, false); - _REGISTER_NATIVE(classp, classp, false, 1, 0, false); - _REGISTER_NATIVE(instancep, instancep, false, 1, 0, false); - - _REGISTER_NATIVE(listp, listp, false, 1, 0, false); - _REGISTER_NATIVE(atom, atom, false, 1, 0, false); - _REGISTER_NATIVE(cons, cons, false, 2, 0, false); - _REGISTER_NATIVE(intern, intern, false, 1, 0, false); - _REGISTER_NATIVE(not, not, false, 1, 0, false); - _REGISTER_NATIVE(hash, hash, false, 1, 0, false); - _REGISTER_NATIVE(make-hash-table, make_hash_table, false, 0, 2, false); - _REGISTER_NATIVE(float, float, false, 1, 0, false); - _REGISTER_NATIVE(eq, eq, false, 2, 0, false); - _REGISTER_NATIVE(gethash, gethash, false, 2, 0, false); - _REGISTER_NATIVE(puthash, puthash, false, 3, 0, false); - _REGISTER_NATIVE(remhash, remhash, false, 2, 0, false); - _REGISTER_NATIVE(symbol-function, symbol_function, false, 1, 0, false); - _REGISTER_NATIVE(funcall, funcall, false, 1, 0, true); - _REGISTER_NATIVE(apply, apply, false, 1, 0, true); - _REGISTER_NATIVE(eval, eval, false, 1, 0, false); - _REGISTER_NATIVE(superclassp, superclassp, false, 2, 0, false); - _REGISTER_NATIVE(subclassp, subclassp, false, 2, 0, false); - _REGISTER_NATIVE(hash-as-zero, hash_as_zero, false, 1, 0, false); - - // These are special forms, their arguments are NOT evaluated - _REGISTER_NATIVE(quote, or, true, 0, 0, true); - _REGISTER_NATIVE(and, and, true, 0, 0, true); - _REGISTER_NATIVE(or, or, true, 0, 0, true); -} -#undef _REGISTER_NATIVE - -static LispClass *lisp_stack_frame_class; - -static LispObject *error_constructor(size_t argc, LispObject **argv) { - LispObject *trace_sym = INTERN_LITERAL("-stack-trace"); - StackFrame *frame = call_stack; - LispCons *trace_list = EMPTY_LIST; - while (frame) { - if (frame->block_name && frame->has_place) { - LispString *file; - if (frame->place.is_native) { - file = STRING_FROM_LITERAL(""); - } else { - file = frame->place.file; - } - trace_list = CONS(new_instance(lisp_stack_frame_class, - "file", file, - "block", frame->block_name, - "line", make_lisp_int(frame->place.line), - "column", make_lisp_int(frame->place.col), - NULL), - trace_list); - } - frame = frame->up; - } - call_native(Fsetslot, 3, argv[0], trace_sym, trace_list); - unref_lisp_object(trace_sym); - return Vnil; -} - -static LispObject *type_error_constructor(size_t argc, LispObject **argv) { - LispInstance *inst = AS_INSTANCE(argv[0]); - LispObject *message_sym = INTERN_LITERAL("message"); - LispObject *expected_sym = INTERN_LITERAL("expected"); - LispObject *got_sym = INTERN_LITERAL("got"); - LispString *expected = AS_STRING(call_native(Fslot, 2, inst, expected_sym)); - LispString *got = AS_STRING(call_native(Fslot, 2, inst, got_sym)); - // TODO use format - const char format[] = "expected %s; got %s"; - char msg[sizeof(format) - 4 + expected->length + got->length]; - sprintf(msg, format, expected->text, got->text); - LispString *msg_obj = make_lisp_string(msg, sizeof(msg) - 1, false); - call_native(Fsetslot, 3, inst, message_sym, msg_obj); - unref_lisp_object(message_sym); - unref_lisp_object(expected_sym); - unref_lisp_object(got_sym); - return Vnil; -} - -static LispObject *argument_error_constructor(size_t argc, LispObject **argv) { - LispInstance *inst = AS_INSTANCE(argv[0]); - LispObject *message_sym = INTERN_LITERAL("message"); - LispObject *expected_sym = INTERN_LITERAL("expected"); - LispObject *got_sym = INTERN_LITERAL("got"); - LispInt *got = AS_INT(call_native(Fslot, 2, inst, got_sym)); - LispObject *expected = call_native(Fslot, 2, inst, expected_sym); - // TODO use format - switch (TYPE_OF(expected)) { - case LISP_TYPE_STRING: - { - const char format[] = "expected %s arguments; got %zu"; - char msg[sizeof(format) - 5 + 128 + ((LispString *) expected)->length]; - sprintf(msg, format, ((LispString *) expected)->text, (size_t) got->value); - LispString *msg_obj = make_lisp_string(msg, sizeof(msg) - 1, false); - call_native(Fsetslot, 3, inst, message_sym, msg_obj); - } - break; - case LISP_TYPE_NIL: - default: - { - const char format[] = "got %zu arguments"; - char msg[sizeof(format) - 3 + 128]; - sprintf(msg, format, (size_t) got->value); - LispString *msg_obj = make_lisp_string(msg, sizeof(msg) - 1, false); - call_native(Fsetslot, 3, inst, message_sym, msg_obj); - } - break; - } - unref_lisp_object(message_sym); - unref_lisp_object(expected_sym); - unref_lisp_object(got_sym); - return Vnil; -} - -static LispObject *function_not_found_error_constructor(size_t argc, - LispObject **argv) { - LispInstance *inst = AS_INSTANCE(argv[0]); - LispObject *message_sym = INTERN_LITERAL("message"); - LispObject *name_sym = INTERN_LITERAL("name"); - LispString *name = AS_STRING(call_native(Fslot, 2, inst, name_sym)); - // TODO use format - const char format[] = "unknown function: %s"; - char msg[sizeof(format) - 2 + name->length]; - sprintf(msg, format, name->text); - LispString *msg_obj = make_lisp_string(msg, sizeof(msg) - 1, false); - call_native(Fsetslot, 3, inst, message_sym, msg_obj); - unref_lisp_object(name_sym); - unref_lisp_object(message_sym); - return Vnil; -} - -static LispObject *class_slot_error_constructor(size_t argc, LispObject **argv) { - LispInstance *inst = AS_INSTANCE(argv[0]); - LispObject *message_sym = INTERN_LITERAL("message"); - LispObject *class_sym = INTERN_LITERAL("class"); - LispObject *name_sym = INTERN_LITERAL("name"); - LispClass *class = AS_CLASS(call_native(Fslot, 2, inst, class_sym)); - LispString *name = AS_STRING(call_native(Fslot, 2, inst, name_sym)); - // TODO use format - const char format[] = "class %s has no slot %s"; - char msg[sizeof(format) - 4 + name->length + class->name->name->length]; - sprintf(msg, format, name->text, class->name->name->text); - LispString *msg_obj = make_lisp_string(msg, sizeof(msg) - 1, false); - call_native(Fsetslot, 3, inst, message_sym, msg_obj); - unref_lisp_object(name_sym); - unref_lisp_object(class_sym); - unref_lisp_object(message_sym); - return Vnil; -} - -#define _REGISTER_ERROR(cvar, name, ...) \ - cvar ## _class = new_class(error_class, system_module, # name, true, \ - make_native_function(false, 1, 0, \ - false, cvar ## _constructor), \ - __VA_ARGS__, NULL); \ - register_class(cvar ## _class); - -static void register_error_classes() { - lisp_stack_frame_class = new_class(Vnil, system_module, - "stack-frame", true, Vnil, - "file", "block", "line", "column", NULL); - register_class(lisp_stack_frame_class); - - error_class = new_class(Vnil, system_module, - "error", true, - make_native_function(false, 1, 0, - false, error_constructor), - "message", "-stack-trace", NULL); - register_class(error_class); - - _REGISTER_ERROR(type_error, type-error, "expected", "got"); - _REGISTER_ERROR(argument_error, argument-error, "expected", "got"); - _REGISTER_ERROR(function_not_found_error, function-not-found-error, "name"); - _REGISTER_ERROR(class_slot_error, class-slot-error, "class", "name"); -} -#undef _REGISTER_ERROR - -void init_lisp() { - // define nil - Vnil = malloc(sizeof(LispObject)); - ((LispObject *) Vnil)->type = LISP_TYPE_NIL; - ((LispObject *) Vnil)->persist = true; - - // define t - Vt = ref_lisp_object(INTERN_LITERAL("t")); - - // The stack... - call_stack = NULL; - call_stack_size = 0; - - // Modules - system_module = ref_lisp_object(INTERN_LITERAL("sl")); - Vmodule = ref_lisp_object(INTERN_LITERAL("sl-user")); - - // Symbols for native types - fill_native_type_symbol_table(); - - // Important tables - Vall_functions = call_native(Fmake_hash_table, 2, Vnil, Vnil); - Vglobals = call_native(Fmake_hash_table, 2, Vnil, Vnil); - Vclasses = call_native(Fmake_hash_table, 2, Vnil, Vnil); - - // Errors - current_error = Vnil; - register_error_classes(); - - // Native functions - register_native_functions(); -} - -void deinit_lisp() { - while (call_stack) { - pop_stack(); - } - - unref_lisp_object(Vclasses); - unref_lisp_object(Vglobals); - unref_lisp_object(Vall_functions); - unref_lisp_object(Vmodule); - - unref_lisp_object(system_module); - - for (size_t i = 0; i < LISP_N_NATIVE_TYPES; ++i) { - unref_lisp_object(native_type_symbols[i]); - } - - Vt->persist = false; - Vt->ref_count = 0; - ((LispSymbol *) Vt)->name->parent.persist = false; - ((LispSymbol *) Vt)->name->parent.ref_count = 0; - unref_lisp_object(Vt); - - free(Vnil); - -#ifndef NDEBUG - if (_lost_allocs) { - fprintf(stderr, "WARNING: lost %zu allocations!!\n", _lost_allocs); - } -#endif -} - -#define _DEFINE_TYPE_PRED(NAME, name) \ -LISP_DEFUN(name ## p) { \ - return LISP_BOOL(NAME ## P (argv[0])); \ -} - -_DEFINE_TYPE_PRED(SYMBOL, symbol) -_DEFINE_TYPE_PRED(STRING, string) -_DEFINE_TYPE_PRED(CONS, cons) -_DEFINE_TYPE_PRED(ARRAY, array) -_DEFINE_TYPE_PRED(INT, int) -_DEFINE_TYPE_PRED(FLOAT, float) -_DEFINE_TYPE_PRED(FUNCTION, function) -_DEFINE_TYPE_PRED(LIST, list) -_DEFINE_TYPE_PRED(HASH_TABLE_, hash_table_) -_DEFINE_TYPE_PRED(CLASS, class) -_DEFINE_TYPE_PRED(INSTANCE, instance) -_DEFINE_TYPE_PRED(POINTER, pointer) - -#undef _DEFINE_TYPE_PRED - -LISP_DEFUN(atom) { - return LISP_BOOL(ATOM(argv[0])); -} - -LISP_DEFUN(native) { - return LISP_BOOL(NATIVE(argv[0])); -} - -LISP_DEFUN(type_of) { - if (NATIVE(argv[0])) { - return native_type_symbols[argv[0]->type]; - } else { - return AS_OBJECT(((LispInstance *) argv[0])->class->name); - } -} - -LISP_DEFUN(cons) { - LispCons *obj = malloc(sizeof(LispCons)); - obj->parent.type = LISP_TYPE_CONS; - obj->parent.persist = false; - obj->parent.ref_count = 0; - obj->car = ref_lisp_object(argv[0]); - obj->cdr = ref_lisp_object(argv[1]); - return AS_OBJECT(obj); -} - -LISP_DEFUN(list) { - LispObject *head = Vnil; - for (size_t i = argc; i >= 1; --i) { - head = call_native(Fcons, 2, argv[i - 1], head); - } - return head; -} - -LISP_DEFUN(length) { - switch (TYPE_OF(argv[0])) { - case LISP_TYPE_ARRAY: - return AS_OBJECT(make_lisp_int(((LispArray *) argv[0])->length)); - case LISP_TYPE_STRING: - return AS_OBJECT(make_lisp_int(((LispString *) argv[0])->length)); - case LISP_TYPE_CONS: - case LISP_TYPE_NIL: - return AS_OBJECT(make_lisp_int(list_length((LispCons *) argv[0]))); - case LISP_TYPE_HASH_TABLE: - return AS_OBJECT(make_lisp_int(((LispHashTable *) argv[0])->count)); - default: - TYPE_ERROR("array, string, cons, nil, or hash table", TYPE_STR(argv[0])); - return Vnil; - } -} - -LISP_DEFUN(intern) { - LispString *name = AS_STRING(argv[0]); - LispSymbol *obj = malloc(sizeof(LispSymbol)); - obj->parent.type = LISP_TYPE_SYMBOL; - obj->parent.persist = false; - obj->parent.ref_count = 0; - obj->name = ref_lisp_object(name); - return AS_OBJECT(obj); -} - -LISP_DEFUN(not) { - return LISP_BOOL(NILP(argv[0])); -} - -LISP_DEFUN(hash) { - int64_t h = 37; - switch (TYPE_OF(argv[0])) { - case LISP_TYPE_CLASS: - { - LispClass *cls = (void *) argv[0]; - LispInt *one = ref_lisp_object(call_native(Fhash, 1, cls->module)); - LispInt *two = ref_lisp_object(call_native(Fhash, 1, cls->name)); - LispInt *retval = make_lisp_int(one->value + two->value); - unref_lisp_object(one); - unref_lisp_object(two); - return AS_OBJECT(retval); - } - case LISP_TYPE_SYMBOL: - argv[0] = AS_OBJECT(((LispSymbol *) argv[0])->name); - case LISP_TYPE_STRING: - for (size_t i = 0; i < ((LispString *) argv[0])->length; ++i) { - h = (h * 54059) ^ (((LispString *) argv[0])->text[i] * 76963); - } - return AS_OBJECT(make_lisp_int(h % 86969)); - default: - return AS_OBJECT(make_lisp_int(0)); - } -} - -LISP_DEFUN(make_hash_table) { - if (!NILP(argv[0]) && !SYMBOLP(argv[0]) && !FUNCTIONP(argv[0])) { - TYPE_ERROR("function, symbol, or nil", TYPE_STR(argv[0])); - } - if (!NILP(argv[1]) && !SYMBOLP(argv[1]) && !FUNCTIONP(argv[1])) { - TYPE_ERROR("function, symbol, or nil", TYPE_STR(argv[1])); - } - LispHashTable *obj = malloc(sizeof(LispHashTable)); - obj->parent.type = LISP_TYPE_HASH_TABLE; - obj->parent.ref_count = 0; - obj->parent.persist = false; - obj->size = LISP_HASH_TABLE_INITIAL_SIZE; - obj->count = 0; - obj->data = calloc(obj->size, sizeof(struct LispHashTableBucket)); - obj->hash_func = ref_lisp_object(argv[0]); - obj->eq_func = ref_lisp_object(argv[1]); - return AS_OBJECT(obj); -} - -LISP_DEFUN(float) { - switch (TYPE_OF(argv[0])) { - case LISP_TYPE_INT: - return AS_OBJECT(make_lisp_float(((LispInt *) argv[0])->value)); - case LISP_TYPE_FLOAT: - return argv[0]; - default: - TYPE_ERROR("float or int", TYPE_OF(argv[0])); - return Vnil; - } -} - -LISP_DEFUN(eq) { - if ((INTP(argv[0]) || FLOATP(argv[0])) && - (INTP(argv[1]) || FLOATP(argv[1]))) { - LispFloat *f1 = ref_lisp_object(call_native(Ffloat, 1, argv[0])); - LispFloat *f2 = ref_lisp_object(call_native(Ffloat, 1, argv[1])); - bool equal = f1->value == f2->value; - unref_lisp_object(f1); - unref_lisp_object(f2); - return LISP_BOOL(equal); - } else if (TYPE_OF(argv[0]) == TYPE_OF(argv[1])) { - switch (TYPE_OF(argv[0])) { - case LISP_TYPE_NIL: - return Vt; - case LISP_TYPE_SYMBOL: - return LISP_BOOL(strncmp(((LispSymbol *) argv[0])->name->text, - ((LispSymbol *) argv[1])->name->text, - ((LispSymbol *) argv[1])->name->length) - == 0); - case LISP_TYPE_CLASS: - { - LispObject *one = call_native(Feq, 2, ((LispClass *) argv[0])->name, - ((LispClass *) argv[1])->name); - LispObject *two = call_native(Feq, 2, ((LispClass *) argv[0])->module, - ((LispClass *) argv[1])->module); - return LISP_BOOL(!NILP(one) && !NILP(two)); - } - case LISP_TYPE_FUNCTION: - if (((LispFunction *) argv[0])->nativep) { - return LISP_BOOL(((LispFunction *) argv[0])->native.action == - ((LispFunction *) argv[1])->native.action); - } - // fall-through - default: - return LISP_BOOL(argv[0] == argv[1]); - } - } - return Vnil; -} - -static uint64_t hash_obj_for_table(LispHashTable *table, LispObject *obj) { - LispInt *hash_obj; - if (NILP(table->hash_func)) { - hash_obj = (void *) call_native(Fhash, 1, obj); - } else { - hash_obj = (void *) call_native(Ffuncall, 2, table->hash_func, obj); - } - uint64_t hash = hash_obj->value; - unref_lisp_object(hash_obj); - return hash; -} - -static struct LispHashTableBucket *find_bucket_in_table(LispHashTable *table, - uint64_t hash, - LispObject *obj) { - struct LispHashTableBucket *bucket = table->data[hash % table->size]; - while (bucket) { - bool equal; - if (NILP(table->eq_func)) { - equal = !NILP(call_native(Feq, 2, obj, bucket->key)); - } else { - equal = !NILP(call_native(Ffuncall, 3, table->eq_func, obj, bucket->key)); - } - if (equal) { - break; - } - bucket = bucket->next; - } - return bucket; -} - -LISP_DEFUN(gethash) { - LispHashTable *table = AS_HASH_TABLE(argv[0]); - uint64_t hash = hash_obj_for_table(table, argv[1]); - struct LispHashTableBucket *bucket = find_bucket_in_table(table, hash, argv[1]); - return bucket ? bucket->value : Vnil; -} - -static void size_up_hash_table(LispHashTable *table) { - size_t old_size = table->size; - struct LispHashTableBucket **old_buckets = table->data; - table->size *= 2; - table->data = calloc(table->size, sizeof(struct LispHashTableBucket *)); - for (size_t i = 0; i < old_size; ++i) { - struct LispHashTableBucket *bucket = old_buckets[i]; - while (bucket) { - struct LispHashTableBucket *next = bucket->next; - bucket->next = table->data[next->hash % table->size]; - table->data[next->hash % table->size] = bucket; - bucket = next; - } - } - free(old_buckets); -} - -LISP_DEFUN(puthash) { - LispHashTable *table = AS_HASH_TABLE(argv[0]); - if (table->count == table->size) { - size_up_hash_table(table); - } - - uint64_t hash = hash_obj_for_table(table, argv[1]); - struct LispHashTableBucket *bucket = find_bucket_in_table(table, hash, argv[1]); - if (bucket) { - LispObject *old_value = unref_lisp_object(bucket->value); - bucket->value = argv[1]; - return old_value; - } - struct LispHashTableBucket *nb = malloc(sizeof(struct LispHashTableBucket)); - if (table->data[hash % table->size]) { - table->data[hash % table->size]->prev = nb; - } - nb->next = table->data[hash % table->size]; - nb->prev = NULL; - nb->hash = hash; - nb->key = ref_lisp_object(argv[1]); - nb->value = ref_lisp_object(argv[2]); - table->data[hash % table->size] = nb; - ++table->count; - return argv[2]; -} - -LISP_DEFUN(remhash) { - LispHashTable *table = AS_HASH_TABLE(argv[0]); - uint64_t hash = hash_obj_for_table(table, argv[1]); - struct LispHashTableBucket *bucket = find_bucket_in_table(table, hash, argv[1]); - if (bucket) { - LispObject *old_value = bucket->value; - bucket->prev->next = bucket->next; - bucket->next->prev = bucket->prev; - unref_lisp_object(bucket->key); - free(bucket); - return unref_lisp_object(old_value); - } - return Vnil; -} - -LISP_DEFUN(symbol_function) { - LispSymbol *sym = AS_SYMBOL(argv[0]); - return AS_OBJECT(lookup_function((LispSymbol *) Vmodule, sym)); -} - -static bool check_function_arguments(LispFunction *func, size_t argc) { - size_t nparg, noarg; - bool rargp; - if (func->nativep) { - nparg = func->native.nparg; - noarg = func->native.noarg; - rargp = func->native.rargp; - } else { - nparg = func->lisp.pargs->length; - noarg = func->lisp.oargs->length; - rargp = !NILP(func->lisp.rarg); - } - return argc >= nparg && (rargp || argc <= nparg + noarg); -} - -LISP_DEFUN(funcall) { - LispFunction *func; - if (FUNCTIONP(argv[0])) { - func = (void *) argv[0]; - } else if (SYMBOLP(argv[0])) { - func = lookup_function((LispSymbol *) Vmodule, (LispSymbol *) argv[0]); - if (NILP(func)) { - ERROR(function_not_found_error_class, - "name", ((LispSymbol *) argv[0])->name); - } - } else { - TYPE_ERROR("function or symbol", TYPE_STR(argv[0])); - } - ref_lisp_object(func); - push_stack(Vnil, NULL, NULL, Vnil); - add_auto_unref(func); - if (!check_function_arguments(func, argc - 1)) { - ERROR(argument_error_class, "got", make_lisp_int(argc - 1)); - } - LispObject *retval; - if (func->nativep) { - retval = func->native.action(argc - 1, &argv[1]); - } else { - // TODO call the lisp function - } - pop_stack(); - return retval; -} - -LISP_DEFUN(apply) { - if (NILP(argv[argc - 1]) || !LISTP(argv[argc - 1])) { - return Ffuncall(argc, argv); - } - LispArray *rest_args = (void *) call_native(Flist_to_array, 1, argv[argc - 1]); - size_t real_argc = argc - 1 + rest_args->length; - LispObject *real_argv[real_argc]; - for (size_t i = 0; i < argc - 1; ++i) { - real_argv[i] = argv[i]; - } - for (size_t i = 0; i < rest_args->length; ++i) { - real_argv[argc - 1 + i] = rest_args->data[i]; - } - unref_lisp_object(rest_args); - return Ffuncall(real_argc, real_argv); -} - -LISP_DEFUN(eval) { - if (ATOM(argv[0])) { - return argv[0]; - } - // TODO implement - return Vnil; -} - -LISP_DEFUN(make_instance) { - LispClass *class; - if (CLASSP(argv[0])) { - class = (void *) argv[0]; - } else if (SYMBOLP(argv[0])) { - class = (void *) lookup_in_module((LispHashTable *) Vclasses, - (LispSymbol *) Vmodule, - (LispSymbol *) argv[0], - true); - } else { - TYPE_ERROR("class or symbol", TYPE_STR(argv[0])); - } - if (argc % 2 != 1) { - ERROR(argument_error_class, - "expected", - STRING_FROM_LITERAL("even number of keys for make-instance"), - "got", make_lisp_int(argc - 1)); - } - LispHashTable *slots = (void *) call_native(Fmake_hash_table, 2, Vnil, Vnil); - ref_lisp_object(slots); - for (size_t i = 1; i < argc - 1; i += 2) { - if (!SYMBOLP(argv[i])) { - // TODO error - continue; - } - call_native(Fputhash, 3, slots, argv[i], argv[i + 1]); - } - LispInstance *obj = make_lisp_instance(class, slots); - unref_lisp_object(slots); - return AS_OBJECT(obj); -} - -LISP_DEFUN(slot) { - LispInstance *inst = AS_INSTANCE(argv[0]); - LispSymbol *name = AS_SYMBOL(argv[1]); - int64_t index = lookup_class_slot(inst->class, name); - if (index < 0) { - ERROR(class_slot_error_class, - "class", inst->class, - "name", name->name); - } - return inst->slots->data[index]; -} - -LISP_DEFUN(setslot) { - LispInstance *inst = AS_INSTANCE(argv[0]); - LispSymbol *name = AS_SYMBOL(argv[1]); - int64_t index = lookup_class_slot(inst->class, name); - if (index < 0) { - ERROR(class_slot_error_class, - "class", inst->class, - "name", name->name); - } - LispObject *old_value = unref_lisp_object(inst->slots->data[index]); - inst->slots->data[index] = ref_lisp_object(argv[2]); - return old_value; -} - -LISP_DEFUN(array_to_list) { - LispArray *arr = AS_ARRAY(argv[0]); - LispCons *out = EMPTY_LIST; - DOARRAY(i, elem, arr, { - out = CONS(elem, out); - }) - return AS_OBJECT(out); -} - -LISP_DEFUN(list_to_array) { - if (NILP(argv[0])) { - return AS_OBJECT(make_lisp_array(0, NULL)); - } - LispCons *list = AS_CONS(argv[0]); - size_t list_len = list_length(list); - LispArray *arr = make_lisp_array(list_len, NULL); - size_t i = 0; - DOLIST(elem, (LispCons *) argv[0], { - arr->data[i++] = ref_lisp_object(elem); - }) - return AS_OBJECT(arr); -} - -// (defun superclassp parent class) -LISP_DEFUN(superclassp) { - LispClass *parent = AS_CLASS(argv[0]); - LispClass *child = AS_CLASS(argv[1]); - while (!NILP(child)) { - if (!NILP(call_native(Feq, 2, parent, child))) { - return Vt; - } - child = child->superclass; - } - return Vnil; -} - -// (defun superclassp child class) -LISP_DEFUN(subclassp) { - return call_native(Fsuperclassp, 2, argv[1], argv[0]); -} - -LISP_DEFUN(hash_as_zero) { - return AS_OBJECT(make_lisp_int(0)); -} - -LISP_DEFUN(quote) { - return argv[0]; -} - -LISP_DEFUN(and) { - for (size_t i = 0; i < argc; ++i) { - LispObject *retval = ref_lisp_object(Feval(1, &argv[i])); - bool is_nil = NILP(retval); - unref_lisp_object(retval); - if (is_nil) { - return Vnil; - } - } - return Vt; -} - -LISP_DEFUN(or) { - for (size_t i = 0; i < argc; ++i) { - LispObject *retval = Feval(1, &argv[i]); - if (!NILP(retval)) { - return retval; - } - } - return Vnil; -} diff --git a/src/lisp.h b/src/lisp.h deleted file mode 100644 index 150ad1f..0000000 --- a/src/lisp.h +++ /dev/null @@ -1,333 +0,0 @@ -#include -#include -#include -#include - -typedef enum { - LISP_TYPE_NIL = 0, // only one value, nil (unit type) - LISP_TYPE_SYMBOL, - LISP_TYPE_CONS, - LISP_TYPE_STRING, - LISP_TYPE_ARRAY, - LISP_TYPE_INT, - LISP_TYPE_FLOAT, - LISP_TYPE_FUNCTION, - LISP_TYPE_CLASS, - LISP_TYPE_HASH_TABLE, - LISP_TYPE_INSTANCE, - LISP_TYPE_POINTER, - LISP_N_NATIVE_TYPES, -} LispType; - -typedef struct { - LispType type; - bool persist; - size_t ref_count; -} LispObject; - -typedef struct { - LispObject parent; - bool skip_free; - char *text; - size_t length; -} LispString; - -typedef struct { - LispObject parent; - LispString *name; -} LispSymbol; - -typedef struct { - LispObject parent; - LispObject *car; - LispObject *cdr; -} LispCons; -#define CONS(car, cdr) ((void *) call_native(Fcons, 2, (car), (cdr))) -#define EMPTY_LIST ((LispCons *) Vnil) - -#define DOLIST(cvar, list, body) \ - for (LispCons *__dolist_c = list; CONSP(__dolist_c); __dolist_c = (void *) \ - __dolist_c->cdr) { \ - LispObject * cvar = __dolist_c->car; \ - body \ - } - -typedef struct { - LispObject parent; - LispObject **data; - size_t length; -} LispArray; - -#define DOARRAY(index, value, arr, body) \ - for (size_t index = 0; index < (arr)->length; ++ index) { \ - LispObject * value = (arr)->data[ index ]; \ - body \ - } - -typedef struct { - LispObject parent; - int64_t value; -} LispInt; - -typedef struct { - LispObject parent; - double value; -} LispFloat; - - - -typedef struct { - LispObject parent; - LispString *doc; - bool nativep; - bool macrop; - union { - struct { - LispObject *(*action)(size_t argc, LispObject **argv); - size_t nparg; - size_t noarg; - bool rargp; - } native; - struct { - LispObject *form; - LispArray *pargs; // list of position arguments - LispArray *oargs; // list of optional positional arguments - LispSymbol *rarg; // name of the rest argument - } lisp; - }; -} LispFunction; - -#define LISP_HASH_TABLE_INITIAL_SIZE 32 - -struct LispHashTableBucket { - uint64_t hash; - LispObject *key; - LispObject *value; - struct LispHashTableBucket *next; - struct LispHashTableBucket *prev; -}; - -typedef struct { - LispObject parent; - size_t size; - size_t count; - struct LispHashTableBucket **data; - LispObject *hash_func; - LispObject *eq_func; -} LispHashTable; - -#define DOHASH(kvar, vvar, table, body) \ - for (size_t __dohash_i = 0; __dohash_i < (table)->size; ++__dohash_i) { \ - struct LispHashTableBucket *__dohash_bucket = (table)->data[__dohash_i]; \ - while (__dohash_bucket) { \ - LispObject * kvar = __dohash_bucket->key; \ - LispObject * vvar = __dohash_bucket->value; \ - body \ - __dohash_bucket = __dohash_bucket->next; \ - } \ - } - -typedef struct _LispClass { - LispObject parent; - struct _LispClass *superclass; - LispSymbol *name; - LispSymbol *module; - LispFunction *constructor; - LispHashTable *slots; // (name . index) - size_t high_slot; - LispHashTable *methods; // (name . function) -} LispClass; - -typedef struct { - LispObject parent; - LispClass *class; - LispArray *slots; -} LispInstance; - -typedef struct { - LispObject parent; - void *data; - void (*free_func)(void *); -} LispPointer; - -extern LispObject *native_type_symbols[LISP_N_NATIVE_TYPES]; -extern LispSymbol *system_module; -extern LispInstance *current_error; - -// Error classes -extern LispClass *error_class; -extern LispClass *type_error_class; -extern LispClass *argument_error_class; -extern LispClass *function_not_found_error_class; -extern LispClass *class_slot_error_class; - -typedef struct { - LispString *file; - bool is_native; - size_t line; - size_t col; -} StackFramePlace; - -typedef struct _StackFrame { - struct _StackFrame *up; - LispSymbol *block_name; - // (error class . int (to return from setjmp)) or nil - bool has_place; - StackFramePlace place; - LispHashTable *handlers; - jmp_buf *jmp; - LispHashTable *locals; - LispCons *extras; // extra objects to be unrefed - LispCons *cleanup; // list of cleanup forms -} StackFrame; - -extern StackFrame *call_stack; -extern size_t call_stack_size; - -#define AS_OBJECT(obj) ((LispObject *) (obj)) -#define LISP_BOOL(obj) ((obj) ? Vt : Vnil) -#define TYPE_OF(obj) (AS_OBJECT(obj)->type) -#define COUNT_REFS(obj) (AS_OBJECT(obj)->ref_count) - -#define LISP_DEFVAR(name) LispObject * V ## name - -extern void *Vnil; -extern LISP_DEFVAR(t); // symbol -extern LISP_DEFVAR(module); -extern LISP_DEFVAR(all_functions); // hash table (symbol . (symbol . function)) -extern LISP_DEFVAR(globals); // hash table (symbol . (symbol . any)) -extern LISP_DEFVAR(classes); // hash table (symbol . (symbol. class)) - -void *ref_lisp_object(void *obj); -void *unref_lisp_object(void *obj); -void *lisp_check_type(LispType type, void *obj); -LispObject *call_native(LispObject *(*func)(size_t argc, LispObject **argv), - size_t argc, ...); -LispString *make_lisp_string(const char *text, size_t length, - bool skip_free); -LispInt *make_lisp_int(int64_t value); -LispFloat *make_lisp_float(double value); -LispSymbol *make_lisp_symbol(const char *text, size_t length, bool skip_free); -LispFunction *make_native_function(bool macrop, size_t nparg, size_t noarg, bool rargp, - LispObject *(*action)(size_t argc, LispObject **argv)); -LispObject *lookup_in_module(LispHashTable *table, LispSymbol *module, - LispSymbol *name, bool include_system); -void register_in_module(LispHashTable *table, LispSymbol *module, - LispSymbol *name, LispObject *thing); -LispArray *make_lisp_array(size_t size, LispObject **init_data); -LispClass *make_lisp_class(LispSymbol *name, LispSymbol *module, - LispClass *superclass, LispFunction *constructor, - LispCons *slots); -LispInstance *make_lisp_instance(LispClass *class, LispHashTable *slots); -LispPointer *make_lisp_pointer(void *data, void(*free_func)(void *)); -void push_stack(LispSymbol *block_name, StackFramePlace *place, jmp_buf *jmp, - LispHashTable *handlers); -void pop_stack(void); -void add_auto_unref(void *obj); -void dump_stack(LispInstance *error); -void throw_error(LispInstance *error); -LispClass *new_class(LispClass *superclass, LispSymbol *module, - const char *name, bool skip_free, LispFunction *constructor, - ...); -LispInstance *new_instance(LispClass *class, ...); -#define ERROR(...) throw_error(new_instance(__VA_ARGS__, NULL)) -#define TYPE_ERROR(exp, got) (ERROR(type_error_class, "expected", \ - STRING_FROM_LITERAL(exp), "got", (got))) -bool instanceof(LispInstance *instance, LispClass *class); -size_t list_length(LispCons *list); - -#define INTERN_LITERAL(name) \ - (AS_OBJECT(make_lisp_symbol(name, sizeof(name) - 1, true))) -#define STRING_FROM_LITERAL(text) (make_lisp_string(text, sizeof(text) - 1, true)) -void init_lisp(void); -void deinit_lisp(void); - -#define LISP_DEFUN(name) LispObject * F ## name (size_t argc, LispObject **argv) - -#define NILP(obj) (TYPE_OF(obj) == LISP_TYPE_NIL) - -#define SYMBOLP(obj) (TYPE_OF(obj) == LISP_TYPE_SYMBOL) -#define AS_SYMBOL(obj) ((LispSymbol *) lisp_check_type(LISP_TYPE_SYMBOL, obj)) -LISP_DEFUN(symbolp); - -#define STRINGP(obj) (TYPE_OF(obj) == LISP_TYPE_STRING) -#define AS_STRING(obj) ((LispString *) lisp_check_type(LISP_TYPE_STRING, obj)) -LISP_DEFUN(stringp); - -#define CONSP(obj) (TYPE_OF(obj) == LISP_TYPE_CONS) -#define AS_CONS(obj) ((LispCons *) lisp_check_type(LISP_TYPE_CONS, obj)) -LISP_DEFUN(consp); - -#define ARRAYP(obj) (TYPE_OF(obj) == LISP_TYPE_ARRAY) -#define AS_ARRAY(obj) ((LispArray *) lisp_check_type(LISP_TYPE_ARRAY, obj)) -LISP_DEFUN(arrayp); - -#define INTP(obj) (TYPE_OF(obj) == LISP_TYPE_INT) -#define AS_INT(obj) ((LispInt *) lisp_check_type(LISP_TYPE_INT, obj)) -LISP_DEFUN(intp); - -#define FLOATP(obj) (TYPE_OF(obj) == LISP_TYPE_FLOAT) -#define AS_FLOAT(obj) ((LispFloat *) lisp_check_type(LISP_TYPE_FLOAT, obj)) -LISP_DEFUN(floatp); - -#define FUNCTIONP(obj) (TYPE_OF(obj) == LISP_TYPE_FUNCTION) -#define AS_FUNCTION(obj) ((LispFunction *) lisp_check_type(LISP_TYPE_FUNCTION, obj)) -LISP_DEFUN(functionp); - -#define HASH_TABLE_P(obj) (TYPE_OF(obj) == LISP_TYPE_HASH_TABLE) -#define AS_HASH_TABLE(obj) ((LispHashTable *) lisp_check_type(LISP_TYPE_HASH_TABLE, obj)) -LISP_DEFUN(hash_table_p); - -#define CLASSP(obj) (TYPE_OF(obj) == LISP_TYPE_CLASS) -#define AS_CLASS(obj) ((LispClass *) lisp_check_type(LISP_TYPE_CLASS, obj)) -LISP_DEFUN(classp); - -#define INSTANCEP(obj) (TYPE_OF(obj) == LISP_TYPE_INSTANCE) -#define AS_INSTANCE(obj) ((LispInstance *) lisp_check_type(LISP_TYPE_INSTANCE, obj)) -LISP_DEFUN(instancep); - -#define POINTERP(obj) (TYPE_OF(obj) == LISP_TYPE_POINTER) -#define AS_POINTER(obj) ((LispPointer *) lisp_check_type(LISP_TYPE_POINTER, obj)) -LISP_DEFUN(pointerp); - -// NOTE: this evaluates obj twice!! -#define LISTP(obj) (NILP(obj) || CONSP(obj)) -LISP_DEFUN(listp); - -#define ATOM(obj) (!CONSP(obj)) -LISP_DEFUN(atom); - -#define NATIVE(obj) (!INSTANCEP(obj)) -LISP_DEFUN(native); - -LISP_DEFUN(type_of); -#define TYPE_STR(obj) (((LispSymbol *) call_native(Ftype_of, 1, (obj)))->name) -LISP_DEFUN(cons); -LISP_DEFUN(list); -LISP_DEFUN(length); -LISP_DEFUN(intern); -LISP_DEFUN(not); -LISP_DEFUN(hash); -LISP_DEFUN(make_hash_table); -LISP_DEFUN(float); -LISP_DEFUN(eq); -LISP_DEFUN(gethash); -LISP_DEFUN(puthash); -LISP_DEFUN(remhash); -LISP_DEFUN(symbol_function); -LISP_DEFUN(funcall); -LISP_DEFUN(apply); -LISP_DEFUN(eval); -LISP_DEFUN(make_instance); -LISP_DEFUN(slot); -LISP_DEFUN(setslot); -LISP_DEFUN(array_to_list); -LISP_DEFUN(list_to_array); -LISP_DEFUN(superclassp); -LISP_DEFUN(subclassp); -LISP_DEFUN(hash_as_zero); - -// These are special forms, they their argument are NOT evaluated -LISP_DEFUN(quote); -LISP_DEFUN(and); -LISP_DEFUN(or); diff --git a/src/main.c b/src/main.c deleted file mode 100644 index aaacbbe..0000000 --- a/src/main.c +++ /dev/null @@ -1,58 +0,0 @@ -#include -#include "parse.h" - -static const char *token_type_to_str(TokenType type) { - switch (type) { - case TOKEN_TYPE_EOF: - return "EOF"; - case TOKEN_TYPE_COMMENT: - return "COMMENT"; - case TOKEN_TYPE_PAREN: - return "PAREN"; - case TOKEN_TYPE_BRACKET: - return "BRACKET"; - case TOKEN_TYPE_SYMBOL: - return "SYMBOL"; - case TOKEN_TYPE_QUOTE: - return "QUOTE"; - case TOKEN_TYPE_NUMBER: - return "NUMBER"; - case TOKEN_TYPE_CHAR: - return "CHAR"; - case TOKEN_TYPE_STRING: - return "STRING"; - default: - return "UNKNOWN"; - } -} - -int main(int argc, const char **argv) { - init_lisp(); - LispObject *msg_slot = ref_lisp_object(INTERN_LITERAL("message")); - jmp_buf jmp; - int branch = setjmp(jmp); - if (!branch) { - LispHashTable *handlers = (void *) call_native(Fmake_hash_table, 2, Vnil, Vnil); - call_native(Fputhash, 3, handlers, type_error_class, make_lisp_int(1)); - call_native(Fputhash, 3, handlers, class_slot_error_class, make_lisp_int(2)); - StackFramePlace err_place = { - .file = STRING_FROM_LITERAL(__FILE__), - .is_native = true, - .line = __LINE__ - 3, - .col = 8, - }; - push_stack((void *) INTERN_LITERAL(__FUNCTION__), &err_place, &jmp, handlers); - unref_lisp_object(handlers); - AS_STRING(Vnil); - } else if (branch == 1) { - LispString *msg = (void *) call_native(Fslot, 2, current_error, msg_slot); - printf("Caught %s: %*s\n", - current_error->class->name->name->text, - (int) msg->length, msg->text); - dump_stack(current_error); - } - unref_lisp_object(msg_slot); - pop_stack(); - deinit_lisp(); - return 0; -}