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

Labels, flet, and macrolet!

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-21 02:15:53 -07:00
parent 56587ed8cf
commit 0b2e5f2366
3 changed files with 160 additions and 21 deletions
Download Patch File Download Diff File Expand all files Collapse all files

91
src/lisp.c
View File

@ -422,6 +422,23 @@ LispVal *make_user_pointer(void *data, void (*free_func)(void *)) {
return LISPVAL(self);
}
DEFUN(make_hashtable, "make-hashtable", (LispVal * hash_fn, LispVal *eq_fn)) {
return make_lisp_hashtable(eq_fn, hash_fn);
}
DEFUN(vector, "vector", (LispVal * 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);
}
DEFUN(pair, "pair", (LispVal * head, LispVal *tail)) {
return make_lisp_pair(head, tail);
}
@ -1068,6 +1085,11 @@ void lisp_init(void) {
REGISTER_STATIC_FUNCTION(set_for_return, "(entry dest)", "");
REGISTER_STATIC_FUNCTION(internal_real_return, "(name tag value)", "");
REGISTER_FUNCTION(make_hashtable, "(&opt hash-fn eq-fn)", "");
REGISTER_FUNCTION(puthash, "(table key value)", "");
REGISTER_FUNCTION(gethash, "(table key &opt def)", "");
REGISTER_FUNCTION(remhash, "(table key)", "");
REGISTER_FUNCTION(vector, "(&rest elements)", "");
REGISTER_FUNCTION(breakpoint, "(&opt id)", "Do nothing...");
REGISTER_FUNCTION(sethead, "(pair newval)",
"Set the head of PAIR to NEWVAL.");
@ -1100,6 +1122,7 @@ void lisp_init(void) {
setq, "(&rest name-value-pairs)",
"Set each of a number of variables to their respective values.");
REGISTER_FUNCTION(progn, "(&rest forms)", "Evaluate each of FORMS.");
REGISTER_FUNCTION(symbol_name, "(sym)", "");
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.");
@ -1120,10 +1143,10 @@ void lisp_init(void) {
"Return non-nil if OBJ1 and OBJ2 are equal");
REGISTER_FUNCTION(make_symbol, "(name)",
"Return a new un-interned symbol named NAME.");
REGISTER_FUNCTION(macroexpand_1, "(form)",
REGISTER_FUNCTION(macroexpand_1, "(form &opt lexical-macros)",
"Return the form which FORM expands to.");
REGISTER_FUNCTION(macroexpand_toplevel, "(form)", "");
REGISTER_FUNCTION(macroexpand_all, "(form)", "");
REGISTER_FUNCTION(macroexpand_toplevel, "(form &opt lexical-macros)", "");
REGISTER_FUNCTION(macroexpand_all, "(form &opt lexical-macros)", "");
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.");
@ -1133,7 +1156,7 @@ void lisp_init(void) {
REGISTER_FUNCTION(
functionp, "(val)",
"Return non-nil if VAL is a non-macro function (includes buitlins).");
REGISTER_FUNCTION(macrop, "(val)",
REGISTER_FUNCTION(macrop, "(val &opt lexical-macros)",
"Return non-nil if VAL is a non-builtin macro.");
REGISTER_FUNCTION(builtinp, "(val)",
"Return non-nil if VAL is a non-macro builtin.");
@ -1210,6 +1233,11 @@ DEFUN(breakpoint, "breakpoint", (LispVal * id)) {
return Qnil;
}
DEFUN(symbol_name, "symbol-name", (LispVal * symbol)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
return refcount_ref(((LispSymbol *) symbol)->name);
}
DEFUN(symbol_function, "symbol-function",
(LispVal * symbol, LispVal *resolve)) {
CHECK_TYPE(TYPE_SYMBOL, symbol);
@ -1707,10 +1735,32 @@ DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
return copy;
}
DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
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)) {
if (PAIRP(form)) {
LispFunction *fobj;
if (FUNCTIONP(HEAD(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 {
fobj = (LispFunction *) Fsymbol_function(HEAD(form), Qt);
@ -1748,12 +1798,13 @@ DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
}
}
DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) {
DEFUN(macroexpand_toplevel, "macroexpand-toplevel",
(LispVal * form, LispVal *lexical_macros)) {
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);
while (PAIRP(out) && !NILP(Fmacrop(HEAD(out), lexical_macros))) {
LispVal *new_out = Fmacroexpand_1(out, lexical_macros);
refcount_unref(out);
out = new_out;
}
@ -1942,12 +1993,15 @@ static LispVal *filter_body_tree(LispVal *body,
return start;
}
static LispVal *macroexpand_toplevel_as_callback(LispVal *form, void *ignored) {
return Fmacroexpand_toplevel(form);
static LispVal *macroexpand_toplevel_as_callback(LispVal *form,
void *lexical_macros) {
return Fmacroexpand_toplevel(form, lexical_macros);
}
DEFUN(macroexpand_all, "macroexpand-all", (LispVal * form)) {
return filter_body_form(form, macroexpand_toplevel_as_callback, NULL);
DEFUN(macroexpand_all, "macroexpand-all",
(LispVal * form, LispVal *lexical_macros)) {
return filter_body_form(form, macroexpand_toplevel_as_callback,
lexical_macros);
}
DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
@ -2257,7 +2311,7 @@ struct NameAndReturnTag {
static LispVal *expand_function_body_callback(LispVal *body, void *data) {
struct NameAndReturnTag *name_and_return_tag = data;
LispVal *expansion = Fmacroexpand_toplevel(body);
LispVal *expansion = Fmacroexpand_toplevel(body, Qnil);
// this mess checks that the call is exactly one of
// - (return-from 'symbol)
// - (return-from 'symbol val)
@ -2292,7 +2346,7 @@ static inline LispVal *expand_function_body(LispVal *name, LispVal *return_tag,
}
static LispVal *macroexpand_all_as_callback(LispVal *form, void *ignored) {
return Fmacroexpand_all(form);
return Fmacroexpand_all(form, Qnil);
}
static inline void expand_lambda_list_for_toplevel(LispVal *list) {
@ -2432,11 +2486,14 @@ DEFUN(functionp, "functionp", (LispVal * val)) {
return Qnil;
}
DEFUN(macrop, "macrop", (LispVal * val)) {
DEFUN(macrop, "macrop", (LispVal * val, LispVal *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