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

Fix current memory issues

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-14 02:45:44 -07:00
parent eb8d54acb1
commit eb0737e83b
5 changed files with 235 additions and 93 deletions
Download Patch File Download Diff File Expand all files Collapse all files

125
src/kernel.el Normal file
View File

@ -0,0 +1,125 @@
;; -*- mode: lisp-data -*-
(fset 'null 'not)
(defun list (&rest r) r)
(fset 'first 'head)
(defun second (list)
(head (tail list)))
(defun third (list)
(head (tail (tail list))))
(defun fourth (list)
(head (tail (tail (tail list)))))
(defun fifth (list)
(head (tail(tail (tail (tail list))))))
(defun sixth (list)
(head (tial (tail (tail (tail (tail list)))))))
(defun seventh (list)
(head (tail (tail (tail (tail (tail (tail list))))))))
(defun eight (list)
(head (tail (tail (tail (tail (tail (tail (tail list)))))))))
(defun ninth (list)
(head (tail (tail (tail (tail (tail (tail (tail (tail list))))))))))
(defun tenth (list)
(head (tail (tail (tail (tail (tail (tail (tail (tail (tail list)))))))))))
(defmacro dolist (vars &rest body)
(funcall
(lambda (tail-var)
(list 'progn
(list 'setq tail-var (second vars))
(list 'while tail-var
(list 'funcall (apply 'list 'lambda (list (first vars)) body)
(list 'head tail-var))
(list 'setq tail-var (list 'tail tail-var)))))
(make-symbol "tail")))
(defun maphead (func list)
(funcall
(lambda (&opt start end)
(dolist (elt list)
(setq elt (funcall func elt))
(if (not start)
(setq start (pair elt nil)
end start)
(settail end (pair elt nil))
(setq end (tail end))))
start)))
(defun reverse (list)
(funcall
(lambda (&opt out)
(dolist (elt list)
(setq out (pair elt out)))
out)))
(defun < (n1 n2)
(not (or (> n1 n2) (= n1 n2))))
(defun <= (n1 n2)
(not (> n1 n2)))
(defun >= (n1 n2)
(or (> n1 n2) (= n1 n2)))
(defmacro let (bindings &rest body)
(funcall
(lambda (&opt vars vals)
(dolist (ent bindings)
(if (symbolp ent)
(setq vars (pair ent vars)
vals (pair nil vals))
(if (and (listp ent) (or (= (list-length ent) 1)
(= (list-length ent) 2)))
(setq vars (pair (first ent) vars)
vals (pair (second ent) vals))
(throw 'argument-error))))
(apply 'list 'funcall (apply 'list 'lambda (reverse vars) body)
(reverse vals)))))
(defun lasttail (list)
"Return the last pair in LIST."
(let (out)
(while list
(setq out list
list (tail list)))
out))
(defun internal-expand-single-cond (cond)
(if (tail cond)
(list 'if (head cond)
(apply 'list 'progn (tail cond)))
(let ((res-var (make-symbol "res")))
(list 'let (list (list res-var (head cond)))
(list 'if res-var res-var)))))
(defmacro cond (&rest conds)
(let (out last-if)
(dolist (cond conds)
(if (not out)
(setq out (internal-expand-single-cond cond)
last-if out)
(let ((new-if (internal-expand-single-cond cond)))
(settail (lasttail last-if) (list new-if))
(setq last-if new-if))))
out))
(defun internal-expand-\` (form)
(cond
((and (listp form) (eq (head form) '\,))
(list (eval (second form))))
((and (listp form) (eq (head form) '\,@))
(eval (second form)))
((pairp form)
(let (out end)
(dolist (arg form)
(if (not out)
(setq out (internal-expand-\` arg)
end (lasttail out))
(settail end (internal-expand-\` arg))
(setq end (lasttail end))))
(list out)))
(t (list form))))
(defmacro \` (form)
(list '\' (head (internal-expand-\` form))))

81
src/lisp.c
View File

@ -378,7 +378,7 @@ LispVal *make_lisp_function(LispVal *args, LispVal *lexenv, LispVal *body,
self->oargs = Qnil;
self->rest_arg = Qnil;
self->kwargs = Qnil;
void *cl = register_cleanup(&free_double_ptr, &self);
void *cl = register_cleanup(&lisp_free, self);
set_function_args(self, args);
cancel_cleanup(cl);
@ -465,8 +465,8 @@ static bool hash_table_eq(LispHashtable *self, LispVal *v1, LispVal *v2) {
return !NILP(Fstrings_equal(v1, v2));
} else {
LispVal *eq_obj;
LispVal *args = const_list(2, v1, v2);
WITH_CLEANUP(args, {
LispVal *args = const_list(true, 2, v1, v2);
WITH_CLEANUP_DOUBLE_PTR(args, {
eq_obj = Ffuncall(self->eq_fn, args); //
});
bool result = !NILP(eq_obj);
@ -486,12 +486,12 @@ static uint64_t hash_table_hash(LispHashtable *self, LispVal *key) {
return hash;
} else {
LispVal *hash_obj;
LispVal *args = const_list(1, key);
WITH_CLEANUP(args, {
LispVal *args = const_list(true, 1, key);
WITH_CLEANUP_DOUBLE_PTR(args, {
hash_obj = Ffuncall(self->hash_fn, args); //
});
uint64_t hash;
WITH_CLEANUP(hash_obj, {
WITH_CLEANUP_DOUBLE_PTR(hash_obj, {
CHECK_TYPE(TYPE_INTEGER, hash_obj);
hash = ((LispInteger *) hash_obj)->value;
});
@ -684,16 +684,16 @@ DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv");
void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame));
frame->name = refcount_ref(name);
frame->name = (LispSymbol *) name;
frame->hidden = false;
frame->detail = refcount_ref(detail);
frame->lexenv = refcount_ref(make_lisp_hashtable(Qnil, Qnil));
frame->detail = detail;
frame->lexenv = make_lisp_hashtable(Qnil, Qnil);
if (inherit && the_stack) {
puthash(LISPVAL(frame->lexenv), Qparent_lexenv,
LISPVAL(the_stack->lexenv));
}
frame->enable_handlers = true;
frame->handlers = refcount_ref(make_lisp_hashtable(Qnil, Qnil));
frame->handlers = make_lisp_hashtable(Qnil, Qnil);
frame->unwind_forms = Qnil;
frame->cleanup_handlers = NULL;
@ -710,6 +710,7 @@ void stack_leave(void) {
refcount_unref(frame->handlers);
FOREACH(elt, frame->unwind_forms) {
WITH_PUSH_FRAME(Qnil, Qnil, false, {
the_stack->hidden = true;
refcount_unref(Feval(elt)); //
});
}
@ -786,6 +787,7 @@ DEFUN(backtrace, "backtrace", (void) ) {
Fpair(Fpair(LISPVAL(frame->name), frame->detail), Qnil);
refcount_unref(HEAD(new_end));
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
}
@ -796,7 +798,8 @@ DEFUN(backtrace, "backtrace", (void) ) {
#pragma GCC diagnostic ignored "-Winfinite-recursion"
DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
CHECK_TYPE(TYPE_SYMBOL, signal);
LispVal *error_arg = const_list(2, Fpair(signal, rest), Fbacktrace());
LispVal *error_arg =
const_list(false, 2, Fpair(signal, rest), Fbacktrace());
for (; the_stack; stack_leave()) {
if (!the_stack->enable_handlers) {
continue;
@ -809,30 +812,30 @@ DEFUN(throw, "throw", (LispVal * signal, LispVal *rest)) {
}
if (handler != Qunbound) {
the_stack->enable_handlers = false;
LispVal *var = Fhead(handler);
LispVal *form = Ftail(handler);
LispVal *var = HEAD(handler);
LispVal *form = TAIL(handler);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
if (!NILP(var)) {
// TODO make sure this isn't constant
puthash(the_stack->lexenv, var, error_arg);
}
WITH_CLEANUP(error_arg, {
WITH_CLEANUP_DOUBLE_PTR(error_arg, {
refcount_unref(Feval(form)); //
});
});
longjmp(the_stack->start, 1); // return a nonzero value
}
}
// we never used it, so drop it
refcount_unref(error_arg);
fprintf(stderr,
"ERROR: An exception has propogated past the top of the stack!\n");
"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
@ -1103,7 +1106,7 @@ static LispVal *find_in_lexenv(LispVal *lexenv, LispVal *key) {
while (HASHTABLEP(lexenv)) {
LispVal *value = gethash(lexenv, key, Qunbound);
if (value != Qunbound) {
return value;
return refcount_ref(value);
}
lexenv = gethash(lexenv, Qparent_lexenv, Qunbound);
}
@ -1122,7 +1125,7 @@ static LispVal *symbol_value_in_lexenv(LispVal *lexenv, LispVal *key) {
return sym_val;
}
// TODO free args (not just this call, all calls to Fthrow)
Fthrow(Qvoid_variable_error, const_list(1, key));
Fthrow(Qvoid_variable_error, const_list(true, 1, key));
}
static void breakpoint(int64_t id) {}
@ -1157,8 +1160,10 @@ DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *final_args = Qnil;
void *cl_handle =
register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &final_args);
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = true;
void *cl_handle = register_cleanup(
(lisp_cleanup_func_t) &unref_double_ptr, &final_args);
LispVal *end;
FOREACH(elt, args) {
if (NILP(final_args)) {
@ -1169,10 +1174,12 @@ static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *new_end = Fpair(Feval_in_env(elt, lexenv), Qnil);
refcount_unref(HEAD(new_end));
Fsettail(end, new_end);
refcount_unref(new_end);
end = new_end;
}
}
cancel_cleanup(cl_handle);
});
return final_args;
}
@ -1200,7 +1207,7 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
if (vec[oad->index]) {
goto multikey;
}
args = Ftail(args);
args = TAIL(args);
if (NILP(args)) {
goto key_no_val;
}
@ -1224,7 +1231,7 @@ static LispVal **process_builtin_args(LispVal *fname, LispFunction *func,
goto too_few;
}
if (!NILP(func->rest_arg)) {
vec[raw_count - 1] = refcount_ref(rest);
vec[raw_count - 1] = rest;
}
for (size_t i = 0; i < raw_count; ++i) {
if (!vec[i]) {
@ -1420,7 +1427,7 @@ static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
}
LispVal *expansion = Fprogn(func->body);
LispVal *retval = Qnil;
WITH_CLEANUP(expansion, {
WITH_CLEANUP_DOUBLE_PTR(expansion, {
// eval in the outer lexenv
retval = Feval_in_env(expansion, args_lexenv);
});
@ -1441,9 +1448,9 @@ static LispVal *call_function(LispVal *func, LispVal *args,
} else {
Fthrow(Qinvalid_function_error, Fpair(func, Qnil));
}
void *cl_handle = register_cleanup(unref_double_ptr, &fobj);
void *cl_handle = register_cleanup(refcount_unref_as_callback, fobj);
if (LISPVAL(fobj) == Qunbound) {
Fthrow(Qvoid_function_error, const_list(1, func));
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) {
@ -1454,18 +1461,18 @@ static LispVal *call_function(LispVal *func, LispVal *args,
}
LispVal *retval = Qnil;
// builtin macros inherit their parents lexenv
refcount_ref(args);
WITH_CLEANUP(args, {
WITH_PUSH_FRAME(func, args, false, {
if (fobj->is_macro && fobj->is_builtin) {
puthash(the_stack->lexenv, Qparent_lexenv, args_lexenv);
}
void *cl_handle =
register_cleanup((lisp_cleanup_func_t) &unref_double_ptr, &args);
if (fobj->is_builtin) {
retval = call_builtin(func, fobj, args);
} else {
retval = call_lisp_function(func, fobj, args, args_lexenv);
}
cancel_cleanup(cl_handle);
});
});
cancel_cleanup(cl_handle);
return retval;
@ -1522,7 +1529,7 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
return refcount_ref(form);
}
LispVal *expansion = Qnil;
WITH_CLEANUP(fobj, {
WITH_CLEANUP_DOUBLE_PTR(fobj, {
WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, {
puthash(the_stack->lexenv, Qparent_lexenv, fobj->lexenv);
process_lisp_args(Fhead(form), fobj, Ftail(form),
@ -1554,7 +1561,7 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
if (LISTP(HEAD(rest))) {
// ensure the list is not circular
refcount_ref(args);
WITH_CLEANUP(args, {
WITH_CLEANUP_DOUBLE_PTR(args, {
list_length(Fhead(rest)); //
});
if (NILP(args)) {
@ -1574,7 +1581,7 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
}
}
LispVal *retval;
WITH_CLEANUP(args, {
WITH_CLEANUP_DOUBLE_PTR(args, {
retval = Ffuncall(function, args); //
});
return retval;
@ -1592,7 +1599,7 @@ DEFUN(exit, "exit", (LispVal * code)) {
if (!NILP(code) && !INTEGERP(code)) {
Fthrow(Qtype_error, Qnil);
}
Fthrow(Qshutdown_signal, const_list(1, code));
Fthrow(Qshutdown_signal, const_list(true, 1, code));
}
DEFMACRO(quote, "'", (LispVal * form)) {
@ -1696,7 +1703,7 @@ DEFUN(add, "+", (LispVal * args)) {
LispVal *out = copy_number(Fhead(args));
FOREACH(arg, Ftail(args)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
WITH_CLEANUP_DOUBLE_PTR(old_out, {
ONE_MATH_OPERAION(+, out, out, arg); //
});
}
@ -1710,7 +1717,7 @@ DEFUN(sub, "-", (LispVal * args)) {
LispVal *out = copy_number(Fhead(args));
FOREACH(arg, Ftail(args)) {
LispVal *old_out = out;
WITH_CLEANUP(old_out, {
WITH_CLEANUP_DOUBLE_PTR(old_out, {
ONE_MATH_OPERAION(-, out, out, arg); //
});
}
@ -1740,7 +1747,7 @@ DEFMACRO(setq, "setq", (LispVal * args)) {
FOREACH_TAIL(tail, args) {
CHECK_TYPE(TYPE_SYMBOL, HEAD(tail));
LispVal *name = HEAD(tail);
tail = HEAD(tail);
tail = TAIL(tail);
retval = Feval(HEAD(tail));
set_symbol_in_lexenv(name, retval, the_stack->lexenv);
}
@ -1879,7 +1886,7 @@ DEFMACRO(and, "and", (LispVal * rest)) {
LispVal *retval = Qnil;
FOREACH(cond, rest) {
LispVal *nc;
WITH_CLEANUP(retval, {
WITH_CLEANUP_DOUBLE_PTR(retval, {
nc = Feval(cond); //
});
if (NILP(nc)) {

25
src/lisp.h
View File

@ -347,7 +347,7 @@ static inline LispVal *_internal_INTERN_STATIC(const char *name, size_t len) {
DECLARE_FUNCTION(sethead, (LispVal * pair, LispVal *head));
DECLARE_FUNCTION(settail, (LispVal * pair, LispVal *tail));
size_t list_length(LispVal *obj);
static inline LispVal *const_list(int len, ...) {
static inline LispVal *const_list(bool do_ref, int len, ...) {
LispVal *list = Qnil;
LispVal *end;
va_list args;
@ -363,6 +363,9 @@ static inline LispVal *const_list(int len, ...) {
refcount_unref(new_end);
end = new_end;
}
if (!do_ref) {
refcount_unref(((LispPair *) end)->head);
}
}
va_end(args);
return list;
@ -418,13 +421,16 @@ struct UnrefListData {
void unref_free_list_double_ptr(void *ptr);
void unref_double_ptr(void *ptr);
void cancel_cleanup(void *handle);
#define WITH_PUSH_FRAME(name, detail, inherit, body) \
#define WITH_PUSH_FRAME_NO_REF(name, detail, inherit, body) \
stack_enter(name, detail, inherit); \
if (setjmp(the_stack->start) == 0) { \
body \
} \
stack_leave();
#define WITH_CLEANUP(var, body) \
#define WITH_PUSH_FRAME(name, detail, inherit, body) \
WITH_PUSH_FRAME_NO_REF(refcount_ref(name), refcount_ref(detail), inherit, \
body)
#define WITH_CLEANUP_DOUBLE_PTR(var, body) \
{ \
void *__with_cleanup_cleanup = register_cleanup( \
(lisp_cleanup_func_t) & unref_double_ptr, &(var)); \
@ -432,6 +438,14 @@ void cancel_cleanup(void *handle);
cancel_cleanup(__with_cleanup_cleanup); \
refcount_unref(var); \
}
#define WITH_CLEANUP(var, body) \
{ \
void *__with_cleanup_cleanup = \
register_cleanup(&refcount_unref_as_callback, (var)); \
{body}; \
cancel_cleanup(__with_cleanup_cleanup); \
refcount_unref(var); \
}
DECLARE_FUNCTION(backtrace, (void) );
noreturn DECLARE_FUNCTION(throw, (LispVal * signal, LispVal *rest));
@ -451,8 +465,9 @@ extern LispVal *Qno_applicable_method_error;
LispVal *predicate_for_type(LispType type);
#define CHECK_TYPE(type, val) \
if (TYPEOF(val) != type) { \
LispVal *inner_list = const_list(1, predicate_for_type(type)); \
LispVal *args = const_list(2, inner_list, Ftype_of(LISPVAL(val))); \
LispVal *inner_list = const_list(false, 1, predicate_for_type(type)); \
LispVal *args = \
const_list(true, 2, inner_list, Ftype_of(LISPVAL(val))); \
refcount_unref(inner_list); \
Fthrow(Qtype_error, args); \
}

32
src/main.c
View File

@ -89,23 +89,21 @@ int main(int argc, const char **argv) {
size_t pos = 0;
WITH_PUSH_FRAME(Qtoplevel, Qnil, false, {
the_stack->hidden = true;
/* LispVal *err_var = INTERN_STATIC("err-var"); */
/* puthash( */
/* the_stack->handlers, Qt, */
/* // simply call the above function */
/* const_list(3, err_var, Ftoplevel_error_handler_function,
* err_var)); */
/* puthash( */
/* the_stack->handlers, Qshutdown_signal, */
/* // simply call the above function */
/* const_list(3, err_var, Ftoplevel_exit_handler_function,
* err_var)); */
/* LispVal *nil_nil = Fpair(Qnil, Qnil); */
/* puthash(the_stack->handlers, Qeof_error, */
/* // ignore */
/* nil_nil); */
/* refcount_unref(nil_nil); */
/* refcount_unref(err_var); */
LispVal *err_var = INTERN_STATIC("err-var");
puthash(the_stack->handlers, Qt,
// simply call the above function
const_list(true, 3, err_var, Ftoplevel_error_handler_function,
err_var));
puthash(the_stack->handlers, Qshutdown_signal,
// simply call the above function
const_list(true, 3, err_var, Ftoplevel_exit_handler_function,
err_var));
LispVal *nil_nil = Fpair(Qnil, Qnil);
puthash(the_stack->handlers, Qeof_error,
// ignore
nil_nil);
refcount_unref(nil_nil);
refcount_unref(err_var);
while (true) {
LispVal *tv;
WITH_PUSH_FRAME(Qtoplevel_read, Qnil, false, {

5
src/read.c
View File

@ -49,10 +49,7 @@ static inline _Noreturn void _internal_read_error(struct ReadState *state,
LispVal *line = make_lisp_integer(state->line);
LispVal *col = make_lisp_integer(state->col);
LispVal *ctx = make_lisp_string(state->head, len, false, false);
LispVal *args = const_list(4, line, col, ctx, desc);
refcount_unref(line);
refcount_unref(col);
refcount_unref(ctx);
LispVal *args = const_list(false, 4, line, col, ctx, refcount_ref(desc));
WITH_CLEANUP(args, {
Fthrow(cause, args); //
});