Zander671/simple-lisp
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Work on function stuff

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-07-03 01:36:25 +09:00
parent e557e58168
commit a19071c35c
5 changed files with 498 additions and 133 deletions
Download Patch File Download Diff File Expand all files Collapse all files

372
src/lisp.c
View File

@ -1,5 +1,7 @@
#include "lisp.h"
#include "read.h"
#include <ctype.h>
#include <stdarg.h>
#include <stdio.h>
@ -90,10 +92,7 @@ void _internal_lisp_delete_object(LispVal *val) {
LispFunction *fn = (LispFunction *) val;
lisp_unref(fn->doc);
lisp_unref(fn->args);
for (size_t i = 0; i < fn->n_kw; ++i) {
lisp_unref(fn->kwargs[i]);
}
lisp_free(fn->kwargs);
lisp_unref(fn->kwargs);
if (!fn->is_builtin) {
lisp_unref(fn->body);
}
@ -176,6 +175,7 @@ LispVal *make_lisp_symbol(LispVal *name) {
self->plist = Qnil;
self->function = Qunbound;
self->value = Qunbound;
self->is_constant = false;
return LISPVAL(self);
}
@ -213,6 +213,116 @@ LispVal *make_lisp_vector(LispVal **data, size_t length) {
return LISPVAL(self);
}
DEF_STATIC_SYMBOL(opt, "&opt");
DEF_STATIC_SYMBOL(key, "&key");
DEF_STATIC_SYMBOL(allow_other_keys, "&allow-other-keys");
DEF_STATIC_SYMBOL(rest, "&rest");
void set_function_args(LispFunction *func, LispVal *args) {
// in case func is static
if (func->args) {
lisp_unref(func->args);
}
if (func->kwargs) {
lisp_unref(func->kwargs);
}
int mode = 0; // required
bool has_opt = false; // mode 1
bool has_key = false; // mode 2
bool has_rest = false; // mode 3
func->n_req = 0;
func->n_opt = 0;
func->has_rest = false;
size_t n_kw = 0;
func->kwargs = lisp_ref(make_lisp_hashtable(Qnil, Qnil));
func->allow_other_keys = false;
FOREACH(arg, args) {
if (!SYMBOLP(arg) || VALUE_CONSTANTP(arg)) {
goto malformed;
} else if (arg == Qopt) {
if (has_opt || mode == 3) {
goto malformed;
}
has_opt = true;
mode = 1;
} else if (arg == Qkey) {
if (has_key || mode == 3) {
goto malformed;
}
has_key = true;
mode = 2;
} else if (arg == Qrest) {
if (has_rest) {
goto malformed;
}
has_rest = true;
mode = 3;
} else if (arg == Qallow_other_keys) {
if (func->allow_other_keys || mode != 2) {
goto malformed;
}
func->allow_other_keys = true;
mode = -1;
} else {
switch (mode) {
case 0:
++func->n_req;
break;
case 1:
++func->n_opt;
break;
case 2: {
LispString *sn = ((LispSymbol *) arg)->name;
char kns[sn->length + 2];
kns[0] = ':';
memcpy(kns + 1, sn->data, sn->length);
kns[sn->length + 1] = '\n';
LispVal *kn =
make_lisp_string(kns, sn->length + 1, false, false);
lisp_ref(kn);
Fputhash(func->kwargs, Fintern(kn), make_lisp_integer(n_kw));
lisp_unref(kn);
} break;
case 3:
if (func->has_rest) {
goto malformed;
}
func->has_rest = true;
mode = -1;
break;
case -1:
goto malformed;
}
}
}
// do this last
func->args = lisp_ref(args);
return;
malformed:
lisp_unref(func->kwargs);
Fthrow(Qmalformed_lambda_list_error, Fpair(args, Qnil));
}
LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv,
LispVal *body, bool is_macro) {
LispFunction *self = lisp_malloc(sizeof(LispFunction));
self->type = TYPE_FUNCTION;
self->ref_count = 0;
self->is_builtin = false;
self->is_macro = is_macro;
self->args = Qnil;
self->kwargs = Qnil;
void *cl = register_cleanup(&free_double_ptr, &self);
set_function_args(self, args);
cancel_cleanup(cl);
// do these after the potential throw
self->doc = lisp_ref(doc);
self->lexenv = lisp_ref(lexenv);
self->body = lisp_ref(body);
return LISPVAL(self);
}
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn) {
LispHashtable *self = lisp_malloc(sizeof(LispHashtable));
self->type = TYPE_HASHTABLE;
@ -292,9 +402,9 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
return !NILP(Fstrings_equal(v1, v2));
} else {
LispVal *eq_obj;
LispVal *args = make_list(2, v1, v2);
LispVal *args = const_list(2, v1, v2);
WITH_CLEANUP(args, {
eq_obj = lisp_ref(Ffuncall(self->eq_fn, args)); //
eq_obj = Ffuncall(self->eq_fn, args); //
});
lisp_ref(eq_obj);
bool result = !NILP(eq_obj);
@ -314,7 +424,7 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
return hash;
} else {
LispVal *hash_obj;
LispVal *args = make_list(1, key);
LispVal *args = const_list(1, key);
WITH_CLEANUP(args, {
hash_obj = Ffuncall(self->hash_fn, args); //
});
@ -549,6 +659,18 @@ void *register_cleanup(lisp_cleanup_func_t fun, void *data) {
return entry;
}
void free_double_ptr(void *ptr) {
free(*(void **) ptr);
}
void unref_free_list_double_ptr(void *ptr) {
struct UnrefListData *data = ptr;
for (size_t i = 0; i < data->len; ++i) {
lisp_unref(data->vals[i]);
}
lisp_free(data->vals);
}
void cancel_cleanup(void *handle) {
struct CleanupHandlerEntry *entry = the_stack->cleanup_handlers;
if (entry == handle) {
@ -587,9 +709,11 @@ DEFUN(backtrace, "backtrace", ()) {
return head;
}
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
CHECK_TYPE(TYPE_SYMBOL, signal);
LispVal *error_arg = make_list(2, Fpair(signal, rest), Fbacktrace());
LispVal *error_arg = const_list(2, Fpair(signal, rest), Fbacktrace());
for (; the_stack; stack_leave()) {
if (!the_stack->enable_handlers) {
continue;
@ -628,6 +752,7 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
fprintf(stderr, "Lisp will now exit...");
abort();
}
#pragma GCC diagnostic pop
DEF_STATIC_SYMBOL(shutdown_signal, "shutdown-signal");
DEF_STATIC_SYMBOL(type_error, "type-error");
@ -636,38 +761,55 @@ 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");
LispVal *Vobarray = Qnil;
void lisp_init() {
Vobarray = lisp_ref(make_lisp_hashtable(Qstrings_equal, Qhash_string));
#define REGISTER_SYMBOL(fn) \
Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##fn)->name), Q##fn)
REGISTER_SYMBOL(nil);
REGISTER_SYMBOL(t);
REGISTER_SYMBOL(opt);
REGISTER_SYMBOL(allow_other_keys);
REGISTER_SYMBOL(key);
REGISTER_SYMBOL(rest);
// TODO fill in the other fields
REGISTER_SYMBOL(pair);
REGISTER_SYMBOL(head);
REGISTER_SYMBOL(tail);
REGISTER_SYMBOL(quote);
REGISTER_SYMBOL(exit);
REGISTER_SYMBOL(print);
REGISTER_SYMBOL(println);
REGISTER_SYMBOL(not);
REGISTER_SYMBOL(when);
REGISTER_SYMBOL(add);
REGISTER_SYMBOL(if);
REGISTER_SYMBOL(setq);
#undef REGISTER_SYMBOL
REGISTER_FUNCTION(pair, "(head tail)",
"Return a new pair with HEAD and TAIL.");
REGISTER_FUNCTION(head, "(pair)", "Return the head of PAIR.");
REGISTER_FUNCTION(tail, "(pair)", "Return the tail of PAIR.");
REGISTER_FUNCTION(quote, "(form)", "Return FORM as read by the reader.");
REGISTER_FUNCTION(exit, "(&opt code)",
"Exit with CODE, defaulting to zero.");
REGISTER_FUNCTION(print, "(obj)",
"Print a human-readable representation of OBJ.");
REGISTER_FUNCTION(
println, "(obj)",
"Print a human-readable representation of OBJ followed by a newline.");
REGISTER_FUNCTION(not, "(obj)",
"Return t if OBJ is nil, otherwise return t.");
REGISTER_FUNCTION(when, "(cond &rest body)",
"Evaluate BODY if COND is non-nil.");
REGISTER_FUNCTION(add, "(&rest nums)", "Return the sun of NUMS.");
REGISTER_FUNCTION(
if, "(cond then &rest else)",
"Evaluate THEN if COND is non-nil, otherwise evaluate ELSE.");
REGISTER_FUNCTION(
setq, "(&rest args)",
"Set each of a number of variables to their respective values.");
REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
REGISTER_FUNCTION(symbol_function, "(sym &opt resolve)", "");
REGISTER_FUNCTION(fset, "(sym new-func)", "");
}
void lisp_shutdown() {
UNREF_INPLACE(Vobarray);
}
void register_static_function(LispVal *func) {}
static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
while (HASHTABLEP(lexenv)) {
LispVal *value = Fgethash(lexenv, key, Qunbound);
@ -690,7 +832,7 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
if (sym_val != Qunbound) {
return sym_val;
}
Fthrow(Qvoid_variable_error, make_list(1, key));
Fthrow(Qvoid_variable_error, const_list(1, key));
}
DEFUN(symbol_function, "symbol-function",
@ -730,30 +872,126 @@ static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
return final_args;
}
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
// TODO actually implement this
size_t count = list_length(args);
switch (count) {
case 0:
return ((LispVal * (*) ()) func->builtin)();
case 1:
return ((LispVal * (*) (LispVal * val)) func->builtin)(Fhead(args));
case 2:
return ((LispVal * (*) (LispVal * val1, LispVal * val2))
func->builtin)(Fhead(args), Fhead(Ftail(args)));
case 3:
return ((LispVal * (*) (LispVal * val1, LispVal * val2, LispVal * val3))
func->builtin)(Fhead(args), Fhead(Ftail(args)),
Fhead(Ftail(Ftail(args))));
/* case 4: */
/* return func->builtin(HEAD(args)); */
/* case 5: */
/* return func->builtin(HEAD(args)); */
/* case 6: */
/* return func->builtin(HEAD(args)); */
default:
return ((LispVal * (*) (LispVal * val)) func->builtin)(args);
static LispVal **process_builtin_args(LispFunction *func, LispVal *args,
size_t *nargs) {
size_t raw_count =
(func->n_req + func->n_opt + ((LispHashtable *) func->kwargs)->count
+ (func->has_rest));
*nargs = raw_count;
LispVal **vec = lisp_malloc(sizeof(LispVal *) * raw_count);
memset(vec, 0, sizeof(LispVal *) * raw_count);
LispVal *rest = Qnil;
LispVal *rest_end;
size_t have_count = 0;
LispVal *index;
LispVal *arg = Qnil; // last arg processed
while (!NILP(args)) {
arg = Fhead(args);
if (have_count < func->n_req + func->n_opt) {
vec[have_count++] = lisp_ref(arg);
} else if (KEYWORDP(arg)
&& !NILP(index = Fgethash(func->kwargs, arg, Qnil))
&& NILP(rest)) {
LispInteger *n = (LispInteger *) index;
if (vec[n->value]) {
goto multikey;
}
args = Ftail(args);
if (NILP(args)) {
goto key_no_val;
}
vec[n->value] = lisp_ref(Fhead(arg));
} else if (KEYWORDP(arg) && !func->allow_other_keys && NILP(rest)) {
goto unknown_key;
} else if (!func->has_rest) {
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);
rest_end = new_end;
}
args = Ftail(args);
}
if (have_count < func->n_req) {
goto too_few;
}
if (func->has_rest) {
vec[raw_count - 1] = lisp_ref(rest);
}
for (size_t i = 0; i < raw_count; ++i) {
if (!vec[i]) {
vec[i] = Qnil;
}
}
return vec;
// TODO different messages
key_no_val:
too_many:
multikey:
unknown_key:
too_few:
lisp_unref(rest);
for (size_t i = 0; i < raw_count; ++i) {
if (vec[i]) {
lisp_unref(vec[i]);
}
}
lisp_free(vec);
Fthrow(Qargument_error, Qnil);
return NULL;
}
static LispVal *call_builtin(LispVal *name, LispFunction *func, LispVal *args) {
size_t nargs;
LispVal **arg_vec = process_builtin_args(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 * (*) ()) 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);
unref_free_list_double_ptr(&cleanup_data);
return retval;
}
static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
@ -773,7 +1011,7 @@ static LispVal *call_function(LispVal *func, LispVal *args,
fobj = (LispFunction *) Fsymbol_function(func, Qt);
}
if (LISPVAL(fobj) == Qunbound) {
Fthrow(Qvoid_function_error, make_list(1, func));
Fthrow(Qvoid_function_error, const_list(1, func));
}
CHECK_TYPE(TYPE_FUNCTION, fobj);
if (!fobj->is_macro && eval_args) {
@ -781,7 +1019,8 @@ static LispVal *call_function(LispVal *func, LispVal *args,
}
lisp_ref(args);
LispVal *retval = Qnil;
WITH_PUSH_FRAME(func, args, false, {
// builtin macros inherit their parents lexenv
WITH_PUSH_FRAME(func, args, fobj->is_macro && fobj->is_builtin, {
void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &lisp_unref_double_ptr, &args);
check_args_for_function(fobj, args);
@ -883,7 +1122,7 @@ DEFUN(exit, "exit", (LispVal * code)) {
if (!NILP(code) && !INTEGERP(code)) {
Fthrow(Qtype_error, Qnil);
}
Fthrow(Qshutdown_signal, make_list(1, code));
Fthrow(Qshutdown_signal, const_list(1, code));
}
DEFMACRO(quote, "'", (LispVal * form)) {
@ -912,14 +1151,22 @@ DEFMACRO(if, "if", (LispVal * cond, LispVal *t, LispVal *nil)) {
if (!NILP(res)) {
retval = Feval(t);
} else {
retval = Feval(nil);
LispVal *body = Fpair(Qprogn, nil);
WITH_CLEANUP(body, {
retval = Feval(body); //
});
}
});
return retval;
}
DEFMACRO(when, "when", (LispVal * cond, LispVal *t)) {
return Fif(cond, t, Qnil);
LispVal *body = Fpair(Qprogn, t);
LispVal *retval = Qnil;
WITH_CLEANUP(body, {
retval = Fif(cond, body, Qnil); //
});
return retval;
}
DEFUN(add, "+", (LispVal * n1, LispVal *n2)) {
@ -949,6 +1196,23 @@ DEFMACRO(setq, "setq", (LispVal * name, LispVal *value)) {
return evaled;
}
DEFMACRO(progn, "progn", (LispVal * forms)) {
LispVal *retval = Qnil;
FOREACH(form, forms) {
retval = Feval(form);
}
return retval;
}
DEFUN(fset, "fset", (LispVal * sym, LispVal *new_func)) {
CHECK_TYPE(TYPE_SYMBOL, sym);
LispSymbol *sobj = ((LispSymbol *) sym);
// TODO make sure this is not constant
lisp_unref(sobj->function);
sobj->function = lisp_ref(new_func);
return new_func;
}
static void debug_dump_real(FILE *stream, void *obj, bool first) {
switch (TYPEOF(obj)) {
case TYPE_STRING: {

230
src/lisp.h
View File

@ -17,6 +17,9 @@
# define PRINTF_FORMAT(first, second)
#endif
// ####################
// # Basic Structures #
// ####################
typedef enum {
TYPE_STRING,
TYPE_SYMBOL,
@ -34,7 +37,6 @@ struct _TypeNameEntry {
size_t len;
};
extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
#define OBJ_TYPE_NAME(obj) (LISP_TYPE_NAMES[LISPVAL(obj)->type].name)
#define LISP_OBJECT_HEADER \
LispType type; \
@ -43,9 +45,6 @@ extern struct _TypeNameEntry LISP_TYPE_NAMES[N_LISP_TYPES];
typedef struct {
LISP_OBJECT_HEADER;
} LispVal;
#define LISPVAL(obj) ((LispVal *) (obj))
#define STATICP(v) (LISPVAL(v)->ref_count < 0)
#define TYPEOF(v) (LISPVAL(v)->type)
typedef struct {
LISP_OBJECT_HEADER;
@ -101,8 +100,8 @@ typedef struct {
size_t n_req;
size_t n_opt;
size_t n_kw;
LispVal **kwargs;
LispVal *kwargs; // hash table
bool allow_other_keys;
bool has_rest;
union {
void *builtin;
@ -134,6 +133,30 @@ typedef struct {
LispVal *hash_fn;
} LispHashtable;
// #######################
// # nil, unbound, and t #
// #######################
#define LISPVAL(obj) ((LispVal *) (obj))
extern LispSymbol _Qnil;
extern LispSymbol _Qunbound; // don't intern!
extern LispSymbol _Qt;
#define Qnil (LISPVAL(&_Qnil))
#define Qunbound (LISPVAL(&_Qunbound))
#define Qt (LISPVAL(&_Qt))
#define LISP_BOOL(v) ((v) ? Qt : Qnil)
// ###################
// # Type predicates #
// ###################
#define STATICP(v) (LISPVAL(v)->ref_count < 0)
#define TYPEOF(v) (LISPVAL(v)->type)
// only use on symbols!
#define VALUE_CONSTANTP(v) (((LispSymbol *) (v))->is_constant)
#define NILP(v) (((void *) (v)) == (void *) Qnil)
#define STRINGP(v) (TYPEOF(v) == TYPE_STRING)
#define SYMBOLP(v) (TYPEOF(v) == TYPE_SYMBOL)
@ -146,13 +169,10 @@ typedef struct {
#define ATOM(v) (TYPEOF(v) != TYPE_PAIR)
extern LispSymbol _Qnil;
extern LispSymbol _Qunbound;
extern LispSymbol _Qt;
#define Qnil (LISPVAL(&_Qnil))
#define Qunbound (LISPVAL(&_Qunbound))
#define Qt (LISPVAL(&_Qt))
inline static bool KEYWORDP(LispVal *v) {
return SYMBOLP(v) && ((LispSymbol *) v)->name->length
&& ((LispSymbol *) v)->name->data[0] == ':';
}
inline static bool LISTP(LispVal *v) {
return NILP(v) || PAIRP(v);
@ -162,11 +182,9 @@ inline static bool NUMBERP(LispVal *v) {
return INTEGERP(v) || FLOATP(v);
}
extern LispVal *Qbackquote;
extern LispVal *Qcomma;
#define LISP_BOOL(v) ((v) ? Qt : Qnil)
// ##################################
// # Macros for static declarations #
// ##################################
#define DEF_STATIC_STRING(name, value) \
static LispString name = { \
.type = TYPE_STRING, \
@ -187,7 +205,69 @@ extern LispVal *Qcomma;
.is_constant = false, \
}; \
LispVal *Q##c_name = LISPVAL(&_Q##c_name);
#define DECLARE_FUNCTION(c_name, args) \
LispVal *F##c_name args; \
extern LispVal *Q##c_name;
// The args and doc fields are filled when the function is registered
#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args) \
LispVal *F##c_name c_args; \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispFunction _Q##c_name##_function = { \
.type = TYPE_FUNCTION, \
.ref_count = -1, \
.is_builtin = true, \
.is_macro = macrop, \
.builtin = &F##c_name, \
.doc = Qnil, \
.args = Qnil, \
.kwargs = Qnil, \
.lexenv = Qnil, \
}; \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.ref_count = -1, \
.name = &_Q##c_name##_name, \
.plist = Qnil, \
.value = Qunbound, \
.function = LISPVAL(&_Q##c_name##_function), \
.is_constant = false, \
}; \
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
LispVal *F##c_name c_args
#define DEFUN(c_name, lisp_name, c_args) \
_INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args)
#define DEFMACRO(c_name, lisp_name, c_args) \
_INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args)
// ###############
// # Loop macros #
// ###############
#define HASHTABLE_FOREACH(key_var, val_var, table, body) \
{ \
LispHashtable *__hashtable_foreach_table = (LispHashtable *) table; \
for (size_t __hashtable_foreach_i = 0; \
__hashtable_foreach_i < __hashtable_foreach_table->count; \
++__hashtable_foreach_i) { \
struct HashtableBucket *__hashtable_foreach_cur = \
__hashtable_foreach_table->data[__hashtable_foreach_i]; \
while (__hashtable_foreach_cur) { \
LispVal *key_var = __hashtable_foreach_cur->key; \
LispVal *val_var = __hashtable_foreach_cur->value; \
{body}; \
__hashtable_foreach_cur = __hashtable_foreach_cur->next; \
} \
} \
}
#define FOREACH(var, list) \
for (LispVal *__foreach_cur = list, *var = Fhead(list); \
!NILP(__foreach_cur); \
__foreach_cur = Ftail(__foreach_cur), var = Fhead(__foreach_cur))
#define FOREACH_TAIL(var, list) \
for (LispVal *var = list; !NILP(var); var = Ftail(var))
// #############################
// # Allocation and references #
// #############################
void *lisp_malloc(size_t size);
void *lisp_realloc(void *old_ptr, size_t size);
#define lisp_free free
@ -227,6 +307,9 @@ inline static void lisp_unref_double_ptr(void **val) {
}
#define IGNORE_REF(val) (lisp_unref(lisp_ref(val)))
// ################
// # Constructors #
// ################
LispVal *make_lisp_string(const char *data, size_t length, bool take,
bool is_static);
#define STATIC_STRING(s) (make_lisp_string((s), sizeof(s) - 1, true, true))
@ -236,76 +319,34 @@ LispVal *make_lisp_pair(LispVal *head, LispVal *tail);
LispVal *make_lisp_integer(intmax_t value);
LispVal *make_lisp_float(long double value);
LispVal *make_lisp_vector(LispVal **data, size_t length);
// TODO make_lisp_function
void set_function_args(LispFunction *func, LispVal *args);
LispVal *make_lisp_function(LispVal *args, LispVal *doc, LispVal *lexenv,
LispVal *body, bool is_macro);
LispVal *make_lisp_hashtable(LispVal *eq_fn, LispVal *hash_fn);
#define DECLARE_FUNCTION(c_name, args) \
LispVal *F##c_name args; \
extern LispVal *Q##c_name;
// The args and doc fields are filled when the function is registered
#define _INTERNAL_DEFUN_EXTENDED(macrop, c_name, lisp_name, c_args) \
LispVal *F##c_name c_args; \
DEF_STATIC_STRING(_Q##c_name##_name, lisp_name); \
static LispFunction _Q##c_name##_function = { \
.type = TYPE_FUNCTION, \
.ref_count = -1, \
.is_builtin = true, \
.is_macro = macrop, \
.builtin = &F##c_name, \
.lexenv = Qnil, \
}; \
static LispSymbol _Q##c_name = { \
.type = TYPE_SYMBOL, \
.ref_count = -1, \
.name = &_Q##c_name##_name, \
.plist = Qnil, \
.value = Qunbound, \
.function = LISPVAL(&_Q##c_name##_function), \
.is_constant = false, \
}; \
LispVal *Q##c_name = (LispVal *) &_Q##c_name; \
LispVal *F##c_name c_args
#define DEFUN(c_name, lisp_name, c_args) \
_INTERNAL_DEFUN_EXTENDED(false, c_name, lisp_name, c_args)
#define DEFMACRO(c_name, lisp_name, c_args) \
_INTERNAL_DEFUN_EXTENDED(true, c_name, lisp_name, c_args)
// ########################
// # Utility and internal #
// ########################
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
DECLARE_FUNCTION(type_of, (LispVal * obj));
DECLARE_FUNCTION(pair, (LispVal * head, LispVal *tail));
DECLARE_FUNCTION(hash_string, (LispVal * obj));
DECLARE_FUNCTION(strings_equal, (LispVal * obj1, LispVal *obj2));
bool strings_equal_nocase(const char *s1, const char *s2, size_t n);
DECLARE_FUNCTION(id, (LispVal * obj));
DECLARE_FUNCTION(eq, (LispVal * obj1, LispVal *obj2));
DECLARE_FUNCTION(puthash, (LispVal * table, LispVal *key, LispVal *value));
DECLARE_FUNCTION(gethash, (LispVal * table, LispVal *key, LispVal *def));
DECLARE_FUNCTION(remhash, (LispVal * table, LispVal *key));
DECLARE_FUNCTION(hash_table_count, (LispVal * table));
#define HASHTABLE_FOREACH(key_var, val_var, table, body) \
{ \
LispHashtable *__hashtable_foreach_table = (LispHashtable *) table; \
for (size_t __hashtable_foreach_i = 0; \
__hashtable_foreach_i < __hashtable_foreach_table->count; \
++__hashtable_foreach_i) { \
struct HashtableBucket *__hashtable_foreach_cur = \
__hashtable_foreach_table->data[__hashtable_foreach_i]; \
while (__hashtable_foreach_cur) { \
LispVal *key_var = __hashtable_foreach_cur->key; \
LispVal *val_var = __hashtable_foreach_cur->value; \
{body}; \
__hashtable_foreach_cur = __hashtable_foreach_cur->next; \
} \
} \
}
DECLARE_FUNCTION(intern, (LispVal * name));
LispVal *intern(const char *name, size_t length, bool take);
DECLARE_FUNCTION(intern, (LispVal * name));
#define INTERN_STATIC(name) (Fintern(STATIC_STRING(name)))
DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));
size_t list_length(LispVal *obj);
static inline LispVal *make_list(int len, ...) {
static inline LispVal *const_list(int len, ...) {
LispVal *list = Qnil;
LispVal *end;
va_list args;
@ -324,11 +365,21 @@ static inline LispVal *make_list(int len, ...) {
va_end(args);
return list;
}
#define FOREACH(var, list) \
for (LispVal *__foreach_cur = list, *var = Fhead(list); \
!NILP(__foreach_cur); \
__foreach_cur = Ftail(__foreach_cur), var = Fhead(__foreach_cur))
static inline LispVal *make_list(size_t len, LispVal **vals) {
LispVal *list = Qnil;
LispVal *end;
for (size_t i = 0; i < len; ++i) {
if (NILP(list)) {
list = Fpair(vals[i], Qnil);
end = list;
} else {
LispVal *new_end = Fpair(vals[i], Qnil);
Fsettail(end, new_end);
end = new_end;
}
}
return list;
}
typedef void (*lisp_cleanup_func_t)(void *);
struct CleanupHandlerEntry {
struct CleanupHandlerEntry *next;
@ -356,6 +407,12 @@ extern LispVal *Qparent_lexenv;
void stack_enter(LispVal *name, LispVal *detail, bool inherit);
void stack_leave(void);
void *register_cleanup(lisp_cleanup_func_t fun, void *data);
void free_double_ptr(void *ptr);
struct UnrefListData {
LispVal **vals;
size_t len;
};
void unref_free_list_double_ptr(void *ptr);
void cancel_cleanup(void *handle);
#define WITH_PUSH_FRAME(name, detail, inherit, body) \
stack_enter(name, detail, inherit); \
@ -383,6 +440,8 @@ extern LispVal *Qeof_error;
extern LispVal *Qvoid_variable_error;
extern LispVal *Qvoid_function_error;
extern LispVal *Qcircular_error;
extern LispVal *Qmalformed_lambda_list_error;
extern LispVal *Qargument_error;
#define CHECK_TYPE(type, val) \
if (TYPEOF(val) != type) { \
@ -391,9 +450,26 @@ extern LispVal *Qcircular_error;
extern LispVal *Vobarray;
#define REGISTER_SYMBOL(sym) \
Fputhash(Vobarray, LISPVAL(((LispSymbol *) Q##sym)->name), Q##sym)
#define REGISTER_STATIC_FUNCTION(obj, args, docstr) \
((LispFunction *) (obj))->doc = STATIC_STRING(docstr); \
{ \
LispVal *src = STATIC_STRING(args); \
lisp_ref(src); \
set_function_args((LispFunction *) (obj), Fread(src)); \
lisp_unref(src); \
}
#define REGISTER_FUNCTION(fn, args, docstr) \
REGISTER_SYMBOL(fn); \
REGISTER_STATIC_FUNCTION(((LispSymbol *) Q##fn)->function, args, docstr);
void lisp_init(void);
void lisp_shutdown(void);
void register_static_function(LispVal *func);
extern LispVal *Qbackquote;
extern LispVal *Qcomma;
DECLARE_FUNCTION(quote, (LispVal * form));
DECLARE_FUNCTION(symbol_function, (LispVal * symbol, LispVal *resolve));
@ -412,8 +488,14 @@ DECLARE_FUNCTION(when, (LispVal * cond, LispVal *t));
DECLARE_FUNCTION(if, (LispVal * cond, LispVal *t, LispVal *nil));
DECLARE_FUNCTION(add, (LispVal * n1, LispVal *n2));
DECLARE_FUNCTION(setq, (LispVal * name, LispVal *value));
DECLARE_FUNCTION(progn, (LispVal * forms));
DECLARE_FUNCTION(fset, (LispVal * sym, LispVal *new_func));
void debug_dump(FILE *stream, void *obj, bool newline);
void debug_print_hashtable(FILE *stream, LispVal *table);
extern LispVal *Qopt;
extern LispVal *Qkey;
extern LispVal *Qallow_other_keys;
extern LispVal *Qrest;
#endif

10
src/main.c
View File

@ -10,6 +10,8 @@ static LispFunction _Ftoplevel_exit_handler_function = {
.is_builtin = 1,
.is_macro = 0,
.builtin = &Ftoplevel_exit_handler,
.args = Qnil,
.kwargs = Qnil,
.lexenv = Qnil,
};
#define Ftoplevel_exit_handler_function \
@ -33,6 +35,8 @@ static LispFunction _Ftoplevel_error_handler_function = {
.is_builtin = 1,
.is_macro = 0,
.builtin = &Ftoplevel_error_handler,
.args = Qnil,
.kwargs = Qnil,
.lexenv = Qnil,
};
#define Ftoplevel_error_handler_function \
@ -75,6 +79,8 @@ int main(int argc, const char **argv) {
fread(buffer, 1, file_len, in);
fclose(in);
lisp_init();
REGISTER_STATIC_FUNCTION(Ftoplevel_error_handler_function, "(e)", "");
REGISTER_STATIC_FUNCTION(Ftoplevel_exit_handler_function, "(e)", "");
size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
the_stack->hidden = true;
@ -82,11 +88,11 @@ int main(int argc, const char **argv) {
Fputhash(
the_stack->handlers, Qt,
// simply call the above function
make_list(3, err_var, Ftoplevel_error_handler_function, err_var));
const_list(3, err_var, Ftoplevel_error_handler_function, err_var));
Fputhash(
the_stack->handlers, Qshutdown_signal,
// simply call the above function
make_list(3, err_var, Ftoplevel_exit_handler_function, err_var));
const_list(3, err_var, Ftoplevel_exit_handler_function, err_var));
Fputhash(the_stack->handlers, Qeof_error,
// ignore
Fpair(Qnil, Qnil));

17
src/read.c
View File

@ -45,7 +45,7 @@ static inline void _internal_read_error(struct ReadState *state, size_t len,
if (len > state->left) {
len = state->left;
}
LispVal *args = make_list(
LispVal *args = const_list(
4, make_lisp_integer(state->line), make_lisp_integer(state->col),
make_lisp_string(state->head, len, false, false), desc);
WITH_CLEANUP(args, {
@ -248,6 +248,8 @@ static LispVal *read_symbol(struct ReadState *state) {
}
static LispVal *read_number_or_symbol(struct ReadState *state, int base) {
// ceil(# bytes in size_t / 3)
// This works because log10(2^n) is O(n) for k=3
size_t size_t_len = ((sizeof(size_t) * 8) / 3) + 1;
char fmt_buf[3 + size_t_len + 1];
struct ReadState start_state = *state;
@ -294,8 +296,6 @@ static LispVal *read_number_or_symbol(struct ReadState *state, int base) {
goto change_to_symbol;
}
size_t len = state->head - number_start;
// ceil(# bytes in size_t / 3)
// This works because log10(2^n) is O(n) for k=3
if (has_decimal || exp_start) {
if (exp_start == state->head) {
goto change_to_symbol;
@ -413,3 +413,14 @@ size_t read_from_buffer(const char *text, size_t length, LispVal **out) {
}
return state.off;
}
DEFUN(read, "read", (LispVal * source)) {
if (STRINGP(source)) {
LispString *str = (LispString *) source;
LispVal *v;
read_from_buffer(str->data, str->length, &v);
return v;
} else {
Fthrow(Qtype_error, Qnil);
}
}

2
src/read.h
View File

@ -12,4 +12,6 @@ typedef enum {
size_t read_from_buffer(const char *text, size_t length, LispVal **out);
DECLARE_FUNCTION(read, (LispVal * source));
#endif