uns_lisp: fix some bugs in first pass of CPS

2 files changed, 44 insertions, 33 deletions

diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c
index a42f7ad..d90f8c5 100644
--- a/examples/lisp/uns_lisp.c
+++ b/examples/lisp/uns_lisp.c
@@ -1061,7 +1061,7 @@ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack,
 	            \ tmp.p */
 	tmp.p = CAR(rest->p);
 	switch (get_type(tmp.p)) {
-	case SYMBOL: case LISP_NULL:
+	case SYMBOL: case LISP_NULL: case EMPTY_LIST:
 		break;
 	default:
 		r = CPS_INVALID_LAMBDA_FORMAL;
@@ -1070,13 +1070,13 @@ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack,
 
 	stack_push(prevstack, &tmp);
 
-	tmp.p = CDR(rest->p);
-	if (get_type(tmp.p) != CELL) {
+	rest->p = CDR(rest->p);
+	if (get_type(rest->p) != CELL) {
 		r = CPS_LAMBDA_UNDERFLOW;
 		goto cleanup;
 	}
 
-	if (get_type(CDR(tmp.p)) != EMPTY_LIST) {
+	if (get_type(CDR(rest->p)) != EMPTY_LIST) {
 		r = CPS_LAMBDA_OVERFLOW;
 		goto cleanup;
 	}
@@ -1180,6 +1180,8 @@ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack,
 	stack_push(&expr, &before);
 	stack_push_const(&expr, "__K/H"); /* (__K/H before after (...) K) */
 
+	stack_push(prevstack, &expr);
+
 	uns_root_remove(gc, &expr);
 	uns_root_remove(gc, &tmp1);
 	uns_root_remove(gc, &bound_k);
@@ -1246,7 +1248,7 @@ static enum cps_return cps_exec_call_cc(struct uns_ctr *prevstack,
 	return CPS_CONTINUE;
 }
 
-/* {K (if E B1 B2} {cps} = {k B1 k B2 k K} {cps swap2 cps cps-if}
+/* {K (if E B1 B2} {cps} = {k B1 k B2 k K E} {cps swap2 cps cps-if}
  */
 static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
                                    struct uns_ctr *K,
@@ -1257,6 +1259,19 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
 	struct uns_ctr newk = {0};
 	struct uns_ctr b1 = {0};
 	struct uns_ctr b2 = {0};
+	struct uns_ctr e = {0};
+
+	uns_root_add(gc, &newk);
+	uns_root_add(gc, &e);
+	uns_root_add(gc, &b1);
+	uns_root_add(gc, &b2);
+
+	gensym(&newk);
+
+	if (get_type(lst->p) != CELL)
+		return CPS_IF_UNDERFLOW;
+	e.p = CAR(lst->p);
+	lst->p = CDR(lst->p);
 
 	if (get_type(lst->p) != CELL)
 		return CPS_IF_UNDERFLOW;
@@ -1269,10 +1284,7 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
 	if (get_type(CDR(lst->p)) != EMPTY_LIST)
 		return CPS_IF_OVERFLOW;
 
-	uns_root_add(gc, &newk);
-	uns_root_add(gc, &b1);
-	uns_root_add(gc, &b2);
-
+	stack_push(prevstack, &e);
 	stack_push(prevstack, K);
 	stack_push(prevstack, &newk);
 	stack_push(prevstack, &b2);
@@ -1286,6 +1298,7 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
 	stack_push_const(readstack, "cps");
 
 	uns_root_remove(gc, &newk);
+	uns_root_remove(gc, &e);
 	uns_root_remove(gc, &b1);
 	uns_root_remove(gc, &b2);
 
@@ -1370,6 +1383,7 @@ static enum cps_return cps_exec_compound_fcall(struct uns_ctr *prevstack,
 
 	tmp.p = expr.p;
 	expr.p = empty_list.p;
+	stack_push(&expr, &tmp);
 	stack_push(&expr, &l);
 	stack_push_const(&expr, "__K"); /* (__K l (f l K)) */
 	stack_push(prevstack, &expr);
@@ -1523,7 +1537,6 @@ static void display(struct uns_ctr *ctr)
 	long indent = 0;
 	long list_part = 0;
 	int add_space = 0;
-	int end_list_seq = 0;
 	struct uns_ctr stack = {0};
 	struct uns_ctr top = {0};
 	struct uns_ctr ival = {0};
@@ -1550,18 +1563,6 @@ static void display(struct uns_ctr *ctr)
 		list_part = get_int(&ival);
 		top.p = CDR(top.p);
 
-		if (get_type(top.p) != EMPTY_LIST)
-			end_list_seq = 0;
-
-		if (!list_part && end_list_seq) {
-			printf("\n");
-			for (l = 0; l < indent; l++) {
-				printf(" ");
-			}
-			end_list_seq = 0;
-			add_space = 1;
-		}
-
 		switch(get_type(top.p)) {
 		case INTEGER:
 			memcpy(&l, uns_get(gc, top.p, 1, NULL), sizeof(long));
@@ -1585,14 +1586,12 @@ static void display(struct uns_ctr *ctr)
 			if (list_part) {
 				printf(")");
 				indent--;
-				end_list_seq = 1;
 			} else {
 				printf("%s'()", SPC);
-				end_list_seq = 0;
 			}
 			break;
 		case LISP_NULL:
-			printf("<undefined>\n");
+			printf("<undefined>");
 			break;
 		case CELL:
 			alloc_int(&ival, 1);
@@ -1606,15 +1605,17 @@ static void display(struct uns_ctr *ctr)
 			stack_push(&stack, &tmp);
 
 			if (!list_part) {
-				indent++;
 				if (add_space) {
 					printf("\n");
 					for (l = 0; l < indent; l++) {
 						printf(" ");
 					}
-					add_space = 0;
+				} else {
+					printf("%s", SPC);
 				}
+				indent++;
 				printf("(");
+				add_space = 0;
 			}
 			break;
 		}
diff --git a/examples/lisp/uns_lisp_cheney_c89.c b/examples/lisp/uns_lisp_cheney_c89.c
index a1f770c..04febb7 100644
--- a/examples/lisp/uns_lisp_cheney_c89.c
+++ b/examples/lisp/uns_lisp_cheney_c89.c
@@ -28,14 +28,18 @@
 #include "uns.h"
 #include "cheney_c89.h"
 
+static int silent = 0;
+
 static void after_gc(Uns_GC gc, struct uns_cheney_c89_statistics *stats)
 {
-	fprintf(stderr,
-		"cheney_c89 %ld: %lu -> %lu\n",
-	        stats->collection_number,
-	        stats->usage_before,
-	        stats->usage_after
-	);
+	if (!silent) {
+		fprintf(stderr,
+			"cheney_c89 %ld: %lu -> %lu\n",
+		        stats->collection_number,
+		        stats->usage_before,
+		        stats->usage_after
+		);
+	}
 
 
 	if (stats->usage_after >= stats->usage_before * 7/10) {
@@ -48,12 +52,18 @@ static void after_gc(Uns_GC gc, struct uns_cheney_c89_statistics *stats)
 Uns_GC uns_lisp_gc_init(void)
 {
 	Uns_GC gc = malloc(uns_gc_size);
+	const char *env;
 	uns_gc_zero(gc);
 	if (!uns_cheney_c89_init(gc, 512)) {
 		fprintf(stderr, "Error initializing GC\n");
 		exit(1);
 	}
 
+	env = getenv("UNS_LISP_SILENT");
+	if (env && env[0] == 'y') {
+		silent = 1;
+	}
+
 	uns_cheney_c89_set_collect_callback(gc, after_gc);
 	uns_cheney_c89_set_new_heap_size(gc, 1024);