Improve macro expansion and returns

src/kernel.sl

@@ -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 ()
+(defmacro return (&opt value)
-  (return-from test 10))
+  (list 'return-from nil value))
-
-(println  (test))

src/lisp.c

@@ -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) {
+        if (!NILP(cur->return_tag) && cur->enable_handlers
-            Fthrow(cur->return_tag, const_list(true, 1, value));
+            && 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, {
+        LispVal *return_ptr = Fpair(Qnil, Qnil);
-            WITH_PUSH_FRAME(HEAD(form), TAIL(form), false, {
+        WITH_CLEANUP(return_ptr, {
-                the_stack->hidden = false;
+            WITH_CLEANUP(fobj, {
-                the_stack->lexenv = refcount_ref(fobj->lexenv);
+                WITH_PUSH_FRAME_NO_REF_HANDLING_THROWS(
-                process_lisp_args(Fhead(form), fobj, Ftail(form),
+                    refcount_ref(HEAD(form)), refcount_ref(TAIL(form)), false,
-                                  &the_stack->lexenv);
+                    {
-                expansion = Fprogn(fobj->body);
+                        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)))) {
+            if (PAIRP(toplevel)) {
-                FOREACH_TAIL(tail, TAIL(toplevel)) {
+                LispFunction *fobj = NULL;
-                    Fsethead(tail,
+                if (FUNCTIONP(HEAD(toplevel))) {
-                             filter_body_form(HEAD(tail), func, user_data));
+                    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, {
+    WITH_CLEANUP(exp_args, {
-        func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
+        WITH_CLEANUP(expanded_body, {
-                                  expanded_body, false);
+            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, {
+    WITH_CLEANUP(exp_args, {
-        func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
+        WITH_CLEANUP(expanded_body, {
-                                  expanded_body, true);
+            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, {
+    WITH_CLEANUP(exp_args, {
-        func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
+        WITH_CLEANUP(expanded_body, {
-                                  expanded_body, false);
+            func = make_lisp_function(name, return_tag, args, the_stack->lexenv,
+                                      expanded_body, false);
+        });
     });
     return func;
 }

src/lisp.h

@@ -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