add macro

bltin.c

@@ -16,11 +16,14 @@ Object Ne	= (Object){.type=OBLTIN, .beg= "!="};
 Object Eq	= (Object){.type=OBLTIN, .beg= "=="};
 
 Object Lambda= (Object){.type=OBLTIN, .beg="lambda"};
+Object Progn=(Object){.type=OBLTIN, .beg="progn"};
 Object Car	= (Object){.type=OBLTIN, .beg="car"};
 Object Cdr	= (Object){.type=OBLTIN, .beg="cdr"};
 Object Quote= (Object){.type=OBLTIN, .beg="'"};
 Object Cons	= (Object){.type=OBLTIN, .beg="cons"};
 Object Define= (Object){.type=OBLTIN, .beg="define"};
+Object Macro= (Object){.type=OBLTIN, .beg="macro"};
+Object Defn= (Object){.type=OBLTIN, .beg="defn"};
 Object Setq	= (Object){.type=OBLTIN, .beg="setq"};
 Object If	= (Object){.type=OBLTIN, .beg="if"};
 
@@ -29,7 +32,10 @@ extern Object* fnmul(Object *, Object *);
 extern Object* fndiv(Object *, Object *);
 extern Object* fnmod(Object *, Object *);
 extern Object* fnlambda(Object *, Object *);
+extern Object* fnprogn(Object *, Object *);
 extern Object* fndefine(Object *, Object *);
+extern Object* fnmacro(Object *, Object *);
+extern Object* fndefn(Object *, Object *);
 extern Object* fnsetq(Object *, Object *);
 extern Object* fnundef(Object *, Object *);
 extern Object* fnquote(Object *, Object *);
@@ -54,11 +60,14 @@ bltinlookup(Object *obj)
 		Bltinfn fn;
 	}bltins[] = {
 		{&Lambda , fnlambda},
+		{&Progn , fnprogn},
 		{&Plus , fnplus},
 		{&Mul , fnmul},
 		{&Mod , fnmod},
 		{&Div , fndiv},
 		{&Define ,fndefine},
+		{&Macro ,fnmacro},
+		{&Defn ,fndefn},
 		{&Setq ,fnsetq},
 		{&Quote ,fnquote},
 		{&Car ,fncar},

dat.h

@@ -13,6 +13,7 @@ enum OType
 	OINT,
 	OLAMBDA,
 	OFUNC,
+	OMACRO,
 	OENV,
 };
 
@@ -63,6 +64,9 @@ extern Object Cdr;
 extern Object Quote;
 extern Object Cons;
 extern Object Define;
+extern Object Progn;
+extern Object Macro;
+extern Object Defn;
 extern Object Setq;
 extern Object Eq;
 extern Object Ne;

eval.c

@@ -37,22 +37,8 @@ find(Object *env, Object *obj)
 	return 0;
 }
 
-static Object*
-enter(Object *env, Object *vars, Object *args)
-{
-	Object *map = &Nil;
-	for(;vars->type==OCELL; vars=vars->cdr,args=args->cdr){
-		if(args->type!=OCELL)
-			error("Cna't apply function argment dose not match");
-		Object *id  = vars->car;
-		Object *val = args->car;
-		map = newacons(gc, id, val, map);
-	}
-	return newenv(gc, &Nil, map, env);
-}
-
 Object*
-fnlambda(Object *env, Object *l)
+_newfn(Object *env, Object *l, enum OType type)
 {
 	if(l->type!=OCELL || islist(l->car)==0 || l->cdr->type!=OCELL)
 		error("malformed function");
@@ -62,7 +48,46 @@ fnlambda(Object *env, Object *l)
 	}
 	Object *params = l->car;
 	Object *body = l->cdr;
-	return newfn(gc, env, params, body);
+	return newfn(gc, env, params, body, type);
+}
+
+Object*
+fndefn(Object *env, Object *list)
+{
+	Object *fn = _newfn(env, list->cdr, OFUNC);
+	env->vars = newacons(gc, list->car, fn, env->vars);
+	return env->vars;
+}
+
+Object*
+fnlambda(Object *env, Object *l)
+{
+	return _newfn(env, l, OFUNC);
+}
+
+Object*
+fnmacro(Object *env, Object *l)
+{
+	Object *macro = _newfn(env, l->cdr, OMACRO);
+	env->vars = newacons(gc, l->car, macro, env->vars);
+	return env->vars;
+}
+
+static Object*
+progn(Object *env, Object *list)
+{
+	Object *r = 0;
+	for(Object *p=list; p!=&Nil; p=p->cdr){
+		r = p->car;
+		r = eval(env, r);
+	}
+	return r;
+}
+
+Object*
+fnprogn(Object *env, Object *list)
+{
+	return progn(env, list);
 }
 
 Object*
@@ -258,12 +283,11 @@ fnne(Object *env, Object *list)
 Object*
 fnif(Object *env, Object *list)
 {
-    if(list == 0 || list == &Nil)
+	Object *test = list->car;
-		error("Malformed if stmt");
+	test = eval(env, test);
-    Object *t = eval(env, list->car->car);
+	if(istrue(test)) return eval(env, list->cdr->car);
-    if(istrue(t))
+	if(list->cdr->cdr == &Nil) return &Nil;
-        return eval(env, list->car->cdr->car);
+	return eval(env, list->cdr->cdr->car);
-    return fnif(env, list->cdr);
 }
 
 static Object*
@@ -278,16 +302,39 @@ evallist(Object *env, Object *list)
 	return newcons(gc, car, cdr);
 }
 
+static Object*
+enter(Object *env, Object *vars, Object *args)
+{
+	Object *map = &Nil;
+	for(;vars->type==OCELL; vars=vars->cdr,args=args->cdr){
+		if(args->type!=OCELL)
+			error("Cna't apply function argment dose not match");
+		Object *id  = vars->car;
+		Object *val = args->car;
+		map = newacons(gc, id, val, map);
+	}
+	if(vars != &Nil)
+		map = newacons(gc, vars, args, map);
+	return newenv(gc, &Nil, map, env);
+}
+
 static Object*
 applyfn(Object *fn, Object *args)
 {
 	Object *env = enter(fn->env, fn->params, args);
+	return progn(env, fn->body);
+}
+
+static Object*
+applymacro(Object *env, Object* fn, Object *args)
+{
+	Object *nenv = enter(fn->env, fn->params, args);
 	Object *r = 0;
 	for(Object *p=fn->body; p!=&Nil; p=p->cdr){
 		r = p->car;
-		r = eval(env, r);
+		r = eval(nenv, r);
 	}
-	return r;
+	return eval(env, r);
 }
 
 static Object*
@@ -330,6 +377,8 @@ eval(Object *env, Object *obj)
 		}
 	case OCELL:{
 			Object *fn = eval(env, obj->car);
+			if(fn->type == OMACRO)
+				return applymacro(env, fn, obj->cdr);
 			if(fn->type!=OFUNC&&fn->type!=OBLTIN)
 				error("expected function type");
 			Object *res = apply(env, fn, obj->cdr);

fn.h

@@ -13,7 +13,7 @@ Object* newenv(GC *,Object*name, Object *vars, Object *up);
 Object* newacons(GC *,Object*, Object*, Object*);
 Object* newsymbol(GC *,char*, int);
 Object* newstr(GC *,int);
-Object* newfn(GC *,Object *env, Object *params, Object *body);
+Object* newfn(GC *,Object *env, Object *params, Object *body, enum OType type);
 
 /* gc.c */
 GC* newgc(void *top, int cap);

gc.c

@@ -71,8 +71,9 @@ cloneobj(GC *dst, GC *src, Object *obj)
 		p->vars = cloneobj(dst, src, obj->vars);
 		p->up = cloneobj(dst, src, obj->up);
 		break;
+	case OMACRO:
 	case OFUNC:
-		obj->forward = p = newfn(dst, &Nil, &Nil, &Nil);
+		obj->forward = p = newfn(dst, &Nil, &Nil, &Nil, obj->type);
 		p->params = cloneobj(dst, src, obj->params);
 		p->body = cloneobj(dst, src, obj->body);
 		p->env = cloneobj(dst, src, obj->env);
@@ -132,6 +133,7 @@ mark(GC *gc, Object *obj)
 		mark(gc, obj->vars);
 		mark(gc, obj->up);
 		break;
+	case OMACRO:
 	case OFUNC:
 		mark(gc, obj->params);
 		mark(gc, obj->body);

main.c

@@ -38,6 +38,9 @@ SExprint(Object *obj)
 		printf("<env>");
 		SExprint(obj->vars);
 		break;
+	case OMACRO:
+		printf("<macro>");
+		goto func;
 	case OLAMBDA:
 		printf("<lambda>");
 		goto func;
@@ -70,6 +73,7 @@ loop(void)
 	}
 	while(1){
 		Object *res = nextexpr();
+		printexpr(res);
 		res = eval(env, res);
 		printgc("status", gc);
 		printf("=============res===========\n");
@@ -83,6 +87,6 @@ loop(void)
 int
 main(int argc, char *argv[])
 {
-	gc = newgc(&argc, 500);
+	gc = newgc(&argc, 4000);
 	loop();
 }

makefile

@@ -10,7 +10,7 @@ OFILES=\
 	parser.o
 
 AS=$(CC) -c
-CFLAGS=-c  -g -O2 -Wall -std=c99
+CFLAGS=-c  -g -O0 -Wall -std=c99
 
 all: $(NAME)
 

obj.c

@@ -46,9 +46,10 @@ newacons(GC *gc, Object *x, Object *y, Object *z)
 }
 
 Object*
-newfn(GC *gc, Object *env, Object *params, Object *body)
+newfn(GC *gc, Object *env, Object *params, Object *body, enum OType type)
 {
-	Object *fn = newobj(gc, OFUNC, 0);
+	Object *fn = newobj(gc, type, 0);
+	fn->type = type;
 	fn->params = params;
 	fn->body = body;
 	fn->env = env; 
@@ -61,7 +62,7 @@ newsymbol(GC *gc, char *str, int len)
 	static Object *syms[] = {
 		&Nil,  &Minus, &Plus, &Mul, &Mod, &Div, &Ge, &Le,
 		&Lt, &Gt, &Ne, &Lambda, &Car, &Cdr, &Quote, &Cons,
-		&Define, &Setq, &Eq, &If,
+		&Define, &Setq, &Eq, &If, &Defn, &Macro, &Progn,
 	};
 	for(int i = 0; i < sizeof(syms)/sizeof(syms[0]); ++i){
 		Object *c = syms[i];