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 = 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;
}

22
examples/lisp/uns_lisp_cheney_c89.c
View File

@ -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);