void
ecl_cs_overflow(void)
{
static const char *stack_overflow_msg =
"\n;;;\n;;; Stack overflow.\n"
";;; Jumping to the outermost toplevel prompt\n"
";;;\n\n";
cl_env_ptr env = ecl_process_env();
cl_index safety_area = ecl_option_values[ECL_OPT_C_STACK_SAFETY_AREA];
cl_index size = env->cs_size;
#ifdef ECL_DOWN_STACK
if (env->cs_limit > env->cs_org - size)
env->cs_limit -= safety_area;
#else
if (env->cs_limit < env->cs_org + size)
env->cs_limit += safety_area;
#endif
else
ecl_unrecoverable_error(env, stack_overflow_msg);
cl_cerror(6, make_constant_base_string("Extend stack size"),
ECL_SYM("EXT::STACK-OVERFLOW",1665), ECL_SYM(":SIZE",1308), ecl_make_fixnum(size),
ECL_SYM(":TYPE",1318), ECL_SYM("EXT::C-STACK",1671));
size += size / 2;
cs_set_size(env, size);
}
cl_object
si_get_limit(cl_object type)
{
cl_env_ptr env = ecl_process_env();
cl_index output;
if (type == ECL_SYM("EXT::FRAME-STACK",1669)) {
output = env->frs_size;
} else if (type == ECL_SYM("EXT::BINDING-STACK",1668)) {
output = env->bds_size;
} else if (type == ECL_SYM("EXT::C-STACK",1671)) {
output = env->cs_size;
} else if (type == ECL_SYM("EXT::LISP-STACK",1670)) {
output = env->stack_size;
} else {
output = cl_core.max_heap_size;
}
{
#line 633
const cl_env_ptr the_env = ecl_process_env();
#line 633
#line 633
cl_object __value0 = ecl_make_unsigned_integer(output);
#line 633
the_env->nvalues = 1;
#line 633
return __value0;
#line 633
}
}
void
FEtype_error_proper_list(cl_object x) {
cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("Not a proper list ~D"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
ECL_SYM(":EXPECTED-TYPE",1232), ecl_read_from_cstring("si::proper-list"),
ECL_SYM(":DATUM",1214), x);
}
cl_object si::make-dynamic-callback(cl_narg narg, ...)
{
#line 848
// ------------------------------2
#line 848
const cl_env_ptr the_env = ecl_process_env();
#line 848
cl_object cctype;
#line 848
va_list ARGS;
va_start(ARGS, narg);
cl_object fun = va_arg(ARGS,cl_object);
cl_object sym = va_arg(ARGS,cl_object);
cl_object rtype = va_arg(ARGS,cl_object);
cl_object argtypes = va_arg(ARGS,cl_object);
#line 848
// ------------------------------3
cl_object data;
cl_object cbk;
#line 852
// ------------------------------4
#line 852
#line 852
if (ecl_unlikely(narg < 4|| narg > 5)) FEwrong_num_arguments(ecl_make_fixnum(1591));
#line 852
if (narg > 4) {
#line 852
cctype = va_arg(ARGS,cl_object);
#line 852
} else {
#line 852
cctype = ECL_SYM(":CDECL",1593);
#line 852
}
#line 852
// ------------------------------5
data = cl_list(3, fun, rtype, argtypes);
cbk = ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377), 0, ecl_dynamic_callback_make(data, ecl_foreign_cc_code(cctype)));
si_put_sysprop(sym, ECL_SYM(":CALLBACK",1590), CONS(cbk, data));
{
#line 856
#line 856
cl_object __value0 = cbk;
#line 856
the_env->nvalues = 1;
#line 856
return __value0;
#line 856
}
}
void
assert_type_non_negative_integer(cl_object p)
{
cl_type t = ecl_t_of(p);
if (t == t_fixnum) {
if (ecl_fixnum_plusp(p))
return;
} else if (t == t_bignum) {
if (_ecl_big_sign(p) >= 0)
return;
}
FEwrong_type_argument(cl_list(3,ECL_SYM("INTEGER",437),ecl_make_fixnum(0),ECL_SYM("*",18)), p);
}
void
ecl_def_c_macro_va(cl_object sym, cl_objectfn c_function)
{
si_fset(3, sym,
ecl_make_cfun_va(c_function, sym, ecl_symbol_value(ECL_SYM("SI::*CBLOCK*",1013))),
ECL_T);
}
static cl_object
ihs_function_name(cl_object x)
{
cl_object y;
switch (ecl_t_of(x)) {
case t_symbol:
return(x);
case t_bclosure:
x = x->bclosure.code;
case t_bytecodes:
y = x->bytecodes.name;
if (Null(y))
return(ECL_SYM("LAMBDA",452));
else
return y;
case t_cfun:
case t_cfunfixed:
return(x->cfun.name);
default:
return(ECL_NIL);
}
}
ecl_long_long_t
ecl_to_long_long(cl_object x)
{
if (ECL_FIXNUMP(x)) {
return (ecl_long_long_t)ecl_fixnum(x);
} else if (!ECL_BIGNUMP(x)) {
(void)0;
} else if (mpz_fits_slong_p(x->big.big_num)) {
return (ecl_long_long_t)mpz_get_si(x->big.big_num);
} else {
cl_object copy = _ecl_big_register0();
int i = ECL_LONG_LONG_BITS - FIXNUM_BITS;
mpz_fdiv_q_2exp(copy->bit.big_num, x->big.big_num, i);
if (mpz_fits_ulong_p(copy->big.big_num)) {
volatile ecl_long_long_t output;
output = mpz_get_si(copy->big.big_num);
for (i -= FIXNUM_BITS; i; i-= FIXNUM_BITS) {
output = (output << FIXNUM_BITS);
output += mpz_get_ui(x->big.big_num);
}
return output;
}
}
FEwrong_type_argument(cl_list(3,ECL_SYM("INTEGER",437),
ecl_negate(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1)),
ecl_one_minus(ecl_ash(ecl_make_fixnum(1), ECL_LONG_LONG_BITS-1))),
x);
}
cl_object
si_float_to_digits(cl_object digits, cl_object number, cl_object position,
cl_object relativep)
{
cl_fixnum k;
float_approx approx[1];
setup(number, approx);
change_precision(approx, position, relativep);
k = scale(approx);
if (Null(digits))
digits = si_make_vector(ECL_SYM("BASE-CHAR",120), ecl_make_fixnum(10),
ECL_T /* adjustable */,
ecl_make_fixnum(0) /* fill pointer */,
ECL_NIL /* displacement */,
ECL_NIL /* displ. offset */);
generate(digits, approx);
{
#line 218
const cl_env_ptr the_env = ecl_process_env();
#line 218
#line 218
cl_object __value0 = ecl_make_fixnum(k);
#line 218
cl_object __value1 = digits;
#line 218
the_env->nvalues = 2;
#line 218
the_env->values[1] = __value1;
#line 218
return __value0;
#line 218
}
}
ecl_uint64_t
ecl_to_uint64_t(cl_object x) {
if (!ecl_minusp(x)) {
if (ECL_FIXNUMP(x)) {
return (ecl_uint64_t)ecl_fixnum(x);
} else if (!ECL_BIGNUMP(x)) {
(void)0;
} else if (mpz_fits_ulong_p(x->big.big_num)) {
return (ecl_uint64_t)mpz_get_ui(x->big.big_num);
} else {
cl_object copy = _ecl_big_register0();
mpz_fdiv_q_2exp(copy->big.big_num, x->big.big_num, 32);
if (mpz_fits_ulong_p(copy->big.big_num)) {
volatile ecl_uint64_t output;
output = (ecl_uint64_t)mpz_get_ui(copy->big.big_num);
output = (output << 32) +
(ecl_uint64_t)mpz_get_ui(x->big.big_num);
return output;
}
}
}
FEwrong_type_argument(cl_list(3,ECL_SYM("INTEGER",437),ecl_make_fixnum(0),
ecl_one_minus(ecl_ash(ecl_make_fixnum(1), 64))),
x);
}
void
ecl_def_c_macro(cl_object sym, cl_objectfn_fixed c_function, int narg)
{
si_fset(3, sym,
ecl_make_cfun(c_function, sym, ecl_symbol_value(ECL_SYM("SI::*CBLOCK*",1013)), 2),
ECL_T);
}
ECL_DLLEXPORT void init_fas_CODE(cl_object flag)
{
const cl_env_ptr cl_env_copy = ecl_process_env();
cl_object value0;
cl_object *VVtemp;
if (flag != OBJNULL){
Cblock = flag;
#ifndef ECL_DYNAMIC_VV
flag->cblock.data = VV;
#endif
flag->cblock.data_size = VM;
flag->cblock.temp_data_size = VMtemp;
flag->cblock.data_text = compiler_data_text;
flag->cblock.data_text_size = compiler_data_text_size;
flag->cblock.cfuns_size = compiler_cfuns_size;
flag->cblock.cfuns = compiler_cfuns;
flag->cblock.source = make_constant_base_string("/home/tucker/Repo/my-code/lisp/misc.lisp");
return;}
#ifdef ECL_DYNAMIC_VV
VV = Cblock->cblock.data;
#endif
Cblock->cblock.data_text = "@EcLtAg:init_fas_CODE@";
VVtemp = Cblock->cblock.temp_data;
ECL_DEFINE_SETF_FUNCTIONS
ecl_function_dispatch(cl_env_copy,VV[2])(10, VVtemp[0], ECL_NIL, ECL_NIL, VVtemp[1], ECL_NIL, ECL_NIL, VVtemp[2], ECL_NIL, ECL_NIL, ECL_NIL) /* DODEFPACKAGE */;
ecl_cmp_defun(VV[3]); /* SEQ */
ecl_function_dispatch(cl_env_copy,VV[4])(3, VV[0], ECL_SYM("FUNCTION",396), VVtemp[3]) /* SET-DOCUMENTATION */;
ecl_cmp_defun(VV[8]); /* INTERLEAVE */
}
cl_object si::call-cfun(cl_narg narg, ...)
{
#line 940
// ------------------------------2
#line 940
const cl_env_ptr the_env = ecl_process_env();
#line 940
cl_object cc_type;
#line 940
va_list ARGS;
va_start(ARGS, narg);
cl_object fun = va_arg(ARGS,cl_object);
cl_object return_type = va_arg(ARGS,cl_object);
cl_object arg_types = va_arg(ARGS,cl_object);
cl_object args = va_arg(ARGS,cl_object);
#line 940
// ------------------------------3
void *cfun = ecl_foreign_data_pointer_safe(fun);
cl_object object;
volatile cl_index sp;
ffi_cif cif;
#line 946
// ------------------------------4
#line 946
#line 946
if (ecl_unlikely(narg < 4|| narg > 5)) FEwrong_num_arguments(ecl_make_fixnum(1589));
#line 946
if (narg > 4) {
#line 946
cc_type = va_arg(ARGS,cl_object);
#line 946
} else {
#line 946
cc_type = ECL_SYM(":DEFAULT",1215);
#line 946
}
#line 946
// ------------------------------5
{
sp = ECL_STACK_INDEX(the_env);
prepare_cif(the_env, &cif, return_type, arg_types, args, cc_type, NULL);
ffi_call(&cif, cfun, the_env->ffi_values, (void **)the_env->ffi_values_ptrs);
object = ecl_foreign_data_ref_elt(the_env->ffi_values,
ecl_foreign_type_code(return_type));
ECL_STACK_SET_INDEX(the_env, sp);
{
#line 953
#line 953
cl_object __value0 = object;
#line 953
the_env->nvalues = 1;
#line 953
return __value0;
#line 953
}
}
}
static cl_object
slot_method_name(cl_object gfun, cl_object args)
{
cl_object methods = _ecl_funcall3(ECL_SYM("COMPUTE-APPLICABLE-METHODS",936),
gfun, args);
unlikely_if (Null(methods)) {
return OBJNULL;
} else {
cl_object
ecl_make_foreign_data(cl_object tag, cl_index size, void *data)
{
cl_object output = ecl_alloc_object(t_foreign);
output->foreign.tag = tag == ECL_NIL ? ECL_SYM(":VOID",1381) : tag;
output->foreign.size = size;
output->foreign.data = (char*)data;
return output;
}
cl_object
si_set_limit(cl_object type, cl_object size)
{
cl_env_ptr env = ecl_process_env();
cl_index the_size = ecl_to_size(size);
if (type == ECL_SYM("EXT::FRAME-STACK",1669)) {
frs_set_size(env, the_size);
} else if (type == ECL_SYM("EXT::BINDING-STACK",1668)) {
ecl_bds_set_size(env, the_size);
} else if (type == ECL_SYM("EXT::C-STACK",1671)) {
cs_set_size(env, the_size);
} else if (type == ECL_SYM("EXT::LISP-STACK",1670)) {
ecl_stack_set_size(env, the_size);
} else {
_ecl_set_max_heap_size(the_size);
}
return si_get_limit(type);
}
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
}
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);
}
ecl_uint8_t
ecl_to_uint8_t(cl_object x) {
if (ecl_likely(ECL_FIXNUMP(x))) {
cl_fixnum aux = ecl_fixnum(x);
if (ecl_likely(aux >= 0 && aux <= 255))
return (ecl_uint8_t)aux;
}
FEwrong_type_argument(cl_list(2, ECL_SYM("UNSIGNED-BYTE",885), ecl_make_fixnum(8)),
x);
}
ecl_int8_t
ecl_to_int8_t(cl_object x) {
if (ecl_likely(ECL_FIXNUMP(x))) {
cl_fixnum aux = ecl_fixnum(x);
if (ecl_likely(aux >= -128 && aux <= 127))
return (ecl_uint8_t)aux;
}
FEwrong_type_argument(cl_list(2, ECL_SYM("SIGNED-BYTE",761), ecl_make_fixnum(8)),
x);
}
static void
frs_overflow(void) /* used as condition in list.d */
{
static const char *stack_overflow_msg =
"\n;;;\n;;; Frame stack overflow.\n"
";;; Jumping to the outermost toplevel prompt\n"
";;;\n\n";
cl_env_ptr env = ecl_process_env();
cl_index margin = ecl_option_values[ECL_OPT_FRAME_STACK_SAFETY_AREA];
cl_index size = env->frs_size;
ecl_frame_ptr org = env->frs_org;
ecl_frame_ptr last = org + size;
if (env->frs_limit >= last) {
ecl_unrecoverable_error(env, stack_overflow_msg);
}
env->frs_limit += margin;
cl_cerror(6, make_constant_base_string("Extend stack size"),
ECL_SYM("EXT::STACK-OVERFLOW",1665), ECL_SYM(":SIZE",1308), ecl_make_fixnum(size),
ECL_SYM(":TYPE",1318), ECL_SYM("EXT::FRAME-STACK",1669));
frs_set_size(env, size + size / 2);
}
cl_object
ecl_null_terminated_base_string(cl_object f)
{
/* 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);
if (ECL_ARRAY_HAS_FILL_POINTER_P(f) &&
f->base_string.self[f->base_string.fillp] != 0) {
return cl_copy_seq(f);
} else {
return f;
}
}
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;
}
}
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;
}
ecl_uint32_t
ecl_to_uint32_t(cl_object x) {
const uint32_t uint32_max = 0xFFFFFFFFUL;
if (ecl_likely(ECL_FIXNUMP(x))) {
cl_fixnum y = ecl_fixnum(x);
if (ecl_likely(y >= 0 && y <= uint32_max)) {
return (ecl_uint32_t)y;
}
}
FEwrong_type_argument(cl_list(3,ECL_SYM("INTEGER",437),ecl_make_fixnum(0),
ecl_make_unsigned_integer(uint32_max)),
x);
}
void
FEcircular_list(cl_object x)
{
/* FIXME: Is this the right way to rebind it? */
ecl_bds_bind(ecl_process_env(), ECL_SYM("*PRINT-CIRCLE*",47), ECL_T);
cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("Circular list ~D"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
ECL_SYM(":EXPECTED-TYPE",1232), ECL_SYM("LIST",481),
ECL_SYM(":DATUM",1214), x);
}
ecl_bds_ptr
ecl_bds_overflow(void)
{
static const char *stack_overflow_msg =
"\n;;;\n;;; Binding stack overflow.\n"
";;; Jumping to the outermost toplevel prompt\n"
";;;\n\n";
cl_env_ptr env = ecl_process_env();
cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
cl_index size = env->bds_size;
ecl_bds_ptr org = env->bds_org;
ecl_bds_ptr last = org + size;
if (env->bds_limit >= last) {
ecl_unrecoverable_error(env, stack_overflow_msg);
}
env->bds_limit += margin;
cl_cerror(6, make_constant_base_string("Extend stack size"),
ECL_SYM("EXT::STACK-OVERFLOW",1665), ECL_SYM(":SIZE",1308), ecl_make_fixnum(size),
ECL_SYM(":TYPE",1318), ECL_SYM("EXT::BINDING-STACK",1668));
ecl_bds_set_size(env, size + (size / 2));
return env->bds_top;
}
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
}
unsigned short
ecl_to_ushort(cl_object x) {
const unsigned short ushort_max = USHRT_MAX;
if (ecl_likely(ECL_FIXNUMP(x))) {
cl_fixnum y = ecl_fixnum(x);
if (ecl_likely(y >= 0 && y <= ushort_max)) {
return (unsigned short)y;
}
}
FEwrong_type_argument(cl_list(3,ECL_SYM("INTEGER",437),
ecl_make_fixnum(0),
ecl_make_fixnum(ushort_max)),
x);
}
static void
FEtype_error_plist(cl_object x)
{
cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("Not a valid property list ~D"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(1, x),
ECL_SYM(":EXPECTED-TYPE",1232), ECL_SYM("SI::PROPERTY-LIST",1658),
ECL_SYM(":DATUM",1214), x);
}
