Commit a8ba6f5c authored by jgarcia's avatar jgarcia
Browse files

Initital support for long double and immediate short floats.

parent 433c8fe3
......@@ -27,6 +27,10 @@ ECL 1.0:
- MAPCAR, MAPLIST, MAPC, MAPL, MAPCAN, MAPCON have now compiler macro functions
which create equivalent inlined forms.
- Support for C "long double" as lisp long-double datatype (originated from
a patch by Lars Brinkhoff). Still missing compiler support for unboxed
long double types.
* Bugs fixed:
- STREAMP signals an error for Gray streams.
......
......@@ -570,4 +570,4 @@ case "${host_cpu}" in
;;
esac
AC_SUBST(ECL_FPE_CODE)
])
\ No newline at end of file
])
......@@ -220,6 +220,10 @@ cl_alloc_object(cl_type t)
return MAKE_FIXNUM(0); /* Immediate fixnum */
case t_character:
return CODE_CHAR('\0'); /* Immediate character */
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
return make_shortfloat(0.0); /* Immediate float */
#endif
default:;
}
......@@ -261,6 +265,9 @@ ONCE_MORE:
break;
case t_singlefloat:
case t_doublefloat:
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
break;
case t_complex:
obj->complex.imag = OBJNULL;
......@@ -722,6 +729,9 @@ init_alloc(void)
init_tm(t_process, "tPROCESS", sizeof(struct ecl_process), 2);
init_tm(t_lock, "tLOCK", sizeof(struct ecl_lock), 2);
#endif /* THREADS */
#ifdef ECL_LONG_FLOAT
init_tm(t_longfloat, "tLONGFLOAT", sizeof(struct ecl_long_float), 2);
#endif
ncb = 0;
ncbpage = 0;
......
......@@ -59,6 +59,12 @@ cl_alloc_object(cl_type t)
obj->cblock.data_size = 0;
obj->cblock.handle = NULL;
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
#endif
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
case t_singlefloat:
case t_doublefloat:
obj = (cl_object)GC_MALLOC_ATOMIC(type_size[t]);
......@@ -204,6 +210,9 @@ init_alloc(void)
init_tm(t_process, "PROCESS", sizeof(struct ecl_process));
init_tm(t_lock, "LOCK", sizeof(struct ecl_lock));
#endif
#ifdef ECL_LONG_FLOAT
init_tm(t_longfloat, "LONG-FLOAT", sizeof(struct ecl_long_float));
#endif
old_GC_push_other_roots = GC_push_other_roots;
GC_push_other_roots = stacks_scanner;
......
......@@ -559,7 +559,7 @@ array_address(cl_object x, cl_index inc)
case aet_index:
return x->array.self.fix + inc;
case aet_sf:
return x->array.self.t + inc;
return x->array.self.sf + inc;
case aet_bc:
return x->base_string.self + inc;
case aet_df:
......
......@@ -77,10 +77,18 @@ object_to_fixnum(cl_object x)
/* case t_character: return (cl_fixnum)CHAR_CODE(x); */
case t_ratio:
return (cl_fixnum)number_to_double(x);
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
return (cl_fixnum)ecl_short_float(x);
#endif
case t_singlefloat:
return (cl_fixnum)sf(x);
case t_doublefloat:
return (cl_fixnum)df(x);
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return (cl_fixnum)ecl_long_float(x);
#endif
default:
FEerror("~S cannot be coerced to a C int.", 1, x);
}
......@@ -95,10 +103,18 @@ object_to_unsigned_integer(cl_object x)
return fixnnint(x);
case t_ratio:
return (cl_index)number_to_double(x);
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
return (cl_index)ecl_short_float(x);
#endif
case t_singlefloat:
return (cl_index)sf(x);
case t_doublefloat:
return (cl_index)df(x);
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return (cl_index)ecl_long_float(x);
#endif
default:
FEerror("~S cannot be coerced to a C unsigned int.", 1, x);
}
......@@ -115,10 +131,18 @@ object_to_float(cl_object x)
case t_bignum:
case t_ratio:
return number_to_double(x);
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
return ecl_short_float(x);
#endif
case t_singlefloat:
return sf(x);
case t_doublefloat:
return df(x);
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_long_float(x);
#endif
default:
FEtype_error_real(x);
}
......@@ -136,10 +160,18 @@ object_to_double(cl_object x)
case t_bignum:
case t_ratio:
return number_to_double(x);
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
return ecl_short_float(x);
#endif
case t_singlefloat:
return sf(x);
case t_doublefloat:
return df(x);
#ifdef ECL_LONG_FLOAT
case t_longfloat:
return ecl_long_float(x);
#endif
default:
FEtype_error_real(x);
}
......
......@@ -1041,14 +1041,35 @@ fmt_exponential_float(format_stack fmt, bool colon, bool atsign)
writestr_stream(b, fmt->stream);
y = symbol_value(@'*read-default-float-format*');
if (exponentchar < 0) {
if (y == @'long-float' || y == @'double-float')
if (y == @'long-float') {
#ifdef ECL_LONG_FLOAT
t = t_longfloat;
#else
t = t_doublefloat;
else
#endif
} else if (y == @'double-float') {
t = t_doublefloat;
} else if (y == @'single-float') {
t = t_singlefloat;
} else {
#ifdef ECL_SHORT_FLOAT
t = t_shortfloat;
#else
t = t_singlefloat;
#endif
}
if (type_of(x) == t)
exponentchar = 'E';
else if (type_of(x) == t_singlefloat)
exponentchar = 'F';
#ifdef ECL_SHORT_FLOAT
else if (type_of(x) == t_shortfloat)
exponentchar = 'S';
#endif
#ifdef ECL_LONG_FLOAT
else if (type_of(x) == t_longfloat)
exponentchar = 'L';
#endif
else
exponentchar = 'D';
}
......
......@@ -146,8 +146,14 @@ BEGIN:
mark_next(x->ratio.den);
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
#endif
case t_singlefloat:
case t_doublefloat:
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
break;
case t_complex:
......
......@@ -129,10 +129,22 @@ _hash_eql(cl_hashkey h, cl_object x)
case t_ratio:
h = _hash_eql(h, x->ratio.num);
return _hash_eql(h, x->ratio.den);
#ifdef ECL_SHORT_FLOAT
case t_shortfloat: {
float f = ecl_short_float(x);
return hash_string(h, (unsigned char*)&f, sizeof(f));
}
#endif
case t_singlefloat:
return hash_string(h, (unsigned char*)&sf(x), sizeof(sf(x)));
case t_doublefloat:
return hash_string(h, (unsigned char*)&df(x), sizeof(df(x)));
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double d = ecl_long_float(x);
return hash_string(h, (unsigned char*)&d, sizeof(d));
}
#endif
case t_complex:
h = _hash_eql(h, x->complex.real);
return _hash_eql(h, x->complex.imag);
......@@ -207,6 +219,16 @@ SCAN: if (depth++ >= 3) {
return h;
case t_fixnum:
return hash_word(h, fix(x));
#ifdef HAVE_SHORT_FLOAT
case t_shortfloat: {
/* FIXME! We should be more precise here! */
return hash_word(h, (cl_index)sf(x));
union { float f; cl_index w; } x;
x.w = 0;
x.f = ecl_short_float(x);
return hash_word(h, x.w);
}
#endif
case t_singlefloat:
/* FIXME! We should be more precise here! */
return hash_word(h, (cl_index)sf(x));
......@@ -373,19 +395,24 @@ ecl_extend_hashtable(cl_object hashtable)
{
cl_object old, key;
cl_index old_size, new_size, i;
cl_object new_size_obj;
assert_type_hash_table(hashtable);
old_size = hashtable->hash.size;
if (FIXNUMP(hashtable->hash.rehash_size))
new_size = old_size + fix(hashtable->hash.rehash_size);
else if (type_of(hashtable->hash.rehash_size) == t_singlefloat)
new_size = (cl_index)(old_size * sf(hashtable->hash.rehash_size));
else if (type_of(hashtable->hash.rehash_size) == t_doublefloat)
new_size = (cl_index)(old_size * df(hashtable->hash.rehash_size));
else
corrupted_hash(hashtable);
if (new_size <= old_size)
new_size = old_size + 1;
/* We do the computation with lisp datatypes, just in case the sizes contain
* weird numbers */
if (FIXNUMP(hashtable->hash.rehash_size)) {
new_size_obj = number_plus(hashtable->hash.rehash_size, MAKE_FIXNUM(old_size));
} else {
new_size_obj = number_times(hashtable->hash.rehash_size, MAKE_FIXNUM(old_size));
new_size_obj = ceiling1(new_size_obj);
}
if (!FIXNUMP(new_size_obj)) {
/* New size is too large */
new_size = old_size * 2;
} else {
new_size = fix(new_size_obj);
}
old = cl_alloc_object(t_hashtable);
old->hash = hashtable->hash;
hashtable->hash.data = NULL; /* for GC sake */
......@@ -446,26 +473,28 @@ cl__make_hash_table(cl_object test, cl_object size, cl_object rehash_size,
hsize = 16;
t = type_of(rehash_size);
if ((t != t_fixnum && t != t_singlefloat && t != t_doublefloat) ||
(number_compare(rehash_size, MAKE_FIXNUM(1)) < 0)) {
if (t != t_fixnum) {
rehash_size = make_doublefloat(number_to_double(rehash_size));
t = t_doublefloat;
}
if ((number_compare(rehash_size, MAKE_FIXNUM(1)) < 0)) {
FEerror("~S is an illegal hash-table rehash-size.",
1, rehash_size);
}
factor = -1.0;
t = type_of(rehash_threshold);
if (t == t_fixnum || t == t_ratio || t == t_singlefloat || t == t_doublefloat) {
factor = number_to_double(rehash_threshold);
}
if (factor < 0.0 || factor > 1.0) {
if (!numberp(rehash_threshold) || number_minusp(rehash_threshold) ||
number_compare(rehash_threshold, MAKE_FIXNUM(1)) > 0)
{
FEerror("~S is an illegal hash-table rehash-threshold.",
1, rehash_threshold);
}
rehash_threshold = cl_max(2, rehash_threshold, make_singlefloat(0.1));
h = cl_alloc_object(t_hashtable);
h->hash.test = htt;
h->hash.size = hsize;
h->hash.rehash_size = rehash_size;
h->hash.threshold = rehash_threshold;
h->hash.factor = factor;
h->hash.factor = number_to_double(rehash_threshold);
h->hash.entries = 0;
h->hash.data = NULL; /* for GC sake */
h->hash.data = (struct ecl_hashtable_entry *)
......
......@@ -208,8 +208,14 @@ cl_class_of(cl_object x)
t = @'integer'; break;
case t_ratio:
t = @'ratio'; break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
#endif
case t_singlefloat:
case t_doublefloat:
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
t = @'float'; break;
/* XXX t = @'long-float'; break; */
case t_complex:
......
......@@ -462,6 +462,12 @@ cl_boot(int argc, char **argv)
#endif
#ifdef ECL_UNICODE
ADD_FEATURE("UNICODE");
#endif
#ifdef ECL_LONG_FLOAT
ADD_FEATURE("LONG-FLOAT");
#endif
#ifdef ECL_SHORT_FLOAT
ADD_FEATURE("SHORT-FLOAT");
#endif
/* This is assumed in all systems */
ADD_FEATURE("IEEE-FLOATING-POINT");
......
This diff is collapsed.
......@@ -89,36 +89,48 @@ number_remainder(cl_object x, cl_object y, cl_object q)
otherwise coerce to same float type as second arg */
@(defun float (x &optional (y OBJNULL))
cl_type t = t_singlefloat;
cl_type t, tx;
double d;
/* TODO: LONG_FLOAT SHORT_FLOAT */
@
if (y != OBJNULL) {
t = type_of(y);
if (t != t_singlefloat && t != t_doublefloat)
FEtype_error_float(y);
}
switch (type_of(x)) {
case t_fixnum:
if (t == t_singlefloat)
x = make_singlefloat(fix(x));
else
x = make_doublefloat(fix(x));
break;
case t_bignum:
case t_ratio: {
double d = number_to_double(x);
if (t == t_singlefloat)
x = make_singlefloat(d);
else
x = make_doublefloat(d);
break;
} else {
t = t_singlefloat;
}
switch (tx = type_of(x)) {
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
#endif
case t_singlefloat:
if (y && t == t_doublefloat)
x = make_doublefloat(sf(x));
break;
case t_doublefloat:
if (y && t == t_singlefloat)
x = make_singlefloat(df(x));
#ifdef ECL_LONG_FLOAT
case t_longfloat:
#endif
if (y == OBJNULL || t == tx)
break;
case t_fixnum:
case t_bignum:
case t_ratio:
switch (t) {
#ifdef ECL_SHORT_FLOAT
case t_shortfloat:
x = make_shortfloat(number_to_double(x)); break;
#endif
case t_singlefloat:
x = make_singlefloat(number_to_double(x)); break;
case t_doublefloat:
x = make_doublefloat(number_to_double(x)); break;
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
/* FIXME! We lose precision! */
volatile double y = number_to_double(x);
x = make_longfloat(y); break;
}
#endif
default:
FEtype_error_float(y);
}
break;
default:
FEtype_error_real(x);
......@@ -177,6 +189,15 @@ floor1(cl_object x)
VALUES(0) = floor2(x->ratio.num, x->ratio.den);
VALUES(1) = make_ratio(VALUES(1), x->ratio.den);
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat: {
float d = ecl_short_float(x);
float y = floorf(d);
VALUES(0) = float_to_integer(y);
VALUES(1) = make_shortfloat(d - y);
break;
}
#endif
case t_singlefloat: {
float d = sf(x);
float y = floorf(d);
......@@ -191,6 +212,15 @@ floor1(cl_object x)
VALUES(1) = make_doublefloat(d - y);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double d = ecl_long_float(x);
long double y = floorl(d);
VALUES(0) = double_to_integer(y);
VALUES(1) = make_longfloat(d - y);
break;
}
#endif
default:
FEtype_error_real(x);
}
......@@ -240,6 +270,16 @@ floor2(cl_object x, cl_object y)
floor2(number_times(x, y->ratio.den), y->ratio.num);
VALUES(1) = make_ratio(VALUES(1), y->ratio.den);
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat: { /* FIX / SF */
float n = ecl_short_float(y);
float p = fix(x) / n;
float q = floorf(p);
VALUES(0) = float_to_integer(q);
VALUES(1) = make_shortfloat((p - q)*n);
break;
}
#endif
case t_singlefloat: { /* FIX / SF */
float n = sf(y);
float p = fix(x) / n;
......@@ -256,6 +296,16 @@ floor2(cl_object x, cl_object y)
VALUES(1) = make_doublefloat((p - q)*n);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: { /* FIX / SF */
long double n = ecl_long_float(y);
long double p = fix(x) / n;
long double q = floorl(p);
VALUES(0) = float_to_integer(q);
VALUES(1) = make_longfloat((p - q)*n);
break;
}
#endif
default:
FEtype_error_real(y);
}
......@@ -294,6 +344,16 @@ floor2(cl_object x, cl_object y)
floor2(number_times(x, y->ratio.den), y->ratio.num);
VALUES(1) = make_ratio(VALUES(1), y->ratio.den);
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat: { /* BIG / SF */
float n = ecl_short_float(y);
float p = big_to_double(x) / n;
float q = floorf(p);
VALUES(0) = float_to_integer(q);
VALUES(1) = make_shortfloat((p - q)*n);
break;
}
#endif
case t_singlefloat: { /* BIG / SF */
float n = sf(y);
float p = big_to_double(x) / n;
......@@ -310,6 +370,16 @@ floor2(cl_object x, cl_object y)
VALUES(1) = make_doublefloat((p - q)*n);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: { /* BIG / DF */
long double n = ecl_long_float(y);
long double p = big_to_double(x) / n;
long double q = floorl(p);
VALUES(0) = double_to_integer(q);
VALUES(1) = make_longfloat((p - q)*n);
break;
}
#endif
default:
FEtype_error_real(y);
}
......@@ -326,6 +396,16 @@ floor2(cl_object x, cl_object y)
VALUES(1) = number_divide(VALUES(1), x->ratio.den);
}
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat: { /* SF / ANY */
float n = number_to_double(y);
float p = sf(x)/n;
float q = floorf(p);
VALUES(0) = float_to_integer(q);
VALUES(1) = make_shortfloat((p - q)*n);
break;
}
#endif
case t_singlefloat: { /* SF / ANY */
float n = number_to_double(y);
float p = sf(x)/n;
......@@ -342,13 +422,23 @@ floor2(cl_object x, cl_object y)
VALUES(1) = make_doublefloat((p - q)*n);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: { /* LF / ANY */
float n = number_to_double(y);
float p = sf(x)/n;
float q = floorl(p);
VALUES(0) = float_to_integer(q);
VALUES(1) = make_longfloat((p - q)*n);
break;
}
#endif
default:
FEtype_error_real(x);
}
NVALUES = 2;
return VALUES(0);
}
@(defun floor (x &optional (y OBJNULL))
@
if (narg == 1)
......@@ -371,6 +461,15 @@ ceiling1(cl_object x)
VALUES(0) = ceiling2(x->ratio.num, x->ratio.den);
VALUES(1) = make_ratio(VALUES(1), x->ratio.den);
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat: {
float d = ecl_short_float(x);
float y = ceilf(d);
VALUES(0) = float_to_integer(y);
VALUES(1) = make_shortfloat(d - y);
break;
}
#endif
case t_singlefloat: {
float d = sf(x);
float y = ceilf(d);
......@@ -385,6 +484,15 @@ ceiling1(cl_object x)
VALUES(1) = make_doublefloat(d - y);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: {
long double d = ecl_long_float(x);
long double y = ceill(d);
VALUES(0) = double_to_integer(y);
VALUES(1) = make_longfloat(d - y);
break;
}
#endif
default:
FEtype_error_real(x);
}
......@@ -434,6 +542,16 @@ ceiling2(cl_object x, cl_object y)
ceiling2(number_times(x, y->ratio.den), y->ratio.num);
VALUES(1) = make_ratio(VALUES(1), y->ratio.den);
break;
#ifdef ECL_SHORT_FLOAT
case t_shortfloat: { /* FIX / SF */
float n = ecl_short_float(y);
float p = fix(x)/n;
float q = ceilf(p);
VALUES(0) = float_to_integer(q);
VALUES(1) = make_singlefloat((p - q)*n);
break;
}
#endif
case t_singlefloat: { /* FIX / SF */
float n = sf(y);
float p = fix(x)/n;
......@@ -450,6 +568,16 @@ ceiling2(cl_object x, cl_object y)
VALUES(1) = make_doublefloat((p - q)*n);
break;
}
#ifdef ECL_LONG_FLOAT
case t_longfloat: { /* FIX / DF */
long double n = ecl_long_float(y);
long double p = fix(x)/n;
long double q = ceill(p);
VALUES(0) = double_to_integer(q);
VALUES(1) = make_longfloat((p - q)*n);
break;