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

4483 lines
151 KiB
C
Raw Blame History

#include "lisp.h"
// used by static function registering macros
#include "read.h" // IWYU pragma: keep
#include <ctype.h>
#include <errno.h>
#include <stdarg.h>
#include <stdio.h>
#include <string.h>
// TODO switch to stdio
#include <unistd.h>
// used to fix up some indentation or syntax highlighting problems
#define IGNORE() struct __ignored_struct
LispVal *LISP_TYPE_SYMS[N_LISP_TYPES] = {NULL};
// #######################
// # 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,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = false,
.is_special_var = true,
};
DEF_STATIC_STRING(_Qunbound_name, "unbound");
LispSymbol _Qunbound = {
.type = TYPE_SYMBOL,
.name = &_Qunbound_name,
.package = Qnil,
.plist = Qnil,
.function = Qnil,
.value = Qunbound,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = true,
.is_special_var = true,
};
DEF_STATIC_STRING(_Qt_name, "t");
LispSymbol _Qt = {
.type = TYPE_SYMBOL,
.name = &_Qt_name,
.package = Qnil,
.plist = Qnil,
.function = Qnil,
.value = Qt,
.value_doc = Qnil,
.is_const_value = true,
.is_const_func = true,
.is_special_var = true,
};
// ###########################
// # Other important symbols #
// ###########################
DEF_STATIC_SYMBOL(backquote, "`");
DEF_STATIC_SYMBOL(comma, ",");
DEF_STATIC_SYMBOL(comma_at, ",@");
DEF_STATIC_SYMBOL(macro, "macro");
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");
DEF_STATIC_SYMBOL(no_backtrace, "no-backtrace");
DEF_STATIC_SYMBOL(symbol, "symbol");
DEF_STATIC_SYMBOL(integer, "integer");
DEF_STATIC_SYMBOL(float, "float");
DEF_STATIC_SYMBOL(function, "function");
DEF_STATIC_SYMBOL(hash_table, "hash_table");
DEF_STATIC_SYMBOL(user_pointer, "user_pointer");
DEF_STATIC_SYMBOL(package, "package");
DEF_STATIC_SYMBOL(record, "record");
// ############################
// # 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);
*held = refcount_list_push(*held, ((LispSymbol *) obj)->value_doc);
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->props);
*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;
}
case TYPE_RECORD: {
LispRecord *rec = obj;
*held = refcount_list_push(*held, rec->record_type);
for (size_t i = 0; i < rec->length; ++i) {
*held = refcount_list_push(*held, rec->data[i]);
}
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:
case TYPE_RECORD:
// 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->value_doc = Qnil;
self->is_const_value = false;
self->is_const_func = false;
self->is_special_var = 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, LispVal *doc,
bool is_macro, LispVal *props) {
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);
self->doc = refcount_ref(doc);
self->body = refcount_ref(body);
self->props = refcount_ref(props);
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 *make_lisp_record(LispVal *type, size_t length) {
CONSTRUCT_OBJECT(self, LispRecord, TYPE_RECORD);
self->record_type = refcount_ref(type);
self->function = Qnil;
self->data = lisp_malloc(sizeof(LispVal *) * length);
for (size_t i = 0; i < length; ++i) {
self->data[i] = Qnil;
}
self->length = length;
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 Qhash_table_p;
case TYPE_USER_POINTER:
return Quser_pointer_p;
case TYPE_PACKAGE:
return Qpackagep;
case TYPE_RECORD:
return Qrecordp;
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);
LISP_TYPE_SYMS[TYPE_STRING] = Qstring;
LISP_TYPE_SYMS[TYPE_SYMBOL] = Qsymbol;
LISP_TYPE_SYMS[TYPE_PAIR] = Qpair;
LISP_TYPE_SYMS[TYPE_INTEGER] = Qinteger;
LISP_TYPE_SYMS[TYPE_FLOAT] = Qfloat;
LISP_TYPE_SYMS[TYPE_VECTOR] = Qvector;
LISP_TYPE_SYMS[TYPE_FUNCTION] = Qfunction;
LISP_TYPE_SYMS[TYPE_HASHTABLE] = Qhash_table;
LISP_TYPE_SYMS[TYPE_USER_POINTER] = Quser_pointer;
LISP_TYPE_SYMS[TYPE_PACKAGE] = Qpackage;
LISP_TYPE_SYMS[TYPE_RECORD] = Qrecord;
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), "(&opt code)",
"Exit with CODE, defaulting to zero.") {
if (!NILP(code) && !INTEGERP(code)) {
Fthrow(Qtype_error, Qnil);
}
Fthrow(Qshutdown_signal, const_list(true, 1, code));
}
DEFUN(id, "id", (LispVal * obj), "(obj)",
"Return a number identifying OBJ uniquely among all currently live "
"objects.") {
return make_lisp_integer((int64_t) obj);
}
DEFUN(eq, "eq", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
"Return non-nil if OBJ1 and OBJ2 are the same object. Objects which are "
"eq also have the same id.") {
return LISP_BOOL(obj1 == obj2);
}
static bool pairs_equal_internal(LispVal *obj1, LispVal *obj2) {
while (PAIRP(obj1) && PAIRP(obj2)
&& !NILP(Fequal(HEAD(obj1), HEAD(obj2)))) {
obj1 = TAIL(obj1);
obj2 = TAIL(obj2);
}
return !PAIRP(obj1) && !NILP(Fequal(obj1, obj2));
}
DEFUN(equal, "equal", (LispVal * obj1, LispVal *obj2), "(obj1 obj2)",
"Return non-nil if OBJ1 and OBJ2 are structurally equal.") {
if (obj1 == obj2) {
return Qt;
} else if (TYPEOF(obj1) != TYPEOF(obj2)) {
return Qnil;
}
switch (TYPEOF(obj1)) {
case TYPE_SYMBOL:
case TYPE_FUNCTION:
case TYPE_PACKAGE:
// only if they are the same object (checked above)
return Qnil;
case TYPE_PAIR:
return LISP_BOOL(pairs_equal_internal(obj1, obj2));
case TYPE_USER_POINTER:
return LISP_BOOL(USERPTR(void *, obj1) == USERPTR(void *, obj2));
case TYPE_STRING:
return Fstrings_equal(obj1, obj2);
case TYPE_INTEGER:
return LISP_BOOL(((LispInteger *) obj1)->value
== ((LispInteger *) obj2)->value);
case TYPE_FLOAT:
return LISP_BOOL(((LispFloat *) obj1)->value
== ((LispFloat *) obj2)->value);
case TYPE_VECTOR: {
LispVector *v1 = (LispVector *) obj1;
LispVector *v2 = (LispVector *) obj2;
if (v1->length != v2->length) {
return Qnil;
}
for (size_t i = 0; i < v1->length; ++i) {
if (!Fequal(v1->data[i], v2->data[i])) {
return Qnil;
}
}
return Qt;
}
case TYPE_HASHTABLE: {
LispHashtable *t1 = (LispHashtable *) obj1;
LispHashtable *t2 = (LispHashtable *) obj2;
if (t1->count != t2->count || NILP(Fequal(t1->eq_fn, t2->eq_fn))
|| NILP(Fequal(t1->hash_fn, t2->hash_fn))) {
return Qnil;
}
HT_FOREACH_VALID_INDEX(t1, i) {
if (NILP(Fequal(HASH_VALUE(t1, i),
gethash(obj2, HASH_KEY(t1, i), Qunbound)))) {
return Qnil;
}
}
return Qt;
}
case TYPE_RECORD: {
// TODO implement this
return Qnil;
}
default:
abort();
}
}
static void breakpoint(int64_t id) {}
DEFUN(breakpoint, "breakpoint", (LispVal * id), "(&opt id)", "Do nothing.") {
if (NILP(id)) {
breakpoint(0);
} else {
CHECK_TYPE(TYPE_INTEGER, id);
breakpoint(((LispInteger *) id)->value);
}
return Qnil;
}
DEFUN(not, "not", (LispVal * obj), "(obj)",
"Return t if OBJ is nil, otherwise, return nil.") {
return NILP(obj) ? Qt : Qnil;
}
DEFUN(
type_of, "type-of", (LispVal * obj), "(obj)",
"Return a symbol that describes the type of OBJ. This is for informational "
"purposes only, don't use this to test for objects of a specific type.") {
if (TYPEOF(obj) != TYPE_RECORD) {
return refcount_ref(LISP_TYPE_SYMS[TYPEOF(obj)]);
} else {
return refcount_ref(((LispRecord *) obj)->record_type);
}
}
DEFUN(user_pointer_p, "user-pointer-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a user pointer.") {
return LISP_BOOL(USER_POINTER_P(val));
}
DEFUN(callablep, "callablep", (LispVal * val), "(obj)",
"Return non-nil if OBJ is callable.") {
if (FUNCTIONP(val)) {
return refcount_ref(val);
} else if (SYMBOLP(val)) {
return Fcallablep(Fsymbol_function(val, Qt));
} else if (PAIRP(val) && HEAD(val) == Qlambda) {
return refcount_ref(val);
} else if (CALLABLE_RECORD_P(val)) {
return Fcallablep(((LispRecord *) val)->function);
}
return Qnil;
}
DEFUN(native_type_p, "native-type-p", (LispVal * sym), "(sym)",
"Return non-nil if SYM names a native type.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
for (size_t i = 0; i < N_LISP_TYPES; ++i) {
if (!NILP(Feq(LISP_TYPE_SYMS[i], sym))) {
return Qt;
}
}
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(elt, lexenv), Qnil);
refcount_unref(HEAD(final_args));
end = final_args;
} else {
LispVal *new_end = Fpair(Feval(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(func->rest_arg)) {
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 new_lexical_var(LispVal **lexenv, LispVal *name, LispVal *value) {
if (SPECIALP(name)) {
push_to_lexenv(&the_stack->dynenv, name, value);
} else {
push_to_lexenv(lexenv, name, value);
}
}
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
}
new_lexical_var(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));
new_lexical_var(lexenv, oad->name, arg);
if (!NILP(oad->pred_var)) {
new_lexical_var(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);
new_lexical_var(lexenv, oad->name, value);
if (!NILP(oad->pred_var)) {
new_lexical_var(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;
}
}
new_lexical_var(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, the_stack->lexenv);
new_lexical_var(lexenv, oad->name, eval_res);
refcount_unref(eval_res);
if (!NILP(oad->pred_var)) {
new_lexical_var(lexenv, oad->pred_var, Qnil);
}
}
}
FOREACH(arg, oargs) {
struct OptArgDesc *oad = USERPTR(struct OptArgDesc, arg);
LispVal *default_val = Feval(oad->default_form, the_stack->lexenv);
new_lexical_var(lexenv, oad->name, default_val);
refcount_unref(default_val);
if (!NILP(oad->pred_var)) {
new_lexical_var(lexenv, oad->pred_var, Qnil);
}
}
if (!NILP(func->rest_arg)) {
new_lexical_var(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(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),
"(entry dest)", "Internal function.") {
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 *) Fcallablep(func);
if (PAIRP(fobj)) {
LispVal *real_fobj = Feval(LISPVAL(fobj), args_lexenv);
refcount_unref(fobj);
fobj = (LispFunction *) real_fobj;
}
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), 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 inline LispVal *find_dynamic_value_on_stack(LispVal *key) {
if (!the_stack) {
return Qunbound;
}
return Fplist_get(the_stack->dynenv, key, Qunbound, Qnil);
}
static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
CHECK_TYPE(TYPE_SYMBOL, key);
if (SPECIALP(key)) {
LispVal *local = find_dynamic_value_on_stack(key);
if (local != Qunbound) {
return local;
}
} else if (!NILP(lexenv)) {
LispVal *local = find_in_lexenv(lexenv, key);
if (local != Qunbound) {
return local;
}
}
LispVal *sym_val = Fsymbol_value(key, Qt);
if (sym_val != Qunbound) {
return sym_val;
}
Fthrow(Qvoid_variable_error, const_list(true, 1, key));
}
DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), "(eval &opt lexenv)",
"Evaluate FORM in the lexical environment 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:
case TYPE_RECORD:
// the above all are self-evaluating
return refcount_ref(form);
case TYPE_SYMBOL:
if (KEYWORDP(form)) {
return refcount_ref(form);
} else {
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(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(funcall, "funcall", (LispVal * function, LispVal *rest),
"(function &rest args)", "Call FUNCTION with ARGS as its arguments.") {
return call_function(function, rest, Qnil, false, false);
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest),
"(function &rest args)",
"Call FUNCTION with ARGS as its arguments. If the last element of ARGS "
"is a list, use its elements as arguments as well.") {
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),
"(form &opt lexical-macros)",
"Expand the toplevel macro one time in FORM. LEXICAL-MACROS is a plist "
"of symbols and functions that are considered to be addition macros to "
"expand. LEXICAL-MACROS take priority over global 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 if (PAIRP(HEAD(form)) && HEAD(HEAD(form)) == Qlambda) {
fobj = (LispFunction *) Feval(HEAD(form), the_stack->lexenv);
assert(FUNCTIONP(fobj));
} 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(fobj), 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), "(form &opt lexical-macros)",
"Expand the toplevel of FORM until it is no longer a macro. "
"LEXICAL-MACROS is the same as for macroexpand-1.") {
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),
"(name tag value)", " Internal function.") {
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, the_stack->lexenv)));
}
}
Fthrow(Qreturn_frame_error, const_list(false, 2, refcount_ref(name),
Feval(value, the_stack->lexenv)));
}
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) Flambda) {
if (!LISTP(args)) {
return;
}
LispVal *expand_from = TAIL(args); // skip lambda list
if (!LISTP(expand_from)) {
return;
}
LispVal *copy = Fcopy_list(HEAD(args));
Fsethead(args, copy);
refcount_unref(copy);
expand_lambda_list(HEAD(args), 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), "(form &opt lexical-macros)",
"Expand all macros in the toplevel and arguments of FORM. LEXICAL-MACROS "
"is as it is for macroexpand-1.") {
return filter_body_form(form, macroexpand_toplevel_as_callback,
lexical_macros);
}
// #################
// # Special Forms #
// #################
DEFMACRO(quote, "'", (LispVal * form), "(form)", "Return FORM.") {
return refcount_ref(form);
}
DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil),
"(cond then &rest else)",
"If COND evaluates to a non-nil value, evaluate THEN, otherwise, "
"evaluate each form in ELSE.") {
LispVal *res = Feval(cond, the_stack->lexenv);
LispVal *retval = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
if (!NILP(res)) {
retval = Feval(t, the_stack->lexenv);
} else {
retval = Fprogn(nil);
}
});
return retval;
}
static void set_symbol_in_lexenv(LispVal *key, LispVal *newval,
LispVal *lexenv) {
if (VALUE_CONSTANTP(key)) {
Fthrow(Qconstant_value_error, Fpair(key, Qnil));
}
LispVal *val_pair = Qnil;
if (SPECIALP(key)) {
val_pair = Fplist_assoc(the_stack->dynenv, key, Qnil);
} else {
val_pair = Fplist_assoc(lexenv, key, Qnil);
}
if (PAIRP(val_pair)) {
Fsethead(TAIL(val_pair), newval);
} else {
refcount_unref(((LispSymbol *) key)->value);
((LispSymbol *) key)->value = refcount_ref(newval);
}
}
DEFMACRO(
setq, "setq", (LispVal * args), "(&rest args)",
"ARGS is a plist of symbols and values. Set each of the symbols to their "
"respective value. Return the last value. Each symbol is set lexically if "
"a lexical binding exists. Otherwise the symbol's value is altered.") {
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), the_stack->lexenv);
WITH_CLEANUP(retval, {
set_symbol_in_lexenv(name, retval, the_stack->lexenv); //
});
}
return retval;
}
DEFMACRO(progn, "progn", (LispVal * forms), "(&rest forms)",
"Evaluate each of FORMS.") {
LispVal *retval = Qnil;
FOREACH(form, forms) {
refcount_unref(retval);
retval = Feval(form, the_stack->lexenv);
}
return retval;
}
DEFMACRO(
condition_case, "condition-case", (LispVal * form, LispVal *rest),
"(form &rest handlers)",
"Evaluate FORM. If an exception is thrown, evaluate the corresponding "
"handler.\n"
"Each handler is HANDLERS is a list with the head being a list of a "
"variable followed by a symbol or a list of symbols and the tail "
"being any number of forms. Each symbol is an error to catch. During "
"the executing of the following forms, the variable will be bound to "
"information about the exception.\n"
"Optionally, the symbols :success or :finally can be used in place of an "
"error or list of errors. :finally forms will be weather or not an error "
"is caught after FORM is done being evaluated. :success forms will be run "
"if the evaluation of FORM finished with no errors.") {
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, the_stack->lexenv);
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, the_stack->lexenv)); //
});
cancel_cleanup(cl_handler);
}
return retval;
}
// true if the form was a declare form
static bool parse_function_declare(LispVal *form, LispVal **name_ptr,
bool *is_macro_ptr, LispVal *props_ht) {
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));
} else if (is_macro_ptr
&& (elt == Qmacro
|| (PAIRP(elt) && HEAD(elt) == Qmacro))) {
*is_macro_ptr = true;
} else if (SYMBOLP(elt)) {
puthash(props_ht, elt, Qt);
} else if (PAIRP(elt) && SYMBOLP(HEAD(elt)) && LISTP(TAIL(elt))) {
puthash(props_ht, HEAD(elt), 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(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)",
"Return a new function.") {
LispVal *doc = Qnil;
if (STRINGP(HEAD(body))) {
doc = HEAD(body);
body = TAIL(body);
}
LispVal *name = Qunbound;
bool is_macro = false;
LispVal *props_ht = make_lisp_hashtable(Qnil, Qnil);
if (parse_function_declare(HEAD(body), &name, &is_macro, props_ht)) {
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 {
if (!SYMBOLP(name)) {
refcount_unref(props_ht);
CHECK_TYPE(TYPE_SYMBOL, name);
}
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
tag_name = name;
}
LispVal *func = Qnil;
WITH_CLEANUP(props_ht, {
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,
doc, is_macro, props_ht);
});
});
});
});
return func;
}
DEFMACRO(while, "while", (LispVal * cond, LispVal *body), "(cond &rest body)",
"Evaluate COND, if its result is non-nil evaluate BODY. Repeat this "
"until COND returns nil. Then return nil.") {
LispVal *evaled_cond;
while (!NILP(evaled_cond = Feval(cond, the_stack->lexenv))) {
refcount_unref(evaled_cond);
refcount_unref(Fprogn(body));
}
return Qnil;
}
DEFMACRO(and, "and", (LispVal * rest), "(&rest rest)",
"Evaluate the first argument in REST. If its result is non-nil "
"evaluate the next argument. Otherwise, return nil. Repeat this until "
"one argument returns nil or there are no arguments left. If no "
"argument returned nil, return the result of the last argument.") {
LispVal *retval = Qnil;
FOREACH(cond, rest) {
LispVal *nc;
WITH_CLEANUP(retval, {
nc = Feval(cond, the_stack->lexenv); //
});
if (NILP(nc)) {
return Qnil;
}
retval = nc;
}
return retval;
}
DEFMACRO(or, "or", (LispVal * rest), "(&rest rest)",
"Evaluate the first argument in REST. If it returns non-nil, return "
"its value. Oterwise, evaluate the next argument. Repeat this until "
"there are no more arguments at which time nil is returned.") {
FOREACH(cond, rest) {
LispVal *nc = Feval(cond, the_stack->lexenv);
if (!NILP(nc)) {
return nc;
}
}
return Qnil;
}
DEFMACRO(in_package, "in-package", (LispVal * package), "(package)",
"Set the current package to PACKAGE.") {
return Fset_current_package(package);
}
DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value),
"(name &opt value)", "Return VALUE from the function named NAME.") {
Fthrow(Qreturn_frame_error, const_list(false, 2, refcount_ref(name),
Feval(value, the_stack->lexenv)));
}
// ######################
// # Function Functions #
// ######################
DEFUN(functionp, "functionp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a non-macro function object or a symbol whose "
"value as a function resolves to a non-macro function object.") {
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),
"(obj &opt lexical-macros)",
"Return non-nil if OBJ is a macro object, a symbol whose value as a "
"function resolves to a macro object, or a symbol with a definition in "
"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), "(obj)",
"Return non-nil if OBJ is a built-in function or a symbol whose value as "
"a function resolves to a built-in function.") {
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), "(obj)",
"Return non-nil if OBJ is a special-function (built-in macro) or a "
"symbol whose value as a function resolves to such a function.") {
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), "(func)",
"Return the documentation string for FUNC, or nil if it has no "
"documentation string.") {
if (FUNCTIONP(func)) {
return ((LispFunction *) func)->doc;
}
LispFunction *fobj = (LispFunction *) Fsymbol_function(func, Qt);
if (!FUNCTIONP(fobj)) {
refcount_unref(fobj);
CHECK_TYPE(TYPE_FUNCTION, fobj);
}
LispVal *retval = refcount_ref(fobj->doc);
refcount_unref(fobj);
return retval;
}
DEFUN(function_properties, "function-properties", (LispVal * func), "(func)",
"Return the property hash table of FUNC.") {
CHECK_TYPE(TYPE_FUNCTION, func);
return refcount_ref(((LispFunction *) func)->props);
}
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), "(obj)",
"Return non-nil if OBJ is a pair.") {
return LISP_BOOL(PAIRP(val));
}
DEFUN(atom, "atom", (LispVal * val), "(obj)",
"Return non-nil if OBJ is not a pair. Nil is not a pair.") {
return LISP_BOOL(ATOM(val));
}
DEFUN(pair, "pair", (LispVal * head, LispVal *tail), "(head tail)",
"Construct a new pair from HEAD and TAIL.") {
return make_lisp_pair(head, tail);
}
DEFUN(head, "head", (LispVal * list), "(list)",
"Return the first element in LIST.") {
return refcount_ref(HEAD(list));
}
DEFUN(tail, "tail", (LispVal * list), "(list)",
"Return everything but the first element in LIST.") {
return refcount_ref(TAIL(list));
}
DEFUN(sethead, "sethead", (LispVal * pair, LispVal *head), "(pair head)",
"Set the head of PAIR to 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), "(pair tail)",
"Set the tail of PAIR to 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), "(obj)",
"Return non-nil if OBJ is a pair or nil.") {
return LISP_BOOL(LISTP(val));
}
DEFUN(list_length, "list-length", (LispVal * list), "(list)",
"Return the length of LIST. Throw an error if LIST is circular.") {
return make_lisp_integer(list_length(list));
}
DEFUN(copy_list, "copy-list", (LispVal * list), "(list)",
"Return a shallow copy of 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), "(tree)",
"Return a copy of TREE and each sub-tree of 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),
"(plist key &opt def pred)",
"Find and return the value associated with KEY in PLIST. If it is not "
"found, return DEF. Keys are compared with 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),
"(plist key value &opt pred)",
"Set the value associated with KEY in PLIST to VALUE. Keys are compared "
"with PRED. Return the modified PLIST.") {
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),
"(plist key &rest pred)",
"Removed KEY and its associated value from PLIST. Keys are compared with "
"PRED. Return the modified PLIST.") {
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), "(plist key &rest pred)",
"Return the sub-list starting with KEY from PLIST. Keys are compared "
"with PRED.") {
for (LispVal *cur = plist; !NILP(cur); cur = TAIL(TAIL(cur))) {
if (call_eq_pred(pred, key, HEAD(cur))) {
return cur;
}
}
return Qnil;
}
// #####################
// # 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), "(obj)",
"Return non-nil if OBJ is a package object.") {
return LISP_BOOL(PACKAGEP(val));
}
DEFUN(make_package, "make-package", (LispVal * name), "(name)",
"Return a new un-registed package object called 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), "(package)",
"Return the name of PACKAGE.") {
CHECK_TYPE(TYPE_PACKAGE, package);
return LISPVAL(((LispPackage *) package)->name);
}
DEFUN(register_package, "register-package", (LispVal * package), "(package)",
"Register PACKAGE with the reader.") {
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 the current package.") {
return refcount_ref(current_package);
}
DEFUN(set_current_package, "set-current-package", (LispVal * package),
"(package)", "Set the current 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),
"(func &opt package)",
"Call FUNC for each symbol in PACKAGE, defaulting to the current "
"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), "(symbol)",
"Mark SYMBOL as exported from its package. If SYMBOL is not interned in "
"any package, throw and error.") {
if (SYMBOLP(symbol)) {
LispSymbol *sym = (LispSymbol *) symbol;
LispPackage *pkg = (LispPackage *) sym->package;
if (NILP(pkg)) {
Fthrow(Qtype_error, Qnil);
}
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),
"(source names &opt target)",
"Import each symbol with a name in NAMES from SOURCE into "
"TARGET. TARGET defaults to the current package. If NAMES "
"is t, import every symbol exported by SOURCE.") {
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), "(name)",
"Return the package named NAME registered with the reader, if one "
"exists.") {
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), "(obj)",
"Return non-nil if OBJ is a symbol.") {
return LISP_BOOL(SYMBOLP(val));
}
DEFUN(keywordp, "keywordp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a symbol interned in the kw package.") {
return LISP_BOOL(KEYWORDP(val));
}
DEFUN(const_value_p, "const-value-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ's value is constant.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(VALUE_CONSTANTP(val));
}
DEFUN(const_func_p, "const-func-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ's value as a function is constant.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(FUNC_CONSTANTP(val));
}
DEFUN(specialp, "specialp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a special variable.") {
CHECK_TYPE(TYPE_SYMBOL, val);
return LISP_BOOL(SPECIALP(val));
}
DEFUN(make_symbol, "make-symbol", (LispVal * name), "(name)",
"Return a new uninterned symbol named NAME.") {
return make_lisp_symbol(name);
}
DEFUN(make_symbol_special, "make-symbol-special", (LispVal * sym), "(sym)",
"Make it so that SYM is a special symbol, that is, it is dynamically "
"bound.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
if (VALUE_CONSTANTP(sym)) {
Fthrow(Qconstant_value_error, Fpair(sym, Qnil));
}
((LispSymbol *) sym)->is_special_var = true;
return refcount_ref(sym);
}
DEFUN(symbol_package, "symbol-package", (LispVal * symbol), "(symbol)",
"Return the package of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->package);
}
DEFUN(symbol_name, "symbol-name", (LispVal * symbol), "(symbol)",
"Return the name of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->name);
}
DEFUN(symbol_function, "symbol-function", (LispVal * symbol, LispVal *resolve),
"(symbol &opt resolve)",
"Return the value as a function of SYMBOL. If RESOLVE is non-nil and the "
"value is also a non-nil symbol, repeat this process.") {
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(fset, "fset", (LispVal * sym, LispVal *new_func), "(symbol func)",
"Set the value as a function of SYMBOL to FUNC.") {
CHECK_TYPE(TYPE_SYMBOL, sym);
LispSymbol *sobj = ((LispSymbol *) sym);
if (FUNC_CONSTANTP(sobj)) {
Fthrow(Qconstant_function_error, Fpair(sym, Qnil));
}
refcount_ref(new_func);
refcount_unref(sobj->function);
sobj->function = new_func;
return refcount_ref(new_func);
}
DEFUN(symbol_value, "symbol-value", (LispVal * symbol, LispVal *default_only),
"(symbol &opt default-only)", "Return the global value of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (KEYWORDP(symbol)) {
return refcount_ref(symbol);
} else if (SPECIALP(symbol) && NILP(default_only)) {
LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
if (!NILP(dynenv_entry)) {
return refcount_ref(HEAD(TAIL(dynenv_entry)));
}
}
return refcount_ref(((LispSymbol *) symbol)->value);
}
DEFUN(set, "set", (LispVal * symbol, LispVal *value, LispVal *default_only),
"(symbol value &opt default-only)",
"Set the global value of SYMBOL to VALUE.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (VALUE_CONSTANTP(symbol)) {
Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
}
if (SPECIALP(symbol) && NILP(default_only)) {
LispVal *dynenv_entry = Fplist_assoc(the_stack->dynenv, symbol, Qnil);
if (!NILP(dynenv_entry)) {
Fsethead(TAIL(dynenv_entry), value);
return refcount_ref(value);
}
}
LispSymbol *sobj = (LispSymbol *) symbol;
refcount_unref(sobj->value);
sobj->value = refcount_ref(value);
return refcount_ref(value);
}
DEFUN(symbol_value_docstr, "symbol-value-docstr", (LispVal * symbol),
"(symbol)", "Return the documentation for SYMBOL's value.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->value_doc);
}
DEFUN(set_symbol_value_docstr, "set-symbol-value-docstr",
(LispVal * symbol, LispVal *docstr), "(symbol value)",
"Set the documentation for SYMBOL's value.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
if (VALUE_CONSTANTP(symbol)) {
Fthrow(Qconstant_value_error, Fpair(symbol, Qnil));
}
LispSymbol *sobj = (LispSymbol *) symbol;
refcount_unref(sobj->value_doc);
sobj->value_doc = refcount_ref(docstr);
return refcount_ref(docstr);
}
DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol), "(symbol)",
"Return the plist of SYMBOL.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->plist);
}
DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist),
"(symbol plist)", "Set the plist of SYMBOL to PLIST.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
LispSymbol *real = (LispSymbol *) symbol;
refcount_unref(real->plist);
real->plist = refcount_ref(plist);
return Qnil;
}
DEFUN(exported_symbol_p, "exported-symbol-p", (LispVal * symbol), "(symbol)",
"Return non-nil if SYMBOL is exported by its package.") {
CHECK_TYPE(TYPE_SYMBOL, symbol);
LispSymbol *sym = (LispSymbol *) symbol;
if (NILP(sym->package)) {
return Qnil;
} else if (KEYWORDP(symbol)) {
return Qt;
}
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),
"(name &opt def package included-too)",
"If a symbol named NAME is interned in PACKAGE, return it. Otherwise, "
"return DEF. If INCLUDED-TOO is non-nil also check symbol imported by "
"PACKAGE.") {
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),
"(name &opt package included-too)",
"If a SYMBOL named NAME is interned in PACKAGE, return it, otherwise, "
"intern a new symbol into PACKAGE. If INCLUDED-TOO is non-nil, also "
"search imported symbols of PACKAGE.") {
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;
}
DEFUN(quote_symbol_name, "quote-symbol-name", (LispVal * name), "(name)",
"Quote NAME such that it could be read back by the reader as a symbol "
"called NAME.") {
CHECK_TYPE(TYPE_STRING, name);
LispString *str = (LispString *) name;
size_t out_len = str->length;
char *out = lisp_malloc(str->length + 1);
for (size_t i = 0, oi = 0; i < str->length; ++i, ++oi) {
char c = str->data[i];
if (c == ':' || c == '`' || c == ',' || c == '\'' || c == '"'
|| isspace(c) || c == '(' || c == ')' || c == '[' || c == ']') {
out = lisp_realloc(out, ++out_len + 1);
out[oi++] = '\\';
}
out[oi] = str->data[i];
}
out[out_len] = '\0';
return make_lisp_string(out, out_len, true, false);
}
DEFUN(symbol_accessible_p, "symbol-accessible-p",
(LispVal * symbol, LispVal *package), "(symbol &opt package)",
"Return non-nil if SYMBOL is interned in PACKAGE or transiently imported "
"into it.") {
LispVal *name = Fsymbol_name(symbol);
LispVal *found;
WITH_CLEANUP(name, {
found = Fintern_soft(name, Qunbound, package, Qt); //
});
bool res = found == symbol;
refcount_unref(found);
return LISP_BOOL(res);
}
DEF_STATIC_SYMBOL(kw_as_needed, "as-needed");
DEFUN(quote_symbol_for_read, "quote-symbol-for-read",
(LispVal * target, LispVal *include_package, LispVal *from),
"(target &opt include-package from)",
"Quote TARGET, as symbol, such that a symbol with the same name as it "
"will read by the reader. If INCLUDE-PACKAGE is :as-needed, add the "
"package if it would be required to read back from the package FROM. If "
"it is any other non-nil value, add the package regardless.") {
CHECK_TYPE(TYPE_SYMBOL, target);
LispSymbol *sym = (LispSymbol *) target;
LispString *sym_name =
(LispString *) Fquote_symbol_name(LISPVAL(sym->name));
if (KEYWORDP(target)) {
size_t size = sym_name->length + 1;
char *new_name = lisp_malloc(size + 1);
snprintf(new_name, size + 1, ":%s", sym_name->data);
refcount_unref(sym_name);
return make_lisp_string(new_name, size, true, false);
} else if (NILP(include_package)) {
return LISPVAL(sym_name);
} else if (include_package == Qkw_as_needed) {
void *cl_handler =
register_cleanup(&refcount_unref_as_callback, sym_name);
bool accessible = !NILP(Fsymbol_accessible_p(LISPVAL(sym), from));
cancel_cleanup(cl_handler);
if (accessible) {
return LISPVAL(sym_name);
}
// otherwise, go on to print the package
}
if (NILP(sym->package)) {
size_t size = sym_name->length + 2;
char *new_name = lisp_malloc(size + 1);
snprintf(new_name, size + 1, "::%s", sym_name->data);
refcount_unref(sym_name);
return make_lisp_string(new_name, size, true, false);
}
LispString *pkg_name = (LispString *) Fquote_symbol_name(
LISPVAL(((LispPackage *) sym->package)->name));
if (NILP(Fexported_symbol_p(LISPVAL(sym)))) {
size_t size = pkg_name->length + sym_name->length + 2;
char *new_name = lisp_malloc(size + 1);
snprintf(new_name, size + 1, "%s::%s", pkg_name->data, sym_name->data);
refcount_unref(pkg_name);
refcount_unref(sym_name);
return make_lisp_string(new_name, size, true, false);
} else {
size_t size = pkg_name->length + sym_name->length + 1;
char *new_name = lisp_malloc(size + 1);
snprintf(new_name, size + 1, "%s:%s", pkg_name->data, sym_name->data);
refcount_unref(pkg_name);
refcount_unref(sym_name);
return make_lisp_string(new_name, size, true, false);
}
}
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(hash_table_p, "hash-table-p", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a hash table.") {
return LISP_BOOL(HASHTABLEP(val));
}
DEFUN(make_hash_table, "make-hash-table", (LispVal * hash_fn, LispVal *eq_fn),
"(&opt hash-fn eq-fn)",
"Create a new hash table with hash function HASH-FN, defaulting to id, "
"and equality test EQ-FN, defaulting to eq.") {
return make_lisp_hashtable(eq_fn, hash_fn);
}
DEFUN(copy_hash_table, "copy-hash-table", (LispVal * table), "(table)",
"Return a copy of TABLE.") {
CHECK_TYPE(TYPE_HASHTABLE, table);
LispHashtable *src = (LispHashtable *) table;
CONSTRUCT_OBJECT(copy, LispHashtable, TYPE_HASHTABLE);
copy->table_size = src->table_size;
copy->count = src->count;
copy->eq_fn = refcount_ref(src->eq_fn);
copy->hash_fn = refcount_ref(src->hash_fn);
copy->key_vals =
lisp_malloc0(sizeof(struct HashtableEntry) * copy->table_size);
HT_FOREACH_VALID_INDEX(src, i) {
copy->key_vals[i].key = refcount_ref(src->key_vals[i].key);
copy->key_vals[i].hash = src->key_vals[i].hash;
copy->key_vals[i].value = refcount_ref(src->key_vals[i].value);
}
return LISPVAL(copy);
}
DEFUN(hash_table_count, "hash-table-count", (LispVal * table), "(table)",
"Return the number of entries in TABLE.") {
CHECK_TYPE(TYPE_HASHTABLE, table);
return make_lisp_integer(((LispHashtable *) table)->count);
}
DEFUN(maphash, "maphash", (LispVal * func, LispVal *table), "(func table)",
"Call FUNC for each key-value pair in TABLE. FUNC may modify table only "
"by altering the current entry.") {
HT_FOREACH_VALID_INDEX(table, i) {
LispVal *args =
const_list(true, 2, HASH_KEY(table, i), HASH_VALUE(table, i));
WITH_CLEANUP(args, {
refcount_unref(Ffuncall(func, args)); //
});
}
return Qnil;
}
DEFUN(
puthash, "puthash", (LispVal * table, LispVal *key, LispVal *value),
"(table key value)",
"Associate VALUE with KEY in TABLE, overriding any current association.") {
return refcount_ref(puthash(table, key, value));
}
DEFUN(gethash, "gethash", (LispVal * table, LispVal *key, LispVal *def),
"(table key &opt def)",
"Return the VALUE associated with KEY in table, or DEF is no such "
"mapping exists.") {
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, LispVal *def),
"(table key &opt def)",
"Remove the value associated with KEY from TABLE. Return the removed "
"value or DEF if no association was found.") {
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);
}
}
void remhash(LispVal *table, LispVal *key) {
refcount_unref(Fremhash(table, key, Qnil));
}
// #####################
// # Numeric Functions #
// #####################
DEFUN(integerp, "integerp", (LispVal * val), "(obj)",
"Return non-nil of OBJ is an integer.") {
return LISP_BOOL(INTEGERP(val));
}
DEFUN(floatp, "floatp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a float.") {
return LISP_BOOL(FLOATP(val));
}
DEFUN(num_eq, "=", (LispVal * n1, LispVal *n2), "(n1 n2)",
"Return non-nil if N1 and N2 are numerically equal.") {
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), "(n1 n2)",
"Return non-nil if N1 is greater than 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 {
Fthrow(Qtype_error, Qnil);
}
}
DEFUN(add, "+", (LispVal * args), "(&rest nums)", "Return the sum of NUMS.") {
if (NILP(args)) {
return make_lisp_integer(0);
}
LispVal *out = copy_number(HEAD(args));
FOREACH(arg, TAIL(args)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
ONE_MATH_OPERAION(+, out, out, arg); //
});
}
return out;
}
DEFUN(sub, "-", (LispVal * args), "(&rest nums)",
"Subtract from the first number in NUMS each other number in NUMS.") {
if (NILP(args)) {
return make_lisp_integer(0);
}
LispVal *out = copy_number(HEAD(args));
FOREACH(arg, TAIL(args)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
ONE_MATH_OPERAION(-, out, out, arg); //
});
}
return out;
}
DEFUN(mul, "*", (LispVal * args), "(nums)", "Return the product of NUMS.") {
if (NILP(args)) {
return make_lisp_integer(1);
}
LispVal *out = copy_number(HEAD(args));
FOREACH(arg, TAIL(args)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
ONE_MATH_OPERAION(*, out, out, arg); //
});
}
return out;
}
DEFUN(div, "/", (LispVal * first, LispVal *rest), "(first &rest rest)",
"If REST is nil, return the reciprocal of FIRST. Otherwise, return FIRST "
"divided by the product of REST.") {
if (NILP(rest)) {
if (INTEGERP(first)) {
return make_lisp_float(1.0 / ((LispInteger *) first)->value);
} else if (FLOATP(first)) {
return make_lisp_float(1.0 / ((LispFloat *) first)->value);
} else {
Fthrow(Qtype_error, Qnil);
}
}
LispVal *out = copy_number(HEAD(rest));
FOREACH(arg, TAIL(rest)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
ONE_MATH_OPERAION(*, out, out, arg); //
});
}
if (FLOATP(first)) {
LispVal *old_out = out;
ONE_MATH_OPERAION(/, out, first, out);
refcount_unref(old_out);
} else if (INTEGERP(first)) {
LispVal *old_out = out;
LispVal *ff = make_lisp_float(((LispInteger *) first)->value);
ONE_MATH_OPERAION(/, out, ff, out);
refcount_unref(ff);
refcount_unref(old_out);
} else {
refcount_unref(out);
Fthrow(Qtype_error, Qnil);
}
return out;
}
// ####################
// # Vector Functions #
// ####################
DEFUN(vectorp, "vectorp", (LispVal * val), "(obj)",
"Return non-nil of OBJ is a vector.") {
return LISP_BOOL(VECTORP(val));
}
DEFUN(make_vector, "make-vector",
(LispVal * initial_size, LispVal *initial_elem),
"(initial-size &opt initial-elem)",
"Return a new vector of INITIAL-SIZE with each element being "
"INITIAL-ELEM.") {
CHECK_TYPE(TYPE_INTEGER, initial_size);
int64_t size = ((LispInteger *) initial_size)->value;
if (size < 0) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, initial_size));
}
LispVal **data = lisp_malloc(sizeof(LispVal *) * size);
for (size_t i = 0; i < size; ++i) {
data[i] = refcount_ref(initial_elem);
}
return make_lisp_vector(data, size);
}
DEFUN(vector, "vector", (LispVal * elems), "(&rest elems)",
"Construct a vector form each of ELEMS.") {
if (LISTP(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);
} else if (STRINGP(elems)) {
LispString *str = (LispString *) elems;
LispVal **data = lisp_malloc(sizeof(LispVal *) * str->length);
for (size_t i = 0; i < str->length; ++i) {
data[i] = make_lisp_integer(str->data[i]);
}
return make_lisp_vector(data, str->length);
} else if (VECTORP(elems)) {
LispVector *vec = (LispVector *) elems;
LispVal **data = lisp_malloc(sizeof(LispVal *) * vec->length);
for (size_t i = 0; i < vec->length; ++i) {
data[i] = refcount_ref(vec->data[i]);
}
return make_lisp_vector(data, vec->length);
} else {
Fthrow(Qtype_error,
const_list(false, 3,
const_list(false, 2, Qvectorp, Qstringp, Qlistp),
refcount_ref(elems)));
}
}
DEFUN(vector_length, "vector-length", (LispVal * vec), "(vec-or-str)",
"Return the length of VEC-OR-STR, a vector or string.") {
if (VECTORP(vec)) {
return make_lisp_integer(((LispVector *) vec)->length);
} else if (STRINGP(vec)) {
return make_lisp_integer(((LispString *) vec)->length);
} else {
Fthrow(Qtype_error,
const_list(false, 2, const_list(false, 2, Qvectorp, Qstringp),
refcount_ref(vec)));
}
}
DEFUN(aref, "aref", (LispVal * vec, LispVal *index), "(vec-or-str index)",
"Return the element numbered INDEX in VEC-OR-STR, starting from zero.") {
CHECK_TYPE(TYPE_INTEGER, index);
int64_t idx = ((LispInteger *) index)->value;
if (idx < 0) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
}
if (VECTORP(vec)) {
LispVector *v = (LispVector *) vec;
if (idx >= v->length) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
}
return refcount_ref(v->data[idx]);
} else if (STRINGP(vec)) {
LispString *s = (LispString *) vec;
if (idx >= s->length) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
}
return make_lisp_integer(s->data[idx]);
} else {
Fthrow(Qtype_error,
const_list(false, 2, const_list(false, 2, Qvectorp, Qstringp),
refcount_ref(vec)));
}
}
DEFUN(aset, "aset", (LispVal * vec, LispVal *index, LispVal *elem),
"(vec index elem)", "Set the element at INDEX in VEC to ELEM.") {
CHECK_TYPE(TYPE_INTEGER, index);
CHECK_TYPE(TYPE_VECTOR, vec);
int64_t idx = ((LispInteger *) index)->value;
if (idx < 0) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
}
LispVector *v = (LispVector *) vec;
if (idx >= v->length) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, index));
}
refcount_unref(v->data[idx]);
v->data[idx] = refcount_ref(elem);
return refcount_ref(elem);
}
DEFUN(subvector, "subvector", (LispVal * seq, LispVal *start, LispVal *end),
"(vec-or-str &opt start end)",
"Return a sub-vector or sub-string of VEC-OR-STR between START and END, "
"defaulting to 0 and the length of VEC-OR-STR.") {
if (!NILP(start)) {
CHECK_TYPE(TYPE_INTEGER, start);
}
if (!NILP(end)) {
CHECK_TYPE(TYPE_INTEGER, end);
}
size_t length;
if (VECTORP(seq)) {
length = ((LispVector *) seq)->length;
} else if (STRINGP(seq)) {
length = ((LispString *) seq)->length;
} else {
Fthrow(Qtype_error,
const_list(false, 2, const_list(false, 2, Qstringp, Qvectorp),
seq));
}
int64_t si = 0;
if (!NILP(start)) {
si = ((LispInteger *) start)->value;
if (si < 0 || si > length) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, start));
}
}
int64_t se = 0;
if (NILP(end)) {
se = length;
} else {
se = ((LispInteger *) end)->value;
if (se < 0 || se > length) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, end));
} else if (si > se) {
Fthrow(Qout_of_bounds_error, const_list(true, 1, start));
}
}
if (VECTORP(seq)) {
LispVector *vec = (LispVector *) seq;
size_t subsize = se - si;
LispVal **subarr = lisp_malloc(sizeof(LispVal *) * subsize);
for (size_t i = si, sub_i = 0; i < se; ++i, ++sub_i) {
subarr[sub_i] = refcount_ref(vec->data[i]);
}
return make_lisp_vector(subarr, subsize);
} else {
LispString *str = (LispString *) seq;
size_t subsize = se - si;
char *subarr = lisp_malloc(subsize);
for (size_t i = si, sub_i = 0; i < se; ++i, ++sub_i) {
subarr[sub_i] = str->data[i];
}
return make_lisp_string(subarr, subsize, true, false);
}
}
// ####################
// # String Functions #
// ####################
DEFUN(stringp, "stringp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a string.") {
return LISP_BOOL(STRINGP(val));
}
DEFUN(string, "string", (LispVal * val), "(seq)",
"Convert SEQ—a string, vector, or list—to a string.") {
if (STRINGP(val)) {
return refcount_ref(val);
} else if (VECTORP(val)) {
LispVector *vec = (LispVector *) val;
char *new_chars = lisp_malloc(vec->length);
void *cl_handler = register_cleanup(&lisp_free, new_chars);
for (size_t i = 0; i < vec->length; ++i) {
CHECK_TYPE(TYPE_INTEGER, vec->data[i]);
LispInteger *elt = (LispInteger *) vec->data[i];
if (elt->value < -128 || elt->value > 127) {
Fthrow(Qtype_error, Qnil);
}
new_chars[i] = elt->value;
}
cancel_cleanup(cl_handler);
return make_lisp_string(new_chars, vec->length, true, false);
} else if (PAIRP(val)) {
char *retval;
size_t size = 0;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
char *new_data = NULL;
void *cl_handler = register_cleanup(&free_double_ptr, &new_data);
FOREACH(elt, val) {
CHECK_TYPE(TYPE_INTEGER, elt);
LispInteger *i = (LispInteger *) elt;
if (i->value < -128 || i->value > 127) {
Fthrow(Qtype_error, Qnil);
}
new_data = lisp_realloc(new_data, sizeof(char) * ++size);
new_data[size - 1] = i->value;
}
cancel_cleanup(cl_handler);
retval = new_data;
});
return make_lisp_string(retval, size, true, false);
} else {
Fthrow(Qtype_error,
const_list(false, 2,
const_list(false, 3, Qvectorp, Qstringp, Qlistp),
refcount_ref(val)));
}
}
DEFUN(hash_string, "hash-string", (LispVal * obj), "(str)",
"Return the hash of STR.") {
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),
"(str1 str2)", "Return non-nil if STR1 and STR2 are equal.") {
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);
}
DEFUN(string_to_vector, "string-to-vector", (LispVal * str), "(str)",
"Convert STR to a vector.") {
CHECK_TYPE(TYPE_STRING, str);
LispString *s = (LispString *) str;
LispVal **vdata = lisp_malloc(sizeof(LispVal *) * s->length);
for (size_t i = 0; i < s->length; ++i) {
vdata[i] = make_lisp_integer(s->data[i]);
}
return make_lisp_vector(vdata, s->length);
}
DEFUN(quote_string, "quote-string", (LispVal * target), "(target)",
"Quote TARGET such that it can be read back by the reader.") {
CHECK_TYPE(TYPE_STRING, target);
LispString *str = (LispString *) target;
size_t out_size = str->length + 2;
char *out = lisp_malloc(out_size + 1);
out[0] = '"';
for (size_t i = 0, oi = 1; i < str->length; ++i, ++oi) {
switch (str->data[i]) {
case '\n':
out = lisp_realloc(out, ++out_size + 1);
out[oi++] = '\\';
out[oi] = 'n';
break;
case '\t':
out = lisp_realloc(out, ++out_size + 1);
out[oi++] = '\\';
out[oi] = 't';
break;
case '\r':
out = lisp_realloc(out, ++out_size + 1);
out[oi++] = '\\';
out[oi] = 'r';
break;
case '\0':
out = lisp_realloc(out, ++out_size + 1);
out[oi++] = '\\';
out[oi] = '0';
break;
case '"':
out = lisp_realloc(out, ++out_size + 1);
out[oi++] = '\\';
out[oi] = '"';
break;
case '\\':
out = lisp_realloc(out, ++out_size + 1);
out[oi++] = '\\';
out[oi] = '\\';
break;
default:
out[oi] = str->data[i];
break;
}
}
out[out_size - 1] = '"';
out[out_size] = '\0';
return make_lisp_string(out, out_size, true, false);
}
DEFUN(concat, "concat", (LispVal * strings), "(&rest strings)",
"Concatenate each string in STRINGS.") {
LispVal *retval;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
char *out = lisp_malloc(1);
out[0] = '\0';
size_t size = 0;
void *cl_handler = register_cleanup(&free_double_ptr, &out);
FOREACH(elt, strings) {
if (NILP(elt)) {
continue;
}
CHECK_TYPE(TYPE_STRING, elt);
LispString *s = (LispString *) elt;
size += s->length;
out = lisp_realloc(out, size + 1);
strncat(out, s->data, s->length);
}
cancel_cleanup(cl_handler);
retval = make_lisp_string(out, size, true, false);
});
return retval;
}
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 - 1, 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;
}
// ####################
// # Record Functions #
// ####################
DEFUN(recordp, "recordp", (LispVal * val), "(obj)",
"Return non-nil if OBJ is a record.") {
return LISP_BOOL(RECORDP(val));
}
DEFUN_DISTINGUISHED(make_record, "make-record",
(LispVal * type, LispVal *length),
"(type length &opt native-backing)",
"Return a new record object of TYPE.") {
CHECK_TYPE(TYPE_INTEGER, length);
int64_t real_length = ((LispInteger *) length)->value;
if (real_length < 0) {
Fthrow(Qout_of_bounds_error, Qnil);
}
return make_lisp_record(type, real_length);
}
DEFUN(record_function, "record-function", (LispVal * record), "(record)",
"Return the function associated with RECORD.") {
CHECK_TYPE(TYPE_RECORD, record);
return refcount_ref(((LispRecord *) record)->function);
}
DEFUN(set_record_function, "set-record-function",
(LispVal * record, LispVal *value), "(record value)",
"Set the function of RECORD to VALUE.") {
CHECK_TYPE(TYPE_RECORD, record);
LispRecord *rec = (LispRecord *) record;
refcount_unref(rec->function);
rec->function = refcount_ref(value);
return refcount_ref(value);
}
DEFUN(record_length, "record-length", (LispVal * record), "(record)",
"Return the length of RECORD.") {
CHECK_TYPE(TYPE_RECORD, record);
return make_lisp_integer(((LispRecord *) record)->length);
}
DEFUN(record_slot, "record-slot", (LispVal * record, LispVal *index),
"(obj index)", "Return the INDEXth slot of RECORD.") {
CHECK_TYPE(TYPE_RECORD, record);
CHECK_TYPE(TYPE_INTEGER, index);
LispRecord *rec = (LispRecord *) record;
int64_t real_index = ((LispInteger *) index)->value;
if (real_index < 0 || real_index > rec->length) {
Fthrow(Qout_of_bounds_error, Fpair(index, Qnil));
}
return refcount_ref(rec->data[real_index]);
}
DEFUN(set_record_slot, "set-record-slot",
(LispVal * record, LispVal *index, LispVal *value),
"(record index value)", "Set the INDEXth slot of RECORD to VALUE.") {
CHECK_TYPE(TYPE_RECORD, record);
CHECK_TYPE(TYPE_INTEGER, index);
LispRecord *rec = (LispRecord *) record;
int64_t real_index = ((LispInteger *) index)->value;
if (real_index < 0 || real_index > rec->length) {
Fthrow(Qout_of_bounds_error, Fpair(index, Qnil));
}
refcount_unref(rec->data[real_index]);
rec->data[real_index] = refcount_ref(value);
return Qnil;
}
// ################
// # IO Functions #
// ################
static inline int CHECK_IO_RESULT(int res, int fd) {
if (res < 0) {
if (errno == EBADFD) {
Fthrow(Qtype_error, const_list(false, 1, make_lisp_integer(fd)));
} else {
Fthrow(Qio_error, Qnil);
}
}
return res;
}
static int64_t internal_print(void *obj, int64_t fd, bool readably,
bool first_in_list) {
switch (TYPEOF(obj)) {
case TYPE_STRING: {
if (readably) {
LispVal *quoted = Fquote_string(obj);
int64_t rval = 0;
WITH_CLEANUP(quoted, {
rval = internal_print(quoted, fd, false, true); //
});
return rval;
} else {
LispString *str = obj;
return CHECK_IO_RESULT(write(fd, str->data, str->length), fd);
}
}
case TYPE_SYMBOL: {
LispVal *name = Qnil;
if (readably) {
name = Fquote_symbol_for_read(obj, Qkw_as_needed, Qnil);
} else {
name = refcount_ref(((LispSymbol *) obj)->name);
}
int64_t np;
WITH_CLEANUP(name, {
np = internal_print(name, fd, false, true); //
});
return np;
} break;
case TYPE_PAIR: {
if (HEAD(obj) == Qquote && PAIRP(TAIL(obj)) && NILP(TAIL(TAIL(obj)))) {
int64_t np = CHECK_IO_RESULT(dprintf(fd, "'"), fd);
np += internal_print(HEAD(TAIL(obj)), fd, readably, true);
return np;
}
int64_t np;
if (first_in_list) {
np = CHECK_IO_RESULT(dprintf(fd, "("), fd);
} else {
np = CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += internal_print(HEAD(obj), fd, readably, true);
if (TAIL(obj) == Qnil) {
np = CHECK_IO_RESULT(dprintf(fd, ")"), fd);
} else {
np += internal_print(TAIL(obj), fd, readably, false);
}
return np;
}
case TYPE_VECTOR: {
LispVector *v = obj;
int64_t np = CHECK_IO_RESULT(dprintf(fd, "["), fd);
for (size_t i = 0; i < v->length; ++i) {
np += internal_print(v->data[i], fd, readably, true);
if (i != v->length - 1) {
np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
}
np += CHECK_IO_RESULT(dprintf(fd, "]"), fd);
return np;
}
case TYPE_INTEGER:
return CHECK_IO_RESULT(
dprintf(fd, "%ji", (intmax_t) ((LispInteger *) obj)->value), fd);
case TYPE_FLOAT:
return CHECK_IO_RESULT(dprintf(fd, "%Lf", ((LispFloat *) obj)->value),
fd);
case TYPE_FUNCTION: {
LispFunction *fn = obj;
int64_t np;
bool need_name = true;
if (fn->is_builtin && fn->is_macro) {
np = CHECK_IO_RESULT(dprintf(fd, "<special-form "), fd);
} else if (fn->is_builtin) {
np = CHECK_IO_RESULT(dprintf(fd, "<builtin "), fd);
} else if (fn->is_macro && fn->name == Qlambda) {
np = CHECK_IO_RESULT(dprintf(fd, "<lambda-macro "), fd);
need_name = false;
} else if (fn->is_macro) {
np = CHECK_IO_RESULT(dprintf(fd, "<macro "), fd);
} else if (fn->name == Qlambda) {
np = CHECK_IO_RESULT(dprintf(fd, "<lambda "), fd);
need_name = false;
} else {
np = CHECK_IO_RESULT(dprintf(fd, "<function "), fd);
}
if (need_name) {
np += internal_print(fn->name, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " "), fd);
}
np += CHECK_IO_RESULT(dprintf(fd, "at %#jx>", (uintmax_t) obj), fd);
return np;
}
case TYPE_HASHTABLE: {
LispHashtable *ht = obj;
LispVal *hash_fn = NILP(ht->hash_fn) ? Qid : ht->hash_fn;
LispVal *eq_fn = NILP(ht->eq_fn) ? Qeq : ht->eq_fn;
int64_t np = CHECK_IO_RESULT(
dprintf(fd, "<hash-table size=%ju count=%ju eq-fn=",
(uintmax_t) ht->table_size, (uintmax_t) ht->count),
fd);
np += internal_print(eq_fn, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " hash-fn="), fd);
np += internal_print(hash_fn, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " at %#jx>", (uintmax_t) obj), fd);
return np;
}
case TYPE_USER_POINTER:
return CHECK_IO_RESULT(dprintf(fd, "<user-pointer to %#jx at %#jx>",
(uintmax_t) USERPTR(void *, obj),
(uintmax_t) obj),
fd);
case TYPE_PACKAGE: {
LispPackage *pkg = obj;
int64_t np = CHECK_IO_RESULT(dprintf(fd, "<package "), fd);
LispVal *name_str = Fquote_string(LISPVAL(pkg->name));
WITH_CLEANUP(name_str, {
np += internal_print(name_str, fd, readably, true); //
});
np += CHECK_IO_RESULT(
dprintf(fd, " interned=%ju at %#jx>",
(uintmax_t) ((LispHashtable *) pkg->obarray)->count,
(uintmax_t) obj),
fd);
return np;
} break;
case TYPE_RECORD: {
// TODO implement
LispRecord *rec = (LispRecord *) obj;
int64_t np = CHECK_IO_RESULT(
dprintf(fd,
"<%srecord type=", NILP(rec->function) ? "" : "callable-"),
fd);
np += internal_print(rec->record_type, fd, readably, true);
np += CHECK_IO_RESULT(dprintf(fd, " length=%ju at %#jx>",
(uintmax_t) rec->length, (uintmax_t) obj),
fd);
return np;
} break;
default:
abort();
}
}
DEFUN_DISTINGUISHED(print, "print",
(LispVal * obj, LispVal *readably, LispVal *stream),
"(obj &opt readably stream)",
"Write a human readable representation of OBJ to STREAM, "
"defaulting to the standard output. With READABLY non-nil, "
"print OBJ in a way that it can be read back.") {
int64_t fd;
if (stream == Qunbound) {
fd = 1;
} else {
CHECK_TYPE(TYPE_INTEGER, stream);
fd = ((LispInteger *) stream)->value;
if (fd < 0) {
Fthrow(Qtype_error, const_list(true, 1, stream));
}
}
bool readably_bool = readably != Qunbound && !NILP(readably);
return make_lisp_integer(internal_print(obj, fd, readably_bool, true));
}
DEFUN_DISTINGUISHED(
println, "println", (LispVal * obj, LispVal *readably, LispVal *stream),
"(obj &opt readably stream)",
"Call print with OBJ and STREAM, then write a newline to STREAM. With "
"READABLY non-nil, print OBJ in a way that it can be read back.") {
static char NEWLINE = '\n';
int64_t fd;
if (stream == Qunbound) {
fd = 1;
} else {
CHECK_TYPE(TYPE_INTEGER, stream);
fd = ((LispInteger *) stream)->value;
if (fd < 0) {
Fthrow(Qtype_error, const_list(true, 1, stream));
}
}
int64_t np = 0;
if (obj != Qunbound) {
bool readably_bool = readably != Qunbound && !NILP(readably);
np += internal_print(obj, fd, readably_bool, true);
}
np += CHECK_IO_RESULT(write(fd, &NEWLINE, 1), fd);
fsync(fd);
return make_lisp_integer(np);
}
// ########################
// # Lexenv and the Stack #
// ########################
DEF_STATIC_SYMBOL(kw_success, "success");
DEF_STATIC_SYMBOL(kw_finally, "finally");
DEFUN(backtrace, "backtrace", (void), "()", "Return a backtrace.") {
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;
}
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest), "(signal &rest rest)",
"Throw a signal SIGNAL with data 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, {
WITH_CLEANUP(error_arg, {
if (!NILP(var)) {
CHECK_TYPE(TYPE_SYMBOL, var);
if (VALUE_CONSTANTP(var)) {
Fthrow(Qconstant_value_error, Fpair(var, Qnil));
}
push_to_lexenv(&the_stack->lexenv, var, error_arg);
}
stack_return = Feval(form, the_stack->lexenv); //
});
});
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, the_stack->lexenv)); //
});
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->dynenv = the_stack ? refcount_ref(the_stack->dynenv) : Qnil;
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->dynenv);
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, the_stack->lexenv)); //
})
}
}
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(error, "error");
DEF_STATIC_SYMBOL(type_error, "type-error");
DEF_STATIC_SYMBOL(read_error, "read-error");
DEF_STATIC_SYMBOL(unclosed_error, "read-error");
DEF_STATIC_SYMBOL(constant_function_error, "constant-function-error");
DEF_STATIC_SYMBOL(constant_value_error, "constant-value-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");
DEF_STATIC_SYMBOL(out_of_bounds_error, "out-of-bounds-error");
DEF_STATIC_SYMBOL(io_error, "io-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: {
LispFunction *fobj = obj;
LispVal *name = ((LispFunction *) obj)->name;
if (fobj->is_builtin) {
fprintf(stream, "<builtin ");
} else {
if (name == Qlambda) {
fprintf(stream, "<lambda"); // no space!
name = NULL;
} else if (fobj->is_macro) {
fprintf(stream, "<macro ");
} 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;
case TYPE_RECORD: {
LispRecord *rec = (LispRecord *) obj;
fprintf(stream,
"<%srecord type=", NILP(rec->function) ? "" : "callable-");
debug_dump_real(stream, rec->record_type, true);
fprintf(stream, " length=%ju at %#jx>", (uintmax_t) rec->length,
(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(macro);
REGISTER_SYMBOL(opt);
REGISTER_SYMBOL(allow_other_keys);
REGISTER_SYMBOL(key);
REGISTER_SYMBOL(rest);
REGISTER_SYMBOL(declare);
REGISTER_SYMBOL(name);
REGISTER_SYMBOL(no_backtrace);
REGISTER_SYMBOL(comma);
REGISTER_SYMBOL(comma_at);
REGISTER_SYMBOL(backquote);
REGISTER_SYMBOL(symbol);
REGISTER_SYMBOL(integer);
REGISTER_SYMBOL(float);
REGISTER_SYMBOL(function);
REGISTER_SYMBOL(hash_table);
REGISTER_SYMBOL(user_pointer);
REGISTER_SYMBOL(package);
REGISTER_SYMBOL(record);
REGISTER_KEYWORD(kw_success);
REGISTER_KEYWORD(kw_finally);
REGISTER_KEYWORD(kw_as_needed);
REGISTER_SYMBOL(shutdown_signal);
REGISTER_SYMBOL(error);
REGISTER_SYMBOL(type_error);
REGISTER_SYMBOL(read_error);
REGISTER_SYMBOL(eof_error);
REGISTER_SYMBOL(unclosed_error);
REGISTER_SYMBOL(constant_function_error);
REGISTER_SYMBOL(constant_value_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);
REGISTER_SYMBOL(out_of_bounds_error);
REGISTER_SYMBOL(io_error);
REGISTER_SYMBOL(toplevel);
// some functions that mustn't be user accessible
REGISTER_STATIC_FUNCTION(set_for_return);
REGISTER_STATIC_FUNCTION(internal_real_return);
// ###############################
// # General and Misc. Functions #
// ###############################
REGISTER_FUNCTION(exit);
REGISTER_FUNCTION(id);
REGISTER_FUNCTION(eq);
REGISTER_FUNCTION(equal);
REGISTER_FUNCTION(breakpoint);
REGISTER_FUNCTION(not);
REGISTER_FUNCTION(type_of);
REGISTER_FUNCTION(user_pointer_p);
REGISTER_FUNCTION(callablep);
REGISTER_FUNCTION(native_type_p);
// ##################################
// # Evaluation and Macro Expansion #
// ##################################
REGISTER_FUNCTION(eval);
REGISTER_FUNCTION(funcall);
REGISTER_FUNCTION(apply);
REGISTER_FUNCTION(macroexpand_1);
REGISTER_FUNCTION(macroexpand_toplevel);
REGISTER_FUNCTION(macroexpand_all);
// #################
// # Special Forms #
// #################
REGISTER_FUNCTION(quote);
REGISTER_FUNCTION(if);
REGISTER_FUNCTION(setq);
REGISTER_FUNCTION(progn);
REGISTER_FUNCTION(condition_case);
REGISTER_FUNCTION(lambda);
REGISTER_FUNCTION(while);
REGISTER_FUNCTION(and);
REGISTER_FUNCTION(or);
REGISTER_FUNCTION(in_package);
REGISTER_FUNCTION(return_from);
// ######################
// # Function Functions #
// ######################
REGISTER_FUNCTION(functionp);
REGISTER_FUNCTION(macrop);
REGISTER_FUNCTION(builtinp);
REGISTER_FUNCTION(special_form_p);
REGISTER_FUNCTION(function_docstr);
REGISTER_FUNCTION(function_properties);
// ###########################
// # Pair and List Functions #
// ###########################
REGISTER_FUNCTION(pairp);
REGISTER_FUNCTION(atom);
REGISTER_FUNCTION(pair);
REGISTER_FUNCTION(head);
REGISTER_FUNCTION(tail);
REGISTER_FUNCTION(sethead);
REGISTER_FUNCTION(settail);
// lists
REGISTER_FUNCTION(listp);
REGISTER_FUNCTION(list_length);
REGISTER_FUNCTION(copy_list);
REGISTER_FUNCTION(copy_tree);
// plists
REGISTER_FUNCTION(plist_get);
REGISTER_FUNCTION(plist_set);
REGISTER_FUNCTION(plist_rem);
REGISTER_FUNCTION(plist_assoc);
// #####################
// # Package Functions #
// #####################
REGISTER_FUNCTION(packagep);
REGISTER_FUNCTION(make_package);
REGISTER_FUNCTION(package_name);
REGISTER_FUNCTION(register_package);
REGISTER_FUNCTION(current_package);
REGISTER_FUNCTION(set_current_package);
REGISTER_FUNCTION(mapsymbols);
REGISTER_FUNCTION(export_symbol);
REGISTER_FUNCTION(import_package);
REGISTER_FUNCTION(find_package);
// ####################
// # Symbol Functions #
// ####################
REGISTER_FUNCTION(symbolp);
REGISTER_FUNCTION(keywordp);
REGISTER_FUNCTION(const_value_p);
REGISTER_FUNCTION(const_func_p);
REGISTER_FUNCTION(specialp);
REGISTER_FUNCTION(make_symbol);
REGISTER_FUNCTION(make_symbol_special);
REGISTER_FUNCTION(symbol_package);
REGISTER_FUNCTION(symbol_name);
REGISTER_FUNCTION(symbol_function);
REGISTER_FUNCTION(fset);
REGISTER_FUNCTION(symbol_value);
REGISTER_FUNCTION(set);
REGISTER_FUNCTION(symbol_value_docstr);
REGISTER_FUNCTION(set_symbol_value_docstr);
REGISTER_FUNCTION(symbol_plist);
REGISTER_FUNCTION(setplist);
REGISTER_FUNCTION(exported_symbol_p);
REGISTER_FUNCTION(intern_soft);
REGISTER_FUNCTION(intern);
REGISTER_FUNCTION(quote_symbol_name);
REGISTER_FUNCTION(symbol_accessible_p);
REGISTER_FUNCTION(quote_symbol_for_read);
// ########################
// # Hash Table Functions #
// ########################
REGISTER_FUNCTION(hash_table_p);
REGISTER_FUNCTION(make_hash_table);
REGISTER_FUNCTION(copy_hash_table);
REGISTER_FUNCTION(hash_table_count);
REGISTER_FUNCTION(maphash);
REGISTER_FUNCTION(puthash);
REGISTER_FUNCTION(gethash);
REGISTER_FUNCTION(remhash);
// #####################
// # Numeric Functions #
// #####################
REGISTER_FUNCTION(integerp);
REGISTER_FUNCTION(floatp);
REGISTER_FUNCTION(num_eq);
REGISTER_FUNCTION(num_gt);
REGISTER_FUNCTION(add);
REGISTER_FUNCTION(sub);
REGISTER_FUNCTION(mul);
REGISTER_FUNCTION(div);
// ####################
// # Vector Functions #
// ####################
REGISTER_FUNCTION(vectorp);
REGISTER_FUNCTION(make_vector);
REGISTER_FUNCTION(vector);
REGISTER_FUNCTION(vector_length);
REGISTER_FUNCTION(aref);
REGISTER_FUNCTION(aset);
REGISTER_FUNCTION(subvector);
// ####################
// # String Functions #
// ####################
REGISTER_FUNCTION(stringp);
REGISTER_FUNCTION(string);
REGISTER_FUNCTION(hash_string);
REGISTER_FUNCTION(strings_equal);
REGISTER_FUNCTION(string_to_vector);
REGISTER_FUNCTION(quote_string);
REGISTER_FUNCTION(concat);
// ####################
// # Record Functions #
// ####################
REGISTER_FUNCTION(recordp);
REGISTER_FUNCTION(make_record);
REGISTER_FUNCTION(record_function);
REGISTER_FUNCTION(set_record_function);
REGISTER_FUNCTION(record_length);
REGISTER_FUNCTION(record_slot);
REGISTER_FUNCTION(set_record_slot);
// ################
// # IO Functions #
// ################
REGISTER_FUNCTION(print);
REGISTER_FUNCTION(println);
// ########################
// # Lexenv and the Stack #
// ########################
REGISTER_FUNCTION(backtrace);
REGISTER_FUNCTION(throw);
// ###############
// # From read.c #
// ###############
register_reader_functions();
}
Reference in New Issue View Git Blame Copy Permalink