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; } }