peter
/
universalservice
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

uns_lisp: fix some bugs in first pass of CPS

This commit is contained in:
Peter McGoron 2024-07-14 09:58:42 -04:00
parent 73a9e320a5
commit 01774a7578
2 changed files with 44 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
examples/lisp/uns_lisp.c
View File

@ -1061,7 +1061,7 @@ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack,
\ tmp.p */ \ tmp.p */
tmp.p = CAR(rest->p); tmp.p = CAR(rest->p);
switch (get_type(tmp.p)) { switch (get_type(tmp.p)) {
case SYMBOL: case LISP_NULL: case SYMBOL: case LISP_NULL: case EMPTY_LIST:
break; break;
default: default:
r = CPS_INVALID_LAMBDA_FORMAL; r = CPS_INVALID_LAMBDA_FORMAL;
@ -1070,13 +1070,13 @@ static enum cps_return cps_exec_lambda(struct uns_ctr *prevstack,
stack_push(prevstack, &tmp); stack_push(prevstack, &tmp);
tmp.p = CDR(rest->p); rest->p = CDR(rest->p);
if (get_type(tmp.p) != CELL) { if (get_type(rest->p) != CELL) {
r = CPS_LAMBDA_UNDERFLOW; r = CPS_LAMBDA_UNDERFLOW;
goto cleanup; goto cleanup;
} }
if (get_type(CDR(tmp.p)) != EMPTY_LIST) { if (get_type(CDR(rest->p)) != EMPTY_LIST) {
r = CPS_LAMBDA_OVERFLOW; r = CPS_LAMBDA_OVERFLOW;
goto cleanup; goto cleanup;
} }
@ -1180,6 +1180,8 @@ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack,
stack_push(&expr, &before); stack_push(&expr, &before);
stack_push_const(&expr, "__K/H"); /* (__K/H before after (...) K) */ stack_push_const(&expr, "__K/H"); /* (__K/H before after (...) K) */
stack_push(prevstack, &expr);
uns_root_remove(gc, &expr); uns_root_remove(gc, &expr);
uns_root_remove(gc, &tmp1); uns_root_remove(gc, &tmp1);
uns_root_remove(gc, &bound_k); 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; 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, static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
struct uns_ctr *K, 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 newk = {0};
struct uns_ctr b1 = {0}; struct uns_ctr b1 = {0};
struct uns_ctr b2 = {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) if (get_type(lst->p) != CELL)
return CPS_IF_UNDERFLOW; 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) if (get_type(CDR(lst->p)) != EMPTY_LIST)
return CPS_IF_OVERFLOW; return CPS_IF_OVERFLOW;
uns_root_add(gc, &newk); stack_push(prevstack, &e);
uns_root_add(gc, &b1);
uns_root_add(gc, &b2);
stack_push(prevstack, K); stack_push(prevstack, K);
stack_push(prevstack, &newk); stack_push(prevstack, &newk);
stack_push(prevstack, &b2); stack_push(prevstack, &b2);
@ -1286,6 +1298,7 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
stack_push_const(readstack, "cps"); stack_push_const(readstack, "cps");
uns_root_remove(gc, &newk); uns_root_remove(gc, &newk);
uns_root_remove(gc, &e);
uns_root_remove(gc, &b1); uns_root_remove(gc, &b1);
uns_root_remove(gc, &b2); 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; tmp.p = expr.p;
expr.p = empty_list.p; expr.p = empty_list.p;
stack_push(&expr, &tmp);
stack_push(&expr, &l); stack_push(&expr, &l);
stack_push_const(&expr, "__K"); /* (__K l (f l K)) */ stack_push_const(&expr, "__K"); /* (__K l (f l K)) */
stack_push(prevstack, &expr); stack_push(prevstack, &expr);
@ -1523,7 +1537,6 @@ static void display(struct uns_ctr *ctr)
long indent = 0; long indent = 0;
long list_part = 0; long list_part = 0;
int add_space = 0; int add_space = 0;
int end_list_seq = 0;
struct uns_ctr stack = {0}; struct uns_ctr stack = {0};
struct uns_ctr top = {0}; struct uns_ctr top = {0};
struct uns_ctr ival = {0}; struct uns_ctr ival = {0};
@ -1550,18 +1563,6 @@ static void display(struct uns_ctr *ctr)
list_part = get_int(&ival); list_part = get_int(&ival);
top.p = CDR(top.p); 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)) { switch(get_type(top.p)) {
case INTEGER: case INTEGER:
memcpy(&l, uns_get(gc, top.p, 1, NULL), sizeof(long)); 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) { if (list_part) {
printf(")"); printf(")");
indent--; indent--;
end_list_seq = 1;
} else { } else {
printf("%s'()", SPC); printf("%s'()", SPC);
end_list_seq = 0;
} }
break; break;
case LISP_NULL: case LISP_NULL:
printf("<undefined>\n"); printf("<undefined>");
break; break;
case CELL: case CELL:
alloc_int(&ival, 1); alloc_int(&ival, 1);
@ -1606,15 +1605,17 @@ static void display(struct uns_ctr *ctr)
stack_push(&stack, &tmp); stack_push(&stack, &tmp);
if (!list_part) { if (!list_part) {
indent++;
if (add_space) { if (add_space) {
printf("\n"); printf("\n");
for (l = 0; l < indent; l++) { for (l = 0; l < indent; l++) {
printf(" "); printf(" ");
} }
add_space = 0; } else {
printf("%s", SPC);
} }
indent++;
printf("("); printf("(");
add_space = 0;
} }
break; break;
} }

22
examples/lisp/uns_lisp_cheney_c89.c
View File

@ -28,14 +28,18 @@
#include "uns.h" #include "uns.h"
#include "cheney_c89.h" #include "cheney_c89.h"
static int silent = 0;
static void after_gc(Uns_GC gc, struct uns_cheney_c89_statistics *stats) static void after_gc(Uns_GC gc, struct uns_cheney_c89_statistics *stats)
{ {
fprintf(stderr, if (!silent) {
"cheney_c89 %ld: %lu -> %lu\n", fprintf(stderr,
stats->collection_number, "cheney_c89 %ld: %lu -> %lu\n",
stats->usage_before, stats->collection_number,
stats->usage_after stats->usage_before,
); stats->usage_after
);
}
if (stats->usage_after >= stats->usage_before * 7/10) { 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 uns_lisp_gc_init(void)
{ {
Uns_GC gc = malloc(uns_gc_size); Uns_GC gc = malloc(uns_gc_size);
const char *env;
uns_gc_zero(gc); uns_gc_zero(gc);
if (!uns_cheney_c89_init(gc, 512)) { if (!uns_cheney_c89_init(gc, 512)) {
fprintf(stderr, "Error initializing GC\n"); fprintf(stderr, "Error initializing GC\n");
exit(1); 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_collect_callback(gc, after_gc);
uns_cheney_c89_set_new_heap_size(gc, 1024); uns_cheney_c89_set_new_heap_size(gc, 1024);