diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c index d90f8c5..1d2d28a 100644 --- a/examples/lisp/uns_lisp.c +++ b/examples/lisp/uns_lisp.c @@ -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: