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 */
}
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);
}
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
}
cl_object
ecl_type_error(cl_object function, const char *place, cl_object o,
cl_object type)
{
si_wrong_type_argument(4, o, type,
(*place? make_constant_base_string(place) : ECL_NIL),
function);
}
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);
}
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);
}
void
FEtype_error_index(cl_object seq, cl_fixnum ndx)
{
cl_object n = ecl_make_fixnum(ndx);
cl_index l = ECL_INSTANCEP(seq)? seq->instance.length : ecl_length(seq);
cl_error(9, ECL_SYM("SIMPLE-TYPE-ERROR",773), ECL_SYM(":FORMAT-CONTROL",1240),
make_constant_base_string("~S is not a valid index into the object ~S"),
ECL_SYM(":FORMAT-ARGUMENTS",1239), cl_list(2, n, seq),
ECL_SYM(":EXPECTED-TYPE",1232), cl_list(3, ECL_SYM("INTEGER",437), ecl_make_fixnum(0), ecl_make_fixnum(l-1)),
ECL_SYM(":DATUM",1214), n);
}
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);
}
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);
}
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_mangle_name(cl_narg narg, ...)
{
#line 81
// ------------------------------2
#line 81
const cl_env_ptr the_env = ecl_process_env();
#line 81
cl_object as_function;
#line 81
va_list ARGS;
va_start(ARGS, narg);
cl_object symbol = va_arg(ARGS,cl_object);
#line 81
// ------------------------------3
cl_index l;
unsigned char c, *source, *dest;
cl_object output;
cl_object package;
cl_object found = ECL_NIL;
cl_object maxarg = ecl_make_fixnum(ECL_CALL_ARGUMENTS_LIMIT);
cl_object minarg = ecl_make_fixnum(0);
bool is_symbol;
cl_object name;
#line 92
// ------------------------------4
#line 92
#line 92
if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(1107));
#line 92
if (narg > 1) {
#line 92
as_function = va_arg(ARGS,cl_object);
#line 92
} else {
#line 92
as_function = ECL_NIL;
#line 92
}
#line 92
// ------------------------------5
name = ecl_symbol_name(symbol);
is_symbol = Null(as_function);
if (is_symbol) {
cl_fixnum p;
if (symbol == ECL_NIL)
{
#line 97
#line 97
cl_object __value0 = ECL_T;
#line 97
cl_object __value1 = make_constant_base_string("ECL_NIL");
#line 97
the_env->nvalues = 2;
#line 97
the_env->values[1] = __value1;
#line 97
return __value0;
#line 97
}
else if (symbol == ECL_T)
{
#line 99
#line 99
cl_object __value0 = ECL_T;
#line 99
cl_object __value1 = make_constant_base_string("ECL_T");
#line 99
the_env->nvalues = 2;
#line 99
the_env->values[1] = __value1;
#line 99
return __value0;
#line 99
}
p = (cl_symbol_initializer*)symbol - cl_symbols;
if (p >= 0 && p <= cl_num_symbols_in_core) {
found = ECL_T;
output = cl_format(4, ECL_NIL,
make_constant_base_string("ECL_SYM(~S,~D)"),
name, ecl_make_fixnum(p));
{
#line 106
#line 106
cl_object __value0 = found;
#line 106
cl_object __value1 = output;
#line 106
cl_object __value2 = maxarg;
#line 106
the_env->nvalues = 3;
#line 106
the_env->values[2] = __value2;
#line 106
the_env->values[1] = __value1;
#line 106
return __value0;
#line 106
}
}
} else if (!Null(symbol)) {
cl_object fun = symbol->symbol.gfdef;
cl_type t = (fun == OBJNULL)? t_other : type_of(fun);
if ((t == t_cfun || t == t_cfunfixed) && fun->cfun.block == OBJNULL) {
for (l = 0; l <= cl_num_symbols_in_core; l++) {
cl_object s = (cl_object)(cl_symbols + l);
if (fun == ECL_SYM_FUN(s)) {
symbol = s;
found = ECL_T;
if (fun->cfun.narg >= 0) {
minarg =
maxarg = ecl_make_fixnum(fun->cfun.narg);
}
break;
}
}
}
}
package = ecl_symbol_package(symbol);
if (Null(package))
;
else if (package == cl_core.lisp_package)
package = make_constant_base_string("cl");
else if (package == cl_core.system_package)
package = make_constant_base_string("si");
else if (package == cl_core.ext_package)
package = make_constant_base_string("si");
else if (package == cl_core.keyword_package)
package = ECL_NIL;
else
package = package->pack.name;
symbol = ecl_symbol_name(symbol);
l = symbol->base_string.fillp;
source = symbol->base_string.self;
output = ecl_alloc_simple_base_string(ecl_length(package) + l + 1);
if (is_symbol && source[0] == '*') {
if (l > 2 && source[l-1] == '*') l--;
c = 'V';
l--;
source++;
} else if (is_symbol && l > 2 && source[0] == '+' && source[l-1] == '+') {
c = 'C';
l-= 2;
source++;
} else if (!is_symbol) {
c = '_';
} else if (package == cl_core.keyword_package) {
c = 'K';
} else {
c = 'S';
}
output->base_string.fillp = 0;
if (!Null(package))
if (!mangle_name(output, package->base_string.self, package->base_string.fillp))
{
#line 162
#line 162
cl_object __value0 = ECL_NIL;
#line 162
cl_object __value1 = ECL_NIL;
#line 162
cl_object __value2 = maxarg;
#line 162
the_env->nvalues = 3;
#line 162
the_env->values[2] = __value2;
#line 162
the_env->values[1] = __value1;
#line 162
return __value0;
#line 162
}
output->base_string.self[output->base_string.fillp++] = c;
if (!(dest = mangle_name(output, source, l)))
{
#line 165
#line 165
cl_object __value0 = ECL_NIL;
#line 165
cl_object __value1 = ECL_NIL;
#line 165
cl_object __value2 = maxarg;
#line 165
the_env->nvalues = 3;
#line 165
the_env->values[2] = __value2;
#line 165
the_env->values[1] = __value1;
#line 165
return __value0;
#line 165
}
if (dest[-1] == '_')
dest[-1] = 'M';
*(dest++) = '\0';
{
#line 169
#line 169
cl_object __value0 = found;
#line 169
cl_object __value1 = output;
#line 169
cl_object __value2 = minarg;
#line 169
cl_object __value3 = maxarg;
#line 169
the_env->nvalues = 4;
#line 169
the_env->values[3] = __value3;
#line 169
the_env->values[2] = __value2;
#line 169
the_env->values[1] = __value1;
#line 169
return __value0;
#line 169
}
}
static void
make_this_symbol(int i, cl_object s, int code, const char *name,
cl_objectfn fun, int narg, cl_object value)
{
enum ecl_stype stp;
cl_object package;
bool form = 0;
switch (code & 3) {
case ORDINARY_SYMBOL: stp = ecl_stp_ordinary; break;
case SPECIAL_SYMBOL: stp = ecl_stp_special; break;
case CONSTANT_SYMBOL: stp = ecl_stp_constant; break;
case FORM_SYMBOL: form = 1; stp = ecl_stp_ordinary;
}
switch (code & 0xfc) {
case CL_PACKAGE: package = cl_core.lisp_package; break;
case SI_PACKAGE: package = cl_core.system_package; break;
case EXT_PACKAGE: package = cl_core.ext_package; break;
case KEYWORD_PACKAGE: package = cl_core.keyword_package; break;
case MP_PACKAGE: package = cl_core.mp_package; break;
#ifdef CLOS
case CLOS_PACKAGE: package = cl_core.clos_package; break;
#endif
#ifdef ECL_CLOS_STREAMS
case GRAY_PACKAGE: package = cl_core.gray_package; break;
#endif
case FFI_PACKAGE: package = cl_core.ffi_package; break;
default: printf("%d\n", code & ~(int)3); ecl_internal_error("Unknown package code in init_all_symbols()");
}
s->symbol.t = t_symbol;
s->symbol.dynamic = 0;
#ifdef ECL_THREADS
s->symbol.binding = ECL_MISSING_SPECIAL_BINDING;
#endif
ECL_SET(s, OBJNULL);
ECL_SYM_FUN(s) = ECL_NIL;
s->symbol.plist = ECL_NIL;
s->symbol.hpack = ECL_NIL;
s->symbol.stype = stp;
s->symbol.hpack = package;
s->symbol.name = make_constant_base_string(name);
if (package == cl_core.keyword_package) {
package->pack.external =
_ecl_sethash(s->symbol.name, package->pack.external, s);
ECL_SET(s, s);
} else {
int intern_flag;
ECL_SET(s, value);
if (ecl_find_symbol(s->symbol.name, package, &intern_flag) != ECL_NIL
&& intern_flag == ECL_INHERITED) {
ecl_shadowing_import(s, package);
} else {
cl_import2(s, package);
}
if (!(code & PRIVATE)) {
cl_export2(s, package);
if (package == cl_core.ext_package)
cl_export2(s, cl_core.system_package);
}
}
if (form) {
s->symbol.stype |= ecl_stp_special_form;
} else if (fun) {
cl_object f;
if (narg >= 0) {
f = ecl_make_cfun((cl_objectfn_fixed)fun, s, NULL, narg);
} else {
f = ecl_make_cfun_va(fun, s, NULL);
}
ECL_SYM_FUN(s) = f;
}
cl_num_symbols_in_core = i + 1;
}