blob: a0b7c78fd5409f64e3380c948ad3fa9dcdb1c499 [file] [log] [blame]
#include "std.h"
#include "../gc.h"
#include "../compiler.h"
#include "../plat/plat.h"
#include <stdlib.h>
#include <string.h>
value_t l_plus(value_t a, value_t b)
{
if (!integerp(a) || !integerp(b))
return nil;
return (((a >> 2) + (b >> 2)) << 2) | INT_TAG;
}
value_t l_minus(value_t a, value_t b)
{
if (!integerp(a) || !integerp(b))
return nil;
return (((a >> 2) - (b >> 2)) << 2) | INT_TAG;
}
value_t l_times(value_t a, value_t b)
{
if (!integerp(a) || !integerp(b))
return nil;
return (((a >> 2) * (b >> 2)) << 2) | INT_TAG;
}
value_t l_divide(value_t a, value_t b)
{
if (!integerp(a) || !integerp(b))
return nil;
return (((a >> 2) / (b >> 2)) << 2) | INT_TAG;
}
value_t l_printval(value_t val)
{
printval(val, 0);
return nil;
}
value_t l_apply(value_t func, value_t args)
{
if (!closurep(func))
return nil;
if (!listp(args))
return nil;
return call_list_closure((struct closure *)(func ^ CLOSURE_TAG), args);
}
value_t l_nilp(value_t val)
{
return nilp(val) ? t : nil;
}
void add_function(struct environment *env, char *name, void *func, struct args *args, enum namespace ns)
{
struct function *last, *new = malloc(sizeof(struct function));
last = env->first;
new->prev = last;
new->name = name;
new->args = args;
new->code_ptr = func;
new->namespace = ns;
env->first = new;
}
void add_c_varargs(struct environment *env, char *name, void *func, int nargs)
{
struct args *args = new_args();
args->num_required = nargs;
args->variadic = true;
add_function(env, name, func, args, NS_FUNCTION);
}
void add_c_function(struct environment *env, char *name, void *func, int nargs)
{
struct args *args = new_args();
args->num_required = nargs;
add_function(env, name, func, args, NS_FUNCTION);
}
value_t l_elt(value_t seq, value_t i)
{
if (!listp(seq) || !integerp(i))
return nil;
return elt(seq, i >> 2);
}
value_t l_read_stdin()
{
char *string = read_input_line("lisp> ");
if (!string)
return nil;
struct istream *is = new_stristream_nt(string);
value_t val = nil;
struct error err = { 0 };
if (!IS_OKAY((err = read1(is, &val))))
{
ereport(err);
del_stristream(is);
free(string);
// tail recursion, yay!
return l_read_stdin();
}
del_stristream(is);
free(string);
return val;
}
value_t l_num_eq(value_t a, value_t b)
{
if (!integerp(a) || !integerp(b))
{
return nil;
}
return (a >> 2) == (b >> 2) ? t : nil;
}
value_t l_num_gt(value_t a, value_t b)
{
if (!integerp(a) || !integerp(b))
return nil;
return (a >> 2) > (b >> 2) ? t : nil;
}
value_t l_num_lt(value_t a, value_t b)
{
if (!integerp(a) || !integerp(b))
return nil;
return (a >> 2) < (b >> 2) ? t : nil;
}
value_t l_append(value_t l)
{
if (nilp(l))
return l;
value_t first = nil;
value_t *last = NULL;
for (value_t item = l; !nilp(item); item = cdr(item))
{
value_t a = car(item);
if (!listp(a))
{
value_t new = cons(a, nil);
*last = new;
last = cdrref(new);
continue;
}
for (value_t i = a; !nilp(i); i = cdr(i))
{
value_t b = car(i);
if (!last)
{
first = cons(b, nil);
last = cdrref(first);
}
else
{
value_t new = cons(b, nil);
*last = new;
last = cdrref(new);
}
}
}
return first;
}
value_t l_gc_stats()
{
struct gc_stats stats = gc_get_stats();
return cons(intval(stats.total_allocs),
cons(intval(stats.gc_runs),
nil));
}
value_t l_list_functions(value_t env)
{
if (!integerp(env))
return nil;
struct environment *e = (void *)env;
value_t list = nil;
for (struct function *fun = e->first; fun; fun = fun->prev)
{
list = cons(symval(fun->name), list);
}
return list;
}
#define LISP_PREDICATE(name) value_t l_##name(value_t v) { return name(v) ? t : nil; }
LISP_PREDICATE(listp)
LISP_PREDICATE(integerp)
LISP_PREDICATE(symbolp)
LISP_PREDICATE(closurep)
LISP_PREDICATE(consp)
#undef LISP_PREDICATE
struct error load_std(struct environment *env)
{
E_INIT();
add_c_function(env, "+", l_plus, 2);
add_c_function(env, "-", l_minus, 2);
add_c_function(env, "*", l_times, 2);
add_c_function(env, "/", l_divide, 2);
add_c_function(env, "=", l_num_eq, 2);
add_c_function(env, "<", l_num_lt, 2);
add_c_function(env, ">", l_num_gt, 2);
add_c_function(env, "car", car, 1);
add_c_function(env, "cdr", cdr, 1);
add_c_function(env, "cons", cons, 2);
add_c_function(env, "print", l_printval, 1);
add_c_function(env, "read-stdin", l_read_stdin, 0);
add_c_function(env, "apply", l_apply, 2);
add_c_varargs(env, "append", l_append, 0);
add_c_function(env, "nilp", l_nilp, 1);
add_c_function(env, "listp", l_listp, 1);
add_c_function(env, "integerp", l_integerp, 1);
add_c_function(env, "symbolp", l_symbolp, 1);
add_c_function(env, "closurep", l_closurep, 1);
add_c_function(env, "functionp", l_closurep, 1);
add_c_function(env, "consp", l_consp, 1);
add_c_function(env, "elt", l_elt, 2);
add_c_function(env, "gc-stats", l_gc_stats, 0);
add_c_function(env, "env-functions", l_list_functions, 1);
if (!load_library(env, "std"))
{
fprintf(stderr, "Not found std\n");
THROW(ENOTFOUND, "Could not load library `std`, make sure your $LISP_LIBRARY_PATH is correct.");
}
OKAY();
}
bool load_library(struct environment *env, char *name)
{
char *lib_paths = getenv("LISP_LIBRARY_PATH");
if (!lib_paths)
lib_paths = "/lib/lisp";
for (char *p = strtok(lib_paths, ":"); p; p = strtok(NULL, ":"))
{
static char path[512];
snprintf(path, 512, "%s/%s.lisp", p, name);
if (file_exists(path))
{
// fprintf(stderr, "loading path: %s\n", path);
return load(env, path);
}
snprintf(path, 512, "%s/%s/%s.lisp", p, name, name);
if (file_exists(path))
{
// fprintf(stderr, "loading path: %s\n", path);
return load(env, path);
}
}
return false;
}