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

uns_lisp: quasiquote parser

This commit is contained in:
Peter McGoron 2024-07-16 19:54:50 -04:00
parent 23ad070039
commit 2e3d3a23cd
2 changed files with 493 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
examples/lisp/prelude.scm
View File

@ -74,7 +74,7 @@
(__define-macro cond body
(let ((cases (car body)))
(if (null? body)
<undefined>
(null)
(let* ((branch (car cases))
(rest (cdr cases))
(test (car branch))

529
examples/lisp/uns_lisp.c
View File

@ -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;
}