This is iteration.c in view mode; [Download] [Up]
/*
(c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
Copying of this file is authorized to users who have executed the true and
proper "License Agreement for Kyoto Common LISP" with SIGLISP.
*/
/*
iteration.c
*/
#include "include.h"
Floop(form)
object form;
{
object x;
object *oldlex = lex_env;
object id;
object *top;
make_nil_block();
if (nlj_active) {
nlj_active = FALSE;
frs_pop();
lex_env = oldlex;
return;
}
top = vs_top;
for(x = form; !endp(x); x = MMcdr(x)) {
vs_top = top;
eval(MMcar(x));
}
LOOP:
/* Just !endp(x) is replaced by x != Cnil. */
for(x = form; x != Cnil; x = MMcdr(x)) {
vs_top = top;
eval(MMcar(x));
}
goto LOOP;
}
/*
use of VS in Fdo and FdoA:
| |
lex_env -> | lex1 |
| lex2 |
| lex3 |
start -> |-------| where each bt is a bind_temp:
| bt1 |
|-------| | var | -- name of DO variable
: | spp | -- T if special
|-------| | init |
| btn | | aux | -- step-form or var (if no
|-------| step-form is given)
end -> | body |
old_top-> |-------| If 'spp' != T, it is NIL during
initialization, and is the pointer to
(var value) in lexical environment
during the main loop.
*/
do_var_list(var_list)
object var_list;
{
object is, x, y;
for (is = var_list; !endp(is); is = MMcdr(is)) {
x = MMcar(is);
if (type_of(x)==t_symbol)
{vs_push(x);vs_push(Cnil);vs_push(Cnil);vs_push(x);
continue;}
if (type_of(x) != t_cons)
FEinvalid_form("The index, ~S, is illegal.", x);
y = MMcar(x);
check_var(y);
vs_push(y);
vs_push(Cnil);
if (endp(MMcdr(x))) {
vs_push(Cnil);
vs_push(y);
} else {
x = MMcdr(x);
vs_push(MMcar(x));
if (endp(MMcdr(x)))
vs_push(y);
else {
x = MMcdr(x);
vs_push(MMcar(x));
if (!endp(MMcdr(x)))
FEerror("Too many forms to the index ~S.",
1, y);
}
}
}
}
Fdo(arg)
object arg;
{
object *oldlex = lex_env;
object *old_top;
struct bind_temp *start, *end, *bt;
object end_test, body;
VOL object result;
bds_ptr old_bds_top = bds_top;
if (endp(arg) || endp(MMcdr(arg)))
FEtoo_few_argumentsF(arg);
if (endp(MMcadr(arg)))
FEinvalid_form("The DO end-test, ~S, is illegal.",
MMcadr(arg));
end_test = MMcaadr(arg);
result = MMcdadr(arg);
make_nil_block();
if (nlj_active) {
nlj_active = FALSE;
goto END;
}
start = (struct bind_temp *) vs_top;
do_var_list(MMcar(arg));
end = (struct bind_temp *)vs_top;
body = let_bind(MMcddr(arg), start, end);
vs_push(body);
for (bt = start; bt < end; bt++)
if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
bt->bt_spp = Ct;
else if (bt->bt_spp == Cnil)
bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
old_top = vs_top;
LOOP: /* the main loop */
vs_top = old_top;
eval(end_test);
if (vs_base[0] != Cnil) {
/* RESULT evaluation */
if (endp(result)) {
vs_base = vs_top = old_top;
vs_push(Cnil);
} else
do {
vs_top = old_top;
eval(MMcar(result));
result = MMcdr(result);
} while (!endp(result));
goto END;
}
vs_top = old_top;
Ftagbody(body);
/* next step */
for (bt = start; bt<end; bt++) {
if (bt->bt_aux != bt->bt_var) {
eval_assign(bt->bt_init, bt->bt_aux);
}
}
for (bt = start; bt<end; bt++) {
if (bt->bt_aux != bt->bt_var)
if (bt->bt_spp == Ct)
bt->bt_var->s.s_dbind = bt->bt_init;
else
MMcadr(bt->bt_spp) = bt->bt_init;
}
goto LOOP;
END:
bds_unwind(old_bds_top);
frs_pop();
lex_env = oldlex;
}
FdoA(arg)
object arg;
{
object *oldlex = lex_env;
object *old_top;
struct bind_temp *start, *end, *bt;
object end_test, body;
VOL object result;
bds_ptr old_bds_top = bds_top;
if (endp(arg) || endp(MMcdr(arg)))
FEtoo_few_argumentsF(arg);
if (endp(MMcadr(arg)))
FEinvalid_form("The DO* end-test, ~S, is illegal.",
MMcadr(arg));
end_test = MMcaadr(arg);
result = MMcdadr(arg);
make_nil_block();
if (nlj_active) {
nlj_active = FALSE;
goto END;
}
start = (struct bind_temp *)vs_top;
do_var_list(MMcar(arg));
end = (struct bind_temp *)vs_top;
body = letA_bind(MMcddr(arg), start, end);
vs_push(body);
for (bt = start; bt < end; bt++)
if ((enum stype)bt->bt_var->s.s_stype != stp_ordinary)
bt->bt_spp = Ct;
else if (bt->bt_spp == Cnil)
bt->bt_spp = assoc_eq(bt->bt_var, lex_env[0]);
old_top = vs_top;
LOOP: /* the main loop */
eval(end_test);
if (vs_base[0] != Cnil) {
/* RESULT evaluation */
if (endp(result)) {
vs_base = vs_top = old_top;
vs_push(Cnil);
} else
do {
vs_top = old_top;
eval(MMcar(result));
result = MMcdr(result);
} while (!endp(result));
goto END;
}
vs_top = old_top;
Ftagbody(body);
/* next step */
for (bt = start; bt < end; bt++)
if (bt->bt_aux != bt->bt_var) {
if (bt->bt_spp == Ct) {
eval_assign(bt->bt_var->s.s_dbind, bt->bt_aux);
} else {
eval_assign(MMcadr(bt->bt_spp), bt->bt_aux);
}
}
goto LOOP;
END:
bds_unwind(old_bds_top);
frs_pop();
lex_env = oldlex;
}
Fdolist(arg)
object arg;
{
object *oldlex = lex_env;
object *old_top;
struct bind_temp *start;
object x, listform, body;
VOL object result;
bds_ptr old_bds_top = bds_top;
if (endp(arg))
FEtoo_few_argumentsF(arg);
x = MMcar(arg);
if (endp(x))
FEerror("No variable.", 0);
start = (struct bind_temp *)vs_top;
vs_push(MMcar(x));
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
x = MMcdr(x);
if (endp(x))
FEerror("No listform.", 0);
listform = MMcar(x);
x = MMcdr(x);
if (endp(x))
result = Cnil;
else {
result = MMcar(x);
if (!endp(MMcdr(x)))
FEerror("Too many resultforms.", 0);
}
make_nil_block();
if (nlj_active) {
nlj_active = FALSE;
goto END;
}
eval_assign(start->bt_init, listform);
body = find_special(MMcdr(arg), start, start+1);
vs_push(body);
bind_var(start->bt_var, Cnil, start->bt_spp);
if ((enum stype)start->bt_var->s.s_stype != stp_ordinary)
start->bt_spp = Ct;
else if (start->bt_spp == Cnil)
start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
old_top = vs_top;
LOOP: /* the main loop */
if (endp(start->bt_init)) {
if (start->bt_spp == Ct)
start->bt_var->s.s_dbind = Cnil;
else
MMcadr(start->bt_spp) = Cnil;
eval(result);
goto END;
}
if (start->bt_spp == Ct)
start->bt_var->s.s_dbind = MMcar(start->bt_init);
else
MMcadr(start->bt_spp) = MMcar(start->bt_init);
start->bt_init = MMcdr(start->bt_init);
vs_top = old_top;
Ftagbody(body);
goto LOOP;
END:
bds_unwind(old_bds_top);
frs_pop();
lex_env = oldlex;
}
Fdotimes(arg)
object arg;
{
object *oldlex = lex_env;
object *old_top;
struct bind_temp *start;
object x, countform, body;
VOL object result;
bds_ptr old_bds_top = bds_top;
if (endp(arg))
FEtoo_few_argumentsF(arg);
x = MMcar(arg);
if (endp(x))
FEerror("No variable.", 0);
start = (struct bind_temp *)vs_top;
vs_push(MMcar(x));
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
x = MMcdr(x);
if (endp(x))
FEerror("No countform.", 0);
countform = MMcar(x);
x = MMcdr(x);
if (endp(x))
result = Cnil;
else {
result = MMcar(x);
if (!endp(MMcdr(x)))
FEerror("Too many resultforms.", 0);
}
make_nil_block();
if (nlj_active) {
nlj_active = FALSE;
goto END;
}
eval_assign(start->bt_init, countform);
if (type_of(start->bt_init) != t_fixnum &&
type_of(start->bt_init) != t_bignum)
FEwrong_type_argument(Sinteger, start->bt_init);
body = find_special(MMcdr(arg), start, start+1);
vs_push(body);
bind_var(start->bt_var, make_fixnum(0), start->bt_spp);
if ((enum stype)start->bt_var->s.s_stype != stp_ordinary) {
start->bt_spp = Ct;
x = start->bt_var->s.s_dbind;
} else if (start->bt_spp == Cnil) {
start->bt_spp = assoc_eq(start->bt_var, lex_env[0]);
x = MMcadr(start->bt_spp);
} else
x = start->bt_var->s.s_dbind;
old_top = vs_top;
LOOP: /* the main loop */
if (number_compare(x, start->bt_init) >= 0) {
eval(result);
goto END;
}
vs_top = old_top;
Ftagbody(body);
if (start->bt_spp == Ct)
x = start->bt_var->s.s_dbind = one_plus(x);
else
x = MMcadr(start->bt_spp) = one_plus(x);
goto LOOP;
END:
bds_unwind(old_bds_top);
frs_pop();
lex_env = oldlex;
}
init_iteration()
{
make_special_form("LOOP", Floop);
make_special_form("DO", Fdo);
make_special_form("DO*", FdoA);
make_special_form("DOLIST", Fdolist);
make_special_form("DOTIMES", Fdotimes);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.