diff --git a/lisp/kernel.gl b/lisp/kernel.gl index 05a4180..b3b0e47 100644 --- a/lisp/kernel.gl +++ b/lisp/kernel.gl @@ -1,3 +1,7 @@ ;; -*- mode: lisp-data -*- -(function-arity (lambda (y &optional x x))) +(fset 'test (cons 'macro (lambda (x) (declare (name test)) (list 'princ x)))) + +(prin1 (macroexpand-all '(lambda () (test x)) + '((test . (lambda (x) (test x)))))) +(write-byte ?\n) diff --git a/src/base.c b/src/base.c index 0a20fb0..094b7ee 100644 --- a/src/base.c +++ b/src/base.c @@ -282,8 +282,8 @@ static void check_handler_bind_handlers(LispVal *handlers) { CHECK_TYPE(XCDR(handler), TYPE_FUNCTION); if (LISTP(XCAR(handler))) { // make sure each condition is a symbol - DOTAILS(rest, XCAR(handler)) { - CHECK_TYPE(XCAR(rest), TYPE_SYMBOL); + DOLIST_SAFE(e, XCAR(handler)) { + CHECK_TYPE(e, TYPE_SYMBOL); } } else if (!SYMBOLP(XCAR(handler))) { // if the condition is not a list or symbol, it's an error diff --git a/src/base.h b/src/base.h index 3a18b75..fe95819 100644 --- a/src/base.h +++ b/src/base.h @@ -1,5 +1,5 @@ -#ifndef INCLUDED_TYPES_H -#define INCLUDED_TYPES_H +#ifndef INCLUDED_BASE_H +#define INCLUDED_BASE_H #include "argcountmacro.h" #include "gc.h" diff --git a/src/function.c b/src/function.c index 10ce269..80e3ebd 100644 --- a/src/function.c +++ b/src/function.c @@ -235,21 +235,6 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*cfunc)(void), } // Calling functions -static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args) { - LispVal *start = Qnil; - LispVal *end = NULL; - DOLIST(arg, args) { - if (NILP(start)) { - start = CONS(Feval(arg, Vlexical_environment), Qnil); - end = start; - } else { - RPLACD(end, CONS(Feval(arg, Vlexical_environment), Qnil)); - end = XCDR(end); - } - } - return start; -} - enum ProcessArgsResult { PROCESS_ARGS_OK, PROCESS_ARGS_TOO_FEW, @@ -334,13 +319,7 @@ static noreturn void signal_argument_error(enum ProcessArgsResult res) { lisp_signal(Qargument_error, LIST(msg)); } -static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, - LispFunction *fobj, LispVal *args) { - StackFrame *stack_ref = LISP_STACK_REF(); - if (!fobj->impl.native.no_eval_args) { - args = evaluate_function_arguments(args); - } - set_stack_evaluated_args(LISP_STACK_REF(), fobj, args); +static ALWAYS_INLINE LispVal *call_native(LispFunction *fobj, LispVal *args) { LispVal *arg_arr[MAX_NATIVE_FUNCTION_ARGS] = {NULL}; size_t count = NATIVE_FUNCTION_TOTAL_ARG_COUNT(fobj); intptr_t rest_idx; @@ -381,7 +360,7 @@ static ALWAYS_INLINE LispVal *call_native(LispVal *orig_func, default: abort(); } - return UNWIND_AND_RETURN(stack_ref, retval); + return retval; } static ALWAYS_INLINE void push_optional_argument_to_lexenv(LispVal *spec, @@ -455,21 +434,17 @@ push_interpreted_args_to_lexenv(LispFunction *fobj, LispVal *args) { return PROCESS_ARGS_OK; } -static ALWAYS_INLINE LispVal * -call_interpreted(LispVal *orig_func, LispFunction *fobj, LispVal *args) { - StackFrame *stack_ref = LISP_STACK_REF(); - LispVal *evaled_args = evaluate_function_arguments(args); - set_stack_evaluated_args(LISP_STACK_REF(), fobj, evaled_args); +static ALWAYS_INLINE LispVal *call_interpreted(LispFunction *fobj, + LispVal *args) { push_dynamic_binding(Qlexical_environment, fobj->impl.interp.lexenv); - enum ProcessArgsResult par = - push_interpreted_args_to_lexenv(fobj, evaled_args); + enum ProcessArgsResult par = push_interpreted_args_to_lexenv(fobj, args); if (par != PROCESS_ARGS_OK) { signal_argument_error(par); } - return UNWIND_AND_RETURN(stack_ref, Fprogn(fobj->impl.interp.body)); + return Fprogn(fobj->impl.interp.body); } -static LispFunction *coerce_to_function(LispVal *func) { +LispFunction *coerce_to_function(LispVal *orig_name, LispVal *func) { LispFunction *fobj = func; if (SYMBOLP(func)) { fobj = Fsymbol_function(func, Qt); @@ -477,29 +452,39 @@ static LispFunction *coerce_to_function(LispVal *func) { fobj = Feval(func, Vlexical_environment); } if (NILP(fobj)) { + lisp_signal(Qvoid_function_error, LIST(orig_name)); + } else if (!FUNCTIONP(fobj)) { signal_type_error(fobj, LIST(Qcallable)); } - // include symbol here for the error message - CHECK_TYPE(fobj, TYPE_FUNCTION, TYPE_SYMBOL); assert(FUNCTIONP(fobj)); return fobj; } -DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", - "") { - StackFrame *stack_ref = LISP_STACK_REF(); - push_call_frame(func, args); - LispFunction *fobj = coerce_to_function(func); +LispVal *raw_funcall(LispVal *func, LispVal *args) { + assert(FUNCTIONP(func)); + LispFunction *fobj = func; switch (fobj->type) { case FUNCTION_NATIVE: - return UNWIND_AND_RETURN(stack_ref, call_native(func, fobj, args)); + return call_native(fobj, args); case FUNCTION_INTERP: - return UNWIND_AND_RETURN(stack_ref, call_interpreted(func, fobj, args)); + return call_interpreted(fobj, args); default: abort(); } } +DEFUN(funcall, "funcall", (LispVal * func, LispVal *args), "(func &rest args)", + "") { + LispVal *res = coerce_to_function(func, func); + if (!NILP(Fspecial_form_p(res))) { + signal_type_error(res, Qfunction); + } + StackFrame *stack_ref = LISP_STACK_REF(); + push_call_frame(func, args); + set_stack_evaluated_args(LISP_STACK_REF(), res, args); + return UNWIND_AND_RETURN(stack_ref, raw_funcall(res, args)); +} + static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) { while (CONSP(body) && CONSP(XCAR(body)) && EQ(XCAR(XCAR(body)), Qdeclare)) { LispVal *decls = XCDR(XCAR(body)); @@ -519,6 +504,18 @@ static LispVal *parse_lambda_declare_form(LispFunction *fobj, LispVal *body) { return body; } +static void macroexpand_lambda_list(struct LambdaList *restrict ll) { + DOLIST(ent, ll->opt) { + RPLACA(XCDR(ent), Fmacroexpand_all(SECOND(ent), Qnil)); + } + if (HASH_TABLE_P(ll->kw)) { + HT_FOREACH_INDEX(ll->kw, i) { + LispVal *ent = HASH_VALUE(ll->kw, i); + RPLACA(XCDR(XCDR(ent)), Fmacroexpand_all(THIRD(ent), Qnil)); + } + } +} + DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body), "(args &rest body)", "") { LambdaListParseResult llpr; @@ -542,7 +539,8 @@ DEFSPECIAL(lambda, "lambda", (LispVal * args, LispVal *body), fobj->docstr = Qnil; } body = parse_lambda_declare_form(fobj, body); - fobj->impl.interp.body = body; + macroexpand_lambda_list(&fobj->args); + fobj->impl.interp.body = macroexpand_list(body, Qnil); fobj->impl.interp.lexenv = Vlexical_environment; return fobj; } @@ -556,8 +554,9 @@ DEFUN(callablep, "callablep", (LispVal * obj), "(obj)", "") { } DEFUN(function_arity, "function-arity", (LispVal * func), "(func)", - "Return a list of the form (NUM-REQ NUM-OPT KW-NAMES HAS-REST).") { - LispFunction *fobj = coerce_to_function(func); + "Return a list of the form (NUM-REQ NUM-OPT KW-NAMES ALLOW-OTHER-KEYS " + "HAS-REST).") { + LispFunction *fobj = coerce_to_function(func, func); LispVal *kw = Qnil; if (HASH_TABLE_P(fobj->args.kw)) { HT_FOREACH_INDEX(fobj->args.kw, i) { @@ -565,7 +564,28 @@ DEFUN(function_arity, "function-arity", (LispVal * func), "(func)", } } return LIST(MAKE_FIXNUM(fobj->args.n_req), MAKE_FIXNUM(fobj->args.n_opt), - kw, NILP(fobj->args.rest) ? Qnil : Qt); + kw, fobj->args.allow_other_keys ? Qt : Qnil, + NILP(fobj->args.rest) ? Qnil : Qt); +} + +bool builtin_function_p(LispVal *val, bool special_form) { + if (SYMBOLP(val)) { + val = Fsymbol_function(val, Qt); + } + if (FUNCTIONP(val)) { + LispFunction *fobj = val; + return fobj->type == FUNCTION_NATIVE + && fobj->impl.native.no_eval_args == special_form; + } + return false; +} + +DEFUN(builtin_function_p, "builtin-function-p", (LispVal * val), "(val)", "") { + return builtin_function_p(val, false) ? Qt : Qnil; +} + +DEFUN(special_form_p, "special-form-p", (LispVal * val), "(val)", "") { + return builtin_function_p(val, true) ? Qt : Qnil; } DEFINE_SYMBOL(declare, "declare"); @@ -574,6 +594,8 @@ DEFINE_SYMBOL(name, "name"); DEFINE_SYMBOL(callable, "callable"); DEFINE_SYMBOL(argument_error, "argument-error"); DEFINE_CONDITION_CLASS(argument_error, error); +DEFINE_SYMBOL(void_function_error, "void-function-error"); +DEFINE_CONDITION_CLASS(void_function_error, error); DEFINE_SYMBOL(function_definition_error, "function-definition-error"); DEFINE_CONDITION_CLASS(function_definition_error, error); diff --git a/src/function.h b/src/function.h index a619576..992a0c9 100644 --- a/src/function.h +++ b/src/function.h @@ -89,6 +89,9 @@ LispVal *make_builtin_function(LispVal *name, LispVal *(*func)(void), make_lisp_string(internal_F##cname##_docstr, \ internal_F##cname##_docstr_len, false, false)) +LispFunction *coerce_to_function(LispVal *orig_name, LispVal *func); +// Call a function object directly +LispVal *raw_funcall(LispVal *func, LispVal *args); DECLARE_FUNCTION(funcall, (LispVal * func, LispVal *args)); #define CALL(func, ...) (Ffuncall((func), LIST(__VA_ARGS__))) #define CALL0(func) (Ffuncall((func), Qnil)) @@ -97,12 +100,18 @@ DECLARE_FUNCTION(lambda, (LispVal * args, LispVal *body)); DECLARE_FUNCTION(callablep, (LispVal * obj)); DECLARE_FUNCTION(function_arity, (LispVal * func)); +bool builtin_function_p(LispVal *val, bool special_form); +DECLARE_FUNCTION(builtin_function_p, (LispVal * val)); +DECLARE_FUNCTION(special_form_p, (LispVal * val)); + DECLARE_SYMBOL(declare); DECLARE_SYMBOL(name); DECLARE_SYMBOL(callable); DECLARE_SYMBOL(argument_error); MAKE_CONDITION_CLASS(argument_error); +DECLARE_SYMBOL(void_function_error); +MAKE_CONDITION_CLASS(void_function_error); DECLARE_SYMBOL(function_definition_error); MAKE_CONDITION_CLASS(function_definition_error); diff --git a/src/gen-init-globals.awk b/src/gen-init-globals.awk index b74b223..9fd5d71 100644 --- a/src/gen-init-globals.awk +++ b/src/gen-init-globals.awk @@ -72,7 +72,7 @@ function get_next_symbol() { function maybe_emit_next_symbol(entity) { name = get_next_symbol() if (name) { - print " REGISTER_GLOBAL_" entity "(" get_next_symbol() ");"; + print " REGISTER_GLOBAL_" entity "(" name ");"; } } diff --git a/src/lisp.c b/src/lisp.c index 23e9a52..09f5290 100644 --- a/src/lisp.c +++ b/src/lisp.c @@ -84,6 +84,22 @@ static inline LispVal *lookup_variable(LispSymbol *name, LispVal *lexenv) { return SYMBOL_VALUE(name); } +static ALWAYS_INLINE LispVal *evaluate_function_arguments(LispVal *args, + LispVal *lexenv) { + LispVal *start = Qnil; + LispVal *end = NULL; + DOLIST(arg, args) { + if (NILP(start)) { + start = CONS(Feval(arg, lexenv), Qnil); + end = start; + } else { + RPLACD(end, CONS(Feval(arg, lexenv), Qnil)); + end = XCDR(end); + } + } + return start; +} + DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), "(form &optional lexenv)", "") { if (!OBJECTP(form)) { @@ -109,8 +125,24 @@ DEFUN(eval, "eval", (LispVal * form, LispVal *lexenv), } case TYPE_SYMBOL: return lookup_variable(form, lexenv); - case TYPE_CONS: - return Ffuncall(XCAR(form), XCDR(form)); + case TYPE_CONS: { + LispVal *res = XCAR(form); + if (SYMBOLP(res)) { + res = Fsymbol_function(res, Qt); + } + if (!NILP(Fmacrop(res))) { + return Feval(Fmacroexpand_all(form, Qnil), lexenv); + } + LispVal *stack_ref = LISP_STACK_REF(); + push_call_frame(XCAR(form), XCDR(form)); + LispVal *evaled_args = XCDR(form); + if (NILP(Fspecial_form_p(res))) { + evaled_args = evaluate_function_arguments(XCDR(form), lexenv); + } + LispVal *fobj = coerce_to_function(XCAR(form), res); + set_stack_evaluated_args(LISP_STACK_REF(), fobj, evaled_args); + return UNWIND_AND_RETURN(stack_ref, raw_funcall(fobj, evaled_args)); + } case TYPE_FIXNUM: case TYPE_FLOAT: default: diff --git a/src/lisp.h b/src/lisp.h index 9ca5ac2..7a3bf9a 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -6,6 +6,7 @@ #include "hashtable.h" // IWYU pragma: export #include "lisp_string.h" // IWYU pragma: export #include "list.h" // IWYU pragma: export +#include "macro.h" // IWYU pragma: export #include "print.h" // IWYU pragma: export #include "stack.h" // IWYU pragma: export diff --git a/src/list.c b/src/list.c index 56e8537..6cfccc0 100644 --- a/src/list.c +++ b/src/list.c @@ -35,6 +35,16 @@ DEFUN(cons, "cons", (LispVal * car, LispVal *cdr), "(car cdr)", return CONS(car, cdr); } +DEFUN(car, "car", (LispVal * list), "(list)", "") { + CHECK_LISTP(list); + return NILP(list) ? Qnil : XCAR(list); +} + +DEFUN(cdr, "cdr", (LispVal * list), "(list)", "") { + CHECK_LISTP(list); + return NILP(list) ? Qnil : XCDR(list); +} + DEFUN(length, "length", (LispVal * list), "(list)", "") { CHECK_LISTP(list); intptr_t len = list_length(list); @@ -96,11 +106,30 @@ DEFUN(list, "list", (LispVal * args), "(&rest args)", "") { return args; } +DEFUN(copy_list, "copy-list", (LispVal * list), "(list)", "") { + LispVal *start = Qnil; + LispVal *end = NULL; + DOTAILS(rest, list) { + if (!CONSP(rest)) { + RPLACD(end, rest); + break; + } + if (NILP(start)) { + start = CONS(XCAR(rest), Qnil); + end = start; + } else { + RPLACD(end, CONS(XCAR(rest), Qnil)); + end = XCDR(end); + } + } + return start; +} + LispVal *nth(size_t n, LispVal *list) { size_t i = 0; - DOTAILS(rest, list) { + DOLIST_SAFE(elt, list) { if (i == n) { - return XCAR(rest); + return elt; } ++i; } @@ -117,12 +146,14 @@ DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred), if (NILP(pred) || pred == Qeq) { // fast case DOTAILS(rest, list) { + CHECK_LISTP(rest); if (elt == XCAR(rest)) { return rest; } } } else { DOTAILS(rest, list) { + CHECK_LISTP(rest); if (!NILP(CALL(pred, elt, XCAR(rest)))) { return rest; } @@ -134,6 +165,7 @@ DEFUN(member, "member", (LispVal * elt, LispVal *list, LispVal *pred), DEFUN(member_if, "member-if", (LispVal * pred, LispVal *list), "(pred list)", "") { DOTAILS(rest, list) { + CHECK_LISTP(rest); if (!NILP(CALL(pred, XCAR(rest)))) { return rest; } @@ -145,7 +177,9 @@ DEFUN(plist_put, "plist-put", (LispVal * plist, LispVal *prop, LispVal *value), "(plist prop value)", "") { CHECK_LISTP(plist); DOTAILS(rest, plist) { + CHECK_LISTP(rest); if (EQ(XCAR(rest), prop)) { + CHECK_TYPE(XCDR(rest), TYPE_CONS); RPLACA(XCDR(rest), value); return plist; } @@ -163,3 +197,24 @@ DEFUN(plist_get, "plist-get", (LispVal * plist, LispVal *prop, LispVal *def), } return def; } + +DEFUN(assoc, "assoc", (LispVal * key, LispVal *alist, LispVal *pred), + "(key alist &optional pred)", "") { + if (NILP(pred)) { + DOLIST_SAFE(ent, alist) { + CHECK_TYPE(ent, TYPE_CONS); + if (EQ(key, XCAR(ent))) { + return ent; + } + } + return Qnil; + } else { + DOLIST_SAFE(ent, alist) { + CHECK_TYPE(ent, TYPE_CONS); + if (!NILP(CALL(pred, key, XCAR(ent)))) { + return ent; + } + } + return Qnil; + } +} diff --git a/src/list.h b/src/list.h index f86e21f..28a29d5 100644 --- a/src/list.h +++ b/src/list.h @@ -106,6 +106,10 @@ static ALWAYS_INLINE LispVal *LIST_N(int count, ...) { for (LispVal *_tail = (l), *v = XCAR(_tail); !NILP(_tail); \ _tail = XCDR(_tail), v = XCAR(_tail)) +#define DOLIST_SAFE(v, l) \ + for (LispVal *_tail = (l), *v = Fcar(_tail); !NILP(_tail); \ + _tail = Fcdr(_tail), v = Fcar(_tail)) + #define DOTAILS(v, l) for (LispVal *v = (l); !NILP(v); v = XCDR_SAFE(v)) DECLARE_SYMBOL(circular_list_error); @@ -117,6 +121,8 @@ intptr_t list_length(LispVal *list); bool list_length_eq(LispVal *list, intptr_t size); DECLARE_FUNCTION(cons, (LispVal * car, LispVal *cdr)); +DECLARE_FUNCTION(car, (LispVal * list)); +DECLARE_FUNCTION(cdr, (LispVal * list)); DECLARE_FUNCTION(length, (LispVal * list)); DECLARE_FUNCTION(length_eq, (LispVal * list, LispVal *length)); DECLARE_FUNCTION(nreverse, (LispVal * list)); @@ -126,6 +132,7 @@ DECLARE_FUNCTION(proper_list_p, (LispVal * obj)); DECLARE_FUNCTION(circular_list_p, (LispVal * obj)); DECLARE_FUNCTION(dotted_list_p, (LispVal * obj)); DECLARE_FUNCTION(list, (LispVal * args)); +DECLARE_FUNCTION(copy_list, (LispVal * list)); LispVal *nth(size_t n, LispVal *list); DECLARE_FUNCTION(nth, (LispVal * n, LispVal *list)); static ALWAYS_INLINE void CHECK_LISTP(LispVal *obj) { @@ -141,4 +148,6 @@ DECLARE_FUNCTION(member_if, (LispVal * pred, LispVal *list)); DECLARE_FUNCTION(plist_put, (LispVal * plist, LispVal *prop, LispVal *value)); DECLARE_FUNCTION(plist_get, (LispVal * plist, LispVal *prop, LispVal *def)); +DECLARE_FUNCTION(assoc, (LispVal * key, LispVal *alist, LispVal *pred)); + #endif diff --git a/src/macro.c b/src/macro.c new file mode 100644 index 0000000..091fd5d --- /dev/null +++ b/src/macro.c @@ -0,0 +1,162 @@ +#include "macro.h" + +#include "function.h" +#include "lisp.h" +#include "list.h" + +DEFINE_SYMBOL(macro, "macro"); + +DEFUN(macrop, "macrop", (LispVal * obj), "(obj)", "") { + if (SYMBOLP(obj)) { + obj = Fsymbol_function(obj, Qt); + } + if (CONSP(obj) && EQ(XCAR(obj), Qmacro) && !NILP(Fcallablep(XCDR(obj)))) { + return XCDR(obj); + } + return Qnil; +} + +static LispVal *resolve_macro(LispVal *sym_or_list, LispVal *lexical_macros) { + if (SYMBOLP(sym_or_list)) { + LispVal *lexical_entry = Fassoc(sym_or_list, lexical_macros, Qnil); + if (CONSP(lexical_entry)) { + return XCDR(lexical_entry); + } + } + return Fmacrop(sym_or_list); +} + +DEFUN(macroexpand_1, "macroexpand-1", (LispVal * form, LispVal *lexical_macros), + "(form &optional lexical-macros)", "") { + CHECK_LISTP(form); + if (NILP(form)) { + return Qnil; + } + LispVal *func = resolve_macro(XCAR(form), lexical_macros); + if (NILP(func)) { + return form; + } + return Ffuncall(func, XCDR(form)); +} + +DEFUN(macroexpand_toplevel, "macroexpand-toplevel", + (LispVal * form, LispVal *lexical_macros), + "(form &optional lexical-macros)", "") { + while (CONSP(form) + && (!NILP(Fmacrop(XCAR(form))) + || !NILP(Fassoc(XCAR(form), lexical_macros, Qnil)))) { + form = Fmacroexpand_1(form, lexical_macros); + } + return form; +} + +LispVal *macroexpand_list(LispVal *list, LispVal *lexical_macros) { + LispVal *start = Qnil; + LispVal *end = NULL; + DOTAILS(rest, list) { + if (!LISTP(rest)) { + RPLACD(end, rest); + break; + } + LispVal *expanded = Fmacroexpand_all(XCAR(rest), lexical_macros); + if (NILP(start)) { + start = CONS(expanded, Qnil); + end = start; + } else { + RPLACD(end, CONS(expanded, Qnil)); + end = XCDR(end); + } + } + return start; +} + +static LispVal *macroexpand_lambda_form(LispVal *form, + LispVal *lexical_macros) { + LispVal *body = macroexpand_list(XCDR_SAFE(XCDR(form)), lexical_macros); + LispVal *lambda_list = Fcopy_list(XCAR_SAFE(XCDR(form))); + enum { REQ, OPT, KEY } state = REQ; + DOTAILS(rest, XCAR_SAFE(XCDR(form))) { + if (!CONSP(rest)) { + break; + } + LispVal *ent = XCAR(rest); + if (state == REQ && EQ(ent, Qand_optional)) { + state = OPT; + } else if (state == OPT && EQ(ent, Qand_key)) { + state = KEY; + } else if ((state == KEY || state == OPT) && CONSP(ent) + && CONSP(XCDR(ent))) { + ent = Fcopy_list(ent); + RPLACA(rest, ent); + RPLACA(XCDR(ent), Fmacroexpand_all(SECOND(ent), lexical_macros)); + } + } + return CONS(XCAR(form), CONS(lambda_list, body)); +} + +static LispVal *macroexpand_special_form(LispVal *fobj, LispVal *form, + LispVal *lexical_macros) { + assert(FUNCTIONP(fobj)); +#define IS(n) (fobj == ((LispSymbol *) Q##n)->function) + if (IS(lambda)) { + return macroexpand_lambda_form(form, lexical_macros); + } else if (IS(quote)) { + return form; + } else if (IS(progn) || IS(if) || IS(and) || IS(or)) { + if (LISTP(XCDR(form))) { + return CONS(XCAR(form), + macroexpand_list(XCDR(form), lexical_macros)); + } + return form; + } else if (IS(setq)) { + LispVal *args = Fcopy_list(XCDR(form)); + bool expand = false; + DOTAILS(rest, args) { + if (expand) { + RPLACA(rest, Fmacroexpand_all(XCAR(rest), lexical_macros)); + } + expand = !expand; + } + return CONS(XCAR(form), args); + } else if (IS(let)) { + LispVal *bindings = Fcopy_list(SECOND(form)); + DOTAILS(rest, bindings) { + if (!LISTP(rest)) { + break; + } + LispVal *binding = XCAR(rest); + if (CONSP(binding) && CONSP(XCDR(binding))) { + RPLACA(XCDR(binding), + Fmacroexpand_all(SECOND(binding), lexical_macros)); + } + } + LispVal *prog = + macroexpand_list(XCDR_SAFE(XCDR_SAFE(form)), lexical_macros); + return CONS(XCAR(form), CONS(bindings, prog)); + } + abort(); +#undef IS +} + +DEFUN(macroexpand_all, "macroexpand-all", + (LispVal * form, LispVal *lexical_macros), + "(form &optional lexical-macros)", "") { + if (!CONSP(form)) { + return form; + } + LispVal *func = XCAR(form); + if (SYMBOLP(func)) { + func = Fsymbol_function(func, Qt); + } + if (builtin_function_p(func, true)) { + return macroexpand_special_form(func, form, lexical_macros); + } else { + form = Fmacroexpand_toplevel(form, lexical_macros); + if (CONSP(form) && CONSP(XCDR(form))) { + return CONS(XCAR(form), + macroexpand_list(XCDR(form), lexical_macros)); + } + return form; + } + return Qnil; +} diff --git a/src/macro.h b/src/macro.h new file mode 100644 index 0000000..6f321e4 --- /dev/null +++ b/src/macro.h @@ -0,0 +1,15 @@ +#ifndef INCLUDED_MACRO_H +#define INCLUDED_MACRO_H + +#include "base.h" + +DECLARE_SYMBOL(macro); + +DECLARE_FUNCTION(macrop, (LispVal * obj)); +DECLARE_FUNCTION(macroexpand_1, (LispVal * form, LispVal *lexical_macros)); +DECLARE_FUNCTION(macroexpand_toplevel, + (LispVal * form, LispVal *lexical_macros)); +LispVal *macroexpand_list(LispVal *list, LispVal *lexical_macros); +DECLARE_FUNCTION(macroexpand_all, (LispVal * form, LispVal *lexical_macros)); + +#endif diff --git a/src/print.c b/src/print.c index 49dcdaa..e4e41ca 100644 --- a/src/print.c +++ b/src/print.c @@ -349,7 +349,11 @@ static void print_function(struct PrintContext *restrict pc, LispVal *val) { print_char(pc, '<'); switch (f->type) { case FUNCTION_NATIVE: - PRINT_STATIC_BUFFER(pc, "native-function"); + if (f->impl.native.no_eval_args) { + PRINT_STATIC_BUFFER(pc, "special-form"); + } else { + PRINT_STATIC_BUFFER(pc, "native-function"); + } break; case FUNCTION_INTERP: PRINT_STATIC_BUFFER(pc, "interp-function"); @@ -358,6 +362,10 @@ static void print_function(struct PrintContext *restrict pc, LispVal *val) { abort(); } print_char(pc, ' '); + if (!NILP(f->name)) { + print_driver(pc, f->name); + print_char(pc, ' '); + } // large enough for 32 or 64 bit word size char buffer[32]; int written = snprintf(buffer, sizeof(buffer), "0x%jx", (uintmax_t) &f);