From 01774a757841ec73182b770a43af347c46a55368 Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Sun, 14 Jul 2024 09:58:42 -0400 Subject: [PATCH] uns_lisp: fix some bugs in first pass of CPS --- examples/lisp/uns_lisp.c | 55 +++++++++++++++-------------- examples/lisp/uns_lisp_cheney_c89.c | 22 ++++++++---- 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("\n"); + printf(""); 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);