lv_t *lisp_let_star(lexec_t *exec, lv_t *args, lv_t *expr) {
lv_t *argp = args;
lv_t *newenv;
lv_t *result;
newenv = lisp_create_pair(lisp_create_hash(), exec->env);
rt_assert(args->type == l_null ||
args->type == l_pair, le_type,
"let arg type");
lisp_exec_push_env(exec, newenv);
if(args->type == l_pair) {
/* walk through each element of the list,
evaling k/v pairs and assigning them
to an environment to run the expr in */
while(argp && L_CAR(argp)) {
rt_assert(c_list_length(L_CAR(argp)) == 2, le_arity,
"let arg arity");
c_hash_insert(L_CAR(newenv), L_CAAR(argp),
lisp_eval(exec, L_CADAR(argp)));
argp=L_CDR(argp);
}
}
result = lisp_eval(exec, expr);
lisp_exec_pop_env(exec);
return result;
}
/**
* quasiquote a term
*/
lv_t *lisp_quasiquote(lexec_t *exec, lv_t *v) {
lv_t *res;
lv_t *vptr;
lv_t *rptr;
lv_t *v2, *v2ptr;
/* strategy: walk through the list, expanding
unquote and unquote-splicing terms */
if(v->type == l_pair) {
if (L_CAR(v)->type == l_sym &&
!strcmp(L_SYM(L_CAR(v)), "unquote")) {
rt_assert(c_list_length(L_CDR(v)) == 1, le_arity,
"unquote arity");
return lisp_eval(exec, L_CADR(v));
}
/* quasi-quote and unquote-splice stuff */
res = lisp_create_pair(NULL, NULL);
rptr = res;
vptr = v;
while(vptr && L_CAR(vptr)) {
if(L_CAR(vptr)->type == l_pair &&
L_CAAR(vptr)->type == l_sym &&
!strcmp(L_SYM(L_CAAR(vptr)), "unquote-splicing")) {
/* splice this into result */
rt_assert(c_list_length(L_CDAR(vptr)) == 1, le_arity,
"unquote-splicing arity");
v2 = lisp_eval(exec, L_CAR(L_CDAR(vptr)));
rt_assert(v2->type == l_pair || v2->type == l_null, le_type,
"unquote-splicing expects list");
if(v2->type != l_null) {
v2ptr = v2;
while(v2ptr && L_CAR(v2ptr)) {
L_CAR(rptr) = L_CAR(v2ptr);
v2ptr = L_CDR(v2ptr);
if(v2ptr) {
L_CDR(rptr) = lisp_create_pair(NULL, NULL);
rptr = L_CDR(rptr);
}
}
}
} else {
L_CAR(rptr) = lisp_quasiquote(exec, L_CAR(vptr));
}
vptr = L_CDR(vptr);
if(vptr) {
L_CDR(rptr) = lisp_create_pair(NULL, NULL);
rptr = L_CDR(rptr);
}
}
return res;
} else {
return v;
}
}
int main(int argc, char **argv)
{
lisp_runtime rt;
lisp_init(&rt);
lisp_scope *scope = (lisp_scope*)lisp_new(&rt, type_scope);
lisp_scope_populate_builtins(&rt, scope);
while (true) {
char *input = readline("> ");
if (input == NULL) {
break;
}
lisp_value *value = lisp_parse(&rt, input);
add_history(input);
free(input);
lisp_value *result = lisp_eval(&rt, scope, value);
lisp_print(stdout, result);
fprintf(stdout, "\n");
lisp_mark(&rt, (lisp_value*)scope);
lisp_sweep(&rt);
}
lisp_destroy(&rt);
return 0;
}
void lisp_repl_file(FILE* f)
{
while (!feof(f)) {
LispVal* val = lisp_read(f);
if (!val)
break;
LispVal* res = lisp_eval(val);
lisp_val_print(res);
putchar('\n');
lisp_val_free(val);
lisp_val_free(res);
}
}
lv_t *lisp_exec_fn(lexec_t *exec, lv_t *fn, lv_t *args) {
lv_t *parsed_args;
lv_t *layer, *newenv;
lv_t *macrofn;
lv_t *result;
assert(exec && fn && args);
rt_assert(fn->type == l_fn, le_type, "not a function");
lisp_exec_push_eval(exec, fn);
switch(L_FN_FTYPE(fn)) {
case lf_native:
result = L_FN(fn)(exec, args);
break;
case lf_lambda:
layer = lisp_args_overlay(exec, L_FN_ARGS(fn), args);
newenv = lisp_create_pair(layer, L_FN_ENV(fn));
lisp_exec_push_env(exec, newenv);
result = lisp_eval(exec, L_FN_BODY(fn));
lisp_exec_pop_env(exec);
break;
case lf_macro:
layer = lisp_args_overlay(exec, L_FN_ARGS(fn), args);
newenv = lisp_create_pair(layer, L_FN_ENV(fn));
lisp_exec_push_env(exec, newenv);
macrofn = lisp_eval(exec, L_FN_BODY(fn));
result = lisp_eval(exec, macrofn);
lisp_exec_pop_env(exec);
break;
default:
assert(0);
}
lisp_exec_pop_eval(exec);
return result;
}
/**
* begin special form
*
* (begin (expr1 expr2 expr3))
*/
lv_t *lisp_begin(lexec_t *exec, lv_t *v) {
lv_t *current;
lv_t *retval;
assert(exec);
rt_assert(v->type == l_pair, le_type, "cannot begin non-list");
current = v;
while(v && (L_CAR(v))) {
retval = lisp_eval(exec, L_CAR(v));
v = L_CDR(v);
}
return retval;
}
void lisp_REPL(FILE* in, FILE* out, FILE* err)
{
while (true) {
LISPTR m = lisp_read(in);
// debugging - trace what we just read:
fputs("lisp_read => ", out);
lisp_print(m, out);
fputs("\n", out);
// NIL means end-of-job:
if (m==NIL) break;
LISPTR v = lisp_eval(m);
fputs("lisp_eval => ", out);
lisp_print(v, out);
fputs("\n", out);
}
}
/**
* eval a list of items, one after the other, returning the
* value of the last eval
*/
lv_t *c_sequential_eval(lexec_t *exec, lv_t *v) {
lv_t *current = v;
lv_t *result;
assert(exec);
assert(v->type == l_pair || v->type == l_null);
if(v->type == l_null)
return v;
while(current && L_CAR(current)) {
result = lisp_eval(exec, L_CAR(current));
current = L_CDR(current);
}
return result;
}
int main()
{
int i = 0;
/*
//initialise opArray with opNames and opPointers
int i = 0;
//initialise + operator
++i;
opArray = realloc(opArray, i * sizeof(struct lisp_object));
opArray[i-1].objectType = T_procedure;
opArray[i-1].proc.opName = malloc(sizeof("+"));
strcpy(opArray[i-1].opName, "+");
opArray[i-1].opPointer = &add;
//initalise - operator
++i;
opArray = realloc(opArray, i * sizeof(struct op));
opArray[i-1].opName = malloc(sizeof("-"));
strcpy(opArray[i-1].opName, "-");
opArray[i-1].opPointer = &subtract;
//initalise * operator
++i;
opArray = realloc(opArray, i * sizeof(struct op));
opArray[i-1].opName = malloc(sizeof("*"));
strcpy(opArray[i-1].opName, "*");
opArray[i-1].opPointer = &multiply;
//initalise - operator
++i;
opArray = realloc(opArray, i * sizeof(struct op));
opArray[i-1].opName = malloc(sizeof("/"));
strcpy(opArray[i-1].opName, "/");
opArray[i-1].opPointer = ÷
*/
//printf("++Because this is currently all operations have to be done inside a list++\n");
printf("++++++++++++++++++++Various other things are also a bit shit+++++++++++++++++++\n\n");
do
{
printf(">");
//struct lisp_object m = lisp_eval(lisp_read());
lisp_write((lisp_eval(lisp_read())));
}
while(1);
}
object_t *eval_fw(lisp_t * l, object_t * args) {
return lisp_eval(l, car(args));
}
/**
* evaluate a lisp value
*/
lv_t *lisp_eval(lexec_t *exec, lv_t *v) {
lv_t *env;
lv_t *fn;
lv_t *args;
lv_t *result;
lv_t *a0, *a1, *a2, *a3;
assert(exec);
if(v->type == l_sym) {
result = c_env_lookup(exec->env, v);
if(result)
return result;
} /* otherwise, return symbol... */
if(v->type != l_pair) { // atom?
return v;
}
/* check for special forms and functions */
if(v->type == l_pair) {
/* test special forms first */
if(L_CAR(v)->type == l_sym) {
if(strcmp(L_SYM(L_CAR(v)), "quote") == 0) {
return lisp_quote(exec, L_CDR(v));
} else if(!strcmp(L_SYM(L_CAR(v)), "define")) {
rt_assert(c_list_length(L_CDR(v)) == 2, le_arity,
"define arity");
result = lisp_eval(exec, L_CADDR(v));
if(!result->bound)
result->bound = L_CADR(v);
return lisp_define(exec, L_CADR(v), result);
} else if(!strcmp(L_SYM(L_CAR(v)), "lambda")) {
rt_assert(c_list_length(L_CDR(v)) == 2, le_arity,
"lambda arity");
result = lisp_create_lambda(exec, L_CADR(v), L_CADDR(v));
lisp_stamp_value(result, v->row, v->col, v->file);
return result;
} else if(!strcmp(L_SYM(L_CAR(v)), "defmacro")) {
rt_assert(c_list_length(L_CDR(v)) == 3, le_arity,
"defmacro arity");
a1 = L_CADR(v); // name
a2 = L_CADDR(v); // lambda-list/formals
a3 = L_CADDDR(v); // form
rt_assert(a1->type == l_sym, le_type,
"defmacro wrong type for name");
return lisp_define(exec, a1, lisp_create_macro(exec, a2, a3));
} else if(!strcmp(L_SYM(L_CAR(v)), "begin")) {
rt_assert(L_CADR(v), le_arity, "begin arity");
return lisp_begin(exec, L_CDR(v));
} else if(!strcmp(L_SYM(L_CAR(v)), "quasiquote")) {
rt_assert(
L_CDR(v)->type == l_null ||
(L_CDR(v)->type == l_pair && c_list_length(L_CDR(v)) == 1),
le_arity,
"quasiquote arity");
return lisp_quasiquote(exec, L_CADR(v));
} else if(!strcmp(L_SYM(L_CAR(v)), "if")) {
rt_assert(c_list_length(L_CDR(v)) == 3, le_arity,
"if arity");
a1 = lisp_eval(exec, L_CADR(v)); // expression
a2 = L_CADDR(v); // value if true
a3 = L_CADDDR(v); // value if false
if(a1->type == l_bool && L_BOOL(a1) == 0)
return lisp_eval(exec, a3);
return lisp_eval(exec, a2);
} else if(!strcmp(L_SYM(L_CAR(v)), "let")) {
rt_assert(c_list_length(L_CDR(v)) == 2, le_arity,
"let arity");
a1 = L_CADR(v); // tuple assignment list
a2 = L_CADDR(v); // eval under let
return lisp_let(exec, a1, a2);
} else if(!strcmp(L_SYM(L_CAR(v)), "let*")) {
rt_assert(c_list_length(L_CDR(v)) == 2, le_arity,
"let arity");
a1 = L_CADR(v); // tuple assignment list
a2 = L_CADDR(v); // eval under let
return lisp_let_star(exec, a1, a2);
}
}
/* otherwise, eval all the items, and execute */
result = lisp_map(exec, lisp_create_pair(lisp_create_native_fn(lisp_eval), v));
/* make sure it's a function */
fn = L_CAR(result);
args = L_CDR(result);
rt_assert(fn->type == l_fn, le_type, "eval a non-function");
if(!args)
args = lisp_create_null();
/* and go. */
return lisp_exec_fn(exec, fn, args);
/* /\* test symbols *\/ */
/* if(v->type == l_fn) */
/* fn = v; */
/* else if(L_CAR(v)->type == l_sym) { */
/* lv_t *tmp = c_env_lookup(env, L_CAR(v)); */
/* rt_assert(tmp, le_lookup, "unknown function"); */
/* rt_assert(tmp->type == l_fn, le_type, "eval a non-function"); */
/* fn = tmp; */
/* } */
/* lv_t *eval_fn = lisp_create_native_fn(lisp_eval); */
/* /\* execute the function *\/ */
/* args = L_CDR(v); */
/* if(!args) */
/* args = lisp_create_null(); */
/* return L_FN(fn)(env, lisp_map(env, c_make_list(eval_fn, args, NULL))); */
}
assert(0);
}
void repl_run(repl_t * repl) {
object_t *repl_obj = lisp_read(repl->lisp, REPL_EXPR, strlen(REPL_EXPR));
lisp_eval(repl->lisp, repl_obj);
}