Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Completely rewrite basically the whole thing

Browse Source
This commit is contained in:
Alexander Rosenberg 2024-09-23 04:39:35 -07:00
parent 2d33b594c5
commit 550a6131e1
Signed by: Zander671
GPG Key ID: 5FD0394ADBD72730
10 changed files with 1167 additions and 1716 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
CMakeLists.txt
View File

@ -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)

931
bootstrap/ast.c Normal file
View File

@ -0,0 +1,931 @@
#include "ast.h"
#include <stdarg.h>
#include <ctype.h>
#include <stdlib.h>
#include <inttypes.h>
#include <string.h>
#include <regex.h>
#include <math.h>
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;
}
}

108
bootstrap/ast.h Normal file
View File

@ -0,0 +1,108 @@
#ifndef INCLUDED_AST_H
#define INCLUDED_AST_H
#include "parse.h"
#include <stddef.h>
#include <stdint.h>
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

29
bootstrap/main.c Normal file
View File

@ -0,0 +1,29 @@
#include <stdio.h>
#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;
}

101
src/parse.c → bootstrap/parse.c
View File

@ -4,6 +4,39 @@
#include <stdlib.h>
#include <string.h>
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;
if (feof(stream->src)) {
token_stream_push_error(stream, token, strdup("expected '\"', got EOF"),
true);
append_null_byte(token);
} else {
append_char(token, '"');
append_null_byte(token);
if (feof(stream->src)) {
token_stream_push_error(stream, token,
strdup("expected '\"', got EOF"));
}
}
@ -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);
} 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);
}

15
src/parse.h → bootstrap/parse.h
View File

@ -1,13 +1,15 @@
#ifndef INCLUDED_PARSE_H
#define INCLUDED_PARSE_H
#include <stdio.h>
#include <stdbool.h>
#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

1
bootstrap/test.sl Normal file
View File

@ -0,0 +1 @@
'('a `(,a '(,a)))

1293
src/lisp.c
View File

File diff suppressed because it is too large Load Diff

333
src/lisp.h
View File

@ -1,333 +0,0 @@
#include <stddef.h>
#include <stdbool.h>
#include <stdint.h>
#include <setjmp.h>
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);

58
src/main.c
View File

@ -1,58 +0,0 @@
#include <stdio.h>
#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;
}