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