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

Improve macro expansion and returns

Browse Source
This commit is contained in:
Alexander Rosenberg
2025-09-19 23:50:23 -07:00
parent 342bdfb169
commit 7f68c8fcbf
3 changed files with 220 additions and 34 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
src/kernel.sl
View File

@ -87,7 +87,8 @@
(throw 'argument-error))))
(apply 'list 'funcall (apply 'list 'lambda
(reverse vars)
'(declare (name nil))
(list 'declare (list 'name
(make-symbol "let")))
body)
(reverse vals)))))
@ -139,7 +140,5 @@
(list 'condition-case form
(pair :finally unwind-forms)))
(defun test ()
(return-from test 10))
(println (test))
(defmacro return (&opt value)
(list 'return-from nil value))

231
src/lisp.c
View File

@ -801,17 +801,20 @@ DEFUN(backtrace, "backtrace", (void) ) {
}
DEFMACRO(return_from, "return-from", (LispVal * name, LispVal *value)) {
Fthrow(Qreturn_frame_error, const_list(true, 2, name, value));
Fthrow(Qreturn_frame_error,
const_list(false, 2, refcount_ref(name), Feval(value)));
}
STATIC_DEFMACRO(internal_real_return, "internal-real-return",
(LispVal * name, LispVal *tag, LispVal *value)) {
for (StackFrame *cur = the_stack; cur; cur = cur->next) {
if (!NILP(cur->return_tag) && cur->return_tag == tag) {
Fthrow(cur->return_tag, const_list(true, 1, value));
if (!NILP(cur->return_tag) && cur->enable_handlers
&& cur->return_tag == tag) {
Fthrow(cur->return_tag, const_list(false, 1, Feval(value)));
}
}
Fthrow(Qreturn_frame_error, const_list(true, 2, name, value));
Fthrow(Qreturn_frame_error,
const_list(false, 2, refcount_ref(name), Feval(value)));
}
#pragma GCC diagnostic push
@ -1509,10 +1512,13 @@ static LispVal *call_lisp_function(LispVal *name, LispFunction *func,
}
LispVal *expansion = Fprogn(func->body);
LispVal *retval = Qnil;
WITH_CLEANUP_DOUBLE_PTR(expansion, {
// disable internal handlers
the_stack->enable_handlers = false;
WITH_CLEANUP(expansion, {
// eval in the outer lexenv
retval = Feval_in_env(expansion, args_lexenv);
});
the_stack->enable_handlers = true; // just in case
return retval;
} else {
return Fprogn(func->body);
@ -1682,19 +1688,37 @@ DEFUN(copy_tree, "copy-tree", (LispVal * tree)) {
DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form)) {
if (PAIRP(form)) {
LispFunction *fobj = (LispFunction *) Fsymbol_function(Fhead(form), Qt);
LispFunction *fobj;
if (FUNCTIONP(HEAD(form))) {
fobj = refcount_ref(HEAD(form));
} else {
fobj = (LispFunction *) Fsymbol_function(HEAD(form), Qt);
}
if (!FUNCTIONP(fobj) || fobj->is_builtin || !fobj->is_macro) {
refcount_unref(fobj);
return refcount_ref(form);
}
LispVal *expansion = Qnil;
WITH_CLEANUP_DOUBLE_PTR(fobj, {
WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, {
the_stack->hidden = false;
the_stack->lexenv = refcount_ref(fobj->lexenv);
process_lisp_args(Fhead(form), fobj, Ftail(form),
&the_stack->lexenv);
expansion = Fprogn(fobj->body);
LispVal *return_ptr = Fpair(Qnil, Qnil);
WITH_CLEANUP(return_ptr, {
WITH_CLEANUP(fobj, {
WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
refcount_ref(HEAD(form)), refcount_ref(TAIL(form)), false,
{
the_stack->hidden = false;
if (!NILP(fobj->return_tag)) {
the_stack->return_tag =
refcount_ref(fobj->return_tag);
setup_return_handler(fobj->return_tag, return_ptr);
}
the_stack->lexenv = refcount_ref(fobj->lexenv);
process_lisp_args(Fhead(form), fobj, Ftail(form),
&the_stack->lexenv);
expansion = Fprogn(fobj->body);
},
{
expansion = refcount_ref(HEAD(return_ptr)); //
});
});
});
return expansion;
@ -1719,6 +1743,117 @@ DEFUN(macroexpand_toplevel, "macroexpand-toplevel", (LispVal * form)) {
}
}
static LispVal *filter_body_form(LispVal *form,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data);
#define EXPAND_HEAD(form) \
{ \
LispVal *expansion = filter_body_form(HEAD(form), func, user_data); \
WITH_CLEANUP(expansion, { Fsethead(form, expansion); }); \
}
static void expand_lambda_list(LispVal *list,
LispVal *(*func)(LispVal *body, void *user_data),
void *user_data) {
bool enable_extended = false;
FOREACH_TAIL(entry, list) {
if (enable_extended && PAIRP(HEAD(entry))) {
LispVal *copy = Fcopy_list(HEAD(entry));
Fsethead(entry, copy);
refcount_unref(copy);
if (PAIRP(TAIL(copy))) {
EXPAND_HEAD(TAIL(copy));
}
} else if (HEAD(entry) == Qrest) {
enable_extended = false;
} else if (HEAD(entry) == Qopt || HEAD(entry) == Qkey) {
enable_extended = true;
}
}
}
static void expand_builtin_macro(LispFunction *fobj, LispVal *args,
LispVal *(*func)(LispVal *body,
void *user_data),
void *user_data) {
if (fobj->builtin == (lisp_function_ptr_t) Fquote) {
return; // do nothing
} else if (fobj->builtin == (lisp_function_ptr_t) Fsetq) {
bool is_var = true;
FOREACH_TAIL(form, args) {
if (!is_var) {
EXPAND_HEAD(form);
}
is_var = !is_var;
}
} else if (fobj->builtin == (lisp_function_ptr_t) Freturn_from) {
if (PAIRP(args) && PAIRP(TAIL(args))) {
EXPAND_HEAD(TAIL(args));
}
} else if (fobj->builtin == (lisp_function_ptr_t) Finternal_real_return) {
if (PAIRP(args) && PAIRP(TAIL(args)) && PAIRP(TAIL(TAIL(args)))) {
EXPAND_HEAD(TAIL(TAIL(args)));
}
} else if (fobj->builtin == (lisp_function_ptr_t) Fcondition_case) {
if (PAIRP(args)) {
EXPAND_HEAD(args);
FOREACH_TAIL(entry_tail, TAIL(args)) {
LispVal *copy = Fcopy_list(HEAD(entry_tail));
Fsethead(entry_tail, copy);
refcount_unref(copy);
if (PAIRP(HEAD(entry_tail))) {
FOREACH_TAIL(form, TAIL(HEAD(entry_tail))) {
EXPAND_HEAD(form);
}
}
}
}
} else if (fobj->builtin == (lisp_function_ptr_t) Fdefmacro
|| fobj->builtin == (lisp_function_ptr_t) Fdefun
|| fobj->builtin == (lisp_function_ptr_t) Flambda) {
if (!LISTP(args)) {
return;
}
LispVal *expand_from = TAIL(args); // skip lambda list
if (!LISTP(expand_from)) {
return;
}
LispVal *lambda_list;
if (fobj->builtin != (lisp_function_ptr_t) Flambda) {
LispVal *copy = Fcopy_list(HEAD(expand_from));
Fsethead(expand_from, copy);
refcount_unref(copy);
lambda_list = HEAD(expand_from);
expand_from = TAIL(expand_from); // skip the name
if (!LISTP(expand_from)) {
return;
}
} else {
LispVal *copy = Fcopy_list(HEAD(args));
Fsethead(args, copy);
refcount_unref(copy);
lambda_list = HEAD(args);
}
expand_lambda_list(lambda_list, func, user_data);
LispVal *first_form = HEAD(expand_from);
if (PAIRP(first_form) && HEAD(first_form) == Qdeclare) {
expand_from = TAIL(expand_from); // declare statement
if (!LISTP(expand_from)) {
return;
}
}
FOREACH_TAIL(form, expand_from) {
EXPAND_HEAD(form);
}
} else {
FOREACH_TAIL(form, args) {
EXPAND_HEAD(form);
}
}
}
#undef EXPAND_HEAD
// func should ref its return value
static LispVal *filter_body_form(LispVal *form,
LispVal *(*func)(LispVal *body,
@ -1732,10 +1867,27 @@ static LispVal *filter_body_form(LispVal *form,
});
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,
filter_body_form(HEAD(tail), func, user_data));
if (PAIRP(toplevel)) {
LispFunction *fobj = NULL;
if (FUNCTIONP(HEAD(toplevel))) {
fobj = refcount_ref(HEAD(toplevel));
} else if (SYMBOLP(HEAD(toplevel))) {
fobj =
(LispFunction *) Fsymbol_function(HEAD(toplevel), Qt);
}
if (fobj) {
WITH_CLEANUP(fobj, {
if (fobj->is_builtin && fobj->is_macro) {
expand_builtin_macro(fobj, TAIL(toplevel), func,
user_data);
} else {
FOREACH_TAIL(tail, TAIL(toplevel)) {
Fsethead(tail,
filter_body_form(HEAD(tail), func,
user_data));
}
}
});
}
}
cancel_cleanup(cl_handler);
@ -1795,7 +1947,7 @@ DEFUN(apply, "apply", (LispVal * function, LispVal *rest)) {
if (LISTP(HEAD(rest))) {
// ensure the list is not circular
refcount_ref(args);
WITH_CLEANUP_DOUBLE_PTR(args, {
WITH_CLEANUP(args, {
list_length(Fhead(rest)); //
});
if (NILP(args)) {
@ -2118,6 +2270,14 @@ static inline LispVal *expand_function_body(LispVal *name, LispVal *return_tag,
&(struct NameAndReturnTag) {.name = name, .return_tag = return_tag});
}
static LispVal *macroexpand_all_as_callback(LispVal *form, void *ignored) {
return Fmacroexpand_all(form);
}
static inline void expand_lambda_list_for_toplevel(LispVal *list) {
expand_lambda_list(list, macroexpand_all_as_callback, NULL);
}
DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
CHECK_TYPE(TYPE_SYMBOL, name);
if (parse_function_declare(HEAD(body), NULL)) {
@ -2125,11 +2285,15 @@ DEFMACRO(defun, "defun", (LispVal * name, LispVal *args, LispVal *body)) {
}
LispVal *return_tag =
make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
LispVal *exp_args = Fcopy_list(args);
expand_lambda_list_for_toplevel(exp_args);
LispVal *expanded_body = expand_function_body(name, return_tag, body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
expanded_body, false);
WITH_CLEANUP(exp_args, {
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, return_tag, exp_args,
the_stack->lexenv, expanded_body, false);
});
});
refcount_unref(Ffset(name, func));
return func;
@ -2142,11 +2306,15 @@ DEFMACRO(defmacro, "defmacro", (LispVal * name, LispVal *args, LispVal *body)) {
}
LispVal *return_tag =
make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
LispVal *exp_args = Fcopy_list(args);
expand_lambda_list_for_toplevel(exp_args);
LispVal *expanded_body = expand_function_body(name, return_tag, body);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
expanded_body, true);
WITH_CLEANUP(exp_args, {
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, return_tag, exp_args,
the_stack->lexenv, expanded_body, true);
});
});
refcount_unref(Ffset(name, func));
return func;
@ -2158,18 +2326,25 @@ DEFMACRO(lambda, "lambda", (LispVal * args, LispVal *body)) {
body = TAIL(body);
}
LispVal *return_tag;
LispVal *tag_name;
if (name == Qunbound) {
name = Qlambda;
tag_name = Qnil;
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) Qnil)->name));
} else {
CHECK_TYPE(TYPE_SYMBOL, name);
return_tag = make_lisp_symbol(LISPVAL(((LispSymbol *) name)->name));
tag_name = name;
}
LispVal *expanded_body = Fmacroexpand_all(body);
LispVal *expanded_body = expand_function_body(tag_name, return_tag, body);
LispVal *exp_args = Fcopy_list(args);
expand_lambda_list_for_toplevel(exp_args);
LispVal *func = Qnil;
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
expanded_body, false);
WITH_CLEANUP(exp_args, {
WITH_CLEANUP(expanded_body, {
func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
expanded_body, false);
});
});
return func;
}

14
src/lisp.h
View File

@ -295,7 +295,7 @@ inline static bool NUMBERP(LispVal *v) {
!NILP(__foreach_cur); \
__foreach_cur = TAIL(__foreach_cur), var = HEAD(__foreach_cur))
#define FOREACH_TAIL(var, list) \
for (LispVal *var = list; !NILP(var); var = TAIL(var))
for (LispVal *var = list; PAIRP(var); var = TAIL(var))
// #############################
// # Allocation and references #
@ -650,5 +650,17 @@ static inline LispVal *TAIL(LispVal *list) {
CHECK_TYPE(TYPE_PAIR, list);
return ((LispPair *) list)->tail;
}
static inline LispVal *HEAD_SAFE(LispVal *list) {
if (!PAIRP(list)) {
return Qnil;
}
return ((LispPair *) list)->head;
}
static inline LispVal *TAIL_SAFE(LispVal *list) {
if (!PAIRP(list)) {
return Qnil;
}
return ((LispPair *) list)->tail;
}
#endif