From e781174511525757e7ec0964d7ff81e98ee6de75 Mon Sep 17 00:00:00 2001
From: Jeremiah Orians <jeremiah@pdp10.guru>
Date: Sat, 4 Feb 2017 14:27:24 -0500
Subject: [PATCH] Added garbage collection and multiple additions to the lisp

---
 stage2/High_level_prototypes/lisp.c       |   4 +
 stage2/High_level_prototypes/lisp.h       |  15 +-
 stage2/High_level_prototypes/lisp_cell.c  | 114 ++++++++-
 stage2/High_level_prototypes/lisp_eval.c  | 288 ++++++++++++++++++----
 stage2/High_level_prototypes/lisp_print.c |   1 +
 stage2/High_level_prototypes/lisp_read.c  |   8 +-
 stage2/High_level_prototypes/makefile     |   2 +-
 7 files changed, 374 insertions(+), 58 deletions(-)

diff --git a/stage2/High_level_prototypes/lisp.c b/stage2/High_level_prototypes/lisp.c
index d9a66cf..154489c 100644
--- a/stage2/High_level_prototypes/lisp.c
+++ b/stage2/High_level_prototypes/lisp.c
@@ -7,13 +7,17 @@ void init_sl3();
 uint32_t Readline(FILE* source_file, char* temp);
 struct cell* parse(char* program, int32_t size);
 void writeobj(FILE *ofp, struct cell* op);
+void garbage_init();
+void garbage_collect();
 
 /*** Main Driver ***/
 int main()
 {
+	garbage_init();
 	init_sl3();
 	for(;;)
 	{
+		garbage_collect();
 		int read;
 		char* message = calloc(1024, sizeof(char));
 		read = Readline(stdin, message);
diff --git a/stage2/High_level_prototypes/lisp.h b/stage2/High_level_prototypes/lisp.h
index 1c719b7..21b956d 100644
--- a/stage2/High_level_prototypes/lisp.h
+++ b/stage2/High_level_prototypes/lisp.h
@@ -6,11 +6,14 @@
 
 enum otype
 {
-	INT = 1,
-	SYM = (1 << 1),
-	CONS = (1 << 2),
-	PROC = (1 << 3),
-	PRIMOP = (1 << 4),
+	FREE = 1,
+	MARKED = (1 << 1),
+	INT = (1 << 2),
+	SYM = (1 << 3),
+	CONS = (1 << 4),
+	PROC = (1 << 5),
+	PRIMOP = (1 << 6),
+	ASCII = (1 << 7)
 };
 
 typedef struct cell* (*Operation)(struct cell *);
@@ -35,4 +38,4 @@ typedef struct cell
 struct cell* make_cons(struct cell* a, struct cell* b);
 
 /* Global objects */
-struct cell *all_symbols, *top_env, *nil, *tee, *quote, *s_if, *s_lambda, *s_define, *s_setb;
+struct cell *all_symbols, *top_env, *nil, *tee, *quote, *s_if, *s_lambda, *s_define, *s_setb, *s_cond, *s_begin;
diff --git a/stage2/High_level_prototypes/lisp_cell.c b/stage2/High_level_prototypes/lisp_cell.c
index a9a31bf..65152e1 100644
--- a/stage2/High_level_prototypes/lisp_cell.c
+++ b/stage2/High_level_prototypes/lisp_cell.c
@@ -1,8 +1,112 @@
 #include "lisp.h"
 
+struct cell *free_cells, *gc_block_start, *gc_block_end;
+int64_t left_to_take;
+
+int64_t cells_remaining()
+{
+	return left_to_take;
+}
+
+void update_remaining()
+{
+	int64_t count = 0;
+	struct cell* i = free_cells;
+	while(NULL != i)
+	{
+		count = count + 1;
+		i = i->cdr;
+	}
+	left_to_take = count;
+}
+
+void reclaim_marked()
+{
+	struct cell* i;
+	for(i= gc_block_start; i < gc_block_end; i = i + 1)
+	{
+		if(i->type & MARKED)
+		{
+			i->type = FREE;
+			i->car = NULL;
+			i->cdr = free_cells;
+			i->env = NULL;
+			free_cells = i;
+		}
+	}
+}
+
+void mark_all_cells()
+{
+	struct cell* i;
+	for(i= gc_block_start; i < gc_block_end; i = i + 1)
+	{
+		/* if not in the free list */
+		if(!(i->type & FREE))
+		{
+			/* Mark it */
+			i->type = i->type | MARKED;
+		}
+	}
+}
+
+void unmark_cells(struct cell* list)
+{
+	for(; NULL != list; list = list->cdr)
+	{
+		list->type = list->type & ~MARKED;
+		if((list->type & CONS)|| list->type & PROC )
+		{
+			unmark_cells(list->car);
+		}
+	}
+}
+
+void garbage_collect()
+{
+	mark_all_cells();
+	unmark_cells(all_symbols);
+	unmark_cells(top_env);
+	unmark_cells(nil);
+	unmark_cells(tee);
+	unmark_cells(quote);
+	unmark_cells(s_if);
+	unmark_cells(s_lambda);
+	unmark_cells(s_define);
+	unmark_cells(s_setb);
+	unmark_cells(s_cond);
+	unmark_cells(s_begin);
+	reclaim_marked();
+	update_remaining();
+}
+
+void garbage_init()
+{
+	int number_of_Cells = 1000000;
+	gc_block_start = calloc(number_of_Cells + 1, sizeof(cell));
+	gc_block_end = gc_block_start + number_of_Cells;
+	free_cells = NULL;
+	garbage_collect();
+}
+
+struct cell* pop_cons()
+{
+	if(NULL == free_cells)
+	{
+		printf("OOOPS we ran out of cells");
+		exit(EXIT_FAILURE);
+	}
+	struct cell* i;
+	i = free_cells;
+	free_cells = i->cdr;
+	i->cdr = NULL;
+	left_to_take = left_to_take - 1;
+	return i;
+}
+
 struct cell* make_int(int a)
 {
-	struct cell* c = calloc(1, sizeof(cell));
+	struct cell* c = pop_cons();
 	c->type = INT;
 	c->value = a;
 	return c;
@@ -10,7 +114,7 @@ struct cell* make_int(int a)
 
 struct cell* make_sym(char* name)
 {
-	struct cell* c = calloc(1, sizeof(cell));
+	struct cell* c = pop_cons();
 	c->type = SYM;
 	c->string = name;
 	return c;
@@ -18,7 +122,7 @@ struct cell* make_sym(char* name)
 
 struct cell* make_cons(struct cell* a, struct cell* b)
 {
-	struct cell* c = calloc(1, sizeof(cell));
+	struct cell* c = pop_cons();
 	c->type = CONS;
 	c->car = a;
 	c->cdr = b;
@@ -27,7 +131,7 @@ struct cell* make_cons(struct cell* a, struct cell* b)
 
 struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env)
 {
-	struct cell* c = calloc(1, sizeof(cell));
+	struct cell* c = pop_cons();
 	c->type = PROC;
 	c->car = a;
 	c->cdr = b;
@@ -37,7 +141,7 @@ struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env)
 
 struct cell* make_prim(void* fun)
 {
-	struct cell* c = calloc(1, sizeof(cell));
+	struct cell* c = pop_cons();
 	c->type = PRIMOP;
 	c->function = fun;
 	return c;
diff --git a/stage2/High_level_prototypes/lisp_eval.c b/stage2/High_level_prototypes/lisp_eval.c
index 927b5a0..33aa3ef 100644
--- a/stage2/High_level_prototypes/lisp_eval.c
+++ b/stage2/High_level_prototypes/lisp_eval.c
@@ -1,17 +1,6 @@
 #include "lisp.h"
 
 /* Support functions */
-struct cell* car(struct cell* a)
-{
-	return a->car;
-}
-
-struct cell* cdr(struct cell* a)
-{
-	return a->cdr;
-}
-
-
 struct cell* findsym(char *name)
 {
 	struct cell* symlist;
@@ -44,24 +33,27 @@ struct cell* extend(struct cell* env, struct cell* symbol, struct cell* value)
 
 struct cell* multiple_extend(struct cell* env, struct cell* syms, struct cell* vals)
 {
-if(nil == syms)
+	if(nil == syms)
 	{
 		return env;
 	}
-	return multiple_extend(extend(env, car(syms), car(vals)), cdr(syms), cdr(vals));
+	return multiple_extend(extend(env, syms->car, vals->car), syms->cdr, vals->cdr);
 }
 
 struct cell* extend_top(struct cell* sym, struct cell* val)
 {
-	top_env->cdr = make_cons(make_cons(sym, val), cdr(top_env));
+	top_env->cdr = make_cons(make_cons(sym, val), top_env->cdr);
 	return val;
 }
 
 struct cell* assoc(struct cell* key, struct cell* alist)
 {
 	if(nil == alist) return nil;
-	if(car(car(alist)) == key) return car(alist);
-	return assoc(key, cdr(alist));
+	for(; nil != alist; alist = alist->cdr)
+	{
+		if(alist->car->car == key) return alist->car;
+	}
+	return nil;
 }
 
 /*** Evaluator (Eval/Apply) ***/
@@ -70,7 +62,7 @@ struct cell* make_proc(struct cell* a, struct cell* b, struct cell* env);
 struct cell* evlis(struct cell* exps, struct cell* env)
 {
 	if(exps == nil) return nil;
-	return make_cons(eval(car(exps), env), evlis(cdr(exps), env));
+	return make_cons(eval(exps->car, env), evlis(exps->cdr, env));
 }
 
 struct cell* progn(struct cell* exps, struct cell* env)
@@ -78,9 +70,9 @@ struct cell* progn(struct cell* exps, struct cell* env)
 	if(exps == nil) return nil;
 	for(;;)
 	{
-		if(cdr(exps) == nil) return eval(car(exps), env);
-		eval(car(exps), env);
-		exps = cdr(exps);
+		if(exps->cdr == nil) return eval(exps->car, env);
+		eval(exps->car, env);
+		exps = exps->cdr;
 	}
 }
 
@@ -103,6 +95,27 @@ struct cell* apply(struct cell* proc, struct cell* vals)
 	return temp;
 }
 
+struct cell* evcond(struct cell* exp, struct cell* env)
+{
+	if(tee == eval(exp->car->car, env))
+	{
+		return eval(exp->car->cdr->car, env);
+	}
+
+	return evcond(exp->cdr, env);
+}
+
+struct cell* prim_begin(struct cell* exp, struct cell* env)
+{
+	struct cell* ret;
+	ret = eval(exp->car, env);
+	if(nil != exp->cdr)
+	{
+		ret = prim_begin(exp->cdr, env);
+	}
+	return ret;
+}
+
 struct cell* eval(struct cell* exp, struct cell* env)
 {
 	if(exp == nil) return nil;
@@ -118,32 +131,35 @@ struct cell* eval(struct cell* exp, struct cell* env)
 				fprintf(stderr,"Unbound symbol\n");
 				exit(EXIT_FAILURE);
 			}
-			return cdr(tmp);
+			return tmp->cdr;
 		}
 		case CONS:
 		{
-			if(car(exp) == s_if)
+			if(exp->car == s_if)
 			{
-				if(eval(car(cdr(exp)), env) != nil)
+				if(eval(exp->cdr->car, env) != nil)
 				{
-					return eval(car(cdr(cdr(exp))), env);
+					return eval(exp->cdr->cdr->car, env);
 				}
-				return eval(car(cdr(cdr(cdr(exp)))), env);
+				return eval(exp->cdr->cdr->cdr->car, env);
 			}
-			if(car(exp) == s_lambda) return make_proc(car(cdr(exp)), cdr(cdr(exp)), env);
-			if(car(exp) == quote) return car(cdr(exp));
-			if(car(exp) == s_define) return(extend_top(car(cdr(exp)), eval(car(cdr(cdr(exp))), env)));
-			if(car(exp) == s_setb)
+			if(exp->car == s_cond) return evcond(exp->cdr, env);
+			if(exp->car == s_begin) return prim_begin(exp->cdr, env);
+			if(exp->car == s_lambda) return make_proc(exp->cdr->car, exp->cdr->cdr, env);
+			if(exp->car == quote) return exp->cdr->car;
+			if(exp->car == s_define) return(extend_top(exp->cdr->car, eval(exp->cdr->cdr->car, env)));
+			if(exp->car == s_setb)
 			{
-				struct cell* pair = assoc(car(cdr(exp)), env);
-				struct cell* newval = eval(car(cdr(cdr(exp))), env);
+				struct cell* pair = assoc(exp->cdr->car, env);
+				struct cell* newval = eval(exp->cdr->cdr->car, env);
 				pair->cdr = newval;
 				return newval;
 			}
-			return apply(eval(car(exp), env), evlis(cdr(exp), env));
+			return apply(eval(exp->car, env), evlis(exp->cdr, env));
 		}
 		case PRIMOP: return exp;
 		case PROC: return exp;
+		default: return exp;
 	}
 	/* Not reached */
 	return exp;
@@ -154,19 +170,19 @@ struct cell* make_int(int a);
 struct cell* prim_sum(struct cell* args)
 {
 	int sum;
-	for(sum = 0; nil != args; args = cdr(args))
+	for(sum = 0; nil != args; args = args->cdr)
 	{
-		sum = sum + car(args)->value;
+		sum = sum + args->car->value;
 	}
 	return make_int(sum);
 }
 
 struct cell* prim_sub(struct cell* args)
 {
-	int sum = car(args)->value;
-	for(args = cdr(args); nil != args; args = cdr(args))
+	int sum = args->car->value;
+	for(args = args->cdr; nil != args; args = args->cdr)
 	{
-		 sum = sum - car(args)->value;
+		 sum = sum - args->car->value;
 	}
 	return make_int(sum);
 }
@@ -174,21 +190,187 @@ struct cell* prim_sub(struct cell* args)
 struct cell* prim_prod(struct cell* args)
 {
 	int prod;
-	for(prod = 1; nil != args; args = cdr(args))
+	for(prod = 1; nil != args; args = args->cdr)
 	{
-		prod = prod * car(args)->value;
+		prod = prod * args->car->value;
 	}
 	return make_int(prod);
 }
 
-struct cell* prim_numeq(struct cell* args)
+struct cell* prim_div(struct cell* args)
 {
-	return car(args)->value == car(cdr(args))->value ? tee : nil;
+	int div = args->car->value;
+	for(args = args->cdr; nil != args; args = args->cdr)
+	{
+		div = div / args->car->value;
+	}
+	return make_int(div);
 }
 
-struct cell* prim_cons(struct cell* args) { return make_cons(car(args), car(cdr(args))); }
-struct cell* prim_car(struct cell* args) { return car(car(args)); }
-struct cell* prim_cdr(struct cell* args) { return cdr(car(args)); }
+struct cell* prim_mod(struct cell* args)
+{
+	int mod = args->car->value % args->cdr->car->value;
+	if(nil != args->cdr->cdr)
+	{
+		printf("wrong number of arguments to mod\n");
+		exit(EXIT_FAILURE);
+	}
+	return make_int(mod);
+}
+
+struct cell* prim_and(struct cell* args)
+{
+	for(; nil != args; args = args->cdr)
+	{
+		if(tee != args->car) return nil;
+	}
+	return tee;
+}
+
+struct cell* prim_or(struct cell* args)
+{
+	for(; nil != args; args = args->cdr)
+	{
+		if(tee == args->car) return tee;
+	}
+	return nil;
+}
+
+struct cell* prim_not(struct cell* args)
+{
+	if(tee != args->car) return tee;
+	return nil;
+}
+
+struct cell* prim_numgt(struct cell* args)
+{
+	int temp = args->car->value;
+	for(args = args->cdr; nil != args; args = args->cdr)
+	{
+		if(temp <= args->car->value)
+		{
+			return nil;
+		}
+		temp = args->car->value;
+	}
+	return tee;
+}
+
+struct cell* prim_numge(struct cell* args)
+{
+	int temp = args->car->value;
+	for(args = args->cdr; nil != args; args = args->cdr)
+	{
+		if(temp < args->car->value)
+		{
+			return nil;
+		}
+		temp = args->car->value;
+	}
+	return tee;
+}
+
+struct cell* prim_numeq(struct cell* args)
+{
+	int temp = args->car->value;
+	for(args = args->cdr; nil != args; args = args->cdr)
+	{
+		if(temp != args->car->value)
+		{
+			return nil;
+		}
+	}
+	return tee;
+}
+
+struct cell* prim_numle(struct cell* args)
+{
+	int temp = args->car->value;
+	for(args = args->cdr; nil != args; args = args->cdr)
+	{
+		if(temp > args->car->value)
+		{
+			return nil;
+		}
+		temp = args->car->value;
+	}
+	return tee;
+}
+
+struct cell* prim_numlt(struct cell* args)
+{
+	int temp = args->car->value;
+	for(args = args->cdr; nil != args; args = args->cdr)
+	{
+		if(temp >= args->car->value)
+		{
+			return nil;
+		}
+		temp = args->car->value;
+	}
+	return tee;
+}
+
+struct cell* prim_listp(struct cell* args)
+{
+	if(CONS == args->car->type)
+	{
+		return tee;
+	}
+	return nil;
+}
+
+struct cell* prim_display(struct cell* args)
+{
+	for(; nil != args; args = args->cdr)
+	{
+		if(INT == args->car->type)
+		{
+			printf("%d", args->car->value);
+		}
+		else if(ASCII == args->car->type)
+		{
+			printf("%c", args->car->value);
+		}
+		else if(CONS == args->car->type)
+		{
+			prim_display(args->car);
+		}
+		else
+		{
+			printf("%s", args->car->string);
+		}
+	}
+	return tee;
+}
+
+int64_t cells_remaining();
+struct cell* prim_freecell(struct cell* args)
+{
+	if(nil == args)
+	{
+		printf("Remaining Cells: ");
+	}
+	return make_int(cells_remaining());
+}
+
+struct cell* prim_ascii(struct cell* args)
+{
+	struct cell* temp;
+	for(temp = args; nil != temp; temp = temp->cdr)
+	{
+		if(INT == temp->car->type)
+		{
+			temp->car->type = ASCII;
+		}
+	}
+	return args;
+}
+
+struct cell* prim_list(struct cell* args) {return args;}
+struct cell* prim_cons(struct cell* args) { return make_cons(args->car, args->cdr->car); }
+struct cell* prim_car(struct cell* args) { return args->car->car; }
+struct cell* prim_cdr(struct cell* args) { return args->car->cdr; }
 
 /*** Initialization ***/
 struct cell* intern(char *name);
@@ -199,17 +381,33 @@ void init_sl3()
 	nil = make_sym("nil");
 	all_symbols = make_cons(nil, nil);
 	top_env = make_cons(make_cons(nil, nil), nil);
-	tee = intern("t");
+	tee = intern("#t");
 	extend_top(tee, tee);
 	quote = intern("quote");
 	s_if = intern("if");
+	s_cond = intern("cond");
 	s_lambda = intern("lambda");
 	s_define = intern("define");
 	s_setb = intern("set!");
+	s_begin = intern("begin");
 	extend_top(intern("+"), make_prim(prim_sum));
 	extend_top(intern("-"), make_prim(prim_sub));
 	extend_top(intern("*"), make_prim(prim_prod));
+	extend_top(intern("/"), make_prim(prim_div));
+	extend_top(intern("mod"), make_prim(prim_mod));
+	extend_top(intern("and"), make_prim(prim_and));
+	extend_top(intern("or"), make_prim(prim_or));
+	extend_top(intern("not"), make_prim(prim_not));
+	extend_top(intern(">"), make_prim(prim_numgt));
+	extend_top(intern(">="), make_prim(prim_numge));
 	extend_top(intern("="), make_prim(prim_numeq));
+	extend_top(intern("<="), make_prim(prim_numle));
+	extend_top(intern("<"), make_prim(prim_numlt));
+	extend_top(intern("display"), make_prim(prim_display));
+	extend_top(intern("free_mem"), make_prim(prim_freecell));
+	extend_top(intern("ascii!"), make_prim(prim_ascii));
+	extend_top(intern("list?"), make_prim(prim_listp));
+	extend_top(intern("list"), make_prim(prim_list));
 	extend_top(intern("cons"), make_prim(prim_cons));
 	extend_top(intern("car"), make_prim(prim_car));
 	extend_top(intern("cdr"), make_prim(prim_cdr));
diff --git a/stage2/High_level_prototypes/lisp_print.c b/stage2/High_level_prototypes/lisp_print.c
index 16cade9..f798d0c 100644
--- a/stage2/High_level_prototypes/lisp_print.c
+++ b/stage2/High_level_prototypes/lisp_print.c
@@ -36,6 +36,7 @@ void writeobj(FILE *ofp, struct cell* op)
 		}
 		case PRIMOP: fprintf(ofp, "#<PRIMOP>"); break;
 		case PROC: fprintf(ofp, "#<PROC>"); break;
+		case ASCII: fprintf(ofp, "%c", op->value); break;
 		default: exit(1);
 	}
 }
diff --git a/stage2/High_level_prototypes/lisp_read.c b/stage2/High_level_prototypes/lisp_read.c
index f5f4177..0242440 100644
--- a/stage2/High_level_prototypes/lisp_read.c
+++ b/stage2/High_level_prototypes/lisp_read.c
@@ -104,6 +104,12 @@ bool is_integer(char* a)
 
 struct cell* atom(struct cell* a)
 {
+	/* Check for quotes */
+	if('\'' == a->string[0])
+	{
+		a->string = a->string + 1;
+		return make_cons(quote, make_cons(a, nil));
+	}
 	/* Check for integer */
 	if(is_integer(a->string))
 	{
@@ -228,7 +234,7 @@ uint32_t Readline(FILE* source_file, char* temp)
 	}
 
 Line_complete:
-	if(1 >= i)
+	if(1 > i)
 	{
 		return Readline(source_file, temp);
 	}
diff --git a/stage2/High_level_prototypes/makefile b/stage2/High_level_prototypes/makefile
index d7324b9..e9f7b56 100644
--- a/stage2/High_level_prototypes/makefile
+++ b/stage2/High_level_prototypes/makefile
@@ -2,7 +2,7 @@ all: lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c
 	gcc -ggdb lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c -o lisp
 
 lisp: lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c
-	gcc lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c -o lisp
+	gcc -O2 lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c -o lisp
 
 coverage-test: lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c
 	gcc -fprofile-arcs -ftest-coverage lisp.h lisp.c lisp_cell.c lisp_eval.c lisp_print.c lisp_read.c -o lisp