mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-28 07:22:27 -08:00
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
This commit is contained in:
Daniel Kochmański
parent
fdc40520a2
commit
e1adfd2794
8 changed files with 219 additions and 107 deletions
|
|
@ -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;
|
||||
|
|
|
|||
182
src/c/number.d
182
src/c/number.d
|
|
@ -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)) {
|
||||
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;
|
||||
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;
|
||||
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
|
||||
case t_longfloat:
|
||||
if (ti != t_longfloat)
|
||||
i = ecl_make_long_float((long double)ecl_to_double(i));
|
||||
break;
|
||||
#endif
|
||||
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)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue