diff --git a/examples/lisp/prelude.scm b/examples/lisp/prelude.scm index b181e34..c2a606a 100644 --- a/examples/lisp/prelude.scm +++ b/examples/lisp/prelude.scm @@ -74,7 +74,7 @@ (__define-macro cond body (let ((cases (car body))) (if (null? body) - + (null) (let* ((branch (car cases)) (rest (cdr cases)) (test (car branch)) diff --git a/examples/lisp/uns_lisp.c b/examples/lisp/uns_lisp.c index aa450a1..f714259 100644 --- a/examples/lisp/uns_lisp.c +++ b/examples/lisp/uns_lisp.c @@ -69,7 +69,7 @@ static const char *token2string_repr[TOKEN_NUM] = { "quote", "quasiquote", "unquote", - "unquote-list", + "unquote-splice", "'ident", "'number", "'float", @@ -392,6 +392,8 @@ static const char *get_string(struct uns_ctr *ctr) case STRING: case SYMBOL: break; default: + abort(); + uns_root_remove(gc, &s); return NULL; } @@ -1011,8 +1013,8 @@ enum cps_return { CPS_CANNOT_CALL_TYPE, CPS_QUOTE_UNDERFLOW, CPS_QUOTE_OVERFLOW, - CPS_QUASIQUOTE_UNDERFLOW, - CPS_QUASIQUOTE_OVERFLOW, + CPS_EXEC_QUASIQUOTE_UNDERFLOW, + CPS_EXEC_QUASIQUOTE_OVERFLOW, CPS_EXEC_LAMBDA_UNDERFLOW, CPS_EXEC_LAMBDA_OVERFLOW, CPS_INVALID_LAMBDA_FORMAL, @@ -1038,6 +1040,13 @@ enum cps_return { CPS_SWAP_UNDERFLOW, CPS_IF_UNDERFLOW, CPS_LAMBDA_UNDERFLOW, + CPS_QUASIQUOTE_UNQUOTE_UNDERFLOW, + CPS_QUASIQUOTE_UNQUOTE_OVERFLOW, + CPS_QUASIQUOTE_SPLICE_UNDERFLOW, + CPS_QUASIQUOTE_SPLICE_OVERFLOW, + CPS_QUASIQUOTE_UNDERFLOW, + CPS_WRAP_SPLICE_UNDERFLOW, + CPS_WRAP_UNDERFLOW, CPS_RETURN_LEN }; @@ -1050,8 +1059,8 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = { "CPS_CANNOT_CALL_TYPE", "CPS_QUOTE_UNDERFLOW", "CPS_QUOTE_OVERFLOW", - "CPS_QUASIQUOTE_UNDERFLOW", - "CPS_QUASIQUOTE_OVERFLOW", + "CPS_EXEC_QUASIQUOTE_UNDERFLOW", + "CPS_EXEC_QUASIQUOTE_OVERFLOW", "CPS_EXEC_LAMBDA_UNDERFLOW", "CPS_EXEC_LAMBDA_OVERFLOW", "CPS_INVALID_LAMBDA_FORMAL", @@ -1076,13 +1085,20 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = { "CPS_FCALL_IMPROPER_LIST", "CPS_SWAP_UNDERFLOW", "CPS_IF_UNDERFLOW", - "CPS_LAMBDA_UNDERFLOW" + "CPS_LAMBDA_UNDERFLOW", + "CPS_QUASIQUOTE_UNQUOTE_UNDERFLOW", + "CPS_QUASIQUOTE_UNQUOTE_OVERFLOW", + "CPS_QUASIQUOTE_SPLICE_UNDERFLOW", + "CPS_QUASIQUOTE_SPLICE_OVERFLOW", + "CPS_QUASIQUOTE_UNDERFLOW", + "CPS_WRAP_SPLICE_UNDERFLOW", + "CPS_WRAP_UNDERFLOW" }; -/* {K (quote QUOTED)} {cps} = {(-> (quote 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 *quote, + struct uns_ctr *quoted, struct uns_ctr *readstack ) { @@ -1090,9 +1106,10 @@ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack, uns_root_add(gc, &wrapped); wrapped.p = empty_list.p; + stack_push(&wrapped, K); - stack_push(&wrapped, quote); - stack_push_const(&wrapped, "->"); + stack_push(&wrapped, quoted); + stack_push_const(&wrapped, "quote->"); stack_push(prevstack, &wrapped); @@ -1100,7 +1117,7 @@ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack, return CPS_CONTINUE; } -/* {K (quasiquote E)} {cps} = {K 1 E} {quasiquote} +/* {K (quasiquote E)} {cps} = {K E n} {quasiquote} */ static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack, @@ -1110,32 +1127,22 @@ static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack, ) { struct uns_ctr tmp = {0}; - struct uns_ctr tmpint = {0}; - const long i = 1; if (get_type(quoted->p) != CELL) - return CPS_QUASIQUOTE_UNDERFLOW; + return CPS_EXEC_QUASIQUOTE_UNDERFLOW; if (get_type(CDR(quoted->p)) != EMPTY_LIST) - return CPS_QUASIQUOTE_OVERFLOW; + return CPS_EXEC_QUASIQUOTE_OVERFLOW; quoted->p = CAR(quoted->p); - stack_push(prevstack, quoted); - uns_root_add(gc, &tmp); - alloc_of_type(&tmp, INTEGER); - - uns_root_add(gc, &tmpint); - tmpint.p = uns_alloc(gc, sizeof(i), 0); - memcpy(tmpint.p, &i, sizeof(i)); - - uns_set(gc, tmp.p, 1, UNS_POINTER, tmpint.p); + alloc_int(&tmp, 1); stack_push(prevstack, &tmp); + stack_push(prevstack, quoted); stack_push(prevstack, K); - stack_push_const(readstack, "quasiquote"); + stack_push_const(readstack, "qq"); - uns_root_remove(gc, &tmpint); uns_root_remove(gc, &tmp); return CPS_CONTINUE; @@ -1372,6 +1379,7 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack, struct uns_ctr b1 = {0}; struct uns_ctr b2 = {0}; struct uns_ctr e = {0}; + enum cps_return r = CPS_CONTINUE; uns_root_add(gc, &newk); uns_root_add(gc, &e); @@ -1380,21 +1388,31 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack, gensym(&newk); - if (get_type(lst->p) != CELL) - return CPS_EXEC_IF_UNDERFLOW; + if (get_type(lst->p) != CELL) { + r = CPS_EXEC_IF_UNDERFLOW; + goto end; + } + e.p = CAR(lst->p); lst->p = CDR(lst->p); - if (get_type(lst->p) != CELL) - return CPS_EXEC_IF_UNDERFLOW; + if (get_type(lst->p) != CELL) { + r = CPS_EXEC_IF_UNDERFLOW; + goto end; + } b1.p = CAR(lst->p); lst->p = CDR(lst->p); - if (get_type(lst->p) != CELL) - return CPS_EXEC_IF_UNDERFLOW; + if (get_type(lst->p) != CELL) { + r = CPS_EXEC_IF_UNDERFLOW; + goto end; + } + b2.p = CAR(lst->p); - if (get_type(CDR(lst->p)) != EMPTY_LIST) - return CPS_EXEC_IF_OVERFLOW; + if (get_type(CDR(lst->p)) != EMPTY_LIST) { + r = CPS_EXEC_IF_OVERFLOW; + goto end; + } stack_push(prevstack, &e); stack_push(prevstack, K); @@ -1414,7 +1432,8 @@ static enum cps_return cps_exec_if(struct uns_ctr *prevstack, uns_root_remove(gc, &b1); uns_root_remove(gc, &b2); - return CPS_CONTINUE; +end: + return r; } static int reverse(struct uns_ctr *into, struct uns_ctr *from) @@ -1566,7 +1585,8 @@ static enum cps_return cps_exec_cell(struct uns_ctr *prevstack, case SYMBOL: symb = get_string(tmp); if (strcmp(symb, "quote") == 0) { - r = cps_exec_quote(prevstack, K, E, readstack); + tmp-> p = CDR(E->p); + r = cps_exec_quote(prevstack, K, tmp, readstack); break; } else if (strcmp(symb, "quasiquote") == 0) { tmp->p = CDR(E->p); @@ -1587,7 +1607,7 @@ static enum cps_return cps_exec_cell(struct uns_ctr *prevstack, } else if (strcmp(symb, "unquote") == 0) { r = CPS_UNQUOTE_INVALID; break; - } else if (strcmp(symb, "unquote-list") == 0) { + } else if (strcmp(symb, "unquote-splice") == 0) { r = CPS_UNQUOTE_LIST_INVALID; break; } else if (strcmp(symb, "if") == 0) { @@ -1912,6 +1932,435 @@ end: return r; } +enum cps_quasiquote_unquote { + CPS_QUASIQUOTE_NONE = 0, + CPS_QUASIQUOTE_UNQUOTE = 1, + CPS_QUASIQUOTE_UNQUOTE_SPLICE = 2 +}; + +static enum cps_quasiquote_unquote is_unquote(struct uns_ctr *E) +{ + struct uns_ctr carptr = {0}; + const char *s; + enum cps_quasiquote_unquote r = CPS_QUASIQUOTE_NONE; + + uns_root_add(gc, &carptr); + carptr.p = CAR(E->p); + + if (get_type(carptr.p) == SYMBOL) { + s = get_string(&carptr); + if (!s) + r = CPS_QUASIQUOTE_NONE; + else if (strcmp(s, "unquote") == 0) + r = CPS_QUASIQUOTE_UNQUOTE; + } else if (get_type(carptr.p) == CELL) { + carptr.p = CAR(carptr.p); + + if (get_type(carptr.p) != SYMBOL) + goto end; + s = get_string(&carptr); + if (!s) + r = CPS_QUASIQUOTE_NONE; + else if (strcmp(s, "unquote-splice") == 0) + r = CPS_QUASIQUOTE_UNQUOTE_SPLICE; + } + +end: + uns_root_remove(gc, &carptr); + return r; +} + +/* + {K (,@A . B) 1} {qq} + = {(kappa b (append-> a b K)) + B 1 a A} {qq wrap cps} + + {K (,@A . B) n} {qq} + = { (kappa b (cons-> aquote b K)) + + B n aquote a A [- n 1]} {qq wrap-splice qq} + */ + +static enum cps_return cps_quasiquote_splice(struct uns_ctr *prevstack, + struct uns_ctr *K, + struct uns_ctr *E, + struct uns_ctr *nptr, + struct uns_ctr *readstack + ) +{ + struct uns_ctr A = {0}; + struct uns_ctr asymb = {0}; + struct uns_ctr aquote = {0}; + struct uns_ctr bsymb = {0}; + struct uns_ctr expr = {0}; + struct uns_ctr tmp = {0}; + long n; + enum cps_return r = CPS_CONTINUE; + + uns_root_add(gc, &A); + uns_root_add(gc, &asymb); + uns_root_add(gc, &aquote); + uns_root_add(gc, &bsymb); + uns_root_add(gc, &expr); + uns_root_add(gc, &tmp); + + A.p = CAR(E->p); + if (get_type(CDR(A.p)) != CELL) { + r = CPS_QUASIQUOTE_SPLICE_UNDERFLOW; + goto end; + } + if (get_type(CDR(CDR(A.p))) != EMPTY_LIST) { + r = CPS_QUASIQUOTE_SPLICE_OVERFLOW; + goto end; + } + + A.p = CAR(CDR(A.p)); + + n = get_int(nptr); + if (n == 1) { + gensym(&asymb); + gensym(&bsymb); + stack_push(prevstack, &A); + stack_push(prevstack, &asymb); + stack_push(prevstack, nptr); + A.p = CDR(E->p); + stack_push(prevstack, &A); + + expr.p = empty_list.p; + stack_push(&expr, K); + stack_push(&expr, &bsymb); + stack_push(&expr, &asymb); + stack_push_const(&expr, "append->"); + + tmp.p = expr.p; + expr.p = empty_list.p; + stack_push(&expr, &tmp); + stack_push(&expr, &bsymb); + stack_push_const(&expr, "K"); + + stack_push(prevstack, &expr); + stack_push_const(readstack, "cps"); + stack_push_const(readstack, "wrap"); + stack_push_const(readstack, "qq"); + } else { + alloc_int(&tmp, n - 1); + stack_push(prevstack, &tmp); + stack_push(prevstack, &A); + + gensym(&asymb); + gensym(&bsymb); + gensym(&aquote); + + A.p = CDR(E->p); + stack_push(prevstack, nptr); + stack_push(prevstack, &aquote); + stack_push(prevstack, &asymb); + stack_push(prevstack, &A); + + expr.p = empty_list.p; + stack_push(&expr, K); + stack_push(&expr, &bsymb); + stack_push(&expr, &aquote); + stack_push_const(&expr, "cons->"); + + tmp.p = expr.p; + expr.p = empty_list.p; + stack_push(&expr, &tmp); + stack_push(&expr, &bsymb); + stack_push_const(&expr, "K"); + + stack_push(prevstack, &expr); + stack_push_const(readstack, "qq"); + stack_push_const(readstack, "wrap-splice"); + stack_push_const(readstack, "qq"); + } +end: + uns_root_remove(gc, &A); + uns_root_remove(gc, &asymb); + uns_root_remove(gc, &aquote); + uns_root_remove(gc, &bsymb); + uns_root_remove(gc, &expr); + uns_root_remove(gc, &tmp); + return r; +} + +/* + {K ,A 1} {qq} = {K A} {cps} + {K ,A n} {qq} = {(kappa a (unquote-> a K)) A [- n 1]} {qq} +*/ +static enum cps_return cps_quasiquote_unquote(struct uns_ctr *prevstack, + struct uns_ctr *K, + struct uns_ctr *E, + struct uns_ctr *nptr, + struct uns_ctr *readstack + ) +{ + long n; + struct uns_ctr expr = {0}; + struct uns_ctr tmp = {0}; + struct uns_ctr asym = {0}; + enum cps_return r = CPS_CONTINUE; + + uns_root_add(gc, &expr); + uns_root_add(gc, &tmp); + uns_root_add(gc, &asym); + + if (get_type(CDR(E->p)) != CELL) { + r = CPS_QUASIQUOTE_UNQUOTE_UNDERFLOW; + goto end; + } + if (get_type(CDR(CDR(E->p))) != EMPTY_LIST) { + r = CPS_QUASIQUOTE_UNQUOTE_OVERFLOW; + goto end; + } + + expr.p = CAR(CDR(E->p)); + + n = get_int(nptr); + if (n == 1) { + stack_push(prevstack, &expr); + stack_push(prevstack, K); + stack_push_const(readstack, "cps"); + } else { + gensym(&asym); + alloc_int(nptr, n - 1); + stack_push(prevstack, nptr); + stack_push(prevstack, &expr); + + expr.p = empty_list.p; + stack_push(&expr, K); + stack_push(&expr, &asym); + stack_push_const(&expr, "unquote->"); + + tmp.p = expr.p; + expr.p = empty_list.p; + stack_push(&expr, &tmp); + stack_push(&expr, &asym); + stack_push_const(&expr, "K"); + stack_push_const(readstack, "qq"); + } + +end: + uns_root_remove(gc, &expr); + uns_root_remove(gc, &tmp); + uns_root_remove(gc, &asym); + return r; +} + +/* {K (A . B) n} {qq} + = {(kappa b (cons-> a b K)) + B n a A n} {qq wrap qq} + */ +static enum cps_return cps_quasiquote_cons(struct uns_ctr *prevstack, + struct uns_ctr *K, + struct uns_ctr *E, + struct uns_ctr *n, + struct uns_ctr *readstack + ) +{ + struct uns_ctr tmp = {0}; + struct uns_ctr expr = {0}; + struct uns_ctr asym = {0}; + struct uns_ctr bsym = {0}; + + uns_root_add(gc, &expr); + uns_root_add(gc, &tmp); + uns_root_add(gc, &asym); + uns_root_add(gc, &bsym); + gensym(&asym); + gensym(&bsym); + + tmp.p = CAR(E->p); + stack_push(prevstack, n); + stack_push(prevstack, &tmp); + stack_push(prevstack, &asym); + + tmp.p = CDR(E->p); + stack_push(prevstack, n); + stack_push(prevstack, &tmp); + + expr.p = empty_list.p; + stack_push(&expr, K); + stack_push(&expr, &bsym); + stack_push(&expr, &asym); + stack_push_const(&expr, "cons->"); + + tmp.p = expr.p; + expr.p = empty_list.p; + stack_push(&expr, &tmp); + stack_push(&expr, &bsym); + stack_push_const(&expr, "K"); + + stack_push(prevstack, &expr); + stack_push_const(readstack, "qq"); + stack_push_const(readstack, "wrap"); + stack_push_const(readstack, "qq"); + + uns_root_remove(gc, &expr); + uns_root_remove(gc, &tmp); + uns_root_remove(gc, &asym); + uns_root_remove(gc, &bsym); + + return CPS_CONTINUE; +} + +static enum cps_return cps_quasiquote_cell(struct uns_ctr *prevstack, + struct uns_ctr *K, + struct uns_ctr *E, + struct uns_ctr *n, + struct uns_ctr *readstack + ) +{ + switch (is_unquote(E)) { + case CPS_QUASIQUOTE_NONE: + return cps_quasiquote_cons(prevstack, K, E, n, readstack); + case CPS_QUASIQUOTE_UNQUOTE: + return cps_quasiquote_unquote(prevstack, K, E, n, readstack); + case CPS_QUASIQUOTE_UNQUOTE_SPLICE: + return cps_quasiquote_splice(prevstack, K, E, n, readstack); + } + return CPS_QUASIQUOTE_UNDERFLOW; +} + +/* {K E _} {qq} = {(quote-> E K} */ +static enum cps_return cps_quasiquote_simple(struct uns_ctr *prevstack, + struct uns_ctr *K, + struct uns_ctr *quoted + ) +{ + struct uns_ctr expr = {0}; + + uns_root_add(gc, &expr); + + expr.p = empty_list.p; + stack_push(&expr, K); + stack_push(&expr, quoted); + stack_push_const(&expr, "quote->"); + + stack_push(prevstack, &expr); + + uns_root_remove(gc, &expr); + return CPS_CONTINUE; +} + +static enum cps_return cps_quasiquote(struct uns_ctr *prevstack, + struct uns_ctr *readstack + ) +{ + struct uns_ctr K = {0}; + struct uns_ctr expr = {0}; + struct uns_ctr number = {0}; + enum cps_return r = CPS_CONTINUE; + + uns_root_add(gc, &K); + uns_root_add(gc, &expr); + uns_root_add(gc, &number); + + if (!stack_pop(prevstack, &K) + || !stack_pop(prevstack, &expr) + || !stack_pop(prevstack, &number)) { + r = CPS_QUASIQUOTE_UNDERFLOW; + goto end; + } + + switch (get_type(expr.p)) { + case CELL: + r = cps_quasiquote_cell(prevstack, &K, &expr, &number, readstack); + break; + default: + r = cps_quasiquote_simple(prevstack, &K, &expr); + } + +end: + uns_root_remove(gc, &K); + uns_root_remove(gc, &expr); + uns_root_remove(gc, &number); + return r; +} + +/* {K a} {wrap} = {(kappa a K)} {} */ +static enum cps_return cps_wrap(struct uns_ctr *prevstack) +{ + struct uns_ctr K = {0}; + struct uns_ctr a = {0}; + struct uns_ctr expr = {0}; + enum cps_return r = CPS_CONTINUE; + + uns_root_add(gc, &K); + uns_root_add(gc, &a); + uns_root_add(gc, &expr); + + if (!stack_pop(prevstack, &K) + || !stack_pop(prevstack, &a)) { + r = CPS_WRAP_UNDERFLOW; + goto end; + } + + expr.p = empty_list.p; + stack_push(&expr, &K); + stack_push(&expr, &a); + stack_push_const(&expr, "K"); + + stack_push(prevstack, &expr); + +end: + + uns_root_remove(gc, &K); + uns_root_remove(gc, &a); + uns_root_remove(gc, &expr); + return r; +} + +/* {K aquote a} {wrap-splice} + = {(kappa a (unquote-splice-> a (kappa aquote K)))} + */ +static enum cps_return cps_wrap_splice(struct uns_ctr *prevstack) +{ + struct uns_ctr expr = {0}; + struct uns_ctr tmp = {0}; + struct uns_ctr K = {0}; + struct uns_ctr aquote = {0}; + struct uns_ctr a = {0}; + enum cps_return r = CPS_CONTINUE; + + uns_root_add(gc, &expr); + uns_root_add(gc, &tmp); + uns_root_add(gc, &K); + uns_root_add(gc, &aquote); + uns_root_add(gc, &a); + + if (!stack_pop(prevstack, &K) + || !stack_pop(prevstack, &aquote) + || !stack_pop(prevstack, &a)) { + r = CPS_WRAP_SPLICE_UNDERFLOW; + goto end; + } + + expr.p = empty_list.p; + stack_push(&expr, &K); + stack_push(&expr, &aquote); + stack_push_const(&expr, "K"); + + tmp.p = expr.p; + expr.p = empty_list.p; + stack_push(&expr, &tmp); + stack_push(&expr, &a); + stack_push_const(&expr, "unquote-splice->"); + + tmp.p = expr.p; + expr.p = empty_list.p; + stack_push(&expr, &tmp); + stack_push(&expr, &a); + stack_push_const(&expr, "K"); +end: + uns_root_remove(gc, &expr); + uns_root_remove(gc, &tmp); + uns_root_remove(gc, &K); + uns_root_remove(gc, &aquote); + uns_root_remove(gc, &a); + return r; +} + static enum cps_return cps(struct uns_ctr *prevstack, struct uns_ctr *readstack) { @@ -1942,6 +2391,12 @@ static enum cps_return cps(struct uns_ctr *prevstack, r = cps_if(prevstack, readstack); } else if (strcmp(cmd, "cps-lambda") == 0) { r = cps_lambda(prevstack); + } else if (strcmp(cmd, "qq") == 0) { + r = cps_quasiquote(prevstack, readstack); + } else if (strcmp(cmd, "wrap") == 0) { + r = cps_wrap(prevstack); + } else if (strcmp(cmd, "wrap-splice") == 0) { + r = cps_wrap_splice(prevstack); } else { r = CPS_INVALID_CMD; }