From a19071c35c973e624b8dbe8f2adaffeaabb6c596 Mon Sep 17 00:00:00 2001 From: Alexander Rosenberg Date: Thu, 3 Jul 2025 01:36:25 +0900 Subject: [PATCH] Work on function stuff --- src/lisp.c | 372 +++++++++++++++++++++++++++++++++++++++++++++-------- src/lisp.h | 230 ++++++++++++++++++++++----------- src/main.c | 10 +- src/read.c | 17 ++- src/read.h | 2 + 5 files changed, 498 insertions(+), 133 deletions(-) diff --git a/src/lisp.c b/src/lisp.c index ee02b46..a8bbebd 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -1,5 +1,7 @@ #include "lisp.h" +#include "read.h" + #include #include #include @@ -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: { diff --git a/src/lisp.h b/src/lisp.h index d998e59..58d87b6 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -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 diff --git a/src/main.c b/src/main.c index deaa09e..e8fefb9 100644 --- a/src/main.c +++ b/src/main.c @@ -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)); diff --git a/src/read.c b/src/read.c index 50b0883..5094031 100644 --- a/src/read.c +++ b/src/read.c @@ -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); + } +} diff --git a/src/read.h b/src/read.h index bbaaed4..d75e9c2 100644 --- a/src/read.h +++ b/src/read.h @@ -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