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);
}
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);
}
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);
}
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);
}
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);
}
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);
}
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
}
}
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);
}
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);
}
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);
}
ecl_int32_t
ecl_to_int32_t(cl_object x) {
const int32_t int32_min = -0x80000000L;
const int32_t int32_max = 0x7FFFFFFFL;
if (ecl_likely(ECL_FIXNUMP(x))) {
cl_fixnum y = ecl_fixnum(x);
if (ecl_likely(y >= int32_min && y <= int32_max)) {
return (ecl_int32_t)y;
}
}
FEwrong_type_argument(cl_list(3,ECL_SYM("INTEGER",437),
ecl_make_integer(int32_min),
ecl_make_integer(int32_max)),
x);
}
short
ecl_to_short(cl_object x) {
const short short_min = SHRT_MIN;
const short short_max = SHRT_MAX;
if (ecl_likely(ECL_FIXNUMP(x))) {
cl_fixnum y = ecl_fixnum(x);
if (ecl_likely(y >= short_min && y <= short_max)) {
return (short)y;
}
}
FEwrong_type_argument(cl_list(3,ECL_SYM("INTEGER",437),
ecl_make_fixnum(short_min),
ecl_make_fixnum(short_max)),
x);
}
cl_index
fixnnint(cl_object x)
{
if (ECL_FIXNUMP(x)) {
cl_fixnum i = ecl_fixnum(x);
if (i >= 0)
return i;
} else if (ECL_BIGNUMP(x)) {
if (mpz_fits_ulong_p(x->big.big_num)) {
return mpz_get_ui(x->big.big_num);
}
}
FEwrong_type_argument(cl_list(3, ECL_SYM("INTEGER",437), ecl_make_fixnum(0),
ecl_make_fixnum(MOST_POSITIVE_FIXNUM)),
x);
}
int main(int narg, char **argv)
{
pthread_t child_thread;
int i, code;
/*
* First of all, we have to initialize the ECL environment.
* This should be done from the main thread.
*/
cl_boot(narg, argv);
/*
* Here we spawn 10 threads using the OS functions. The
* current version is for Unix and uses pthread_create.
* Since we have included <gc.h>, pthread_create will be
* replaced with the appropiate routine from the garbage
* collector.
*/
cl_object sym_print = c_string_to_object("PRINT");
/*
* This array will keep the forms we want to evaluate from
* being garbage collected.
*/
volatile cl_object forms[4];
for (i = 0; i < 4; i++) {
forms[i] = cl_list(2, sym_print, MAKE_FIXNUM(i));
code = pthread_create(&child_thread, NULL, thread_entry_point,
(void*)forms[i]);
if (code) {
printf("Unable to create thread\n");
exit(1);
}
}
/*
* Here we wait for the last thread to finish.
*/
pthread_join(child_thread, NULL);
return 0;
}
cl_object
cl_type_of(cl_object x)
{
cl_object t;
cl_type tx = ecl_t_of(x);
switch (tx) {
#ifdef CLOS
case t_instance: {
cl_object cl = ECL_CLASS_OF(x);
t = ECL_CLASS_NAME(cl);
if (t == ECL_NIL || cl != cl_find_class(2, t, ECL_NIL))
t = cl;
break;
}
#endif
#if 1
case t_fixnum:
case t_bignum:
t = cl_list(3, ECL_SYM("INTEGER",437), x, x); break;
#endif
case t_character: {
int i = ECL_CHAR_CODE(x);
if (ecl_standard_char_p(i)) {
t = ECL_SYM("STANDARD-CHAR",794);
} else if (ecl_base_char_p(i)) {
t = ECL_SYM("BASE-CHAR",120);
} else {
t = ECL_SYM("CHARACTER",222);
}
break;
}
case t_symbol:
if (x == ECL_T)
t = ECL_SYM("BOOLEAN",155);
else if (x->symbol.hpack == cl_core.keyword_package)
t = ECL_SYM("KEYWORD",449);
else
t = ECL_SYM("SYMBOL",840);
break;
case t_array:
if (ECL_ADJUSTABLE_ARRAY_P(x) ||
!Null(CAR(x->array.displaced)))
t = ECL_SYM("ARRAY",96);
else
t = ECL_SYM("SIMPLE-ARRAY",763);
t = cl_list(3, t, ecl_elttype_to_symbol(ecl_array_elttype(x)),
cl_array_dimensions(x));
break;
case t_vector:
if (ECL_ADJUSTABLE_ARRAY_P(x) ||
!Null(CAR(x->vector.displaced))) {
t = cl_list(3, ECL_SYM("VECTOR",898), ecl_elttype_to_symbol(ecl_array_elttype(x)),
ecl_make_fixnum(x->vector.dim));
} else if (ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
(cl_elttype)x->vector.elttype != ecl_aet_object) {
t = cl_list(3, ECL_SYM("SIMPLE-ARRAY",763),
ecl_elttype_to_symbol(ecl_array_elttype(x)),
cl_array_dimensions(x));
} else {
t = cl_list(2, ECL_SYM("SIMPLE-VECTOR",774), ecl_make_fixnum(x->vector.dim));
}
break;
#ifdef ECL_UNICODE
case t_string:
if (ECL_ADJUSTABLE_ARRAY_P(x) ||
ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
!Null(CAR(x->string.displaced)))
t = ECL_SYM("ARRAY",96);
else
t = ECL_SYM("SIMPLE-ARRAY",763);
t = cl_list(3, t, ECL_SYM("CHARACTER",222), cl_list(1, ecl_make_fixnum(x->string.dim)));
break;
#endif
case t_base_string:
if (ECL_ADJUSTABLE_ARRAY_P(x) ||
ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
!Null(CAR(x->base_string.displaced)))
t = ECL_SYM("ARRAY",96);
else
t = ECL_SYM("SIMPLE-ARRAY",763);
t = cl_list(3, t, ECL_SYM("BASE-CHAR",120), cl_list(1, ecl_make_fixnum(x->base_string.dim)));
break;
case t_bitvector:
if (ECL_ADJUSTABLE_ARRAY_P(x) ||
ECL_ARRAY_HAS_FILL_POINTER_P(x) ||
!Null(CAR(x->vector.displaced)))
t = ECL_SYM("ARRAY",96);
else
t = ECL_SYM("SIMPLE-ARRAY",763);
t = cl_list(3, t, ECL_SYM("BIT",123), cl_list(1, ecl_make_fixnum(x->vector.dim)));
break;
#ifndef CLOS
case t_structure:
t = x->str.name; break;
#endif
case t_stream:
switch (x->stream.mode) {
case ecl_smm_synonym: t = ECL_SYM("SYNONYM-STREAM",848); break;
case ecl_smm_broadcast: t = ECL_SYM("BROADCAST-STREAM",159); break;
case ecl_smm_concatenated: t = ECL_SYM("CONCATENATED-STREAM",245); break;
case ecl_smm_two_way: t = ECL_SYM("TWO-WAY-STREAM",866); break;
case ecl_smm_string_input:
case ecl_smm_string_output: t = ECL_SYM("STRING-STREAM",816); break;
case ecl_smm_echo: t = ECL_SYM("ECHO-STREAM",322); break;
case ecl_smm_sequence_input:
case ecl_smm_sequence_output: t = ECL_SYM("EXT::SEQUENCE-STREAM",1925); break;
default: t = ECL_SYM("FILE-STREAM",358); break;
}
break;
case t_pathname:
t = x->pathname.logical? ECL_SYM("LOGICAL-PATHNAME",498) : ECL_SYM("PATHNAME",630);
break;
case t_list:
t = Null(x) ? ECL_SYM("NULL",605) : ECL_SYM("CONS",251);
break;
#ifdef ECL_SSE2
case t_sse_pack:
t = ECL_SYM("EXT::SSE-PACK",1790);
break;
#endif
default:
t = ecl_type_to_symbol(tx);
}
{
#line 355
const cl_env_ptr the_env = ecl_process_env();
#line 355
#line 355
cl_object __value0 = t;
#line 355
the_env->nvalues = 1;
#line 355
return __value0;
#line 355
}
}
void
ecl_defvar(cl_object sym, cl_object val)
{
si_safe_eval(3, cl_list(3, ECL_SYM("DEFVAR",290), sym, cl_list(2, ECL_SYM("QUOTE",679), val)), ECL_NIL, ECL_NIL);
}
cl_object cl_gensym(cl_narg narg, ...)
{
#line 337
// ------------------------------2
#line 337
const cl_env_ptr the_env = ecl_process_env();
#line 337
cl_object prefix;
#line 337
va_list ARGS;
va_start(ARGS, narg);
#line 337
// ------------------------------3
cl_type t;
cl_object counter, output;
bool increment;
#line 341
// ------------------------------4
#line 341
#line 341
if (ecl_unlikely(narg < 0|| narg > 1)) FEwrong_num_arguments(ecl_make_fixnum(400));
#line 341
if (narg > 0) {
#line 341
prefix = va_arg(ARGS,cl_object);
#line 341
} else {
#line 341
prefix = cl_core.gensym_prefix;
#line 341
}
#line 341
// ------------------------------5
{
if (ecl_stringp(prefix)) {
counter = ECL_SYM_VAL(the_env, ECL_SYM("*GENSYM-COUNTER*",35));
increment = 1;
} else if ((t = ecl_t_of(prefix)) == t_fixnum || t == t_bignum) {
counter = prefix;
prefix = cl_core.gensym_prefix;
increment = 0;
} else {
FEwrong_type_nth_arg(ecl_make_fixnum(/*GENSYM*/400),2,prefix,
cl_list(3, ECL_SYM("OR",614), ECL_SYM("STRING",805), ECL_SYM("INTEGER",437)));
}
output = ecl_make_string_output_stream(64, 1);
ecl_bds_bind(the_env, ECL_SYM("*PRINT-ESCAPE*",48), ECL_NIL);
ecl_bds_bind(the_env, ECL_SYM("*PRINT-READABLY*",57), ECL_NIL);
ecl_bds_bind(the_env, ECL_SYM("*PRINT-BASE*",45), ecl_make_fixnum(10));
ecl_bds_bind(the_env, ECL_SYM("*PRINT-RADIX*",56), ECL_NIL);
si_write_ugly_object(prefix, output);
si_write_ugly_object(counter, output);
ecl_bds_unwind_n(the_env, 4);
output = cl_make_symbol(cl_get_output_stream_string(output));
if (increment)
ECL_SETQ(the_env, ECL_SYM("*GENSYM-COUNTER*",35),ecl_one_plus(counter));
{
#line 364
#line 364
cl_object __value0 = output;
#line 364
the_env->nvalues = 1;
#line 364
return __value0;
#line 364
}
;
} }
cl_object si::make-dynamic-callback(cl_narg narg, ...)
{
#line 989
// ------------------------------2
#line 989
const cl_env_ptr the_env = ecl_process_env();
#line 989
cl_object cc_type;
#line 989
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 return_type = va_arg(ARGS,cl_object);
cl_object arg_types = va_arg(ARGS,cl_object);
#line 989
// ------------------------------3
#line 991
// ------------------------------4
#line 991
#line 991
if (ecl_unlikely(narg < 4|| narg > 5)) FEwrong_num_arguments(ecl_make_fixnum(1591));
#line 991
if (narg > 4) {
#line 991
cc_type = va_arg(ARGS,cl_object);
#line 991
} else {
#line 991
cc_type = ECL_SYM(":DEFAULT",1215);
#line 991
}
#line 991
// ------------------------------5
{
ffi_cif *cif = ecl_alloc(sizeof(ffi_cif));
ffi_type **types;
int n = prepare_cif(the_env, cif, return_type, arg_types, ECL_NIL, cc_type,
&types);
/* libffi allocates executable memory for us. ffi_closure_alloc()
* returns a pointer to memory and a pointer to the beginning of
* the actual executable region (executable_closure) which is
* where the code resides. */
void *executable_region;
ffi_closure *closure = ffi_closure_alloc(sizeof(ffi_closure), &executable_region);
cl_object closure_object = ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377),
sizeof(ffi_closure),
closure);
si_set_finalizer(closure_object, ECL_SYM("SI::FREE-FFI-CLOSURE",1592));
cl_object data = cl_list(6, closure_object,
fun, return_type, arg_types, cc_type,
ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377),
sizeof(*cif), cif),
ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377),
(n + 1) * sizeof(ffi_type*),
types));
int status = ffi_prep_closure_loc(closure, cif, callback_executor,
ECL_CONS_CDR(data), executable_region);
if (status != FFI_OK) {
FEerror("Unable to build callback. libffi returns ~D", 1,
ecl_make_fixnum(status));
}
si_put_sysprop(sym, ECL_SYM(":CALLBACK",1590), data);
{
#line 1024
#line 1024
cl_object __value0 = closure_object;
#line 1024
the_env->nvalues = 1;
#line 1024
return __value0;
#line 1024
}
;
}
}
void
FEtype_error_size(cl_object x) {
FEwrong_type_argument(cl_list(3, ECL_SYM("INTEGER",437), ecl_make_fixnum(0),
ecl_make_fixnum(MOST_POSITIVE_FIXNUM)),
x);
}
void
ecl_defparameter(cl_object sym, cl_object val)
{
si_safe_eval(3, cl_list(3, ECL_SYM("DEFPARAMETER",285), sym, cl_list(2, ECL_SYM("QUOTE",679), val)), ECL_NIL, ECL_NIL);
}
cl_object
ecl_make_integer_type(cl_object min, cl_object max)
{
return cl_list(3, ECL_SYM("INTEGER",437), min, max);
}
