/**
* (append list ...)
*/
lv_t *p_append(lexec_t *exec, lv_t *v) {
lv_t *r;
lv_t *tptr, *vptr;
assert(exec && v);
assert((v->type == l_pair) || (v->type == l_null));
rt_assert(c_list_length(v) > 1, le_arity, "expecting at least 1 arg");
r = L_CAR(v);
vptr = L_CDR(v);
while(vptr) {
r = lisp_dup_item(r);
if(r->type == l_null)
r = L_CAR(vptr);
else {
tptr = r;
while(L_CDR(tptr))
tptr = L_CDR(tptr);
L_CDR(tptr) = L_CAR(vptr);
}
vptr = L_CDR(vptr);
}
return r;
}
lv_t *p_load(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "load arity");
rt_assert(L_CAR(v)->type == l_str, le_type, "filename must be string");
return c_sequential_eval(exec, c_parse_file(exec, L_STR(L_CAR(v))));
}
/**
* map a function onto a list, returning the
* resulting list
*/
lv_t *lisp_map(lexec_t *exec, lv_t *v) {
lv_t *vptr;
lv_t *result = lisp_create_pair(NULL, NULL);
lv_t *rptr = result;
lv_t *fn, *list;
assert(exec);
fn = L_CAR(v);
list = L_CDR(v);
rt_assert(fn->type == l_fn, le_type, "map with non-function");
rt_assert((list->type == l_pair) || (list->type == l_null),
le_type, "map to non-list");
if(list->type == l_null)
return list;
vptr = list;
while(vptr) {
L_CAR(rptr) = L_FN(fn)(exec, L_CAR(vptr));
vptr=L_CDR(vptr);
if(vptr) {
L_CDR(rptr) = lisp_create_pair(NULL, NULL);
rptr = L_CDR(rptr);
}
}
return result;
}
lv_t *p_not(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "not arity");
rt_assert(L_CAR(v)->type == l_bool, le_type, "not bool");
return lisp_create_bool(!(L_BOOL(L_CAR(v))));
}
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;
}
/**
* dup an object
*/
lv_t *lisp_dup_item(lv_t *v) {
lv_t *r;
lv_t *vptr = v;
lv_t *rptr;
assert(v);
switch(v->type) {
case l_int:
r = lisp_create_int(0);
mpz_set(L_INT(r), L_INT(v));
return r;
case l_rational:
r = lisp_create_rational(1, 1);
mpq_set(L_RAT(r), L_RAT(v));
return r;
case l_float:
r = lisp_create_float(0.0);
mpfr_set(L_FLOAT(r), L_FLOAT(v), MPFR_ROUND_TYPE);
return r;
case l_bool:
return v;
case l_sym:
return lisp_create_symbol(L_SYM(v));
case l_str:
return lisp_create_string(L_STR(v));
case l_null:
return v;
case l_port:
/* can't really copy this -- it's a socket or a file
handle, or something else. */
return v;
case l_char:
return lisp_create_char(L_CHAR(v));
case l_fn:
/* can't really copy this either, but it's essentially
immutable */
return v;
case l_err:
return lisp_create_err(L_ERR(v));
case l_hash:
/* FIXME: should really be a copy */
return v;
case l_pair:
r = lisp_create_pair(NULL, NULL);
rptr = r;
while(vptr && L_CAR(vptr)) {
L_CAR(rptr) = lisp_dup_item(L_CAR(vptr));
vptr = L_CDR(vptr);
if(vptr) {
L_CDR(rptr) = lisp_create_pair(NULL, NULL);
rptr = L_CDR(rptr);
}
}
return r;
}
assert(0);
}
/**
* 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;
}
}
lv_t *p_set_car(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 2, le_arity, "set-cdr arity");
rt_assert(L_CAR(v)->type == l_pair, le_type, "set-car on non-pair");
L_CAR(L_CAR(v)) = L_CADR(v);
return lisp_create_null();
}
lv_t *p_assert(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "assert arity");
rt_assert(L_CAR(v)->type == l_bool, le_type, "assert not bool");
if(!L_BOOL(L_CAR(v)))
rt_assert(0, le_internal, "error raised");
return lisp_create_null();
}
lv_t *p_warn(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "warn arity");
rt_assert(L_CAR(v)->type == l_bool, le_type, "warn not bool");
if(!L_BOOL(L_CAR(v)))
rt_assert(0, le_warn, "warning raised");
return lisp_create_null();
}
/**
* print a value to a fd, in a debug form
*/
void lisp_dump_value(int fd, lv_t *v, int level) {
switch(v->type) {
case l_null:
dprintf(fd, "()");
break;
case l_int:
dprintf(fd, "%" PRIu64, L_INT(v));
break;
case l_float:
dprintf(fd, "%0.16g", L_FLOAT(v));
break;
case l_bool:
dprintf(fd, "%s", L_BOOL(v) ? "#t": "#f");
break;
case l_sym:
dprintf(fd, "%s", L_SYM(v));
break;
case l_str:
dprintf(fd, "\"%s\"", L_STR(v));
break;
case l_char:
dprintf(fd, "#\%02x", L_CHAR(v));
break;
case l_pair:
dprintf(fd, "(");
lv_t *vp = v;
while(vp && L_CAR(vp)) {
lisp_dump_value(fd, L_CAR(vp), level + 1);
if(L_CDR(vp) && (L_CDR(vp)->type != l_pair)) {
dprintf(fd, " . ");
lisp_dump_value(fd, L_CDR(vp), level + 1);
vp = NULL;
} else {
vp = L_CDR(vp);
dprintf(fd, "%s", vp ? " " : "");
}
}
dprintf(fd, ")");
break;
case l_fn:
if(L_FN(v) == NULL)
dprintf(fd, "<lambda@%p>", v);
else
dprintf(fd, "<built-in@%p>", v);
break;
default:
// missing a type check.
assert(0);
}
}
lv_t *lisp_args_overlay(lexec_t *exec, lv_t *formals, lv_t *args) {
lv_t *pf, *pa;
lv_t *env_layer;
assert(formals->type == l_pair ||
formals->type == l_null ||
formals->type == l_sym);
assert(args->type == l_pair || args->type == l_null || args->type == l_sym);
env_layer = lisp_create_hash();
pf = formals;
pa = args;
/* no args */
if(pf->type == l_null) {
rt_assert(c_list_length(pa) == 0, le_arity, "too many arguments");
return env_layer;
}
/* single arg gets the whole list */
if(pf->type == l_sym) {
c_hash_insert(env_layer, pf, lisp_dup_item(pa));
return env_layer;
}
/* walk through the formal list, matching to args */
while(pf && L_CAR(pf)) {
rt_assert(pa && L_CAR(pa), le_arity, "not enough arguments");
c_hash_insert(env_layer, L_CAR(pf), L_CAR(pa));
pf = L_CDR(pf);
pa = L_CDR(pa);
if(pf && pf->type == l_sym) {
/* improper list */
if(!pa) {
c_hash_insert(env_layer, pf, lisp_create_null());
} else {
c_hash_insert(env_layer, pf, lisp_dup_item(pa));
}
return env_layer;
}
rt_assert(!pf || pf->type == l_pair, le_type, "unexpected formal type");
}
rt_assert(!pa, le_arity, "too many arguments");
return env_layer;
}
/**
* c helper for equalp
*/
int c_equalp(lv_t *a1, lv_t *a2) {
int result = 0;
if(a1->type != a2->type)
return 0;
switch(a1->type) {
case l_int:
result = (mpz_cmp(L_INT(a1), L_INT(a2)) == 0);
break;
case l_float:
result = (mpfr_cmp(L_FLOAT(a1), L_FLOAT(a2)) == 0);
break;
case l_bool:
if((L_BOOL(a1) == 0 && L_BOOL(a2) == 0) ||
(L_BOOL(a1) != 0 && L_BOOL(a1) != 0))
result = 1;
break;
case l_sym:
if(strcmp(L_SYM(a1), L_SYM(a2)) == 0)
result = 1;
break;
case l_str:
if(strcmp(L_STR(a1), L_STR(a2)) == 0)
result = 1;
break;
case l_hash:
result = (L_HASH(a1) == L_HASH(a2));
break;
case l_null:
result = 1;
break;
case l_fn:
result = (L_FN(a1) == L_FN(a1));
break;
case l_pair:
/* this is perhaps not right */
if(!(c_equalp(L_CAR(a1), L_CAR(a2))))
return 0;
if(L_CDR(a1) && L_CDR(a2))
return c_equalp(L_CDR(a1), L_CDR(a2));
if(!L_CDR(a1) && !L_CDR(a2))
return 1;
result = 0;
break;
}
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;
}
lv_t *p_symbolp(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
lv_t *a0 = L_CAR(v);
return s_is_type(a0, l_sym);
}
lv_t *p_inspect(lexec_t *exec, lv_t *v) {
lv_t *arg;
int show_line = 1;
char buffer[256];
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "inspect arity");
arg = L_CAR(v);
memset(buffer, 0, sizeof(buffer));
strcat(buffer, "type: ");
if(arg->type == l_fn) {
if(L_FN(arg)) {
strcat(buffer, "built-in function");
show_line = 0;
} else {
strcat(buffer, "lambda, declared at");
}
} else {
strcat(buffer, lisp_types_list[arg->type] + 2);
}
if(show_line)
sprintf(buffer + strlen(buffer), " %s:%d:%d",
arg->file, arg->row, arg->col);
if(arg->bound)
sprintf(buffer + strlen(buffer), ", bound to: %s",
L_SYM(arg->bound));
return lisp_create_string(buffer);
}
lv_t *p_consp(lexec_t *exec, lv_t *v) {
assert(v && v->type == l_pair);
rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
lv_t *a0 = L_CAR(v);
return s_is_type(a0, l_pair);
}
lv_t *p_pairp(lexec_t *exec, lv_t *v) {
assert(v && v->type == l_pair);
rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
lv_t *a0 = L_CAR(v);
return lisp_create_bool(a0->type == l_pair);
}
lv_t *c_env_version(int version) {
environment_list_t *current = s_env_prim;
lv_t *p_layer = lisp_create_hash();
lv_t *newenv;
char filename[40];
lexec_t *exec;
newenv = lisp_create_pair(lisp_create_hash(),
lisp_create_pair(p_layer, NULL));
exec = safe_malloc(sizeof(lexec_t));
memset(exec, 0, sizeof(lexec_t));
exec->env = newenv;
snprintf(filename, sizeof(filename), "env/r%d.scm", version);
/* now, load up a primitive environment */
while(current && current->name) {
c_hash_insert(p_layer, lisp_create_string(current->name),
lisp_create_native_fn(current->fn));
current++;
}
/* now, run the setup environment */
p_load(exec, lisp_create_pair(lisp_create_string(filename), NULL));
/* and return just the generated environment */
return lisp_create_pair(L_CAR(exec->env), NULL);
}
lv_t *c_env_lookup(lv_t *env, lv_t *key) {
lv_t *current;
lv_t *result;
assert(env->type == l_pair &&
L_CAR(env) &&
L_CAR(env)->type == l_hash);
current=env;
while(current) {
if((result = c_hash_fetch(L_CAR(current), key)))
return result;
current = L_CDR(current);
}
return NULL;
}
/**
* 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;
}
lv_t *lisp_define(lexec_t *exec, lv_t *sym, lv_t *v) {
assert(exec);
/* this is probably not a good or completely safe
* check of an environment */
rt_assert(exec->env->type == l_pair &&
L_CAR(exec->env) &&
L_CAR(exec->env)->type == l_hash, le_type,
"Not a valid environment");
rt_assert(sym->type == l_sym, le_type, "cannot define non-symbol");
rt_assert(c_hash_insert(L_CAR(exec->env), sym, v), le_internal,
"error inserting hash element");
return lisp_create_null();
}
void repl(int level) {
char prompt[30];
char *cmd;
int quit = 0;
int line = 1;
lv_t *parsed_value;
lv_t *env_sym;
lv_t *result;
lv_t *arg;
lv_t *str;
char sym_buf[20];
lexec_t *exec;
exec = lisp_context_new(5); /* get r5rs environment */
while(!quit) {
snprintf(prompt, sizeof(prompt), "%d:%d> ", level, line);
// r!
cmd = readline(prompt);
if(!cmd) {
printf("\n");
quit = 1;
break;
}
if(!*cmd)
continue;
parsed_value = lisp_parse_string(cmd);
if(!parsed_value) {
fprintf(stderr, "synax error\n");
continue;
}
// e!
result = lisp_execute(exec, parsed_value);
// p!
if(result && !is_nil(result)) {
sprintf(sym_buf, "$%d", line);
env_sym = lisp_create_symbol(sym_buf);
c_hash_insert(L_CAR(exec->env), env_sym, result);
dprintf(1, "%s = ", sym_buf);
str = lisp_str_from_value(result);
printf("%s\n", L_STR(str));
}
// and l. ;)
add_history(cmd);
free(cmd);
line++;
}
}
lv_t *p_listp(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "wrong arity");
lv_t *a0 = L_CAR(v);
if((a0->type == l_pair) || (a0->type == l_null))
return lisp_create_bool(1);
return lisp_create_bool(0);
}
/**
* lisp wrapper around c_equalp
*/
lv_t *p_equalp(lexec_t *exec, lv_t *v) {
int result;
assert(v && exec);
rt_assert(c_list_length(v) == 2, le_arity, "wrong arity");
lv_t *a1 = L_CAR(v);
lv_t *a2 = L_CADR(v);
return(lisp_create_bool(c_equalp(a1, a2)));
}
lv_t *p_cdr(lexec_t *exec, lv_t *v) {
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "cdr arity");
rt_assert(L_CAR(v)->type == l_pair, le_type, "cdr on non-list");
if(L_CDAR(v) == NULL)
return lisp_create_null();
return L_CDAR(v);
}
/**
* determine if an error object is a particular
* subtype
*/
lv_t *c_error_type(lexec_t *exec, lv_t *v, lisp_errsubtype_t s) {
assert(exec && v);
assert(v->type == l_pair);
rt_assert(c_list_length(v) == 1, le_arity, "expecting 1 arg");
lv_t *a0 = L_CAR(v);
if((a0->type == l_err) && (L_ERR(a0) == s))
return lisp_create_bool(1);
return lisp_create_bool(0);
}
/**
* (error-object? obj)
*
* returns #t if obj is an error object, else #f
*/
lv_t *p_error_objectp(lexec_t *exec, lv_t *v) {
assert(exec && v);
assert(v->type == l_pair);
rt_assert(c_list_length(v) == 1, le_arity, "expecting 1 arg");
lv_t *a0 = L_CAR(v);
if(a0->type == l_err)
return lisp_create_bool(1);
return lisp_create_bool(0);
}
/**
* (write obj)
* (write obj port)
*
* write a representation of obj to the given port
* (or current-output-port if unspecified)
*
* returns nil
*/
lv_t *p_write(lexec_t *exec, lv_t *v) {
lv_t *str;
assert(v && exec);
rt_assert(c_list_length(v) == 1, le_arity, "display arity");
str = lisp_str_from_value(exec, L_CAR(v), 0);
fprintf(stdout, "%s", L_STR(str));
fflush(stdout);
return lisp_create_null();
}
/**
* (reverse list)
*/
lv_t *p_reverse(lexec_t *exec, lv_t *v) {
lv_t *r, *vptr;
assert(exec && v);
assert((v->type == l_pair) || (v->type == l_null));
rt_assert(c_list_length(v) == 1, le_arity, "expecting 1 arg");
vptr = L_CAR(v);
if(vptr->type == l_null)
return lisp_create_null();
rt_assert(vptr->type == l_pair, le_type, "expecting list");
r = NULL;
while(vptr && L_CAR(vptr)) {
r = lisp_create_pair(lisp_dup_item(L_CAR(vptr)), r);
vptr = L_CDR(vptr);
rt_assert(!vptr || (vptr->type == l_pair), le_type,
"expecting proper list");
}
return r;
}