uns_lisp: change cps-list transformation to make it respect scope
This commit is contained in:
parent
5343a0ba4d
commit
3c119ee11f
|
|
@ -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("<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} */
|
||||
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;
|
||||
}
|
||||
/* 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("<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)
|
||||
{
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue