This is let.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.
*/
/*
let.c
*/
#include "include.h"
let_var_list(var_list)
object var_list;
{
object x, y;
for (x = var_list; !endp(x); x = x->c.c_cdr) {
y = x->c.c_car;
if (type_of(y) == t_symbol) {
check_var(y);
vs_push(y);
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
} else {
endp(y);
check_var(y->c.c_car);
vs_push(y->c.c_car);
vs_push(Cnil);
y = y->c.c_cdr;
if (endp(y)) /*
FEerror("No initial form to the variable ~S.",
1, vs_top[-2]) */ ;
else if (!endp(y->c.c_cdr))
FEerror("Too many initial forms to the variable ~S.",
1, vs_top[-2]);
vs_push(y->c.c_car);
vs_push(Cnil);
}
}
}
Flet(form)
object form;
{
object body;
struct bind_temp *start;
object *old_lex;
bds_ptr old_bds_top;
if (endp(form))
FEerror("No argument to LET.", 0);
old_lex = lex_env;
lex_copy();
old_bds_top = bds_top;
start = (struct bind_temp *)vs_top;
let_var_list(form->c.c_car);
body = let_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top);
vs_top = (object *)start;
vs_push(body);
Fprogn(body);
lex_env = old_lex;
bds_unwind(old_bds_top);
}
FletA(form)
object form;
{
object body;
struct bind_temp *start;
object *old_lex;
bds_ptr old_bds_top;
if (endp(form))
FEerror("No argument to LET*.", 0);
old_lex = lex_env;
lex_copy();
old_bds_top = bds_top;
start = (struct bind_temp *)vs_top;
let_var_list(form->c.c_car);
body = letA_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top);
vs_top = (object *)start;
vs_push(body);
Fprogn(body);
lex_env = old_lex;
bds_unwind(old_bds_top);
}
Fmultiple_value_bind(form)
object form;
{
object body, values_form, x, y;
int n, m, i;
object *base;
object *old_lex;
bds_ptr old_bds_top;
struct bind_temp *start;
if (endp(form))
FEerror("No argument to MULTIPLE-VALUE-BIND.", 0);
body = form->c.c_cdr;
if (endp(body))
FEerror("No values-form to MULTIPLE-VALUE-BIND.", 0);
values_form = body->c.c_car;
body = body->c.c_cdr;
old_lex = lex_env;
lex_copy();
old_bds_top = bds_top;
eval(values_form);
base = vs_base;
m = vs_top - vs_base;
start = (struct bind_temp *)vs_top;
for (n = 0, x = form->c.c_car; !endp(x); n++, x = x->c.c_cdr) {
y = x->c.c_car;
check_var(y);
vs_push(y);
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
}
{
object *vt = vs_top;
vs_push(find_special(body, start, (struct bind_temp *)vt));
}
for (i = 0; i < n; i++)
bind_var(start[i].bt_var,
(i < m ? base[i] : Cnil),
start[i].bt_spp);
body = vs_pop;
vs_top = vs_base = base;
vs_push(body);
Fprogn(body);
lex_env = old_lex;
bds_unwind(old_bds_top);
}
Fcompiler_let(form)
object form;
{
object body, x, y;
object *old_lex;
bds_ptr old_bds_top;
struct bind_temp *start, *end, *bt;
if (endp(form))
FEerror("No argument to COMPILER-LET.", 0);
body = form->c.c_cdr;
old_lex = lex_env;
lex_copy();
old_bds_top = bds_top;
start = (struct bind_temp *)vs_top;
let_var_list(form->c.c_car);
end = (struct bind_temp *)vs_top;
for (bt = start; bt < end; bt++) {
eval_assign(bt->bt_init, bt->bt_init);
}
for (bt = start; bt < end; bt++)
bind_var(bt->bt_var, bt->bt_init, Ct);
vs_top = (object *)start;
Fprogn(body);
lex_env = old_lex;
bds_unwind(old_bds_top);
}
Fflet(args)
object args;
{
object def_list;
object def;
object *lex = lex_env;
object *top = vs_top;
vs_push(Cnil); /* space for each closure */
if (endp(args))
FEtoo_few_argumentsF(args);
def_list = MMcar(args);
lex_copy();
while (!endp(def_list)) {
def = MMcar(def_list);
if (endp(def) || endp(MMcdr(def)) ||
type_of(MMcar(def)) != t_symbol)
FEerror("~S~%\
is an illegal function definition in FLET.",
1, def);
top[0] = MMcons(lex[2], def);
top[0] = MMcons(lex[1], top[0]);
top[0] = MMcons(lex[0], top[0]);
top[0] = MMcons(Slambda_block_closure, top[0]);
lex_fun_bind(MMcar(def), top[0]);
def_list = MMcdr(def_list);
}
vs_push(find_special(MMcdr(args), NULL, NULL));
Fprogn(vs_head);
lex_env = lex;
}
Flabels(args)
object args;
{
object def_list;
object def;
object closure_list;
object *lex = lex_env;
object *top = vs_top;
vs_push(Cnil); /* space for each closure */
vs_push(Cnil); /* space for closure-list */
if (endp(args))
FEtoo_few_argumentsF(args);
def_list = MMcar(args);
lex_copy();
while (!endp(def_list)) {
def = MMcar(def_list);
if (endp(def) || endp(MMcdr(def)) ||
type_of(MMcar(def)) != t_symbol)
FEerror("~S~%\
is an illegal function definition in LABELS.",
1, def);
top[0] = MMcons(lex[2], def);
top[0] = MMcons(Cnil, top[0]);
top[1] = MMcons(top[0], top[1]);
top[0] = MMcons(lex[0], top[0]);
top[0] = MMcons(Slambda_block_closure, top[0]);
lex_fun_bind(MMcar(def), top[0]);
def_list = MMcdr(def_list);
}
closure_list = top[1];
while (!endp(closure_list)) {
MMcaar(closure_list) = lex_env[1];
closure_list = MMcdr(closure_list);
}
vs_push(find_special(MMcdr(args), NULL, NULL));
Fprogn(vs_head);
lex_env = lex;
}
Fmacrolet(args)
object args;
{
object def_list;
object def;
object *lex = lex_env;
object *top = vs_top;
vs_push(Cnil); /* space for each macrodef */
if (endp(args))
FEtoo_few_argumentsF(args);
def_list = MMcar(args);
lex_copy();
while (!endp(def_list)) {
def = MMcar(def_list);
if (endp(def) || endp(MMcdr(def)) ||
type_of(MMcar(def)) != t_symbol)
FEerror("~S~%\
is an illegal macro definition in MACROFLET.",
1, def);
top[0] = ifuncall3(siSdefmacroA,
MMcar(def),
MMcadr(def),
MMcddr(def));
lex_macro_bind(MMcar(def), MMcaddr(top[0]));
def_list = MMcdr(def_list);
}
vs_push(find_special(MMcdr(args), NULL, NULL));
Fprogn(vs_head);
lex_env = lex;
}
init_let()
{
make_special_form("LET", Flet);
make_special_form("LET*", FletA);
make_special_form("MULTIPLE-VALUE-BIND", Fmultiple_value_bind);
make_special_form("COMPILER-LET", Fcompiler_let);
make_special_form("FLET",Fflet);
make_special_form("LABELS",Flabels);
make_special_form("MACROLET",Fmacrolet);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.