diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c index fc53464..f6760a9 100644 --- a/examples/lisp/uns_lisp.c +++ b/examples/lisp/uns_lisp.c @@ -891,6 +891,104 @@ static int stack_pop(struct uns_ctr *stack, struct uns_ctr *into) return 1; } +static void display(struct uns_ctr *ctr) +{ + long indent = 0; + long list_part = 0; + int add_space = 0; + struct uns_ctr stack = {0}; + struct uns_ctr top = {0}; + struct uns_ctr ival = {0}; + struct uns_ctr tmp = {0}; + struct uns_ctr exprstore = {0}; + long l; + double f; + +#define SPC (add_space ? " " : "") + + uns_root_add(gc, &stack); + uns_root_add(gc, &top); + uns_root_add(gc, &ival); + uns_root_add(gc, &tmp); + uns_root_add(gc, &exprstore); + + stack.p = empty_list.p; + alloc_int(&ival, 0); + cons(&top, &ival, ctr); /* (0 . expr) */ + stack_push(&stack, &top); + + while (stack_pop(&stack, &top)) { + ival.p = CAR(top.p); + list_part = get_int(&ival); + top.p = CDR(top.p); + + switch(get_type(top.p)) { + case INTEGER: + memcpy(&l, uns_get(gc, top.p, 1, NULL), sizeof(long)); + printf("%s%ld", SPC, l); + break; + case FLOAT: + memcpy(&f, uns_get(gc, top.p, 1, NULL), sizeof(double)); + printf("%s%f", SPC, f); + break; + case STRING: + tmp.p = uns_get(gc, top.p, 1, NULL); + printf("%s\"%s\"", SPC, uns_string_cstring(gc, &tmp)); + break; + case SYMBOL: + tmp.p = uns_get(gc, top.p, 1, NULL); + printf("%s%s", SPC, uns_string_cstring(gc, &tmp)); + break; + case EMPTY_LIST: + if (list_part) { + printf(")"); + indent--; + } else { + printf("%s'()", SPC); + } + break; + case LISP_NULL: + printf(""); + break; + case CELL: + alloc_int(&ival, 1); + exprstore.p = CDR(top.p); + cons(&tmp, &ival, &exprstore); + stack_push(&stack, &tmp); + + alloc_int(&ival, 0); + exprstore.p = CAR(top.p); + cons(&tmp, &ival, &exprstore); + stack_push(&stack, &tmp); + + if (!list_part) { + if (add_space) { + printf("\n"); + for (l = 0; l < indent; l++) { + printf(" "); + } + } else { + printf("%s", SPC); + } + indent++; + printf("("); + add_space = 0; + } + break; + } + + if (get_type(top.p) != CELL) + add_space = 1; + } + + uns_root_remove(gc, &stack); + uns_root_remove(gc, &top); + uns_root_remove(gc, &ival); + uns_root_remove(gc, &tmp); + uns_root_remove(gc, &exprstore); + printf("\n"); +} + /* Initialize to {__toplevel EXPR} {__cps __return} */ static void cps_init(struct uns_ctr *prevstack, struct uns_ctr *readstack, struct uns_ctr *expr) @@ -933,8 +1031,10 @@ enum cps_return { CPS_LIST_INCONSISTENT_LIST, CPS_LIST_UNDERFLOW, CPS_LIST_IMPROPER_LIST, + CPS_LIST_BAD_ALIST, CPS_EXEC_INVALID_APPL_LIST, CPS_APP_UNDERFLOW, + CPS_FCALL_IMPROPER_LIST, CPS_RETURN_LEN }; @@ -962,35 +1062,30 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = { "CPS_IF_OVERFLOW", "CPS_UNQUOTE_INVALID", "CPS_UNQUOTE_LIST_INVALID", - "CPS_INVALID_CMD", "CPS_NULL_EXPR", + "CPS_INVALID_CMD", "CPS_LIST_INCONSISTENT_LIST", + "CPS_LIST_UNDERFLOW", "CPS_LIST_IMPROPER_LIST", + "CPS_LIST_BAD_ALIST", "CPS_EXEC_INVALID_APPL_LIST", "CPS_APP_UNDERFLOW", - "CPS_LIST_UNDERFLOW" + "CPS_FCALL_IMPROPER_LIST", }; -/* {K (quote QUOTED)} {cps} = {(-> QUOTED K)} */ +/* {K (quote QUOTED)} {cps} = {(-> (quote QUOTED) K)} */ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack, struct uns_ctr *K, - struct uns_ctr *quoted, + struct uns_ctr *quote, struct uns_ctr *readstack ) { struct uns_ctr wrapped = {0}; - if (get_type(quoted->p) != CELL) - return CPS_QUOTE_UNDERFLOW; - if (get_type(CDR(quoted->p)) != EMPTY_LIST) - return CPS_QUOTE_OVERFLOW; - - quoted->p = CAR(quoted->p); - uns_root_add(gc, &wrapped); wrapped.p = empty_list.p; stack_push(&wrapped, K); - stack_push(&wrapped, quoted); + stack_push(&wrapped, quote); stack_push_const(&wrapped, "->"); stack_push(prevstack, &wrapped); @@ -999,8 +1094,7 @@ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack, return CPS_CONTINUE; } -/* Start quasiquotation: - * {K (quasiquote E)} {cps} = {K 1 E} {cps-quasiquote} +/* {K (quasiquote E)} {cps} = {K 1 E} {quasiquote} */ static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack, @@ -1205,6 +1299,7 @@ static enum cps_return cps_exec_dynamic_wind(struct uns_ctr *prevstack, return CPS_CONTINUE; } +/* {K (call/cc f)} {cps} = {(<- (kappa k (@ f k k)) K)} {} */ static enum cps_return cps_exec_call_cc(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *lst, @@ -1352,94 +1447,99 @@ end: return r; } -/* {K (f . L)} {cps} = {(@ f l K) '() [rev L] l} {cps-list} */ +/* Push to prevstack an assocation list of (gensym . expr), where expr + * is evalulated and given the name gensym. + + * combo_in is modified to be a list of symbols, where complex expressions + * are replaced with gensyms. + */ +static int fcall_lists(struct uns_ctr *prevstack, + struct uns_ctr *combo_in + ) +{ + struct uns_ctr revcombo = {0}; + struct uns_ctr exprs = {0}; + struct uns_ctr tmp = {0}; + struct uns_ctr symb = {0}; + struct uns_ctr alist_cell = {0}; + int r = 1; + + uns_root_add(gc, &revcombo); + uns_root_add(gc, &exprs); + uns_root_add(gc, &tmp); + uns_root_add(gc, &symb); + uns_root_add(gc, &alist_cell); + + revcombo.p = exprs.p = empty_list.p; + + while (get_type(combo_in->p) != EMPTY_LIST) { + if (get_type(combo_in->p) != CELL) { + r = 0; + goto end; + } + + tmp.p = CAR(combo_in->p); + if (get_type(tmp.p) == CELL) { + gensym(&symb); + cons(&alist_cell, &symb, &tmp); + stack_push(&exprs, &alist_cell); + stack_push(&revcombo, &symb); + } else { + stack_push(&revcombo, &tmp); + } + + combo_in->p = CDR(combo_in->p); + } + + if (!reverse(combo_in, &revcombo)) { + r = 0; + goto end; + } + stack_push(prevstack, &exprs); + +end: + uns_root_remove(gc, &revcombo); + uns_root_remove(gc, &exprs); + uns_root_remove(gc, &tmp); + uns_root_remove(gc, &symb); + uns_root_remove(gc, &alist_cell); + + return r; +} + +/* {K (F . L)} {cps} = {(@ (symb1 ... symbn) K) [to-eval L]} {cps-list} */ static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack, struct uns_ctr *K, struct uns_ctr *E, struct uns_ctr *readstack ) { - /* CAR(E.p) is the symbol */ struct uns_ctr tmp = {0}; struct uns_ctr expr = {0}; - struct uns_ctr l = {0}; + enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &expr); uns_root_add(gc, &tmp); - 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); + tmp.p = E->p; + if (!fcall_lists(prevstack, &tmp)) { + r = CPS_FCALL_IMPROPER_LIST; + goto end; + } + /* tmp now has simplified combo */ 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) */ stack_push(prevstack, &expr); stack_push_const(readstack, "cps-list"); +end: uns_root_remove(gc, &expr); uns_root_remove(gc, &tmp); - uns_root_remove(gc, &l); - return CPS_CONTINUE; -} - -/* {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, - struct uns_ctr *readstack - ) -{ - struct uns_ctr f = {0}; - struct uns_ctr l = {0}; - struct uns_ctr tmp = {0}; - struct uns_ctr expr = {0}; - - uns_root_add(gc, &f); - uns_root_add(gc, &l); - uns_root_add(gc, &tmp); - uns_root_add(gc, &expr); - gensym(&f); - gensym(&l); - - tmp.p = CAR(E->p); - stack_push(prevstack, &tmp); - stack_push(prevstack, &f); - - 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); - stack_push(&expr, &f); - stack_push_const(&expr, "A"); /* (__A f l K) */ - stack_push(prevstack, &expr); - - stack_push_const(readstack, "cps-app"); - stack_push_const(readstack, "cps-list"); - - uns_root_remove(gc, &f); - uns_root_remove(gc, &l); - uns_root_remove(gc, &tmp); - uns_root_remove(gc, &expr); - - return CPS_CONTINUE; + return r; } static enum cps_return cps_exec_cell(struct uns_ctr *prevstack, @@ -1462,34 +1562,38 @@ static enum cps_return cps_exec_cell(struct uns_ctr *prevstack, case SYMBOL: symb = get_string(tmp); if (strcmp(symb, "quote") == 0) { - tmp->p = CDR(E->p); - r = cps_exec_quote(prevstack, K, tmp, readstack); + r = cps_exec_quote(prevstack, K, E, readstack); + break; } else if (strcmp(symb, "quasiquote") == 0) { tmp->p = CDR(E->p); r = cps_exec_quasiquote(prevstack, K, tmp, readstack); + break; } else if (strcmp(symb, "__lambda") == 0) { tmp->p = CDR(E->p); r = cps_exec_lambda(prevstack, K, tmp, readstack); + break; } else if (strcmp(symb, "__call/cc") == 0) { - /* {K (call/cc f)} {cps} = {(<- (kappa k (@ f k k)) K)} {} */ tmp->p = CDR(E->p); r = cps_exec_call_cc(prevstack, K, tmp, readstack); + break; } else if (strcmp(symb, "__dynamic-wind") == 0) { tmp->p = CDR(E->p); r = cps_exec_dynamic_wind(prevstack, K, tmp, readstack); + break; } else if (strcmp(symb, "unquote") == 0) { r = CPS_UNQUOTE_INVALID; + break; } else if (strcmp(symb, "unquote-list") == 0) { r = CPS_UNQUOTE_LIST_INVALID; + break; } else if (strcmp(symb, "if") == 0) { tmp->p = CDR(E->p); r = cps_exec_if(prevstack, K, tmp, readstack); - } else { - r = cps_exec_fcall(prevstack, K, E, readstack); + break; } - break; + /* FALLTHROUGH */ case CELL: - r = cps_exec_compound_fcall(prevstack, K, E, readstack); + r = cps_exec_fcall(prevstack, K, E, readstack); } return r; @@ -1544,77 +1648,59 @@ 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} +/* {K ((symb . E) . B)} {cps-list} = + {(kappa symb K) E B} {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}; + struct uns_ctr alist_elem = {0}; + struct uns_ctr tmp = {0}; enum cps_return r = CPS_CONTINUE; + uns_root_add(gc, &alist_elem); + uns_root_add(gc, &tmp); 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); + tmp.p = CDR(head->p); /* B */ + stack_push(prevstack, &tmp); + + alist_elem.p = CAR(head->p); + if (get_type(alist_elem.p) != CELL) { + r = CPS_LIST_BAD_ALIST; + goto end; + } + + tmp.p = CDR(alist_elem.p); /* E */ + stack_push(prevstack, &tmp); + + tmp.p = CAR(alist_elem.p); + if (get_type(tmp.p) != SYMBOL) { + r = CPS_LIST_BAD_ALIST; + goto end; + } expr.p = empty_list.p; stack_push(&expr, K); - stack_push(&expr, &atmp); + stack_push(&expr, &tmp); stack_push_const(&expr, "K"); stack_push(prevstack, &expr); stack_push_const(readstack, "cps-list"); stack_push_const(readstack, "cps"); +end: + uns_root_remove(gc, &alist_elem); + uns_root_remove(gc, &tmp); uns_root_remove(gc, &expr); - uns_root_remove(gc, &atmp); return r; } -/* {K HEAD ARGS l} {cps-list} +/* {K HEAD} {cps-list} */ static enum cps_return cps_list(struct uns_ctr *prevstack, struct uns_ctr *readstack @@ -1622,74 +1708,33 @@ static enum cps_return cps_list(struct uns_ctr *prevstack, { 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)) { + || !stack_pop(prevstack, &head)) { r = CPS_LIST_UNDERFLOW; goto end; } - switch (get_type(args.p)) { + switch (get_type(head.p)) { case EMPTY_LIST: - r = cps_list_final(prevstack, &K, &head, &l); + /* {K '()} {cps-list} = {K} */ + stack_push(prevstack, &K); break; case CELL: - stack_push(prevstack, &l); - r = cps_list_cell(prevstack, &K, &head, &args, readstack); + r = cps_list_cell(prevstack, &K, &head, 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; -} - -/* {K f} {cps-app} = {(kappa f K)} {cps} */ -static enum cps_return cps_app(struct uns_ctr *prevstack, - struct uns_ctr *readstack) -{ - struct uns_ctr K = {0}; - struct uns_ctr fsymb = {0}; - struct uns_ctr expr = {0}; - enum cps_return r = CPS_CONTINUE; - - uns_root_add(gc, &K); - uns_root_add(gc, &fsymb); - uns_root_add(gc, &expr); - - if (!stack_pop(prevstack, &K) - || !stack_pop(prevstack, &fsymb)) { - r = CPS_APP_UNDERFLOW; - goto end; - } - - expr.p = empty_list.p; - stack_push(&expr, &K); - stack_push(&expr, &fsymb); - stack_push_const(&expr, "K"); - stack_push(prevstack, &expr); - - stack_push_const(readstack, "cps"); - -end: - uns_root_remove(gc, &K); - uns_root_remove(gc, &fsymb); - uns_root_remove(gc, &expr); return r; } @@ -1717,8 +1762,6 @@ static enum cps_return cps(struct uns_ctr *prevstack, r = cps_exec(prevstack, readstack); } else if (strcmp(cmd, "cps-list") == 0) { r = cps_list(prevstack, readstack); - } else if (strcmp(cmd, "cps-app") == 0) { - r = cps_app(prevstack, readstack); } else { r = CPS_INVALID_CMD; } @@ -1728,104 +1771,6 @@ end: return r; } -static void display(struct uns_ctr *ctr) -{ - long indent = 0; - long list_part = 0; - int add_space = 0; - struct uns_ctr stack = {0}; - struct uns_ctr top = {0}; - struct uns_ctr ival = {0}; - struct uns_ctr tmp = {0}; - struct uns_ctr exprstore = {0}; - long l; - double f; - -#define SPC (add_space ? " " : "") - - uns_root_add(gc, &stack); - uns_root_add(gc, &top); - uns_root_add(gc, &ival); - uns_root_add(gc, &tmp); - uns_root_add(gc, &exprstore); - - stack.p = empty_list.p; - alloc_int(&ival, 0); - cons(&top, &ival, ctr); /* (0 . expr) */ - stack_push(&stack, &top); - - while (stack_pop(&stack, &top)) { - ival.p = CAR(top.p); - list_part = get_int(&ival); - top.p = CDR(top.p); - - switch(get_type(top.p)) { - case INTEGER: - memcpy(&l, uns_get(gc, top.p, 1, NULL), sizeof(long)); - printf("%s%ld", SPC, l); - break; - case FLOAT: - memcpy(&f, uns_get(gc, top.p, 1, NULL), sizeof(double)); - printf("%s%f", SPC, f); - break; - case STRING: - tmp.p = uns_get(gc, top.p, 1, NULL); - printf("%s\"%s\"", SPC, uns_string_cstring(gc, &tmp)); - break; - case SYMBOL: - tmp.p = uns_get(gc, top.p, 1, NULL); - printf("%s%s", SPC, uns_string_cstring(gc, &tmp)); - break; - case EMPTY_LIST: - if (list_part) { - printf(")"); - indent--; - } else { - printf("%s'()", SPC); - } - break; - case LISP_NULL: - printf(""); - break; - case CELL: - alloc_int(&ival, 1); - exprstore.p = CDR(top.p); - cons(&tmp, &ival, &exprstore); - stack_push(&stack, &tmp); - - alloc_int(&ival, 0); - exprstore.p = CAR(top.p); - cons(&tmp, &ival, &exprstore); - stack_push(&stack, &tmp); - - if (!list_part) { - if (add_space) { - printf("\n"); - for (l = 0; l < indent; l++) { - printf(" "); - } - } else { - printf("%s", SPC); - } - indent++; - printf("("); - add_space = 0; - } - break; - } - - if (get_type(top.p) != CELL) - add_space = 1; - } - - uns_root_remove(gc, &stack); - uns_root_remove(gc, &top); - uns_root_remove(gc, &ival); - uns_root_remove(gc, &tmp); - uns_root_remove(gc, &exprstore); - printf("\n"); -} - static void error(struct location *loc, const char *emsg) { fprintf(stderr, "%ld:%ld: ", loc->line, loc->offset); @@ -1891,12 +1836,15 @@ int main(void) printf("}\n"); r = cps(&prevstack, &readstack); } while (r == CPS_CONTINUE); + printf("%s\n", cps_return_to_string[r]); } cleanup: uns_root_remove(gc, &expr); uns_root_remove(gc, &prevstack); uns_root_remove(gc, &readstack); + uns_root_remove(gc, &empty_list); + uns_collect(gc); uns_deinit(gc); return 0; }