Permalink
Browse files

macro support

  • Loading branch information...
1 parent 7717942 commit 84b62fea49613d08264311d979bba5cdbd9075a2 @cpylua committed Apr 15, 2012
Showing with 172 additions and 1 deletion.
  1. +76 −0 eval.c
  2. +4 −0 gc.c
  3. +14 −0 macro.c
  4. +1 −1 makefile
  5. +8 −0 object.h
  6. +6 −0 sform.c
  7. +1 −0 sform.h
  8. +60 −0 test/macro-test.scm
  9. +2 −0 write.c
View
76 eval.c
@@ -605,6 +605,44 @@ static object* eval_exps(object *args) {
return car(args);
}
+/* macro functions */
+static int is_macro_definition(object *exp) {
+ return is_tagged_list(exp, get_definemacro_symbol());
+}
+
+static object *eval_macro_definition(object *exp, object *env) {
+ object *var, *val;
+ char msg[] = "wrong arity in `define-macro form\n";
+ int ret;
+
+ var = definition_variable(exp);
+ val = definition_value(exp);
+ if (val == NULL || var == NULL ||
+ (is_symbol(cadr(exp)) && !is_empty_list(cdddr(exp)))) {
+ fprintf(stderr, "%s", msg);
+ return NULL;
+ }
+ if (!is_variable(var)) {
+ fprintf(stderr, "%s\n", "variable must be symbol");
+ return NULL;
+ }
+
+ gc_protect(val); /* protect lambda form */
+ val = sc_eval(val, env);
+ if (val == NULL) {
+ return NULL;
+ }
+ val = make_macro(val);
+ ret = define_variable(var, val, env);
+ gc_abandon();
+ if (ret != 0) {
+ fprintf(stderr, "%s\n",
+ "unexpected error in define-macro");
+ return NULL;
+ }
+ return get_nrv_symbol();
+}
+
static object* eval_env(object *args) {
object *env;
@@ -644,6 +682,8 @@ object* sc_eval(object *exp, object *env) {
val = eval_assignment(exp, env);
} else if (is_definition(exp)) {
val = eval_definition(exp, env);
+ } else if (is_macro_definition(exp)) {
+ val = eval_macro_definition(exp, env);
} else if (is_if(exp)) {
object *pred;
if (!check_if_arity(exp)) {
@@ -730,6 +770,42 @@ object* sc_eval(object *exp, object *env) {
int err;
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();
+ 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;
+ }
+
+ /* normal application */
gc_protect(op);
args = list_of_values(operands(exp), env);
if (args == NULL) {
View
4 gc.c
@@ -343,6 +343,10 @@ static void mark_object(object *obj) {
mark_object(objs[i]);
}
}
+ if (is_macro(obj)) {
+ obj = obj_mv(obj);
+ goto tailcall;
+ }
}
static void mark_stack_root(stack_elem elem) {
View
14 macro.c
@@ -0,0 +1,14 @@
+#include "object.h"
+#include "mem.h"
+
+int is_macro(object *obj) {
+ return obj != NULL && type(obj) == MACRO;
+}
+
+object *make_macro(object *t) {
+ object *obj = alloc_object();
+ type(obj) = MACRO;
+ obj_mv(obj) = t;
+ return obj;
+}
+
View
@@ -5,7 +5,7 @@ OBJS = eval.o mem.o reader.o fixnum.o charcache.o \
primitive.o procdef.o compound.o eof.o \
port.o ioproc.o gc.o stack.o intcache.o \
mathproc.o strproc.o objstream.o vector.o \
- vecproc.o frame.o cont.o
+ vecproc.o frame.o cont.o macro.o
CFLAG = -Wall -c
LFLAG = -lm -lrt
View
@@ -27,6 +27,7 @@ typedef enum {
VECTOR,
ENV_FRAME,
CONT,
+ MACRO,
} object_type;
struct object;
@@ -86,6 +87,9 @@ typedef struct object {
unsigned char argc; /* (x y . z) is 2 */
} compound_proc;
struct {
+ struct object *transformer;
+ } macro;
+ struct {
FILE *stream;
} input_port;
struct {
@@ -124,6 +128,7 @@ typedef struct object {
#define gc_chain(p) ((p)->gc.chain)
#define obj_rbtv(p) (p->data.env_frame.tree)
#define obj_cont(p) (p->data.continuation.c)
+#define obj_mv(p) (p->data.macro.transformer)
#define SIZEOF_OBJECT sizeof(object)
@@ -239,5 +244,8 @@ void cont_free(object *obj);
object* get_escape_val(void);
#define restore_cont(c, v) internal_restore_cont(c, v, 1);
+int is_macro(object *obj);
+object *make_macro(object *t);
+
#endif
View
@@ -15,6 +15,7 @@ static object *g_let_symbol;
static object *g_and_symbol;
static object *g_or_symbol;
static object *g_callwcc_symbol;
+static object *g_definemacro_symbol;
#define DEFINE_SYMBOL(var, sym) \
{ \
@@ -40,6 +41,7 @@ int sform_init(void) {
DEFINE_SYMBOL(g_and_symbol, "and");
DEFINE_SYMBOL(g_or_symbol, "or");
DEFINE_SYMBOL(g_callwcc_symbol, "call-with-current-continuation");
+ DEFINE_SYMBOL(g_definemacro_symbol, "define-macro");
return 0;
}
@@ -96,3 +98,7 @@ object* get_callwcc_symbol(void) {
return g_callwcc_symbol;
}
+object* get_definemacro_symbol(void) {
+ return g_definemacro_symbol;
+}
+
View
@@ -18,6 +18,7 @@ object* get_let_symbol(void);
object* get_and_symbol(void);
object* get_or_symbol(void);
object* get_callwcc_symbol(void);
+object* get_definemacro_symbol(void);
#endif
View
@@ -0,0 +1,60 @@
+(define-macro when
+ (lambda (test . branch)
+ (list 'if test (cons 'begin branch))))
+(define test 1)
+(when (< test 89)
+ (display-line "line 1")
+ (display-line "line 2")
+ (display-line "done"))
+
+(when (< test 0)
+ (display-line "never here")
+ (display-line "never here 2"))
+
+(define-macro unless
+ (lambda (test . branch)
+ (cons 'when
+ (cons (list 'not test) branch))))
+
+(unless (< test 89)
+ (display-line "never here")
+ (display-line "never here 2"))
+
+(unless (< test 0)
+ (display-line "line 1")
+ (display-line "line 2")
+ (display-line "done"))
+
+
+(define-macro my-or-wrong
+ (lambda (x y)
+ (list 'if x x y)))
+(display-line (my-or-wrong 1 2))
+(display-line (my-or-wrong #f 2))
+(my-or-wrong
+ (begin
+ (display-line "doing first argument")
+ #t)
+ 2)
+
+(define-macro
+ my-or-wrong2
+ (lambda (x y)
+ (list 'let (list (list 'temp x))
+ (list 'if 'temp 'temp y))))
+(my-or-wrong2
+ (begin
+ (display-line "2doing first argument")
+ #t)
+ 2)
+(define temp 3)
+(display-line (my-or-wrong2 #f temp))
+
+(define-macro
+ my-or
+ (lambda (x y)
+ (let ((temp (gensym)))
+ (list 'let (list (list temp x))
+ (list 'if temp temp y)))))
+(display-line (my-or #f temp))
+
View
@@ -160,6 +160,8 @@ int sc_write(FILE *out, object *val) {
fprintf(out, "#<environment-frame@%p>", val);
} else if (is_cont(val)) {
fprintf(out, "#<continuation@%p>", val);
+ } else if (is_macro(val)) {
+ fprintf(out, "#<macro@%p>", val);
} else {
fprintf(stderr,
"unknown type, cannot print\n");

0 comments on commit 84b62fe

Please sign in to comment.