uns_lisp: fix some bugs in first pass of CPS
This commit is contained in:
parent
73a9e320a5
commit
01774a7578
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
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);
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue