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

Some random work

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-15 01:12:54 -07:00
parent eb0737e83b
commit 91f2ab8e0a
3 changed files with 322 additions and 56 deletions
Download Patch File Download Diff File Expand all files Collapse all files

225
src/lisp.c
View File

@ -680,7 +680,8 @@ size_t list_length(LispVal *obj) {
StackFrame *the_stack = NULL;
DEF_STATIC_SYMBOL(toplevel, "toplevel");
DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv");
DEF_STATIC_SYMBOL(parent_lexenv, "parent-lexenv"); // DO NOT INTERN
DEF_STATIC_SYMBOL(return_signal, "return-signal"); // DO NOT INTERN
void stack_enter(LispVal *name, LispVal *detail, bool inherit) {
StackFrame *frame = lisp_malloc(sizeof(StackFrame));
@ -1045,6 +1046,10 @@ void lisp_init(void) {
"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(symbol_value, "(sym)", "Return the global value of SYM.");
REGISTER_FUNCTION(symbol_plist, "(sym)", "Return the plist of SYM.");
REGISTER_FUNCTION(setplist, "(sym plist)",
"Set the plist of SYM to PLIST.");
REGISTER_FUNCTION(fset, "(sym new-func)", "");
REGISTER_FUNCTION(defun, "(name args &rest body)",
"Define NAME to be a new function.");
@ -1062,15 +1067,23 @@ void lisp_init(void) {
"Return a new un-interned symbol named NAME.");
REGISTER_FUNCTION(macroexpand_1, "(form)",
"Return the form which FORM expands to.");
REGISTER_FUNCTION(macroexpand_toplevel, "(form)", "");
REGISTER_FUNCTION(macroexpand_all, "(form)", "");
REGISTER_FUNCTION(stringp, "(val)", "Return non-nil if VAL is a string.");
REGISTER_FUNCTION(symbolp, "(val)", "Return non-nil if VAL is a symbol.");
REGISTER_FUNCTION(pairp, "(val)", "Return non-nil if VAL is a pair.");
REGISTER_FUNCTION(integerp, "(val)", "Return non-nil if VAL is a integer.");
REGISTER_FUNCTION(floatp, "(val)", "Return non-nil if VAL is a float.");
REGISTER_FUNCTION(vectorp, "(val)", "Return non-nil if VAL is a vector.");
REGISTER_FUNCTION(functionp, "(val)",
"Return non-nil if VAL is a function.");
REGISTER_FUNCTION(macrop, "(val)", "Return non-nil if VAL is a macro.");
REGISTER_FUNCTION(
functionp, "(val)",
"Return non-nil if VAL is a non-macro function (includes buitlins).");
REGISTER_FUNCTION(macrop, "(val)",
"Return non-nil if VAL is a non-builtin macro.");
REGISTER_FUNCTION(builtinp, "(val)",
"Return non-nil if VAL is a non-macro builtin.");
REGISTER_FUNCTION(special_form_p, "(val)",
"Return non-nil if VAL is a macro-builtin.");
REGISTER_FUNCTION(hashtablep, "(val)",
"Return non-nil if VAL is a hashtable.");
REGISTER_FUNCTION(user_pointer_p, "(val)",
@ -1080,6 +1093,9 @@ void lisp_init(void) {
REGISTER_FUNCTION(keywordp, "(val)", "Return non-nil if VAL is a keyword.");
REGISTER_FUNCTION(numberp, "(val)", "Return non-nil if VAL is a number.");
REGISTER_FUNCTION(list_length, "(list)", "Return the length of LIST.");
REGISTER_FUNCTION(copy_list, "(list)", "Return a shallow copy of LIST.");
REGISTER_FUNCTION(copy_tree, "(tree)",
"Return a deep copy of TREE and all sublists in it.");
REGISTER_FUNCTION(num_eq, "(n1 n2)",
"Return non-nil if N1 and N2 are equal numerically.")
REGISTER_FUNCTION(num_gt, "(n1 n2)",
@ -1158,6 +1174,19 @@ DEFUN(symbol_value, "symbol-value", (LispVal * symbol)) {
return refcount_ref(((LispSymbol *) symbol)->value);
}
DEFUN(symbol_plist, "symbol-plist", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->plist);
}
DEFUN(setplist, "setplist", (LispVal * symbol, LispVal *plist)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
LispSymbol *real = (LispSymbol *) symbol;
refcount_unref(real->plist);
real->plist = refcount_ref(plist);
return Qnil;
}
static inline LispVal *eval_function_args(LispVal *args, LispVal *lexenv) {
LispVal *final_args = Qnil;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
@ -1521,6 +1550,55 @@ DEFUN(funcall, "funcall", (LispVal * function, LispVal *rest)) {
return call_function(function, rest, Qnil, false, false);
}
DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
if (NILP(tree)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, tree);
LispPair *tortise = (LispPair *) tree;
LispPair *hare = (LispPair *) tortise->tail;
LispVal *copy = Qnil;
LispVal *copy_end;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
the_stack->hidden = 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;
}
DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
if (PAIRP(form)) {
LispFunction *fobj = (LispFunction *) Fsymbol_function(Fhead(form), Qt);
@ -1543,6 +1621,45 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
}
}
DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) {
if (PAIRP(form)) {
LispVal *out = refcount_ref(form);
void *cl_handler = register_cleanup(&unref_double_ptr, &out);
while (PAIRP(out) && !NILP(Fmacrop(HEAD(out)))) {
LispVal *new_out = Fmacroexpand_1(out);
refcount_unref(out);
out = new_out;
}
cancel_cleanup(cl_handler);
return out;
} else {
return refcount_ref(form);
}
}
DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
if (PAIRP(form)) {
LispVal *toplevel_orig = Fmacroexpand_toplevel(form);
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) && NILP(Feq(Qquote, HEAD(toplevel)))) {
FOREACH_TAIL(tail, TAIL(toplevel)) {
Fsethead(tail, Fmacroexpand_all(HEAD(tail)));
}
}
cancel_cleanup(cl_handler);
});
return toplevel;
} else {
return refcount_ref(form);
}
return Qnil;
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
LispVal *args = Qnil;
LispVal *end;
@ -1788,7 +1905,13 @@ DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
}
DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
return make_lisp_function(args, the_stack->lexenv, body, false);
LispVal *expanded_body = Fmacroexpand_all(body);
LispVal *retval = Qnil;
WITH_CLEANUP(expanded_body, {
retval =
make_lisp_function(args, the_stack->lexenv, expanded_body, false);
});
return retval;
}
DEFMACRO(while, "while", (LispVal * cond, LispVal *body)) {
@ -1842,12 +1965,44 @@ DEFUN(functionp, "functionp", (LispVal * val)) {
}
DEFUN(macrop, "macrop", (LispVal * val)) {
if (FUNCTIONP(val) && ((LispFunction *) val)->is_macro) {
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_macro);
LISP_BOOL(FUNCTIONP(res) && !((LispFunction *) res)->is_builtin
&& ((LispFunction *) res)->is_macro);
refcount_unref(res);
return retval;
}
return Qnil;
}
DEFUN(builtinp, "builtinp", (LispVal * val)) {
if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
&& !((LispFunction *) val)->is_macro) {
return Qt;
} else if (SYMBOLP(val)) {
LispVal *res = Fsymbol_function(val, Qt);
LispVal *retval =
LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
&& !((LispFunction *) res)->is_macro);
refcount_unref(res);
return retval;
}
return Qnil;
}
DEFUN(special_form_p, "special-form-p", (LispVal * val)) {
if (FUNCTIONP(val) && ((LispFunction *) val)->is_builtin
&& ((LispFunction *) val)->is_macro) {
return Qt;
} else if (SYMBOLP(val)) {
LispVal *res = Fsymbol_function(val, Qt);
LispVal *retval =
LISP_BOOL(FUNCTIONP(res) && ((LispFunction *) res)->is_builtin
&& ((LispFunction *) res)->is_macro);
refcount_unref(res);
return retval;
}
@ -1882,6 +2037,31 @@ DEFUN(list_length, "list-length", (LispVal * list)) {
return make_lisp_integer(list_length(list));
}
DEFUN(copy_list, "copy-list", (LispVal * list)) {
if (NILP(list)) {
return Qnil;
}
CHECK_TYPE(TYPE_PAIR, list);
LispVal *copy = Qnil;
LispVal *copy_end;
WITH_PUSH_FRAME(Qnil, Qnil, true, {
void *cl_cleanup = register_cleanup(&unref_double_ptr, &copy);
FOREACH(elt, list) {
if (NILP(copy)) {
copy = Fpair(elt, Qnil);
copy_end = copy;
} else {
LispVal *new_end = Fpair(elt, Qnil);
Fsettail(copy_end, new_end);
refcount_unref(new_end);
copy_end = new_end;
}
}
cancel_cleanup(cl_cleanup);
});
return copy;
}
DEFMACRO(and, "and", (LispVal * rest)) {
LispVal *retval = Qnil;
FOREACH(cond, rest) {
@ -1915,6 +2095,7 @@ DEFUN(type_of, "type-of", (LispVal * obj)) {
make_lisp_string((char *) LISP_TYPE_NAMES[obj->type].name,
LISP_TYPE_NAMES[obj->type].len, true, true);
LispVal *sym = Fintern(name);
refcount_unref(name);
return sym;
}
@ -2033,3 +2214,33 @@ static bool debug_print_tree_callback(void *obj, const RefcountList *trail,
void debug_print_tree(FILE *stream, void *obj) {
refcount_debug_walk_tree(obj, debug_print_tree_callback, stream);
}
void debug_dump_lexenv(FILE *stream, LispVal *lexenv) {
if (!the_stack) {
fprintf(stream, "debug_dump_lexenv: No stack frames...\n");
}
if (!lexenv) {
lexenv = the_stack->lexenv;
}
bool first = true;
while (!NILP(lexenv)) {
if (first) {
fprintf(stream, "Lexical variables (most recent frame first):\n");
} else {
fprintf(stream, "\nNext parent:\n");
}
first = false;
LispVal *next_lexenv = Qnil;
HASHTABLE_FOREACH(var, val, lexenv, {
if (var == Qparent_lexenv) {
next_lexenv = val;
} else {
fprintf(stream, " - ");
debug_dump(stream, var, false);
fprintf(stream, " -> ");
debug_dump(stream, val, true);
}
});
lexenv = next_lexenv;
}
}