Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
f96167367073f7f31dc6f00f60bc218dfb0acf9d
simple-lisp/src/lisp.c

3304 lines
109 KiB
C
Raw Blame History

#include "lisp.h"
// used by static function registering macros
#include "read.h" // IWYU pragma: keep
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
#include <string.h>
// used to fix up some indentation or syntax highlighting problems
#define IGNORE() struct __ignored_struct
struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES] = {
[TYPE_STRING] = {"string", sizeof("string") - 1},
[TYPE_SYMBOL] = {"symbol", sizeof("symbol") - 1},
[TYPE_PAIR] = {"pair", sizeof("pair") - 1},
[TYPE_INTEGER] = {"integer", sizeof("integer") - 1},
[TYPE_FLOAT] = {"float", sizeof("float") - 1},
[TYPE_VECTOR] = {"vector", sizeof("vector") - 1},
[TYPE_FUNCTION] = {"function", sizeof("function") - 1},
[TYPE_HASHTABLE] = {"hashtable", sizeof("hashtable") - 1},
[TYPE_USER_POINTER] = {"user-pointer", sizeof("user-pointer") - 1},
[TYPE_PACKAGE] = {"package", sizeof("package") - 1},
};
// #######################
// # nil, unbound, and t #
// #######################
DEF_STATIC_STRING(_Qnil_name, "nil");
LispSymbol _Qnil = {
.type = TYPE_SYMBOL,
.name = &_Qnil_name,
.package = Qnil,
.plist = Qnil,
.function = Qnil,
.value = Qnil,
.is_constant = true,
};
DEF_STATIC_STRING(_Qunbound_name, "unbound");
LispSymbol _Qunbound = {
.type = TYPE_SYMBOL,
.name = &_Qunbound_name,
.package = Qnil,
.plist = Qnil,
.function = Qnil,
.value = Qunbound,
.is_constant = true,
};
DEF_STATIC_STRING(_Qt_name, "t");
LispSymbol _Qt = {
.type = TYPE_SYMBOL,
.name = &_Qt_name,
.package = Qnil,
.plist = Qnil,
.function = Qnil,
.value = Qt,
.is_constant = true,
};
// ###########################
// # Other important symbols #
// ###########################
DEF_STATIC_SYMBOL(backquote, "`");
DEF_STATIC_SYMBOL(comma, ",");
DEF_STATIC_SYMBOL(comma_at, ",@");
DEF_STATIC_SYMBOL(opt, "&opt");
DEF_STATIC_SYMBOL(key, "&key");
DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys");
DEF_STATIC_SYMBOL(rest, "&rest");
DEF_STATIC_SYMBOL(declare, "declare");
DEF_STATIC_SYMBOL(name, "name");
// ############################
// # Global Package Variables #
// ############################
LispVal *package_table = Qnil;
LispVal *system_package = Qnil;
LispVal *keyword_package = Qnil;
LispVal *current_package = Qnil;
// #############################
// # Allocation and references #
// #############################
static size_t bytes_allocated = 0;
static size_t last_gc = 0;
void *lisp_malloc(size_t size) {
return lisp_realloc(NULL, size);
}
void *lisp_realloc(void *old_ptr, size_t size) {
if (!size) {
return NULL;
}
if (refcount_default_context && !refcount_is_doing_gc()) {
bytes_allocated += size;
}
void *new_ptr = realloc(old_ptr, size);
if (!new_ptr) {
abort();
}
return new_ptr;
}
void *lisp_malloc0(size_t size) {
void *ptr = lisp_malloc(size);
if (ptr && size) {
memset(ptr, 0, size);
}
return ptr;
}
void garbage_collect(void) {
last_gc = bytes_allocated;
refcount_garbage_collect();
}
static bool held_refs_callback(void *obj, RefcountList **held, void *ignored) {
switch (TYPEOF(obj)) {
case TYPE_STRING:
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_USER_POINTER:
// no held refs
return true;
case TYPE_SYMBOL:
*held = refcount_list_push(*held, ((LispSymbol *) obj)->name);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->function);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->plist);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->value);
return true;
case TYPE_PAIR:
*held = refcount_list_push(*held, ((LispPair *) obj)->head);
*held = refcount_list_push(*held, ((LispPair *) obj)->tail);
return true;
case TYPE_VECTOR: {
LispVector *vec = obj;
for (size_t i = 0; i < vec->length; ++i) {
*held = refcount_list_push(*held, vec->data[i]);
}
return true;
}
case TYPE_HASHTABLE: {
LispHashtable *ht = obj;
HT_FOREACH_VALID_INDEX(obj, i) {
*held = refcount_list_push(*held, HASH_KEY(obj, i));
*held = refcount_list_push(*held, HASH_VALUE(obj, i));
}
if (ht->eq_fn != Qstrings_equal) {
*held = refcount_list_push(*held, ht->eq_fn);
}
if (ht->hash_fn != Qhash_string) {
*held = refcount_list_push(*held, ht->hash_fn);
}
return true;
}
case TYPE_FUNCTION: {
LispFunction *fn = obj;
*held = refcount_list_push(*held, fn->name);
*held = refcount_list_push(*held, fn->return_tag);
*held = refcount_list_push(*held, fn->args);
*held = refcount_list_push(*held, fn->kwargs);
*held = refcount_list_push(*held, fn->oargs);
*held = refcount_list_push(*held, fn->rargs);
*held = refcount_list_push(*held, fn->lexenv);
*held = refcount_list_push(*held, fn->doc);
*held = refcount_list_push(*held, fn->rest_arg);
if (!fn->is_builtin) {
*held = refcount_list_push(*held, fn->body);
}
return true;
}
case TYPE_PACKAGE: {
LispPackage *pkg = obj;
*held = refcount_list_push(*held, pkg->name);
*held = refcount_list_push(*held, pkg->imported);
*held = refcount_list_push(*held, pkg->obarray);
*held = refcount_list_push(*held, pkg->exported_sym_table);
return true;
}
default:
abort();
}
}
static void free_obj_callback(void *obj, void *ignored) {
switch (TYPEOF(obj)) {
case TYPE_STRING: {
LispString *str = obj;
if (!str->is_static) {
lisp_free(str->data);
}
} break;
case TYPE_VECTOR: {
LispVector *vec = obj;
if (!vec->is_static) {
lisp_free(vec->data);
}
} break;
case TYPE_USER_POINTER: {
LispUserPointer *ptr = obj;
if (ptr->free_func) {
ptr->free_func(ptr->data);
}
} break;
case TYPE_HASHTABLE: {
LispHashtable *ht = obj;
lisp_free(ht->key_vals);
} break;
case TYPE_FUNCTION:
case TYPE_SYMBOL:
case TYPE_PAIR:
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_PACKAGE:
// no internal data to free
break;
default:
abort();
}
lisp_free(obj);
}
// ################
// # Constructors #
// ################
#define CONSTRUCT_OBJECT(var, Type, TYPE) \
Type *var = lisp_malloc(sizeof(Type)); \
refcount_init_obj(var); \
var->type = TYPE;
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static) {
CONSTRUCT_OBJECT(self, LispString, TYPE_STRING);
if (take) {
self->data = (char *) data;
} else {
self->data = lisp_malloc(length + 1);
memcpy(self->data, data, length);
self->data[length] = '\0';
}
self->length = length;
self->is_static = is_static;
return LISPVAL(self);
}
LispVal *make_lisp_symbol(LispVal *name) {
CHECK_TYPE(TYPE_STRING, name);
CONSTRUCT_OBJECT(self, LispSymbol, TYPE_SYMBOL);
self->name = (LispString *) refcount_ref(name);
self->package = Qnil;
self->plist = Qnil;
self->function = Qnil;
self->value = Qunbound;
self->is_constant = false;
return LISPVAL(self);
}
LispVal *make_lisp_pair(LispVal *head, LispVal *tail) {
CONSTRUCT_OBJECT(self, LispPair, TYPE_PAIR);
self->head = refcount_ref(head);
self->tail = refcount_ref(tail);
return LISPVAL(self);
}
LispVal *make_lisp_integer(intmax_t value) {
CONSTRUCT_OBJECT(self, LispInteger, TYPE_INTEGER);
self->type = TYPE_INTEGER;
self->value = value;
return LISPVAL(self);
}
LispVal *make_lisp_float(long double value) {
CONSTRUCT_OBJECT(self, LispFloat, TYPE_FLOAT);
self->value = value;
return LISPVAL(self);
}
LispVal *make_lisp_vector(LispVal **data, size_t length) {
CONSTRUCT_OBJECT(self, LispVector, TYPE_VECTOR);
self->data = data;
self->length = length;
self->is_static = false;
return LISPVAL(self);
}
static bool parse_opt_arg_entry(LispVal *ent, struct OptArgDesc *aod,
LispVal *found_args) {
aod->name = Qnil;
aod->default_form = Qnil;
aod->pred_var = Qnil;
if (TYPEOF(ent) == TYPE_SYMBOL) {
if (VALUE_CONSTANTP(ent)) {
return false;
} else if (!NILP(gethash(found_args, ent, Qnil))) {
return false;
}
aod->name = refcount_ref(ent);
aod->pred_var = Qnil;
aod->default_form = Qnil;
return true;
} else if (LISTP(ent) && SYMBOLP(HEAD(ent)) && !VALUE_CONSTANTP(HEAD(ent))
&& LISTP(TAIL(ent))) {
LispVal *end = TAIL(TAIL(ent));
if (!LISTP(end) || (!SYMBOLP(HEAD(end)) && !NILP(HEAD(end)))
|| (!NILP(HEAD(end)) && VALUE_CONSTANTP(HEAD(end)))) {
return false;
} else if (!NILP(gethash(found_args, HEAD(ent), Qnil))) {
return false;
} else if (!NILP(end)
&& (!NILP(gethash(found_args, HEAD(end), Qnil))
|| VALUE_CONSTANTP(HEAD(end))
|| HEAD(end) == HEAD(ent))) {
return false;
}
aod->name = refcount_ref(HEAD(ent));
aod->default_form = refcount_ref(HEAD(TAIL(ent)));
aod->pred_var = refcount_ref(HEAD(end));
return true;
}
return false;
}
LispVal *make_lisp_function(LispVal *name, LispVal *return_tag, LispVal *args,
LispVal *lexenv, LispVal *body, bool is_macro) {
CONSTRUCT_OBJECT(self, LispFunction, TYPE_FUNCTION);
self->is_builtin = false;
self->is_macro = is_macro;
self->args = Qnil;
self->rargs = Qnil;
self->oargs = Qnil;
self->rest_arg = Qnil;
self->kwargs = Qnil;
self->name = Qnil;
self->return_tag = Qnil;
self->lexenv = Qnil;
self->doc = Qnil;
self->body = Qnil;
void *cl = register_cleanup(&refcount_unref_as_callback, self);
set_function_args(self, args);
cancel_cleanup(cl);
// do these after the potential throw
self->name = refcount_ref(name);
self->return_tag = refcount_ref(return_tag);
self->lexenv = refcount_ref(lexenv);
if (STRINGP(HEAD(body))) {
self->doc = refcount_ref(HEAD(body));
self->body = refcount_ref(TAIL(body));
} else {
self->doc = Qnil;
self->body = refcount_ref(body);
}
return LISPVAL(self);
}
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
CONSTRUCT_OBJECT(self, LispHashtable, TYPE_HASHTABLE);
self->table_size = LISP_HASHTABLE_INITIAL_SIZE;
self->key_vals =
lisp_malloc0(sizeof(struct HashtableEntry) * self->table_size);
self->count = 0;
// needed during early initialization
if (eq_fn == Qstrings_equal) {
self->eq_fn = eq_fn;
} else {
self->eq_fn = refcount_ref(eq_fn);
}
if (hash_fn == Qhash_string) {
self->hash_fn = hash_fn;
} else {
self->hash_fn = refcount_ref(hash_fn);
}
return LISPVAL(self);
}
LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
CONSTRUCT_OBJECT(self, LispUserPointer, TYPE_USER_POINTER);
self->data = data;
self->free_func = free_func;
return LISPVAL(self);
}
LispVal *make_lisp_package(LispVal *name) {
CHECK_TYPE(TYPE_STRING, name);
CONSTRUCT_OBJECT(self, LispPackage, TYPE_PACKAGE);
self->name = refcount_ref(name);
self->obarray = make_lisp_hashtable(Qstrings_equal, Qhash_string);
self->exported_sym_table = make_lisp_hashtable(Qnil, Qnil);
self->imported = Qnil;
return LISPVAL(self);
}
LispVal *predicate_for_type(LispType type) {
switch (type) {
case TYPE_STRING:
return Qstringp;
case TYPE_SYMBOL:
return Qsymbolp;
case TYPE_PAIR:
return Qpairp;
case TYPE_INTEGER:
return Qintegerp;
case TYPE_FLOAT:
return Qfloatp;
case TYPE_VECTOR:
return Qvectorp;
case TYPE_FUNCTION:
return Qfunctionp;
case TYPE_HASHTABLE:
return Qhashtablep;
case TYPE_USER_POINTER:
return Quser_pointer_p;
case TYPE_PACKAGE:
return Qpackagep;
default:
abort();
}
}
// ###############################
// # Initialization and Shutdown #
// ###############################
static void register_symbols_and_functions(void);
void lisp_init(void) {
RefcountContext *ctx = refcount_make_context(
offsetof(LispVal, refcount), Qnil, held_refs_callback,
free_obj_callback, NULL,
&(RefcountAllocator) {.malloc.no_data = lisp_malloc,
.free.no_data = lisp_free});
refcount_default_context = ctx;
REGISTER_SYMBOL_NOINTERN(unbound);
REGISTER_SYMBOL_NOINTERN(nil);
REGISTER_SYMBOL_NOINTERN(t);
package_table = make_lisp_hashtable(Qstrings_equal, Qhash_string);
LispVal *sys_package_name = STATIC_STRING("sys");
system_package = make_lisp_package(sys_package_name);
refcount_unref(Fregister_package(system_package));
refcount_unref(sys_package_name);
LispVal *kw_package_name = STATIC_STRING("kw");
keyword_package = make_lisp_package(kw_package_name);
refcount_unref(Fregister_package(keyword_package));
refcount_unref(kw_package_name);
current_package = refcount_ref(system_package);
register_symbols_and_functions();
}
void lisp_shutdown(void) {
garbage_collect();
refcount_unref(current_package);
refcount_unref(system_package);
refcount_unref(package_table);
refcount_context_destroy(refcount_default_context);
refcount_default_context = NULL;
}
// ###############################
// # General and Misc. Functions #
// ###############################
DEFUN(exit, "exit", (LispVal * code)) {
if (!NILP(code) && !INTEGERP(code)) {
Fthrow(Qtype_error, Qnil);
}
Fthrow(Qshutdown_signal, const_list(true, 1, code));
}
DEFUN(id, "id", (LispVal * obj)) {
return make_lisp_integer((int64_t) obj);
}
DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2)) {
return LISP_BOOL(obj1 == obj2);
}
static void breakpoint(int64_t id) {}
DEFUN(breakpoint, "breakpoint", (LispVal * id)) {
if (NILP(id)) {
breakpoint(0);
} else {
CHECK_TYPE(TYPE_INTEGER, id);
breakpoint(((LispInteger *) id)->value);
}
return Qnil;
}
DEFUN(not, "not", (LispVal * obj)) {
return NILP(obj) ? Qt : Qnil;
}
DEFUN(type_of, "type-of", (LispVal * obj)) {
if (obj->type < 0 || obj->type >= N_LISP_TYPES) {
return Qnil;
}
LispVal *name =
make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
LISP_TYPE_NAMES[obj->type].len, true, true);
LispVal *sym = Fintern(name, system_package, Qnil);
refcount_unref(name);
return sym;
}
DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val)) {
return LISP_BOOL(USER_POINTER_P(val));
}
DEFUN(print, "print", (LispVal * obj)) {
debug_dump(stdout, obj, false);
return Qnil;
}
DEFUN(println, "println", (LispVal * obj)) {
debug_dump(stdout, obj, true);
return Qnil;
}
// ##################################
// # Evaluation and Macro Expansion #
// ##################################
static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *final_args = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &unref_double_ptr, &final_args);
LispVal *end = Qnil;
FOREACH(elt, args) {
if (NILP(final_args)) {
final_args = Fpair(Feval_in_env(elt, lexenv), Qnil);
refcount_unref(HEAD(final_args));
end = final_args;
} else {
LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil);
refcount_unref(HEAD(new_end));
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
}
cancel_cleanup(cl_handle);
});
return final_args;
}
static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
LispVal *args, size_t *nargs) {
size_t raw_count =
(func->n_req + func->n_opt + ((LispHashtable *) func->kwargs)->count
+ !NILP(func->rest_arg));
*nargs = raw_count;
LispVal **vec = lisp_malloc0(sizeof(LispVal *) * raw_count);
LispVal *rest = Qnil;
LispVal *rest_end = Qnil;
size_t have_count = 0;
LispVal *opt_desc;
LispVal *arg = Qnil; // last arg processed
while (!NILP(args)) {
arg = HEAD(args);
if (have_count < func->n_req + func->n_opt) {
vec[have_count++] = refcount_ref(arg);
} else if (KEYWORDP(arg)
&& !NILP(opt_desc = HEAD(gethash(func->kwargs, arg, Qnil)))
&& NILP(rest)) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, opt_desc);
if (vec[oad->index]) {
goto multikey;
}
args = TAIL(args);
if (NILP(args)) {
goto key_no_val;
}
vec[oad->index] = refcount_ref(HEAD(arg));
} else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
goto unknown_key;
} else if (NILP(func->rest_arg)) {
goto too_many;
} else if (NILP(rest)) {
rest = Fpair(arg, Qnil);
rest_end = rest;
} else {
LispVal *new_end = Fpair(arg, Qnil);
Fsettail(rest_end, new_end);
refcount_unref(new_end);
rest_end = new_end;
}
args = TAIL(args);
}
if (have_count < func->n_req) {
goto too_few;
}
if (!NILP(func->rest_arg)) {
vec[raw_count - 1] = rest;
}
for (size_t i = 0; i < raw_count; ++i) {
if (!vec[i]) {
vec[i] = func->distinguish_unpassed ? Qunbound : Qnil;
}
}
return vec;
// TODO different messages
key_no_val:
too_many:
multikey:
unknown_key:
too_few:
refcount_unref(rest);
for (size_t i = 0; i < raw_count; ++i) {
refcount_unref(vec[i]);
}
lisp_free(vec);
Fthrow(Qargument_error, Fpair(fname, Qnil));
return NULL;
}
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args,
LispVal *args_lexenv) {
// builtin macros inherit their parents lexenv
if (func->is_macro) {
the_stack->lexenv = refcount_ref(args_lexenv);
}
size_t nargs;
LispVal **arg_vec = process_builtin_args(name, func, args, &nargs);
struct UnrefListData cleanup_data = {.vals = arg_vec, .len = nargs};
void *cl = register_cleanup(&unref_free_list_double_ptr, &cleanup_data);
LispVal *retval;
switch (nargs) {
case 0:
retval = ((LispVal * (*) (void) ) func->builtin)();
break;
case 1:
retval = ((LispVal * (*) (LispVal *) ) func->builtin)(arg_vec[0]);
break;
case 2:
retval = ((LispVal * (*) (LispVal *, LispVal *) )
func->builtin)(arg_vec[0], arg_vec[1]);
break;
case 3:
retval = ((LispVal * (*) (LispVal *, LispVal *, LispVal *) )
func->builtin)(arg_vec[0], arg_vec[1], arg_vec[2]);
break;
case 4:
retval =
((LispVal * (*) (LispVal *, LispVal *, LispVal *, LispVal *) )
func->builtin)(arg_vec[0], arg_vec[1], arg_vec[2], arg_vec[3]);
break;
case 5:
retval =
((LispVal
* (*) (LispVal *, LispVal *, LispVal *, LispVal *, LispVal *) )
func->builtin)(arg_vec[0], arg_vec[1], arg_vec[2], arg_vec[3],
arg_vec[4]);
break;
case 6:
retval = ((LispVal
* (*) (LispVal *, LispVal *, LispVal *, LispVal *, LispVal *,
LispVal *) ) func->builtin)(arg_vec[0], arg_vec[1],
arg_vec[2], arg_vec[3],
arg_vec[4], arg_vec[5]);
break;
default:
fprintf(stderr,
"Builtin functions cannot have more than 6 arguments!\n");
abort();
}
cancel_cleanup(cl);
refcount_ref(retval);
unref_free_list_double_ptr(&cleanup_data);
return retval;
}
static void process_lisp_args(LispVal *fname, LispFunction *func, LispVal *args,
LispVal **lexenv) {
LispVal *added_kwds = make_lisp_hashtable(Qnil, Qnil);
void *cl_handle = register_cleanup(&refcount_unref_as_callback, added_kwds);
enum { REQ, OPT, KEY, REST } mode = REQ;
LispVal *rargs = func->rargs;
LispVal *oargs = func->oargs;
while (!NILP(args)) {
LispVal *arg = HEAD(args);
switch (mode) {
case REQ: {
if (NILP(rargs)) {
mode = OPT;
continue; // skip increment
}
push_to_lexenv(lexenv, HEAD(rargs), arg);
rargs = TAIL(rargs);
} break;
case OPT: {
if (NILP(oargs)) {
mode = KEY;
continue; // skip increment
}
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, HEAD(oargs));
push_to_lexenv(lexenv, oad->name, arg);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qt);
}
oargs = TAIL(oargs);
} break;
case KEY:
if (!KEYWORDP(arg)) {
mode = REST;
continue; // skip increment
}
LispVal *desc_lv = gethash(func->kwargs, arg, Qnil);
if (NILP(desc_lv)) {
if (!func->allow_other_keys) {
goto unknown_key;
}
mode = REST;
continue; // skip increment
}
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, desc_lv);
args = TAIL(args);
if (NILP(args)) {
goto missing_value;
}
LispVal *value = HEAD(args);
puthash(added_kwds, oad->name, Qt);
push_to_lexenv(lexenv, oad->name, value);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qt);
}
break;
case REST:
if (NILP(func->rest_arg)) {
if (KEYWORDP(arg)) {
args = TAIL(args);
if (NILP(args)) {
goto missing_value;
}
args = TAIL(args);
continue; // skip increment
} else {
goto too_many_args;
}
}
push_to_lexenv(lexenv, func->rest_arg, args);
// done processing
goto done_adding;
}
args = TAIL(args);
}
if (!NILP(rargs)) {
goto missing_required;
}
HT_FOREACH_VALID_INDEX(func->kwargs, i) {
struct OptArgDesc *oad =
USERPTR(struct OptArgDesc, HASH_VALUE(func->kwargs, i));
// only check the current function's lexenv and not its parents'
if (NILP(gethash(added_kwds, oad->name, Qnil))) {
LispVal *eval_res = Feval(oad->default_form);
push_to_lexenv(lexenv, oad->name, eval_res);
refcount_unref(eval_res);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qnil);
}
}
}
FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
LispVal *default_val = Feval(oad->default_form);
push_to_lexenv(lexenv, oad->name, default_val);
refcount_unref(default_val);
if (!NILP(oad->pred_var)) {
push_to_lexenv(lexenv, oad->pred_var, Qnil);
}
}
if (!NILP(func->rest_arg)) {
push_to_lexenv(lexenv, func->rest_arg, Qnil);
}
done_adding:
cancel_cleanup(cl_handle);
refcount_unref(added_kwds);
return;
// TODO different messages
missing_required:
too_many_args:
missing_value:
unknown_key:
cancel_cleanup(cl_handle);
refcount_unref(added_kwds);
Fthrow(Qargument_error, Fpair(fname, Qnil));
}
static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
LispVal *args, LispVal *args_lexenv) {
the_stack->lexenv = refcount_ref(func->lexenv);
process_lisp_args(name, func, args, &the_stack->lexenv);
if (func->is_macro) {
if (!the_stack->next) {
abort();
}
LispVal *expansion = Fprogn(func->body);
LispVal *retval = Qnil;
// disable internal handlers
the_stack->enable_handlers = false;
WITH_CLEANUP(expansion, {
// eval in the outer lexenv
retval = Feval_in_env(expansion, args_lexenv);
});
the_stack->enable_handlers = true; // just in case
return retval;
} else {
return Fprogn(func->body);
}
}
STATIC_DEFUN(set_for_return, "set-for-return",
(LispVal * entry, LispVal *dest)) {
LispVal *retval = HEAD(TAIL(HEAD(entry)));
Fsethead(dest, retval);
return Qnil;
}
static inline void setup_return_handler(LispVal *tag, LispVal *dest) {
LispVal *err_var = INTERN_STATIC("e", system_package);
LispVal *quoted_dest = const_list(false, 2, Qquote, dest);
LispVal *handler =
const_list(true, 4, err_var, Qset_for_return, err_var, quoted_dest);
refcount_unref(quoted_dest);
puthash(the_stack->handlers, tag, handler);
refcount_unref(handler);
}
static LispVal *call_function(LispVal *func, LispVal *args,
LispVal *args_lexenv, bool eval_args,
bool allow_macro) {
LispFunction *fobj = (LispFunction *) Qnil;
if (FUNCTIONP(func)) {
fobj = (LispFunction *) refcount_ref(func);
} else if (SYMBOLP(func)) {
fobj = (LispFunction *) Fsymbol_function(func, Qt);
} else if (PAIRP(func) && HEAD(func) == Qlambda) {
fobj = (LispFunction *) Feval_in_env(func, args_lexenv);
assert(FUNCTIONP(fobj));
} else {
Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
}
void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj);
if (NILP(fobj)) {
Fthrow(Qvoid_function_error, const_list(true, 1, func));
} else if (!FUNCTIONP(fobj)) {
Fthrow(Qinvalid_function_error, Fpair(LISPVAL(fobj), Qnil));
} else if (!allow_macro && fobj->is_macro) {
Fthrow(Qtype_error, Qnil);
}
if (!fobj->is_macro && eval_args) {
args = eval_function_args(args, args_lexenv);
}
LispVal *retval = Qnil;
LispVal *return_ptr = Fpair(Qnil, Qnil);
void *return_cl_handle =
register_cleanup(refcount_unref_as_callback, return_ptr);
refcount_ref(args);
WITH_CLEANUP(args, {
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
refcount_ref(fobj->name), refcount_ref(args),
false, // make sure the lexenv is nil
{
the_stack->hidden = false;
if (!NILP(fobj->return_tag)) {
the_stack->return_tag = refcount_ref(fobj->return_tag);
setup_return_handler(fobj->return_tag, return_ptr);
}
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args, args_lexenv);
} else {
retval = call_lisp_function(func, fobj, args, args_lexenv);
}
},
{
retval = refcount_ref(HEAD(return_ptr)); //
});
});
cancel_cleanup(return_cl_handle);
refcount_unref(return_ptr);
cancel_cleanup(cl_handle);
refcount_unref(fobj);
return retval;
}
static inline LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
return Fplist_get(lexenv, key, Qunbound, Qnil);
}
static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
if (!NILP(lexenv)) {
LispVal *local = find_in_lexenv(lexenv, key);
if (local != Qunbound) {
return local;
}
}
LispVal *sym_val = Fsymbol_value(key);
if (sym_val != Qunbound) {
return sym_val;
}
Fthrow(Qvoid_variable_error, const_list(true, 1, key));
}
DEFUN(eval_in_env, "eval-in-env", (LispVal * form, LispVal *lexenv)) {
switch (TYPEOF(form)) {
case TYPE_STRING:
case TYPE_FUNCTION:
case TYPE_INTEGER:
case TYPE_FLOAT:
case TYPE_HASHTABLE:
case TYPE_USER_POINTER:
case TYPE_PACKAGE:
// the above all are self-evaluating
return refcount_ref(form);
case TYPE_SYMBOL:
if (KEYWORDP(form)) {
return refcount_ref(form);
} else {
// this refs its return value
return symbol_value_in_lexenv(lexenv, form);
}
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) form;
LispVal **elts = lisp_malloc0(sizeof(LispVal *) * vec->length);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
struct UnrefListData uld;
uld.vals = elts;
uld.len = vec->length;
void *cl_handler =
register_cleanup(&unref_free_list_double_ptr, &uld);
for (size_t i = 0; i < vec->length; ++i) {
elts[i] = Feval_in_env(vec->data[i], lexenv);
}
cancel_cleanup(cl_handler);
});
// does not ref its arguments
return make_lisp_vector(elts, vec->length);
}
case TYPE_PAIR: {
LispPair *pair = (LispPair *) form;
return call_function(pair->head, pair->tail, lexenv, true, true);
}
default:
abort();
}
}
DEFUN(eval, "eval", (LispVal * form)) {
return Feval_in_env(form, LISPVAL(the_stack->lexenv));
}
DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) {
return call_function(function, rest, Qnil, false, false);
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
LispVal *args = Qnil;
LispVal *end = Qnil;
while (!NILP(rest) && !NILP(((LispPair *) rest)->tail)) {
if (NILP(args)) {
args = Fpair(((LispPair *) rest)->head, Qnil);
end = args;
} else {
LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
rest = ((LispPair *) rest)->tail;
}
if (LISTP(HEAD(rest))) {
// ensure the list is not circular
refcount_ref(args);
WITH_CLEANUP(args, {
list_length(Fhead(rest)); //
});
if (NILP(args)) {
args = HEAD(rest);
} else {
Fsettail(end, HEAD(rest));
}
} else {
if (NILP(args)) {
args = Fpair(((LispPair *) rest)->head, Qnil);
end = args;
} else {
LispVal *new_end = Fpair(((LispPair *) rest)->head, Qnil);
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
}
LispVal *retval;
WITH_CLEANUP_DOUBLE_PTR(args, {
retval = Ffuncall(function, args); //
});
return retval;
}
static LispVal *lookup_lexical_macro(LispVal *name, LispVal *lexical_macros) {
if (!SYMBOLP(name)) {
return Qunbound;
}
LispVal *res = Fplist_get(lexical_macros, name, Qunbound, Qnil);
if (FUNCTIONP(res)) {
return res;
}
refcount_unref(res);
return Qunbound;
}
static inline LispVal *expand_function_as_macro(LispFunction *fobj,
LispVal *args) {
return Ffuncall((LispVal *) fobj, args);
}
DEFUN(macroexpand_1, "macroexpand-1",
(LispVal * form, LispVal *lexical_macros)) {
if (PAIRP(form)) {
LispVal *lex_res = lookup_lexical_macro(HEAD(form), lexical_macros);
LispFunction *fobj = (LispFunction *) Qunbound;
if (lex_res != Qunbound) {
return expand_function_as_macro((LispFunction *) lex_res,
TAIL(form));
} else if (FUNCTIONP(HEAD(form))) {
fobj = refcount_ref(HEAD(form));
} else {
fobj = (LispFunction *) Fsymbol_function(HEAD(form), Qt);
}
if (!FUNCTIONP(fobj) || fobj->is_builtin || !fobj->is_macro) {
refcount_unref(fobj);
return refcount_ref(form);
}
LispVal *expansion = Qnil;
LispVal *return_ptr = Fpair(Qnil, Qnil);
WITH_CLEANUP(return_ptr, {
WITH_CLEANUP(fobj, {
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
refcount_ref(HEAD(form)), refcount_ref(TAIL(form)), false,
{
the_stack->hidden = false;
if (!NILP(fobj->return_tag)) {
the_stack->return_tag =
refcount_ref(fobj->return_tag);
setup_return_handler(fobj->return_tag, return_ptr);
}
the_stack->lexenv = refcount_ref(fobj->lexenv);
process_lisp_args(Fhead(form), fobj, Ftail(form),
&the_stack->lexenv);
expansion = Fprogn(fobj->body);
},
{
expansion = refcount_ref(HEAD(return_ptr)); //
});
});
});
return expansion;
} else {
return refcount_ref(form);
}
}
DEFUN(macroexpand_toplevel, "macroexpand-toplevel",
(LispVal * form, LispVal *lexical_macros)) {
if (PAIRP(form)) {
LispVal *out = refcount_ref(form);
void *cl_handler = register_cleanup(&unref_double_ptr, &out);
while (PAIRP(out) && !NILP(Fmacrop(HEAD(out), lexical_macros))) {
LispVal *new_out = Fmacroexpand_1(out, lexical_macros);
refcount_unref(out);
out = new_out;
}
cancel_cleanup(cl_handler);
return out;
} else {
return refcount_ref(form);
}
}
static LispVal *filter_body_form(LispVal *form,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data);
#define EXPAND_HEAD(form) \
{ \
LispVal *expansion = filter_body_form(HEAD(form), func, user_data); \
WITH_CLEANUP(expansion, { Fsethead(form, expansion); }); \
}
static void expand_lambda_list(LispVal *list,
LispVal *(*func)(LispVal *body, void *user_data),
void *user_data) {
bool enable_extended = false;
FOREACH_TAIL(entry, list) {
if (enable_extended && PAIRP(HEAD(entry))) {
LispVal *copy = Fcopy_list(HEAD(entry));
Fsethead(entry, copy);
refcount_unref(copy);
if (PAIRP(TAIL(copy))) {
EXPAND_HEAD(TAIL(copy));
}
} else if (HEAD(entry) == Qrest) {
enable_extended = false;
} else if (HEAD(entry) == Qopt || HEAD(entry) == Qkey) {
enable_extended = true;
}
}
}
STATIC_DEFMACRO(internal_real_return, "internal-real-return",
(LispVal * name, LispVal *tag, LispVal *value)) {
for (StackFrame *cur = the_stack; cur; cur = cur->next) {
if (!NILP(cur->return_tag) && cur->enable_handlers
&& cur->return_tag == tag) {
Fthrow(cur->return_tag, const_list(false, 1, Feval(value)));
}
}
Fthrow(Qreturn_frame_error,
const_list(false, 2, refcount_ref(name), Feval(value)));
}
static void expand_builtin_macro(LispFunction *fobj, LispVal *args,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
if (fobj->builtin == (lisp_function_ptr_t) Fquote) {
return; // do nothing
} else if (fobj->builtin == (lisp_function_ptr_t) Fsetq) {
bool is_var = true;
FOREACH_TAIL(form, args) {
if (!is_var) {
EXPAND_HEAD(form);
}
is_var = !is_var;
}
} else if (fobj->builtin == (lisp_function_ptr_t) Freturn_from) {
if (PAIRP(args) && PAIRP(TAIL(args))) {
EXPAND_HEAD(TAIL(args));
}
} else if (fobj->builtin == (lisp_function_ptr_t) Finternal_real_return) {
if (PAIRP(args) && PAIRP(TAIL(args)) && PAIRP(TAIL(TAIL(args)))) {
EXPAND_HEAD(TAIL(TAIL(args)));
}
} else if (fobj->builtin == (lisp_function_ptr_t) Fcondition_case) {
if (PAIRP(args)) {
EXPAND_HEAD(args);
FOREACH_TAIL(entry_tail, TAIL(args)) {
LispVal *copy = Fcopy_list(HEAD(entry_tail));
Fsethead(entry_tail, copy);
refcount_unref(copy);
if (PAIRP(HEAD(entry_tail))) {
FOREACH_TAIL(form, TAIL(HEAD(entry_tail))) {
EXPAND_HEAD(form);
}
}
}
}
} else if (fobj->builtin == (lisp_function_ptr_t) Fdefmacro
|| fobj->builtin == (lisp_function_ptr_t) Fdefun
|| fobj->builtin == (lisp_function_ptr_t) Flambda) {
if (!LISTP(args)) {
return;
}
LispVal *expand_from = TAIL(args); // skip lambda list
if (!LISTP(expand_from)) {
return;
}
LispVal *lambda_list;
if (fobj->builtin != (lisp_function_ptr_t) Flambda) {
LispVal *copy = Fcopy_list(HEAD(expand_from));
Fsethead(expand_from, copy);
refcount_unref(copy);
lambda_list = HEAD(expand_from);
expand_from = TAIL(expand_from); // skip the name
if (!LISTP(expand_from)) {
return;
}
} else {
LispVal *copy = Fcopy_list(HEAD(args));
Fsethead(args, copy);
refcount_unref(copy);
lambda_list = HEAD(args);
}
expand_lambda_list(lambda_list, func, user_data);
LispVal *first_form = HEAD(expand_from);
if (PAIRP(first_form) && HEAD(first_form) == Qdeclare) {
expand_from = TAIL(expand_from); // declare statement
if (!LISTP(expand_from)) {
return;
}
}
FOREACH_TAIL(form, expand_from) {
EXPAND_HEAD(form);
}
} else {
FOREACH_TAIL(form, args) {
EXPAND_HEAD(form);
}
}
}
#undef EXPAND_HEAD
// func should ref its return value
static LispVal *filter_body_form(LispVal *form,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
LispVal *toplevel_orig = func(form, user_data);
if (PAIRP(toplevel_orig)) {
LispVal *toplevel;
WITH_CLEANUP(toplevel_orig, {
toplevel = Fcopy_list(toplevel_orig); //
});
WITH_PUSH_FRAME(Qnil, Qnil, true, {
void *cl_handler = register_cleanup(&unref_double_ptr, &toplevel);
if (PAIRP(toplevel)) {
LispFunction *fobj = NULL;
if (FUNCTIONP(HEAD(toplevel))) {
fobj = refcount_ref(HEAD(toplevel));
} else if (SYMBOLP(HEAD(toplevel))) {
fobj =
(LispFunction *) Fsymbol_function(HEAD(toplevel), Qt);
}
if (fobj && FUNCTIONP(fobj)) {
WITH_CLEANUP(fobj, {
if (fobj->is_builtin && fobj->is_macro) {
expand_builtin_macro(fobj, TAIL(toplevel), func,
user_data);
} else {
FOREACH_TAIL(tail, TAIL(toplevel)) {
Fsethead(tail,
filter_body_form(HEAD(tail), func,
user_data));
}
}
});
}
}
cancel_cleanup(cl_handler);
});
return toplevel;
} else {
return toplevel_orig;
}
return Qnil;
}
static LispVal *filter_body_tree(LispVal *body,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
LispVal *start = Qnil;
LispVal *end = Qnil;
FOREACH(form, body) {
LispVal *filtered = filter_body_form(form, func, user_data);
if (NILP(start)) {
start = Fpair(filtered, Qnil);
end = start;
} else {
LispVal *new_end = Fpair(filtered, Qnil);
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
refcount_unref(filtered);
}
return start;
}
static LispVal *macroexpand_toplevel_as_callback(LispVal *form,
void *lexical_macros) {
return Fmacroexpand_toplevel(form, lexical_macros);
}
DEFUN(macroexpand_all, "macroexpand-all",
(LispVal * form, LispVal *lexical_macros)) {
return filter_body_form(form, macroexpand_toplevel_as_callback,
lexical_macros);
}
// #################
// # Special Forms #
// #################
DEFMACRO(quote, "'", (LispVal * form)) {
return refcount_ref(form);
}
DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) {
LispVal *res = Feval(cond);
LispVal *retval = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
if (!NILP(res)) {
retval = Feval(t);
} else {
retval = Fprogn(nil);
}
});
return retval;
}
static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
LispVal *lexenv) {
LispVal *lexval = Fplist_assoc(lexenv, key, Qnil);
if (PAIRP(lexval)) {
Fsethead(TAIL(lexval), newval);
} else {
refcount_ref(newval);
refcount_unref(((LispSymbol *) key)->value);
((LispSymbol *) key)->value = newval;
}
}
DEFMACRO(setq, "setq", (LispVal * args)) {
size_t len = list_length(args);
if (!len || len % 2) {
Fthrow(Qargument_error, Fpair(Qsetq, Qnil));
}
LispVal *retval = Qnil;
FOREACH_TAIL(tail, args) {
CHECK_TYPE(TYPE_SYMBOL, HEAD(tail));
LispVal *name = HEAD(tail);
tail = TAIL(tail);
retval = Feval(HEAD(tail));
set_symbol_in_lexenv(name, retval, the_stack->lexenv);
}
return retval;
}
DEFMACRO(progn, "progn", (LispVal * forms)) {
LispVal *retval = Qnil;
FOREACH(form, forms) {
refcount_unref(retval);
retval = Feval(form);
}
return retval;
}
DEFMACRO(condition_case, "condition-case", (LispVal * form, LispVal *rest)) {
bool success = false;
LispVal *success_form = Qunbound;
LispVal *finally_form = Qunbound;
LispVal *retval = Qnil;
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
Qnil, Qnil, true,
{
void *cl_handler =
register_cleanup(&unref_double_ptr, &success_form);
void *cl_handler2 =
register_cleanup(&unref_double_ptr, &finally_form);
FOREACH(entry, rest) {
if (HEAD(entry) == Qkw_success) {
if (success_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
success_form = Fpair(Qprogn, TAIL(entry));
} else if (HEAD(entry) == Qkw_finally) {
if (finally_form != Qunbound) {
Fthrow(Qmalformed_lambda_list_error, Qnil);
}
finally_form = Fpair(Qprogn, TAIL(entry));
} else {
LispVal *var = HEAD(HEAD(entry));
LispVal *types = HEAD(TAIL(HEAD(entry)));
if (!PAIRP(types)) {
types = const_list(true, 1, types);
} else {
types = refcount_ref(types);
}
WITH_CLEANUP(types, {
IGNORE(); // unconfuse clang-format
FOREACH(type, types) {
LispVal *handler =
push_many(TAIL(entry), 2, Qprogn, var);
puthash(the_stack->handlers, type, handler);
refcount_unref(handler);
}
});
}
}
cancel_cleanup(cl_handler2);
if (finally_form != Qunbound) {
the_stack->unwind_form = finally_form;
}
retval = Feval(form);
cancel_cleanup(cl_handler);
success = true;
},
{ retval = refcount_ref(stack_return); });
// call this out here so it is not covered by the handlers
if (success && success_form != Qunbound) {
void *cl_handler =
register_cleanup(&refcount_unref_as_callback, retval);
WITH_CLEANUP(success_form, { refcount_unref(Feval(success_form)); });
cancel_cleanup(cl_handler);
}
return retval;
}
// true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr) {
if (PAIRP(form) && HEAD(form) == Qdeclare) {
FOREACH(elt, TAIL(form)) {
if (name_ptr && PAIRP(elt) && HEAD(elt) == Qname
&& PAIRP(TAIL(elt))) {
*name_ptr = HEAD(TAIL(elt));
}
}
return true;
}
return false;
}
struct NameAndReturnTag {
LispVal *name;
LispVal *return_tag;
};
static LispVal *expand_function_body_callback(LispVal *body, void *data) {
struct NameAndReturnTag *name_and_return_tag = data;
LispVal *expansion = Fmacroexpand_toplevel(body, Qnil);
// this mess checks that the call is exactly one of
// - (return-from 'symbol)
// - (return-from 'symbol val)
if (PAIRP(expansion) && HEAD(expansion) == Qreturn_from
&& PAIRP(TAIL(expansion)) && LISTP(TAIL(TAIL(expansion)))
&& NILP(TAIL(TAIL(TAIL(expansion)))) && SYMBOLP(HEAD(TAIL(expansion)))
&& HEAD(TAIL(expansion)) == name_and_return_tag->name) {
LispVal *retval = Qnil;
if (!NILP(TAIL(TAIL(expansion)))) {
retval = refcount_ref(HEAD(TAIL(TAIL(expansion))));
}
refcount_unref(expansion);
return const_list(false, 4, Qinternal_real_return,
refcount_ref(name_and_return_tag->name),
refcount_ref(name_and_return_tag->return_tag),
retval);
} else if (PAIRP(expansion) && HEAD(expansion) == Qinternal_real_return
&& list_length(expansion) == 4
&& HEAD(TAIL(expansion)) == name_and_return_tag->name
&& HEAD(TAIL(TAIL(expansion)))
!= name_and_return_tag->return_tag) {
Fsethead(TAIL(TAIL(expansion)), name_and_return_tag->return_tag);
}
return expansion;
}
static inline LispVal *expand_function_body(LispVal *name, LispVal *return_tag,
LispVal *body) {
return filter_body_tree(
body, expand_function_body_callback,
&(struct NameAndReturnTag) {.name = name, .return_tag = return_tag});
}
static LispVal *macroexpand_all_as_callback(LispVal *form, void *ignored) {
return Fmacroexpand_all(form, Qnil);
}
static inline void expand_lambda_list_for_toplevel(LispVal *list) {
expand_lambda_list(list, macroexpand_all_as_callback, NULL);
}
DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
CHECK_TYPE(TYPE_SYMBOL, name);
if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *return_tag =
make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
LispVal *func = Qnil;
WITH_CLEANUP(return_tag, {
LispVal *exp_args = Fcopy_list(args);
WITH_CLEANUP(exp_args, {
expand_lambda_list_for_toplevel(exp_args);
LispVal *expanded_body =
expand_function_body(name, return_tag, body);
WITH_CLEANUP(expanded_body, {
func =
make_lisp_function(name, return_tag, exp_args,
the_stack->lexenv, expanded_body, false);
});
});
});
refcount_unref(Ffset(name, func));
return func;
}
DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
CHECK_TYPE(TYPE_SYMBOL, name);
if (parse_function_declare(HEAD(body), NULL)) {
body = TAIL(body);
}
LispVal *return_tag =
make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
LispVal *func = Qnil;
WITH_CLEANUP(return_tag, {
LispVal *exp_args = Fcopy_list(args);
WITH_CLEANUP(exp_args, {
expand_lambda_list_for_toplevel(exp_args);
LispVal *expanded_body =
expand_function_body(name, return_tag, body);
WITH_CLEANUP(expanded_body, {
func =
make_lisp_function(name, return_tag, exp_args,
the_stack->lexenv, expanded_body, true);
});
});
});
refcount_unref(Ffset(name, func));
return func;
}
DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
LispVal *name = Qunbound;
if (parse_function_declare(HEAD(body), &name)) {
body = TAIL(body);
}
LispVal *return_tag;
LispVal *tag_name;
if (name == Qunbound) {
name = Qlambda;
tag_name = Qnil;
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) Qnil)->name));
} else {
CHECK_TYPE(TYPE_SYMBOL, name);
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
tag_name = name;
}
LispVal *func = Qnil;
WITH_CLEANUP(return_tag, {
LispVal *expanded_body =
expand_function_body(tag_name, return_tag, body);
LispVal *exp_args = Fcopy_list(args);
WITH_CLEANUP(exp_args, {
expand_lambda_list_for_toplevel(exp_args);
WITH_CLEANUP(expanded_body, {
func =
make_lisp_function(name, return_tag, args,
the_stack->lexenv, expanded_body, false);
});
});
});
return func;
}
DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) {
LispVal *evaled_cond;
while (!NILP(evaled_cond = Feval(cond))) {
refcount_unref(evaled_cond);
refcount_unref(Fprogn(body));
}
return Qnil;
}
DEFMACRO(and, "and", (LispVal * rest)) {
LispVal *retval = Qnil;
FOREACH(cond, rest) {
LispVal *nc;
WITH_CLEANUP(retval, {
nc = Feval(cond); //
});
if (NILP(nc)) {
return Qnil;
}
retval = nc;
}
return retval;
}
DEFMACRO(or, "or", (LispVal * rest)) {
FOREACH(cond, rest) {
LispVal *nc = Feval(cond);
if (!NILP(nc)) {
return nc;
}
}
return Qnil;
}
DEFMACRO(in_package, "in-package", (LispVal * package)) {
return Fset_current_package(package);
}
DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) {
Fthrow(Qreturn_frame_error,
const_list(false, 2, refcount_ref(name), Feval(value)));
}
// ######################
// # Function Functions #
// ######################
DEFUN(functionp, "functionp", (LispVal * val)) {
if (FUNCTIONP(val) && !((LispFunction *) val)->is_macro) {
return Qt;
} else if (SYMBOLP(val)) {
LispVal *res = Fsymbol_function(val, Qt);
LispVal *retval =
LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_macro);
refcount_unref(res);
return retval;
}
return Qnil;
}
DEFUN(macrop, "macrop", (LispVal * val, LispVal *lexical_macros)) {
if (FUNCTIONP(val) && !((LispFunction *) val)->is_builtin
&& ((LispFunction *) val)->is_macro) {
return Qt;
} else if (SYMBOLP(val)) {
if (lookup_lexical_macro(val, lexical_macros) != Qunbound) {
return Qt;
}
LispVal *res = Fsymbol_function(val, Qt);
LispVal *retval =
LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_builtin
&& ((LispFunction *) res)->is_macro);
refcount_unref(res);
return retval;
}
return Qnil;
}
DEFUN(builtinp, "builtinp", (LispVal * val)) {
if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
&& !((LispFunction *) val)->is_macro) {
return Qt;
} else if (SYMBOLP(val)) {
LispVal *res = Fsymbol_function(val, Qt);
LispVal *retval =
LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
&& !((LispFunction *) res)->is_macro);
refcount_unref(res);
return retval;
}
return Qnil;
}
DEFUN(special_form_p, "special-form-p", (LispVal * val)) {
if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
&& ((LispFunction *) val)->is_macro) {
return Qt;
} else if (SYMBOLP(val)) {
LispVal *res = Fsymbol_function(val, Qt);
LispVal *retval =
LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
&& ((LispFunction *) res)->is_macro);
refcount_unref(res);
return retval;
}
return Qnil;
}
DEFUN(function_docstr, "function-docstr", (LispVal * func)) {
if (FUNCTIONP(func)) {
return ((LispFunction *) func)->doc;
}
LispFunction *fobj = (LispFunction *) Fsymbol_function(func, Qt);
CHECK_TYPE(TYPE_FUNCTION, fobj);
LispVal *retval = refcount_ref(fobj->doc);
refcount_unref(fobj);
return retval;
}
void free_opt_arg_desc(void *obj) {
struct OptArgDesc *oad = obj;
refcount_unref(oad->name);
refcount_unref(oad->default_form);
refcount_unref(oad->pred_var);
lisp_free(oad);
}
void set_function_args(LispFunction *func, LispVal *args) {
refcount_unref(func->args);
refcount_unref(func->kwargs);
refcount_unref(func->rargs);
refcount_unref(func->oargs);
refcount_unref(func->rest_arg);
LispVal *found_args = make_lisp_hashtable(Qnil, Qnil);
enum {
REQ,
OPT,
KEY,
REST,
MUST_CHANGE,
} mode = REQ;
bool has_opt = false;
bool has_key = false;
bool has_rest = false;
func->n_req = 0;
func->rargs = Qnil;
func->n_opt = 0;
func->oargs = Qnil;
func->rest_arg = Qnil;
func->kwargs = make_lisp_hashtable(Qnil, Qnil);
func->allow_other_keys = false;
LispVal *rargs_end = Qnil;
LispVal *oargs_end = Qnil;
FOREACH(arg, args) {
if (arg == Qopt) {
if (has_opt || mode == REST) {
goto malformed;
}
has_opt = true;
mode = OPT;
} else if (arg == Qkey) {
if (has_key || mode == REST) {
goto malformed;
}
has_key = true;
mode = KEY;
} else if (arg == Qrest) {
if (has_rest) {
goto malformed;
}
has_rest = true;
mode = REST;
} else if (arg == Qallow_other_keys) {
if (func->allow_other_keys || mode != KEY) {
goto malformed;
}
func->allow_other_keys = true;
mode = MUST_CHANGE;
} else {
switch (mode) {
case REQ:
if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)
|| !NILP(gethash(found_args, arg, Qnil))) {
goto malformed;
}
if (NILP(func->rargs)) {
func->rargs = Fpair(arg, Qnil);
rargs_end = func->rargs;
} else {
LispVal *new_end = Fpair(arg, Qnil);
Fsettail(rargs_end, new_end);
refcount_unref(new_end);
rargs_end = new_end;
}
puthash(found_args, arg, Qt);
++func->n_req;
break;
case OPT: {
LispVal *desc =
ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc);
USERPTR(struct OptArgDesc, desc)->index = 0;
if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc),
found_args)) {
refcount_unref(desc);
goto malformed;
}
if (NILP(func->oargs)) {
func->oargs = Fpair(desc, Qnil);
oargs_end = func->oargs;
} else {
LispVal *new_end = Fpair(desc, Qnil);
Fsettail(oargs_end, new_end);
refcount_unref(new_end);
oargs_end = new_end;
}
refcount_unref(desc);
puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt);
if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) {
puthash(found_args,
USERPTR(struct OptArgDesc, desc)->pred_var, Qt);
}
++func->n_opt;
} break;
case KEY: {
LispVal *desc =
ALLOC_USERPTR(struct OptArgDesc, free_opt_arg_desc);
if (!parse_opt_arg_entry(arg, USERPTR(struct OptArgDesc, desc),
found_args)) {
refcount_unref(desc);
goto malformed;
}
USERPTR(struct OptArgDesc, desc)->index =
((LispHashtable *) func->kwargs)->count;
LispString *sn =
((LispSymbol *) USERPTR(struct OptArgDesc, desc)->name)
->name;
char kns[sn->length + 2];
kns[0] = ':';
memcpy(kns + 1, sn->data, sn->length);
kns[sn->length + 1] = '\0';
LispVal *kn =
make_lisp_string(kns, sn->length + 1, false, false);
LispVal *keyword = Fintern(kn, Qnil, Qnil);
puthash(func->kwargs, keyword, desc);
refcount_unref(keyword);
refcount_unref(kn);
refcount_unref(desc);
puthash(found_args, USERPTR(struct OptArgDesc, desc)->name, Qt);
if (!NILP(USERPTR(struct OptArgDesc, desc)->pred_var)) {
puthash(found_args,
USERPTR(struct OptArgDesc, desc)->pred_var, Qt);
}
} break;
case REST:
if (!NILP(func->rest_arg)) {
goto malformed;
} else if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) {
goto malformed;
} else if (!NILP(Fgethash(found_args, arg, Qnil))) {
goto malformed;
}
func->rest_arg = refcount_ref(arg);
mode = MUST_CHANGE;
break;
case MUST_CHANGE:
goto malformed;
}
}
}
refcount_unref(found_args);
// do this last
func->args = refcount_ref(args);
return;
malformed:
refcount_unref(func->rargs);
refcount_unref(func->oargs);
refcount_unref(func->rest_arg);
refcount_unref(func->kwargs);
refcount_unref(found_args);
Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
}
// ###########################
// # Pair and List Functions #
// ###########################
DEFUN(pairp, "pairp", (LispVal * val)) {
return LISP_BOOL(PAIRP(val));
}
DEFUN(atom, "atom", (LispVal * val)) {
return LISP_BOOL(ATOM(val));
}
DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) {
return make_lisp_pair(head, tail);
}
DEFUN(head, "head", (LispVal * list)) {
return refcount_ref(HEAD(list));
}
DEFUN(tail, "tail", (LispVal * list)) {
return refcount_ref(TAIL(list));
}
DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head)) {
CHECK_TYPE(TYPE_PAIR, pair);
refcount_unref(((LispPair *) pair)->head);
((LispPair *) pair)->head = refcount_ref(head);
return Qnil;
}
DEFUN(settail, "settail", (LispVal * pair, LispVal *tail)) {
CHECK_TYPE(TYPE_PAIR, pair);
refcount_unref(((LispPair *) pair)->tail);
((LispPair *) pair)->tail = refcount_ref(tail);
return Qnil;
}
// lists
DEFUN(listp, "listp", (LispVal * val)) {
return LISP_BOOL(LISTP(val));
}
DEFUN(list_length, "list-length", (LispVal * list)) {
return make_lisp_integer(list_length(list));
}
DEFUN(copy_list, "copy-list", (LispVal * list)) {
if (NILP(list)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, list);
LispVal *copy = Qnil;
LispVal *copy_end;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
void *cl_cleanup = register_cleanup(&unref_double_ptr, &copy);
FOREACH(elt, list) {
if (NILP(copy)) {
copy = Fpair(elt, Qnil);
copy_end = copy;
} else {
LispVal *new_end = Fpair(elt, Qnil);
Fsettail(copy_end, new_end);
refcount_unref(new_end);
copy_end = new_end;
}
}
cancel_cleanup(cl_cleanup);
});
return copy;
}
DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
if (NILP(tree)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, tree);
LispPair *tortise = (LispPair *) tree;
LispPair *hare = (LispPair *) tortise->tail;
LispVal *copy = Qnil;
LispVal *copy_end;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
void *cl_handle = register_cleanup(&unref_double_ptr, &copy);
while (!NILP(tortise)) {
if (!LISTP(LISPVAL(tortise))) {
break;
} else if (tortise == hare) {
refcount_unref(copy);
Fthrow(Qcircular_error, Qnil);
}
LispVal *elt = tortise->head;
if (PAIRP(elt)) {
elt = Fcopy_tree(elt);
} else {
refcount_ref(elt);
}
if (NILP(copy)) {
copy = Fpair(elt, Qnil);
copy_end = copy;
} else {
LispVal *new_end = Fpair(elt, Qnil);
Fsettail(copy_end, new_end);
refcount_unref(new_end);
copy_end = new_end;
}
refcount_unref(elt);
tortise = (LispPair *) tortise->tail;
if (PAIRP(hare)) {
if (PAIRP(((LispPair *) hare)->tail)) {
hare = (LispPair *) ((LispPair *) hare->tail)->tail;
} else if (NILP(((LispPair *) hare)->tail)) {
hare = (LispPair *) Qnil;
}
}
}
cancel_cleanup(cl_handle);
});
return copy;
}
size_t list_length(LispVal *obj) {
if (NILP(obj)) {
return 0;
}
CHECK_TYPE(TYPE_PAIR, obj);
size_t length = 0;
LispPair *tortise = (LispPair *) obj;
LispPair *hare = (LispPair *) tortise->tail;
while (!NILP(tortise)) {
if (!LISTP(LISPVAL(tortise))) {
break;
} else if (tortise == hare) {
Fthrow(Qcircular_error, Qnil);
}
++length;
tortise = (LispPair *) tortise->tail;
if (PAIRP(hare)) {
if (PAIRP(((LispPair *) hare)->tail)) {
hare = (LispPair *) ((LispPair *) hare->tail)->tail;
} else if (NILP(((LispPair *) hare)->tail)) {
hare = (LispPair *) Qnil;
}
}
}
return length;
}
// plists
static bool call_eq_pred(LispVal *pred, LispVal *v1, LispVal *v2) {
if (NILP(pred)) {
return !NILP(Feq(v1, v2));
} else {
LispVal *fcall_args = const_list(true, 2, v1, v2);
bool res = false;
WITH_CLEANUP(fcall_args, {
LispVal *lvpr = Ffuncall(pred, fcall_args); //
res = !NILP(lvpr);
refcount_unref(lvpr);
});
return res;
}
}
DEFUN(plist_get, "plist-get",
(LispVal * plist, LispVal *key, LispVal *def, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(TAIL(cur))) {
return refcount_ref(def);
}
return refcount_ref(HEAD(TAIL(cur)));
}
}
return refcount_ref(def);
}
DEFUN(plist_set, "plist-set",
(LispVal * plist, LispVal *key, LispVal *value, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(TAIL(cur))) {
break;
}
Fsethead(TAIL(cur), value);
return refcount_ref(plist);
}
}
return push_many(plist, 2, value, key);
}
DEFUN(plist_rem, "plist-rem", (LispVal * plist, LispVal *key, LispVal *pred)) {
for (LispVal *prev = Qnil, *cur = plist; !NILP(cur);
prev = cur, cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
if (NILP(prev)) {
return refcount_ref(TAIL(TAIL(plist)));
} else {
Fsettail(TAIL(prev), TAIL(TAIL(cur)));
return refcount_ref(plist);
}
}
}
return refcount_ref(plist);
}
DEFUN(plist_assoc, "plist-assoc",
(LispVal * plist, LispVal *key, LispVal *pred)) {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
return cur;
}
}
return Qnil;
}
// ####################
// # String Functions #
// ####################
DEFUN(stringp, "stringp", (LispVal * val)) {
return LISP_BOOL(STRINGP(val));
}
DEFUN(hash_string, "hash-string", (LispVal * obj)) {
CHECK_TYPE(TYPE_STRING, obj);
const char *str = ((LispString *) obj)->data;
uint64_t hash = 5381;
int c;
while ((c = *(str++))) {
hash = ((hash << 5) + hash) + c;
}
return make_lisp_integer(hash);
}
DEFUN(strings_equal, "strings-equal", (LispVal * obj1, LispVal *obj2)) {
CHECK_TYPE(TYPE_STRING, obj1);
CHECK_TYPE(TYPE_STRING, obj2);
LispString *str1 = (LispString *) obj1;
LispString *str2 = (LispString *) obj2;
if (str1->length != str2->length) {
return Qnil;
}
return LISP_BOOL(memcmp(str1->data, str2->data, str1->length) == 0);
}
LispVal *sprintf_lisp(const char *format, ...) {
va_list args;
va_start(args, format);
va_list args_measure;
va_copy(args_measure, args);
int size = vsnprintf(NULL, 0, format, args_measure) + 1;
va_end(args_measure);
char *buffer = lisp_malloc(size);
vsnprintf(buffer, size, format, args);
LispVal *obj = make_lisp_string(buffer, size, true, false);
va_end(args);
return obj;
}
bool strings_equal_nocase(const char *s1, const char *s2, size_t n) {
for (size_t i = 0; i < n; ++i) {
if (!s1[i] || !s2[i]) {
return !s1[i] && !s2[i];
} else if (tolower(s1[i]) != tolower(s2[i])) {
return false;
}
}
return true;
}
// #####################
// # Package Functions #
// #####################
static LispVal *normalize_package(LispVal *arg) {
if (STRINGP(arg) || SYMBOLP(arg)) {
LispVal *found = Ffind_package(arg);
if (!PACKAGEP(found)) {
refcount_unref(found);
Fthrow(Qunknown_package_error, const_list(true, 1, arg));
}
return found;
} else if (PACKAGEP(arg)) {
return refcount_ref(arg);
} else {
Fthrow(Qtype_error, Qnil);
}
}
DEFUN(packagep, "packagep", (LispVal * val)) {
return LISP_BOOL(PACKAGEP(val));
}
DEFUN(make_package, "make-package", (LispVal * name)) {
if (SYMBOLP(name)) {
name = Fsymbol_name(name);
} else {
name = refcount_ref(name);
}
LispVal *np = make_lisp_package(name);
refcount_unref(name);
return np;
}
DEFUN(package_name, "package-name", (LispVal * package)) {
CHECK_TYPE(TYPE_PACKAGE, package);
return LISPVAL(((LispPackage *) package)->name);
}
DEFUN(register_package, "register-package", (LispVal * package)) {
if (STRINGP(package)) {
package = make_lisp_package(package);
} else if (SYMBOLP(package)) {
package = make_lisp_package(LISPVAL(((LispSymbol *) package)->name));
} else {
CHECK_TYPE(TYPE_PACKAGE, package);
package = refcount_ref(package);
}
LispVal *found = Ffind_package(package);
if (!NILP(found)) {
refcount_unref(package);
Fthrow(Qpackage_exists_error, const_list(true, 1, package));
}
puthash(package_table, LISPVAL(((LispPackage *) package)->name), package);
return package;
}
DEFUN(current_package, "current-package", (void) ) {
return refcount_ref(current_package);
}
IGNORE(); // fix indentation
DEFUN(set_current_package, "set-current-package", (LispVal * package)) {
LispVal *new = normalize_package(package);
LispVal *old = current_package;
current_package = new;
refcount_unref(old);
return refcount_ref(current_package);
}
DEFUN(mapsymbols, "mapsymbols", (LispVal * func, LispVal *package)) {
LispPackage *pkg;
if (NILP(package)) {
pkg = refcount_ref(current_package);
} else {
pkg = (LispPackage *) normalize_package(package);
}
WITH_CLEANUP(pkg, {
IGNORE();
HT_FOREACH_VALID_INDEX(pkg->obarray, i) {
LispVal *args = const_list(true, 1, HASH_VALUE(pkg->obarray, i));
refcount_unref(Ffuncall(func, args));
}
});
return Qnil;
}
DEFUN(export_symbol, "export-symbol", (LispVal * symbol)) {
if (SYMBOLP(symbol)) {
LispSymbol *sym = (LispSymbol *) symbol;
LispPackage *pkg = (LispPackage *) sym->package;
puthash(pkg->exported_sym_table, symbol, Qt);
} else if (LISTP(symbol)) {
FOREACH(cur, symbol) {
CHECK_TYPE(TYPE_SYMBOL, cur);
Fexport_symbol(cur);
}
} else {
Fthrow(Qtype_error,
const_list(false, 2, const_list(false, 2, Qlistp, Qsymbolp),
symbol));
}
return Qnil;
}
// recursively search all imports of SOURCE, looking for TARGET
static bool check_recursive_import(LispVal *source, LispVal *target) {
FOREACH(entry, ((LispPackage *) source)->imported) {
if (HEAD(entry) == target
|| check_recursive_import(HEAD(entry), target)) {
return true;
}
}
return false;
}
DEFUN_DISTINGUISHED(import_package, "import-package",
(LispVal * source, LispVal *names, LispVal *target)) {
LispPackage *target_pkg;
if (target == Qunbound || NILP(target)) {
target_pkg = refcount_ref(current_package);
} else {
target_pkg = (LispPackage *) normalize_package(target);
}
if (!PACKAGEP(target_pkg)) {
refcount_unref(target_pkg);
Fthrow(Qimport_error, Qnil);
}
if (names == Qunbound) {
names = Qt; // all symbols
}
FOREACH(entry, target_pkg->imported) {
if (HEAD(entry) == source) {
if (names == Qt) {
Fsettail(HEAD(entry), Qt);
} else {
LispVal *imported = TAIL(entry);
// if we have already imported everything, do nothing
if (imported == Qt) {
goto done;
}
FOREACH(name, names) {
if (SYMBOLP(name)) {
name = LISPVAL(((LispSymbol *) name)->name);
} else if (!STRINGP(name)) {
refcount_unref(target_pkg);
CHECK_TYPE(TYPE_STRING, name);
}
puthash(imported, name, Qt);
}
}
goto done;
}
}
// we didn't find any existing imports, so add a new entry
if (check_recursive_import(source, LISPVAL(target_pkg))) {
refcount_unref(target_pkg);
Fthrow(Qimport_error, Qnil);
}
LispVal *lasttail = Qnil;
FOREACH_TAIL(tail, target_pkg->imported) {
if (NILP(TAIL(tail))) {
lasttail = tail;
break;
}
}
if (LISTP(names)) {
LispVal *norm_names = make_lisp_hashtable(Qstrings_equal, Qhash_string);
FOREACH(name, names) {
if (SYMBOLP(name)) {
name = LISPVAL(((LispSymbol *) name)->name);
} else if (!STRINGP(name)) {
refcount_unref(target_pkg);
refcount_unref(norm_names);
CHECK_TYPE(TYPE_STRING, name);
}
puthash(norm_names, name, Qt);
}
names = norm_names;
}
if (NILP(lasttail)) {
target_pkg->imported = const_list(false, 1, Fpair(source, names));
} else {
Fsettail(lasttail, const_list(false, 1, Fpair(source, names)));
}
refcount_unref(names);
done:
refcount_unref(target_pkg);
return Qnil;
}
DEFUN(find_package, "find-package", (LispVal * name)) {
if (STRINGP(name)) {
return Fgethash(package_table, name, Qnil);
} else if (SYMBOLP(name)) {
return Fgethash(package_table, LISPVAL(((LispSymbol *) name)->name),
Qnil);
} else if (PACKAGEP(name)) {
LispPackage *pkg = (LispPackage *) name;
LispVal *found = Fgethash(package_table, LISPVAL(pkg->name), Qnil);
if (found == LISPVAL(pkg)) {
return found;
} else {
refcount_unref(found);
return Qnil;
}
} else {
Fthrow(Qtype_error, Qnil);
}
}
LispVal *find_package(const char *name, size_t length) {
LispVal *sobj = make_lisp_string(name, length, false, false);
LispVal *pkg = Ffind_package(sobj);
refcount_unref(sobj);
return pkg;
}
// ####################
// # Symbol Functions #
// ####################
DEFUN(symbolp, "symbolp", (LispVal * val)) {
return LISP_BOOL(SYMBOLP(val));
}
DEFUN(keywordp, "keywordp", (LispVal * val)) {
return LISP_BOOL(KEYWORDP(val));
}
DEFUN(make_symbol, "make-symbol", (LispVal * name)) {
return make_lisp_symbol(name);
}
DEFUN(symbol_package, "symbol-package", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->package);
}
DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->name);
}
DEFUN(symbol_function, "symbol-function",
(LispVal * symbol, LispVal *resolve)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (NILP(resolve)) {
return refcount_ref(((LispSymbol *) symbol)->function);
}
while (SYMBOLP(symbol) && !NILP(symbol)) {
symbol = ((LispSymbol *) symbol)->function;
}
return refcount_ref(symbol);
}
DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->value);
}
DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->plist);
}
DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
LispSymbol *real = (LispSymbol *) symbol;
refcount_unref(real->plist);
real->plist = refcount_ref(plist);
return Qnil;
}
DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
CHECK_TYPE(TYPE_SYMBOL, sym);
LispSymbol *sobj = ((LispSymbol *) sym);
// TODO make sure this is not constant
refcount_ref(new_func);
refcount_unref(sobj->function);
sobj->function = new_func;
return refcount_ref(new_func);
}
DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
LispSymbol *sym = (LispSymbol *) symbol;
if (NILP(sym->package)) {
return Qnil;
}
LispPackage *pkg = (LispPackage *) sym->package;
return Fgethash(pkg->exported_sym_table, LISPVAL(sym), Qnil);
}
DEFUN(intern_soft, "intern-soft",
(LispVal * name, LispVal *def, LispVal *package, LispVal *included_too)) {
LispPackage *real_pkg;
if (NILP(package)) {
real_pkg = refcount_ref(current_package);
} else {
real_pkg = (LispPackage *) normalize_package(package);
}
LispVal *cur = gethash(real_pkg->obarray, name, Qunbound);
if (cur != Qunbound) {
refcount_unref(real_pkg);
return refcount_ref(cur);
}
if (!NILP(included_too)) {
FOREACH(entry, real_pkg->imported) {
if (TAIL(entry) != Qt) {
LispVal *sub = HEAD(entry);
LispVal *imported = TAIL(entry);
if (!NILP(gethash(imported, name, Qnil))) {
refcount_unref(real_pkg);
// we import it from this package, so don't keep searching
// if the intern fails
return Fintern_soft(name, def, sub, Qt);
}
// otherwise, keep looking in a different package
} else {
cur = Fintern_soft(name, Qunbound, HEAD(entry), Qt);
if (cur != Qunbound) {
refcount_unref(real_pkg);
return cur;
}
}
}
}
refcount_unref(real_pkg);
return refcount_ref(def);
}
DEFUN(intern, "intern",
(LispVal * name, LispVal *package, LispVal *included_too)) {
CHECK_TYPE(TYPE_STRING, name);
LispPackage *real_pkg;
if (NILP(package)) {
real_pkg = refcount_ref(current_package);
} else {
real_pkg = (LispPackage *) normalize_package(package);
}
LispVal *cur = Fintern_soft(name, Qunbound, package, included_too);
if (cur != Qunbound) {
return cur;
}
LispVal *sym = make_lisp_symbol(name);
((LispSymbol *) sym)->package = refcount_ref(real_pkg);
puthash(real_pkg->obarray, name, sym);
refcount_unref(real_pkg);
return sym;
}
LispVal *intern(const char *name, size_t length, bool take, LispVal *package,
bool included_too) {
if (!NILP(package)) {
CHECK_TYPE(TYPE_PACKAGE, package);
}
LispVal *name_obj = make_lisp_string((char *) name, length, take, false);
LispVal *sym = Fintern(name_obj, package, LISP_BOOL(included_too));
refcount_unref(name_obj);
return sym;
}
// #######################
// # Hash Table Functions #
// #######################
DEFUN(hashtablep, "hashtablep", (LispVal * val)) {
return LISP_BOOL(HASHTABLEP(val));
}
DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) {
return make_lisp_hashtable(eq_fn, hash_fn);
}
DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table)) {
CHECK_TYPE(TYPE_HASHTABLE, table);
// TODO implement
return Qnil;
}
DEFUN(hash_table_count, "hash-table-count", (LispVal * table)) {
CHECK_TYPE(TYPE_HASHTABLE, table);
return make_lisp_integer(((LispHashtable *) table)->count);
}
DEFUN(puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value)) {
return refcount_ref(puthash(table, key, value));
}
DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def)) {
return refcount_ref(gethash(table, key, def));
}
static bool hash_table_eq(LispVal *eq_fn, LispVal *v1, LispVal *v2) {
if (NILP(eq_fn)) {
return v1 == v2;
} else if (eq_fn == Qstrings_equal) {
return !NILP(Fstrings_equal(v1, v2));
} else {
LispVal *eq_obj;
LispVal *args = const_list(true, 2, v1, v2);
WITH_CLEANUP(args, {
eq_obj = Ffuncall(eq_fn, args); //
});
bool result = !NILP(eq_obj);
refcount_unref(eq_obj);
return result;
}
}
static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
if (NILP(self->hash_fn)) {
return (uint64_t) key;
} else if (self->hash_fn == Qhash_string) {
// Make obarray and lexenv lookups faster
LispVal *hash_obj = Fhash_string(key);
uint64_t hash = ((LispInteger *) hash_obj)->value;
refcount_unref(hash_obj);
return hash;
} else {
LispVal *hash_obj;
LispVal *args = const_list(true, 1, key);
WITH_CLEANUP(args, {
hash_obj = Ffuncall(self->hash_fn, args); //
});
uint64_t hash;
WITH_CLEANUP(hash_obj, {
CHECK_TYPE(TYPE_INTEGER, hash_obj);
hash = ((LispInteger *) hash_obj)->value;
});
return hash;
}
}
static ptrdiff_t hash_table_find_entry(struct HashtableEntry *entries,
size_t size, LispVal *eq_fn,
LispVal *key, uint64_t hash) {
size_t i = hash % size;
while (entries[i].key && !hash_table_eq(eq_fn, key, entries[i].key)) {
i = (i + 1) % size;
}
return i;
}
DEFUN(remhash, "remhash", (LispVal * table, LispVal *key)) {
CHECK_TYPE(TYPE_HASHTABLE, table);
LispHashtable *self = (LispHashtable *) table;
uint64_t hash = hash_table_hash(self, key);
ptrdiff_t i = hash_table_find_entry(self->key_vals, self->table_size,
self->eq_fn, key, hash);
if (HASH_SLOT_UNSET_P(self, i)) {
return Qnil;
}
refcount_unref(self->key_vals[i].key);
self->key_vals[i].key = NULL;
LispVal *retval = self->key_vals[i].value;
--self->count;
// fixup the table
for (size_t j = (i + 1) % self->table_size; !HASH_SLOT_UNSET_P(self, j);
j = (j + 1) % self->table_size) {
size_t k = HASH_HASH(self, j) % self->table_size;
if ((i <= j && i < k && k <= j) || (i > j && (k <= j || i < k))) {
// https://en.wikipedia.org/wiki/Open_addressing
// test if the value actually should come before i or after j
continue;
}
self->key_vals[i].hash = HASH_HASH(self, j);
self->key_vals[i].key = HASH_KEY(self, j);
self->key_vals[i].value = HASH_VALUE(self, j);
self->key_vals[j].key = NULL;
i = j;
}
return retval;
}
void free_hash_table_data_array(void *data) {
struct HashtableDataArray *arr = data;
for (size_t i = 0; i < arr->size; ++i) {
refcount_unref(arr->entries[i].key);
refcount_unref(arr->entries[i].value);
}
lisp_free(arr->entries);
}
// we assume the table is not full
// return true if we added a new entry, false otherwise
static bool puthash_to_array(LispVal *eq_fn, struct HashtableEntry *key_vals,
size_t table_size, LispVal *key, uint64_t hash,
LispVal *value) {
ptrdiff_t i = hash_table_find_entry(key_vals, table_size, eq_fn, key, hash);
if (!key_vals[i].key) {
key_vals[i].key = refcount_ref(key);
key_vals[i].hash = hash;
key_vals[i].value = refcount_ref(value);
return true;
} else {
refcount_unref(key_vals[i].key);
key_vals[i].key = refcount_ref(key);
refcount_unref(key_vals[i].value);
key_vals[i].value = refcount_ref(value);
return false;
}
}
static void rehash_to(LispHashtable *self, size_t new_size) {
struct HashtableEntry *new_data =
lisp_malloc0(sizeof(struct HashtableEntry) * new_size);
struct HashtableDataArray data_arr = {.size = new_size,
.entries = new_data};
void *cl_handler;
if (the_stack) {
cl_handler = register_cleanup(&free_hash_table_data_array, &data_arr);
}
size_t new_count = 0; // this should be the same, but just in case the user
// violates the rules of immutability
HT_FOREACH_VALID_INDEX(self, i) {
LispVal *key = HASH_KEY(self, i);
uint64_t hash = HASH_HASH(self, i);
LispVal *value = HASH_VALUE(self, i);
if (puthash_to_array(self->eq_fn, new_data, new_size, key, hash,
value)) {
++new_count;
}
}
if (the_stack) {
cancel_cleanup(cl_handler);
}
free_hash_table_data_array(&(struct HashtableDataArray) {
.size = self->table_size, .entries = self->key_vals});
self->key_vals = new_data;
self->table_size = new_size;
self->count = new_count;
}
static inline void maybe_rehash(LispHashtable *self) {
if (HASH_TABLE_LOAD_FACTOR(self) >= 0.5) {
rehash_to(self, self->table_size * LISP_HASHTABLE_GROWTH_FACTOR);
} /* else if (HASH_TABLE_LOAD_FACTOR(self) <= 0.1
&& self->table_size > LISP_HASHTABLE_INITIAL_SIZE) {
rehash_to(self, self->table_size / LISP_HASHTABLE_GROWTH_FACTOR);
} */
}
LispVal *puthash(LispVal *table, LispVal *key, LispVal *value) {
CHECK_TYPE(TYPE_HASHTABLE, table);
LispHashtable *self = (LispHashtable *) table;
maybe_rehash(self);
uint64_t hash = hash_table_hash(self, key);
if (puthash_to_array(self->eq_fn, self->key_vals, self->table_size, key,
hash, value)) {
++self->count;
}
return value;
}
LispVal *gethash(LispVal *table, LispVal *key, LispVal *def) {
CHECK_TYPE(TYPE_HASHTABLE, table);
assert(HASH_TABLE_LOAD_FACTOR(table) < 0.95); // infinite loop otherwise
LispHashtable *self = (LispHashtable *) table;
uint64_t hash = hash_table_hash(self, key);
ptrdiff_t i = hash_table_find_entry(self->key_vals, self->table_size,
self->eq_fn, key, hash);
if (HASH_SLOT_UNSET_P(self, i)) {
return def;
} else {
return HASH_VALUE(self, i);
}
}
LispVal *remhash(LispVal *table, LispVal *key) {
return refcount_unref(Fremhash(table, key));
}
// #####################
// # Numeric Functions #
// #####################
DEFUN(integerp, "integerp", (LispVal * val)) {
return LISP_BOOL(INTEGERP(val));
}
DEFUN(floatp, "floatp", (LispVal * val)) {
return LISP_BOOL(FLOATP(val));
}
DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2)) {
if (INTEGERP(n1) && INTEGERP(n2)) {
return LISP_BOOL(((LispInteger *) n1)->value
== ((LispInteger *) n2)->value);
} else if (INTEGERP(n1) && FLOATP(n2)) {
return LISP_BOOL(((LispInteger *) n1)->value
== ((LispFloat *) n2)->value);
} else if (FLOATP(n1) && INTEGERP(n2)) {
return LISP_BOOL(((LispFloat *) n1)->value
== ((LispInteger *) n2)->value);
} else if (FLOATP(n1) && FLOATP(n2)) {
return LISP_BOOL(((LispFloat *) n1)->value
== ((LispFloat *) n2)->value);
} else {
Fthrow(Qtype_error, Qnil);
}
}
DEFUN(num_gt, ">", (LispVal * n1, LispVal *n2)) {
if (INTEGERP(n1) && INTEGERP(n2)) {
return LISP_BOOL(((LispInteger *) n1)->value
> ((LispInteger *) n2)->value);
} else if (INTEGERP(n1) && FLOATP(n2)) {
return LISP_BOOL(((LispInteger *) n1)->value
> ((LispFloat *) n2)->value);
} else if (FLOATP(n1) && INTEGERP(n2)) {
return LISP_BOOL(((LispFloat *) n1)->value
> ((LispInteger *) n2)->value);
} else if (FLOATP(n1) && FLOATP(n2)) {
return LISP_BOOL(((LispFloat *) n1)->value > ((LispFloat *) n2)->value);
} else {
Fthrow(Qtype_error, Qnil);
}
}
#define ONE_MATH_OPERAION(oper, out, n1, n2) \
if (INTEGERP(n1) && INTEGERP(n2)) { \
out = make_lisp_integer( \
((LispInteger *) n1)->value oper((LispInteger *) n2)->value); \
} else if (INTEGERP(n1) && FLOATP(n2)) { \
out = make_lisp_float( \
((LispInteger *) n1)->value oper((LispFloat *) n2)->value); \
} else if (FLOATP(n1) && INTEGERP(n2)) { \
out = make_lisp_float( \
((LispFloat *) n1)->value oper((LispInteger *) n2)->value); \
} else if (FLOATP(n1) && FLOATP(n2)) { \
out = make_lisp_float( \
((LispFloat *) n1)->value oper((LispFloat *) n2)->value); \
} else { \
Fthrow(Qtype_error, Qnil); \
}
static inline LispVal *copy_number(LispVal *v) {
if (FLOATP(v)) {
return make_lisp_float(((LispFloat *) v)->value);
} else if (INTEGERP(v)) {
return make_lisp_integer(((LispInteger *) v)->value);
} else {
abort();
}
}
DEFUN(add, "+", (LispVal * args)) {
if (NILP(args)) {
return make_lisp_integer(0);
}
LispVal *out = copy_number(Fhead(args));
FOREACH(arg, Ftail(args)) {
LispVal *old_out = out;
WITH_CLEANUP_DOUBLE_PTR(old_out, {
ONE_MATH_OPERAION(+, out, out, arg); //
});
}
return out;
}
DEFUN(sub, "-", (LispVal * args)) {
if (NILP(args)) {
return make_lisp_integer(0);
}
LispVal *out = copy_number(Fhead(args));
FOREACH(arg, Ftail(args)) {
LispVal *old_out = out;
WITH_CLEANUP_DOUBLE_PTR(old_out, {
ONE_MATH_OPERAION(-, out, out, arg); //
});
}
return out;
}
// ####################
// # Vector Functions #
// ####################
DEFUN(vectorp, "vectorp", (LispVal * val)) {
return LISP_BOOL(VECTORP(val));
}
DEFUN(vector, "vector", (LispVal * elems)) {
struct UnrefListData uld = {.vals = NULL, .len = 0};
WITH_PUSH_FRAME(Qnil, Qnil, true, {
void *cl_handler = register_cleanup(&unref_free_list_double_ptr, &uld);
FOREACH(elt, elems) {
uld.vals = lisp_realloc(uld.vals, sizeof(LispVal *) * (++uld.len));
uld.vals[uld.len - 1] = elt;
}
cancel_cleanup(cl_handler);
});
return make_lisp_vector(uld.vals, uld.len);
}
// ########################
// # Lexenv and the Stack #
// ########################
DEF_STATIC_SYMBOL(kw_success, "success");
DEF_STATIC_SYMBOL(kw_finally, "finally");
DEFUN(backtrace, "backtrace", (void) ) {
LispVal *head = Qnil;
LispVal *end = Qnil;
for (StackFrame *frame = the_stack; frame; frame = frame->next) {
if (frame->hidden) {
continue;
}
if (NILP(head)) {
head = Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
refcount_unref(HEAD(head));
end = head;
} else {
LispVal *new_end =
Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
refcount_unref(HEAD(new_end));
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
}
return head;
}
IGNORE(); // fix indentation
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
CHECK_TYPE(TYPE_SYMBOL, signal);
LispVal *error_arg =
const_list(false, 2, Fpair(signal, rest), Fbacktrace());
while (the_stack) {
if (!the_stack->enable_handlers) {
goto up_frame;
}
LispVal *handler =
gethash(LISPVAL(the_stack->handlers), signal, Qunbound);
if (handler == Qunbound) {
// handler for all exceptions
handler = gethash(LISPVAL(the_stack->handlers), Qt, Qunbound);
}
if (handler != Qunbound) {
the_stack->enable_handlers = false;
LispVal *var = HEAD(handler);
LispVal *form = TAIL(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
if (!NILP(var)) {
// TODO make sure this isn't constant
push_to_lexenv(&the_stack->lexenv, var, error_arg);
}
WITH_CLEANUP(error_arg, {
stack_return = Feval(form); //
});
});
longjmp(the_stack->start, STACK_EXIT_THROW);
}
up_frame: {
// steal the form so we can call it after we unwind (in case it
// throws)
LispVal *unwind_form = the_stack->unwind_form;
the_stack->unwind_form = Qnil;
stack_leave();
if (!NILP(unwind_form)) {
void *cl_handler =
register_cleanup(&refcount_unref_as_callback, error_arg);
WITH_CLEANUP(unwind_form, {
refcount_unref(Feval(unwind_form)); //
});
cancel_cleanup(cl_handler);
}
}
}
fprintf(stderr,
"ERROR: An exception has propagated past the top of the stack!\n");
fprintf(stderr, "Type: ");
debug_dump(stderr, signal, true);
fprintf(stderr, "Args: ");
debug_dump(stderr, rest, true);
fprintf(stderr, "Lisp will now exit...");
// we never used it, so drop it
refcount_unref(error_arg);
abort();
}
#pragma GCC diagnostic pop
StackFrame *the_stack = NULL;
LispVal *stack_return = NULL;
DEF_STATIC_SYMBOL(toplevel, "toplevel");
void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame));
frame->name = name;
frame->return_tag = Qnil;
frame->hidden = true;
frame->detail = detail;
frame->lexenv = Qnil;
if (inherit && the_stack) {
frame->lexenv = refcount_ref(the_stack->lexenv);
}
frame->enable_handlers = true;
frame->handlers = make_lisp_hashtable(Qnil, Qnil);
frame->unwind_form = Qnil;
frame->cleanup_handlers = NULL;
frame->next = the_stack;
the_stack = frame;
}
void stack_leave(void) {
StackFrame *frame = the_stack;
the_stack = the_stack->next;
refcount_unref(frame->name);
refcount_unref(frame->return_tag);
refcount_unref(frame->detail);
refcount_unref(frame->lexenv);
refcount_unref(frame->handlers);
while (frame->cleanup_handlers) {
frame->cleanup_handlers->fun(frame->cleanup_handlers->data);
struct CleanupHandlerEntry *next = frame->cleanup_handlers->next;
lisp_free(frame->cleanup_handlers);
frame->cleanup_handlers = next;
}
LispVal *unwind_form = frame->unwind_form;
// steal the ref
frame->unwind_form = Qnil;
lisp_free(frame);
if (!NILP(unwind_form)) {
WITH_CLEANUP(unwind_form, {
refcount_unref(Feval(unwind_form)); //
})
}
}
void *register_cleanup(lisp_cleanup_func_t fun, void *data) {
struct CleanupHandlerEntry *entry =
lisp_malloc(sizeof(struct CleanupHandlerEntry));
entry->fun = fun;
entry->data = data;
entry->next = the_stack->cleanup_handlers;
the_stack->cleanup_handlers = entry;
return entry;
}
void free_double_ptr(void *ptr) {
lisp_free(*(void **) ptr);
}
void unref_free_list_double_ptr(void *ptr) {
struct UnrefListData *data = ptr;
for (size_t i = 0; i < data->len; ++i) {
refcount_unref(data->vals[i]);
}
lisp_free(data->vals);
}
void unref_double_ptr(void *ptr) {
if (*(void **) ptr) {
refcount_unref(*(void **) ptr);
*(void **) ptr = NULL;
}
}
void cancel_cleanup(void *handle) {
struct CleanupHandlerEntry *entry = the_stack->cleanup_handlers;
if (entry == handle) {
the_stack->cleanup_handlers = entry->next;
lisp_free(entry);
} else {
while (entry) {
if (entry->next == handle) {
struct CleanupHandlerEntry *to_free = entry->next;
entry->next = entry->next->next;
lisp_free(to_free);
break;
}
entry = entry->next;
}
}
}
// #########################
// # Errors and Conditions #
// #########################
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(unclosed_error, "read-error");
DEF_STATIC_SYMBOL(eof_error, "eof-error");
DEF_STATIC_SYMBOL(void_variable_error, "void-variable-error");
DEF_STATIC_SYMBOL(void_function_error, "void-function-error");
DEF_STATIC_SYMBOL(circular_error, "circular-error");
DEF_STATIC_SYMBOL(malformed_lambda_list_error, "malformed-lambda-list-error");
DEF_STATIC_SYMBOL(argument_error, "argument-error");
DEF_STATIC_SYMBOL(invalid_function_error, "invalid-function-error");
DEF_STATIC_SYMBOL(no_applicable_method_error, "no-applicable-method-error");
DEF_STATIC_SYMBOL(return_frame_error, "return-frame-error");
DEF_STATIC_SYMBOL(package_exists_error, "package-exists-error");
DEF_STATIC_SYMBOL(import_error, "import-error");
DEF_STATIC_SYMBOL(unknown_package_error, "unknown-package-error");
// ###################
// # Debug Functions #
// ###################
static void debug_dump_real(FILE *stream, void *obj, bool first) {
switch (TYPEOF(obj)) {
case TYPE_STRING: {
LispString *str = (LispString *) obj;
// TODO actually quote
fputc('"', stream);
fwrite(str->data, 1, str->length, stream);
fputc('"', stream);
} break;
case TYPE_SYMBOL: {
LispSymbol *sym = (LispSymbol *) obj;
if (KEYWORDP(obj)) {
fputc(':', stream);
} else if (NILP(sym->package)) {
fprintf(stream, "::");
} else if (sym->package != current_package) {
LispPackage *pkg = (LispPackage *) sym->package;
fwrite(pkg->name->data, 1, pkg->name->length, stream);
fputc(':', stream);
if (NILP(Fexported_symbol_p(obj))) {
fputc(':', stream);
}
}
fwrite(sym->name->data, 1, sym->name->length, stream);
} break;
case TYPE_PAIR: {
LispPair *pair = (LispPair *) obj;
if (first) {
fputc('(', stream);
} else {
fputc(' ', stream);
}
debug_dump_real(stream, pair->head, true);
if (NILP(pair->tail)) {
fputc(')', stream);
} else if (PAIRP(pair->tail)) {
debug_dump_real(stream, pair->tail, false);
} else {
fprintf(stream, " . ");
debug_dump_real(stream, pair->tail, false);
fputc(')', stream);
}
} break;
case TYPE_INTEGER:
fprintf(stream, "%jd", (intmax_t) ((LispInteger *) obj)->value);
break;
case TYPE_FLOAT:
fprintf(stream, "%Lf", ((LispFloat *) obj)->value);
break;
case TYPE_VECTOR: {
LispVector *vec = (LispVector *) obj;
fputc('[', stream);
for (size_t i = 0; i < vec->length; ++i) {
if (i) {
fputc(' ', stream);
}
debug_dump_real(stream, vec->data[i], true);
}
fputc(']', stream);
} break;
case TYPE_FUNCTION: {
LispVal *name = ((LispFunction *) obj)->name;
if (((LispFunction *) obj)->is_builtin) {
fprintf(stream, "<builtin ");
} else {
if (name == Qlambda) {
fprintf(stream, "<lambda"); // no space!
name = NULL;
} else {
fprintf(stream, "<function ");
}
}
if (name) {
debug_dump_real(stream, name, false);
}
fprintf(stream, " at %#jx>", (uintmax_t) obj);
} break;
case TYPE_HASHTABLE: {
LispHashtable *tbl = (LispHashtable *) obj;
fprintf(stream, "<hashtable size=%zu count=%zu at %#jx>",
tbl->table_size, tbl->count, (uintmax_t) obj);
} break;
case TYPE_USER_POINTER: {
LispUserPointer *ptr = (LispUserPointer *) obj;
fprintf(stream, "<user-pointer ptr=%#jx at %#jx>",
(uintmax_t) ptr->data, (uintmax_t) obj);
} break;
case TYPE_PACKAGE: {
LispPackage *pkg = (LispPackage *) obj;
fprintf(stream, "<package ");
fwrite(pkg->name->data, 1, pkg->name->length, stream);
fprintf(stream, " obarray-size=%zu at %#jx>",
((LispHashtable *) pkg->obarray)->count, (uintmax_t) obj);
} break;
default:
fprintf(stream, "<object type=%ju at %#jx>",
(uintmax_t) LISPVAL(obj)->type, (uintmax_t) obj);
break;
}
}
void debug_dump(FILE *stream, void *obj, bool newline) {
debug_dump_real(stream, obj, true);
if (newline) {
fputc('\n', stream);
}
}
void debug_print_hashtable(FILE *stream, LispVal *table) {
debug_dump(stream, table, true);
HT_FOREACH_VALID_INDEX(table, i) {
fprintf(stream, "- ");
debug_dump(stream, HASH_KEY(table, i), false);
fprintf(stream, " = ");
debug_dump(stream, HASH_VALUE(table, i), true);
}
}
static bool debug_print_tree_callback(void *obj, const RefcountList *trail,
void *stream_raw) {
FILE *stream = stream_raw;
size_t depth = refcount_list_length(trail);
for (size_t i = 0; i < depth; ++i) {
fprintf(stream, " ");
}
fprintf(stream, "- ");
debug_dump(stream, obj, true);
return false;
}
void debug_print_tree(FILE *stream, void *obj) {
refcount_debug_walk_tree(obj, debug_print_tree_callback, stream);
}
// ################
// # Registration #
// ################
static void register_symbols_and_functions(void) {
// don't intern Qunbound!
REGISTER_DO_INTERN(nil, system_package);
REGISTER_DO_INTERN(t, system_package);
REGISTER_SYMBOL(opt);
REGISTER_SYMBOL(allow_other_keys);
REGISTER_SYMBOL(key);
REGISTER_SYMBOL(rest);
REGISTER_SYMBOL(declare);
REGISTER_SYMBOL(name);
REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL_INTO(kw_success, keyword_package);
REGISTER_SYMBOL_INTO(kw_finally, keyword_package);
REGISTER_SYMBOL(shutdown_signal);
REGISTER_SYMBOL(type_error);
REGISTER_SYMBOL(read_error);
REGISTER_SYMBOL(eof_error);
REGISTER_SYMBOL(unclosed_error);
REGISTER_SYMBOL(void_variable_error);
REGISTER_SYMBOL(void_function_error);
REGISTER_SYMBOL(circular_error);
REGISTER_SYMBOL(malformed_lambda_list_error);
REGISTER_SYMBOL(argument_error);
REGISTER_SYMBOL(invalid_function_error);
REGISTER_SYMBOL(no_applicable_method_error);
REGISTER_SYMBOL(return_frame_error);
REGISTER_SYMBOL(package_exists_error);
REGISTER_SYMBOL(import_error);
REGISTER_SYMBOL(unknown_package_error);
// some stuff that musn't be user accesable
REGISTER_SYMBOL_NOINTERN(toplevel);
REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", "");
REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", "");
REGISTER_FUNCTION(make_hashtable, "(&opt hash-fn eq-fn)", "");
REGISTER_FUNCTION(puthash, "(table key value)", "");
REGISTER_FUNCTION(gethash, "(table key &opt def)", "");
REGISTER_FUNCTION(remhash, "(table key)", "");
REGISTER_FUNCTION(vector, "(&rest elements)", "");
REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing...");
REGISTER_FUNCTION(sethead, "(pair newval)",
"Set the head of PAIR to NEWVAL.");
REGISTER_FUNCTION(settail, "(pair newval)",
"Set the tail of PAIR to NEWVAL.");
REGISTER_FUNCTION(funcall, "(function &rest args)", "")
REGISTER_FUNCTION(apply, "(function &rest args)", "")
REGISTER_FUNCTION(throw, "(signal &rest data)", "");
REGISTER_FUNCTION(pair, "(head tail)",
"Return a new pair with HEAD and TAIL.");
REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR.");
REGISTER_FUNCTION(tail, "(pair)", "Return the tail of PAIR.");
REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader.");
REGISTER_FUNCTION(exit, "(&opt code)",
"Exit with CODE, defaulting to zero.");
REGISTER_FUNCTION(print, "(obj)",
"Print a human-readable representation of OBJ.");
REGISTER_FUNCTION(
println, "(obj)",
"Print a human-readable representation of OBJ followed by a newline.");
REGISTER_FUNCTION(not, "(obj)",
"Return t if OBJ is nil, otherwise return t.");
REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS.");
REGISTER_FUNCTION(sub, "(&rest nums)",
"Return (head NUMS) - (apply '+ (tail NUMS)).");
REGISTER_FUNCTION(
if, "(cond then &rest else)",
"Evaluate THEN if COND is non-nil, otherwise evaluate ELSE.");
REGISTER_FUNCTION(
setq, "(&rest name-value-pairs)",
"Set each of a number of variables to their respective values.");
REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
REGISTER_FUNCTION(symbol_name, "(sym)", "");
REGISTER_FUNCTION(symbol_package, "(sym)", "");
REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
REGISTER_FUNCTION(symbol_value, "(sym)", "Return the global value of SYM.");
REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM.");
REGISTER_FUNCTION(setplist, "(sym plist)",
"Set the plist of SYM to PLIST.");
REGISTER_FUNCTION(fset, "(sym new-func)", "");
REGISTER_FUNCTION(defun, "(name args &rest body)",
"Define NAME to be a new function.");
REGISTER_FUNCTION(defmacro, "(name args &rest body)",
"Define NAME to be a new macro.");
REGISTER_FUNCTION(lambda, "(args &rest body)", "Return a new closure.");
REGISTER_FUNCTION(while, "(cond &rest body)",
"Run BODY until COND returns nil.");
REGISTER_FUNCTION(eval, "(expr)", "Evaluate the lisp expression EXPR");
REGISTER_FUNCTION(read, "(source)",
"Read and return the next s-expr from SOURCE.");
REGISTER_FUNCTION(eq, "(obj1 obj2)",
"Return non-nil if OBJ1 and OBJ2 are equal");
REGISTER_FUNCTION(make_symbol, "(name)",
"Return a new un-interned symbol named NAME.");
REGISTER_FUNCTION(macroexpand_1, "(form &opt lexical-macros)",
"Return the form which FORM expands to.");
REGISTER_FUNCTION(macroexpand_toplevel, "(form &opt lexical-macros)", "");
REGISTER_FUNCTION(macroexpand_all, "(form &opt lexical-macros)", "");
REGISTER_FUNCTION(stringp, "(val)", "Return non-nil if VAL is a string.");
REGISTER_FUNCTION(symbolp, "(val)", "Return non-nil if VAL is a symbol.");
REGISTER_FUNCTION(pairp, "(val)", "Return non-nil if VAL is a pair.");
REGISTER_FUNCTION(integerp, "(val)", "Return non-nil if VAL is a integer.");
REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float.");
REGISTER_FUNCTION(vectorp, "(val)", "Return non-nil if VAL is a vector.");
REGISTER_FUNCTION(packagep, "(val)", "Return non-nil if VAL is a package.");
REGISTER_FUNCTION(
functionp, "(val)",
"Return non-nil if VAL is a non-macro function (includes buitlins).");
REGISTER_FUNCTION(macrop, "(val &opt lexical-macros)",
"Return non-nil if VAL is a non-builtin macro.");
REGISTER_FUNCTION(builtinp, "(val)",
"Return non-nil if VAL is a non-macro builtin.");
REGISTER_FUNCTION(special_form_p, "(val)",
"Return non-nil if VAL is a macro-builtin.");
REGISTER_FUNCTION(hashtablep, "(val)",
"Return non-nil if VAL is a hashtable.");
REGISTER_FUNCTION(user_pointer_p, "(val)",
"Return non-nil if VAL is a user pointer.");
REGISTER_FUNCTION(atom, "(val)", "Return non-nil if VAL is a atom.");
REGISTER_FUNCTION(listp, "(val)", "Return non-nil if VAL is a list.");
REGISTER_FUNCTION(keywordp, "(val)", "Return non-nil if VAL is a keyword.");
REGISTER_FUNCTION(list_length, "(list)", "Return the length of LIST.");
REGISTER_FUNCTION(copy_list, "(list)", "Return a shallow copy of LIST.");
REGISTER_FUNCTION(copy_tree, "(tree)",
"Return a deep copy of TREE and all sublists in it.");
REGISTER_FUNCTION(num_eq, "(n1 n2)",
"Return non-nil if N1 and N2 are equal numerically.")
REGISTER_FUNCTION(num_gt, "(n1 n2)",
"Return non-nil if N1 is greather than N2.")
REGISTER_FUNCTION(and, "(&rest args)",
"Logical and (with short circuit evaluation.)");
REGISTER_FUNCTION(or, "(&rest args)",
"Logical or (with short circuit evaluation.)");
REGISTER_FUNCTION(type_of, "(obj)", "Return the type of OBJ.");
REGISTER_FUNCTION(function_docstr, "(func)",
"Return the documentation string of FUNC.");
REGISTER_FUNCTION(plist_get, "(plist key &opt def pred)", "");
REGISTER_FUNCTION(plist_set, "(plist key value &opt pred)", "");
REGISTER_FUNCTION(plist_rem, "(plist key &opt pred)", "");
REGISTER_FUNCTION(return_from, "(name &opt value)",
"Return from the function named NAME and return VALUE.");
REGISTER_FUNCTION(intern, "(name &opt package included-too)", "");
REGISTER_FUNCTION(intern_soft, "(name &opt default package included-too)",
"");
REGISTER_FUNCTION(condition_case, "(form &rest handlers)", "");
REGISTER_FUNCTION(set_current_package, "(package)", "");
REGISTER_FUNCTION(in_package, "(package)", "");
REGISTER_FUNCTION(current_package, "()", "");
REGISTER_FUNCTION(make_package, "(name)", "");
REGISTER_FUNCTION(register_package, "(package)", "");
REGISTER_FUNCTION(find_package, "(name)", "");
REGISTER_FUNCTION(exported_symbol_p, "(symbol)", "");
REGISTER_FUNCTION(export_symbol, "(symbol)", "");
REGISTER_FUNCTION(import_package, "(source &opt names target)", "");
REGISTER_FUNCTION(hash_table_count, "(table)", "");
REGISTER_FUNCTION(copy_hash_table, "(table)", "");
REGISTER_FUNCTION(package_name, "(package)", "");
REGISTER_FUNCTION(mapsymbols, "(func &opt package)", "");
}
Reference in New Issue View Git Blame Copy Permalink