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

uns_lisp: cps transformation of function arguments

This commit is contained in:
Peter McGoron 2024-07-14 18:33:02 -04:00
parent 01774a7578
commit 63ba63c776
1 changed files with 195 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

233
examples/lisp/uns_lisp.c
View File

@ -928,6 +928,10 @@ enum cps_return {
CPS_UNQUOTE_LIST_INVALID,
CPS_NULL_EXPR,
CPS_INVALID_CMD,
CPS_LIST_INCONSISTENT_LIST,
CPS_LIST_UNDERFLOW,
CPS_LIST_IMPROPER_LIST,
CPS_EXEC_INVALID_APPL_LIST,
CPS_RETURN_LEN
};
@ -956,7 +960,11 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
"CPS_UNQUOTE_INVALID",
"CPS_UNQUOTE_LIST_INVALID",
"CPS_INVALID_CMD",
"CPS_NULL_EXPR"
"CPS_NULL_EXPR",
"CPS_LIST_INCONSISTENT_LIST",
"CPS_LIST_IMPROPER_LIST",
"CPS_EXEC_INVALID_APPL_LIST",
"CPS_LIST_UNDERFLOW"
};
/* {K (quote QUOTED)} {cps} = {(-> QUOTED K)} */
@ -979,7 +987,7 @@ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack,
wrapped.p = empty_list.p;
stack_push(&wrapped, K);
stack_push(&wrapped, quoted);
stack_push_const(&wrapped, "__->");
stack_push_const(&wrapped, "->");
stack_push(prevstack, &wrapped);
@ -1021,7 +1029,7 @@ static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack,
stack_push(prevstack, &tmp);
stack_push(prevstack, K);
stack_push_const(readstack, "__quasiquote");
stack_push_const(readstack, "quasiquote");
uns_root_remove(gc, &tmpint);
uns_root_remove(gc, &tmp);
@ -1164,13 +1172,13 @@ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack,
stack_push(&expr, &bound_k);
stack_push(&expr, &empty_list);
stack_push(&expr, &thunk);
stack_push_const(&expr, "__A"); /* (__A thunk '() bound_k) */
stack_push_const(&expr, "A"); /* (__A thunk '() bound_k) */
tmp1.p = expr.p;
expr.p = empty_list.p;
stack_push(&expr, &tmp1);
stack_push(&expr, &bound_k);
stack_push_const(&expr, "__K"); /* (__K bound_k (__A thunk '() bound_k)) */
stack_push_const(&expr, "K"); /* (__K bound_k (__A thunk '() bound_k)) */
tmp1.p = expr.p;
expr.p = empty_list.p;
@ -1178,7 +1186,7 @@ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack,
stack_push(&expr, &tmp1);
stack_push(&expr, &after);
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);
@ -1225,19 +1233,19 @@ static enum cps_return cps_exec_call_cc(struct uns_ctr *prevstack,
stack_push(&expr, &newk);
stack_push(&expr, &newk);
stack_push(&expr, &f);
stack_push_const(&expr, "__A"); /* (__A f k k) */
stack_push_const(&expr, "A"); /* (__A f k k) */
tmp.p = expr.p;
expr.p = empty_list.p;
stack_push(&expr, &tmp);
stack_push(&expr, &newk);
stack_push_const(&expr, "kappa"); /* (kappa k (__A f k k)) */
stack_push_const(&expr, "K"); /* (kappa k (__A f k k)) */
tmp.p = expr.p;
expr.p = empty_list.p;
stack_push(&expr, K);
stack_push(&expr, &tmp);
stack_push_const(&expr, "__<-"); /* (__<- (...) K) */
stack_push_const(&expr, "<-"); /* (__<- (...) K) */
stack_push(prevstack, &expr);
@ -1305,7 +1313,41 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack,
return CPS_CONTINUE;
}
/* {K (f . L)} {cps} = {(kappa l (@ f l K)) '() L} {cps-list} */
static int reverse(struct uns_ctr *into, struct uns_ctr *from)
{
struct uns_ctr cell = {0};
struct uns_ctr tmp = {0};
int r = 1;
into->p = empty_list.p;
uns_root_add(gc, &tmp);
uns_root_add(gc, &cell);
if (get_type(from->p) == EMPTY_LIST)
goto end;
if (get_type(from->p) != CELL) {
r = 0;
goto end;
}
cell.p = from->p;
while (get_type(cell.p) != EMPTY_LIST) {
if (get_type(cell.p) != CELL) {
r = 0;
goto end;
}
tmp.p = CAR(cell.p);
stack_push(into, &tmp);
cell.p = CDR(cell.p);
}
end:
uns_root_remove(gc, &tmp);
uns_root_remove(gc, &cell);
return r;
}
/* {K (f . L)} {cps} = {(@ f l K) '() [rev L] l} {cps-list} */
static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
struct uns_ctr *K,
struct uns_ctr *E,
@ -1322,23 +1364,20 @@ static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
uns_root_add(gc, &l);
gensym(&l);
stack_push(prevstack, &l);
tmp.p = CDR(E->p);
if (!reverse(&expr, &tmp))
return CPS_EXEC_INVALID_APPL_LIST;
stack_push(prevstack, &expr);
stack_push(prevstack, &empty_list);
expr.p = empty_list.p;
stack_push(&expr, K);
stack_push(&expr, &l);
tmp.p = CAR(E->p);
stack_push(&expr, &tmp);
stack_push_const(&expr, "__A"); /* (__A f l K) */
tmp.p = expr.p;
expr.p = empty_list.p;
stack_push(&expr, &tmp);
stack_push(&expr, &l);
stack_push_const(&expr, "__K"); /* (__K l (...)) */
tmp.p = CDR(E->p);
stack_push(prevstack, &tmp);
stack_push(prevstack, &empty_list);
stack_push_const(&expr, "A"); /* (__A f l K) */
stack_push(prevstack, &expr);
stack_push_const(readstack, "cps-list");
@ -1349,7 +1388,7 @@ static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
return CPS_CONTINUE;
}
/* {K (F . L)} {cps} = {(kappa l (@ f l K)) '() L f F} {cps-list cps-app} */
/* {K (F . L)} {cps} = {(@ f l K) '() [rev L] l f F} {cps-list cps-app} */
static enum cps_return cps_exec_compound_fcall(struct uns_ctr *prevstack,
struct uns_ctr *K,
struct uns_ctr *E,
@ -1371,21 +1410,20 @@ static enum cps_return cps_exec_compound_fcall(struct uns_ctr *prevstack,
tmp.p = CAR(E->p);
stack_push(prevstack, &tmp);
stack_push(prevstack, &f);
stack_push(prevstack, &l);
tmp.p = CDR(E->p);
stack_push(prevstack, &tmp);
if (!reverse(&expr, &tmp))
return CPS_EXEC_INVALID_APPL_LIST;
stack_push(prevstack, &expr);
stack_push(prevstack, &empty_list);
expr.p = empty_list.p;
stack_push(&expr, K);
stack_push(&expr, &l);
stack_push(&expr, &f);
stack_push_const(&expr, "__A"); /* (__A f l K) */
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_const(&expr, "A"); /* (__A f l K) */
stack_push(prevstack, &expr);
stack_push_const(readstack, "cps-app");
@ -1482,7 +1520,7 @@ static enum cps_return cps_exec(struct uns_ctr *prevstack,
case EMPTY_LIST:
stack_push(&tmp, &K);
stack_push(&tmp, &E);
stack_push_const(&tmp, "__->");
stack_push_const(&tmp, "->");
stack_push(prevstack, &tmp);
break;
case CELL:
@ -1501,6 +1539,121 @@ end:
return r;
}
/* {K HEAD '() l} {cps-list} = {(-> HEAD (kappa l K))} {} */
static enum cps_return cps_list_final(struct uns_ctr *prevstack,
struct uns_ctr *K,
struct uns_ctr *head,
struct uns_ctr *l
)
{
struct uns_ctr expr = {0};
struct uns_ctr tmp = {0};
uns_root_add(gc, &expr);
uns_root_add(gc, &tmp);
expr.p = empty_list.p;
stack_push(&expr, K);
stack_push(&expr, l);
stack_push_const(&expr, "K");
tmp.p = expr.p;
expr.p = empty_list.p;
stack_push(&expr, &tmp);
stack_push(&expr, head);
stack_push_const(&expr, "->");
stack_push(prevstack, &expr);
uns_root_remove(gc, &expr);
uns_root_remove(gc, &tmp);
return CPS_CONTINUE;
}
/* {K HEAD (A . B) l} {cps-list} =
{(kappa a K) A [cons a HEAD] B l} {cps cps-list}
*/
static enum cps_return cps_list_cell(struct uns_ctr *prevstack,
struct uns_ctr *K,
struct uns_ctr *head,
struct uns_ctr *args,
struct uns_ctr *readstack
)
{
struct uns_ctr expr = {0};
struct uns_ctr atmp = {0};
enum cps_return r = CPS_CONTINUE;
uns_root_add(gc, &expr);
uns_root_add(gc, &atmp);
gensym(&atmp);
expr.p = CDR(args->p);
stack_push(prevstack, &expr);
cons(&expr, &atmp, head);
stack_push(prevstack, &expr);
expr.p = CAR(args->p);
stack_push(prevstack, &expr);
expr.p = empty_list.p;
stack_push(&expr, K);
stack_push(&expr, &atmp);
stack_push_const(&expr, "K");
stack_push(prevstack, &expr);
stack_push_const(readstack, "cps-list");
stack_push_const(readstack, "cps");
uns_root_remove(gc, &expr);
uns_root_remove(gc, &atmp);
return r;
}
/* {K HEAD ARGS l} {cps-list}
*/
static enum cps_return cps_list(struct uns_ctr *prevstack,
struct uns_ctr *readstack
)
{
struct uns_ctr K = {0};
struct uns_ctr head = {0};
struct uns_ctr args = {0};
struct uns_ctr l = {0};
enum cps_return r = CPS_CONTINUE;
uns_root_add(gc, &K);
uns_root_add(gc, &head);
uns_root_add(gc, &args);
uns_root_add(gc, &l);
if (!stack_pop(prevstack, &K)
|| !stack_pop(prevstack, &head)
|| !stack_pop(prevstack, &args)
|| !stack_pop(prevstack, &l)) {
r = CPS_LIST_UNDERFLOW;
goto end;
}
switch (get_type(args.p)) {
case EMPTY_LIST:
r = cps_list_final(prevstack, &K, &head, &l);
break;
case CELL:
stack_push(prevstack, &l);
r = cps_list_cell(prevstack, &K, &head, &args, readstack);
break;
default:
r = CPS_LIST_IMPROPER_LIST;
break;
}
end:
uns_root_remove(gc, &K);
uns_root_remove(gc, &head);
uns_root_remove(gc, &args);
uns_root_remove(gc, &l);
return r;
}
static enum cps_return cps(struct uns_ctr *prevstack,
struct uns_ctr *readstack)
{
@ -1523,6 +1676,8 @@ static enum cps_return cps(struct uns_ctr *prevstack,
if (strcmp(cmd, "cps") == 0) {
r = cps_exec(prevstack, readstack);
} else if (strcmp(cmd, "cps-list") == 0) {
r = cps_list(prevstack, readstack);
} else {
r = CPS_INVALID_CMD;
}
@ -1644,6 +1799,7 @@ int main(void)
struct uns_ctr prevstack = {0};
struct uns_ctr readstack = {0};
struct file input = {0};
enum cps_return r;
input.loc.line = 1;
init();
@ -1656,7 +1812,6 @@ int main(void)
expr.p = NULL;
switch (expr_parse(&input, &expr)) {
case EXPR_PARSE_OK:
fprintf(stderr, "parse finished\n");
expr.p = uns_get(gc, expr.p, 0, NULL);
display(&expr);
break;
@ -1689,12 +1844,14 @@ int main(void)
}
cps_init(&prevstack, &readstack, &expr);
fprintf(stderr, "cps: %s\n", cps_return_to_string[cps(&prevstack, &readstack)]);
printf("Prev: {\n");
display(&prevstack);
printf("}\nRead: {\n");
display(&readstack);
printf("}\n");
do {
printf("Prev: {\n");
display(&prevstack);
printf("}\nRead: {\n");
display(&readstack);
printf("}\n");
r = cps(&prevstack, &readstack);
} while (r == CPS_CONTINUE);
}
cleanup: