mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 01:57:09 +03:00
319 lines
10 KiB
C
319 lines
10 KiB
C
#include <stdlib.h>
|
|
#include <stdio.h>
|
|
#include <unistd.h>
|
|
#include <sys/stat.h>
|
|
#include <fcntl.h>
|
|
#include "types.h"
|
|
#include "readline.h"
|
|
#include "reader.h"
|
|
#include "interop.h"
|
|
|
|
// Declarations
|
|
MalVal *EVAL(MalVal *ast, Env *env);
|
|
|
|
// read
|
|
MalVal *READ(char prompt[], char *str) {
|
|
char *line;
|
|
MalVal *ast;
|
|
if (str) {
|
|
line = str;
|
|
} else {
|
|
line = _readline(prompt);
|
|
if (!line) {
|
|
_error("EOF");
|
|
return NULL;
|
|
}
|
|
}
|
|
ast = read_str(line);
|
|
if (!str) { free(line); }
|
|
return ast;
|
|
}
|
|
|
|
// eval
|
|
int is_pair(MalVal *x) {
|
|
return _sequential_Q(x) && (_count(x) > 0);
|
|
}
|
|
|
|
MalVal *quasiquote(MalVal *ast) {
|
|
if (!is_pair(ast)) {
|
|
return _list(2, malval_new_symbol("quote"), ast);
|
|
} else {
|
|
MalVal *a0 = _nth(ast, 0);
|
|
if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("unquote", a0->val.string) == 0) {
|
|
return _nth(ast, 1);
|
|
} else if (is_pair(a0)) {
|
|
MalVal *a00 = _nth(a0, 0);
|
|
if ((a00->type & MAL_SYMBOL) &&
|
|
strcmp("splice-unquote", a00->val.string) == 0) {
|
|
return _list(3, malval_new_symbol("concat"),
|
|
_nth(a0, 1),
|
|
quasiquote(rest(ast)));
|
|
}
|
|
}
|
|
return _list(3, malval_new_symbol("cons"),
|
|
quasiquote(a0),
|
|
quasiquote(rest(ast)));
|
|
}
|
|
}
|
|
|
|
MalVal *eval_ast(MalVal *ast, Env *env) {
|
|
if (!ast || mal_error) return NULL;
|
|
if (ast->type == MAL_SYMBOL) {
|
|
//g_print("EVAL symbol: %s\n", ast->val.string);
|
|
return env_get(env, ast->val.string);
|
|
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
|
|
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
|
|
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
|
|
if (!el || mal_error) return NULL;
|
|
el->type = ast->type;
|
|
return el;
|
|
} else if (ast->type == MAL_HASH_MAP) {
|
|
//g_print("EVAL hash_map: %s\n", _pr_str(ast,1));
|
|
GHashTableIter iter;
|
|
gpointer key, value;
|
|
MalVal *seq = malval_new_list(MAL_LIST,
|
|
g_array_sized_new(TRUE, TRUE, sizeof(MalVal*),
|
|
_count(ast)));
|
|
g_hash_table_iter_init (&iter, ast->val.hash_table);
|
|
while (g_hash_table_iter_next (&iter, &key, &value)) {
|
|
MalVal *kname = malval_new_string((char *)key);
|
|
g_array_append_val(seq->val.array, kname);
|
|
MalVal *new_val = EVAL((MalVal *)value, env);
|
|
g_array_append_val(seq->val.array, new_val);
|
|
}
|
|
return hash_map(seq);
|
|
} else {
|
|
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
|
|
return ast;
|
|
}
|
|
}
|
|
|
|
MalVal *EVAL(MalVal *ast, Env *env) {
|
|
while (TRUE) {
|
|
//g_print("EVAL: %s\n", _pr_str(ast,1));
|
|
if (!ast || mal_error) return NULL;
|
|
if (ast->type != MAL_LIST) {
|
|
return eval_ast(ast, env);
|
|
}
|
|
if (!ast || mal_error) return NULL;
|
|
|
|
// apply list
|
|
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
|
|
int i, len;
|
|
if (_count(ast) == 0) { return ast; }
|
|
MalVal *a0 = _nth(ast, 0);
|
|
if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("def!", a0->val.string) == 0) {
|
|
//g_print("eval apply def!\n");
|
|
MalVal *a1 = _nth(ast, 1),
|
|
*a2 = _nth(ast, 2);
|
|
MalVal *res = EVAL(a2, env);
|
|
env_set(env, a1->val.string, res);
|
|
return res;
|
|
} else if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("let*", a0->val.string) == 0) {
|
|
//g_print("eval apply let*\n");
|
|
MalVal *a1 = _nth(ast, 1),
|
|
*a2 = _nth(ast, 2),
|
|
*key, *val;
|
|
assert_type(a1, MAL_LIST|MAL_VECTOR,
|
|
"let* bindings must be list or vector");
|
|
len = _count(a1);
|
|
assert((len % 2) == 0, "odd number of let* bindings forms");
|
|
Env *let_env = new_env(env, NULL, NULL);
|
|
for(i=0; i<len; i+=2) {
|
|
key = g_array_index(a1->val.array, MalVal*, i);
|
|
val = g_array_index(a1->val.array, MalVal*, i+1);
|
|
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
|
|
env_set(let_env, key->val.string, EVAL(val, let_env));
|
|
}
|
|
return EVAL(a2, let_env);
|
|
} else if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("quote", a0->val.string) == 0) {
|
|
//g_print("eval apply quote\n");
|
|
return _nth(ast, 1);
|
|
} else if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("quasiquote", a0->val.string) == 0) {
|
|
//g_print("eval apply quasiquote\n");
|
|
MalVal *a1 = _nth(ast, 1);
|
|
return EVAL(quasiquote(a1), env);
|
|
} else if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("do", a0->val.string) == 0) {
|
|
//g_print("eval apply do\n");
|
|
eval_ast(_slice(ast, 1, _count(ast)-1), env);
|
|
ast = last(ast);
|
|
// Continue loop
|
|
} else if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("if", a0->val.string) == 0) {
|
|
//g_print("eval apply if\n");
|
|
MalVal *a1 = _nth(ast, 1);
|
|
MalVal *cond = EVAL(a1, env);
|
|
if (!cond || mal_error) return NULL;
|
|
if (cond->type & (MAL_FALSE|MAL_NIL)) {
|
|
// eval false slot form
|
|
ast = _nth(ast, 3);
|
|
if (!ast) {
|
|
return &mal_nil;
|
|
}
|
|
} else {
|
|
// eval true slot form
|
|
ast = _nth(ast, 2);
|
|
}
|
|
// Continue loop
|
|
} else if ((a0->type & MAL_SYMBOL) &&
|
|
strcmp("fn*", a0->val.string) == 0) {
|
|
//g_print("eval apply fn*\n");
|
|
MalVal *mf = malval_new(MAL_FUNCTION_MAL, NULL);
|
|
mf->val.func.evaluator = EVAL;
|
|
mf->val.func.args = _nth(ast, 1);
|
|
mf->val.func.body = _nth(ast, 2);
|
|
mf->val.func.env = env;
|
|
return mf;
|
|
} else {
|
|
//g_print("eval apply\n");
|
|
MalVal *el = eval_ast(ast, env);
|
|
if (!el || mal_error) { return NULL; }
|
|
MalVal *f = first(el),
|
|
*args = rest(el);
|
|
assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
|
|
"cannot invoke '%s'", _pr_str(f,1));
|
|
if (f->type & MAL_FUNCTION_MAL) {
|
|
ast = f->val.func.body;
|
|
env = new_env(f->val.func.env, f->val.func.args, args);
|
|
// Continue loop
|
|
} else {
|
|
return apply(f, args);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
// print
|
|
char *PRINT(MalVal *exp) {
|
|
if (mal_error) {
|
|
fprintf(stderr, "Error: %s\n", mal_error->val.string);
|
|
malval_free(mal_error);
|
|
mal_error = NULL;
|
|
return NULL;
|
|
}
|
|
return _pr_str(exp,1);
|
|
}
|
|
|
|
// repl
|
|
|
|
// read and eval
|
|
MalVal *RE(Env *env, char *prompt, char *str) {
|
|
MalVal *ast, *exp;
|
|
ast = READ(prompt, str);
|
|
if (!ast || mal_error) return NULL;
|
|
exp = EVAL(ast, env);
|
|
if (ast != exp) {
|
|
malval_free(ast); // Free input structure
|
|
}
|
|
return exp;
|
|
}
|
|
|
|
// Setup the initial REPL environment
|
|
Env *repl_env;
|
|
|
|
char *slurp_raw(char *path) {
|
|
char *data;
|
|
struct stat fst;
|
|
int fd = open(path, O_RDONLY),
|
|
sz;
|
|
if (fd < 0) {
|
|
abort("slurp failed to open '%s'", path);
|
|
}
|
|
if (fstat(fd, &fst) < 0) {
|
|
abort("slurp failed to stat '%s'", path);
|
|
}
|
|
data = malloc(fst.st_size+1);
|
|
sz = read(fd, data, fst.st_size);
|
|
if (sz < fst.st_size) {
|
|
abort("slurp failed to read '%s'", path);
|
|
}
|
|
data[sz] = '\0';
|
|
return data;
|
|
}
|
|
|
|
void init_repl_env() {
|
|
void _ref(char *name, MalVal*(*func)(MalVal*), int arg_cnt) {
|
|
void *(*f)(void *) = (void*(*)(void*))func;
|
|
env_set(repl_env, name, malval_new_function(f, arg_cnt, NULL));
|
|
}
|
|
repl_env = new_env(NULL, NULL, NULL);
|
|
|
|
int i;
|
|
for(i=0; i< (sizeof(types_ns) / sizeof(types_ns[0])); i++) {
|
|
MalVal *(*f)(MalVal *) = (MalVal*(*)(MalVal*))types_ns[i].func;
|
|
_ref(types_ns[i].name, f, types_ns[i].arg_cnt);
|
|
}
|
|
|
|
MalVal *read_string(MalVal *str) {
|
|
assert_type(str, MAL_STRING, "read_string of non-string");
|
|
return read_str(str->val.string);
|
|
}
|
|
_ref("read-string", read_string, 1);
|
|
|
|
MalVal *do_eval(MalVal *ast) {
|
|
return EVAL(ast, repl_env);
|
|
}
|
|
_ref("eval", do_eval, 1);
|
|
|
|
MalVal *slurp(MalVal *path) {
|
|
assert_type(path, MAL_STRING, "slurp of non-string");
|
|
char *data = slurp_raw(path->val.string);
|
|
if (!data || mal_error) { return NULL; }
|
|
return malval_new_string(data);
|
|
}
|
|
_ref("slurp", slurp, 1);
|
|
|
|
MalVal *slurp_do(MalVal *path) {
|
|
assert_type(path, MAL_STRING, "slurp of non-string");
|
|
char *data = slurp_raw(path->val.string),
|
|
*wrapped_data;
|
|
if (!data || mal_error) { return NULL; }
|
|
wrapped_data = g_strdup_printf("(do %s)", data);
|
|
free(data);
|
|
return malval_new_string(wrapped_data);
|
|
}
|
|
_ref("slurp-do", slurp_do, 1);
|
|
|
|
RE(repl_env, "", "(def! not (fn* (a) (if a false true)))");
|
|
RE(repl_env, "",
|
|
"(def! load-file (fn* (f) (eval (read-string (slurp-do f)))))");
|
|
}
|
|
|
|
int main(int argc, char *argv[])
|
|
{
|
|
MalVal *exp;
|
|
char *output;
|
|
char prompt[100];
|
|
|
|
// Set the initial prompt and environment
|
|
snprintf(prompt, sizeof(prompt), "user> ");
|
|
init_repl_env();
|
|
|
|
if (argc > 1) {
|
|
char *cmd = g_strdup_printf("(load-file \"%s\")", argv[1]);
|
|
RE(repl_env, "", cmd);
|
|
} else {
|
|
// REPL loop
|
|
for(;;) {
|
|
exp = RE(repl_env, prompt, NULL);
|
|
if (mal_error && strcmp("EOF", mal_error->val.string) == 0) {
|
|
return 0;
|
|
}
|
|
output = PRINT(exp);
|
|
|
|
if (output) {
|
|
g_print("%s\n", output);
|
|
free(output); // Free output string
|
|
}
|
|
|
|
//malval_free(exp); // Free evaluated expression
|
|
}
|
|
}
|
|
}
|