Commit d70f0317 authored by Marius Gerbershagen's avatar Marius Gerbershagen

Merge branch 'feature-float-complex' into 'develop'

Feature complex float

See merge request !149
parents aa5ed8bc 60370703
Pipeline #61884880 passed with stage
......@@ -350,8 +350,8 @@ cl_object_mark_proc(void *addr, struct GC_ms_entry *msp, struct GC_ms_entry *msl
MAYBE_MARK(o->ratio.den);
break;
case t_complex:
MAYBE_MARK(o->complex.real);
MAYBE_MARK(o->complex.imag);
MAYBE_MARK(o->gencomplex.real);
MAYBE_MARK(o->gencomplex.imag);
break;
case t_symbol:
MAYBE_MARK(o->symbol.hpack);
......@@ -559,6 +559,11 @@ ecl_alloc_object(cl_type t)
#endif
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat:
case t_cdfloat:
case t_clfloat:
#endif
case t_singlefloat:
case t_doublefloat: {
......@@ -851,6 +856,11 @@ init_alloc(void)
init_tm(t_longfloat, "LONG-FLOAT", sizeof(struct ecl_long_float), 0);
#endif
init_tm(t_complex, "COMPLEX", sizeof(struct ecl_complex), 2);
#ifdef ECL_COMPLEX_FLOAT
init_tm(t_csfloat, "COMPLEX-SINGLE-FLOAT", sizeof(struct ecl_csfloat), 0);
init_tm(t_cdfloat, "COMPLEX-DOUBLE-FLOAT", sizeof(struct ecl_cdfloat), 0);
init_tm(t_clfloat, "COMPLEX-LONG-FLOAT", sizeof(struct ecl_clfloat), 0);
#endif
init_tm(t_symbol, "SYMBOL", sizeof(struct ecl_symbol), 5);
init_tm(t_package, "PACKAGE", sizeof(struct ecl_package), -1); /* 36 */
#ifdef ECL_THREADS
......@@ -909,6 +919,11 @@ init_alloc(void)
type_info[t_complex].descriptor =
to_bitmap(&o, &(o.complex.real)) |
to_bitmap(&o, &(o.complex.imag));
#ifdef ECL_COMPLEX_FLOAT
type_info[t_csfloat].descriptor = 0;
type_info[t_cdfloat].descriptor = 0;
type_info[t_clfloat].descriptor = 0;
#endif
type_info[t_symbol].descriptor =
to_bitmap(&o, &(o.symbol.value)) |
to_bitmap(&o, &(o.symbol.gfdef)) |
......
......@@ -22,6 +22,14 @@ static const cl_object ecl_aet_name[] = {
ECL_T, /* ecl_aet_object */
@'single-float', /* ecl_aet_sf */
@'double-float', /* ecl_aet_df */
#ifdef ECL_LONG_FLOAT
@'long-float', /* ecl_aet_lf */
#endif
#ifdef ECL_COMPLEX_FLOAT
@'si::complex-single-float', /* ecl_aet_csf */
@'si::complex-double-float', /* ecl_aet_cdf */
@'si::complex-long-float', /* ecl_aet_clf */
#endif
@'bit', /* ecl_aet_bit */
@'ext::cl-fixnum', /* ecl_aet_fix */
@'ext::cl-index', /* ecl_aet_index */
......@@ -173,6 +181,18 @@ ecl_aref_unsafe(cl_object x, cl_index index)
return(ecl_make_single_float(x->array.self.sf[index]));
case ecl_aet_df:
return(ecl_make_double_float(x->array.self.df[index]));
#ifdef ECL_LONG_FLOAT
case ecl_aet_lf:
return(ecl_make_long_float(x->array.self.lf[index]));
#endif
#ifdef ECL_COMPLEX_FLOAT
case ecl_aet_csf:
return(ecl_make_csfloat(x->array.self.csf[index]));
case ecl_aet_cdf:
return(ecl_make_cdfloat(x->array.self.cdf[index]));
case ecl_aet_clf:
return(ecl_make_clfloat(x->array.self.clf[index]));
#endif
case ecl_aet_b8:
return ecl_make_uint8_t(x->array.self.b8[index]);
case ecl_aet_i8:
......@@ -329,6 +349,22 @@ ecl_aset_unsafe(cl_object x, cl_index index, cl_object value)
case ecl_aet_df:
x->array.self.df[index] = ecl_to_double(value);
break;
#ifdef ECL_LONG_FLOAT
case ecl_aet_lf:
x->array.self.lf[index] = ecl_to_long_double(value);
break;
#endif
#ifdef ECL_COMPLEX_FLOAT
case ecl_aet_csf:
x->array.self.csf[index] = ecl_to_csfloat(value);
break;
case ecl_aet_cdf:
x->array.self.cdf[index] = ecl_to_cdfloat(value);
break;
case ecl_aet_clf:
x->array.self.clf[index] = ecl_to_clfloat(value);
break;
#endif
case ecl_aet_b8:
x->array.self.b8[index] = ecl_to_uint8_t(value);
break;
......@@ -635,11 +671,20 @@ ecl_symbol_to_elttype(cl_object x)
return(ecl_aet_df);
else if (x == @'long-float') {
#ifdef ECL_LONG_FLOAT
return(ecl_aet_object);
return(ecl_aet_lf);
#else
return(ecl_aet_df);
#endif
} else if (x == @'ext::byte8')
}
#ifdef ECL_COMPLEX_FLOAT
else if (x == @'si::complex-single-float')
return(ecl_aet_csf);
else if (x == @'si::complex-double-float')
return(ecl_aet_cdf);
else if (x == @'si::complex-long-float')
return(ecl_aet_clf);
#endif
else if (x == @'ext::byte8')
return(ecl_aet_b8);
else if (x == @'ext::integer8')
return(ecl_aet_i8);
......@@ -710,6 +755,18 @@ address_inc(void *address, cl_fixnum inc, cl_elttype elt_type)
#endif
case ecl_aet_df:
return aux.df + inc;
#ifdef ECL_LONG_FLOAT
case ecl_aet_lf:
return aux.lf + inc;
#endif
#ifdef ECL_COMPLEX_FLOAT
case ecl_aet_csf:
return aux.csf + inc;
case ecl_aet_cdf:
return aux.cdf + inc;
case ecl_aet_clf:
return aux.clf + inc;
#endif
case ecl_aet_b8:
case ecl_aet_i8:
return aux.b8 + inc;
......@@ -971,6 +1028,22 @@ cl_array_displacement(cl_object a)
case ecl_aet_df:
offset = a->array.self.df - to_array->array.self.df;
break;
#ifdef ECL_LONG_FLOAT
case ecl_aet_lf:
offset = a->array.self.lf - to_array->array.self.lf;
break;
#endif
#ifdef ECL_COMPLEX_FLOAT
case ecl_aet_csf:
offset = a->array.self.csf - to_array->array.self.csf;
break;
case ecl_aet_cdf:
offset = a->array.self.cdf - to_array->array.self.cdf;
break;
case ecl_aet_clf:
offset = a->array.self.clf - to_array->array.self.clf;
break;
#endif
case ecl_aet_b8:
case ecl_aet_i8:
offset = a->array.self.b8 - to_array->array.self.b8;
......@@ -1241,6 +1314,38 @@ ecl_reverse_subarray(cl_object x, cl_index i0, cl_index i1)
x->array.self.df[j] = y;
}
break;
#ifdef ECL_LONG_FLOAT
case ecl_aet_lf:
for (i = i0, j = i1-1; i < j; i++, --j) {
long double y = x->array.self.lf[i];
x->array.self.lf[i] = x->array.self.lf[j];
x->array.self.lf[j] = y;
}
break;
#endif
#ifdef ECL_COMPLEX_FLOAT
case ecl_aet_csf:
for (i = i0, j = i1-1; i < j; i++, --j) {
_Complex float y = x->array.self.csf[i];
x->array.self.csf[i] = x->array.self.csf[j];
x->array.self.csf[j] = y;
}
break;
case ecl_aet_cdf:
for (i = i0, j = i1-1; i < j; i++, --j) {
_Complex double y = x->array.self.cdf[i];
x->array.self.cdf[i] = x->array.self.cdf[j];
x->array.self.cdf[j] = y;
}
break;
case ecl_aet_clf:
for (i = i0, j = i1-1; i < j; i++, --j) {
_Complex long double y = x->array.self.clf[i];
x->array.self.clf[i] = x->array.self.clf[j];
x->array.self.clf[j] = y;
}
break;
#endif
case ecl_aet_bc:
for (i = i0, j = i1-1; i < j; i++, --j) {
ecl_base_char y = x->array.self.bc[i];
......@@ -1383,6 +1488,34 @@ si_fill_array_with_elt(cl_object x, cl_object elt, cl_object start, cl_object en
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#ifdef ECL_LONG_FLOAT
case ecl_aet_lf: {
long double e = ecl_to_long_double(elt);
long double *p = x->vector.self.lf + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
#ifdef ECL_COMPLEX_FLOAT
case ecl_aet_csf: {
_Complex float e = ecl_to_csfloat(elt);
_Complex float *p = x->vector.self.csf + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_cdf: {
_Complex double e = ecl_to_cdfloat(elt);
_Complex double *p = x->vector.self.cdf + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
case ecl_aet_clf: {
_Complex long double e = ecl_to_clfloat(elt);
_Complex long double *p = x->vector.self.clf + first;
for (first = last - first; first; --first, ++p) { *p = e; }
break;
}
#endif
case ecl_aet_b8: {
uint8_t e = ecl_to_uint8_t(elt);
uint8_t *p = x->vector.self.b8 + first;
......
......@@ -337,7 +337,16 @@ enum ecl_built_in_classes {
ECL_BUILTIN_FLOAT,
ECL_BUILTIN_SINGLE_FLOAT,
ECL_BUILTIN_DOUBLE_FLOAT,
#ifdef ECL_LONG_FLOAT
ECL_BUILTIN_LONG_FLOAT,
#endif
ECL_BUILTIN_COMPLEX,
#ifdef ECL_COMPLEX_FLOAT
ECL_BUILTIN_COMPLEX_FLOAT,
ECL_BUILTIN_COMPLEX_SINGLE_FLOAT,
ECL_BUILTIN_COMPLEX_DOUBLE_FLOAT,
ECL_BUILTIN_COMPLEX_LONG_FLOAT,
#endif
ECL_BUILTIN_SYMBOL,
ECL_BUILTIN_NULL,
ECL_BUILTIN_KEYWORD,
......@@ -386,11 +395,18 @@ cl_class_of(cl_object x)
index = ECL_BUILTIN_DOUBLE_FLOAT; break;
#ifdef ECL_LONG_FLOAT
case t_longfloat:
index = ECL_BUILTIN_FLOAT; break;
/* XXX index = ECL_BUILTIN_LONG_FLOAT; break; */
index = ECL_BUILTIN_LONG_FLOAT; break;
#endif
case t_complex:
index = ECL_BUILTIN_COMPLEX; break;
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat:
index = ECL_BUILTIN_COMPLEX_SINGLE_FLOAT; break;
case t_cdfloat:
index = ECL_BUILTIN_COMPLEX_DOUBLE_FLOAT; break;
case t_clfloat:
index = ECL_BUILTIN_COMPLEX_LONG_FLOAT; break;
#endif
case t_character:
index = ECL_BUILTIN_CHARACTER; break;
case t_symbol:
......
......@@ -74,6 +74,9 @@ ecl_def_string_array(feature_names,static,const) = {
#ifdef ECL_LONG_FLOAT
ecl_def_string_array_elt("LONG-FLOAT"),
#endif
#ifdef ECL_COMPLEX_FLOAT
ecl_def_string_array_elt("COMPLEX-FLOAT"),
#endif
#ifdef ecl_uint16_t
ecl_def_string_array_elt("UINT16-T"),
#endif
......
......@@ -17,8 +17,16 @@
static const cl_object ecl_aet_to_ffi_table[ecl_aet_bc+1] = {
@':void', /* ecl_aet_object */
@':float', /* ecl_aet_df */
@':float', /* ecl_aet_sf */
@':double', /* ecl_aet_df */
#ifdef ECL_LONG_FLOAT
@':long-double', /* ecl_aet_lf */
#endif
#ifdef ECL_COMPLEX_FLOAT
@':csfloat', /* ecl_aet_csf */
@':cdfloat', /* ecl_aet_cdf */
@':clfloat', /* ecl_aet_clf */
#endif
@':void', /* ecl_aet_bit */
#if ECL_FIXNUM_BITS == 32 && defined(ecl_uint32_t)
@':int32-t', /* ecl_aet_fix */
......@@ -117,6 +125,14 @@ ecl_foreign_type_table[] = {
FFI_DESC(@':object', cl_object),
FFI_DESC(@':float', float),
FFI_DESC(@':double', double),
#ifdef ECL_LONG_FLOAT
FFI_DESC(@':long-double', long double),
#endif
#ifdef ECL_COMPLEX_FLOAT
FFI_DESC(@':csfloat', _Complex float),
FFI_DESC(@':cdfloat', _Complex double),
FFI_DESC(@':clfloat', _Complex long double),
#endif
{@':void', 0, 0}
};
......@@ -139,7 +155,7 @@ static struct {
#endif
};
static ffi_type *ecl_type_to_libffi_type[] = {
static ffi_type *ecl_type_to_libffi_types[] = {
&ffi_type_schar, /*@':char',*/
&ffi_type_uchar, /*@':unsigned-char',*/
&ffi_type_sint8, /*@':byte',*/
......@@ -175,8 +191,29 @@ static ffi_type *ecl_type_to_libffi_type[] = {
&ffi_type_pointer, /*@':object',*/
&ffi_type_float, /*@':float',*/
&ffi_type_double, /*@':double',*/
#ifdef ECL_LONG_FLOAT
&ffi_type_longdouble, /*@':long-double',*/
#endif
#ifdef ECL_COMPLEX_FLOAT
/* These ffi types are defined in libffi but they dont't seem to
work. For the issue report check the following link:
https://github.com/libffi/libffi/issues/489 -- jd 2019-05-14 */
NULL /* &ffi_type_complex_float */, /*@':csfloat',*/
NULL /* &ffi_type_complex_double */, /*@':cdfloat',*/
NULL /* &ffi_type_complex_longdouble */, /*@':clfloat',*/
#endif
&ffi_type_void /*@':void'*/
};
static ffi_type *
ecl_type_to_libffi_type(cl_object type) {
enum ecl_ffi_tag tag = ecl_foreign_type_code(type);
ffi_type *result = ecl_type_to_libffi_types[tag];
if (result == NULL) {
FEerror("Dynamic FFI cannot encode argument of type ~s.", 1, type);
}
return result;
}
#endif /* HAVE_LIBFFI */
cl_object
......@@ -500,6 +537,18 @@ ecl_foreign_data_ref_elt(void *p, enum ecl_ffi_tag tag)
return ecl_make_single_float(*(float *)p);
case ECL_FFI_DOUBLE:
return ecl_make_double_float(*(double *)p);
#ifdef ECL_LONG_FLOAT
case ECL_FFI_LONG_DOUBLE:
return ecl_make_long_float(*(long double *)p);
#endif
#ifdef ECL_COMPLEX_FLOAT
case ECL_FFI_CSFLOAT:
return ecl_make_csfloat(*(_Complex float *)p);
case ECL_FFI_CDFLOAT:
return ecl_make_cdfloat(*(_Complex double *)p);
case ECL_FFI_CLFLOAT:
return ecl_make_clfloat(*(_Complex long double *)p);
#endif
case ECL_FFI_VOID:
return ECL_NIL;
default:
......@@ -594,6 +643,22 @@ ecl_foreign_data_set_elt(void *p, enum ecl_ffi_tag tag, cl_object value)
case ECL_FFI_DOUBLE:
*(double *)p = ecl_to_double(value);
break;
#ifdef ECL_LONG_FLOAT
case ECL_FFI_LONG_DOUBLE:
*(long double *)p = ecl_to_long_double(value);
break;
#endif
#ifdef ECL_COMPLEX_FLOAT
case ECL_FFI_CSFLOAT:
*(_Complex float *)p = ecl_to_csfloat(value);
break;
case ECL_FFI_CDFLOAT:
*(_Complex double *)p = ecl_to_cdfloat(value);
break;
case ECL_FFI_CLFLOAT:
*(_Complex long double *)p = ecl_to_clfloat(value);
break;
#endif
case ECL_FFI_VOID:
break;
default:
......@@ -797,10 +862,11 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type,
{
int n, ok;
ffi_type **types;
enum ecl_ffi_tag type = ecl_foreign_type_code(return_type);
enum ecl_ffi_tag type;
cl_object arg_type;
if (!the_env->ffi_args_limit)
resize_call_stack(the_env, 32);
the_env->ffi_types[0] = ecl_type_to_libffi_type[type];
the_env->ffi_types[0] = ecl_type_to_libffi_type(return_type);
for (n=0; !Null(arg_types); ) {
if (!LISTP(arg_types)) {
FEerror("In CALL-CFUN, types lists is not a proper list", 0);
......@@ -808,9 +874,10 @@ prepare_cif(cl_env_ptr the_env, ffi_cif *cif, cl_object return_type,
if (n >= the_env->ffi_args_limit) {
resize_call_stack(the_env, n + 32);
}
type = ecl_foreign_type_code(ECL_CONS_CAR(arg_types));
arg_type = ECL_CONS_CAR(arg_types);
arg_types = ECL_CONS_CDR(arg_types);
the_env->ffi_types[++n] = ecl_type_to_libffi_type[type];
type = ecl_foreign_type_code(arg_type);
the_env->ffi_types[++n] = ecl_type_to_libffi_type(arg_type);
if (CONSP(args)) {
cl_object object = ECL_CONS_CAR(args);
args = ECL_CONS_CDR(args);
......
......@@ -49,9 +49,8 @@ _hash_eql(cl_hashkey h, cl_object x)
return hash_string(h, (unsigned char*)&ecl_double_float(x), sizeof(ecl_double_float(x)));
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
/* We coerce to double because long double has extra bits
* that give rise to different hash key and are not
* meaningful */
/* We coerce to double because long double has extra bits that
* give rise to different hash key and are not meaningful. */
struct { double mantissa; int exponent; int sign; } aux;
aux.mantissa = frexpl(ecl_long_float(x), &aux.exponent);
aux.sign = (ecl_long_float(x) < 0)? -1: 1;
......@@ -59,8 +58,28 @@ _hash_eql(cl_hashkey h, cl_object x)
}
#endif
case t_complex:
h = _hash_eql(h, x->complex.real);
return _hash_eql(h, x->complex.imag);
h = _hash_eql(h, x->gencomplex.real);
return _hash_eql(h, x->gencomplex.imag);
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat: return hash_string(h, (unsigned char*)&ecl_csfloat(x), sizeof(ecl_csfloat(x)));
case t_cdfloat: return hash_string(h, (unsigned char*)&ecl_cdfloat(x), sizeof(ecl_cdfloat(x)));
case t_clfloat: {
/* We coerce to _Complex double because _Complex long double has
* extra bits that give rise to different hash key and are not
* meaningful. */
struct {
double mantissa1, mantissa2;
int exponent1, exponent2;
int sign1, sign2; } aux;
long double realpart = creall(ecl_clfloat(x));
long double imagpart = cimagl(ecl_clfloat(x));
aux.mantissa1 = frexpl(realpart, &aux.exponent1);
aux.mantissa2 = frexpl(imagpart, &aux.exponent2);
aux.sign1 = (realpart < 0)? -1: 1;
aux.sign2 = (imagpart < 0)? -1: 1;
return hash_string(h, (unsigned char*)&aux, sizeof(aux));
}
#endif
case t_character:
return hash_word(h, ECL_CHAR_CODE(x));
#ifdef ECL_SSE2
......@@ -119,6 +138,9 @@ _hash_equal(int depth, cl_hashkey h, cl_object x)
(h, (unsigned char*)array->vector.self.b8, 4*624);
}
#ifdef ECL_SIGNED_ZERO
/* According to 3.2.4.2.2 Definition of Similarity two numbers are
"similar" if they are of the same type and represent the same
mathematical value. -- jd 2019-05-06*/
case t_singlefloat: {
float f = ecl_single_float(x);
if (f == 0.0) f = 0.0;
......@@ -142,9 +164,41 @@ _hash_equal(int depth, cl_hashkey h, cl_object x)
}
# endif
case t_complex: {
h = _hash_equal(depth, h, x->complex.real);
return _hash_equal(depth, h, x->complex.imag);
h = _hash_equal(depth, h, x->gencomplex.real);
return _hash_equal(depth, h, x->gencomplex.imag);
}
# ifdef ECL_COMPLEX_FLOAT
case t_csfloat: {
_Complex float f = ecl_csfloat(x);
if (crealf(f) == 0.0) f = 0.0 + I * cimagf(f);
if (cimagf(f) == 0.0) f = crealf(f) + I * 0.0;
return hash_string(h, (unsigned char*)&(f), sizeof(f));
}
case t_cdfloat: {
_Complex double f = ecl_cdfloat(x);
if (creal(f) == 0.0) f = 0.0 + I * cimag(f);
if (cimag(f) == 0.0) f = creal(f) + I * 0.0;
return hash_string(h, (unsigned char*)&(f), sizeof(f));
}
case t_clfloat: {
/* We coerce to _Complex double because _Complex long double has
* extra bits that give rise to different hash key and are not
* meaningful. */
struct {
double mantissa1, mantissa2;
int exponent1, exponent2;
int sign1, sign2; } aux;
long double realpart = creall(ecl_clfloat(x));
long double imagpart = cimagl(ecl_clfloat(x));
aux.mantissa1 = frexpl(realpart, &aux.exponent1);
aux.mantissa2 = frexpl(imagpart, &aux.exponent2);
aux.sign1 = (realpart < 0)? -1: 1;
aux.sign2 = (imagpart < 0)? -1: 1;
if (aux.mantissa1 == 0.0) aux.mantissa1 = 0.0;
if (aux.mantissa2 == 0.0) aux.mantissa2 = 0.0;
return hash_string(h, (unsigned char*)&aux, sizeof(aux));
}
# endif
#endif
default:
return _hash_eql(h, x);
......@@ -201,8 +255,14 @@ _hash_equalp(int depth, cl_hashkey h, cl_object x)
h = _hash_equalp(0, h, x->ratio.num);
return _hash_equalp(0, h, x->ratio.den);
case t_complex:
h = _hash_equalp(0, h, x->complex.real);
return _hash_equalp(0, h, x->complex.imag);
h = _hash_equalp(0, h, x->gencomplex.real);
return _hash_equalp(0, h, x->gencomplex.imag);
#ifdef ECL_COMPLEX_FLOAT
/* FIXME! We should be more precise here! */
case t_csfloat: return hash_word(h, (cl_index)ecl_csfloat(x));
case t_cdfloat: return hash_word(h, (cl_index)ecl_cdfloat(x));
case t_clfloat: return hash_word(h, (cl_index)ecl_clfloat(x));
#endif
case t_instance:
case t_hashtable:
/* FIXME! We should be more precise here! */
......
......@@ -434,8 +434,25 @@ cl_realpart(cl_object x)
#endif
break;
case t_complex:
x = x->complex.real;
x = x->gencomplex.real;
break;
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat: {
float f = crealf(ecl_csfloat(x));
x = ecl_make_single_float(f);
break;
}
case t_cdfloat: {
double f = creal(ecl_cdfloat(x));
x = ecl_make_double_float(f);
break;
}
case t_clfloat: {
long double f = creall(ecl_clfloat(x));
x = ecl_make_long_float(f);
break;
}
#endif
default:
FEwrong_type_only_arg(@[realpart],x,@[number]);
}
......@@ -472,8 +489,25 @@ cl_imagpart(cl_object x)
break;
#endif
case t_complex:
x = x->complex.imag;
x = x->gencomplex.imag;
break;
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat: {
float f = cimagf(ecl_csfloat(x));
x = ecl_make_single_float(f);
break;
}
case t_cdfloat: {
double f = cimag(ecl_cdfloat(x));
x = ecl_make_double_float(f);
break;
}
case t_clfloat: {
long double f = cimagl(ecl_clfloat(x));
x = ecl_make_long_float(f);
break;
}
#endif
default:
FEwrong_type_only_arg(@[imagpart],x,@[number]);
}
......
......@@ -13,6 +13,7 @@
*/
#include <float.h>
#include <complex.h>
#include <limits.h>
#include <signal.h>
#define ECL_INCLUDE_MATH_H
......@@ -533,96 +534,112 @@ ecl_make_long_float(long double f)
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)) {
cl_object c = ECL_NIL;
cl_type tr = ecl_t_of(r);
cl_type ti = ecl_t_of(i);
if (!ECL_REAL_TYPE_P(tr)) { ecl_type_error(@'complex', "real part", r, @'real'); }
if (!ECL_REAL_TYPE_P(ti)) { ecl_type_error(@'complex', "imaginary part", i, @'real'); }
switch((tr > ti) ? tr : ti) {
#ifdef ECL_COMPLEX_FLOAT
case t_longfloat: return ecl_make_clfloat(ecl_to_long_double(r) + I * ecl_to_long_double(i));
case t_doublefloat: return ecl_make_cdfloat(ecl_to_double(r) + I * ecl_to_double(i));
case t_singlefloat: return ecl_make_csfloat(ecl_to_float(r) + I * ecl_to_float(i));
#else
case t_singlefloat:
c = ecl_alloc_object(t_complex);
c->gencomplex.real = ecl_make_single_float(ecl_to_float(r));
c->gencomplex.imag = ecl_make_single_float(ecl_to_float(i));
return c;
case t_doublefloat:
c = ecl_alloc_object(t_complex);
c->gencomplex.real = ecl_make_double_float(ecl_to_double(r));
c->gencomplex.imag = ecl_make_double_float(ecl_to_double(i));
return c;
# ifdef ECL_LONG_FLOAT
case t_longfloat:
c = ecl_alloc_object(t_complex);
c->gencomplex.real = ecl_make_long_float(ecl_to_long_double(r));
c->gencomplex.imag = ecl_make_long_float(ecl_to_long_double(i));
return c;
# endif
#endif
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(@'complex',"imaginary part", i, @'real');
goto AGAIN;
}
break;
if (i == ecl_make_fixnum(0))
return r;
c = ecl_alloc_object(t_complex);
c->gencomplex.real = r;
c->gencomplex.imag = i;
return c;
default:
FEerror("ecl_make_complex: unexpected argument type.", 0);
}
return(c);
}
#ifdef ECL_COMPLEX_FLOAT
/* This function is safe. Still both arguments must be of the same
float type, otherwise a type error will be signalled. -- jd 2019-04-03 */
cl_object si_complex_float_p(cl_object f) {
switch(ecl_t_of(f)) {
case t_csfloat:
case t_cdfloat:
case t_clfloat:
return ECL_T;
default:
return ECL_NIL;
}
}
cl_object
ecl_make_complex_float(cl_object r, cl_object i)
{
cl_type tr = ecl_t_of(r);
cl_type ti = ecl_t_of(i);
cl_object result;