This is let.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.
*/
/*
let.c
*/
#include "include.h"
let_var_list(var_list)
object var_list;
{
object endp_temp;
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 endp_temp;
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 endp_temp;
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 endp_temp;
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 endp_temp;
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 endp_temp;
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(sLlambda_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 endp_temp;
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(sLlambda_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 endp_temp;
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(sSdefmacroA,
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.