This is iteration.c in view mode; [Download] [Up]
/*
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
This file is part of GNU Common Lisp, herein referred to as GCL
GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GCL is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
License for more details.
You should have received a copy of the GNU Library General Public License
along with GCL; see the file COPYING. If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/*
iteration.c
*/
#include "include.h"
Floop(form)
object form;
{
object endp_temp;
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 endp_temp;
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 endp_temp;
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 endp_temp;
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 endp_temp;
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 endp_temp;
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(sLinteger, 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.