Commit e1adfd27 authored by Daniel Kochmański's avatar Daniel Kochmański

numeric tower: merge <complex float> with <complex>

cl_type_of: give better results for (type-of <complex>)

Instead of simply returning complex we return:

  (complex real)

when code is built without complex float support, and otherwise

  (complex rational)
  (complex single-float)
  (complex double-float)
  (complex long-float)

New functions:
- ecl_to_csfloat
- ecl_to_cdfloat
- ecl_to_clfloat
parent fdc40520
......@@ -343,6 +343,9 @@ enum ecl_built_in_classes {
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,
......@@ -398,9 +401,11 @@ cl_class_of(cl_object x)
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_FLOAT; break;
index = ECL_BUILTIN_COMPLEX_LONG_FLOAT; break;
#endif
case t_character:
index = ECL_BUILTIN_CHARACTER; break;
......
......@@ -534,93 +534,47 @@ 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)) {
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;
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:
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(@'complex',"imaginary part", i, @'real');
goto AGAIN;
}
break;
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:
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(@'complex',"imaginary part", i, @'real');
goto AGAIN;
}
break;
#ifdef ECL_LONG_FLOAT
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:
if (ti != t_longfloat)
i = ecl_make_long_float((long double)ecl_to_double(i));
break;
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:
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:
r = ecl_type_error(@'complex',"real part", r, @'real');
goto AGAIN;
FEerror("ecl_make_complex: unexpected argument type.", 0);
}
c = ecl_alloc_object(t_complex);
c->gencomplex.real = r;
c->gencomplex.imag = i;
return(c);
}
......@@ -670,16 +624,19 @@ ecl_make_complex_float(cl_object r, cl_object i)
cl_object ecl_make_csfloat(float _Complex x) {
cl_object c = ecl_alloc_object(t_csfloat);
ecl_csfloat(c) = x;
return c;
}
cl_object ecl_make_cdfloat(double _Complex x) {
cl_object c = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(c) = x;
return c;
}
cl_object ecl_make_clfloat(long double _Complex x) {
cl_object c = ecl_alloc_object(t_clfloat);
ecl_clfloat(c) = x;
return c;
}
#endif
......@@ -843,6 +800,67 @@ ecl_to_long_double(cl_object x)
}
#endif
#ifdef ECL_COMPLEX_FLOAT
float _Complex ecl_to_csfloat(cl_object x) {
switch(ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
case t_ratio:
case t_singlefloat:
case t_doublefloat:
case t_longfloat: {
return ecl_to_float(x);
}
case t_complex: {
return ecl_to_float(x->gencomplex.real) + I * ecl_to_float(x->gencomplex.imag);
}
case t_csfloat: return ecl_csfloat(x);
case t_cdfloat: return ecl_cdfloat(x);
case t_clfloat: return ecl_clfloat(x);
default:
FEwrong_type_nth_arg(@[coerce], 1, x, @[number]);
}
}
double _Complex ecl_to_cdfloat(cl_object x) {
switch(ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
case t_ratio:
case t_singlefloat:
case t_doublefloat:
case t_longfloat:
return ecl_to_double(x);
case t_complex:
return ecl_to_double(x->gencomplex.real) + I * ecl_to_double(x->gencomplex.imag);
case t_csfloat: return ecl_csfloat(x);
case t_cdfloat: return ecl_cdfloat(x);
case t_clfloat: return ecl_clfloat(x);
default:
FEwrong_type_nth_arg(@[coerce], 1, x, @[number]);
}
}
long double _Complex ecl_to_clfloat(cl_object x) {
switch(ecl_t_of(x)) {
case t_fixnum:
case t_bignum:
case t_ratio:
case t_singlefloat:
case t_doublefloat:
case t_longfloat:
return ecl_to_long_double(x);
case t_complex:
return ecl_to_long_double(x->gencomplex.real) + I * ecl_to_long_double(x->gencomplex.imag);
case t_csfloat: return ecl_csfloat(x);
case t_cdfloat: return ecl_cdfloat(x);
case t_clfloat: return ecl_clfloat(x);
default:
FEwrong_type_nth_arg(@[coerce], 1, x, @[number]);
}
}
#endif
cl_object
cl_rational(cl_object x)
{
......
......@@ -134,6 +134,8 @@ write_complex_float(cl_object f, cl_object stream)
real = ecl_make_long_float(creall(ecl_clfloat(f)));
imag = ecl_make_long_float(cimagl(ecl_clfloat(f)));
break;
default:
break;
}
writestr_stream("#<CF(", stream);
si_write_ugly_object(real, stream);
......
......@@ -263,7 +263,24 @@ cl_type_of(cl_object x)
}
break;
}
#ifdef ECL_COMPLEX_FLOAT
case t_complex:
t = cl_list(2, @'complex', @'rational');
break;
case t_csfloat:
t = cl_list(2, @'complex', @'single-float');
break;
case t_cdfloat:
t = cl_list(2, @'complex', @'double-float');
break;
case t_clfloat:
t = cl_list(2, @'complex', @'long-float');
break;
#else
case t_complex:
t = cl_list(2, @'complex', @'real');
break;
#endif
case t_symbol:
if (x == ECL_T)
t = @'boolean';
......
......@@ -214,8 +214,11 @@
(double-float float)
#+long-float (long-float float)
(complex number)
#+complex-float (si:complex-float number)
(symbol)
#+complex-float (si:complex-float complex)
#+complex-float (si:complex-single-float si:complex-float)
#+complex-float (si:complex-double-float si:complex-float)
#+complex-float (si:complex-long-float si:complex-float)
(symbol)
(null symbol list)
(keyword symbol)
(package)
......
......@@ -118,6 +118,26 @@
(cl_object)real, (cl_object)imag }; \
static const cl_object name = (cl_object)(& name ## _data)
#ifdef ECL_COMPLEX_FLOAT
#define ecl_def_ct_csfloat(name,f,static,const) \
static const struct ecl_csfloat name ## _data = { \
(int8_t)t_csfloat, 0, 0, 0, \
(float _Complex)(f) }; \
static const cl_object name = (cl_object)(& name ## _data)
#define ecl_def_ct_cdfloat(name,f,static,const) \
static const struct ecl_cdfloat name ## _data = { \
(int8_t)t_cdfloat, 0, 0, 0, \
(double _Complex)(f) }; \
static const cl_object name = (cl_object)(& name ## _data)
#define ecl_def_ct_clfloat(name,f,static,const) \
static const struct ecl_clfloat name ## _data = { \
(int8_t)t_clfloat, 0, 0, 0, \
(long double _Complex)(f) }; \
static const cl_object name = (cl_object)(& name ## _data)
#endif
#define ecl_def_ct_vector(name,type,raw,len,static,const) \
static const struct ecl_vector name ## _data = { \
(int8_t)t_vector, 0, (type), 0, \
......
......@@ -690,6 +690,10 @@ static union {
# define LDBL_TRUE_MIN LDBL_MIN
#endif
#ifdef ECL_COMPLEX_FLOAT
#include <complex.h>
#endif
#ifdef __cplusplus
}
#endif
......
......@@ -390,6 +390,28 @@ and is not adjustable."
#+ecl-min
(eq (type-of x) 'double-float))
#+complex-float
(defun complex-single-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_csfloat" :one-liner t)
#+ecl-min
(equal (type-of x) '(complex single-float)))
#+complex-float
(defun complex-double-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_cdfloat" :one-liner t)
#+ecl-min
(equal (type-of x) '(complex double-float)))
#+complex-float
(defun complex-long-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_clfloat" :one-liner t)
#+ecl-min
(equal (type-of x) '(complex long-float)))
(eval-when (:execute :load-toplevel :compile-toplevel)
(defconstant +known-typep-predicates+
'((ARRAY . ARRAYP)
......@@ -402,9 +424,9 @@ and is not adjustable."
(CHARACTER . CHARACTERP)
(COMPILED-FUNCTION . COMPILED-FUNCTION-P)
(COMPLEX . COMPLEXP)
#+complex-float(SI:COMPLEX-SINGLE-FLOAT . SI:COMPLEX-FLOAT-P)
#+complex-float(SI:COMPLEX-DOUBLE-FLOAT . SI:COMPLEX-FLOAT-P)
#+complex-float(SI:COMPLEX-LONG-FLOAT . SI:COMPLEX-FLOAT-P)
#+complex-float(SI:COMPLEX-SINGLE-FLOAT . COMPLEX-SINGLE-FLOAT-P)
#+complex-float(SI:COMPLEX-DOUBLE-FLOAT . COMPLEX-DOUBLE-FLOAT-P)
#+complex-float(SI:COMPLEX-LONG-FLOAT . COMPLEX-LONG-FLOAT-P)
(COMPLEX-ARRAY . COMPLEX-ARRAY-P)
(CONS . CONSP)
(DOUBLE-FLOAT . SI:DOUBLE-FLOAT-P)
......@@ -481,9 +503,19 @@ and is not adjustable."
;; (error "~S is not a valid part type for a complex." real-type))
;; (when (subtypep real-type v)
;; (return v))))
(unless (subtypep real-type 'REAL)
(error "~S is not a valid part type for a complex." real-type))
'REAL)
#+complex-float
(cond ((subtypep real-type 'null) nil)
((subtypep real-type 'rational) 'rational)
((subtypep real-type 'single-float) 'single-float)
((subtypep real-type 'double-float) 'double-float)
((subtypep real-type 'long-float) 'long-float)
((subtypep real-type 'float) 'float)
((subtypep real-type 'real) 'real)
(t (error "~S is not a valid part type for a complex." real-type)))
#-complex-float
(cond ((subtypep real-type 'null) nil)
((subtypep real-type 'real) 'real)
(t (error "~S is not a valid part type for a complex." real-type))))
(defun in-interval-p (x interval)
(declare (si::c-local))
......@@ -1185,10 +1217,24 @@ if not possible."
(declare (si::c-local))
;; UPGRADE-COMPLEX-PART-TYPE signals condition when REAL-TYPE is not
;; a subtype of REAL.
(let ((type (if (eq real-type '*)
`(complex real)
`(complex ,(upgraded-complex-part-type real-type)))))
(when (eq real-type '*)
(setq real-type 'real))
(let* ((ucpt (upgraded-complex-part-type real-type))
(type `(complex ,ucpt)))
(or (find-registered-tag type)
#+complex-float
(case ucpt
(real
(logior (canonical-complex-type 'float)
(canonical-complex-type 'rational)))
(float
(logior (canonical-complex-type 'single-float)
(canonical-complex-type 'double-float)
(canonical-complex-type 'long-float)))
(otherwise
(let ((tag (new-type-tag)))
(push-type type tag))))
#-complex-float
(let ((tag (new-type-tag)))
(push-type type tag)))))
......@@ -1252,19 +1298,14 @@ if not possible."
#+long-float LONG-FLOAT))
(REAL (OR RATIONAL FLOAT))
(COMPLEX (COMPLEX REAL))
;; For now we create COMPLEX-FLOAT type being disjoint
;; with the numeric tower. Later we will merge it with
;; complex and arithmetic operations.
#+complex-float(SI:COMPLEX-SINGLE-FLOAT)
#+complex-float(SI:COMPLEX-DOUBLE-FLOAT)
#+complex-float(SI:COMPLEX-LONG-FLOAT)
#+complex-float(SI:COMPLEX-FLOAT (OR SI:COMPLEX-SINGLE-FLOAT
SI:COMPLEX-DOUBLE-FLOAT
SI:COMPLEX-LONG-FLOAT))
#+complex-float(SI:COMPLEX-SINGLE-FLOAT (COMPLEX SINGLE-FLOAT))
#+complex-float(SI:COMPLEX-DOUBLE-FLOAT (COMPLEX DOUBLE-FLOAT))
#+complex-float(SI:COMPLEX-LONG-FLOAT (COMPLEX LONG-FLOAT))
#+complex-float(SI:COMPLEX-FLOAT (COMPLEX FLOAT))
(NUMBER (OR REAL COMPLEX #+complex-float SI:COMPLEX-FLOAT))
(COMPLEX (COMPLEX *))
(NUMBER (OR REAL COMPLEX))
(CHARACTER)
#-unicode
......@@ -1448,7 +1489,9 @@ if not possible."
(RATIO ,@(rest type)))))
(COMPLEX
(or (find-built-in-tag type)
(canonical-complex-type (second type))))
(canonical-complex-type (if (endp (rest type))
'real
(second type)))))
(CONS (apply #'register-cons-type (rest type)))
(ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type)))
(register-array-type `(SIMPLE-ARRAY ,@(rest type)))))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment