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

uns_lisp: change cps-list transformation to make it respect scope

This commit is contained in:
Peter McGoron 2024-07-16 14:24:46 -04:00
parent 5343a0ba4d
commit 3c119ee11f
1 changed files with 227 additions and 279 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

506
examples/lisp/uns_lisp.c
View File

@ -891,6 +891,104 @@ static int stack_pop(struct uns_ctr *stack, struct uns_ctr *into)
return 1; 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("<undefined>");
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} */ /* Initialize to {__toplevel EXPR} {__cps __return} */
static void cps_init(struct uns_ctr *prevstack, struct uns_ctr *readstack, static void cps_init(struct uns_ctr *prevstack, struct uns_ctr *readstack,
struct uns_ctr *expr) struct uns_ctr *expr)
@ -933,8 +1031,10 @@ enum cps_return {
CPS_LIST_INCONSISTENT_LIST, CPS_LIST_INCONSISTENT_LIST,
CPS_LIST_UNDERFLOW, CPS_LIST_UNDERFLOW,
CPS_LIST_IMPROPER_LIST, CPS_LIST_IMPROPER_LIST,
CPS_LIST_BAD_ALIST,
CPS_EXEC_INVALID_APPL_LIST, CPS_EXEC_INVALID_APPL_LIST,
CPS_APP_UNDERFLOW, CPS_APP_UNDERFLOW,
CPS_FCALL_IMPROPER_LIST,
CPS_RETURN_LEN CPS_RETURN_LEN
}; };
@ -962,35 +1062,30 @@ static const char *cps_return_to_string[CPS_RETURN_LEN] = {
"CPS_IF_OVERFLOW", "CPS_IF_OVERFLOW",
"CPS_UNQUOTE_INVALID", "CPS_UNQUOTE_INVALID",
"CPS_UNQUOTE_LIST_INVALID", "CPS_UNQUOTE_LIST_INVALID",
"CPS_INVALID_CMD",
"CPS_NULL_EXPR", "CPS_NULL_EXPR",
"CPS_INVALID_CMD",
"CPS_LIST_INCONSISTENT_LIST", "CPS_LIST_INCONSISTENT_LIST",
"CPS_LIST_UNDERFLOW",
"CPS_LIST_IMPROPER_LIST", "CPS_LIST_IMPROPER_LIST",
"CPS_LIST_BAD_ALIST",
"CPS_EXEC_INVALID_APPL_LIST", "CPS_EXEC_INVALID_APPL_LIST",
"CPS_APP_UNDERFLOW", "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, static enum cps_return cps_exec_quote(struct uns_ctr *prevstack,
struct uns_ctr *K, struct uns_ctr *K,
struct uns_ctr *quoted, struct uns_ctr *quote,
struct uns_ctr *readstack struct uns_ctr *readstack
) )
{ {
struct uns_ctr wrapped = {0}; 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); uns_root_add(gc, &wrapped);
wrapped.p = empty_list.p; wrapped.p = empty_list.p;
stack_push(&wrapped, K); stack_push(&wrapped, K);
stack_push(&wrapped, quoted); stack_push(&wrapped, quote);
stack_push_const(&wrapped, "->"); stack_push_const(&wrapped, "->");
stack_push(prevstack, &wrapped); stack_push(prevstack, &wrapped);
@ -999,8 +1094,7 @@ static enum cps_return cps_exec_quote(struct uns_ctr *prevstack,
return CPS_CONTINUE; return CPS_CONTINUE;
} }
/* Start quasiquotation: /* {K (quasiquote E)} {cps} = {K 1 E} {quasiquote}
* {K (quasiquote E)} {cps} = {K 1 E} {cps-quasiquote}
*/ */
static enum cps_return cps_exec_quasiquote(struct uns_ctr *prevstack, 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; 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, static enum cps_return cps_exec_call_cc(struct uns_ctr *prevstack,
struct uns_ctr *K, struct uns_ctr *K,
struct uns_ctr *lst, struct uns_ctr *lst,
@ -1352,94 +1447,99 @@ end:
return r; 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, static enum cps_return cps_exec_fcall(struct uns_ctr *prevstack,
struct uns_ctr *K, struct uns_ctr *K,
struct uns_ctr *E, struct uns_ctr *E,
struct uns_ctr *readstack struct uns_ctr *readstack
) )
{ {
/* CAR(E.p) is the symbol */
struct uns_ctr tmp = {0}; struct uns_ctr tmp = {0};
struct uns_ctr expr = {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, &expr);
uns_root_add(gc, &tmp); uns_root_add(gc, &tmp);
uns_root_add(gc, &l);
gensym(&l); tmp.p = E->p;
stack_push(prevstack, &l); if (!fcall_lists(prevstack, &tmp)) {
r = CPS_FCALL_IMPROPER_LIST;
tmp.p = CDR(E->p); goto end;
if (!reverse(&expr, &tmp)) }
return CPS_EXEC_INVALID_APPL_LIST; /* tmp now has simplified combo */
stack_push(prevstack, &expr);
stack_push(prevstack, &empty_list);
expr.p = empty_list.p; expr.p = empty_list.p;
stack_push(&expr, K); stack_push(&expr, K);
stack_push(&expr, &l);
tmp.p = CAR(E->p);
stack_push(&expr, &tmp); stack_push(&expr, &tmp);
stack_push_const(&expr, "A"); /* (__A f l K) */ stack_push_const(&expr, "A"); /* (__A f l K) */
stack_push(prevstack, &expr); stack_push(prevstack, &expr);
stack_push_const(readstack, "cps-list"); stack_push_const(readstack, "cps-list");
end:
uns_root_remove(gc, &expr); uns_root_remove(gc, &expr);
uns_root_remove(gc, &tmp); uns_root_remove(gc, &tmp);
uns_root_remove(gc, &l); return r;
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;
} }
static enum cps_return cps_exec_cell(struct uns_ctr *prevstack, 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: case SYMBOL:
symb = get_string(tmp); symb = get_string(tmp);
if (strcmp(symb, "quote") == 0) { if (strcmp(symb, "quote") == 0) {
tmp->p = CDR(E->p); r = cps_exec_quote(prevstack, K, E, readstack);
r = cps_exec_quote(prevstack, K, tmp, readstack); break;
} else if (strcmp(symb, "quasiquote") == 0) { } else if (strcmp(symb, "quasiquote") == 0) {
tmp->p = CDR(E->p); tmp->p = CDR(E->p);
r = cps_exec_quasiquote(prevstack, K, tmp, readstack); r = cps_exec_quasiquote(prevstack, K, tmp, readstack);
break;
} else if (strcmp(symb, "__lambda") == 0) { } else if (strcmp(symb, "__lambda") == 0) {
tmp->p = CDR(E->p); tmp->p = CDR(E->p);
r = cps_exec_lambda(prevstack, K, tmp, readstack); r = cps_exec_lambda(prevstack, K, tmp, readstack);
break;
} else if (strcmp(symb, "__call/cc") == 0) { } else if (strcmp(symb, "__call/cc") == 0) {
/* {K (call/cc f)} {cps} = {(<- (kappa k (@ f k k)) K)} {} */
tmp->p = CDR(E->p); tmp->p = CDR(E->p);
r = cps_exec_call_cc(prevstack, K, tmp, readstack); r = cps_exec_call_cc(prevstack, K, tmp, readstack);
break;
} else if (strcmp(symb, "__dynamic-wind") == 0) { } else if (strcmp(symb, "__dynamic-wind") == 0) {
tmp->p = CDR(E->p); tmp->p = CDR(E->p);
r = cps_exec_dynamic_wind(prevstack, K, tmp, readstack); r = cps_exec_dynamic_wind(prevstack, K, tmp, readstack);
break;
} else if (strcmp(symb, "unquote") == 0) { } else if (strcmp(symb, "unquote") == 0) {
r = CPS_UNQUOTE_INVALID; r = CPS_UNQUOTE_INVALID;
break;
} else if (strcmp(symb, "unquote-list") == 0) { } else if (strcmp(symb, "unquote-list") == 0) {
r = CPS_UNQUOTE_LIST_INVALID; r = CPS_UNQUOTE_LIST_INVALID;
break;
} else if (strcmp(symb, "if") == 0) { } else if (strcmp(symb, "if") == 0) {
tmp->p = CDR(E->p); tmp->p = CDR(E->p);
r = cps_exec_if(prevstack, K, tmp, readstack); r = cps_exec_if(prevstack, K, tmp, readstack);
} else {
r = cps_exec_fcall(prevstack, K, E, readstack);
}
break; break;
}
/* FALLTHROUGH */
case CELL: case CELL:
r = cps_exec_compound_fcall(prevstack, K, E, readstack); r = cps_exec_fcall(prevstack, K, E, readstack);
} }
return r; return r;
@ -1544,77 +1648,59 @@ end:
return r; return r;
} }
/* {K HEAD '() l} {cps-list} = {(-> HEAD (kappa l K))} {} */ /* {K ((symb . E) . B)} {cps-list} =
static enum cps_return cps_list_final(struct uns_ctr *prevstack, {(kappa symb K) E B} {cps cps-list}
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, static enum cps_return cps_list_cell(struct uns_ctr *prevstack,
struct uns_ctr *K, struct uns_ctr *K,
struct uns_ctr *head, struct uns_ctr *head,
struct uns_ctr *args,
struct uns_ctr *readstack struct uns_ctr *readstack
) )
{ {
struct uns_ctr expr = {0}; 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; 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, &expr);
uns_root_add(gc, &atmp);
gensym(&atmp);
expr.p = CDR(args->p); tmp.p = CDR(head->p); /* B */
stack_push(prevstack, &expr); stack_push(prevstack, &tmp);
cons(&expr, &atmp, head);
stack_push(prevstack, &expr); alist_elem.p = CAR(head->p);
expr.p = CAR(args->p); if (get_type(alist_elem.p) != CELL) {
stack_push(prevstack, &expr); 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; expr.p = empty_list.p;
stack_push(&expr, K); stack_push(&expr, K);
stack_push(&expr, &atmp); stack_push(&expr, &tmp);
stack_push_const(&expr, "K"); stack_push_const(&expr, "K");
stack_push(prevstack, &expr); stack_push(prevstack, &expr);
stack_push_const(readstack, "cps-list"); stack_push_const(readstack, "cps-list");
stack_push_const(readstack, "cps"); 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, &expr);
uns_root_remove(gc, &atmp);
return r; return r;
} }
/* {K HEAD ARGS l} {cps-list} /* {K HEAD} {cps-list}
*/ */
static enum cps_return cps_list(struct uns_ctr *prevstack, static enum cps_return cps_list(struct uns_ctr *prevstack,
struct uns_ctr *readstack 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 K = {0};
struct uns_ctr head = {0}; struct uns_ctr head = {0};
struct uns_ctr args = {0};
struct uns_ctr l = {0};
enum cps_return r = CPS_CONTINUE; enum cps_return r = CPS_CONTINUE;
uns_root_add(gc, &K); uns_root_add(gc, &K);
uns_root_add(gc, &head); uns_root_add(gc, &head);
uns_root_add(gc, &args);
uns_root_add(gc, &l);
if (!stack_pop(prevstack, &K) if (!stack_pop(prevstack, &K)
|| !stack_pop(prevstack, &head) || !stack_pop(prevstack, &head)) {
|| !stack_pop(prevstack, &args)
|| !stack_pop(prevstack, &l)) {
r = CPS_LIST_UNDERFLOW; r = CPS_LIST_UNDERFLOW;
goto end; goto end;
} }
switch (get_type(args.p)) { switch (get_type(head.p)) {
case EMPTY_LIST: case EMPTY_LIST:
r = cps_list_final(prevstack, &K, &head, &l); /* {K '()} {cps-list} = {K} */
stack_push(prevstack, &K);
break; break;
case CELL: case CELL:
stack_push(prevstack, &l); r = cps_list_cell(prevstack, &K, &head, readstack);
r = cps_list_cell(prevstack, &K, &head, &args, readstack);
break; break;
default: default:
r = CPS_LIST_IMPROPER_LIST; r = CPS_LIST_IMPROPER_LIST;
break; break;
} }
end: end:
uns_root_remove(gc, &K); uns_root_remove(gc, &K);
uns_root_remove(gc, &head); 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; return r;
} }
@ -1717,8 +1762,6 @@ static enum cps_return cps(struct uns_ctr *prevstack,
r = cps_exec(prevstack, readstack); r = cps_exec(prevstack, readstack);
} else if (strcmp(cmd, "cps-list") == 0) { } else if (strcmp(cmd, "cps-list") == 0) {
r = cps_list(prevstack, readstack); r = cps_list(prevstack, readstack);
} else if (strcmp(cmd, "cps-app") == 0) {
r = cps_app(prevstack, readstack);
} else { } else {
r = CPS_INVALID_CMD; r = CPS_INVALID_CMD;
} }
@ -1728,104 +1771,6 @@ end:
return r; 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("<undefined>");
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) static void error(struct location *loc, const char *emsg)
{ {
fprintf(stderr, "%ld:%ld: ", loc->line, loc->offset); fprintf(stderr, "%ld:%ld: ", loc->line, loc->offset);
@ -1891,12 +1836,15 @@ int main(void)
printf("}\n"); printf("}\n");
r = cps(&prevstack, &readstack); r = cps(&prevstack, &readstack);
} while (r == CPS_CONTINUE); } while (r == CPS_CONTINUE);
printf("%s\n", cps_return_to_string[r]);
} }
cleanup: cleanup:
uns_root_remove(gc, &expr); uns_root_remove(gc, &expr);
uns_root_remove(gc, &prevstack); uns_root_remove(gc, &prevstack);
uns_root_remove(gc, &readstack); uns_root_remove(gc, &readstack);
uns_root_remove(gc, &empty_list);
uns_collect(gc);
uns_deinit(gc); uns_deinit(gc);
return 0; return 0;
} }