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

complex float: add a new types and builtin classes

What has changed:

- new types si:complex-float, si:complex-single-float,
  si:complex-double-float and si:complex-long-float
- new builtin classes long-float (for completness) and
  si:complex-float
- new internal function si:complex-float and si:complex-float-p for
  constructing complex floats (both arguments must be of the same
  float type) and a type predicate
- printer for new types (right now it conses, see below)
- a new feature :complex-float
- a new type is recognized as a type disjoint of complex and real

- cleanup: +built-in-type-list+: remove some redundancy
  For instance instread of saying
    (real (or integer single-float double-float ratio))
  We say
    (real (or integer float ratio))
  etc.

Flaws which will be fixed in upcoming commits:

- complex-float hierarchy is independent of the complex hierarchy
- ecl_make_complex_float could be replaced by _ecl_make_complex_*float
- write_complex_float allocates new objects for printing
- write_complex_float does print unreadable object
- math dispatchers doesn't recognize the object

Testing things out:

> (si:complex-float 0.0d0 0.0d0)
; #<CF(0.0d0 0.0d0)>
> (si:complex-float 0.0d0 0.0s0)       ; signals type error
> (+ (si:complex-float 0.0d0 0.0d0) 1) ; signals type error

lisp runtime: make si_complex-float a subtype of a number.
parent 20a70302
......@@ -337,7 +337,13 @@ 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,
#endif
ECL_BUILTIN_SYMBOL,
ECL_BUILTIN_NULL,
ECL_BUILTIN_KEYWORD,
......@@ -386,11 +392,16 @@ 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:
case t_cdfloat:
case t_clfloat:
index = ECL_BUILTIN_COMPLEX_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
......
......@@ -13,6 +13,7 @@
*/
#include <float.h>
#include <complex.h>
#include <limits.h>
#include <signal.h>
#define ECL_INCLUDE_MATH_H
......@@ -623,6 +624,65 @@ ecl_make_complex(cl_object r, cl_object i)
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;
switch (tr) {
case t_singlefloat:
if (ti != tr) { ecl_type_error(@'si::complex-float',"imag part", i, @'single-float'); }
result = ecl_alloc_object(t_csfloat);
ecl_csfloat(result) = ecl_single_float(r) + ecl_single_float(i) * I;
break;
case t_doublefloat:
if (ti != tr) { ecl_type_error(@'si::complex-float',"imag part", i, @'double-float'); }
result = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(result) = ecl_double_float(r) + ecl_double_float(i) * I;
break;
case t_longfloat:
if (ti != tr) { ecl_type_error(@'si::complex-float',"imag part", i, @'long-float'); }
result = ecl_alloc_object(t_clfloat);
ecl_clfloat(result) = ecl_long_float(r) + ecl_long_float(i) * I;
break;
default:
ecl_type_error(@'si::complex-float',"real part", r, @'float');
}
return result;
}
cl_object ecl_make_csfloat(float _Complex x) {
cl_object c = ecl_alloc_object(t_csfloat);
ecl_csfloat(c) = x;
}
cl_object ecl_make_cdfloat(double _Complex x) {
cl_object c = ecl_alloc_object(t_cdfloat);
ecl_cdfloat(c) = x;
}
cl_object ecl_make_clfloat(long double _Complex x) {
cl_object c = ecl_alloc_object(t_clfloat);
ecl_clfloat(c) = x;
}
#endif
static cl_object
mantissa_and_exponent_from_ratio(cl_object num, cl_object den, int digits, cl_fixnum *exponent)
{
......
......@@ -116,6 +116,33 @@ write_float(cl_object f, cl_object stream)
si_put_buffer_string(s);
}
#ifdef ECL_COMPLEX_FLOAT
static void /* XXX: do not cons new floats here! */
write_complex_float(cl_object f, cl_object stream)
{
cl_object real, imag;
switch (ecl_t_of(f)) {
case t_csfloat:
real = ecl_make_single_float(crealf(ecl_csfloat(f)));
imag = ecl_make_single_float(cimagf(ecl_csfloat(f)));
break;
case t_cdfloat:
real = ecl_make_double_float(creal(ecl_cdfloat(f)));
imag = ecl_make_double_float(cimag(ecl_cdfloat(f)));
break;
case t_clfloat:
real = ecl_make_long_float(creall(ecl_clfloat(f)));
imag = ecl_make_long_float(cimagl(ecl_clfloat(f)));
break;
}
writestr_stream("#<CF(", stream);
si_write_ugly_object(real, stream);
ecl_write_char(' ', stream);
si_write_ugly_object(imag, stream);
writestr_stream(")>", stream);
}
#endif
static void
write_character(cl_object x, cl_object stream)
{
......@@ -414,9 +441,9 @@ static printer dispatch[FREE+1] = {
#endif
write_complex, /* t_complex */
#ifdef ECL_COMPLEX_FLOAT
write_illegal, /* t_csfloat */
write_illegal, /* t_cdfloat */
write_illegal, /* t_clfloat */
write_complex_float, /* t_csfloat */
write_complex_float, /* t_cdfloat */
write_complex_float, /* t_clfloat */
#endif
_ecl_write_symbol, /* t_symbol */
write_package, /* t_package */
......
......@@ -71,6 +71,11 @@ typedef struct {
#else
# define IF_DFFI(x) NULL
#endif
#ifdef ECL_COMPLEX_FLOAT
# define IF_COMPLEX_FLOAT(x) x
#else
# define IF_COMPLEX_FLOAT(x) NULL
#endif
cl_symbol_initializer
cl_symbols[] = {
......@@ -2079,6 +2084,14 @@ cl_symbols[] = {
{EXT_ "ARRAY-ELEMENT-TYPE-BYTE-SIZE", EXT_ORDINARY, si_array_element_type_byte_size, 1, OBJNULL},
/* #ifdef ECL_COMPLEX_FLOAT */
{SYS_ "COMPLEX-FLOAT-P", SI_ORDINARY, IF_COMPLEX_FLOAT(si_complex_float_p), 1, OBJNULL},
{SYS_ "COMPLEX-FLOAT", SI_ORDINARY, IF_COMPLEX_FLOAT(ecl_make_complex_float), 2, OBJNULL},
{SYS_ "COMPLEX-SINGLE-FLOAT", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "COMPLEX-DOUBLE-FLOAT", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "COMPLEX-LONG-FLOAT", SI_ORDINARY, NULL, -1, OBJNULL},
/* #endif */
/* #ifdef ECL_SSE2 */
{EXT_ "SSE-PACK", EXT_ORDINARY, NULL, -1, OBJNULL},
{EXT_ "SSE-PACK-P", EXT_ORDINARY, IF_SSE2(si_sse_pack_p), 1, OBJNULL},
......
......@@ -71,6 +71,11 @@ typedef struct {
#else
# define IF_DFFI(x) NULL
#endif
#ifdef ECL_COMPLEX_FLOAT
# define IF_COMPLEX_FLOAT(x) x
#else
# define IF_COMPLEX_FLOAT(x) NULL
#endif
cl_symbol_initializer
cl_symbols[] = {
......@@ -2079,6 +2084,14 @@ cl_symbols[] = {
{EXT_ "ARRAY-ELEMENT-TYPE-BYTE-SIZE","si_array_element_type_byte_size"},
/* #ifdef ECL_COMPLEX_FLOAT */
{SYS_ "COMPLEX-FLOAT-P","IF_COMPLEX_FLOAT(si_complex_float_p)"},
{SYS_ "COMPLEX-FLOAT","IF_COMPLEX_FLOAT(ecl_make_complex_float)"},
{SYS_ "COMPLEX-SINGLE-FLOAT",NULL},
{SYS_ "COMPLEX-DOUBLE-FLOAT",NULL},
{SYS_ "COMPLEX-LONG-FLOAT",NULL},
/* #endif */
/* #ifdef ECL_SSE2 */
{EXT_ "SSE-PACK",NULL},
{EXT_ "SSE-PACK-P",IF_SSE2("si_sse_pack_p")},
......
......@@ -119,6 +119,14 @@ ecl_type_to_symbol(cl_type t)
#endif
case t_complex:
return @'complex';
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat:
return @'si::complex-single-float';
case t_cdfloat:
return @'si::complex-double-float';
case t_clfloat:
return @'si::complex-long-float';
#endif
case t_symbol:
return @'symbol';
case t_package:
......
......@@ -212,7 +212,9 @@
(float real)
(single-float float)
(double-float float)
(complex number)
#+long-float (long-float float)
(complex number)
#+complex-float (si:complex-float number)
(symbol)
(null symbol list)
(keyword symbol)
......
......@@ -601,6 +601,8 @@
(proclamation si:single-float-p (t) gen-bool :pure)
(proclamation si:double-float-p (t) gen-bool :pure)
(proclamation si:long-float-p (t) gen-bool :pure)
#+complex-float (proclamation si:complex-float (float float) si:complex-float :pure)
#+complex-float (proclamation si:complex-float-p (t) gen-bool :pure)
;; Virtual functions added by the compiler
(proclamation shift>> (*) nil :pure)
......
......@@ -1137,6 +1137,14 @@ extern ECL_API double ecl_to_double(cl_object x);
extern ECL_API long double ecl_to_long_double(cl_object x);
extern ECL_API cl_object ecl_make_long_float(long double f);
#endif
#ifdef ECL_COMPLEX_FLOAT
extern ECL_API cl_object ecl_make_csfloat(float _Complex x);
extern ECL_API cl_object ecl_make_cdfloat(double _Complex x);
extern ECL_API cl_object ecl_make_clfloat(long double _Complex x);
extern ECL_API float _Complex ecl_to_csfloat(cl_object x);
extern ECL_API double _Complex ecl_to_cdfloat(cl_object x);
extern ECL_API long double _Complex ecl_to_clfloat(cl_object x);
#endif
#ifdef ECL_IEEE_FP
extern ECL_API cl_object si_nan();
#endif /* ECL_IEEE_FP */
......
......@@ -341,6 +341,10 @@ extern cl_object _ecl_float_to_integer(float d);
#ifdef ECL_LONG_FLOAT
extern cl_object _ecl_long_double_to_integer(long double d);
#endif
#ifdef ECL_COMPLEX_FLOAT
extern cl_object si_complex_float_p(cl_object o);
extern cl_object ecl_make_complex_float(cl_object r, cl_object i);
#endif
/* main.d */
......
......@@ -57,6 +57,9 @@ typedef enum {
t_csfloat,
t_cdfloat,
t_clfloat,
t_last_number = t_clfloat,
#else
t_last_number = t_complex,
#endif
t_symbol,
t_package,
......@@ -157,7 +160,7 @@ typedef cl_object (*cl_objectfn_fixed)();
#define ECL_CHAR_CODE_NEWLINE 10
#define ECL_CHAR_CODE_LINEFEED 10
#define ECL_NUMBER_TYPE_P(t) (t >= t_fixnum && t <= t_complex)
#define ECL_NUMBER_TYPE_P(t) (t >= t_fixnum && t <= t_last_number)
#define ECL_REAL_TYPE_P(t) (t >= t_fixnum && t < t_complex)
#define ECL_ARRAYP(x) ((ECL_IMMEDIATE(x) == 0) && (x)->d.t >= t_array && (x)->d.t <= t_bitvector)
#define ECL_VECTORP(x) ((ECL_IMMEDIATE(x) == 0) && (x)->d.t >= t_vector && (x)->d.t <= t_bitvector)
......@@ -173,7 +176,11 @@ typedef cl_object (*cl_objectfn_fixed)();
#define ECL_BASE_STRING_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_base_string))
#define ECL_HASH_TABLE_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_hashtable))
#define ECL_BIGNUMP(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_bignum))
#ifdef ECL_COMPLEX_FLOAT
#define ECL_COMPLEXP(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t >= t_complex) && ((x)->d.t <= t_clfloat))
#else
#define ECL_COMPLEXP(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_complex))
#endif
#define ECL_RANDOM_STATE_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_random))
#define ECL_SINGLE_FLOAT_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_singlefloat))
#define ECL_DOUBLE_FLOAT_P(x) ((ECL_IMMEDIATE(x) == 0) && ((x)->d.t == t_doublefloat))
......
......@@ -402,6 +402,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-ARRAY . COMPLEX-ARRAY-P)
(CONS . CONSP)
(DOUBLE-FLOAT . SI:DOUBLE-FLOAT-P)
......@@ -1234,30 +1237,34 @@ if not possible."
(INTEGER (INTEGER * *))
(FIXNUM (INTEGER #.most-negative-fixnum #.most-positive-fixnum))
(BIGNUM (OR (INTEGER * (#.most-negative-fixnum)) (INTEGER (#.most-positive-fixnum) *)))
#+short-float
(SHORT-FLOAT (SHORT-FLOAT * *))
(BIGNUM (OR (INTEGER * (#.most-negative-fixnum))
(INTEGER (#.most-positive-fixnum) *)))
#+short-float (SHORT-FLOAT (SHORT-FLOAT * *))
(SINGLE-FLOAT (SINGLE-FLOAT * *))
(DOUBLE-FLOAT (DOUBLE-FLOAT * *))
#+long-float
(LONG-FLOAT (LONG-FLOAT * *))
#+long-float (LONG-FLOAT (LONG-FLOAT * *))
(RATIO (RATIO * *))
(RATIONAL (OR INTEGER RATIO))
(FLOAT (OR
#+short-float SHORT-FLOAT
SINGLE-FLOAT
DOUBLE-FLOAT
#+long-float LONG-FLOAT))
(REAL (OR INTEGER
#+short-float SHORT-FLOAT
SINGLE-FLOAT
DOUBLE-FLOAT
#+long-float LONG-FLOAT
RATIO))
(FLOAT (OR #+short-float SHORT-FLOAT
SINGLE-FLOAT
DOUBLE-FLOAT
#+long-float LONG-FLOAT))
(REAL (OR RATIONAL FLOAT))
(COMPLEX (COMPLEX REAL))
(NUMBER (OR REAL COMPLEX))
;; 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))
(NUMBER (OR REAL COMPLEX #+complex-float SI:COMPLEX-FLOAT))
(CHARACTER)
#-unicode
......
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