cl_object
cl_scale_float(cl_object x, cl_object y)
{
const cl_env_ptr the_env = ecl_process_env();
cl_fixnum k;
if (ECL_FIXNUMP(y)) {
k = ecl_fixnum(y);
} else {
FEwrong_type_nth_arg(ecl_make_fixnum(/*SCALE-FLOAT*/737),2,y,ecl_make_fixnum(/*FIXNUM*/372));
}
switch (ecl_t_of(x)) {
case t_singlefloat:
x = ecl_make_single_float(ldexpf(ecl_single_float(x), k));
break;
case t_doublefloat:
x = ecl_make_double_float(ldexp(ecl_double_float(x), k));
break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
x = ecl_make_long_float(ldexpl(ecl_long_float(x), k));
break;
#endif
default:
FEwrong_type_nth_arg(ecl_make_fixnum(/*SCALE-FLOAT*/737),1,x,ecl_make_fixnum(/*FLOAT*/374));
}
ecl_return1(the_env, x);
}
static void
write_sse_double(double v, cl_object stream)
{
if (is_all_FF(&v, sizeof(double)))
writestr_stream(" TRUE", stream);
else {
ecl_write_char(' ', stream);
si_write_ugly_object(ecl_make_double_float(v), stream);
}
}
cl_object
cl_decode_float(cl_object x)
{
const cl_env_ptr the_env = ecl_process_env();
int e, s;
cl_type tx = ecl_t_of(x);
float f;
switch (tx) {
case t_singlefloat: {
f = ecl_single_float(x);
if (f >= 0.0) {
s = 1;
} else {
f = -f;
s = 0;
}
f = frexpf(f, &e);
x = ecl_make_single_float(f);
break;
}
case t_doublefloat: {
double d = ecl_double_float(x);
if (d >= 0.0) {
s = 1;
} else {
d = -d;
s = 0;
}
d = frexp(d, &e);
x = ecl_make_double_float(d);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double d = ecl_long_float(x);
if (d >= 0.0)
s = 1;
else {
d = -d;
s = 0;
}
d = frexpl(d, &e);
x = ecl_make_long_float(d);
break;
}
#endif
default:
FEwrong_type_nth_arg(ecl_make_fixnum(/*DECODE-FLOAT*/275),1,x,ecl_make_fixnum(/*FLOAT*/374));
}
ecl_return3(the_env, x, ecl_make_fixnum(e), ecl_make_single_float(s));
}
// Create a new plugin instance.
static LV2_Handle
instantiate(const LV2_Descriptor* descriptor,
double rate,
const char* bundle_path,
const LV2_Feature* const* features)
{
char *real_string = NULL;
int lv2_desc_index;
int lv2_handle_index;
DescAssoc *da = NULL;
LV2_Handle ret;
// lookup the DescAssoc with this descripter pointer
lv2_desc_index = da_get_index(descriptor);
da = da_get_da(lv2_desc_index);
printf("C: instantiate() for LV2_Desc called:\n"
"\tlv2_desc_index = %d\n"
"\tdescriptor = %p\n"
"\trate = %f\n"
"\tbundle path = %s\n"
"\tfeatures array = %p\n",
lv2_desc_index, descriptor, rate, bundle_path, features);
// Call the mirrored lisp instantiate function from the associated
// lisp version of the lv2-descriptor. This is going to return a
// cl_object that represents an LV2_Handle.
// first, get the function we need to call from the right lisp lv2
// descriptor.
cl_object lisp_instantiate_function =
cl_funcall(2,
c_string_to_object("lv2-instantiate"),
da->lisp_lv2_desc);
// Then call it, passing the usual stuff. lisp will return to us the
// handle it wants back.
real_string = stringify(bundle_path);
cl_object lisp_handle =
cl_funcall(5,
lisp_instantiate_function,
da->lisp_lv2_desc,
ecl_make_double_float(rate),
c_string_to_object(real_string),
Cnil);
free(real_string);
// Associate the lisp_handle with a duck handle we're going to give to the
// host.
lv2_handle_index = hda_allocate();
hda_associate(lv2_handle_index,
lv2_desc_index, lisp_handle);
// Then, return the fake LV2_Handle to the host.
ret = hda_get_address(lv2_handle_index);
return ret;
}
cl_object
ecl_make_complex(cl_object r, cl_object i)
{
cl_object c;
cl_type ti;
AGAIN:
ti = ecl_t_of(i);
/* Both R and I are promoted to a common type */
switch (ecl_t_of(r)) {
case t_fixnum:
case t_bignum:
case t_ratio:
switch (ti) {
case t_fixnum:
if (i == ecl_make_fixnum(0))
return(r);
case t_bignum:
case t_ratio:
break;
case t_singlefloat:
r = ecl_make_single_float((float)ecl_to_double(r));
break;
case t_doublefloat:
r = ecl_make_double_float(ecl_to_double(r));
break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
r = ecl_make_long_float(ecl_to_double(r));
break;
#endif
default:
i = ecl_type_error(ECL_SYM("COMPLEX",241),"imaginary part", i, ECL_SYM("REAL",703));
goto AGAIN;
}
break;
case t_singlefloat:
switch (ti) {
case t_fixnum:
case t_bignum:
case t_ratio:
i = ecl_make_single_float((float)ecl_to_double(i));
break;
case t_singlefloat:
break;
case t_doublefloat:
r = ecl_make_double_float((double)(ecl_single_float(r)));
break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
r = ecl_make_long_float((long double)ecl_single_float(r));
break;
#endif
default:
i = ecl_type_error(ECL_SYM("COMPLEX",241),"imaginary part", i, ECL_SYM("REAL",703));
goto AGAIN;
}
break;
case t_doublefloat:
switch (ti) {
case t_fixnum:
case t_bignum:
case t_ratio:
case t_singlefloat:
i = ecl_make_double_float(ecl_to_double(i));
case t_doublefloat:
break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
r = ecl_make_long_float((long double)ecl_double_float(r));
break;
#endif
default:
i = ecl_type_error(ECL_SYM("COMPLEX",241),"imaginary part", i, ECL_SYM("REAL",703));
goto AGAIN;
}
break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
if (ti != t_longfloat)
i = ecl_make_long_float((long double)ecl_to_double(i));
break;
#endif
default:
r = ecl_type_error(ECL_SYM("COMPLEX",241),"real part", r, ECL_SYM("REAL",703));
goto AGAIN;
}
c = ecl_alloc_object(t_complex);
c->complex.real = r;
c->complex.imag = i;
return(c);
}
cl_object cl_float(cl_narg narg, ...)
{
#line 48
// ------------------------------2
#line 48
const cl_env_ptr the_env = ecl_process_env();
#line 48
cl_object y;
#line 48
va_list ARGS;
va_start(ARGS, narg);
cl_object x = va_arg(ARGS,cl_object);
#line 48
// ------------------------------3
cl_type ty, tx;
#line 51
// ------------------------------4
#line 51
#line 51
if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(374));
#line 51
if (narg > 1) {
#line 51
y = va_arg(ARGS,cl_object);
#line 51
} else {
#line 51
y = OBJNULL;
#line 51
}
#line 51
// ------------------------------5
if (y != OBJNULL) {
ty = ecl_t_of(y);
} else {
ty = t_singlefloat;
}
switch (tx = ecl_t_of(x)) {
case t_singlefloat:
case t_doublefloat:
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
if (y == OBJNULL || ty == tx)
break;
case t_fixnum:
case t_bignum:
case t_ratio:
switch (ty) {
case t_singlefloat:
x = ecl_make_single_float(ecl_to_double(x)); break;
case t_doublefloat:
x = ecl_make_double_float(ecl_to_double(x)); break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
x = ecl_make_long_float(ecl_to_long_double(x)); break;
#endif
default:
FEwrong_type_nth_arg(ecl_make_fixnum(/*FLOAT*/374),2,y,ecl_make_fixnum(/*FLOAT*/374));
}
break;
default:
FEwrong_type_nth_arg(ecl_make_fixnum(/*FLOAT*/374),1,x,ecl_make_fixnum(/*REAL*/703));
}
{
#line 83
#line 83
cl_object __value0 = x;
#line 83
the_env->nvalues = 1;
#line 83
return __value0;
#line 83
}
}
cl_object cl_float_sign(cl_narg narg, ...)
{
#line 245
// ------------------------------2
#line 245
const cl_env_ptr the_env = ecl_process_env();
#line 245
cl_object y;
#line 245
bool yp;
#line 245
va_list ARGS;
va_start(ARGS, narg);
cl_object x = va_arg(ARGS,cl_object);
#line 245
// ------------------------------3
int negativep;
#line 248
// ------------------------------4
#line 248
#line 248
if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(378));
#line 248
if (narg > 1) {
#line 248
y = va_arg(ARGS,cl_object);
#line 248
yp = TRUE;
#line 248
} else {
#line 248
y = x;
#line 248
yp = FALSE;
#line 248
}
#line 248
// ------------------------------5
if (!yp) {
y = cl_float(2, ecl_make_fixnum(1), x);
}
negativep = ecl_signbit(x);
switch (ecl_t_of(y)) {
case t_singlefloat: {
float f = ecl_single_float(y);
if (signbit(f) != negativep) y = ecl_make_single_float(-f);
break;
}
case t_doublefloat: {
double f = ecl_double_float(y);
if (signbit(f) != negativep) y = ecl_make_double_float(-f);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double f = ecl_long_float(y);
if (signbit(f) != negativep) y = ecl_make_long_float(-f);
break;
}
#endif
default:
FEwrong_type_nth_arg(ecl_make_fixnum(/*FLOAT-SIGN*/378),2,y,ecl_make_fixnum(/*FLOAT*/374));
}
{
#line 273
#line 273
cl_object __value0 = y;
#line 273
the_env->nvalues = 1;
#line 273
return __value0;
#line 273
}
;
}
MATH_DISPATCH2_BEGIN(x,y)
{
CASE_FIXNUM_FIXNUM;
CASE_BIGNUM_FIXNUM {
if (y == ecl_make_fixnum(0))
FEdivision_by_zero(x, y);
}
CASE_FIXNUM_BIGNUM;
CASE_BIGNUM_BIGNUM {
return ecl_make_ratio(x, y);
}
CASE_FIXNUM_RATIO;
CASE_BIGNUM_RATIO {
return ecl_make_ratio(ecl_times(x, y->ratio.den),
y->ratio.num);
}
CASE_FIXNUM_SINGLE_FLOAT {
return ecl_make_single_float(ecl_fixnum(x) / ecl_single_float(y));
}
CASE_FIXNUM_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_fixnum(x) / ecl_double_float(y));
}
CASE_BIGNUM_SINGLE_FLOAT;
CASE_RATIO_SINGLE_FLOAT {
return ecl_make_single_float(ecl_to_float(x) / ecl_single_float(y));
}
CASE_BIGNUM_DOUBLE_FLOAT;
CASE_RATIO_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_to_double(x) / ecl_double_float(y));
}
CASE_RATIO_FIXNUM {
if (y == ecl_make_fixnum(0)) {
FEdivision_by_zero(x,y);
}
}
CASE_RATIO_BIGNUM {
cl_object z = ecl_times(x->ratio.den, y);
return ecl_make_ratio(x->ratio.num, z);
}
CASE_RATIO_RATIO {
cl_object num = ecl_times(x->ratio.num,y->ratio.den);
cl_object den = ecl_times(x->ratio.den,y->ratio.num);
return ecl_make_ratio(num, den);
}
CASE_SINGLE_FLOAT_FIXNUM {
return ecl_make_single_float(ecl_single_float(x) / ecl_fixnum(y));
}
CASE_SINGLE_FLOAT_BIGNUM;
CASE_SINGLE_FLOAT_RATIO {
return ecl_make_single_float(ecl_single_float(x) / ecl_to_float(y));
}
CASE_SINGLE_FLOAT_SINGLE_FLOAT {
return ecl_make_single_float(ecl_single_float(x) / ecl_single_float(y));
}
CASE_SINGLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_single_float(x) / ecl_double_float(y));
}
CASE_DOUBLE_FLOAT_FIXNUM {
return ecl_make_double_float(ecl_double_float(x) / ecl_fixnum(y));
}
CASE_DOUBLE_FLOAT_BIGNUM;
CASE_DOUBLE_FLOAT_RATIO {
return ecl_make_double_float(ecl_double_float(x) / ecl_to_double(y));
}
CASE_DOUBLE_FLOAT_SINGLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) / ecl_single_float(y));
}
CASE_DOUBLE_FLOAT_DOUBLE_FLOAT {
return ecl_make_double_float(ecl_double_float(x) / ecl_double_float(y));
}
#ifdef ECL_LONG_FLOAT
CASE_FIXNUM_LONG_FLOAT {
return ecl_make_long_float(ecl_fixnum(x) / ecl_long_float(y));
}
CASE_BIGNUM_LONG_FLOAT;
CASE_RATIO_LONG_FLOAT {
return ecl_make_long_float(ecl_to_long_double(x) / ecl_long_float(y));
}
CASE_SINGLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_single_float(x) / ecl_long_float(y));
}
CASE_DOUBLE_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_double_float(x) / ecl_long_float(y));
}
CASE_LONG_FLOAT_FIXNUM {
return ecl_make_long_float(ecl_long_float(x) / ecl_fixnum(y));
}
CASE_LONG_FLOAT_BIGNUM;
CASE_LONG_FLOAT_RATIO {
return ecl_make_long_float(ecl_long_float(x) / ecl_to_long_double(y));
}
CASE_LONG_FLOAT_SINGLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) / ecl_single_float(y));
}
CASE_LONG_FLOAT_DOUBLE_FLOAT {
return ecl_make_long_float(ecl_long_float(x) / ecl_double_float(y));
}
CASE_LONG_FLOAT_LONG_FLOAT {
return ecl_make_long_float(ecl_long_float(x) / ecl_long_float(y));
}
CASE_LONG_FLOAT_COMPLEX {
goto COMPLEX_Y;
}
CASE_COMPLEX_LONG_FLOAT; {
goto COMPLEX_X;
}
#endif
CASE_COMPLEX_FIXNUM;
CASE_COMPLEX_BIGNUM;
CASE_COMPLEX_RATIO;
CASE_COMPLEX_SINGLE_FLOAT;
CASE_COMPLEX_DOUBLE_FLOAT; COMPLEX_X: {
return ecl_make_complex(ecl_divide(x->complex.real, y),
ecl_divide(x->complex.imag, y));
}
CASE_BIGNUM_COMPLEX;
CASE_RATIO_COMPLEX;
CASE_SINGLE_FLOAT_COMPLEX;
CASE_DOUBLE_FLOAT_COMPLEX;
CASE_FIXNUM_COMPLEX {
COMPLEX_Y:
return complex_divide(x, ecl_make_fixnum(0), y->complex.real, y->complex.imag);
}
CASE_COMPLEX_COMPLEX {
return complex_divide(x->complex.real, x->complex.imag,
y->complex.real, y->complex.imag);
}
CASE_UNKNOWN(ecl_make_fixnum(/*/*/21),x,y,ecl_make_fixnum(/*NUMBER*/606));
}
cl_object
ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag)
{
switch (tag) {
case ECL_FFI_CHAR:
return ECL_CODE_CHAR(*(char *)p);
case ECL_FFI_UNSIGNED_CHAR:
return ECL_CODE_CHAR(*(unsigned char *)p);
case ECL_FFI_BYTE:
return ecl_make_fixnum(*(int8_t *)p);
case ECL_FFI_UNSIGNED_BYTE:
return ecl_make_fixnum(*(uint8_t *)p);
case ECL_FFI_SHORT:
return ecl_make_fixnum(*(short *)p);
case ECL_FFI_UNSIGNED_SHORT:
return ecl_make_fixnum(*(unsigned short *)p);
case ECL_FFI_INT:
return ecl_make_integer(*(int *)p);
case ECL_FFI_UNSIGNED_INT:
return ecl_make_unsigned_integer(*(unsigned int *)p);
case ECL_FFI_LONG:
return ecl_make_integer(*(long *)p);
#ifdef ecl_uint8_t
case ECL_FFI_INT8_T:
return ecl_make_fixnum(*(ecl_int8_t *)p);
case ECL_FFI_UINT8_T:
return ecl_make_fixnum(*(ecl_uint8_t *)p);
#endif
#ifdef ecl_uint16_t
case ECL_FFI_INT16_T:
return ecl_make_int16_t(*(ecl_int16_t *)p);
case ECL_FFI_UINT16_T:
return ecl_make_uint16_t(*(ecl_uint16_t *)p);
#endif
#ifdef ecl_uint32_t
case ECL_FFI_INT32_T:
return ecl_make_int32_t(*(ecl_int32_t *)p);
case ECL_FFI_UINT32_T:
return ecl_make_uint32_t(*(ecl_uint32_t *)p);
#endif
#ifdef ecl_uint64_t
case ECL_FFI_INT64_T:
return ecl_make_int64_t(*(ecl_int64_t *)p);
case ECL_FFI_UINT64_T:
return ecl_make_uint64_t(*(ecl_uint64_t *)p);
#endif
#ifdef ecl_long_long_t
case ECL_FFI_LONG_LONG:
return ecl_make_long_long(*(ecl_long_long_t *)p);
case ECL_FFI_UNSIGNED_LONG_LONG:
return ecl_make_ulong_long(*(ecl_ulong_long_t *)p);
#endif
case ECL_FFI_UNSIGNED_LONG:
return ecl_make_unsigned_integer(*(unsigned long *)p);
case ECL_FFI_POINTER_VOID:
return ecl_make_foreign_data(ECL_SYM(":POINTER-VOID",1377), 0, *(void **)p);
case ECL_FFI_CSTRING:
return *(char **)p ?
ecl_make_simple_base_string(*(char **)p, -1) : ECL_NIL;
case ECL_FFI_OBJECT:
return *(cl_object *)p;
case ECL_FFI_FLOAT:
return ecl_make_single_float(*(float *)p);
case ECL_FFI_DOUBLE:
return ecl_make_double_float(*(double *)p);
case ECL_FFI_VOID:
return ECL_NIL;
default:
wrong_ffi_tag(tag);
}
}
