From e1adfd2794016a8ac1934cf816fc136ac932f095 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Wed, 3 Apr 2019 16:33:45 +0200 Subject: [PATCH] numeric tower: merge with cl_type_of: give better results for (type-of ) 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 --- src/c/clos/instance.d | 7 +- src/c/number.d | 182 ++++++++++++++++++++----------------- src/c/printer/write_ugly.d | 2 + src/c/typespec.d | 19 +++- src/clos/hierarchy.lsp | 7 +- src/h/ecl-inl.h | 20 ++++ src/h/internal.h | 4 + src/lsp/predlib.lsp | 85 ++++++++++++----- 8 files changed, 219 insertions(+), 107 deletions(-) diff --git a/src/c/clos/instance.d b/src/c/clos/instance.d index 93eb96d5a..4da5c0356 100644 --- a/src/c/clos/instance.d +++ b/src/c/clos/instance.d @@ -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; diff --git a/src/c/number.d b/src/c/number.d index 2145dc571..665a2ab2e 100644 --- a/src/c/number.d +++ b/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) { diff --git a/src/c/printer/write_ugly.d b/src/c/printer/write_ugly.d index 5ad76445b..d117920d1 100644 --- a/src/c/printer/write_ugly.d +++ b/src/c/printer/write_ugly.d @@ -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("# +#endif + #ifdef __cplusplus } #endif diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index e67e7ffcd..abd6df389 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -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)))))