cl_object
cl_function_lambda_expression(cl_object fun)
{
cl_env_ptr the_env = ecl_process_env();
cl_object output, name = ECL_NIL, lex = ECL_NIL;
switch(ecl_t_of(fun)) {
case t_bclosure:
lex = fun->bclosure.lex;
fun = fun->bclosure.code;
case t_bytecodes:
name = fun->bytecodes.name;
output = fun->bytecodes.definition;
if (name == ECL_NIL)
output = cl_cons(ECL_SYM("LAMBDA",452), output);
else if (name != ECL_SYM("SI::BYTECODES",1659))
output = cl_listX(3, ECL_SYM("EXT::LAMBDA-BLOCK",1339), name, output);
break;
case t_cfun:
case t_cfunfixed:
name = fun->cfun.name;
lex = ECL_NIL;
output = ECL_NIL;
break;
case t_cclosure:
name = ECL_NIL;
lex = ECL_T;
output = ECL_NIL;
break;
#ifdef CLOS
case t_instance:
if (fun->instance.isgf) {
name = ECL_NIL;
lex = ECL_NIL;
output = ECL_NIL;
break;
}
#endif
default:
FEinvalid_function(fun);
}
ecl_return3(the_env, output, lex, name);
}
cl_object
si_compiled_function_name(cl_object fun)
{
cl_env_ptr the_env = ecl_process_env();
cl_object output;
switch(ecl_t_of(fun)) {
case t_bclosure:
fun = fun->bclosure.code;
case t_bytecodes:
output = fun->bytecodes.name; break;
case t_cfun:
case t_cfunfixed:
output = fun->cfun.name; break;
case t_cclosure:
output = ECL_NIL; break;
default:
FEinvalid_function(fun);
}
ecl_return1(the_env, output);
}
void
funcall(object fun) {
/* object VOL sfirst=NULL; */
/* wipe_stack(&sfirst); */
/* { */
object temporary=OBJNULL;
object x=OBJNULL;
object * VOL top=NULL;
object *lex=NULL;
bds_ptr old_bds_top=NULL;
VOL bool b=0;
bool c=0;
DEBUG_AVMA
TOP:
if (fun == OBJNULL)
FEerror("Undefined function.", 0);
switch (type_of(fun)) {
/* case t_cfun: */
/* MMcall(fun); */
/* CHECK_AVMA; return; */
case t_function:
{int i=Rset;
if (!i) {ihs_check;ihs_push(fun);}
quick_call_function(fun);
if (!i) ihs_pop();
}
return;
case t_symbol:
{
object x = fun->s.s_gfdef;
if (x!=OBJNULL) { fun = x; goto TOP;}
else
FEundefined_function(fun);
}
/* case t_ifun: */
/* { */
/* object x = fun->ifn.ifn_self; */
/* if (x) { fun = x; /\* ihs_check;ihs_push(fun); *\/break;} */
/* else */
/* FEundefined_function(fun); */
/* } */
case t_cons:
if (fun->c.c_car!=sLlambda &&
fun->c.c_car!=sLlambda_closure &&
fun->c.c_car!=sLlambda_block &&
fun->c.c_car!=sSlambda_block_expanded &&
fun->c.c_car!=sLlambda_block_closure)
FEinvalid_function(fun);
break;
default:
FEinvalid_function(fun);
}
/*
This part is the same as that of funcall_no_event.
*/
/* we may have pushed the calling form if this is called invoked from
eval. A lambda call requires vs_push's, so we can tell
if we pushed by vs_base being the same.
*/
{ VOL int not_pushed = 0;
if (vs_base != ihs_top->ihs_base){
ihs_check;
ihs_push(fun);
}
else
not_pushed = 1;
ihs_top->ihs_base = lex_env;
x = MMcar(fun);
top = vs_top;
lex = lex_env;
old_bds_top = bds_top;
/* maybe digest this lambda expression
(lambda-block-expand name ..) has already been
expanded. The value of lambda-block-expand may
be a compiled function in which case we say expand
with it)
*/
if (x == sSlambda_block_expanded) {
b = TRUE;
c = FALSE;
fun = fun->c.c_cdr;
} else if (x == sLlambda_block) {
b = TRUE;
c = FALSE;
if(sSlambda_block_expanded->s.s_dbind!=OBJNULL)
fun = ifuncall1(sSlambda_block_expanded->s.s_dbind,fun);
fun = fun->c.c_cdr;
} else if (x == sLlambda_closure) {
b = FALSE;
c = TRUE;
fun = fun->c.c_cdr;
} else if (x == sLlambda) {
b = c = FALSE;
fun = fun->c.c_cdr;
} else if (x == sLlambda_block_closure) {
b = c = TRUE;
fun = fun->c.c_cdr;
} else
b = c = TRUE;
if (c) {
vs_push(kar(fun));
fun = fun->c.c_cdr;
vs_push(kar(fun));
fun = fun->c.c_cdr;
vs_push(kar(fun));
fun = fun->c.c_cdr;
} else {
*(struct nil3 *)vs_top = three_nils;
vs_top += 3;
}
if (b) {
x = kar(fun); /* block name */
fun = fun->c.c_cdr;
}
lex_env = top;
vs_push(fun);
lambda_bind(top);
ihs_top->ihs_base = lex_env;
if (b) {
fun = temporary = alloc_frame_id();
/* lex_block_bind(x, temporary); */
temporary = MMcons(temporary, Cnil);
temporary = MMcons(sLblock, temporary);
temporary = MMcons(x, temporary);
lex_env[2] = MMcons(temporary, lex_env[2]);
frs_push(FRS_CATCH, fun);
if (nlj_active) {
nlj_active = FALSE;
goto END;
}
}
x = top[3]; /* body */
if(endp(x)) {
vs_base = vs_top;
vs_push(Cnil);
} else {
top = vs_top;
for (;;) {
eval(MMcar(x));
x = MMcdr(x);
if (endp(x))
break;
vs_top = top;
}
}
END:
if (b)
frs_pop();
bds_unwind(old_bds_top);
lex_env = lex;
if (not_pushed == 0) {ihs_pop();}
CHECK_AVMA;
}
}
