static void
FFN(Freturn_from)(object args)
{
object lex_block;
frame_ptr fr;
if (endp(args))
FEtoo_few_argumentsF(args);
if (!endp(MMcdr(args)) && !endp(MMcddr(args)))
FEtoo_many_argumentsF(args);
lex_block = lex_block_sch(MMcar(args));
if (MMnull(lex_block))
FEerror("The block name ~S is undefined.", 1, MMcar(args));
fr = frs_sch(MMcaddr(lex_block));
if(fr == NULL)
FEerror("The block ~S is missing.", 1, MMcar(args));
if(endp(MMcdr(args))) {
vs_base = vs_top;
vs_push(Cnil);
}
else
eval(MMcadr(args));
unwind(fr, MMcaddr(lex_block));
/* never reached */
}
static object verify_big_or_zero(object big)
{ int size;
if(type_of(big)!=t_bignum) FEerror("Not a bignum",0);
size = MP_SIZE(big);
if ( size && (MP_SELF(big))[ABS(size)-1]==0)
FEerror("badly formed",0);
return big;
}
static int
prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type,
cl_object arg_types, cl_object args,
cl_object cc_type, ffi_type ***output_copy)
{
int n, ok;
ffi_type **types;
enum ecl_ffi_tag type = ecl_foreign_type_code(return_type);
if (!the_env->ffi_args_limit)
resize_call_stack(the_env, 32);
the_env->ffi_types[0] = ecl_type_to_libffi_type[type];
for (n=0; !Null(arg_types); ) {
if (!LISTP(arg_types)) {
FEerror("In CALL-CFUN, types lists is not a proper list", 0);
}
if (n >= the_env->ffi_args_limit) {
resize_call_stack(the_env, n + 32);
}
type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types));
arg_types = ECL_CONS_CDR(arg_types);
the_env->ffi_types[++n] = ecl_type_to_libffi_type[type];
if (CONSP(args)) {
cl_object object = ECL_CONS_CAR(args);
args = ECL_CONS_CDR(args);
if (type == ECL_FFI_CSTRING) {
object = ecl_null_terminated_base_string(CAR(args));
if (ECL_CONS_CAR(args) != object) {
ECL_STACK_PUSH(the_env, object);
}
}
ecl_foreign_data_set_elt(the_env->ffi_values + n, type, object);
}
}
if (output_copy) {
cl_index bytes = (n + 1) * sizeof(ffi_type*);
*output_copy = types = (ffi_type**)ecl_alloc_atomic(bytes);
memcpy(types, the_env->ffi_types, bytes);
} else {
types = the_env->ffi_types;
}
ok = ffi_prep_cif(cif, ecl_foreign_cc_code(cc_type), n, types[0], types + 1);
if (ok != FFI_OK) {
if (ok == FFI_BAD_ABI) {
FEerror("In CALL-CFUN, not a valid ABI: ~A", 1,
cc_type);
}
if (ok == FFI_BAD_TYPEDEF) {
FEerror("In CALL-CFUN, wrong or malformed argument types", 0);
}
}
return n;
}
cl_object
si_foreign_data_set(cl_object f, cl_object andx, cl_object value)
{
cl_index ndx = ecl_to_size(andx);
cl_index size, limit;
if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-SET*/1353), 1, f,
ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
}
if (ecl_unlikely(ecl_t_of(value) != t_foreign)) {
FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-SET*/1353), 3, value,
ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
}
size = value->foreign.size;
limit = f->foreign.size;
if (ecl_unlikely(ndx >= limit || (limit - ndx) < size)) {
FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
}
memcpy(f->foreign.data + ndx, value->foreign.data, size);
{
#line 397
const cl_env_ptr the_env = ecl_process_env();
#line 397
#line 397
cl_object __value0 = value;
#line 397
the_env->nvalues = 1;
#line 397
return __value0;
#line 397
}
}
cl_object
si_foreign_data_ref(cl_object f, cl_object andx, cl_object asize, cl_object tag)
{
cl_index ndx = ecl_to_size(andx);
cl_index size = ecl_to_size(asize);
cl_object output;
if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-REF*/1351), 1, f,
ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
}
if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) {
FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
}
output = ecl_allocate_foreign_data(tag, size);
memcpy(output->foreign.data, f->foreign.data + ndx, size);
{
#line 374
const cl_env_ptr the_env = ecl_process_env();
#line 374
#line 374
cl_object __value0 = output;
#line 374
the_env->nvalues = 1;
#line 374
return __value0;
#line 374
}
}
cl_object
si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize,
cl_object tag)
{
cl_index ndx = ecl_to_size(andx);
cl_index size = ecl_to_size(asize);
cl_object output;
if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
FEwrong_type_only_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-POINTER*/1349), f,
ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
}
if (ecl_unlikely(ndx >= f->foreign.size || (f->foreign.size - ndx) < size)) {
FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
}
output = ecl_alloc_object(t_foreign);
output->foreign.tag = tag;
output->foreign.size = size;
output->foreign.data = f->foreign.data + ndx;
{
#line 355
const cl_env_ptr the_env = ecl_process_env();
#line 355
#line 355
cl_object __value0 = output;
#line 355
the_env->nvalues = 1;
#line 355
return __value0;
#line 355
}
}
cl_object
si_make_foreign_data_from_array(cl_object array)
{
cl_object tag;
if (ecl_unlikely(ecl_t_of(array) != t_array && ecl_t_of(array) != t_vector)) {
FEwrong_type_only_arg(ecl_make_fixnum(/*SI::MAKE-FOREIGN-DATA-FROM-ARRAY*/1358), array,
ecl_make_fixnum(/*ARRAY*/96));
}
tag = ecl_aet_to_ffi_table[array->array.elttype];
if (ecl_unlikely(Null(tag))) {
FEerror("Cannot make foreign object from array "
"with element type ~S.", 1,
ecl_elttype_to_symbol(array->array.elttype));
}
{
#line 293
const cl_env_ptr the_env = ecl_process_env();
#line 293
#line 293
cl_object __value0 = ecl_make_foreign_data(tag, 0, array->array.self.bc);
#line 293
the_env->nvalues = 1;
#line 293
return __value0;
#line 293
}
;
}
cl_object
si_compiled_function_block(cl_object fun)
{
cl_object output;
switch(ecl_t_of(fun)) {
case t_cfun:
output = fun->cfun.block; break;
case t_cfunfixed:
output = fun->cfunfixed.block; break;
case t_cclosure:
output = fun->cclosure.block; break;
default:
FEerror("~S is not a C compiled function.", 1, fun);
}
{
#line 182
const cl_env_ptr the_env = ecl_process_env();
#line 182
#line 182
cl_object __value0 = output;
#line 182
the_env->nvalues = 1;
#line 182
return __value0;
#line 182
}
}
void
ecl_set_function_source_file_info(cl_object b, cl_object source, cl_object position)
{
BEGIN:
switch (ecl_t_of(b)) {
case t_bclosure:
b = b->bclosure.code;
goto BEGIN;
case t_bytecodes:
b->bytecodes.file = source;
b->bytecodes.file_position = position;
break;
case t_cfun:
b->cfun.file = source;
b->cfun.file_position = position;
break;
case t_cfunfixed:
b->cfunfixed.file = source;
b->cfunfixed.file_position = position;
break;
case t_cclosure:
b->cclosure.file = source;
b->cclosure.file_position = position;
break;
default:
FEerror("~S is not a compiled function.", 1, b);
}
}
cl_object
si_foreign_data_set_elt(cl_object f, cl_object andx, cl_object type, cl_object value)
{
cl_index ndx = ecl_to_size(andx);
cl_index limit = f->foreign.size;
enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
if (ecl_unlikely(ndx >= limit ||
ndx + ecl_foreign_type_table[tag].size > limit)) {
FEerror("Out of bounds reference into foreign data type ~A.", 1, f);
}
if (ecl_unlikely(ecl_t_of(f) != t_foreign)) {
FEwrong_type_nth_arg(ecl_make_fixnum(/*SI::FOREIGN-DATA-SET-ELT*/1354), 1, f,
ecl_make_fixnum(/*SI::FOREIGN-DATA*/1345));
}
ecl_foreign_data_set_elt((void*)(f->foreign.data + ndx), tag, value);
{
#line 655
const cl_env_ptr the_env = ecl_process_env();
#line 655
#line 655
cl_object __value0 = value;
#line 655
the_env->nvalues = 1;
#line 655
return __value0;
#line 655
}
}
static void
FEunknown_rwlock_error(cl_object lock, int rc)
{
#ifdef ECL_WINDOWS_THREADS
FEwin32_error("When acting on rwlock ~A, got an unexpected error.", 1, lock);
#else
const char *msg = NULL;
switch (rc) {
case EINVAL:
msg = "The value specified by rwlock is invalid";
break;
case EPERM:
msg = "Read/write lock not owned by us";
break;
case EDEADLK:
msg = "Thread already owns this lock";
break;
case ENOMEM:
msg = "Out of memory";
break;
default:
FElibc_error("When acting on rwlock ~A, got an unexpected error.",
1, lock);
}
FEerror("When acting on rwlock ~A, got the following C library error:~%"
"~A", 2, lock, make_constant_base_string(msg));
#endif
}
void
init_gmp_rnd_state(__gmp_randstate_struct *x) {
static int n;
bzero(x,sizeof(*x));
#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2)
/* if (!trap_size) { */
old_gcl_gmp_allocfun=gcl_gmp_allocfun;
gcl_gmp_allocfun=trap_gcl_gmp_allocfun;
/* } */
#endif
gmp_randinit_default(x);
#if __GNU_MP_VERSION > 4 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR >= 2)
if (!n) {
if (x->_mp_seed->_mp_d!=trap_result)
FEerror("Unknown pointer in rnd_state!",0);
/* #ifndef __hppa__ /\*FIXME*\/ */
/* if (((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->b!=Mersenne_Twister_Generator_Noseed.b || */
/* ((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->c!=Mersenne_Twister_Generator_Noseed.c || */
/* ((gmp_randfnptr_t *)x->_mp_algdata._mp_lc)->d!=Mersenne_Twister_Generator_Noseed.d) */
/* FEerror("Unknown pointer data in rnd_state!",0); */
/* #endif */
n=1;
}
gcl_gmp_allocfun=old_gcl_gmp_allocfun;
x->_mp_seed->_mp_alloc=x->_mp_seed->_mp_size=trap_size;
#endif
}
static void
frs_set_size(cl_env_ptr env, cl_index size)
{
ecl_frame_ptr old_org = env->frs_org;
cl_index limit = env->frs_top - old_org;
if (size <= limit) {
FEerror("Cannot shrink frame stack below ~D.", 1,
ecl_make_unsigned_integer(limit));
} else {
cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
ecl_frame_ptr org;
size += 2*margin;
org = ecl_alloc_atomic(size * sizeof(*org));
ecl_disable_interrupts_env(env);
memcpy(org, old_org, (limit + 1) * sizeof(*org));
env->frs_top = org + limit;
env->frs_org = org;
env->frs_limit = org + (size - 2*margin);
env->frs_size = size;
ecl_enable_interrupts_env(env);
ecl_dealloc(old_org);
}
}
static void
FFN(siLAmake_special)(void)
{
check_arg(1);
check_type_symbol(&vs_base[0]);
if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
FEerror("~S is a constant.", 1, vs_base[0]);
vs_base[0]->s.s_stype = (short)stp_special;
}
enum ecl_ffi_tag
ecl_foreign_type_code(cl_object type)
{
int i = foreign_type_code(type);
if (ecl_unlikely(i < 0)) {
FEerror("~A does not denote an elementary foreign type.", 1, type);
}
return (enum ecl_ffi_tag)i;
}
cl_object
si_load_foreign_module(cl_object filename)
{
#if !defined(ENABLE_DLOPEN)
FEerror("SI:LOAD-FOREIGN-MODULE does not work when ECL is statically linked", 0);
#else
cl_object output;
# ifdef ECL_THREADS
mp_get_lock(1, ecl_symbol_value(ECL_SYM("MP::+LOAD-COMPILE-LOCK+",1426)));
ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) {
# endif
output = ecl_library_open(filename, 0);
if (output->cblock.handle == NULL) {
cl_object aux = ecl_library_error(output);
ecl_library_close(output);
output = aux;
}
# ifdef ECL_THREADS
(void)0; /* MSVC complains about missing ';' before '}' */
} ECL_UNWIND_PROTECT_EXIT {
mp_giveup_lock(ecl_symbol_value(ECL_SYM("MP::+LOAD-COMPILE-LOCK+",1426)));
} ECL_UNWIND_PROTECT_END;
# endif
if (ecl_unlikely(ecl_t_of(output) != t_codeblock)) {
FEerror("LOAD-FOREIGN-MODULE: Could not load "
"foreign module ~S (Error: ~S)", 2, filename, output);
}
output->cblock.locked |= 1;
{
#line 727
const cl_env_ptr the_env = ecl_process_env();
#line 727
#line 727
cl_object __value0 = output;
#line 727
the_env->nvalues = 1;
#line 727
return __value0;
#line 727
}
#endif
}
enum ecl_ffi_calling_convention
ecl_foreign_cc_code(cl_object cc)
{
int i;
for (i = 0; i <= ECL_FFI_CC_STDCALL; i++) {
if (cc == ecl_foreign_cc_table[i])
return (enum ecl_ffi_calling_convention)i;
}
FEerror("~A does no denote a valid calling convention.", 1, cc);
return ECL_FFI_CC_CDECL;
}
static ecl_ihs_ptr
get_ihs_ptr(cl_index n)
{
cl_env_ptr env = ecl_process_env();
ecl_ihs_ptr p = env->ihs_top;
if (n > p->index)
FEerror("~D is an illegal IHS index.", 1, ecl_make_fixnum(n));
while (n < p->index)
p = p->next;
return p;
}
static ecl_frame_ptr
get_frame_ptr(cl_object x)
{
if (ECL_FIXNUMP(x)) {
cl_env_ptr env = ecl_process_env();
ecl_frame_ptr p = env->frs_org + ecl_fixnum(x);
if (env->frs_org <= p && p <= env->frs_top)
return p;
}
FEerror("~S is an illegal frs index.", 1, x);
}
cl_object
si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size)
{
#if !defined(ENABLE_DLOPEN)
FEerror("SI:FIND-FOREIGN-SYMBOL does not work when ECL is statically linked", 0);
#else
cl_object block;
cl_object output = ECL_NIL;
void *sym;
block = (module == ECL_SYM(":DEFAULT",1215) ? module : si_load_foreign_module(module));
var = ecl_null_terminated_base_string(var);
sym = ecl_library_symbol(block, (char*)var->base_string.self, 1);
if (sym == NULL) {
if (block != ECL_SYM(":DEFAULT",1215))
output = ecl_library_error(block);
goto OUTPUT;
}
output = ecl_make_foreign_data(type, ecl_to_fixnum(size), sym);
OUTPUT:
if (ecl_unlikely(ecl_t_of(output) != t_foreign))
FEerror("FIND-FOREIGN-SYMBOL: Could not load "
"foreign symbol ~S from module ~S (Error: ~S)",
3, var, module, output);
{
#line 755
const cl_env_ptr the_env = ecl_process_env();
#line 755
#line 755
cl_object __value0 = output;
#line 755
the_env->nvalues = 1;
#line 755
return __value0;
#line 755
}
#endif
}
char *
ecl_base_string_pointer_safe(cl_object f)
{
unsigned char *s;
/* FIXME! Is there a better function name? */
f = ecl_check_cl_type(ECL_SYM("SI::MAKE-FOREIGN-DATA-FROM-ARRAY",1358), f, t_base_string);
s = f->base_string.self;
if (ecl_unlikely(ECL_ARRAY_HAS_FILL_POINTER_P(f) &&
s[f->base_string.fillp] != 0)) {
FEerror("Cannot coerce a string with fill pointer to (char *)", 0);
}
return (char *)s;
}
static object
rando(object x, object rs) {
enum type tx;
object base,out,z;
fixnum fbase;
double d;
tx = type_of(x);
if (number_compare(x, small_fixnum(0)) != 1)
FEwrong_type_argument(TSpositive_number, x);
if (tx==t_bignum) {
out=new_bignum();
base=x;
fbase=-1;
} else {
out=big_fixnum1;
fbase=tx==t_fixnum ? fix(x) : MOST_POSITIVE_FIX;
mpz_set_si(MP(big_fixnum2),fbase);
base=big_fixnum2;
}
mpz_urandomm(MP(out),&rs->rnd.rnd_state,MP(base));
switch (tx) {
case t_fixnum:
return make_fixnum(mpz_get_si(MP(out)));
case t_bignum:
return normalize_big(out);
case t_shortfloat: case t_longfloat:
d=mpz_get_d(MP(out));
d/=(double)fbase;
z=alloc_object(tx);
if (tx==t_shortfloat) sf(z)=sf(x)*d; else lf(z)=lf(x)*d;
return z;
default:
FEerror("~S is not an integer nor a floating-point number.", 1, x);
return(Cnil);
}
}
cl_object
ecl_make_rwlock(cl_object name)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object output = ecl_alloc_object(t_rwlock);
#ifdef ECL_RWLOCK
int rc;
ecl_disable_interrupts_env(the_env);
rc = pthread_rwlock_init(&output->rwlock.mutex, NULL);
ecl_enable_interrupts_env(the_env);
if (rc) {
FEerror("Unable to create read/write lock", 0);
}
ecl_set_finalizer_unprotected(output, ECL_T);
#else
output->rwlock.mutex = ecl_make_lock(name, 0);
#endif
output->rwlock.name = name;
return output;
}
static void
setup_test(struct cl_test *t, cl_object item, cl_object test,
cl_object test_not, cl_object key)
{
cl_env_ptr env = t->env = ecl_process_env();
t->item_compared = item;
if (test != ECL_NIL) {
if (test_not != ECL_NIL)
FEerror("Both :TEST and :TEST-NOT are specified.", 0);
t->test_function = test = si_coerce_to_function(test);
if (test == ECL_SYM_FUN(ECL_SYM("EQ",333))) {
t->test_c_function = test_eq;
} else if (test == ECL_SYM_FUN(ECL_SYM("EQL",334))) {
t->test_c_function = test_eql;
} else if (test == ECL_SYM_FUN(ECL_SYM("EQUAL",335))) {
t->test_c_function = test_equal;
} else if (test == ECL_SYM_FUN(ECL_SYM("EQUALP",336))) {
t->test_c_function = test_equalp;
} else {
t->test_c_function = test_compare;
t->test_fn = ecl_function_dispatch(env, test);
t->test_function = env->function;
}
} else if (test_not != ECL_NIL) {
t->test_c_function = test_compare_not;
test_not = si_coerce_to_function(test_not);
t->test_fn = ecl_function_dispatch(env, test_not);
t->test_function = env->function;
} else {
t->test_c_function = test_eql;
}
if (key != ECL_NIL) {
key = si_coerce_to_function(key);
t->key_fn = ecl_function_dispatch(env, key);
t->key_function = env->function;
t->key_c_function = key_function;
} else {
t->key_c_function = key_identity;
}
}
cl_object
si_Xmake_special(cl_object sym)
{
int type = ecl_symbol_type(sym);
if (type & ecl_stp_constant)
FEerror("~S is a constant.", 1, sym);
ecl_symbol_type_set(sym, type | ecl_stp_special);
cl_remprop(sym, ECL_SYM("SI::SYMBOL-MACRO",1159));
{
#line 455
const cl_env_ptr the_env = ecl_process_env();
#line 455
#line 455
cl_object __value0 = sym;
#line 455
the_env->nvalues = 1;
#line 455
return __value0;
#line 455
}
}
cl_index
ecl_progv(cl_env_ptr env, cl_object vars0, cl_object values0)
{
cl_object vars = vars0, values = values0;
cl_index n = env->bds_top - env->bds_org;
for (; LISTP(vars) && LISTP(values); vars = ECL_CONS_CDR(vars)) {
if (Null(vars)) {
return n;
} else {
cl_object var = ECL_CONS_CAR(vars);
if (Null(values)) {
ecl_bds_bind(env, var, OBJNULL);
} else {
ecl_bds_bind(env, var, ECL_CONS_CAR(values));
values = ECL_CONS_CDR(values);
}
}
}
FEerror("Wrong arguments to special form PROGV. Either~%"
"~A~%or~%~A~%are not proper lists",
2, vars0, values0);
}
cl_object
si_Xmake_constant(cl_object sym, cl_object val)
{
int type = ecl_symbol_type(sym);
if (type & ecl_stp_special)
FEerror("The argument ~S to DEFCONSTANT is a special variable.",
1, sym);
ecl_symbol_type_set(sym, type | ecl_stp_constant);
ECL_SET(sym, val);
{
#line 467
const cl_env_ptr the_env = ecl_process_env();
#line 467
#line 467
cl_object __value0 = sym;
#line 467
the_env->nvalues = 1;
#line 467
return __value0;
#line 467
}
}
static void
ecl_fficall_overflow()
{
FEerror("Stack overflow on SI:CALL-CFUN", 0);
}
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;
}
}
static void
FFN(Fdefun)(object args)
{
object name,oname;
object body, form;
if (endp(args) || endp(MMcdr(args)))
FEtoo_few_argumentsF(args);
if (MMcadr(args) != Cnil && !consp(MMcadr(args)))
FEerror("~S is an illegal lambda-list.", 1, MMcadr(args));
oname=name = MMcar(args);
if (type_of(name) != t_symbol)
name=ifuncall1(sSfunid_to_sym,name);
if (name->s.s_sfdef != NOT_SPECIAL) {
if (name->s.s_mflag) {
if (symbol_value(sSAinhibit_macro_specialA) != Cnil)
name->s.s_sfdef = NOT_SPECIAL;
} else if (symbol_value(sSAinhibit_macro_specialA) != Cnil)
FEerror("~S, a special form, cannot be redefined.", 1, name);
}
if (name->s.s_hpack == lisp_package &&
name->s.s_gfdef != OBJNULL && !raw_image && sLwarn->s.s_gfdef) {
vs_push(make_simple_string("~S is being redefined."));
ifuncall2(sLwarn, vs_head, name);
vs_popp;
}
vs_base = vs_top;
if (lex_env[0] == Cnil && lex_env[1] == Cnil && lex_env[2] == Cnil) {
vs_push(MMcons(sLlambda_block, args));
} else {
vs_push(MMcons(lex_env[2], args));
vs_base[0] = MMcons(lex_env[1], vs_base[0]);
vs_base[0] = MMcons(lex_env[0], vs_base[0]);
vs_base[0] = MMcons(sLlambda_block_closure, vs_base[0]);
}
{/* object fname; */
vs_base[0]=fSfset_in(name,vs_base[0]);
/* object x=alloc_object(t_ifun); */
/* x->ifn.ifn_self=vs_base[0]; */
/* x->ifn.ifn_name=name; */
/* x->ifn.ifn_call=Cnil; */
/* vs_base[0]=x; */
/* fname = clear_compiler_properties(name,vs_base[0]); */
/* fname->s.s_gfdef = vs_base[0]; */
/* fname->s.s_mflag = FALSE; */
}
vs_base[0] = oname;
for (body = MMcddr(args); !endp(body); body = body->c.c_cdr) {
form = macro_expand(body->c.c_car);
if (type_of(form) == t_string) {
if (endp(body->c.c_cdr))
break;
vs_push(form);
name->s.s_plist =
putf(name->s.s_plist,
form,
sSfunction_documentation);
vs_popp;
break;
}
if (!consp(form) || form->c.c_car != sLdeclare)
break;
}
}
