383 lines
10 KiB
C
383 lines
10 KiB
C
|
#include "main.h"
|
||
|
|
||
|
lisp_cons* syms_alist;
|
||
|
lisp_cons* funs_alist;
|
||
|
lisp_cons* atoms_alist;
|
||
|
|
||
|
bool lisp_is_nil(lisp_value value) {
|
||
|
return (value.type == LISP_T_CONS) && (value.value.cons == NULL);
|
||
|
}
|
||
|
bool lisp_is_equal(lisp_value a, lisp_value b) {
|
||
|
if (a.type != b.type)
|
||
|
return false;
|
||
|
switch (a.type) {
|
||
|
case LISP_T_CONS:
|
||
|
return a.value.cons == b.value.cons;
|
||
|
case LISP_T_ATOM:
|
||
|
return a.value.atom == b.value.atom;
|
||
|
case LISP_T_INT:
|
||
|
return a.value._int == b.value._int;
|
||
|
case LISP_T_FLOAT:
|
||
|
return a.value._float == b.value._float;
|
||
|
case LISP_T_STRING:
|
||
|
return lisp_string_cmp(a.value.string, b.value.string) == 0;
|
||
|
default:
|
||
|
return false;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
void lisp_cons_join(lisp_cons* head, lisp_cons* tail) {
|
||
|
while ((head->cdr.type == LISP_T_CONS) && !lisp_is_nil(head->cdr)) {
|
||
|
head = head->cdr.value.cons;
|
||
|
}
|
||
|
head->cdr.type = LISP_T_CONS;
|
||
|
head->cdr.value.cons = tail;
|
||
|
}
|
||
|
|
||
|
lisp_atom atom_t;
|
||
|
lisp_atom atom_quote;
|
||
|
|
||
|
#include "crc_table.h"
|
||
|
lisp_atom lisp_atomize(lisp_string* atom_lstr) {
|
||
|
char* buf = lisp_string_data(atom_lstr);
|
||
|
int len = lisp_string_len(atom_lstr);
|
||
|
lisp_atom atom = 0xFFFFFFFF;
|
||
|
while (len--) {
|
||
|
atom = (atom << 8) ^ crc32_table[((atom >> 24) ^ *buf) & 255];
|
||
|
buf++;
|
||
|
}
|
||
|
#ifdef LISP_USE_ATOMS_ALIST
|
||
|
lisp_value key;
|
||
|
key.type = LISP_T_ATOM;
|
||
|
key.value.atom = atom;
|
||
|
if (lisp_alist_getptr(atoms_alist, key) == NULL) {
|
||
|
lisp_cons* pair = dbg_malloc(sizeof(lisp_cons));
|
||
|
pair->car.type = LISP_T_ATOM;
|
||
|
pair->car.value.atom = atom;
|
||
|
pair->cdr.type = LISP_T_STRING;
|
||
|
pair->cdr.value.string = lisp_string_copy(atom_lstr);
|
||
|
lisp_cons* new_alist = dbg_malloc(sizeof(lisp_cons));
|
||
|
new_alist->car.type = LISP_T_CONS;
|
||
|
new_alist->car.value.cons = pair;
|
||
|
new_alist->cdr.type = LISP_T_CONS;
|
||
|
new_alist->cdr.value.cons = atoms_alist;
|
||
|
atoms_alist = new_alist;
|
||
|
}
|
||
|
#endif
|
||
|
return atom;
|
||
|
}
|
||
|
lisp_atom lisp_atom_init(lisp_string* atom_lstr) {
|
||
|
lisp_atom atom = lisp_atomize(atom_lstr);
|
||
|
dbg_free(atom_lstr);
|
||
|
return atom;
|
||
|
}
|
||
|
|
||
|
lisp_cons** lisp_alist_getptr(lisp_cons* alist, lisp_value key) {
|
||
|
while (alist != NULL) {
|
||
|
if (alist->car.type != LISP_T_CONS || alist->car.value.cons == NULL)
|
||
|
goto next;
|
||
|
lisp_cons* pair = alist->car.value.cons;
|
||
|
if (lisp_is_equal(pair->car, key))
|
||
|
return &alist->car.value.cons;
|
||
|
next:
|
||
|
if (alist->cdr.type == LISP_T_CONS)
|
||
|
alist = alist->cdr.value.cons;
|
||
|
else
|
||
|
alist = NULL;
|
||
|
}
|
||
|
return NULL;
|
||
|
}
|
||
|
lisp_cons* lisp_alist_get(lisp_cons* alist, lisp_value key) {
|
||
|
lisp_cons** pairptr = lisp_alist_getptr(alist, key);
|
||
|
if (pairptr == NULL)
|
||
|
return NULL;
|
||
|
return *pairptr;
|
||
|
}
|
||
|
lisp_cons* lisp_alist_put(lisp_cons** alist, lisp_cons* pair) {
|
||
|
lisp_cons** pairptr = lisp_alist_getptr(*alist, pair->car);
|
||
|
if (pairptr != NULL) {
|
||
|
lisp_cons* old_pair = *pairptr;
|
||
|
*pairptr = pair;
|
||
|
return old_pair;
|
||
|
}
|
||
|
lisp_cons* new_alist = dbg_malloc(sizeof(lisp_cons));
|
||
|
new_alist->car.type = LISP_T_CONS;
|
||
|
new_alist->car.value.cons = pair;
|
||
|
new_alist->cdr.type = LISP_T_CONS;
|
||
|
new_alist->cdr.value.cons = *alist;
|
||
|
*alist = new_alist;
|
||
|
return NULL;
|
||
|
}
|
||
|
lisp_cons* lisp_alist_del(lisp_cons** alist, lisp_value key) {
|
||
|
lisp_cons* alist_cur = *alist;
|
||
|
lisp_cons* alist_prev = NULL;
|
||
|
while (alist_cur != NULL) {
|
||
|
if (alist_cur->car.type != LISP_T_CONS || alist_cur->car.value.cons == NULL)
|
||
|
goto next;
|
||
|
lisp_cons* pair = alist_cur->car.value.cons;
|
||
|
if (lisp_is_equal(pair->car, key)) {
|
||
|
// remove current element from list
|
||
|
if (alist_prev != NULL)
|
||
|
alist_prev->cdr = alist_cur->cdr;
|
||
|
else if (alist_cur->cdr.type == LISP_T_CONS)
|
||
|
*alist = alist_cur->cdr.value.cons;
|
||
|
return pair;
|
||
|
}
|
||
|
next:
|
||
|
alist_prev = alist_cur;
|
||
|
if (alist_cur->cdr.type == LISP_T_CONS)
|
||
|
alist_cur = alist_cur->cdr.value.cons;
|
||
|
else
|
||
|
alist_cur = NULL;
|
||
|
}
|
||
|
return NULL;
|
||
|
}
|
||
|
|
||
|
void test_print_value(lisp_value value) {
|
||
|
if (lisp_is_nil(value))
|
||
|
printf("nil");
|
||
|
else if (value.type == LISP_T_CONS)
|
||
|
test_print_cons(value.value.cons);
|
||
|
else if (value.type == LISP_T_ATOM) {
|
||
|
#ifdef LISP_USE_ATOMS_ALIST
|
||
|
lisp_cons* pair = lisp_alist_get(atoms_alist, value);
|
||
|
if (pair != NULL)
|
||
|
lisp_string_print(pair->cdr.value.string);
|
||
|
else
|
||
|
#endif
|
||
|
printf("<atom %08x>", value.value.atom);
|
||
|
} else if (value.type == LISP_T_INT)
|
||
|
printf("%li", value.value._int);
|
||
|
else if (value.type == LISP_T_FLOAT)
|
||
|
printf("%g", value.value._float);
|
||
|
else if (value.type == LISP_T_STRING) {
|
||
|
putchar('\"');
|
||
|
lisp_string_print(value.value.string);
|
||
|
putchar('\"');
|
||
|
} else if (value.type == LISP_T_FUNPTR)
|
||
|
printf("<native-fun %p>", value.value.funptr);
|
||
|
}
|
||
|
void test_print_cons(lisp_cons* cons) {
|
||
|
printf("(");
|
||
|
while (cons != NULL) {
|
||
|
test_print_value(cons->car);
|
||
|
if (cons->cdr.type == LISP_T_CONS) {
|
||
|
cons = cons->cdr.value.cons;
|
||
|
if (cons != NULL)
|
||
|
printf(" ");
|
||
|
} else {
|
||
|
printf(" . ");
|
||
|
test_print_value(cons->cdr);
|
||
|
cons = NULL;
|
||
|
}
|
||
|
}
|
||
|
printf(")");
|
||
|
}
|
||
|
|
||
|
void recursive_free(lisp_cons* cons) {
|
||
|
while (cons != NULL) {
|
||
|
if (cons->car.type == LISP_T_STRING)
|
||
|
dbg_free(cons->car.value.string);
|
||
|
else if (cons->car.type == LISP_T_CONS)
|
||
|
recursive_free(cons->car.value.cons);
|
||
|
if (cons->cdr.type == LISP_T_STRING)
|
||
|
dbg_free(cons->cdr.value.string);
|
||
|
lisp_cons* next_cons = NULL;
|
||
|
if (cons->cdr.type == LISP_T_CONS)
|
||
|
next_cons = cons->cdr.value.cons;
|
||
|
dbg_free(cons);
|
||
|
cons = next_cons;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
bool fetch_tokens(lisp_cons** tokens) {
|
||
|
char buf[64];
|
||
|
//test_print_cons(*tokens);
|
||
|
//printf("> ");
|
||
|
if (!fgets(buf, 64, stdin))
|
||
|
return false;
|
||
|
lisp_tokenize(buf, strlen(buf), tokens);
|
||
|
return true;
|
||
|
}
|
||
|
|
||
|
lisp_atom lisp_defun_native(lisp_string* lstr, lisp_native_fun funptr) {
|
||
|
lisp_atom atom = lisp_atom_init(lstr);
|
||
|
lisp_cons* cons = dbg_malloc(sizeof(lisp_cons));
|
||
|
cons->car.type = LISP_T_ATOM;
|
||
|
cons->car.value.atom = atom;
|
||
|
cons->cdr.type = LISP_T_FUNPTR;
|
||
|
cons->cdr.value.funptr = funptr;
|
||
|
lisp_alist_put(&funs_alist, cons);
|
||
|
return atom;
|
||
|
}
|
||
|
|
||
|
void lisp_evaluate_value(lisp_value input, lisp_value* result) {
|
||
|
if (input.type == LISP_T_ATOM) {
|
||
|
if (input.value.atom == atom_t) {
|
||
|
*result = input;
|
||
|
return;
|
||
|
}
|
||
|
lisp_cons* sym_pair = lisp_alist_get(syms_alist, input);
|
||
|
if (sym_pair != NULL)
|
||
|
*result = sym_pair->cdr;
|
||
|
else {
|
||
|
result->type = LISP_T_CONS;
|
||
|
result->value.cons = NULL;
|
||
|
}
|
||
|
} else if (input.type == LISP_T_CONS && !lisp_is_nil(input))
|
||
|
lisp_evaluate(input.value.cons, result);
|
||
|
else
|
||
|
*result = input;
|
||
|
}
|
||
|
void lisp_evaluate(lisp_cons* cons, lisp_value* value) {
|
||
|
if (cons->car.value.atom == atom_quote) {
|
||
|
*value = cons->cdr.value.cons->car;
|
||
|
return;
|
||
|
}
|
||
|
if (cons->car.value.atom == atom_cond) {
|
||
|
lisp_macro_cond(cons->cdr.value.cons, value);
|
||
|
return;
|
||
|
}
|
||
|
lisp_cons* fun_cons = lisp_alist_get(funs_alist, cons->car);
|
||
|
if (fun_cons == NULL) {
|
||
|
fprintf(stderr, "EVAL ERROR! (no such fun)\n");
|
||
|
value->type = LISP_T_CONS;
|
||
|
value->value.cons = NULL;
|
||
|
return;
|
||
|
}
|
||
|
lisp_cons* args = NULL;
|
||
|
lisp_cons* args_tail = NULL;
|
||
|
cons = cons->cdr.value.cons;
|
||
|
while (cons != NULL) {
|
||
|
lisp_cons* arg_cons = dbg_malloc(sizeof(lisp_cons));
|
||
|
arg_cons->cdr.type = LISP_T_CONS;
|
||
|
arg_cons->cdr.value.cons = NULL;
|
||
|
lisp_evaluate_value(cons->car, &arg_cons->car);
|
||
|
cons = cons->cdr.value.cons;
|
||
|
if (args == NULL)
|
||
|
args = arg_cons;
|
||
|
if (args_tail == NULL)
|
||
|
args_tail = args;
|
||
|
else {
|
||
|
args_tail->cdr.value.cons = arg_cons;
|
||
|
args_tail = arg_cons;
|
||
|
}
|
||
|
}
|
||
|
if (fun_cons->cdr.type == LISP_T_FUNPTR) {
|
||
|
// native-fun
|
||
|
(*fun_cons->cdr.value.funptr)(args, value);
|
||
|
while (args != NULL) {
|
||
|
args_tail = args->cdr.value.cons;
|
||
|
dbg_free(args);
|
||
|
args = args_tail;
|
||
|
}
|
||
|
} else {
|
||
|
fprintf(stderr, "EVAL ERROR! (not a native-fun)\n");
|
||
|
value->type = LISP_T_CONS;
|
||
|
value->value.cons = NULL;
|
||
|
return;
|
||
|
}
|
||
|
}
|
||
|
lisp_atom atom_cond;
|
||
|
void lisp_macro_cond(lisp_cons* cons, lisp_value* value) {
|
||
|
while (cons != NULL) {
|
||
|
lisp_cons* fork = cons->car.value.cons;
|
||
|
lisp_evaluate_value(fork->car, value);
|
||
|
if (!lisp_is_nil(*value)) {
|
||
|
fork = fork->cdr.value.cons;
|
||
|
while (fork != NULL) {
|
||
|
lisp_evaluate_value(fork->car, value);
|
||
|
fork = fork->cdr.value.cons;
|
||
|
}
|
||
|
return;
|
||
|
}
|
||
|
cons = cons->cdr.value.cons;
|
||
|
}
|
||
|
value->type = LISP_T_CONS;
|
||
|
value->value.cons = NULL;
|
||
|
}
|
||
|
|
||
|
void lisp_set(lisp_cons* cons, lisp_value* value) {
|
||
|
lisp_cons* pair = dbg_malloc(sizeof(lisp_cons));
|
||
|
pair->car = cons->car;
|
||
|
pair->cdr = cons->cdr.value.cons->car;
|
||
|
lisp_alist_put(&syms_alist, pair);
|
||
|
*value = pair->cdr;
|
||
|
}
|
||
|
|
||
|
void lisp_fun(lisp_cons* cons, lisp_value* value) {
|
||
|
lisp_cons* pair = lisp_alist_get(funs_alist, cons->car);
|
||
|
*value = pair->cdr;
|
||
|
}
|
||
|
|
||
|
lisp_atom atom_cons;
|
||
|
lisp_atom atom_atom;
|
||
|
lisp_atom atom_int;
|
||
|
lisp_atom atom_float;
|
||
|
lisp_atom atom_string;
|
||
|
lisp_atom atom_native_fun;
|
||
|
|
||
|
int main() {
|
||
|
printf("sizeof(lisp_atom) = %lu\n", sizeof(lisp_atom));
|
||
|
printf("sizeof(lisp_value) = %lu\n", sizeof(lisp_value));
|
||
|
printf("sizeof(lisp_cons) = %lu\n", sizeof(lisp_cons));
|
||
|
|
||
|
atom_t = lisp_atom_init(lisp_string_create("t"));
|
||
|
atom_quote = lisp_atom_init(lisp_string_create("quote"));
|
||
|
|
||
|
atom_cond = lisp_atom_init(lisp_string_create("cond"));
|
||
|
|
||
|
atom_cons = lisp_atom_init(lisp_string_create("cons"));
|
||
|
atom_atom = lisp_atom_init(lisp_string_create("atom"));
|
||
|
atom_int = lisp_atom_init(lisp_string_create("int"));
|
||
|
atom_float = lisp_atom_init(lisp_string_create("float"));
|
||
|
atom_string = lisp_atom_init(lisp_string_create("string"));
|
||
|
atom_native_fun = lisp_atom_init(lisp_string_create("native-fun"));
|
||
|
|
||
|
init_native_funs();
|
||
|
lisp_defun_native(lisp_string_create("set"), &lisp_set);
|
||
|
lisp_defun_native(lisp_string_create("fun"), &lisp_fun);
|
||
|
|
||
|
printf("Init: %4liB used\n", dbg_malloc_mem_usage);
|
||
|
|
||
|
while (true) {
|
||
|
lisp_cons* tokens = NULL;
|
||
|
lisp_value value;
|
||
|
printf("> ");
|
||
|
lisp_tokenize_init();
|
||
|
if (lisp_parse_recursive(&tokens, &fetch_tokens, &value)) {
|
||
|
//test_print_value(value);
|
||
|
//printf("\n");
|
||
|
lisp_value result;
|
||
|
lisp_evaluate_value(value, &result);
|
||
|
test_print_value(result);
|
||
|
printf("\n");
|
||
|
printf("Freeing sexpr...\n");
|
||
|
if (value.type == LISP_T_CONS)
|
||
|
recursive_free(value.value.cons);
|
||
|
else if (value.type == LISP_T_STRING)
|
||
|
dbg_free(value.value.string);
|
||
|
printf("Freeing tokens...\n");
|
||
|
recursive_free(tokens);
|
||
|
|
||
|
if (lisp_is_nil(value))
|
||
|
break;
|
||
|
} else {
|
||
|
printf("PARSE ERROR!\n");
|
||
|
test_print_cons(tokens);
|
||
|
printf("\n");
|
||
|
}
|
||
|
}
|
||
|
|
||
|
printf("Freeing syms-alist...\n");
|
||
|
recursive_free(syms_alist);
|
||
|
printf("Freeing funs-alist...\n");
|
||
|
recursive_free(funs_alist);
|
||
|
printf("Freeing atoms-alist...\n");
|
||
|
recursive_free(atoms_alist);
|
||
|
printf("Done: %4liB used (should be 0)\n", dbg_malloc_mem_usage);
|
||
|
printf("Peak: %4liB used\n", dbg_malloc_peak_usage);
|
||
|
|
||
|
return 0;
|
||
|
}
|