Skip to content
Browse files

add macroexpand-1, macro?

  • Loading branch information...
1 parent 0030619 commit 537ec3babfd8fb0386680ad75915b5c7d0caeee7 @cpylua committed Apr 15, 2012
Showing with 91 additions and 25 deletions.
  1. +64 −24 eval.c
  2. +26 −1 procdef.c
  3. +1 −0 procdef.h
View
88 eval.c
@@ -762,6 +762,34 @@ static object* eval_env(object *args) {
return env;
}
+static object* expand_macro(object *raw_exp, object *macro, object *args) {
+ object *texp, *tenv, *op, *exp, *params;
+
+ /* handle var-arg */
+ op = obj_mv(macro);
+ params = normalize_lambda_args(obj_lvargc(op), obj_lvvar(op), args);
+ if (params == NULL) {
+ fprintf(stderr, "wrong arity `");
+ sc_write(stderr, raw_exp);
+ fprintf(stderr, "\n");
+ return NULL;
+ }
+
+ /* do macro transform */
+ gc_protect(params);
+ tenv = extend_env(obj_lvp(op),
+ params,
+ obj_lve(op));
+ texp = make_begin(obj_lvb(op));
+ gc_protect(tenv);
+ gc_protect(texp);
+ exp = sc_eval(texp, tenv);
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ return exp;
+}
+
object* sc_eval(object *exp, object *env) {
object *val = NULL;
@@ -875,37 +903,17 @@ object* sc_eval(object *exp, object *env) {
op = sc_eval(operator(exp), env);
if (is_macro(op)) {
- object *texp, *tenv;
- /* handle var-arg */
- op = obj_mv(op);
args = cdr(exp);
gc_protect(op);
gc_protect(args);
- args = normalize_lambda_args(obj_lvargc(op), obj_lvvar(op), args);
- if (args == NULL) {
- fprintf(stderr, "wrong arity `");
- sc_write(stderr, exp);
- fprintf(stderr, "\n");
- gc_abandon();
- gc_abandon();
+ exp = expand_macro(exp, op, args);
+ gc_abandon(); /* args */
+ gc_abandon(); /* op */
+ if (exp == NULL) {
gc_abandon();
gc_abandon();
return NULL;
}
-
- /* do macro transform */
- tenv = extend_env(obj_lvp(op),
- args,
- obj_lve(op));
- texp = make_begin(obj_lvb(op));
- gc_protect(tenv);
- gc_protect(texp);
- exp = sc_eval(texp, tenv);
- gc_abandon();
- gc_abandon();
-
- gc_abandon(); /* args */
- gc_abandon(); /* op */
goto tailcall;
}
@@ -968,6 +976,38 @@ object* sc_eval(object *exp, object *env) {
goto tailcall;
}
+ /* handle macroexpand specially for args */
+ if (is_macroexpand(op)) {
+ if (!is_empty_list(cdr(args))) {
+ fprintf(stderr, "%s\n", "wrong arity in macroexpand");
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ return NULL;
+ } else {
+ object *mexp = car(args);
+ object *macro = sc_eval(car(mexp), env);
+ if (!is_macro(macro)) {
+ sc_write(stderr, car(mexp));
+ fprintf(stderr, "%s\n", " not a macro");
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ return NULL;
+ }
+ gc_protect(macro);
+ val = expand_macro(mexp, macro, cdr(mexp));
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ gc_abandon();
+ return val;
+ }
+ }
+
if (is_callwcc(op)) {
object *c;
if (!is_empty_list(cdr(args))) {
View
27 procdef.c
@@ -1270,7 +1270,7 @@ static int random_proc(object *params, object **result) {
static int callwcc_proc(object *params, object **result) {
/* handled specially in sc_eval.
*
- * this function exists so that apply can be treated
+ * this function exists so that call/cc can be treated
* as normal function in Scheme code.
*/
return SC_E_INV_STAT;
@@ -1281,6 +1281,20 @@ int is_callwcc(object *exp) {
obj_fv(exp) == callwcc_proc;
}
+static int macroexpand_proc(object *params, object **result) {
+ /* handled specially in sc_eval.
+ *
+ * this function exists so that macroexpand can be treated
+ * as normal function in Scheme code.
+ */
+ return SC_E_INV_STAT;
+}
+
+int is_macroexpand(object *exp) {
+ return is_primitive_proc(exp) &&
+ obj_fv(exp) == macroexpand_proc;
+}
+
#define DEFAULT_PREFIX "GEN"
static int gensym_proc(object *params, object **result) {
char *prefix, *sym;
@@ -1315,6 +1329,15 @@ static int gensym_proc(object *params, object **result) {
return 0;
}
+static int is_macro_proc(object *params, object **result) {
+ object *obj;
+ check_null(result);
+ check_arg1(params);
+ obj = car(params);
+ *result = is_macro(obj) ? get_true_obj() : get_false_obj();
+ return 0;
+}
+
#define DEFINE_LIST_PROC(name) \
define_proc(#name, name ## _proc)
@@ -1417,6 +1440,8 @@ int init_primitive(object *env) {
define_proc("random", random_proc);
define_proc("gensym", gensym_proc);
+ define_proc("macro?", is_macro_proc);
+ define_proc("macroexpand-1", macroexpand_proc);
ret = init_io_primitive(env);
if (ret != 0) {
View
1 procdef.h
@@ -46,6 +46,7 @@ char* error_str(int err);
int is_apply(object *obj);
int is_eval(object *obj);
int is_callwcc(object *exp);
+int is_macroexpand(object *exp);
int env_define_proc(char *sym, prim_proc fn, object *env);
double number_to_double(object *obj);

0 comments on commit 537ec3b

Please sign in to comment.
Something went wrong with that request. Please try again.